From fa22d01c7fc7fb26573cf3bac70162c2b51a4196 Mon Sep 17 00:00:00 2001 From: Thomas Refis Date: Fri, 4 Mar 2022 15:42:30 +0100 Subject: [PATCH 001/130] upstream: remove 4.13 directory --- upstream/ocaml_413/base-rev.txt | 1 - upstream/ocaml_413/file_formats/cmi_format.ml | 118 - .../ocaml_413/file_formats/cmi_format.mli | 51 - .../ocaml_413/file_formats/cmo_format.mli | 68 - upstream/ocaml_413/file_formats/cmt_format.ml | 194 - .../ocaml_413/file_formats/cmt_format.mli | 123 - .../ocaml_413/file_formats/cmx_format.mli | 58 - .../ocaml_413/file_formats/cmxs_format.mli | 35 - .../ocaml_413/file_formats/linear_format.ml | 101 - .../ocaml_413/file_formats/linear_format.mli | 38 - upstream/ocaml_413/parsing/CONFLICTS.md | 54 - upstream/ocaml_413/parsing/HACKING.adoc | 76 - upstream/ocaml_413/parsing/VIPs.md | 20 - upstream/ocaml_413/parsing/ast_helper.ml | 643 -- upstream/ocaml_413/parsing/ast_helper.mli | 493 -- upstream/ocaml_413/parsing/ast_invariants.ml | 191 - upstream/ocaml_413/parsing/ast_invariants.mli | 23 - upstream/ocaml_413/parsing/ast_iterator.ml | 682 -- upstream/ocaml_413/parsing/ast_iterator.mli | 83 - upstream/ocaml_413/parsing/ast_mapper.ml | 1078 --- upstream/ocaml_413/parsing/ast_mapper.mli | 208 - upstream/ocaml_413/parsing/asttypes.mli | 67 - upstream/ocaml_413/parsing/attr_helper.ml | 54 - upstream/ocaml_413/parsing/attr_helper.mli | 41 - .../ocaml_413/parsing/builtin_attributes.ml | 289 - .../ocaml_413/parsing/builtin_attributes.mli | 84 - upstream/ocaml_413/parsing/depend.ml | 594 -- upstream/ocaml_413/parsing/depend.mli | 45 - upstream/ocaml_413/parsing/docstrings.ml | 425 -- upstream/ocaml_413/parsing/docstrings.mli | 223 - upstream/ocaml_413/parsing/lexer.mli | 65 - upstream/ocaml_413/parsing/lexer.mll | 871 --- upstream/ocaml_413/parsing/location.ml | 949 --- upstream/ocaml_413/parsing/location.mli | 287 - upstream/ocaml_413/parsing/longident.ml | 50 - upstream/ocaml_413/parsing/longident.mli | 58 - upstream/ocaml_413/parsing/parse.ml | 147 - upstream/ocaml_413/parsing/parse.mli | 108 - upstream/ocaml_413/parsing/parser.mly | 3867 ----------- upstream/ocaml_413/parsing/parsetree.mli | 978 --- upstream/ocaml_413/parsing/pprintast.ml | 1700 ----- upstream/ocaml_413/parsing/pprintast.mli | 46 - upstream/ocaml_413/parsing/printast.ml | 981 --- upstream/ocaml_413/parsing/printast.mli | 32 - upstream/ocaml_413/parsing/syntaxerr.ml | 43 - upstream/ocaml_413/parsing/syntaxerr.mli | 37 - upstream/ocaml_413/typing/HACKING.adoc | 58 - upstream/ocaml_413/typing/TODO.md | 101 - upstream/ocaml_413/typing/annot.mli | 24 - upstream/ocaml_413/typing/btype.ml | 828 --- upstream/ocaml_413/typing/btype.mli | 276 - upstream/ocaml_413/typing/cmt2annot.ml | 184 - upstream/ocaml_413/typing/ctype.ml | 5027 -------------- upstream/ocaml_413/typing/ctype.mli | 354 - upstream/ocaml_413/typing/datarepr.ml | 242 - upstream/ocaml_413/typing/datarepr.mli | 45 - upstream/ocaml_413/typing/env.ml | 3481 ---------- upstream/ocaml_413/typing/env.mli | 485 -- upstream/ocaml_413/typing/envaux.ml | 115 - upstream/ocaml_413/typing/envaux.mli | 36 - upstream/ocaml_413/typing/errortrace.ml | 158 - upstream/ocaml_413/typing/errortrace.mli | 116 - upstream/ocaml_413/typing/ident.ml | 360 - upstream/ocaml_413/typing/ident.mli | 80 - upstream/ocaml_413/typing/includeclass.ml | 120 - upstream/ocaml_413/typing/includeclass.mli | 32 - upstream/ocaml_413/typing/includecore.ml | 685 -- upstream/ocaml_413/typing/includecore.mli | 116 - upstream/ocaml_413/typing/includemod.ml | 1024 --- upstream/ocaml_413/typing/includemod.mli | 237 - .../typing/includemod_errorprinter.ml | 932 --- .../typing/includemod_errorprinter.mli | 17 - upstream/ocaml_413/typing/mtype.ml | 530 -- upstream/ocaml_413/typing/mtype.mli | 55 - upstream/ocaml_413/typing/oprint.ml | 832 --- upstream/ocaml_413/typing/oprint.mli | 36 - upstream/ocaml_413/typing/outcometree.mli | 150 - upstream/ocaml_413/typing/parmatch.ml | 2479 ------- upstream/ocaml_413/typing/parmatch.mli | 134 - upstream/ocaml_413/typing/path.ml | 129 - upstream/ocaml_413/typing/path.mli | 52 - upstream/ocaml_413/typing/patterns.ml | 254 - upstream/ocaml_413/typing/patterns.mli | 109 - upstream/ocaml_413/typing/persistent_env.ml | 373 -- upstream/ocaml_413/typing/persistent_env.mli | 105 - upstream/ocaml_413/typing/predef.ml | 253 - upstream/ocaml_413/typing/predef.mli | 87 - upstream/ocaml_413/typing/primitive.ml | 251 - upstream/ocaml_413/typing/primitive.mli | 79 - upstream/ocaml_413/typing/printpat.ml | 169 - upstream/ocaml_413/typing/printpat.mli | 27 - upstream/ocaml_413/typing/printtyp.ml | 2373 ------- upstream/ocaml_413/typing/printtyp.mli | 219 - upstream/ocaml_413/typing/printtyped.ml | 962 --- upstream/ocaml_413/typing/printtyped.mli | 23 - upstream/ocaml_413/typing/rec_check.ml | 1258 ---- upstream/ocaml_413/typing/rec_check.mli | 19 - upstream/ocaml_413/typing/signature_group.ml | 155 - upstream/ocaml_413/typing/signature_group.mli | 85 - upstream/ocaml_413/typing/stypes.ml | 210 - upstream/ocaml_413/typing/stypes.mli | 36 - upstream/ocaml_413/typing/subst.ml | 580 -- upstream/ocaml_413/typing/subst.mli | 89 - upstream/ocaml_413/typing/tast_iterator.ml | 516 -- upstream/ocaml_413/typing/tast_iterator.mli | 68 - upstream/ocaml_413/typing/tast_mapper.ml | 749 --- upstream/ocaml_413/typing/tast_mapper.mli | 72 - upstream/ocaml_413/typing/type_immediacy.ml | 43 - upstream/ocaml_413/typing/type_immediacy.mli | 40 - upstream/ocaml_413/typing/typeclass.ml | 2063 ------ upstream/ocaml_413/typing/typeclass.mli | 130 - upstream/ocaml_413/typing/typecore.ml | 5813 ----------------- upstream/ocaml_413/typing/typecore.mli | 223 - upstream/ocaml_413/typing/typedecl.ml | 1903 ------ upstream/ocaml_413/typing/typedecl.mli | 109 - .../ocaml_413/typing/typedecl_immediacy.ml | 71 - .../ocaml_413/typing/typedecl_immediacy.mli | 27 - .../ocaml_413/typing/typedecl_properties.ml | 73 - .../ocaml_413/typing/typedecl_properties.mli | 55 - .../ocaml_413/typing/typedecl_separability.ml | 674 -- .../typing/typedecl_separability.mli | 132 - upstream/ocaml_413/typing/typedecl_unboxed.ml | 53 - .../ocaml_413/typing/typedecl_unboxed.mli | 25 - .../ocaml_413/typing/typedecl_variance.ml | 422 -- .../ocaml_413/typing/typedecl_variance.mli | 63 - upstream/ocaml_413/typing/typedtree.ml | 844 --- upstream/ocaml_413/typing/typedtree.mli | 822 --- upstream/ocaml_413/typing/typemod.ml | 3205 --------- upstream/ocaml_413/typing/typemod.mli | 139 - upstream/ocaml_413/typing/typeopt.ml | 216 - upstream/ocaml_413/typing/typeopt.mli | 43 - upstream/ocaml_413/typing/types.ml | 479 -- upstream/ocaml_413/typing/types.mli | 589 -- upstream/ocaml_413/typing/typetexp.ml | 808 --- upstream/ocaml_413/typing/typetexp.mli | 79 - upstream/ocaml_413/typing/untypeast.ml | 914 --- upstream/ocaml_413/typing/untypeast.mli | 87 - upstream/ocaml_413/utils/HACKING.adoc | 50 - upstream/ocaml_413/utils/Makefile | 119 - upstream/ocaml_413/utils/arg_helper.ml | 127 - upstream/ocaml_413/utils/arg_helper.mli | 68 - upstream/ocaml_413/utils/binutils.ml | 684 -- upstream/ocaml_413/utils/binutils.mli | 30 - .../ocaml_413/utils/build_path_prefix_map.ml | 119 - .../ocaml_413/utils/build_path_prefix_map.mli | 47 - upstream/ocaml_413/utils/ccomp.ml | 213 - upstream/ocaml_413/utils/ccomp.mli | 40 - upstream/ocaml_413/utils/clflags.ml | 575 -- upstream/ocaml_413/utils/clflags.mli | 270 - upstream/ocaml_413/utils/config.mli | 266 - upstream/ocaml_413/utils/config.mlp | 246 - upstream/ocaml_413/utils/consistbl.ml | 97 - upstream/ocaml_413/utils/consistbl.mli | 82 - upstream/ocaml_413/utils/diffing.ml | 370 -- upstream/ocaml_413/utils/diffing.mli | 112 - upstream/ocaml_413/utils/domainstate.ml.c | 34 - upstream/ocaml_413/utils/domainstate.mli.c | 22 - upstream/ocaml_413/utils/identifiable.ml | 249 - upstream/ocaml_413/utils/identifiable.mli | 113 - .../utils/int_replace_polymorphic_compare.ml | 8 - .../utils/int_replace_polymorphic_compare.mli | 8 - upstream/ocaml_413/utils/lazy_backtrack.ml | 81 - upstream/ocaml_413/utils/lazy_backtrack.mli | 33 - upstream/ocaml_413/utils/load_path.ml | 124 - upstream/ocaml_413/utils/load_path.mli | 75 - upstream/ocaml_413/utils/local_store.ml | 74 - upstream/ocaml_413/utils/local_store.mli | 66 - upstream/ocaml_413/utils/misc.ml | 1118 ---- upstream/ocaml_413/utils/misc.mli | 667 -- upstream/ocaml_413/utils/numbers.ml | 88 - upstream/ocaml_413/utils/numbers.mli | 51 - upstream/ocaml_413/utils/profile.ml | 335 - upstream/ocaml_413/utils/profile.mli | 49 - .../utils/strongly_connected_components.ml | 195 - .../utils/strongly_connected_components.mli | 43 - upstream/ocaml_413/utils/targetint.ml | 104 - upstream/ocaml_413/utils/targetint.mli | 207 - upstream/ocaml_413/utils/terminfo.ml | 45 - upstream/ocaml_413/utils/terminfo.mli | 32 - upstream/ocaml_413/utils/warnings.ml | 1032 --- upstream/ocaml_413/utils/warnings.mli | 153 - 181 files changed, 73695 deletions(-) delete mode 100644 upstream/ocaml_413/base-rev.txt delete mode 100644 upstream/ocaml_413/file_formats/cmi_format.ml delete mode 100644 upstream/ocaml_413/file_formats/cmi_format.mli delete mode 100644 upstream/ocaml_413/file_formats/cmo_format.mli delete mode 100644 upstream/ocaml_413/file_formats/cmt_format.ml delete mode 100644 upstream/ocaml_413/file_formats/cmt_format.mli delete mode 100644 upstream/ocaml_413/file_formats/cmx_format.mli delete mode 100644 upstream/ocaml_413/file_formats/cmxs_format.mli delete mode 100644 upstream/ocaml_413/file_formats/linear_format.ml delete mode 100644 upstream/ocaml_413/file_formats/linear_format.mli delete mode 100644 upstream/ocaml_413/parsing/CONFLICTS.md delete mode 100644 upstream/ocaml_413/parsing/HACKING.adoc delete mode 100644 upstream/ocaml_413/parsing/VIPs.md delete mode 100644 upstream/ocaml_413/parsing/ast_helper.ml delete mode 100644 upstream/ocaml_413/parsing/ast_helper.mli delete mode 100644 upstream/ocaml_413/parsing/ast_invariants.ml delete mode 100644 upstream/ocaml_413/parsing/ast_invariants.mli delete mode 100644 upstream/ocaml_413/parsing/ast_iterator.ml delete mode 100644 upstream/ocaml_413/parsing/ast_iterator.mli delete mode 100644 upstream/ocaml_413/parsing/ast_mapper.ml delete mode 100644 upstream/ocaml_413/parsing/ast_mapper.mli delete mode 100644 upstream/ocaml_413/parsing/asttypes.mli delete mode 100644 upstream/ocaml_413/parsing/attr_helper.ml delete mode 100644 upstream/ocaml_413/parsing/attr_helper.mli delete mode 100644 upstream/ocaml_413/parsing/builtin_attributes.ml delete mode 100644 upstream/ocaml_413/parsing/builtin_attributes.mli delete mode 100644 upstream/ocaml_413/parsing/depend.ml delete mode 100644 upstream/ocaml_413/parsing/depend.mli delete mode 100644 upstream/ocaml_413/parsing/docstrings.ml delete mode 100644 upstream/ocaml_413/parsing/docstrings.mli delete mode 100644 upstream/ocaml_413/parsing/lexer.mli delete mode 100644 upstream/ocaml_413/parsing/lexer.mll delete mode 100644 upstream/ocaml_413/parsing/location.ml delete mode 100644 upstream/ocaml_413/parsing/location.mli delete mode 100644 upstream/ocaml_413/parsing/longident.ml delete mode 100644 upstream/ocaml_413/parsing/longident.mli delete mode 100644 upstream/ocaml_413/parsing/parse.ml delete mode 100644 upstream/ocaml_413/parsing/parse.mli delete mode 100644 upstream/ocaml_413/parsing/parser.mly delete mode 100644 upstream/ocaml_413/parsing/parsetree.mli delete mode 100644 upstream/ocaml_413/parsing/pprintast.ml delete mode 100644 upstream/ocaml_413/parsing/pprintast.mli delete mode 100644 upstream/ocaml_413/parsing/printast.ml delete mode 100644 upstream/ocaml_413/parsing/printast.mli delete mode 100644 upstream/ocaml_413/parsing/syntaxerr.ml delete mode 100644 upstream/ocaml_413/parsing/syntaxerr.mli delete mode 100644 upstream/ocaml_413/typing/HACKING.adoc delete mode 100644 upstream/ocaml_413/typing/TODO.md delete mode 100644 upstream/ocaml_413/typing/annot.mli delete mode 100644 upstream/ocaml_413/typing/btype.ml delete mode 100644 upstream/ocaml_413/typing/btype.mli delete mode 100644 upstream/ocaml_413/typing/cmt2annot.ml delete mode 100644 upstream/ocaml_413/typing/ctype.ml delete mode 100644 upstream/ocaml_413/typing/ctype.mli delete mode 100644 upstream/ocaml_413/typing/datarepr.ml delete mode 100644 upstream/ocaml_413/typing/datarepr.mli delete mode 100644 upstream/ocaml_413/typing/env.ml delete mode 100644 upstream/ocaml_413/typing/env.mli delete mode 100644 upstream/ocaml_413/typing/envaux.ml delete mode 100644 upstream/ocaml_413/typing/envaux.mli delete mode 100644 upstream/ocaml_413/typing/errortrace.ml delete mode 100644 upstream/ocaml_413/typing/errortrace.mli delete mode 100644 upstream/ocaml_413/typing/ident.ml delete mode 100644 upstream/ocaml_413/typing/ident.mli delete mode 100644 upstream/ocaml_413/typing/includeclass.ml delete mode 100644 upstream/ocaml_413/typing/includeclass.mli delete mode 100644 upstream/ocaml_413/typing/includecore.ml delete mode 100644 upstream/ocaml_413/typing/includecore.mli delete mode 100644 upstream/ocaml_413/typing/includemod.ml delete mode 100644 upstream/ocaml_413/typing/includemod.mli delete mode 100644 upstream/ocaml_413/typing/includemod_errorprinter.ml delete mode 100644 upstream/ocaml_413/typing/includemod_errorprinter.mli delete mode 100644 upstream/ocaml_413/typing/mtype.ml delete mode 100644 upstream/ocaml_413/typing/mtype.mli delete mode 100644 upstream/ocaml_413/typing/oprint.ml delete mode 100644 upstream/ocaml_413/typing/oprint.mli delete mode 100644 upstream/ocaml_413/typing/outcometree.mli delete mode 100644 upstream/ocaml_413/typing/parmatch.ml delete mode 100644 upstream/ocaml_413/typing/parmatch.mli delete mode 100644 upstream/ocaml_413/typing/path.ml delete mode 100644 upstream/ocaml_413/typing/path.mli delete mode 100644 upstream/ocaml_413/typing/patterns.ml delete mode 100644 upstream/ocaml_413/typing/patterns.mli delete mode 100644 upstream/ocaml_413/typing/persistent_env.ml delete mode 100644 upstream/ocaml_413/typing/persistent_env.mli delete mode 100644 upstream/ocaml_413/typing/predef.ml delete mode 100644 upstream/ocaml_413/typing/predef.mli delete mode 100644 upstream/ocaml_413/typing/primitive.ml delete mode 100644 upstream/ocaml_413/typing/primitive.mli delete mode 100644 upstream/ocaml_413/typing/printpat.ml delete mode 100644 upstream/ocaml_413/typing/printpat.mli delete mode 100644 upstream/ocaml_413/typing/printtyp.ml delete mode 100644 upstream/ocaml_413/typing/printtyp.mli delete mode 100644 upstream/ocaml_413/typing/printtyped.ml delete mode 100644 upstream/ocaml_413/typing/printtyped.mli delete mode 100644 upstream/ocaml_413/typing/rec_check.ml delete mode 100644 upstream/ocaml_413/typing/rec_check.mli delete mode 100644 upstream/ocaml_413/typing/signature_group.ml delete mode 100644 upstream/ocaml_413/typing/signature_group.mli delete mode 100644 upstream/ocaml_413/typing/stypes.ml delete mode 100644 upstream/ocaml_413/typing/stypes.mli delete mode 100644 upstream/ocaml_413/typing/subst.ml delete mode 100644 upstream/ocaml_413/typing/subst.mli delete mode 100644 upstream/ocaml_413/typing/tast_iterator.ml delete mode 100644 upstream/ocaml_413/typing/tast_iterator.mli delete mode 100644 upstream/ocaml_413/typing/tast_mapper.ml delete mode 100644 upstream/ocaml_413/typing/tast_mapper.mli delete mode 100644 upstream/ocaml_413/typing/type_immediacy.ml delete mode 100644 upstream/ocaml_413/typing/type_immediacy.mli delete mode 100644 upstream/ocaml_413/typing/typeclass.ml delete mode 100644 upstream/ocaml_413/typing/typeclass.mli delete mode 100644 upstream/ocaml_413/typing/typecore.ml delete mode 100644 upstream/ocaml_413/typing/typecore.mli delete mode 100644 upstream/ocaml_413/typing/typedecl.ml delete mode 100644 upstream/ocaml_413/typing/typedecl.mli delete mode 100644 upstream/ocaml_413/typing/typedecl_immediacy.ml delete mode 100644 upstream/ocaml_413/typing/typedecl_immediacy.mli delete mode 100644 upstream/ocaml_413/typing/typedecl_properties.ml delete mode 100644 upstream/ocaml_413/typing/typedecl_properties.mli delete mode 100644 upstream/ocaml_413/typing/typedecl_separability.ml delete mode 100644 upstream/ocaml_413/typing/typedecl_separability.mli delete mode 100644 upstream/ocaml_413/typing/typedecl_unboxed.ml delete mode 100644 upstream/ocaml_413/typing/typedecl_unboxed.mli delete mode 100644 upstream/ocaml_413/typing/typedecl_variance.ml delete mode 100644 upstream/ocaml_413/typing/typedecl_variance.mli delete mode 100644 upstream/ocaml_413/typing/typedtree.ml delete mode 100644 upstream/ocaml_413/typing/typedtree.mli delete mode 100644 upstream/ocaml_413/typing/typemod.ml delete mode 100644 upstream/ocaml_413/typing/typemod.mli delete mode 100644 upstream/ocaml_413/typing/typeopt.ml delete mode 100644 upstream/ocaml_413/typing/typeopt.mli delete mode 100644 upstream/ocaml_413/typing/types.ml delete mode 100644 upstream/ocaml_413/typing/types.mli delete mode 100644 upstream/ocaml_413/typing/typetexp.ml delete mode 100644 upstream/ocaml_413/typing/typetexp.mli delete mode 100644 upstream/ocaml_413/typing/untypeast.ml delete mode 100644 upstream/ocaml_413/typing/untypeast.mli delete mode 100644 upstream/ocaml_413/utils/HACKING.adoc delete mode 100644 upstream/ocaml_413/utils/Makefile delete mode 100644 upstream/ocaml_413/utils/arg_helper.ml delete mode 100644 upstream/ocaml_413/utils/arg_helper.mli delete mode 100644 upstream/ocaml_413/utils/binutils.ml delete mode 100644 upstream/ocaml_413/utils/binutils.mli delete mode 100644 upstream/ocaml_413/utils/build_path_prefix_map.ml delete mode 100644 upstream/ocaml_413/utils/build_path_prefix_map.mli delete mode 100644 upstream/ocaml_413/utils/ccomp.ml delete mode 100644 upstream/ocaml_413/utils/ccomp.mli delete mode 100644 upstream/ocaml_413/utils/clflags.ml delete mode 100644 upstream/ocaml_413/utils/clflags.mli delete mode 100644 upstream/ocaml_413/utils/config.mli delete mode 100644 upstream/ocaml_413/utils/config.mlp delete mode 100644 upstream/ocaml_413/utils/consistbl.ml delete mode 100644 upstream/ocaml_413/utils/consistbl.mli delete mode 100644 upstream/ocaml_413/utils/diffing.ml delete mode 100644 upstream/ocaml_413/utils/diffing.mli delete mode 100644 upstream/ocaml_413/utils/domainstate.ml.c delete mode 100644 upstream/ocaml_413/utils/domainstate.mli.c delete mode 100644 upstream/ocaml_413/utils/identifiable.ml delete mode 100644 upstream/ocaml_413/utils/identifiable.mli delete mode 100644 upstream/ocaml_413/utils/int_replace_polymorphic_compare.ml delete mode 100644 upstream/ocaml_413/utils/int_replace_polymorphic_compare.mli delete mode 100644 upstream/ocaml_413/utils/lazy_backtrack.ml delete mode 100644 upstream/ocaml_413/utils/lazy_backtrack.mli delete mode 100644 upstream/ocaml_413/utils/load_path.ml delete mode 100644 upstream/ocaml_413/utils/load_path.mli delete mode 100644 upstream/ocaml_413/utils/local_store.ml delete mode 100644 upstream/ocaml_413/utils/local_store.mli delete mode 100644 upstream/ocaml_413/utils/misc.ml delete mode 100644 upstream/ocaml_413/utils/misc.mli delete mode 100644 upstream/ocaml_413/utils/numbers.ml delete mode 100644 upstream/ocaml_413/utils/numbers.mli delete mode 100644 upstream/ocaml_413/utils/profile.ml delete mode 100644 upstream/ocaml_413/utils/profile.mli delete mode 100644 upstream/ocaml_413/utils/strongly_connected_components.ml delete mode 100644 upstream/ocaml_413/utils/strongly_connected_components.mli delete mode 100644 upstream/ocaml_413/utils/targetint.ml delete mode 100644 upstream/ocaml_413/utils/targetint.mli delete mode 100644 upstream/ocaml_413/utils/terminfo.ml delete mode 100644 upstream/ocaml_413/utils/terminfo.mli delete mode 100644 upstream/ocaml_413/utils/warnings.ml delete mode 100644 upstream/ocaml_413/utils/warnings.mli diff --git a/upstream/ocaml_413/base-rev.txt b/upstream/ocaml_413/base-rev.txt deleted file mode 100644 index f971401ca7..0000000000 --- a/upstream/ocaml_413/base-rev.txt +++ /dev/null @@ -1 +0,0 @@ -ab626576eee205615a9d7c5a66c2cb2478f1169c diff --git a/upstream/ocaml_413/file_formats/cmi_format.ml b/upstream/ocaml_413/file_formats/cmi_format.ml deleted file mode 100644 index eadf676e08..0000000000 --- a/upstream/ocaml_413/file_formats/cmi_format.ml +++ /dev/null @@ -1,118 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index d4d665fdf5..0000000000 --- a/upstream/ocaml_413/file_formats/cmi_format.mli +++ /dev/null @@ -1,51 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 0952157b37..0000000000 --- a/upstream/ocaml_413/file_formats/cmo_format.mli +++ /dev/null @@ -1,68 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 709509a72c..0000000000 --- a/upstream/ocaml_413/file_formats/cmt_format.ml +++ /dev/null @@ -1,194 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 8a52c4b28f..0000000000 --- a/upstream/ocaml_413/file_formats/cmt_format.mli +++ /dev/null @@ -1,123 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 infos\} \{\} - where is the cmi file format: - := . - More precisely, the optional 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 deleted file mode 100644 index 91ad2d1ff1..0000000000 --- a/upstream/ocaml_413/file_formats/cmx_format.mli +++ /dev/null @@ -1,58 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index c670024f92..0000000000 --- a/upstream/ocaml_413/file_formats/cmxs_format.mli +++ /dev/null @@ -1,35 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 5525a69707..0000000000 --- a/upstream/ocaml_413/file_formats/linear_format.ml +++ /dev/null @@ -1,101 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 766db5db24..0000000000 --- a/upstream/ocaml_413/file_formats/linear_format.mli +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index b2a84fcbc3..0000000000 --- a/upstream/ocaml_413/parsing/CONFLICTS.md +++ /dev/null @@ -1,54 +0,0 @@ -# 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 -> -``` - -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 deleted file mode 100644 index 0566c0135d..0000000000 --- a/upstream/ocaml_413/parsing/HACKING.adoc +++ /dev/null @@ -1,76 +0,0 @@ -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 deleted file mode 100644 index baae024402..0000000000 --- a/upstream/ocaml_413/parsing/VIPs.md +++ /dev/null @@ -1,20 +0,0 @@ -# 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 deleted file mode 100644 index 41f5fb9b8d..0000000000 --- a/upstream/ocaml_413/parsing/ast_helper.ml +++ /dev/null @@ -1,643 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 42ce9e2e98..0000000000 --- a/upstream/ocaml_413/parsing/ast_helper.mli +++ /dev/null @@ -1,493 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index d9b83c0edd..0000000000 --- a/upstream/ocaml_413/parsing/ast_invariants.ml +++ /dev/null @@ -1,191 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index fdb56aa5ef..0000000000 --- a/upstream/ocaml_413/parsing/ast_invariants.mli +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 0b88be7386..0000000000 --- a/upstream/ocaml_413/parsing/ast_iterator.ml +++ /dev/null @@ -1,682 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 26308d20de..0000000000 --- a/upstream/ocaml_413/parsing/ast_iterator.mli +++ /dev/null @@ -1,83 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index f23325ba97..0000000000 --- a/upstream/ocaml_413/parsing/ast_mapper.ml +++ /dev/null @@ -1,1078 +0,0 @@ -(**************************************************************************) -(* *) -(* 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] \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 deleted file mode 100644 index 69f6b017ab..0000000000 --- a/upstream/ocaml_413/parsing/ast_mapper.mli +++ /dev/null @@ -1,208 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index f4745fb7ab..0000000000 --- a/upstream/ocaml_413/parsing/asttypes.mli +++ /dev/null @@ -1,67 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 0a616cd746..0000000000 --- a/upstream/ocaml_413/parsing/attr_helper.ml +++ /dev/null @@ -1,54 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index a3ddc0c9cb..0000000000 --- a/upstream/ocaml_413/parsing/attr_helper.mli +++ /dev/null @@ -1,41 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index c90542567a..0000000000 --- a/upstream/ocaml_413/parsing/builtin_attributes.ml +++ /dev/null @@ -1,289 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 6200fd74ec..0000000000 --- a/upstream/ocaml_413/parsing/builtin_attributes.mli +++ /dev/null @@ -1,84 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index d2ebb81ec9..0000000000 --- a/upstream/ocaml_413/parsing/depend.ml +++ /dev/null @@ -1,594 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 74c095f969..0000000000 --- a/upstream/ocaml_413/parsing/depend.mli +++ /dev/null @@ -1,45 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index a39f75d259..0000000000 --- a/upstream/ocaml_413/parsing/docstrings.ml +++ /dev/null @@ -1,425 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index bf2508fdc4..0000000000 --- a/upstream/ocaml_413/parsing/docstrings.mli +++ /dev/null @@ -1,223 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 85b85a8953..0000000000 --- a/upstream/ocaml_413/parsing/lexer.mli +++ /dev/null @@ -1,65 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 89d6876300..0000000000 --- a/upstream/ocaml_413/parsing/lexer.mll +++ /dev/null @@ -1,871 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 26a66019de..0000000000 --- a/upstream/ocaml_413/parsing/location.ml +++ /dev/null @@ -1,949 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "@{"; - - 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 "@["; - 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 "@[%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 "@[%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@}" - | Report_warning w -> Format.fprintf ppf "@{Warning@} %s" w - | Report_warning_as_error w -> - Format.fprintf ppf "@{Error@} (warning %s)" w - | Report_alert w -> Format.fprintf ppf "@{Alert@} %s" w - | Report_alert_as_error w -> - Format.fprintf ppf "@{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 deleted file mode 100644 index 5ba80b04da..0000000000 --- a/upstream/ocaml_413/parsing/location.mli +++ /dev/null @@ -1,287 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index eaafb02bee..0000000000 --- a/upstream/ocaml_413/parsing/longident.ml +++ /dev/null @@ -1,50 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 8704a7780e..0000000000 --- a/upstream/ocaml_413/parsing/longident.mli +++ /dev/null @@ -1,58 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 05bc9fca46..0000000000 --- a/upstream/ocaml_413/parsing/parse.ml +++ /dev/null @@ -1,147 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 8669a4b6c2..0000000000 --- a/upstream/ocaml_413/parsing/parse.mli +++ /dev/null @@ -1,108 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index bb1319d570..0000000000 --- a/upstream/ocaml_413/parsing/parser.mly +++ /dev/null @@ -1,3867 +0,0 @@ -/**************************************************************************/ -/* */ -/* 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, <>] ] - * [ 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 "'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 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 INFIXOP0 "!=" (* just an example *) -%token INFIXOP1 "@" (* just an example *) -%token INFIXOP2 "+!" (* chosen with care; see above *) -%token INFIXOP3 "land" (* just an example *) -%token INFIXOP4 "**" (* just an example *) -%token DOTOP ".+" -%token LETOP "let*" (* just an example *) -%token ANDOP "and*" (* just an example *) -%token INHERIT "inherit" -%token INITIALIZER "initializer" -%token INT "42" (* just an example *) -%token 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 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 OPTLABEL "?label:" (* just an example *) -%token OR "or" -/* %token PARSER "parser" */ -%token PERCENT "%" -%token PLUS "+" -%token PLUSDOT "+." -%token PLUSEQ "+=" -%token 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 HASHOP "##" (* just an example *) -%token SIG "sig" -%token STAR "*" -%token - STRING "\"hello\"" (* just an example *) -%token - QUOTED_STRING_EXPR "{%hello|world|}" (* just an example *) -%token - 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 UIDENT "UIdent" (* just an example *) -%token UNDERSCORE "_" -%token VAL "val" -%token VIRTUAL "virtual" -%token WHEN "when" -%token WHILE "while" -%token WITH "with" -%token COMMENT "(* comment *)" -%token 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 implementation -/* BEGIN AVOID */ -%start interface /* for interface files */ -%type interface -/* END AVOID */ -%start toplevel_phrase /* for interactive use */ -%type toplevel_phrase -%start use_file /* for the #use directive */ -%type use_file -/* BEGIN AVOID */ -%start parse_core_type -%type parse_core_type -%start parse_expression -%type parse_expression -%start parse_pattern -%type parse_pattern -%start parse_constr_longident -%type parse_constr_longident -%start parse_val_longident -%type parse_val_longident -%start parse_mty_longident -%type parse_mty_longident -%start parse_mod_ext_longident -%type parse_mod_ext_longident -%start parse_mod_longident -%type parse_mod_longident -%start parse_any_longident -%type 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 deleted file mode 100644 index 0508d04bac..0000000000 --- a/upstream/ocaml_413/parsing/parsetree.mli +++ /dev/null @@ -1,978 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index b8a320ccc0..0000000000 --- a/upstream/ocaml_413/parsing/pprintast.ml +++ /dev/null @@ -1,1700 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "@[%s: %a@ %a@ @]" l.txt - (core_type ctxt) ct (attributes ctxt) x.pof_attributes - | Oinherit ct -> - pp f "@[%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 "@[<@ %a%a@ > @]" - (list core_field_type ~sep:";") l - field_var o (* Cf #7200 *) - | Ptyp_class (li, l) -> (*FIXME*) - pp f "@[%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 "@[(module@ %a)@]" longident_loc lid - |_ -> - pp f "@[(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 "@[%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 "@[!%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 "@[function%a@]" (case_list ctxt) l - | Pexp_match (e, l) -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - (expression reset_ctxt) e (case_list ctxt) l - - | Pexp_try (e, l) -> - pp f "@[<0>@[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 "@[%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 ="@[@[<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 "@[%a@]" - (list (expression (under_semi ctxt)) ~sep:";@;") lst - | Pexp_new (li) -> - pp f "@[new@ %a@]" longident_loc li; - | Pexp_setinstvar (s, e) -> - pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e - | Pexp_override l -> (* FIXME *) - let string_x_expression f (s, e) = - pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in - pp f "@[{<%a>}@]" - (list string_x_expression ~sep:";" ) l; - | Pexp_letmodule (s, me, e) -> - pp f "@[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 "@[let@ exception@ %a@ in@ %a@]" - (extension_constructor ctxt) cd - (expression ctxt) e - | Pexp_assert e -> - pp f "@[assert@ %a@]" (simple_expr ctxt) e - | Pexp_lazy (e) -> - pp f "@[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 "@[!poly!@ %a@]" (simple_expr ctxt) e - | Pexp_poly (e, Some ct) -> - pp f "@[(!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>@[%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 "@[%a.%a@]" (simple_expr ctxt) e longident_loc li - | Pexp_send (e, s) -> pp f "@[%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 "@[[%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 "@[(%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 "@[%a@]" longident_loc li - | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e - in - pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%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 = - "@[@[@[<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 "@[%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 "@[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 "@[@[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 "@[%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 "@[@[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 "@[functor () ->@ %a@]" (module_type ctxt) mt2 - | Pmty_functor (Named (s, mt1), mt2) -> - begin match s.txt with - | None -> - pp f "@[%a@ ->@ %a@]" - (module_type1 ctxt) mt1 (module_type ctxt) mt2 - | Some name -> - pp f "@[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 "@[%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 "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) - (list (signature_item ctxt)) s (* FIXME wrong indentation*) - | Pmty_typeof me -> - pp f "@[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 "@[%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 "@[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 "@[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 "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt - longident_loc pms.pms_manifest - (item_attributes ctxt) pms.pms_attributes - | Psig_open od -> - pp f "@[open%s@ %a@]%a" - (override od.popen_override) - longident_loc od.popen_expr - (item_attributes ctxt) od.popen_attributes - | Psig_include incl -> - pp f "@[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 "@[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 "@[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 "@ @[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 "@[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 "@[struct@;@[<0>%a@]@;<1 -2>end@]" - (list (structure_item ctxt) ~sep:"@\n") s; - | Pmod_constraint (me, mt) -> - pp f "@[(%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 "@[%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 "@[;;%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 "@[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 "@[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 "@[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 "@[%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 "@[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 "@[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 "@[@ 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 "@[@ 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 "@[@[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 "@[@[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 "@[%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 "@[@ 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 "@[%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 "@[#%s@]" pdir_name.txt - | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} -> - pp f "@[#%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 deleted file mode 100644 index 6c7022cf69..0000000000 --- a/upstream/ocaml_413/parsing/pprintast.mli +++ /dev/null @@ -1,46 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 647dfe94a8..0000000000 --- a/upstream/ocaml_413/parsing/printast.ml +++ /dev/null @@ -1,981 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "\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 " %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 "\n"; - pattern (i+1) ppf pc_lhs; - begin match pc_guard with - | None -> () - | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g - end; - expression (i+1) ppf pc_rhs; - -and value_binding i ppf x = - line i ppf "\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 " %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 " %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 "\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 deleted file mode 100644 index 8215654826..0000000000 --- a/upstream/ocaml_413/parsing/printast.mli +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 49372b9edf..0000000000 --- a/upstream/ocaml_413/parsing/syntaxerr.ml +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 26ba712671..0000000000 --- a/upstream/ocaml_413/parsing/syntaxerr.mli +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 8633ef52ed..0000000000 --- a/upstream/ocaml_413/typing/HACKING.adoc +++ /dev/null @@ -1,58 +0,0 @@ -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é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 deleted file mode 100644 index c115116117..0000000000 --- a/upstream/ocaml_413/typing/TODO.md +++ /dev/null @@ -1,101 +0,0 @@ -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 deleted file mode 100644 index 3cae8f2735..0000000000 --- a/upstream/ocaml_413/typing/annot.mli +++ /dev/null @@ -1,24 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index a18f53dd25..0000000000 --- a/upstream/ocaml_413/typing/btype.ml +++ /dev/null @@ -1,828 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index f16a3595ed..0000000000 --- a/upstream/ocaml_413/typing/btype.mli +++ /dev/null @@ -1,276 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 40ee752e80..0000000000 --- a/upstream/ocaml_413/typing/cmt2annot.ml +++ /dev/null @@ -1,184 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 5d1d2473ec..0000000000 --- a/upstream/ocaml_413/typing/ctype.ml +++ /dev/null @@ -1,5027 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 = ]). 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 deleted file mode 100644 index 7185cdb7e0..0000000000 --- a/upstream/ocaml_413/typing/ctype.mli +++ /dev/null @@ -1,354 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 8ec47a914b..0000000000 --- a/upstream/ocaml_413/typing/datarepr.ml +++ /dev/null @@ -1,242 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 38f05f74f0..0000000000 --- a/upstream/ocaml_413/typing/datarepr.mli +++ /dev/null @@ -1,45 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 545c6ff8a0..0000000000 --- a/upstream/ocaml_413/typing/env.ml +++ /dev/null @@ -1,3481 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "@[@["; - 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 deleted file mode 100644 index 0536f3b863..0000000000 --- a/upstream/ocaml_413/typing/env.mli +++ /dev/null @@ -1,485 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index a0bbbc2684..0000000000 --- a/upstream/ocaml_413/typing/envaux.ml +++ /dev/null @@ -1,115 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 2869890a14..0000000000 --- a/upstream/ocaml_413/typing/envaux.mli +++ /dev/null @@ -1,36 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index eca74088de..0000000000 --- a/upstream/ocaml_413/typing/errortrace.ml +++ /dev/null @@ -1,158 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index be6000ed10..0000000000 --- a/upstream/ocaml_413/typing/errortrace.mli +++ /dev/null @@ -1,116 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index feb590d024..0000000000 --- a/upstream/ocaml_413/typing/ident.ml +++ /dev/null @@ -1,360 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 - "_", 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 deleted file mode 100644 index ff48efb3ad..0000000000 --- a/upstream/ocaml_413/typing/ident.mli +++ /dev/null @@ -1,80 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 2f0c057ff9..0000000000 --- a/upstream/ocaml_413/typing/includeclass.ml +++ /dev/null @@ -1,120 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "@[%a%a@]" include_err err print_errs errs diff --git a/upstream/ocaml_413/typing/includeclass.mli b/upstream/ocaml_413/typing/includeclass.mli deleted file mode 100644 index ebfa97897f..0000000000 --- a/upstream/ocaml_413/typing/includeclass.mli +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index d712faeeab..0000000000 --- a/upstream/ocaml_413/typing/includecore.ml +++ /dev/null @@ -1,685 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 - "@[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 "@[Fields number %i have different names, %s and %s.@]" - n (Ident.name name1) (Ident.name name2) - | Label_missing (ord, s) -> - pr "@[The field %s is only present in %s %s.@]" - (Ident.name s) (choose ord first second) decl - | Unboxed_float_representation ord -> - pr "@[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 - "@[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 "@[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 deleted file mode 100644 index 95bcbb23cb..0000000000 --- a/upstream/ocaml_413/typing/includecore.mli +++ /dev/null @@ -1,116 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 1b542d5f5d..0000000000 --- a/upstream/ocaml_413/typing/includemod.ml +++ /dev/null @@ -1,1024 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index f4bd3a6f11..0000000000 --- a/upstream/ocaml_413/typing/includemod.mli +++ /dev/null @@ -1,237 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 013275b57b..0000000000 --- a/upstream/ocaml_413/typing/includemod_errorprinter.ml +++ /dev/null @@ -1,932 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "" - 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 "@[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 "@[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 - "@[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@[%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@[%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 - "@[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 "@[@[%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 "@[@[%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 - "@[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 - "@[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 - "@[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 - "@[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 - "@[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 - "@[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 - "@[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 deleted file mode 100644 index 12ea2169b0..0000000000 --- a/upstream/ocaml_413/typing/includemod_errorprinter.mli +++ /dev/null @@ -1,17 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 3af072e876..0000000000 --- a/upstream/ocaml_413/typing/mtype.ml +++ /dev/null @@ -1,530 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 68d290b36f..0000000000 --- a/upstream/ocaml_413/typing/mtype.mli +++ /dev/null @@ -1,55 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 7a47cab446..0000000000 --- a/upstream/ocaml_413/typing/oprint.ml +++ /dev/null @@ -1,832 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "" - 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 "@[%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>> @[%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@[[%s@[@[%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 "@[`%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 "@[@[<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 "@[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>@[%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 "@[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 "@[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 "@[%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 deleted file mode 100644 index bafd17ccf1..0000000000 --- a/upstream/ocaml_413/typing/oprint.mli +++ /dev/null @@ -1,36 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index d9b4f04c1c..0000000000 --- a/upstream/ocaml_413/typing/outcometree.mli +++ /dev/null @@ -1,150 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index c179155fb9..0000000000 --- a/upstream/ocaml_413/typing/parmatch.ml +++ /dev/null @@ -1,2479 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 = "" - -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 deleted file mode 100644 index fc81476bc4..0000000000 --- a/upstream/ocaml_413/typing/parmatch.mli +++ /dev/null @@ -1,134 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 4190c27e6a..0000000000 --- a/upstream/ocaml_413/typing/path.ml +++ /dev/null @@ -1,129 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index bddf9d670a..0000000000 --- a/upstream/ocaml_413/typing/path.mli +++ /dev/null @@ -1,52 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 8580329988..0000000000 --- a/upstream/ocaml_413/typing/patterns.ml +++ /dev/null @@ -1,254 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 66dd2d05a4..0000000000 --- a/upstream/ocaml_413/typing/patterns.mli +++ /dev/null @@ -1,109 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 65f6066376..0000000000 --- a/upstream/ocaml_413/typing/persistent_env.ml +++ /dev/null @@ -1,373 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 - "@[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 - "@[Invalid import of %s, which uses recursive types.@ %s@]" - import "The compilation flag -rectypes is required" - | Depend_on_unsafe_string_unit(import) -> - fprintf ppf - "@[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 deleted file mode 100644 index b2e139312d..0000000000 --- a/upstream/ocaml_413/typing/persistent_env.mli +++ /dev/null @@ -1,105 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 671df8176b..0000000000 --- a/upstream/ocaml_413/typing/predef.ml +++ /dev/null @@ -1,253 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 962a276a92..0000000000 --- a/upstream/ocaml_413/typing/predef.mli +++ /dev/null @@ -1,87 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index bf4fe83248..0000000000 --- a/upstream/ocaml_413/typing/primitive.ml +++ /dev/null @@ -1,251 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index e8376ad552..0000000000 --- a/upstream/ocaml_413/typing/primitive.mli +++ /dev/null @@ -1,79 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 64094b63ec..0000000000 --- a/upstream/ocaml_413/typing/printpat.ml +++ /dev/null @@ -1,169 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 1865a2ab29..0000000000 --- a/upstream/ocaml_413/typing/printpat.mli +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index dd7d8aaaf1..0000000000 --- a/upstream/ocaml_413/typing/printtyp.ml +++ /dev/null @@ -1,2373 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "@[%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 "@[%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 "@[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 "@[Tconstr(@,%a,@,%a,@,%a)@]" path p - raw_type_list tl - (raw_list path) (list_of_memo !abbrev) - | Tobject (t, nm) -> - fprintf ppf "@[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 "@[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 "@[Tpoly(@,%a,@,%a)@]" - raw_type t - raw_type_list tl - | Tvariant row -> - fprintf ppf - "@[{@[%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 "@[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 "@[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 "" - 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 "" - | 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 "@[%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 "" - 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 "@[%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)@ @[%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 @,@[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 "@,@[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 - "@[\ - @[%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 "@[%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>@[%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 deleted file mode 100644 index 01c76c89c7..0000000000 --- a/upstream/ocaml_413/typing/printtyp.mli +++ /dev/null @@ -1,219 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 3457e08c8c..0000000000 --- a/upstream/ocaml_413/typing/printtyped.ml +++ /dev/null @@ -1,962 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 " %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 "\n"; - pattern (i+1) ppf c_lhs; - begin match c_guard with - | None -> () - | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g - end; - expression (i+1) ppf c_rhs; - -and value_binding i ppf x = - line i ppf "\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 " \"%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 "" - -and label_x_expression i ppf (l, e) = - line i ppf "\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 " \"%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 deleted file mode 100644 index 538a3faae2..0000000000 --- a/upstream/ocaml_413/typing/printtyped.mli +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 75091497a3..0000000000 --- a/upstream/ocaml_413/typing/rec_check.ml +++ /dev/null @@ -1,1258 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 |- : m -| G' - G' |- body : m - ------------------------------- - G |- let 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 |- : 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 deleted file mode 100644 index aa5c1ca3c1..0000000000 --- a/upstream/ocaml_413/typing/rec_check.mli +++ /dev/null @@ -1,19 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 7395961758..0000000000 --- a/upstream/ocaml_413/typing/signature_group.ml +++ /dev/null @@ -1,155 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index e6e0dbdd14..0000000000 --- a/upstream/ocaml_413/typing/signature_group.mli +++ /dev/null @@ -1,85 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index dfbcc9918d..0000000000 --- a/upstream/ocaml_413/typing/stypes.ml +++ /dev/null @@ -1,210 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index fda575fc02..0000000000 --- a/upstream/ocaml_413/typing/stypes.mli +++ /dev/null @@ -1,36 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 6ad01b9dac..0000000000 --- a/upstream/ocaml_413/typing/subst.ml +++ /dev/null @@ -1,580 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 4ae8e13679..0000000000 --- a/upstream/ocaml_413/typing/subst.mli +++ /dev/null @@ -1,89 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index bdb8d74f39..0000000000 --- a/upstream/ocaml_413/typing/tast_iterator.ml +++ /dev/null @@ -1,516 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index e126128edf..0000000000 --- a/upstream/ocaml_413/typing/tast_iterator.mli +++ /dev/null @@ -1,68 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 4bb43a8bf9..0000000000 --- a/upstream/ocaml_413/typing/tast_mapper.ml +++ /dev/null @@ -1,749 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index ea6543d04f..0000000000 --- a/upstream/ocaml_413/typing/tast_mapper.mli +++ /dev/null @@ -1,72 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 557ed4271a..0000000000 --- a/upstream/ocaml_413/typing/type_immediacy.ml +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 3fc2e3b4f9..0000000000 --- a/upstream/ocaml_413/typing/type_immediacy.mli +++ /dev/null @@ -1,40 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 5907cbb8cb..0000000000 --- a/upstream/ocaml_413/typing/typeclass.ml +++ /dev/null @@ -1,2063 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "@[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 - "@[@[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 deleted file mode 100644 index ac8eb06ec5..0000000000 --- a/upstream/ocaml_413/typing/typeclass.mli +++ /dev/null @@ -1,130 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 87d4a55572..0000000000 --- a/upstream/ocaml_413/typing/typecore.ml +++ /dev/null @@ -1,5813 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 = - ]} - 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 - "@[@[<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 "@[@[<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 - "@[@[<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 "@[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 - "@[@[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 ".@.@[%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 - "@[@[<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 deleted file mode 100644 index 4994075e77..0000000000 --- a/upstream/ocaml_413/typing/typecore.mli +++ /dev/null @@ -1,223 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 7f6b5d5f63..0000000000 --- a/upstream/ocaml_413/typing/typedecl.ml +++ /dev/null @@ -1,1903 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 - ".@ @[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 "@[The definition of %s contains a cycle:@ %a@]" - s Printtyp.type_expr ty - | Definition_mismatch (ty, None) -> - fprintf ppf "@[@[%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 "@[@[%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 "@[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 - "@[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 - "@[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"); - 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 "@[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 "@[@[%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 - "@[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.@]@,\ - @[@[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 deleted file mode 100644 index 2ec3fef337..0000000000 --- a/upstream/ocaml_413/typing/typedecl.mli +++ /dev/null @@ -1,109 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index bcc4d34943..0000000000 --- a/upstream/ocaml_413/typing/typedecl_immediacy.ml +++ /dev/null @@ -1,71 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 17fb985c80..0000000000 --- a/upstream/ocaml_413/typing/typedecl_immediacy.mli +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 28a1bb6673..0000000000 --- a/upstream/ocaml_413/typing/typedecl_properties.ml +++ /dev/null @@ -1,73 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 153c3f719c..0000000000 --- a/upstream/ocaml_413/typing/typedecl_properties.mli +++ /dev/null @@ -1,55 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 0d4efd66a3..0000000000 --- a/upstream/ocaml_413/typing/typedecl_separability.ml +++ /dev/null @@ -1,674 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 = ) - for each type parameter 'a of the type constructor. For each - such equation, we should "strengthen" the current context in - the following way: - - if is another variable 'b, - the mode of 'a is set to the mode of 'b, - and 'b is set to Ind - - if 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 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 deleted file mode 100644 index 079e640807..0000000000 --- a/upstream/ocaml_413/typing/typedecl_separability.mli +++ /dev/null @@ -1,132 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 6e23ab9c66..0000000000 --- a/upstream/ocaml_413/typing/typedecl_unboxed.ml +++ /dev/null @@ -1,53 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 9afd38e879..0000000000 --- a/upstream/ocaml_413/typing/typedecl_unboxed.mli +++ /dev/null @@ -1,25 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index da5dce2b95..0000000000 --- a/upstream/ocaml_413/typing/typedecl_variance.ml +++ /dev/null @@ -1,422 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 941ab99299..0000000000 --- a/upstream/ocaml_413/typing/typedecl_variance.mli +++ /dev/null @@ -1,63 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 5a82ba7e70..0000000000 --- a/upstream/ocaml_413/typing/typedtree.ml +++ /dev/null @@ -1,844 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 551542517b..0000000000 --- a/upstream/ocaml_413/typing/typedtree.mli +++ /dev/null @@ -1,822 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 3eecba5488..0000000000 --- a/upstream/ocaml_413/typing/typemod.ml +++ /dev/null @@ -1,3205 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "@[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 - "@[\ - @[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 - "@[\ - @[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 - "@[\ - @[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 - "@[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 - "@[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 - "@[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 deleted file mode 100644 index 7507416604..0000000000 --- a/upstream/ocaml_413/typing/typemod.mli +++ /dev/null @@ -1,139 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 9ac86c8286..0000000000 --- a/upstream/ocaml_413/typing/typeopt.ml +++ /dev/null @@ -1,216 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 0f6b9f373f..0000000000 --- a/upstream/ocaml_413/typing/typeopt.mli +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index fa8e452ec2..0000000000 --- a/upstream/ocaml_413/typing/types.ml +++ /dev/null @@ -1,479 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "" - | Predef name -> Format.fprintf fmt "" 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 deleted file mode 100644 index 1fa3483523..0000000000 --- a/upstream/ocaml_413/typing/types.mli +++ /dev/null @@ -1,589 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index b1a908a411..0000000000 --- a/upstream/ocaml_413/typing/typetexp.ml +++ /dev/null @@ -1,808 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 - "@[@[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 "@[%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 - "@[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 "@[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 deleted file mode 100644 index 609305ba06..0000000000 --- a/upstream/ocaml_413/typing/typetexp.mli +++ /dev/null @@ -1,79 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 6e54cb249c..0000000000 --- a/upstream/ocaml_413/typing/untypeast.ml +++ /dev/null @@ -1,914 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 809df9ad08..0000000000 --- a/upstream/ocaml_413/typing/untypeast.mli +++ /dev/null @@ -1,87 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 707fdfd656..0000000000 --- a/upstream/ocaml_413/utils/HACKING.adoc +++ /dev/null @@ -1,50 +0,0 @@ -== 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 deleted file mode 100644 index 5ff17f64a3..0000000000 --- a/upstream/ocaml_413/utils/Makefile +++ /dev/null @@ -1,119 +0,0 @@ -#************************************************************************** -#* * -#* 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 deleted file mode 100644 index fa80007ad4..0000000000 --- a/upstream/ocaml_413/utils/arg_helper.ml +++ /dev/null @@ -1,127 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 18f60fea5c..0000000000 --- a/upstream/ocaml_413/utils/arg_helper.mli +++ /dev/null @@ -1,68 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 - | =[,...] - - (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 deleted file mode 100644 index cf8a53e70a..0000000000 --- a/upstream/ocaml_413/utils/binutils.ml +++ /dev/null @@ -1,684 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 44e17fec38..0000000000 --- a/upstream/ocaml_413/utils/binutils.mli +++ /dev/null @@ -1,30 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index c204d3a6b3..0000000000 --- a/upstream/ocaml_413/utils/build_path_prefix_map.ml +++ /dev/null @@ -1,119 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index dbcc8dc16f..0000000000 --- a/upstream/ocaml_413/utils/build_path_prefix_map.mli +++ /dev/null @@ -1,47 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 955968d1cd..0000000000 --- a/upstream/ocaml_413/utils/ccomp.ml +++ /dev/null @@ -1,213 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 46f58a982e..0000000000 --- a/upstream/ocaml_413/utils/ccomp.mli +++ /dev/null @@ -1,40 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index b9f60cb086..0000000000 --- a/upstream/ocaml_413/utils/clflags.ml +++ /dev/null @@ -1,575 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 \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 deleted file mode 100644 index 06b478d3b6..0000000000 --- a/upstream/ocaml_413/utils/clflags.mli +++ /dev/null @@ -1,270 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 33dc0430b0..0000000000 --- a/upstream/ocaml_413/utils/config.mli +++ /dev/null @@ -1,266 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index bbb3c56948..0000000000 --- a/upstream/ocaml_413/utils/config.mlp +++ /dev/null @@ -1,246 +0,0 @@ -#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 deleted file mode 100644 index b3299114a4..0000000000 --- a/upstream/ocaml_413/utils/consistbl.ml +++ /dev/null @@ -1,97 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 5067addfa7..0000000000 --- a/upstream/ocaml_413/utils/consistbl.mli +++ /dev/null @@ -1,82 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index b12f101f09..0000000000 --- a/upstream/ocaml_413/utils/diffing.ml +++ /dev/null @@ -1,370 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 - 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 deleted file mode 100644 index 51f4858c7e..0000000000 --- a/upstream/ocaml_413/utils/diffing.mli +++ /dev/null @@ -1,112 +0,0 @@ - -(**************************************************************************) -(* *) -(* 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 ). - - 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 deleted file mode 100644 index 7ece1ad851..0000000000 --- a/upstream/ocaml_413/utils/domainstate.ml.c +++ /dev/null @@ -1,34 +0,0 @@ -/**************************************************************************/ -/* */ -/* 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 deleted file mode 100644 index 1da60c94aa..0000000000 --- a/upstream/ocaml_413/utils/domainstate.mli.c +++ /dev/null @@ -1,22 +0,0 @@ -/**************************************************************************/ -/* */ -/* 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 deleted file mode 100644 index 9bbfb65733..0000000000 --- a/upstream/ocaml_413/utils/identifiable.ml +++ /dev/null @@ -1,249 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 0da5a66191..0000000000 --- a/upstream/ocaml_413/utils/identifiable.mli +++ /dev/null @@ -1,113 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 7cd6bf1099..0000000000 --- a/upstream/ocaml_413/utils/int_replace_polymorphic_compare.ml +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 index 689e741b66..0000000000 --- a/upstream/ocaml_413/utils/int_replace_polymorphic_compare.mli +++ /dev/null @@ -1,8 +0,0 @@ -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 deleted file mode 100644 index a867013215..0000000000 --- a/upstream/ocaml_413/utils/lazy_backtrack.ml +++ /dev/null @@ -1,81 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index b3673be47b..0000000000 --- a/upstream/ocaml_413/utils/lazy_backtrack.mli +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 2b1d02654b..0000000000 --- a/upstream/ocaml_413/utils/load_path.ml +++ /dev/null @@ -1,124 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 1f9aba28bf..0000000000 --- a/upstream/ocaml_413/utils/load_path.mli +++ /dev/null @@ -1,75 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 4babf61d82..0000000000 --- a/upstream/ocaml_413/utils/local_store.ml +++ /dev/null @@ -1,74 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index f39cd12328..0000000000 --- a/upstream/ocaml_413/utils/local_store.mli +++ /dev/null @@ -1,66 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index c5bfadfdc0..0000000000 --- a/upstream/ocaml_413/utils/misc.ml +++ /dev/null @@ -1,1118 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 "@["; - 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 deleted file mode 100644 index 741ebf73f1..0000000000 --- a/upstream/ocaml_413/utils/misc.mli +++ /dev/null @@ -1,667 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 1680675bab..0000000000 --- a/upstream/ocaml_413/utils/numbers.ml +++ /dev/null @@ -1,88 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index fa565e67e1..0000000000 --- a/upstream/ocaml_413/utils/numbers.mli +++ /dev/null @@ -1,51 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 27c92a5463..0000000000 --- a/upstream/ocaml_413/utils/profile.ml +++ /dev/null @@ -1,335 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 7eff6957b6..0000000000 --- a/upstream/ocaml_413/utils/profile.mli +++ /dev/null @@ -1,49 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index eb1501ca7c..0000000000 --- a/upstream/ocaml_413/utils/strongly_connected_components.ml +++ /dev/null @@ -1,195 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index e700952792..0000000000 --- a/upstream/ocaml_413/utils/strongly_connected_components.mli +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 9d15a2ff56..0000000000 --- a/upstream/ocaml_413/utils/targetint.ml +++ /dev/null @@ -1,104 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 72d464d215..0000000000 --- a/upstream/ocaml_413/utils/targetint.mli +++ /dev/null @@ -1,207 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 1b4a3578eb..0000000000 --- a/upstream/ocaml_413/utils/terminfo.ml +++ /dev/null @@ -1,45 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index 10f5f5453f..0000000000 --- a/upstream/ocaml_413/utils/terminfo.mli +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 deleted file mode 100644 index d19874bcec..0000000000 --- a/upstream/ocaml_413/utils/warnings.ml +++ /dev/null @@ -1,1032 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 - "@[@[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 ' -> .'" - | 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 deleted file mode 100644 index 0430b89f0b..0000000000 --- a/upstream/ocaml_413/utils/warnings.mli +++ /dev/null @@ -1,153 +0,0 @@ -(**************************************************************************) -(* *) -(* 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. *) From 46a480bfabbf2caf78bc29bb0bbab4948f2bc567 Mon Sep 17 00:00:00 2001 From: Thomas Refis Date: Fri, 4 Mar 2022 16:03:42 +0100 Subject: [PATCH 002/130] upstream: add 5.00 --- upstream/ocaml_500/base-rev.txt | 1 + upstream/ocaml_500/file_formats/cmi_format.ml | 117 + .../ocaml_500/file_formats/cmi_format.mli | 50 + .../ocaml_500/file_formats/cmo_format.mli | 68 + upstream/ocaml_500/file_formats/cmt_format.ml | 198 + .../ocaml_500/file_formats/cmt_format.mli | 126 + .../ocaml_500/file_formats/cmx_format.mli | 58 + .../ocaml_500/file_formats/cmxs_format.mli | 35 + .../ocaml_500/file_formats/linear_format.ml | 101 + .../ocaml_500/file_formats/linear_format.mli | 38 + upstream/ocaml_500/parsing/CONFLICTS.md | 54 + upstream/ocaml_500/parsing/ast_helper.ml | 644 ++ upstream/ocaml_500/parsing/ast_helper.mli | 495 ++ upstream/ocaml_500/parsing/ast_invariants.ml | 191 + upstream/ocaml_500/parsing/ast_invariants.mli | 23 + upstream/ocaml_500/parsing/ast_iterator.ml | 686 ++ upstream/ocaml_500/parsing/ast_iterator.mli | 83 + upstream/ocaml_500/parsing/ast_mapper.ml | 1080 +++ upstream/ocaml_500/parsing/ast_mapper.mli | 208 + upstream/ocaml_500/parsing/asttypes.mli | 67 + upstream/ocaml_500/parsing/attr_helper.ml | 54 + upstream/ocaml_500/parsing/attr_helper.mli | 41 + .../ocaml_500/parsing/builtin_attributes.ml | 289 + .../ocaml_500/parsing/builtin_attributes.mli | 84 + upstream/ocaml_500/parsing/depend.ml | 594 ++ upstream/ocaml_500/parsing/depend.mli | 45 + upstream/ocaml_500/parsing/docstrings.ml | 425 ++ upstream/ocaml_500/parsing/docstrings.mli | 223 + upstream/ocaml_500/parsing/lexer.mli | 64 + upstream/ocaml_500/parsing/lexer.mll | 869 +++ upstream/ocaml_500/parsing/location.ml | 952 +++ upstream/ocaml_500/parsing/location.mli | 287 + upstream/ocaml_500/parsing/longident.ml | 50 + upstream/ocaml_500/parsing/longident.mli | 58 + upstream/ocaml_500/parsing/parse.ml | 149 + upstream/ocaml_500/parsing/parse.mli | 110 + upstream/ocaml_500/parsing/parser.mly | 3885 +++++++++++ upstream/ocaml_500/parsing/parsetree.mli | 983 +++ upstream/ocaml_500/parsing/pprintast.ml | 1716 +++++ upstream/ocaml_500/parsing/pprintast.mli | 55 + upstream/ocaml_500/parsing/printast.ml | 963 +++ upstream/ocaml_500/parsing/printast.mli | 32 + upstream/ocaml_500/parsing/syntaxerr.ml | 43 + upstream/ocaml_500/parsing/syntaxerr.mli | 37 + upstream/ocaml_500/typing/annot.mli | 23 + upstream/ocaml_500/typing/btype.ml | 771 +++ upstream/ocaml_500/typing/btype.mli | 315 + upstream/ocaml_500/typing/cmt2annot.ml | 184 + upstream/ocaml_500/typing/ctype.ml | 5434 +++++++++++++++ upstream/ocaml_500/typing/ctype.mli | 426 ++ upstream/ocaml_500/typing/datarepr.ml | 238 + upstream/ocaml_500/typing/datarepr.mli | 45 + upstream/ocaml_500/typing/env.ml | 3667 ++++++++++ upstream/ocaml_500/typing/env.mli | 508 ++ upstream/ocaml_500/typing/envaux.ml | 115 + upstream/ocaml_500/typing/envaux.mli | 36 + upstream/ocaml_500/typing/errortrace.ml | 194 + upstream/ocaml_500/typing/errortrace.mli | 168 + upstream/ocaml_500/typing/ident.ml | 360 + upstream/ocaml_500/typing/ident.mli | 80 + upstream/ocaml_500/typing/includeclass.ml | 116 + upstream/ocaml_500/typing/includeclass.mli | 33 + upstream/ocaml_500/typing/includecore.ml | 993 +++ upstream/ocaml_500/typing/includecore.mli | 131 + upstream/ocaml_500/typing/includemod.ml | 1238 ++++ upstream/ocaml_500/typing/includemod.mli | 252 + .../typing/includemod_errorprinter.ml | 926 +++ .../typing/includemod_errorprinter.mli | 17 + upstream/ocaml_500/typing/mtype.ml | 558 ++ upstream/ocaml_500/typing/mtype.mli | 55 + upstream/ocaml_500/typing/oprint.ml | 848 +++ upstream/ocaml_500/typing/oprint.mli | 35 + upstream/ocaml_500/typing/outcometree.mli | 156 + upstream/ocaml_500/typing/parmatch.ml | 2482 +++++++ upstream/ocaml_500/typing/parmatch.mli | 134 + upstream/ocaml_500/typing/path.ml | 129 + upstream/ocaml_500/typing/path.mli | 52 + upstream/ocaml_500/typing/patterns.ml | 254 + upstream/ocaml_500/typing/patterns.mli | 109 + upstream/ocaml_500/typing/persistent_env.ml | 359 + upstream/ocaml_500/typing/persistent_env.mli | 104 + upstream/ocaml_500/typing/predef.ml | 259 + upstream/ocaml_500/typing/predef.mli | 87 + upstream/ocaml_500/typing/primitive.ml | 251 + upstream/ocaml_500/typing/primitive.mli | 79 + upstream/ocaml_500/typing/printpat.ml | 169 + upstream/ocaml_500/typing/printpat.mli | 27 + upstream/ocaml_500/typing/printtyp.ml | 2533 +++++++ upstream/ocaml_500/typing/printtyp.mli | 241 + upstream/ocaml_500/typing/printtyped.ml | 954 +++ upstream/ocaml_500/typing/printtyped.mli | 23 + upstream/ocaml_500/typing/rec_check.ml | 1260 ++++ upstream/ocaml_500/typing/rec_check.mli | 19 + upstream/ocaml_500/typing/shape.ml | 521 ++ upstream/ocaml_500/typing/shape.mli | 157 + upstream/ocaml_500/typing/signature_group.ml | 155 + upstream/ocaml_500/typing/signature_group.mli | 85 + upstream/ocaml_500/typing/stypes.ml | 195 + upstream/ocaml_500/typing/stypes.mli | 35 + upstream/ocaml_500/typing/subst.ml | 766 +++ upstream/ocaml_500/typing/subst.mli | 152 + upstream/ocaml_500/typing/tast_iterator.ml | 515 ++ upstream/ocaml_500/typing/tast_iterator.mli | 68 + upstream/ocaml_500/typing/tast_mapper.ml | 748 +++ upstream/ocaml_500/typing/tast_mapper.mli | 72 + upstream/ocaml_500/typing/type_immediacy.ml | 43 + upstream/ocaml_500/typing/type_immediacy.mli | 40 + upstream/ocaml_500/typing/typeclass.ml | 2136 ++++++ upstream/ocaml_500/typing/typeclass.mli | 136 + upstream/ocaml_500/typing/typecore.ml | 5931 +++++++++++++++++ upstream/ocaml_500/typing/typecore.mli | 250 + upstream/ocaml_500/typing/typedecl.ml | 1915 ++++++ upstream/ocaml_500/typing/typedecl.mli | 106 + .../ocaml_500/typing/typedecl_immediacy.ml | 67 + .../ocaml_500/typing/typedecl_immediacy.mli | 27 + .../ocaml_500/typing/typedecl_properties.ml | 73 + .../ocaml_500/typing/typedecl_properties.mli | 55 + .../ocaml_500/typing/typedecl_separability.ml | 668 ++ .../typing/typedecl_separability.mli | 132 + upstream/ocaml_500/typing/typedecl_unboxed.ml | 43 + .../ocaml_500/typing/typedecl_unboxed.mli | 20 + .../ocaml_500/typing/typedecl_variance.ml | 418 ++ .../ocaml_500/typing/typedecl_variance.mli | 63 + upstream/ocaml_500/typing/typedtree.ml | 847 +++ upstream/ocaml_500/typing/typedtree.mli | 826 +++ upstream/ocaml_500/typing/typemod.ml | 3343 ++++++++++ upstream/ocaml_500/typing/typemod.mli | 140 + upstream/ocaml_500/typing/typeopt.ml | 231 + upstream/ocaml_500/typing/typeopt.mli | 43 + upstream/ocaml_500/typing/types.ml | 860 +++ upstream/ocaml_500/typing/types.mli | 725 ++ upstream/ocaml_500/typing/typetexp.ml | 818 +++ upstream/ocaml_500/typing/typetexp.mli | 93 + upstream/ocaml_500/typing/untypeast.ml | 916 +++ upstream/ocaml_500/typing/untypeast.mli | 87 + upstream/ocaml_500/utils/Makefile | 118 + upstream/ocaml_500/utils/arg_helper.ml | 127 + upstream/ocaml_500/utils/arg_helper.mli | 68 + upstream/ocaml_500/utils/binutils.ml | 684 ++ upstream/ocaml_500/utils/binutils.mli | 30 + .../ocaml_500/utils/build_path_prefix_map.ml | 119 + .../ocaml_500/utils/build_path_prefix_map.mli | 47 + upstream/ocaml_500/utils/ccomp.ml | 213 + upstream/ocaml_500/utils/ccomp.mli | 40 + upstream/ocaml_500/utils/clflags.ml | 578 ++ upstream/ocaml_500/utils/clflags.mli | 273 + upstream/ocaml_500/utils/config.mli | 263 + upstream/ocaml_500/utils/config.mlp | 248 + upstream/ocaml_500/utils/consistbl.ml | 97 + upstream/ocaml_500/utils/consistbl.mli | 82 + upstream/ocaml_500/utils/diffing.ml | 447 ++ upstream/ocaml_500/utils/diffing.mli | 148 + upstream/ocaml_500/utils/diffing_with_keys.ml | 208 + .../ocaml_500/utils/diffing_with_keys.mli | 77 + upstream/ocaml_500/utils/domainstate.ml.c | 38 + upstream/ocaml_500/utils/domainstate.mli.c | 24 + upstream/ocaml_500/utils/identifiable.ml | 249 + upstream/ocaml_500/utils/identifiable.mli | 113 + .../utils/int_replace_polymorphic_compare.ml | 8 + .../utils/int_replace_polymorphic_compare.mli | 8 + upstream/ocaml_500/utils/lazy_backtrack.ml | 87 + upstream/ocaml_500/utils/lazy_backtrack.mli | 34 + upstream/ocaml_500/utils/load_path.ml | 124 + upstream/ocaml_500/utils/load_path.mli | 75 + upstream/ocaml_500/utils/local_store.ml | 74 + upstream/ocaml_500/utils/local_store.mli | 66 + upstream/ocaml_500/utils/misc.ml | 1125 ++++ upstream/ocaml_500/utils/misc.mli | 672 ++ upstream/ocaml_500/utils/misc.mli.orig | 673 ++ upstream/ocaml_500/utils/numbers.ml | 88 + upstream/ocaml_500/utils/numbers.mli | 51 + upstream/ocaml_500/utils/profile.ml | 335 + upstream/ocaml_500/utils/profile.mli | 49 + .../utils/strongly_connected_components.ml | 195 + .../utils/strongly_connected_components.mli | 43 + upstream/ocaml_500/utils/targetint.ml | 104 + upstream/ocaml_500/utils/targetint.mli | 208 + upstream/ocaml_500/utils/terminfo.ml | 45 + upstream/ocaml_500/utils/terminfo.mli | 32 + upstream/ocaml_500/utils/warnings.ml | 1131 ++++ upstream/ocaml_500/utils/warnings.ml.orig | 1137 ++++ upstream/ocaml_500/utils/warnings.mli | 162 + 182 files changed, 79116 insertions(+) create mode 100644 upstream/ocaml_500/base-rev.txt create mode 100644 upstream/ocaml_500/file_formats/cmi_format.ml create mode 100644 upstream/ocaml_500/file_formats/cmi_format.mli create mode 100644 upstream/ocaml_500/file_formats/cmo_format.mli create mode 100644 upstream/ocaml_500/file_formats/cmt_format.ml create mode 100644 upstream/ocaml_500/file_formats/cmt_format.mli create mode 100644 upstream/ocaml_500/file_formats/cmx_format.mli create mode 100644 upstream/ocaml_500/file_formats/cmxs_format.mli create mode 100644 upstream/ocaml_500/file_formats/linear_format.ml create mode 100644 upstream/ocaml_500/file_formats/linear_format.mli create mode 100644 upstream/ocaml_500/parsing/CONFLICTS.md create mode 100644 upstream/ocaml_500/parsing/ast_helper.ml create mode 100644 upstream/ocaml_500/parsing/ast_helper.mli create mode 100644 upstream/ocaml_500/parsing/ast_invariants.ml create mode 100644 upstream/ocaml_500/parsing/ast_invariants.mli create mode 100644 upstream/ocaml_500/parsing/ast_iterator.ml create mode 100644 upstream/ocaml_500/parsing/ast_iterator.mli create mode 100644 upstream/ocaml_500/parsing/ast_mapper.ml create mode 100644 upstream/ocaml_500/parsing/ast_mapper.mli create mode 100644 upstream/ocaml_500/parsing/asttypes.mli create mode 100644 upstream/ocaml_500/parsing/attr_helper.ml create mode 100644 upstream/ocaml_500/parsing/attr_helper.mli create mode 100644 upstream/ocaml_500/parsing/builtin_attributes.ml create mode 100644 upstream/ocaml_500/parsing/builtin_attributes.mli create mode 100644 upstream/ocaml_500/parsing/depend.ml create mode 100644 upstream/ocaml_500/parsing/depend.mli create mode 100644 upstream/ocaml_500/parsing/docstrings.ml create mode 100644 upstream/ocaml_500/parsing/docstrings.mli create mode 100644 upstream/ocaml_500/parsing/lexer.mli create mode 100644 upstream/ocaml_500/parsing/lexer.mll create mode 100644 upstream/ocaml_500/parsing/location.ml create mode 100644 upstream/ocaml_500/parsing/location.mli create mode 100644 upstream/ocaml_500/parsing/longident.ml create mode 100644 upstream/ocaml_500/parsing/longident.mli create mode 100644 upstream/ocaml_500/parsing/parse.ml create mode 100644 upstream/ocaml_500/parsing/parse.mli create mode 100644 upstream/ocaml_500/parsing/parser.mly create mode 100644 upstream/ocaml_500/parsing/parsetree.mli create mode 100644 upstream/ocaml_500/parsing/pprintast.ml create mode 100644 upstream/ocaml_500/parsing/pprintast.mli create mode 100644 upstream/ocaml_500/parsing/printast.ml create mode 100644 upstream/ocaml_500/parsing/printast.mli create mode 100644 upstream/ocaml_500/parsing/syntaxerr.ml create mode 100644 upstream/ocaml_500/parsing/syntaxerr.mli create mode 100644 upstream/ocaml_500/typing/annot.mli create mode 100644 upstream/ocaml_500/typing/btype.ml create mode 100644 upstream/ocaml_500/typing/btype.mli create mode 100644 upstream/ocaml_500/typing/cmt2annot.ml create mode 100644 upstream/ocaml_500/typing/ctype.ml create mode 100644 upstream/ocaml_500/typing/ctype.mli create mode 100644 upstream/ocaml_500/typing/datarepr.ml create mode 100644 upstream/ocaml_500/typing/datarepr.mli create mode 100644 upstream/ocaml_500/typing/env.ml create mode 100644 upstream/ocaml_500/typing/env.mli create mode 100644 upstream/ocaml_500/typing/envaux.ml create mode 100644 upstream/ocaml_500/typing/envaux.mli create mode 100644 upstream/ocaml_500/typing/errortrace.ml create mode 100644 upstream/ocaml_500/typing/errortrace.mli create mode 100644 upstream/ocaml_500/typing/ident.ml create mode 100644 upstream/ocaml_500/typing/ident.mli create mode 100644 upstream/ocaml_500/typing/includeclass.ml create mode 100644 upstream/ocaml_500/typing/includeclass.mli create mode 100644 upstream/ocaml_500/typing/includecore.ml create mode 100644 upstream/ocaml_500/typing/includecore.mli create mode 100644 upstream/ocaml_500/typing/includemod.ml create mode 100644 upstream/ocaml_500/typing/includemod.mli create mode 100644 upstream/ocaml_500/typing/includemod_errorprinter.ml create mode 100644 upstream/ocaml_500/typing/includemod_errorprinter.mli create mode 100644 upstream/ocaml_500/typing/mtype.ml create mode 100644 upstream/ocaml_500/typing/mtype.mli create mode 100644 upstream/ocaml_500/typing/oprint.ml create mode 100644 upstream/ocaml_500/typing/oprint.mli create mode 100644 upstream/ocaml_500/typing/outcometree.mli create mode 100644 upstream/ocaml_500/typing/parmatch.ml create mode 100644 upstream/ocaml_500/typing/parmatch.mli create mode 100644 upstream/ocaml_500/typing/path.ml create mode 100644 upstream/ocaml_500/typing/path.mli create mode 100644 upstream/ocaml_500/typing/patterns.ml create mode 100644 upstream/ocaml_500/typing/patterns.mli create mode 100644 upstream/ocaml_500/typing/persistent_env.ml create mode 100644 upstream/ocaml_500/typing/persistent_env.mli create mode 100644 upstream/ocaml_500/typing/predef.ml create mode 100644 upstream/ocaml_500/typing/predef.mli create mode 100644 upstream/ocaml_500/typing/primitive.ml create mode 100644 upstream/ocaml_500/typing/primitive.mli create mode 100644 upstream/ocaml_500/typing/printpat.ml create mode 100644 upstream/ocaml_500/typing/printpat.mli create mode 100644 upstream/ocaml_500/typing/printtyp.ml create mode 100644 upstream/ocaml_500/typing/printtyp.mli create mode 100644 upstream/ocaml_500/typing/printtyped.ml create mode 100644 upstream/ocaml_500/typing/printtyped.mli create mode 100644 upstream/ocaml_500/typing/rec_check.ml create mode 100644 upstream/ocaml_500/typing/rec_check.mli create mode 100644 upstream/ocaml_500/typing/shape.ml create mode 100644 upstream/ocaml_500/typing/shape.mli create mode 100644 upstream/ocaml_500/typing/signature_group.ml create mode 100644 upstream/ocaml_500/typing/signature_group.mli create mode 100644 upstream/ocaml_500/typing/stypes.ml create mode 100644 upstream/ocaml_500/typing/stypes.mli create mode 100644 upstream/ocaml_500/typing/subst.ml create mode 100644 upstream/ocaml_500/typing/subst.mli create mode 100644 upstream/ocaml_500/typing/tast_iterator.ml create mode 100644 upstream/ocaml_500/typing/tast_iterator.mli create mode 100644 upstream/ocaml_500/typing/tast_mapper.ml create mode 100644 upstream/ocaml_500/typing/tast_mapper.mli create mode 100644 upstream/ocaml_500/typing/type_immediacy.ml create mode 100644 upstream/ocaml_500/typing/type_immediacy.mli create mode 100644 upstream/ocaml_500/typing/typeclass.ml create mode 100644 upstream/ocaml_500/typing/typeclass.mli create mode 100644 upstream/ocaml_500/typing/typecore.ml create mode 100644 upstream/ocaml_500/typing/typecore.mli create mode 100644 upstream/ocaml_500/typing/typedecl.ml create mode 100644 upstream/ocaml_500/typing/typedecl.mli create mode 100644 upstream/ocaml_500/typing/typedecl_immediacy.ml create mode 100644 upstream/ocaml_500/typing/typedecl_immediacy.mli create mode 100644 upstream/ocaml_500/typing/typedecl_properties.ml create mode 100644 upstream/ocaml_500/typing/typedecl_properties.mli create mode 100644 upstream/ocaml_500/typing/typedecl_separability.ml create mode 100644 upstream/ocaml_500/typing/typedecl_separability.mli create mode 100644 upstream/ocaml_500/typing/typedecl_unboxed.ml create mode 100644 upstream/ocaml_500/typing/typedecl_unboxed.mli create mode 100644 upstream/ocaml_500/typing/typedecl_variance.ml create mode 100644 upstream/ocaml_500/typing/typedecl_variance.mli create mode 100644 upstream/ocaml_500/typing/typedtree.ml create mode 100644 upstream/ocaml_500/typing/typedtree.mli create mode 100644 upstream/ocaml_500/typing/typemod.ml create mode 100644 upstream/ocaml_500/typing/typemod.mli create mode 100644 upstream/ocaml_500/typing/typeopt.ml create mode 100644 upstream/ocaml_500/typing/typeopt.mli create mode 100644 upstream/ocaml_500/typing/types.ml create mode 100644 upstream/ocaml_500/typing/types.mli create mode 100644 upstream/ocaml_500/typing/typetexp.ml create mode 100644 upstream/ocaml_500/typing/typetexp.mli create mode 100644 upstream/ocaml_500/typing/untypeast.ml create mode 100644 upstream/ocaml_500/typing/untypeast.mli create mode 100644 upstream/ocaml_500/utils/Makefile create mode 100644 upstream/ocaml_500/utils/arg_helper.ml create mode 100644 upstream/ocaml_500/utils/arg_helper.mli create mode 100644 upstream/ocaml_500/utils/binutils.ml create mode 100644 upstream/ocaml_500/utils/binutils.mli create mode 100644 upstream/ocaml_500/utils/build_path_prefix_map.ml create mode 100644 upstream/ocaml_500/utils/build_path_prefix_map.mli create mode 100644 upstream/ocaml_500/utils/ccomp.ml create mode 100644 upstream/ocaml_500/utils/ccomp.mli create mode 100644 upstream/ocaml_500/utils/clflags.ml create mode 100644 upstream/ocaml_500/utils/clflags.mli create mode 100644 upstream/ocaml_500/utils/config.mli create mode 100644 upstream/ocaml_500/utils/config.mlp create mode 100644 upstream/ocaml_500/utils/consistbl.ml create mode 100644 upstream/ocaml_500/utils/consistbl.mli create mode 100644 upstream/ocaml_500/utils/diffing.ml create mode 100644 upstream/ocaml_500/utils/diffing.mli create mode 100644 upstream/ocaml_500/utils/diffing_with_keys.ml create mode 100644 upstream/ocaml_500/utils/diffing_with_keys.mli create mode 100644 upstream/ocaml_500/utils/domainstate.ml.c create mode 100644 upstream/ocaml_500/utils/domainstate.mli.c create mode 100644 upstream/ocaml_500/utils/identifiable.ml create mode 100644 upstream/ocaml_500/utils/identifiable.mli create mode 100644 upstream/ocaml_500/utils/int_replace_polymorphic_compare.ml create mode 100644 upstream/ocaml_500/utils/int_replace_polymorphic_compare.mli create mode 100644 upstream/ocaml_500/utils/lazy_backtrack.ml create mode 100644 upstream/ocaml_500/utils/lazy_backtrack.mli create mode 100644 upstream/ocaml_500/utils/load_path.ml create mode 100644 upstream/ocaml_500/utils/load_path.mli create mode 100644 upstream/ocaml_500/utils/local_store.ml create mode 100644 upstream/ocaml_500/utils/local_store.mli create mode 100644 upstream/ocaml_500/utils/misc.ml create mode 100644 upstream/ocaml_500/utils/misc.mli create mode 100644 upstream/ocaml_500/utils/misc.mli.orig create mode 100644 upstream/ocaml_500/utils/numbers.ml create mode 100644 upstream/ocaml_500/utils/numbers.mli create mode 100644 upstream/ocaml_500/utils/profile.ml create mode 100644 upstream/ocaml_500/utils/profile.mli create mode 100644 upstream/ocaml_500/utils/strongly_connected_components.ml create mode 100644 upstream/ocaml_500/utils/strongly_connected_components.mli create mode 100644 upstream/ocaml_500/utils/targetint.ml create mode 100644 upstream/ocaml_500/utils/targetint.mli create mode 100644 upstream/ocaml_500/utils/terminfo.ml create mode 100644 upstream/ocaml_500/utils/terminfo.mli create mode 100644 upstream/ocaml_500/utils/warnings.ml create mode 100644 upstream/ocaml_500/utils/warnings.ml.orig create mode 100644 upstream/ocaml_500/utils/warnings.mli diff --git a/upstream/ocaml_500/base-rev.txt b/upstream/ocaml_500/base-rev.txt new file mode 100644 index 0000000000..767843f768 --- /dev/null +++ b/upstream/ocaml_500/base-rev.txt @@ -0,0 +1 @@ +c3a5ebd4926ac0c8cde7c512fa1f350134b27b58 diff --git a/upstream/ocaml_500/file_formats/cmi_format.ml b/upstream/ocaml_500/file_formats/cmi_format.ml new file mode 100644 index 0000000000..bd82cc3761 --- /dev/null +++ b/upstream/ocaml_500/file_formats/cmi_format.ml @@ -0,0 +1,117 @@ +(**************************************************************************) +(* *) +(* 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 + +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_500/file_formats/cmi_format.mli b/upstream/ocaml_500/file_formats/cmi_format.mli new file mode 100644 index 0000000000..2a63deb3dc --- /dev/null +++ b/upstream/ocaml_500/file_formats/cmi_format.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* 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 + +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_500/file_formats/cmo_format.mli b/upstream/ocaml_500/file_formats/cmo_format.mli new file mode 100644 index 0000000000..0952157b37 --- /dev/null +++ b/upstream/ocaml_500/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_500/file_formats/cmt_format.ml b/upstream/ocaml_500/file_formats/cmt_format.ml new file mode 100644 index 0000000000..a493780e5a --- /dev/null +++ b/upstream/ocaml_500/file_formats/cmt_format.ml @@ -0,0 +1,198 @@ +(**************************************************************************) +(* *) +(* 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; + cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_impl_shape : Shape.t option; (* None for mli *) +} + +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 shape = + 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; + cmt_uid_to_loc = Env.get_uid_to_loc_tbl (); + cmt_impl_shape = shape; + } in + output_cmt oc cmt) + end; + clear () diff --git a/upstream/ocaml_500/file_formats/cmt_format.mli b/upstream/ocaml_500/file_formats/cmt_format.mli new file mode 100644 index 0000000000..43e09f1236 --- /dev/null +++ b/upstream/ocaml_500/file_formats/cmt_format.mli @@ -0,0 +1,126 @@ +(**************************************************************************) +(* *) +(* 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 infos\} \{\} + where is the cmi file format: + := . + More precisely, the optional 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; + cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_impl_shape : Shape.t option; (* None for mli *) +} + +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 *) + Shape.t option -> + 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_500/file_formats/cmx_format.mli b/upstream/ocaml_500/file_formats/cmx_format.mli new file mode 100644 index 0000000000..91ad2d1ff1 --- /dev/null +++ b/upstream/ocaml_500/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_500/file_formats/cmxs_format.mli b/upstream/ocaml_500/file_formats/cmxs_format.mli new file mode 100644 index 0000000000..c670024f92 --- /dev/null +++ b/upstream/ocaml_500/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_500/file_formats/linear_format.ml b/upstream/ocaml_500/file_formats/linear_format.ml new file mode 100644 index 0000000000..5525a69707 --- /dev/null +++ b/upstream/ocaml_500/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_500/file_formats/linear_format.mli b/upstream/ocaml_500/file_formats/linear_format.mli new file mode 100644 index 0000000000..766db5db24 --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/CONFLICTS.md b/upstream/ocaml_500/parsing/CONFLICTS.md new file mode 100644 index 0000000000..b2a84fcbc3 --- /dev/null +++ b/upstream/ocaml_500/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 -> +``` + +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_500/parsing/ast_helper.ml b/upstream/ocaml_500/parsing/ast_helper.ml new file mode 100644 index 0000000000..a1da7df974 --- /dev/null +++ b/upstream/ocaml_500/parsing/ast_helper.ml @@ -0,0 +1,644 @@ +(**************************************************************************) +(* *) +(* 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) + ?(vars = []) ?(args = Pcstr_tuple []) ?res name = + { + pcd_name = name; + pcd_vars = vars; + 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) ?(vars = []) ?(args = Pcstr_tuple []) ?res name = + { + pext_name = name; + pext_kind = Pext_decl(vars, 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_500/parsing/ast_helper.mli b/upstream/ocaml_500/parsing/ast_helper.mli new file mode 100644 index 0000000000..8e778e8c43 --- /dev/null +++ b/upstream/ocaml_500/parsing/ast_helper.mli @@ -0,0 +1,495 @@ +(**************************************************************************) +(* *) +(* 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 -> + ?vars:str list -> ?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 -> + ?vars:str list -> ?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_500/parsing/ast_invariants.ml b/upstream/ocaml_500/parsing/ast_invariants.ml new file mode 100644 index 0000000000..d9b83c0edd --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/ast_invariants.mli b/upstream/ocaml_500/parsing/ast_invariants.mli new file mode 100644 index 0000000000..fdb56aa5ef --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/ast_iterator.ml b/upstream/ocaml_500/parsing/ast_iterator.ml new file mode 100644 index 0000000000..468baedce0 --- /dev/null +++ b/upstream/ocaml_500/parsing/ast_iterator.ml @@ -0,0 +1,686 @@ +(**************************************************************************) +(* *) +(* 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(vars, ctl, cto) -> + List.iter (iter_loc sub) vars; + 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_vars; pcd_args; + pcd_res; pcd_loc; pcd_attributes} -> + iter_loc this pcd_name; + List.iter (iter_loc this) pcd_vars; + 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_500/parsing/ast_iterator.mli b/upstream/ocaml_500/parsing/ast_iterator.mli new file mode 100644 index 0000000000..26308d20de --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/ast_mapper.ml b/upstream/ocaml_500/parsing/ast_mapper.ml new file mode 100644 index 0000000000..f6c992ba45 --- /dev/null +++ b/upstream/ocaml_500/parsing/ast_mapper.ml @@ -0,0 +1,1080 @@ +(**************************************************************************) +(* *) +(* 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(vars, ctl, cto) -> + Pext_decl(List.map (map_loc sub) vars, + 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_vars; pcd_args; + pcd_res; pcd_loc; pcd_attributes} -> + Type.constructor + (map_loc this pcd_name) + ~vars:(List.map (map_loc this) pcd_vars) + ~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 false; (* kept for compatibility *) + 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 + | "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] \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_500/parsing/ast_mapper.mli b/upstream/ocaml_500/parsing/ast_mapper.mli new file mode 100644 index 0000000000..69f6b017ab --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/asttypes.mli b/upstream/ocaml_500/parsing/asttypes.mli new file mode 100644 index 0000000000..f4745fb7ab --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/attr_helper.ml b/upstream/ocaml_500/parsing/attr_helper.ml new file mode 100644 index 0000000000..0a616cd746 --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/attr_helper.mli b/upstream/ocaml_500/parsing/attr_helper.mli new file mode 100644 index 0000000000..a3ddc0c9cb --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/builtin_attributes.ml b/upstream/ocaml_500/parsing/builtin_attributes.ml new file mode 100644 index 0000000000..c90542567a --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/builtin_attributes.mli b/upstream/ocaml_500/parsing/builtin_attributes.mli new file mode 100644 index 0000000000..6200fd74ec --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/depend.ml b/upstream/ocaml_500/parsing/depend.ml new file mode 100644 index 0000000000..55b4f410cd --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/depend.mli b/upstream/ocaml_500/parsing/depend.mli new file mode 100644 index 0000000000..74c095f969 --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/docstrings.ml b/upstream/ocaml_500/parsing/docstrings.ml new file mode 100644 index 0000000000..a39f75d259 --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/docstrings.mli b/upstream/ocaml_500/parsing/docstrings.mli new file mode 100644 index 0000000000..bf2508fdc4 --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/lexer.mli b/upstream/ocaml_500/parsing/lexer.mli new file mode 100644 index 0000000000..b5d3a96ac1 --- /dev/null +++ b/upstream/ocaml_500/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 + | 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_500/parsing/lexer.mll b/upstream/ocaml_500/parsing/lexer.mll new file mode 100644 index 0000000000..3ca816800d --- /dev/null +++ b/upstream/ocaml_500/parsing/lexer.mll @@ -0,0 +1,869 @@ +(**************************************************************************) +(* *) +(* 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_500/parsing/location.ml b/upstream/ocaml_500/parsing/location.ml new file mode 100644 index 0000000000..209797a3f5 --- /dev/null +++ b/upstream/ocaml_500/parsing/location.ml @@ -0,0 +1,952 @@ +(**************************************************************************) +(* *) +(* 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 "@{"; + + 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 "@["; + 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) ""; + String.iteri (fun i c -> + let pos = line_start_cnum + i in + 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 if pos < rightmost.pos_cnum then begin + (* For alignment purposes, align using a tab for each tab in the + source code *) + if c = '\t' then Format.pp_print_char ppf '\t' + else Format.pp_print_char ppf ' ' + end; + if ISet.is_end iset ~pos <> None then + Format.fprintf ppf "@}" + ) line; + 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 "@[%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 "@[%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@}" + | Report_warning w -> Format.fprintf ppf "@{Warning@} %s" w + | Report_warning_as_error w -> + Format.fprintf ppf "@{Error@} (warning %s)" w + | Report_alert w -> Format.fprintf ppf "@{Alert@} %s" w + | Report_alert_as_error w -> + Format.fprintf ppf "@{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_500/parsing/location.mli b/upstream/ocaml_500/parsing/location.mli new file mode 100644 index 0000000000..5ba80b04da --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/longident.ml b/upstream/ocaml_500/parsing/longident.ml new file mode 100644 index 0000000000..eaafb02bee --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/longident.mli b/upstream/ocaml_500/parsing/longident.mli new file mode 100644 index 0000000000..8704a7780e --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/parse.ml b/upstream/ocaml_500/parsing/parse.ml new file mode 100644 index 0000000000..cf703060f4 --- /dev/null +++ b/upstream/ocaml_500/parsing/parse.ml @@ -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. *) +(* *) +(**************************************************************************) + +(* 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 module_type = wrap Parser.parse_module_type +let module_expr = wrap Parser.parse_module_expr + +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_500/parsing/parse.mli b/upstream/ocaml_500/parsing/parse.mli new file mode 100644 index 0000000000..0de6b48a13 --- /dev/null +++ b/upstream/ocaml_500/parsing/parse.mli @@ -0,0 +1,110 @@ +(**************************************************************************) +(* *) +(* 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 +val module_type : Lexing.lexbuf -> Parsetree.module_type +val module_expr : Lexing.lexbuf -> Parsetree.module_expr + +(** 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_500/parsing/parser.mly b/upstream/ocaml_500/parsing/parser.mly new file mode 100644 index 0000000000..f0c4bc0498 --- /dev/null +++ b/upstream/ocaml_500/parsing/parser.mly @@ -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. */ +/* */ +/**************************************************************************/ + +/* 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 -> mkexp ~loc (Pexp_constraint(e, t)) + | _, Some t -> mkexp ~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))) + +(* 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, <>] ] + * [ 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 lid = + let lid = loc_map (fun id -> Lident (Longident.last id)) lid in + Exp.mk ~loc:lid.loc (Pexp_ident lid) + +let exp_of_label lbl = + Exp.mk ~loc:lbl.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 "'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 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 INFIXOP0 "!=" (* just an example *) +%token INFIXOP1 "@" (* just an example *) +%token INFIXOP2 "+!" (* chosen with care; see above *) +%token INFIXOP3 "land" (* just an example *) +%token INFIXOP4 "**" (* just an example *) +%token DOTOP ".+" +%token LETOP "let*" (* just an example *) +%token ANDOP "and*" (* just an example *) +%token INHERIT "inherit" +%token INITIALIZER "initializer" +%token INT "42" (* just an example *) +%token 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 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 OPTLABEL "?label:" (* just an example *) +%token OR "or" +/* %token PARSER "parser" */ +%token PERCENT "%" +%token PLUS "+" +%token PLUSDOT "+." +%token PLUSEQ "+=" +%token 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 HASHOP "##" (* just an example *) +%token SIG "sig" +%token STAR "*" +%token + STRING "\"hello\"" (* just an example *) +%token + QUOTED_STRING_EXPR "{%hello|world|}" (* just an example *) +%token + 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 UIDENT "UIdent" (* just an example *) +%token UNDERSCORE "_" +%token VAL "val" +%token VIRTUAL "virtual" +%token WHEN "when" +%token WHILE "while" +%token WITH "with" +%token COMMENT "(* comment *)" +%token 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 OBJECT + 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 implementation +/* BEGIN AVOID */ +%start interface /* for interface files */ +%type interface +/* END AVOID */ +%start toplevel_phrase /* for interactive use */ +%type toplevel_phrase +%start use_file /* for the #use directive */ +%type use_file +/* BEGIN AVOID */ +%start parse_module_type +%type parse_module_type +%start parse_module_expr +%type parse_module_expr +%start parse_core_type +%type parse_core_type +%start parse_expression +%type parse_expression +%start parse_pattern +%type parse_pattern +%start parse_constr_longident +%type parse_constr_longident +%start parse_val_longident +%type parse_val_longident +%start parse_mty_longident +%type parse_mty_longident +%start parse_mod_ext_longident +%type parse_mod_ext_longident +%start parse_mod_longident +%type parse_mod_longident +%start parse_any_longident +%type 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_module_type: + module_type EOF + { $1 } +; + +parse_module_expr: + module_expr EOF + { $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 } +; +/* 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 } +; +%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) } + | OBJECT ext_attributes class_structure END + { Pexp_object $3, $2 } + | OBJECT ext_attributes class_structure error + { unclosed "object" $loc($1) "end" $loc($4) } +; +%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) } + | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN + { (Labelled label, mkexp_constraint ~loc:($startpos($2), $endpos) + (mkexpvar ~loc:$loc(label) label) ty) } + | 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 poly(core_type) EQUAL seq_expr + { let patloc = ($startpos($1), $endpos($3)) in + (ghpat ~loc:patloc + (Ppat_constraint($1, ghtyp ~loc:($loc($3)) $3)), + $5) } + | 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 constraint_loc, label, e = + match eo with + | None -> + (* No pattern; this is a pun. Desugar it. *) + $sloc, make_ghost label, exp_of_longident label + | Some e -> + ($startpos(c), $endpos), label, e + in + label, mkexp_opt_constraint ~loc:constraint_loc 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 label, e = + match oe with + | None -> + (* No expression; this is a pun. Desugar it. *) + make_ghost label, exp_of_label label + | Some e -> + label, 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 constraint_loc, 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). *) + $sloc, make_ghost label, pat_of_label label + | Some pat -> + ($startpos(octy), $endpos), label, pat + in + label, mkpat_opt_constraint ~loc:constraint_loc pat octy + } +; + +/* Value descriptions */ + +value_description: + VAL + ext = ext + attrs1 = attributes + id = mkrhs(val_ident) + COLON + ty = possibly_poly(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 = possibly_poly(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) + vars_args_res = generalized_constructor_arguments + attrs = attributes + { + let vars, args, res = vars_args_res in + let info = symbol_info $endpos in + let loc = make_loc $sloc in + cid, vars, args, res, attrs, loc, info + } +; +%inline constructor_declaration(opening): + d = generic_constructor_declaration(opening) + { + let cid, vars, args, res, attrs, loc, info = d in + Type.constructor cid ~vars ~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) + vars_args_res = generalized_constructor_arguments + attrs2 = attributes + attrs = post_item_attributes + { let vars, args, res = vars_args_res in + let loc = make_loc ($startpos, $endpos(attrs2)) in + let docs = symbol_docs $sloc in + Te.mk_exception ~attrs + (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) + , ext } +; +%inline let_exception_declaration: + mkrhs(constr_ident) generalized_constructor_arguments attributes + { let vars, args, res = $2 in + Te.decl $1 ~vars ~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 typevar_list DOT constructor_arguments MINUSGREATER atomic_type + %prec below_HASH + { ($2,$4,Some $6) } + | COLON atomic_type %prec below_HASH + { ([],Pcstr_tuple [],Some $2) } + | COLON typevar_list DOT atomic_type %prec below_HASH + { ($2,Pcstr_tuple [],Some $4) } +; + +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, vars, args, res, attrs, loc, info = d in + Te.decl cid ~vars ~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_500/parsing/parsetree.mli b/upstream/ocaml_500/parsing/parsetree.mli new file mode 100644 index 0000000000..e806a16091 --- /dev/null +++ b/upstream/ocaml_500/parsing/parsetree.mli @@ -0,0 +1,983 @@ +(**************************************************************************) +(* *) +(* 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. + + - As the pval_type field of a value_description. + *) + + | 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_vars: string loc list; + 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 string loc list * constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([], [T1; ...; Tn], None) + | C: T0 ([], [], Some T0) + | C: T1 * ... * Tn -> T0 ([], [T1; ...; Tn], Some T0) + | C: 'a... . T1... -> T0 (['a;...]; [T1;...], 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; + } +(* S := M *) + +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_500/parsing/pprintast.ml b/upstream/ocaml_500/parsing/pprintast.ml new file mode 100644 index 0000000000..eee4b5848f --- /dev/null +++ b/upstream/ocaml_500/parsing/pprintast.ml @@ -0,0 +1,1716 @@ +(**************************************************************************) +(* *) +(* 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 "@[%s: %a@ %a@ @]" l.txt + (core_type ctxt) ct (attributes ctxt) x.pof_attributes + | Oinherit ct -> + pp f "@[%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 "@[<@ %a%a@ > @]" + (list core_field_type ~sep:";") l + field_var o (* Cf #7200 *) + | Ptyp_class (li, l) -> (*FIXME*) + pp f "@[%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 "@[(module@ %a)@]" longident_loc lid + |_ -> + pp f "@[(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 "@[%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 "@[!%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 "@[function%a@]" (case_list ctxt) l + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + (expression reset_ctxt) e (case_list ctxt) l + + | Pexp_try (e, l) -> + pp f "@[<0>@[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 "@[%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 ="@[@[<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 "@[%a@]" + (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new (li) -> + pp f "@[new@ %a@]" longident_loc li; + | Pexp_setinstvar (s, e) -> + pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e + | Pexp_override l -> (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in + pp f "@[{<%a>}@]" + (list string_x_expression ~sep:";" ) l; + | Pexp_letmodule (s, me, e) -> + pp f "@[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 "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) cd + (expression ctxt) e + | Pexp_assert e -> + pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy (e) -> + pp f "@[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 "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!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>@[%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 "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> pp f "@[%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 "@[[%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 "@[(%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 "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%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 = + "@[@[@[<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 "@[%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 "@[exception@ %a@]%a" + (extension_constructor ctxt) x.ptyexn_constructor + (item_attributes ctxt) x.ptyexn_attributes + +and class_type_field ctxt 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 + +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = + pp f "@[@[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 ctxt) ~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 "@[%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 "@[@[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 "@[functor () ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (Named (s, mt1), mt2) -> + begin match s.txt with + | None -> + pp f "@[%a@ ->@ %a@]" + (module_type1 ctxt) mt1 (module_type ctxt) mt2 + | Some name -> + pp f "@[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 "@[%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 "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) s (* FIXME wrong indentation*) + | Pmty_typeof me -> + pp f "@[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 "@[%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 "@[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 "@[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 "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt + longident_loc pms.pms_manifest + (item_attributes ctxt) pms.pms_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_expr + (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[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 "@[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 "@[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 "@ @[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 "@[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 "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") s; + | Pmod_constraint (me, mt) -> + pp f "@[(%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 "@[%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 "@[;;%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 "@[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 "@[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 "@[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 "@[%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 "@[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 "@[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 "@[@ 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 "@[@ 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 "@[@[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 "@[@[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 "@[%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_vars, + 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 "@[@ 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, vars, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s in + let pp_vars f vs = + match vs with + | [] -> () + | vs -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") vs 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@;%a" name + pp_vars vars + (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(v, l, r) -> + constructor_declaration ctxt f + (x.pext_name.txt, v, 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 "@[%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 "@[#%s@]" pdir_name.txt + | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} -> + pp f "@[#%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 module_type = module_type reset_ctxt +let class_field = class_field reset_ctxt +let class_type_field = class_type_field reset_ctxt +let class_expr = class_expr reset_ctxt +let class_type = class_type reset_ctxt +let structure_item = structure_item reset_ctxt +let signature_item = signature_item reset_ctxt +let binding = binding reset_ctxt +let payload = payload reset_ctxt diff --git a/upstream/ocaml_500/parsing/pprintast.mli b/upstream/ocaml_500/parsing/pprintast.mli new file mode 100644 index 0000000000..42acd5f15c --- /dev/null +++ b/upstream/ocaml_500/parsing/pprintast.mli @@ -0,0 +1,55 @@ +(**************************************************************************) +(* *) +(* 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 class_field: Format.formatter -> Parsetree.class_field -> unit +val class_type_field: Format.formatter -> Parsetree.class_type_field -> unit +val class_expr: Format.formatter -> Parsetree.class_expr -> unit +val class_type: Format.formatter -> Parsetree.class_type -> unit +val module_type: Format.formatter -> Parsetree.module_type -> unit +val structure_item: Format.formatter -> Parsetree.structure_item -> unit +val signature_item: Format.formatter -> Parsetree.signature_item -> unit +val binding: Format.formatter -> Parsetree.value_binding -> unit +val payload: Format.formatter -> Parsetree.payload -> 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_500/parsing/printast.ml b/upstream/ocaml_500/parsing/printast.ml new file mode 100644 index 0000000000..a566f3452b --- /dev/null +++ b/upstream/ocaml_500/parsing/printast.ml @@ -0,0 +1,963 @@ +(**************************************************************************) +(* *) +(* 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 typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + +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" typevars 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 "\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(v, a, r) -> + line i ppf "Pext_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; + 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 " %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_vars; 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; + if pcd_vars <> [] then line (i+1) ppf "pcd_vars =%a\n" typevars pcd_vars; + 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 "\n"; + pattern (i+1) ppf pc_lhs; + begin match pc_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf pc_rhs; + +and value_binding i ppf x = + line i ppf "\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 " %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 " %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 "\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_500/parsing/printast.mli b/upstream/ocaml_500/parsing/printast.mli new file mode 100644 index 0000000000..5bc496182f --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/syntaxerr.ml b/upstream/ocaml_500/parsing/syntaxerr.ml new file mode 100644 index 0000000000..49372b9edf --- /dev/null +++ b/upstream/ocaml_500/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_500/parsing/syntaxerr.mli b/upstream/ocaml_500/parsing/syntaxerr.mli new file mode 100644 index 0000000000..26ba712671 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/annot.mli b/upstream/ocaml_500/typing/annot.mli new file mode 100644 index 0000000000..bbaade5b03 --- /dev/null +++ b/upstream/ocaml_500/typing/annot.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* 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_500/typing/btype.ml b/upstream/ocaml_500/typing/btype.ml new file mode 100644 index 0000000000..6e742771d1 --- /dev/null +++ b/upstream/ocaml_500/typing/btype.ml @@ -0,0 +1,771 @@ +(**************************************************************************) +(* *) +(* 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 ****) + +let wrap_repr f ty = f (Transient_expr.repr ty) +let wrap_type_expr f tty = f (Transient_expr.type_expr tty) + +module TransientTypeSet = Set.Make(TransientTypeOps) +module TypeSet = struct + include TransientTypeSet + let add = wrap_repr add + let mem = wrap_repr mem + let singleton = wrap_repr singleton + let exists p = TransientTypeSet.exists (wrap_type_expr p) + let elements set = + List.map Transient_expr.type_expr (TransientTypeSet.elements set) +end +module TransientTypeMap = Map.Make(TransientTypeOps) +module TypeMap = struct + include TransientTypeMap + let add ty = wrap_repr add ty + let find ty = wrap_repr find ty + let singleton ty = wrap_repr singleton ty + let fold f = TransientTypeMap.fold (wrap_type_expr f) +end +module TransientTypeHash = Hashtbl.Make(TransientTypeOps) +module TypeHash = struct + include TransientTypeHash + let add hash = wrap_repr (add hash) + let find hash = wrap_repr (find hash) + let iter f = TransientTypeHash.iter (wrap_type_expr f) +end +module TransientTypePairs = + Hashtbl.Make (struct + type t = transient_expr * transient_expr + let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') + let hash (t, t') = t.id + 93 * t'.id + end) +module TypePairs = struct + module H = TransientTypePairs + open Transient_expr + + type t = { + set : unit H.t; + mutable elems : (transient_expr * transient_expr) list; + (* elems preserves the (reversed) insertion order of elements *) + } + + let create n = + { elems = []; set = H.create n } + + let clear t = + t.elems <- []; + H.clear t.set + + let repr2 (t1, t2) = (repr t1, repr t2) + + let add t p = + let p = repr2 p in + if H.mem t.set p then () else begin + H.add t.set p (); + t.elems <- p :: t.elems + end + + let mem t p = H.mem t.set (repr2 p) + + let iter f t = + (* iterate in insertion order, not Hashtbl.iter order *) + List.rev t.elems + |> List.iter (fun (t1,t2) -> + f (type_expr t1, type_expr t2)) +end + +(**** 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 newgenty desc = newty2 ~level:generic_level desc +let newgenvar ?name () = newgenty (Tvar name) +let newgenstub ~scope = newty3 ~level:generic_level ~scope (Tvar None) + +(* +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 ty = match get_desc ty with Tvar _ -> true | _ -> false +let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false +let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false + +let dummy_method = "*dummy method*" + +(**** Representative of a type ****) + +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 = + match row_fixed row with + | Some _ as x -> x + | None -> + let ty = row_more row in + match get_desc ty with + | Tvar _ | Tnil -> None + | Tunivar _ -> Some (Univar ty) + | Tconstr (p,_,_) -> Some (Reified p) + | _ -> assert false + +let is_fixed row = match row_fixed row with + | None -> false + | Some _ -> true + +let has_fixed_explanation row = fixed_explanation row <> None + +let static_row row = + row_closed row && + List.for_all + (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true) + (row_fields row) + +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 = + match get_desc ty with + | Tvariant row when not (static_row row) -> + row_more row + | Tobject (ty, _) -> + let rec proxy_obj ty = + match get_desc ty with + Tfield (_, _, _, ty) -> proxy_obj ty + | Tvar _ | Tunivar _ | Tconstr _ -> ty + | Tnil -> ty + | _ -> assert false + in proxy_obj ty + | _ -> ty + +(**** Utilities for fixed row private types ****) + +let row_of_type t = + match get_desc t with + Tobject(t,_) -> + let rec get_row t = + match get_desc t 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 get_desc t 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_static_row_name decl path = + match decl.type_manifest with + None -> () + | Some ty -> + match get_desc ty with + Tvariant row when static_row row -> + let row = + set_row_name row (Some (path, decl.type_params)) in + set_type_desc ty (Tvariant row) + | _ -> () + + + (**********************************) + (* Utilities for type traversal *) + (**********************************) + +let 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_fields row) + in + match get_desc (row_more row) with + | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil -> + begin match + Option.map (fun (_,l) -> List.fold_left f result l) (row_name row) + 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 get_desc ty 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 _ + | 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; + it.it_type_expr it cs.csig_self_row; + Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars; + Meths.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_meths + | 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 get_desc ty with + Tconstr (p, _, _) + | Tobject (_, {contents=Some (p, _)}) + | Tpackage (p, _) -> + it.it_path p + | Tvariant row -> + Option.iter (fun (p,_) -> it.it_path p) (row_name row) + | _ -> () + 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 Row {fields = orig_fields; fixed = orig_fixed; closed; name = orig_name} = + row_repr row in + let fields = List.map + (fun (l, fi) -> l, + match row_field_repr fi with + | Rpresent oty -> rf_present (Option.map f oty) + | Reither(c, tl, m) -> + let use_ext_of = if keep then Some fi else None in + let m = if is_fixed row then fixed else m in + let tl = List.map f tl in + rf_either tl ?use_ext_of ~no_arg:c ~matched:m + | Rabsent -> rf_absent) + orig_fields in + let name = + match orig_name with + | None -> None + | Some (path, tl) -> Some (path, List.map f tl) in + let fixed = if fixed then orig_fixed else None in + create_row ~fields ~more ~fixed ~closed ~name + +let copy_commu c = if is_commu_ok c then commu_ok else commu_var () + +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) -> + Tfield (p, field_kind_internal_repr k, f ty1, f ty2) + (* the kind is kept shared, with indirections removed for performance *) + | Tnil -> Tnil + | Tlink ty -> copy_type_desc f (get_desc ty) + | 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 redirect_desc: copy_scope -> type_expr -> type_desc -> unit + + val with_scope: (copy_scope -> 'a) -> 'a +end = struct + type copy_scope = { + mutable saved_desc : (transient_expr * type_desc) list; + (* Save association of generic nodes with their description. *) + } + + let redirect_desc copy_scope ty desc = + let ty = Transient_expr.repr ty in + copy_scope.saved_desc <- (ty, ty.desc) :: copy_scope.saved_desc; + Transient_expr.set_desc ty desc + + (* Restore type descriptions. *) + let cleanup { saved_desc; _ } = + List.iter (fun (ty, desc) -> Transient_expr.set_desc ty desc) saved_desc + + let with_scope f = + let scope = { saved_desc = [] } 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 +*) + +(* Re-export backtrack *) + +let snapshot = snapshot +let backtrack = backtrack ~cleanup_abbrev + + (**********************************) + (* 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 + + (*******************************) + (* 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 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 + +(* Fully expand the head of a class type *) +let rec scrape_class_type = + function + Cty_constr (_, _, cty) -> scrape_class_type cty + | cty -> cty + +let rec class_type_arity = + function + Cty_constr (_, _, cty) -> class_type_arity cty + | Cty_signature _ -> 0 + | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty + +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) + +let self_type cty = + (signature_of_class_type cty).csig_self + +let self_type_row cty = + (signature_of_class_type cty).csig_self_row + +(* Return the methods of a class signature *) +let methods sign = + Meths.fold + (fun name _ l -> name :: l) + sign.csig_meths [] + +(* Return the virtual methods of a class signature *) +let virtual_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_meths [] + +(* Return the concrete methods of a class signature *) +let concrete_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> MethSet.add name s) + sign.csig_meths MethSet.empty + +(* Return the public methods of a class signature *) +let public_methods sign = + Meths.fold + (fun name (priv, _vr, _ty) l -> + match priv with + | Mprivate _ -> l + | Mpublic -> name :: l) + sign.csig_meths [] + +(* Return the instance variables of a class signature *) +let instance_vars sign = + Vars.fold + (fun name _ l -> name :: l) + sign.csig_vars [] + +(* Return the virtual instance variables of a class signature *) +let virtual_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_vars [] + +(* Return the concrete instance variables of a class signature *) +let concrete_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> VarSet.add name s) + sign.csig_vars VarSet.empty + +let method_type label sign = + match Meths.find label sign.csig_meths with + | (_, _, ty) -> ty + | exception Not_found -> assert false + +let instance_variable_type label sign = + match Vars.find label sign.csig_vars with + | (_, _, ty) -> ty + | exception Not_found -> assert false + + (**********************************) + (* Utilities for level-marking *) + (**********************************) + +let not_marked_node ty = get_level ty >= lowest_level + (* type nodes with negative levels are "marked" *) + +let flip_mark_node ty = + let ty = Transient_expr.repr ty in + Transient_expr.set_level ty (pivot_level - ty.level) +let logged_mark_node ty = + set_level ty (pivot_level - get_level ty) + +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 = + 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 = + 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 = + if get_level ty < 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; + unmark_type sign.csig_self_row; + Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars; + Meths.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_meths + +let unmark_class_type cty = + unmark_iterators.it_class_type unmark_iterators cty + +(**** Type information getter ****) + +let cstr_type_path cstr = + match get_desc cstr.cstr_res with + | Tconstr (p, _, _) -> p + | _ -> assert false diff --git a/upstream/ocaml_500/typing/btype.mli b/upstream/ocaml_500/typing/btype.mli new file mode 100644 index 0000000000..f051e777a4 --- /dev/null +++ b/upstream/ocaml_500/typing/btype.mli @@ -0,0 +1,315 @@ +(**************************************************************************) +(* *) +(* 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 : sig + include Set.S with type elt = transient_expr + val add: type_expr -> t -> t + val mem: type_expr -> t -> bool + val singleton: type_expr -> t + val exists: (type_expr -> bool) -> t -> bool + val elements: t -> type_expr list +end +module TransientTypeMap : Map.S with type key = transient_expr +module TypeMap : sig + include Map.S with type key = transient_expr + and type 'a t = 'a TransientTypeMap.t + val add: type_expr -> 'a -> 'a t -> 'a t + val find: type_expr -> 'a t -> 'a + val singleton: type_expr -> 'a -> 'a t + val fold: (type_expr -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end +module TypeHash : sig + include Hashtbl.S with type key = transient_expr + val add: 'a t -> type_expr -> 'a -> unit + val find: 'a t -> type_expr -> 'a + val iter: (type_expr -> 'a -> unit) -> 'a t -> unit +end +module TypePairs : sig + type t + val create: int -> t + val clear: t -> unit + val add: t -> type_expr * type_expr -> unit + val mem: t -> type_expr * type_expr -> bool + val iter: (type_expr * type_expr -> unit) -> t -> unit +end + +(**** Levels ****) + +val generic_level: int + +val newgenty: type_desc -> type_expr + (* Create a generic type *) +val newgenvar: ?name:string -> unit -> type_expr + (* Return a fresh generic variable *) +val newgenstub: scope:int -> type_expr + (* Return a fresh generic node, to be instantiated + by [Transient_expr.set_stub_desc] *) + +(* 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 + +(**** polymorphic variants ****) + +val is_fixed: row_desc -> bool +(* Return whether the row is directly marked as fixed or not *) + +val has_fixed_explanation: row_desc -> bool +(* Return whether the row should be treated as fixed or not. + In particular, [is_fixed row] implies [has_fixed_explanation 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_static_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 *) +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) + + +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 + +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 redirect_desc: copy_scope -> type_expr -> type_desc -> unit + (* Temporarily change a type description *) + + 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 *) +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. + 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 *) + +(**** Backtracking ****) + +val snapshot: unit -> snapshot +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 *) + +(**** 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 class types ****) + +(* Get the class signature within a class type *) +val signature_of_class_type : class_type -> class_signature + +(* Get the body of a class type (i.e. without parameters) *) +val class_body : class_type -> class_type + +(* Fully expand the head of a class type *) +val scrape_class_type : class_type -> class_type + +(* Return the number of parameters of a class type *) +val class_type_arity : class_type -> int + +(* Given a path and type parameters, add an abbreviation to a class type *) +val abbreviate_class_type : + Path.t -> type_expr list -> class_type -> class_type + +(* Get the self type of a class *) +val self_type : class_type -> type_expr + +(* Get the row variable of the self type of a class *) +val self_type_row : class_type -> type_expr + +(* Return the methods of a class signature *) +val methods : class_signature -> string list + +(* Return the virtual methods of a class signature *) +val virtual_methods : class_signature -> string list + +(* Return the concrete methods of a class signature *) +val concrete_methods : class_signature -> MethSet.t + +(* Return the public methods of a class signature *) +val public_methods : class_signature -> string list + +(* Return the instance variables of a class signature *) +val instance_vars : class_signature -> string list + +(* Return the virtual instance variables of a class signature *) +val virtual_instance_vars : class_signature -> string list + +(* Return the concrete instance variables of a class signature *) +val concrete_instance_vars : class_signature -> VarSet.t + +(* Return the type of a method. + @raises [Assert_failure] if the class has no such method. *) +val method_type : label -> class_signature -> type_expr + +(* Return the type of an instance variable. + @raises [Assert_failure] if the class has no such method. *) +val instance_variable_type : label -> class_signature -> type_expr + +(**** Forward declarations ****) +val print_raw: (Format.formatter -> type_expr -> unit) ref + +(**** Type information getter ****) + +val cstr_type_path : constructor_description -> Path.t diff --git a/upstream/ocaml_500/typing/cmt2annot.ml b/upstream/ocaml_500/typing/cmt2annot.ml new file mode 100644 index 0000000000..40ee752e80 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/ctype.ml b/upstream/ocaml_500/typing/ctype.ml new file mode 100644 index 0000000000..becdca2074 --- /dev/null +++ b/upstream/ocaml_500/typing/ctype.ml @@ -0,0 +1,5434 @@ +(**************************************************************************) +(* *) +(* 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 knows 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 ****) + +(* There are two classes of errortrace-related exceptions: *traces* and + *errors*. The former, whose names end with [_trace], contain + [Errortrace.trace]s, representing traces that are currently being built; they + are local to this file. All the internal functions that implement + unification, type equality, and moregen raise trace exceptions. Once we are + done, in the top level functions such as [unify], [equal], and [moregen], we + catch the trace exceptions and transform them into the analogous error + exception. This indicates that we are done building the trace, and expect + the error to flow out of unification, type equality, or moregen into + surrounding code (with some few exceptions when these top-level functions are + used as building blocks elsewhere.) Only the error exceptions are exposed in + [ctype.mli]; the trace exceptions are an implementation detail. Any trace + exception that escapes from a function in this file is a bug. *) + +exception Unify_trace of unification trace +exception Equality_trace of comparison trace +exception Moregen_trace of comparison trace + +exception Unify of unification_error +exception Equality of equality_error +exception Moregen of moregen_error +exception Subtype of Subtype.error + +exception Escape of type_expr 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 trace) : 'a = + match tr_exn with + | Unify -> raise (Unify_trace tr) + | Equality -> raise (Equality_trace tr) + | Moregen -> raise (Moregen_trace 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 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_error + +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 newty desc = newty2 ~level:!current_level desc +let new_scoped_ty scope desc = newty3 ~level:!current_level ~scope desc + +let newvar ?name () = newty2 ~level:!current_level (Tvar name) +let newvar2 ?name level = newty2 ~level:level (Tvar name) +let new_global_var ?name () = newty2 ~level:!global_level (Tvar name) +let newstub ~scope = newty3 ~level:!current_level ~scope (Tvar None) + +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 *) + +(**** 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 : 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); 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 get_desc ty with + Tobject (fields, _) -> fields + | _ -> assert false + +let flatten_fields ty = + let rec flatten l ty = + match get_desc ty 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) + +(**** Check whether an object is open ****) + +(* +++ The abbreviation should eventually be expanded *) +let rec object_row ty = + match get_desc ty with + Tobject (t, _) -> object_row t + | Tfield(_, _, _, t) -> object_row t + | _ -> ty + +let opened_object ty = + match get_desc (object_row ty) with + | Tvar _ | Tunivar _ | Tconstr _ -> true + | _ -> false + +let concrete_object ty = + match get_desc (object_row ty) with + | Tvar _ -> false + | _ -> true + +(**** Row variable of an object type ****) + +let rec fields_row_variable ty = + match get_desc ty with + | Tfield (_, _, _, ty) -> fields_row_variable ty + | Tvar _ -> ty + | _ -> assert false + +(**** Object name manipulation ****) +(* +++ Bientot obsolete *) + +let set_object_name id params ty = + match get_desc ty with + | Tobject (fi, nm) -> + let rv = fields_row_variable fi in + set_name nm (Some (Path.Pident id, rv::params)) + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.set_object_name" + +let remove_object_name ty = + match get_desc ty with + Tobject (_, nm) -> set_name nm None + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.remove_object_name" + + (*******************************************) + (* 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) when erase -> + link_row_field_ext ~inside:f rf_absent; 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 = + if try_mark_node ty then + match get_desc ty, !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 get_level body <> 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, _ -> + iter_row (free_vars_rec true) row; + if not (static_row row) then free_vars_rec false (row_more row) + | _ -> + 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 + +exception CCFailure of (type_expr * bool * string * type_expr) + +let closed_class params sign = + List.iter mark_type params; + ignore (try_mark_node sign.csig_self_row); + try + Meths.iter + (fun lab (priv, _, ty) -> + if priv = Mpublic then begin + try closed_type ty with Non_closed (ty0, real) -> + raise (CCFailure (ty0, real, lab, ty)) + end) + sign.csig_meths; + List.iter unmark_type params; + unmark_class_signature sign; + None + with CCFailure reason -> + 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 level = get_level ty in + if (level > !current_level) && (level <> generic_level) then begin + set_level ty generic_level; + (* recur into abbrev for the speed *) + begin match get_desc ty 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 level = get_level ty in + if level <> generic_level then begin + if is_Tvar ty && level > !current_level then + set_level ty !current_level + else if + level > !current_level && + match get_desc ty 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 level = get_level ty in + if level < !current_level || level = generic_level then () else + match get_desc ty 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 orig_level = get_level ty in + if try_logged_mark_node ty then begin + if level < get_scope ty then + raise_scope_escape_exn ty; + begin match get_desc ty 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 + (newty2 ~level: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 = + if get_scope ty < scope then begin + if get_level ty < 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 = + if get_level ty > level then begin + if level < get_scope ty then raise_scope_escape_exn ty; + match get_desc ty with + Tconstr(p, _tl, _abbrev) when level < Path.scope p -> + (* Try first to replace an abbreviation by its expansion. *) + begin try + let ty' = !forward_try_expand_safe env ty in + link_type ty 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 && get_level ty > level) + variance tl + in + begin try + if not needs_expand then raise Cannot_expand; + let ty' = !forward_try_expand_safe env ty in + link_type ty 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 -> + begin match row_name row with + | Some (p, _tl) when level < Path.scope p -> + set_type_desc ty (Tvariant (set_row_name row None)) + | _ -> () + end; + set_level ty level; + iter_type_expr (update_level env level expand) ty + | Tfield(lab, _, ty1, _) + when lab = dummy_method && level < get_scope ty1 -> + 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 = + if get_level ty > 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 must_visit = + get_level ty > var_level && + match Hashtbl.find visited (get_id ty) with + | done_contra -> contra && not done_contra + | exception Not_found -> true + in + if must_visit then begin + Hashtbl.add visited (get_id ty) contra; + let lower_rec = lower_contravariant env var_level visited in + match get_desc ty 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_variables_only env level ty = + simple_abbrevs := Mnil; + lower_contravariant env level (Hashtbl.create 7) true ty + +let lower_contravariant env ty = + simple_abbrevs := Mnil; + lower_contravariant env !nongen_level (Hashtbl.create 7) false ty + +let rec generalize_class_type' gen = + function + Cty_constr (_, params, cty) -> + List.iter gen params; + generalize_class_type' gen cty + | Cty_signature csig -> + gen csig.csig_self; + gen csig.csig_self_row; + Vars.iter (fun _ (_, _, ty) -> gen ty) csig.csig_vars; + Meths.iter (fun _ (_, _, ty) -> gen ty) csig.csig_meths + | Cty_arrow (_, ty, cty) -> + gen ty; + generalize_class_type' gen cty + +let generalize_class_type cty = + generalize_class_type' generalize cty + +let generalize_class_type_structure cty = + generalize_class_type' generalize_structure cty + +(* 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 graph = Hashtbl.create 17 in + let idx = ref lowest_level in + let roots = ref [] in + + let rec inverse pty ty = + let level = get_level ty in + if (level > !current_level) || (level = generic_level) then begin + decr idx; + Hashtbl.add graph !idx (ty, ref pty); + if (level = generic_level) || eq_type ty ty0 then + roots := ty :: !roots; + set_level ty !idx; + iter_type_expr (inverse [ty]) ty + end else if level < lowest_level then begin + let (_, parents) = Hashtbl.find graph level in + parents := pty @ !parents + end + + and generalize_parents ty = + let idx = get_level ty 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 get_desc ty with + Tvariant row -> + let more = row_more row in + let lv = get_level more in + if (lv < lowest_level || lv > !current_level) + && lv <> generic_level then set_level more generic_level + | _ -> () + end + in + + inverse [] ty; + if get_level ty0 < lowest_level then + iter_type_expr (inverse []) ty0; + List.iter generalize_parents !roots; + Hashtbl.iter + (fun _ (ty, _) -> + if get_level ty <> generic_level then set_level ty !current_level) + graph + +let limited_generalize_class_type rv cty = + generalize_class_type' (limited_generalize rv) cty + +(* 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 = + 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 get_desc inv.inv_type with + Tpoly (_ty, tl) when List.memq (get_id univ) (List.map get_id 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 = + if not_marked_node ty then + if get_level ty = 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 + match get_desc ty with + Tsubst (ty, _) -> ty + | desc -> + let level = get_level ty in + if 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 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 level else !current_level + else generic_level + in + if forget <> generic_level then newty2 ~level:forget (Tvar None) else + let t = newstub ~scope:(get_scope ty) in + For_copy.redirect_desc scope ty (Tsubst (t, None)); + let desc' = + match desc with + | Tconstr (p, tl, _) -> + let abbrevs = proper_abbrevs p tl !abbreviations in + begin match find_repr p !abbrevs with + Some ty when not (eq_type 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 row -> + let more = row_more row in + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + begin match mored with + Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + (* If the row variable is not generic, we must keep it *) + let keep = get_level more <> generic_level && partial = None in + let more' = + match mored with + Tsubst (ty, None) -> ty + (* TODO: is this case possible? + possibly an interaction with (copy more) below? *) + | Tconstr _ | Tnil -> + copy more + | Tvar _ | Tunivar _ -> + if keep then more else newty mored + | _ -> assert false + in + let row = + match get_desc more' with (* PR#6163 *) + Tconstr (x,_,_) when not (is_fixed row) -> + let Row {fields; more; closed; name} = row_repr row in + create_row ~fields ~more ~closed ~name + ~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 not (eq_type more more') 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 + let fields = row_fields row in + if row_closed row && not (is_fixed row) + && TypeSet.is_empty (free_univars ty) + && not (List.for_all not_reither fields) then + (more', + create_row ~fields:(List.filter not_reither fields) + ~more:more' ~closed:false ~fixed:None ~name:None) + else (more', row) + | _ -> (more', row) + in + (* Register new type first for recursion *) + For_copy.redirect_desc scope more + (Tsubst(more', Some t)); + (* Return a new copy *) + Tvariant (copy_row copy true row keep more') + end + | Tobject (ty1, _) when partial <> None -> + Tobject (copy ty1, ref None) + | _ -> copy_type_desc ?keep_names copy desc + in + Transient_expr.set_stub_desc t desc'; + 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 get_desc ty with + | 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_self_row = copy scope sign.csig_self_row; + csig_vars = + Vars.map + (function (m, v, ty) -> (m, v, copy scope ty)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, ty) -> (p, v, copy scope ty)) + sign.csig_meths} + | 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 get_id bound in + TypeSet.exists (fun t -> List.memq (get_id 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 ~may_share + (visited : (int * (type_expr * type_expr list)) list) (ty : type_expr) = + let univars = free ty in + if is_Tvar ty || may_share && TypeSet.is_empty univars then + if get_level ty <> generic_level then ty else + let t = newstub ~scope:(get_scope ty) in + delayed_copy := + lazy (Transient_expr.set_stub_desc t (Tlink (copy cleanup_scope ty))) + :: !delayed_copy; + t + else try + let t, bound_t = List.assq (get_id 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 = newstub ~scope:(get_scope ty) in + let desc = get_desc ty in + let visited = + match desc with + Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ -> + (get_id 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 + let desc' = + match desc with + | Tvariant row -> + let more = row_more row in + (* We shall really check the level on the row variable *) + let keep = is_Tvar more && get_level more <> generic_level in + let more' = copy_rec ~may_share:false more in + let fixed' = fixed && (is_Tvar more || is_Tunivar more) in + let row = + copy_row (copy_rec ~may_share:true) fixed' row keep more' in + Tvariant row + | Tpoly (t1, tl) -> + let tl' = List.map (fun t -> newty (get_desc t)) tl in + let bound = tl @ bound in + let visited = + List.map2 (fun ty t -> get_id ty, (t, bound)) tl tl' @ visited in + let body = + copy_sep ~cleanup_scope ~fixed ~free ~bound ~may_share:true + visited t1 in + Tpoly (body, tl') + | Tfield (p, k, ty1, ty2) -> + (* the kind is kept shared, see Btype.copy_type_desc *) + Tfield (p, field_kind_internal_repr k, copy_rec ~may_share:true ty1, + copy_rec ~may_share:false ty2) + | _ -> copy_type_desc (copy_rec ~may_share:true) desc + in + Transient_expr.set_stub_desc t desc'; + t + end + +let instance_poly' cleanup_scope ~keep_names fixed univars sch = + (* In order to compute univars below, [sch] should not contain [Tsubst] *) + let copy_var ty = + match get_desc ty 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 -> get_id u, (v, [])) univars vars in + delayed_copy := []; + let ty = + copy_sep ~cleanup_scope ~fixed ~free:(compute_univars sch) ~bound:[] + ~may_share:true 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 get_desc lbl.lbl_arg with + 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 ****) + +(* NB: since this is [unify_var], it raises [Unify], not [Unify_trace] *) +let unify_var' = (* Forward declaration *) + ref (fun _env _ty1 _ty2 -> assert false) + +let subst env level priv abbrev oty 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 oty with + | None -> fun () -> () (* No abbreviation added *) + | Some ty -> + match get_desc ty with + Tconstr (path, tl, _) -> + 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_var' env body0 body'; + List.iter2 (!unify_var' 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 get_desc ty with + Tconstr (path, args, abbrev) -> + let level = get_level ty in + let scope = get_scope ty in + 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; + 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 (get_scope ty) 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 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 = + match get_desc ty with + Tconstr _ -> 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.t -> type_expr -> type_expr) 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 -> 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 -> 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 + *) + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + | Has_no_typedecl + | May_have_typedecl + +let rec extract_concrete_typedecl env ty = + match get_desc ty with + Tconstr (p, _, _) -> + begin match Env.find_type p env with + | exception Not_found -> May_have_typedecl + | decl -> + if decl.type_kind <> Type_abstract then Typedecl(p, p, decl) + else begin + match try_expand_safe env ty with + | exception Cannot_expand -> May_have_typedecl + | ty -> + match extract_concrete_typedecl env ty with + | Typedecl(_, p', decl) -> Typedecl(p, p', decl) + | Has_no_typedecl -> Has_no_typedecl + | May_have_typedecl -> May_have_typedecl + end + end + | Tpoly(ty, _) -> extract_concrete_typedecl env ty + | Tarrow _ | Ttuple _ | Tobject _ | Tfield _ | Tnil + | Tvariant _ | Tpackage _ -> Has_no_typedecl + | Tvar _ | Tunivar _ -> May_have_typedecl + | Tlink _ | Tsubst _ -> assert false + +(* 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 = + match get_desc ty with + Tconstr _ -> 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 -> 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 + try expand_head_unif env ty with Unify_trace _ -> + (* #10277: forget scopes when printing trace *) + begin_def (); + init_def (get_level ty); + 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 -> ty + in + end_def (); + ty + else expand_head env ty + in + match get_desc ty with + Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar v -> + newty2 ~level:(get_level ty) (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 + get_level body = 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} -> + get_level body = 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 ty = + if eq_type ty ty0 then raise Occur; + match get_desc ty 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;*) + if not (List.memq (get_id ty) visited) then begin + match get_desc ty 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 = get_id 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 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 = get_id 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',_) -> eq_type t 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 eq_type t2 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 = + 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 get_desc ty with + Tunivar _ -> + if not (TypeSet.mem ty bound) then + raise_escape_exn (Univ ty) + | Tpoly (ty, tyl) -> + let bound = List.fold_right TypeSet.add 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 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 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 = + if TypeSet.mem t !visited then () else begin + visited := TypeSet.add t !visited; + match get_desc t with + Tpoly (t, tl) -> + if List.exists (fun t -> TypeSet.mem 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 + 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 = + match get_desc ty with + | Tvar name when get_level ty = generic_level -> + let t = newty (Tunivar name) in + For_copy.redirect_desc scope 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 ~level:(get_level ty) (Tpoly(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 ? *) +(* That's hard to do because it relies on the expansion machinery in Ctype, + but still might be nice. *) + +let expand_type env ty = + { ty = ty; + expanded = full_expand ~may_forget_scope:true env ty } + +let expand_any_trace map env trace = + map (expand_type env) 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 + +let expand_to_unification_error env trace = + unification_error ~trace:(expand_trace env trace) + +let expand_to_equality_error env trace subst = + equality_error ~trace:(expand_trace env trace) ~subst + +let expand_to_moregen_error env trace = + moregen_error ~trace:(expand_trace env trace) + +(* [expand_trace] and the [expand_to_*_error] functions take care of most of the + expansion in this file, but we occasionally need to build [Errortrace.error]s + in other ways/elsewhere, so we expose some machinery for doing so +*) + +(* Equivalent to [expand_trace env [Diff {got; expected}]] for a single + element *) +let expanded_diff env ~got ~expected = + Diff (map_diff (expand_type env) {got; expected}) + +(* Diff while transforming a [type_expr] into an [expanded_type] without + expanding *) +let unexpanded_diff ~got ~expected = + Diff (map_diff trivial_expansion {got; expected}) + +(**** Unification ****) + +(* Return whether [t0] occurs in [ty]. Objects are also traversed. *) +let deep_occur t0 ty = + let rec occur_rec ty = + if get_level ty >= get_level t0 && try_mark_node ty then begin + if eq_type 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 ~level:lev (Tconstr (path,[],ref Mnil)) in + env := new_env; + path, t + in + let visited = ref TypeSet.empty in + let rec iterator ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty with + Tvar o -> + let level = get_level ty in + let path, t = create_fresh_constr level o in + link_type ty t; + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) + | Tvariant r -> + if not (static_row r) then begin + if is_fixed r then iterator (row_more r) else + let m = row_more r in + match get_desc m with + Tvar o -> + let level = get_level m in + let path, t = create_fresh_constr level o in + let row = + let fixed = Some (Reified path) in + create_row ~fields:[] ~more:t ~fixed + ~name:(row_name r) ~closed:(row_closed r) in + link_type m (newty2 ~level (Tvariant row)); + if 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 = + match get_desc ty 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 eq_type t1 t2 then () else + match (get_desc t1, get_desc t2) 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... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') 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_unexplained_for Unify + | (_, Tconstr (_, [], _)) when has_injective_univars env t1' -> + raise_unexplained_for 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 = Fpublic) in + mcomp type_pairs env rest1 rest2; + if has_present miss1 && get_desc (object_row ty2) = Tnil + || has_present miss2 && get_desc (object_row ty1) = 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 + (Fpublic, Fabsent) + | (Fabsent, Fpublic) -> raise Incompatible + | _ -> () + +and mcomp_row type_pairs env row1 row2 = + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + let cannot_erase (_,f) = + match row_field_repr f with + Rpresent _ -> true + | Rabsent | Reither _ -> false + in + if row_closed row1 && List.exists cannot_erase r2 + || row_closed row2 && 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 = + if not_marked_node ty then begin + let level = get_level ty in + if level < !lowest then lowest := 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 get_id t1 <= get_id t2 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 = + eq_type t1 t2 || + match !umode with + | Expression -> false + | Pattern -> + TypePairs.mem unify_eq_set (order_type_pair t1 t2) + +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 (get_level t1) t2; + update_scope (get_scope t1) t2; + with Escape e -> + raise_for Unify (Escape e) + end; + link_type t1 t2; + true + | exception Unify_trace _ 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_trace _ 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 = ]). 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 unify_eq t1 t2 then () else + let reset_tracing = check_trace_gadt_instances !env in + + try + type_changed := true; + begin match (get_desc t1, get_desc t2) 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 (get_level t1) t2; + update_scope_for Unify (get_scope t1) 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 (get_level t1) t2; + update_scope_for Unify (get_scope t1) 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 trace -> + reset_trace_gadt_instances reset_tracing; + raise_trace_for Unify (Diff {got = t1; expected = 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 (get_level t1') (get_level t2') in + let scope = Int.max (get_scope t1') (get_scope t2') 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, 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 get_desc t1 with Tconstr (_, [], _) -> t1' | _ -> t1), + (match get_desc t2 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 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 tt1' = Transient_expr.repr t1' in + let d1 = tt1'.desc and d2 = get_desc t2' in + let create_recursion = + (not (eq_type 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'; + 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 is_commu_ok c1, is_commu_ok c2 with + | false, true -> set_commu_ok c1 + | true, false -> set_commu_ok c2 + | false, false -> link_commu ~inside:c1 c2 + | true, true -> () + 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_trace _ -> + 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 get_desc t2' with + Tobject (_, {contents = Some (_, va::_)}) when + (match get_desc va 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_trace _ -> + 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 + Fprivate when f <> dummy_method -> + link_kind ~inside:kind field_absent; + if d2 = Tnil then unify env rem t2' + else unify env (newgenty 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) + (get_level t1) p1 fl1 (get_level t2) 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_for Unify (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> + raise_for Unify (Obj (Abstract_row First)) + | (_, _) -> raise_unexplained_for Unify + end; + (* XXX Commentaires + changer "create_recursion" + ||| Comments + change "create_recursion" *) + if create_recursion then + match get_desc t2 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 t2 t2' + | _ -> + () (* t2 has already been expanded by update_level *) + with Unify_trace trace -> + Transient_expr.set_desc tt1' 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 get_desc ty with + Tvar None -> set_type_desc ty (Tvar name) + | _ -> () + in + let name = + match get_desc rest1, get_desc rest2 with + Tvar (Some _ as name1), Tvar (Some _ as name2) -> + if get_level rest1 <= get_level rest2 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 newty2 ~level (Tvar name) + +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 = get_level ty1 and l2 = get_level ty2 in + let va = make_rowvar (Int.min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in + let tr1 = Transient_expr.repr rest1 and tr2 = Transient_expr.repr rest2 in + let d1 = tr1.desc and d2 = tr2.desc in + try + unify env (build_fields l1 miss1 va) rest2; + unify env rest1 (build_fields l2 miss2 va); + List.iter + (fun (name, k1, t1, k2, t2) -> + unify_kind k1 k2; + try + if !trace_gadt_instances then begin + update_level_for Unify !env (get_level va) t1; + update_scope_for Unify (get_scope va) t1 + end; + unify env t1 t2 + with Unify_trace trace -> + raise_trace_for Unify + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) + ) + pairs + with exn -> + Transient_expr.set_desc tr1 d1; + Transient_expr.set_desc tr2 d2; + raise exn + +and unify_kind k1 k2 = + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fprivate) -> link_kind ~inside:k2 k1 + | (Fpublic, Fpublic) -> () + | _ -> assert false + +and unify_row env row1 row2 = + let Row {fields = row1_fields; more = rm1; + closed = row1_closed; name = row1_name} = row_repr row1 in + let Row {fields = row2_fields; more = rm2; + closed = row2_closed; name = row2_name} = row_repr row2 in + if unify_eq rm1 rm2 then () else + let r1, r2, pairs = merge_row_fields row1_fields row2_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 get_level rm2 < get_level rm1 then rm2 else rm1 + | Some _, None -> rm1 + | None, Some _ -> rm2 + | None, None -> + newty2 ~level:(Int.min (get_level rm1) (get_level rm2)) (Tvar None) + in + let fixed = merge_fixed_explanation fixed1 fixed2 + and closed = row1_closed || row2_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_closed) && (empty r2 || row1_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_name <> None && (row1_closed || empty r2) && + (not row2_closed || keep (fun f1 f2 -> f1, f2) && empty r1) + then row1_name + else if row2_name <> None && (row2_closed || empty r1) && + (not row1_closed || keep (fun f1 f2 -> f2, f1) && empty r2) + then row2_name + else None + in + let set_more pos row rest = + let rest = + if closed then + filter_row_fields (row_closed row) rest + else rest in + begin match fixed_explanation row with + | None -> + if rest <> [] && row_closed row then + raise_for Unify (Variant (No_tags(pos,rest))) + | Some fixed -> + if closed && not (row_closed row) 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 (get_level rm) (newgenty (Tvariant row)); + if has_fixed_explanation row then + if eq_type more rm then () else + if is_Tvar rm then link_type rm more else unify env rm more + else + let ty = + newgenty (Tvariant + (create_row ~fields:rest ~more ~closed ~fixed ~name)) + in + update_level_for Unify !env (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty; + link_type rm ty + in + let tm1 = Transient_expr.repr rm1 and tm2 = Transient_expr.repr rm2 in + let md1 = tm1.desc and md2 = tm2.desc in + begin try + set_more Second row2 r1; + set_more First row1 r2; + List.iter + (fun (l,f1,f2) -> + try unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 + with Unify_trace 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 ~level:(get_level rm) Tnil) + end + with exn -> + Transient_expr.set_desc tm1 md1; + Transient_expr.set_desc tm2 md2; + raise exn + end + +and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = + 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 row_field_repr f1, row_field_repr f2 with + Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 + | Rpresent None, Rpresent None -> () + | Reither(c1, tl1, m1), Reither(c2, tl2, m2) -> + if eq_row_field_ext f1 f2 then () else + let no_arg = c1 || c2 and matched = m1 || m2 in + if either_fixed && not no_arg + && List.length tl1 = List.length tl2 then begin + (* PR#7496 *) + let f = rf_either [] ~no_arg ~matched in + link_row_field_ext ~inside:f1 f; link_row_field_ext ~inside:f2 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 no_arg then raise_unexplained_for Unify; + Types.changed_row_field_exts [f1;f2] (fun () -> + List.iter (unify env t1) tl + ) + end in + if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else + let remq tl = + List.filter (fun ty -> not (List.exists (eq_type ty) 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? *) + let update_levels rm = + List.iter + (fun ty -> + update_level_for Unify !env (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty) + in + update_levels rm2 tl1'; + update_levels rm1 tl2'; + let f1' = rf_either tl2' ~no_arg ~matched in + let f2' = rf_either tl1' ~use_ext_of:f1' ~no_arg ~matched in + link_row_field_ext ~inside:f1 f1'; link_row_field_ext ~inside:f2 f2'; + | Reither(_, _, false), Rabsent -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rabsent, Reither(_, _, false) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | Rabsent, Rabsent -> () + | Reither(false, tl, _), Rpresent(Some t2) -> + if_not_fixed first (fun () -> + let s = snapshot () in + link_row_field_ext ~inside:f1 f2; + update_level_for Unify !env (get_level rm1) t2; + update_scope_for Unify (get_scope rm1) t2; + (try List.iter (fun t1 -> unify env t1 t2) tl + with exn -> undo_first_change_after s; raise exn) + ) + | Rpresent(Some t1), Reither(false, tl, _) -> + if_not_fixed second (fun () -> + let s = snapshot () in + link_row_field_ext ~inside:f2 f1; + update_level_for Unify !env (get_level rm2) t1; + update_scope_for Unify (get_scope rm2) t1; + (try List.iter (unify env t1) tl + with exn -> undo_first_change_after s; raise exn) + ) + | Reither(true, [], _), Rpresent None -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rpresent None, Reither(true, [], _) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | _ -> raise_unexplained_for Unify + +let unify env ty1 ty2 = + let snap = Btype.snapshot () in + try + unify env ty1 ty2 + with + Unify_trace trace -> + undo_compress snap; + raise (Unify (expand_to_unification_error !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 = + if eq_type t1 t2 then () else + match get_desc t1, get_desc t2 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 (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2; + reset_trace_gadt_instances reset_tracing; + with Unify_trace trace -> + reset_trace_gadt_instances reset_tracing; + raise (Unify (expand_to_unification_error + env + (Diff { got = t1; expected = t2 } :: trace))) + end + | _ -> + unify (ref env) t1 t2 + +let _ = unify_var' := 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 +*) + +type filter_arrow_failure = + | Unification_error of unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +let filter_arrow env t l = + let function_type level = + let t1 = newvar2 level and t2 = newvar2 level in + let t' = newty2 ~level (Tarrow (l, t1, t2, commu_ok)) in + t', t1, t2 + in + let t = + try expand_head_trace env t + with Unify_trace trace -> + let t', _, _ = function_type (get_level t) in + raise (Filter_arrow_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = t'; expected = t } :: trace)))) + in + match get_desc t with + | Tvar _ -> + let t', t1, t2 = function_type (get_level t) in + link_type t t'; + (t1, t2) + | Tarrow(l', t1, t2, _) -> + if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') + then (t1, t2) + else raise (Filter_arrow_failed + (Label_mismatch + { got = l; expected = l'; expected_type = t })) + | _ -> + raise (Filter_arrow_failed Not_a_function) + +type filter_method_failure = + | Unification_error of unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + +(* Used by [filter_method]. *) +let rec filter_method_field env name ty = + let method_type ~level = + let ty1 = newvar2 level and ty2 = newvar2 level in + let ty' = newty2 ~level (Tfield (name, field_public, ty1, ty2)) in + ty', ty1 + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let ty', _ = method_type ~level in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let ty', ty1 = method_type ~level in + link_type ty ty'; + ty1 + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + unify_kind kind field_public; + ty1 + end else + filter_method_field env name ty2 + | _ -> + raise (Filter_method_failed Not_a_method) + +(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) +let filter_method env name ty = + let object_type ~level ~scope = + let ty1 = newvar2 level in + let ty' = newty3 ~level ~scope (Tobject (ty1, ref None)) in + let ty_meth = filter_method_field env name ty1 in + (ty', ty_meth) + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let scope = get_scope ty in + let ty', _ = object_type ~level ~scope in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let scope = get_scope ty in + let ty', ty_meth = object_type ~level ~scope in + link_type ty ty'; + ty_meth + | Tobject(f, _) -> + filter_method_field env name f + | _ -> + raise (Filter_method_failed (Not_an_object ty)) + +exception Filter_method_row_failed + +let rec filter_method_row env name priv ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let field = newvar2 level in + let row = newvar2 level in + let kind, priv = + match priv with + | Private -> + let kind = field_private () in + kind, Mprivate kind + | Public -> + field_public, Mpublic + in + let ty' = newty2 ~level (Tfield (name, kind, field, row)) in + link_type ty ty'; + priv, field, row + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + let priv = + match priv with + | Public -> + unify_kind kind field_public; + Mpublic + | Private -> Mprivate kind + in + priv, ty1, ty2 + end else begin + let level = get_level ty in + let priv, field, row = filter_method_row env name priv ty2 in + let row = newty2 ~level (Tfield (n, kind, ty1, row)) in + priv, field, row + end + | Tnil -> + if name = Btype.dummy_method then raise Filter_method_row_failed + else begin + match priv with + | Public -> raise Filter_method_row_failed + | Private -> + let level = get_level ty in + let kind = field_absent in + Mprivate kind, newvar2 level, ty + end + | _ -> + raise Filter_method_row_failed + +(* Operations on class signatures *) + +let new_class_signature () = + let row = newvar () in + let self = newobj row in + { csig_self = self; + csig_self_row = row; + csig_vars = Vars.empty; + csig_meths = Meths.empty; } + +let add_dummy_method env ~scope sign = + let _, ty, row = + filter_method_row env dummy_method Private sign.csig_self_row + in + unify env ty (new_scoped_ty scope (Ttuple [])); + sign.csig_self_row <- row + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +let add_method env label priv virt ty sign = + let meths = sign.csig_meths in + let priv, virt = + match Meths.find label meths with + | (priv', virt', ty') -> begin + let priv = + match priv' with + | Mpublic -> Mpublic + | Mprivate k -> + match priv with + | Public -> + begin match field_kind_repr k with + | Fpublic -> () + | Fprivate -> link_kind ~inside:k field_public + | Fabsent -> assert false + end; + Mpublic + | Private -> priv' + in + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + match unify env ty ty' with + | () -> priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + | exception Not_found -> begin + let priv, ty', row = + match filter_method_row env label priv sign.csig_self_row with + | priv, ty', row -> + priv, ty', row + | exception Filter_method_row_failed -> + raise (Add_method_failed Unexpected_method) + in + match unify env ty ty' with + | () -> + sign.csig_self_row <- row; + priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + in + let meths = Meths.add label (priv, virt, ty) meths in + sign.csig_meths <- meths + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +let check_mutability mut mut' = + match mut, mut' with + | Mutable, Mutable -> () + | Immutable, Immutable -> () + | Mutable, Immutable | Immutable, Mutable -> + raise (Add_instance_variable_failed (Mutability_mismatch mut)) + +let add_instance_variable ~strict env label mut virt ty sign = + let vars = sign.csig_vars in + let virt = + match Vars.find label vars with + | (mut', virt', ty') -> + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + if strict then begin + check_mutability mut mut'; + match unify env ty ty' with + | () -> () + | exception Unify trace -> + raise (Add_instance_variable_failed (Type_mismatch trace)) + end; + virt + | exception Not_found -> virt + in + let vars = Vars.add label (mut, virt, ty) vars in + sign.csig_vars <- vars + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +let unify_self_types env sign1 sign2 = + let self_type1 = sign1.csig_self in + let self_type2 = sign2.csig_self in + match unify env self_type1 self_type2 with + | () -> () + | exception Unify err -> begin + match err.trace with + | Errortrace.Diff _ :: Errortrace.Incompatible_fields {name; _} :: rem -> + let err = Errortrace.unification_error ~trace:rem in + let failure = Method (name, Type_mismatch err) in + raise (Inherit_class_signature_failed failure) + | _ -> + raise (Inherit_class_signature_failed (Self_type_mismatch err)) + end + +(* Unify components of sign2 into sign1 *) +let inherit_class_signature ~strict env sign1 sign2 = + unify_self_types env sign1 sign2; + Meths.iter + (fun label (priv, virt, ty) -> + let priv = + match priv with + | Mpublic -> Public + | Mprivate kind -> + assert (field_kind_repr kind = Fabsent); + Private + in + match add_method env label priv virt ty sign1 with + | () -> () + | exception Add_method_failed failure -> + let failure = Method(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_meths; + Vars.iter + (fun label (mut, virt, ty) -> + match add_instance_variable ~strict env label mut virt ty sign1 with + | () -> () + | exception Add_instance_variable_failed failure -> + let failure = Instance_variable(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_vars + +let update_class_signature env sign = + let self = expand_head env sign.Types.csig_self in + let fields, row = flatten_fields (object_fields self) in + let meths, implicitly_public, implicitly_declared = + List.fold_left + (fun (meths, implicitly_public, implicitly_declared) (lab, k, ty) -> + if lab = dummy_method then + meths, implicitly_public, implicitly_declared + else begin + match Meths.find lab meths with + | priv, virt, ty' -> + let meths, implicitly_public = + match priv, field_kind_repr k with + | Mpublic, _ -> meths, implicitly_public + | Mprivate _, Fpublic -> + let meths = Meths.add lab (Mpublic, virt, ty') meths in + let implicitly_public = lab :: implicitly_public in + meths, implicitly_public + | Mprivate _, _ -> meths, implicitly_public + in + meths, implicitly_public, implicitly_declared + | exception Not_found -> + let meths, implicitly_declared = + match field_kind_repr k with + | Fpublic -> + let meths = Meths.add lab (Mpublic, Virtual, ty) meths in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fprivate -> + let meths = + Meths.add lab (Mprivate k, Virtual, ty) meths + in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fabsent -> meths, implicitly_declared + in + meths, implicitly_public, implicitly_declared + end) + (sign.csig_meths, [], []) fields + in + sign.csig_meths <- meths; + sign.csig_self_row <- row; + implicitly_public, implicitly_declared + +let hide_private_methods env sign = + let self = expand_head env sign.Types.csig_self in + let fields, _ = flatten_fields (object_fields self) in + List.iter + (fun (_, k, _) -> + match field_kind_repr k with + | Fprivate -> link_kind ~inside:k field_absent + | _ -> ()) + fields + +let close_class_signature env sign = + let rec close env ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + link_type ty (newty2 ~level Tnil); true + | Tfield(lab, _, _, _) when lab = dummy_method -> + false + | Tfield(_, _, _, ty') -> close env ty' + | Tnil -> true + | _ -> assert false + in + let self = expand_head env sign.csig_self in + close env (object_fields self) + +let generalize_class_signature_spine env sign = + (* Generalize the spine of methods *) + let meths = sign.csig_meths in + Meths.iter (fun _ (_, _, ty) -> generalize_spine ty) meths; + let new_meths = + Meths.map + (fun (priv, virt, ty) -> (priv, virt, generic_instance ty)) + meths + in + (* But keep levels correct on the type of self *) + Meths.iter + (fun _ (_, _, ty) -> unify_var env (newvar ()) ty) + meths; + sign.csig_meths <- new_meths + + (***********************************) + (* 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 lv = get_level ty in + if lv <= level then () else + if is_Tvar ty && lv >= 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 = + let level = get_level t1 in + if inst_nongen then level <> generic_level - 1 + else level = generic_level + +let rec moregen inst_nongen type_pairs env t1 t2 = + if eq_type t1 t2 then () else + + try + match (get_desc t1, get_desc t2) with + (Tvar _, _) when may_instantiate inst_nongen t1 -> + moregen_occur env (get_level t1) t2; + update_scope_for Moregen (get_scope t1) 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... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, _) when may_instantiate inst_nongen t1' -> + moregen_occur env (get_level t1') t2; + update_scope_for Moregen (get_scope t1') 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) + (get_level t1') p1 fl1 (get_level t2') 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 trace -> + raise_trace_for Moregen (Diff {got = t1; expected = 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 (get_level ty2) miss2 rest2); + List.iter + (fun (name, 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 trace -> + raise_trace_for Moregen + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) + ) + pairs + +and moregen_kind k1 k2 = + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fpublic) -> () + | (Fpublic, Fprivate) -> raise Public_method_to_private_method + | (Fabsent, _) | (_, Fabsent) -> assert false + +and moregen_row inst_nongen type_pairs env row1 row2 = + let Row {fields = row1_fields; more = rm1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = rm2; closed = row2_closed; + fixed = row2_fixed} = row_repr row2 in + if eq_type rm1 rm2 then () else + let may_inst = + is_Tvar rm1 && may_instantiate inst_nongen rm1 || get_desc rm1 = Tnil in + let r1, r2, pairs = merge_row_fields row1_fields row2_fields in + let r1, r2 = + if row2_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_closed then begin + match row2_closed, r2 with + | false, _ -> raise_for Moregen (Variant (Openness Second)) + | _, _ :: _ -> raise_for Moregen (Variant (No_tags (First, r2))) + | _, [] -> () + end; + let md1 = get_desc rm1 (* This lets us undo a following [link_type] *) in + begin match md1, get_desc rm2 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 + (create_row ~fields:r2 ~more:rm2 ~name:None + ~fixed:row2_fixed ~closed:row2_closed)) + in + moregen_occur env (get_level rm1) ext; + update_scope_for Moregen (get_scope rm1) ext; + (* This [link_type] has to be undone if the rest of the function fails *) + link_type rm1 ext + | Tconstr _, Tconstr _ -> + moregen inst_nongen type_pairs env rm1 rm2 + | _ -> raise_unexplained_for Moregen + end; + try + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + moregen inst_nongen type_pairs env t1 t2 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both [Reither] *) + | Reither(c1, tl1, _), Reither(c2, tl2, m2) -> begin + try + if not (eq_row_field_ext f1 f2) then begin + if c1 && not c2 then raise_unexplained_for Moregen; + let f2' = + rf_either [] ~use_ext_of:f2 ~no_arg:c2 ~matched:m2 in + link_row_field_ext ~inside:f1 f2'; + 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 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + (* Generalizing [Reither] *) + | Reither(false, tl1, _), Rpresent(Some t2) when may_inst -> begin + try + link_row_field_ext ~inside:f1 f2; + List.iter + (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Reither(true, [], _), Rpresent None when may_inst -> + link_row_field_ext ~inside:f1 f2 + | Reither(_, _, _), Rabsent when may_inst -> + link_row_field_ext ~inside:f1 f2 + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) -> + raise_for Moregen (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Moregen (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Moregen (Variant (No_tags (Second, [l, f1])))) + pairs + with exn -> + (* Undo [link_type] if we failed *) + set_type_desc rm1 md1; raise exn + +(* 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_inst = instance subj_sch in + let subj = duplicate_type subj_inst in + current_level := generic_level; + (* Duplicate generic variables *) + let patt = instance pat_sch in + + Misc.try_finally + (fun () -> + try + moregen inst_nongen (TypePairs.create 13) env patt subj + with Moregen_trace trace -> + (* Moregen splits the generic level into two finer levels: + [generic_level] and [generic_level - 1]. In order to properly + detect and print weak variables when printing this error, we need to + merge them back together, by regeneralizing the levels of the types + after they were instantiated at [generic_level - 1] above. Because + [moregen] does some unification that we need to preserve for more + legible error messages, we have to manually perform the + regeneralization rather than backtracking. *) + current_level := generic_level - 2; + generalize subj_inst; + raise (Moregen (expand_to_moregen_error env trace))) + ~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 = + if try_mark_node ty then + begin match get_desc ty with + | Tvar _ -> + if not (TypeSet.mem ty !vars) then vars := TypeSet.add ty !vars + | Tvariant row -> + let Row {more; name; closed} = row_repr row in + if is_Tvar more && not (has_fixed_explanation row) then begin + let more' = newty2 ~level:(get_level more) (get_desc more) in + let row' = + create_row ~fixed:(Some Rigid) ~fields:[] ~more:more' + ~name ~closed + in link_type more (newty2 ~level:(get_level ty) (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 TypeSet.empty in + rigidify_rec vars ty; + unmark_type ty; + TypeSet.elements !vars + +let all_distinct_vars env vars = + let tys = ref TypeSet.empty in + List.for_all + (fun ty -> + let ty = expand_head env ty in + if TypeSet.mem ty !tys then false else + (tys := TypeSet.add ty !tys; is_Tvar ty)) + vars + +let matches ~expand_error_trace 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; + let diff = + if expand_error_trace + then expanded_diff env ~got:ty ~expected:ty' + else unexpanded_diff ~got:ty ~expected:ty' + in + raise (Matches_failure (env, unification_error ~trace:[diff])) + end; + backtrack snap + | exception Unify err -> + backtrack snap; + raise (Matches_failure (env, err)) + +let does_match env ty ty' = + match matches ~expand_error_trace:false 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 eqtype_subst type_pairs subst t1 t2 = + if List.exists + (fun (t,t') -> + let found1 = eq_type t1 t in + let found2 = eq_type t2 t' in + if found1 && found2 then true else + if found1 || found2 then raise_unexplained_for Equality else false) + !subst + then () + else begin + subst := (t1, t2) :: !subst; + TypePairs.add type_pairs (t1, t2) + end + +let rec eqtype rename type_pairs subst env t1 t2 = + if eq_type t1 t2 then () else + + try + match (get_desc t1, get_desc t2) with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1 t2 + | (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... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1' t2' + | (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) + (get_level t1') p1 fl1 (get_level t2') 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 trace -> + raise_trace_for Equality (Diff {got = t1; expected = 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 = + eq_type rest1 rest2 || TypePairs.mem type_pairs (rest1,rest2) + in + if same_row then () else + (* Try expansion, needed when called from Includecore.type_manifest *) + match get_desc (expand_head_rigid env rest2) with + 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 (name, k1, t1, k2, t2) -> + eqtype_kind k1 k2; + try + eqtype rename type_pairs subst env t1 t2; + with Equality_trace trace -> + raise_trace_for Equality + (incompatible_fields ~name ~got:t1 ~expected: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 + | (Fprivate, Fprivate) + | (Fpublic, Fpublic) -> () + | _ -> raise_unexplained_for Unify + (* It's probably not possible to hit this case with + real OCaml code *) + +and eqtype_row rename type_pairs subst env row1 row2 = + (* Try expansion, needed when called from Includecore.type_manifest *) + match get_desc (expand_head_rigid env (row_more row2)) with + Tvariant row2 -> eqtype_row rename type_pairs subst env row1 row2 + | _ -> + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + if row_closed row1 <> row_closed row2 then begin + raise_for Equality + (Variant (Openness (if row_closed row2 then First else Second))) + end; + if not (row_closed row1) 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 (row_more row1) (row_more row2); + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + eqtype rename type_pairs subst env t1 t2 + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both matching [Reither]s *) + | Reither(c1, [], _), Reither(c2, [], _) when c1 = c2 -> () + | Reither(c1, t1::tl1, _), Reither(c2, t2::tl2, _) + when c1 = c2 -> begin + try + 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 + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) + | Reither _, Reither _ -> + raise_for Equality (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Equality (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Equality (Variant (No_tags (Second, [l, f1])))) + 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 = + let subst = ref [] in + try eqtype_list rename (TypePairs.create 11) subst env tyl1 tyl2 + with Equality_trace trace -> + raise (Equality (expand_to_equality_error env trace !subst)) + +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 = + CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of Env.t * equality_error + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of Env.t * moregen_error + | CM_Val_type_mismatch of string * Env.t * comparison_error + | CM_Meth_type_mismatch of string * Env.t * comparison_error + | 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 match_class_sig_shape ~strict sign1 sign2 = + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> CM_Missing_method lab::err + | (priv', vr', _) -> + match priv', priv with + | Mpublic, Mprivate _ -> CM_Public_method lab::err + | Mprivate _, Mpublic when strict -> CM_Private_method lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Virtual_method lab::err + | _, _ -> err) + sign2.csig_meths [] + in + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + if Meths.mem lab sign2.csig_meths then err + else begin + let err = + match priv with + | Mpublic -> CM_Hide_public lab :: err + | Mprivate _ -> err + in + match vr with + | Virtual -> CM_Hide_virtual ("method", lab) :: err + | Concrete -> err + end) + sign1.csig_meths errors + in + let errors = + Vars.fold + (fun lab (mut, vr, _) err -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> CM_Missing_value lab::err + | (mut', vr', _) -> + match mut', mut with + | Immutable, Mutable -> CM_Non_mutable_value lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Non_concrete_value lab::err + | _, _ -> err) + sign2.csig_vars errors + in + 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 errors + +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 trace -> + raise (Failure [ + CM_Parameter_mismatch (env, expand_to_moregen_error env trace)]) + end; + moregen_clty false type_pairs env cty1' cty2' + | Cty_signature sign1, Cty_signature sign2 -> + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error env trace))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error 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 sign1 = signature_of_class_type pat_sch in + let sign2 = signature_of_class_type subj_sch in + let errors = match_class_sig_shape ~strict:false sign1 sign2 in + match errors with + | [] -> + 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 type_pairs = TypePairs.create 53 in + let sign1 = signature_of_class_type patt in + let sign2 = signature_of_class_type subj in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + moregen true type_pairs env row1 row2; + let res = + match moregen_clty trace type_pairs env patt subj with + | () -> [] + | exception Failure res -> + (* We've found an error. Moregen splits the generic level into two + finer levels: [generic_level] and [generic_level - 1]. In order + to properly detect and print weak variables when printing this + error, we need to merge them back together, by regeneralizing the + levels of the types after they were instantiated at + [generic_level - 1] above. Because [moregen] does some + unification that we need to preserve for more legible error + messages, we have to manually perform the regeneralization rather + than backtracking. *) + current_level := generic_level - 2; + generalize_class_type subj_inst; + res + in + current_level := old_level; + res + | errors -> + CM_Class_type_mismatch (env, pat_sch, subj_sch) :: errors + +let equal_clsig trace type_pairs subst env sign1 sign2 = + try + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + 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 sign1 = signature_of_class_type patt_type in + let sign2 = signature_of_class_type subj_type in + let errors = match_class_sig_shape ~strict:true sign1 sign2 in + match errors with + | [] -> begin + try + let subst = ref [] in + let type_pairs = TypePairs.create 53 in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + eqtype true type_pairs subst env row1 row2; + 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 trace -> + raise (Failure + [CM_Type_parameter_mismatch + (env, expand_to_equality_error env trace !subst)])) + 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 get_desc ty 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 : transient_expr list) + (loops : (int * type_expr) list) posi level t = + match get_desc t with + Tvar _ -> + if posi then + try + let t' = List.assq (get_id t) loops in + warn := true; + (t', Equiv) + with Not_found -> + (t, Unchanged) + else + (t, Unchanged) + | Tarrow(l, t1, t2, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: 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', commu_ok)), c) + else (t, Unchanged) + | Ttuple tlist -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: 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' = expand_abbrev env t in + let level' = pred_expand level in + begin try match get_desc t' 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 ty1, tl1 = + match get_desc ty 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 = (get_id ty, t'') :: loops in + (* May discard [visited] as level is going down *) + let (ty1', c) = + build_subtype env [Transient_expr.repr 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 *) + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: 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 tt = Transient_expr.repr t in + if memq_warn tt visited || not (static_row row) then (t, Unchanged) else + let level' = pred_enlarge level in + let visited = + tt :: if level' < level then [] else filter_visited visited in + let fields = filter_row_fields false (row_fields row) in + let fields = + List.map + (fun (l,f as orig) -> match row_field_repr f with + Rpresent None -> + if posi then + (l, rf_either_of 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 rf_either_of (Some t') + else rf_present (Some t') + in (l, f), c + | _ -> assert false) + fields + in + let c = collect fields in + let row = + create_row ~fields:(List.map fst fields) ~more:(newvar ()) + ~closed:posi ~fixed:None + ~name:(if c > Unchanged then None else row_name row) + in + (newty (Tvariant row), Changed) + | Tobject (t1, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited || opened_object t1 then (t, Unchanged) else + let level' = pred_enlarge level in + let visited = + tt :: 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, field_public, 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 ~unification_trace = + raise (Subtype (Subtype.error + ~trace:(expand_subtype_trace env (List.rev trace)) + ~unification_trace)) + +let rec subtype_rec env trace t1 t2 cstrs = + if eq_type t1 t2 then cstrs else + + if TypePairs.mem subtypes (t1, t2) then + cstrs + else begin + TypePairs.add subtypes (t1, t2); + match (get_desc t1, get_desc t2) 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 {got = t2; expected = t1} :: trace) + t2 t1 + cstrs + in + subtype_rec + env + (Subtype.Diff {got = u1; expected = 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 ~level:(get_level t1) (Ttuple[t1]), + newty2 ~level:(get_level t2) (Ttuple[t2]), !univar_pairs) + :: cstrs + else + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + else + if cn + then + subtype_rec + env + (Subtype.Diff {got = t2; expected = 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 (get_level t1) (Mty_ident p1) fl1 + and ntl2 = + complete_type_list env fl1 (get_level t2) (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 ~unification_trace:[]; + List.fold_left2 + (fun cstrs t1 t2 -> + subtype_rec + env + (Subtype.Diff { got = t1; expected = 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 get_desc rest2 = Tnil then cstrs else + if miss1 = [] then + subtype_rec + env + (Subtype.Diff {got = rest1; expected = rest2} :: trace) + rest1 rest2 + cstrs + else + (trace, build_fields (get_level ty1) miss1 rest1, rest2, + !univar_pairs) :: cstrs + in + let cstrs = + if miss2 = [] then cstrs else + (trace, rest1, build_fields (get_level ty2) 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 {got = t1; expected = t2} :: trace) + t1 t2 + cstrs) + cstrs pairs + +and subtype_row env trace row1 row2 cstrs = + let Row {fields = row1_fields; more = more1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = more2; closed = row2_closed} = + row_repr row2 in + let r1, r2, pairs = + merge_row_fields row1_fields row2_fields in + let r1 = if row2_closed then filter_row_fields false r1 else r1 in + let r2 = if row1_closed then filter_row_fields false r2 else r2 in + match get_desc more1, get_desc more2 with + Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> + subtype_rec + env + (Subtype.Diff {got = more1; expected = more2} :: trace) + more1 more2 + cstrs + | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) + when row1_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 {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Reither(false, t1::_, _), Rpresent(Some t2) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Rabsent, _ -> cstrs + | _ -> raise Exit) + cstrs pairs + | Tunivar _, Tunivar _ + when row1_closed = row2_closed && r1 = [] && r2 = [] -> + let cstrs = + subtype_rec + env + (Subtype.Diff {got = more1; expected = 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 {got = t1; expected = 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 {got = ty1; expected = 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} -> + subtype_error ~env ~trace:trace0 ~unification_trace:(List.tl trace)) + (List.rev cstrs) + + (*******************) + (* Miscellaneous *) + (*******************) + +(* Utility for printing. The resulting type is not used in computation. *) +let rec unalias_object ty = + let level = get_level ty in + match get_desc ty with + Tfield (s, k, t1, t2) -> + newty2 ~level (Tfield (s, k, t1, unalias_object t2)) + | Tvar _ | Tnil as desc -> + newty2 ~level desc + | Tunivar _ -> + ty + | Tconstr _ -> + newvar2 level + | _ -> + assert false + +let unalias ty = + let level = get_level ty in + match get_desc ty with + Tvar _ | Tunivar _ -> + ty + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + newty2 ~level + (Tvariant + (create_row ~fields ~name ~fixed ~closed ~more: + (newty2 ~level:(get_level more) (get_desc more)))) + | Tobject (ty, nm) -> + newty2 ~level (Tobject (unalias_object ty, nm)) + | desc -> + newty2 ~level desc + +(* Return the arity (as for curried functions) of the given type. *) +let rec arity ty = + match get_desc ty with + Tarrow(_, _t1, t2, _) -> 1 + arity t2 + | _ -> 0 + +(* Check for non-generalizable type variables *) +exception Nongen +let visited = ref TypeSet.empty + +let rec nongen_schema_rec env ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty with + Tvar _ when get_level ty <> generic_level -> + raise Nongen + | Tconstr _ -> + let old = !visited in + begin try iter_type_expr (nongen_schema_rec env) ty + with Nongen -> try + visited := old; + nongen_schema_rec env (try_expand_head try_expand_safe env ty) + with Cannot_expand -> + raise Nongen + end + | Tfield(_, kind, t1, t2) -> + if field_kind_repr kind = Fpublic then + nongen_schema_rec env t1; + nongen_schema_rec env t2 + | Tvariant row -> + iter_row (nongen_schema_rec env) row; + if not (static_row row) then nongen_schema_rec env (row_more row) + | _ -> + iter_type_expr (nongen_schema_rec env) ty + end + +(* Return whether all variables of type [ty] are generic. *) +let nongen_schema env ty = + visited := TypeSet.empty; + try + nongen_schema_rec env ty; + visited := TypeSet.empty; + false + with Nongen -> + visited := TypeSet.empty; + true + +(* 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 nongen_class_type = function + | Cty_constr (_, params, _) -> + List.exists (nongen_schema Env.empty) params + | Cty_signature sign -> + nongen_schema Env.empty sign.csig_self + || nongen_schema Env.empty sign.csig_self_row + || Meths.exists + (fun _ (_, _, ty) -> nongen_schema Env.empty ty) + sign.csig_meths + || Vars.exists + (fun _ (_, _, ty) -> nongen_schema Env.empty ty) + sign.csig_vars + | Cty_arrow (_, ty, cty) -> + nongen_schema Env.empty ty + || nongen_class_type cty + +let nongen_class_declaration cty = + List.exists (nongen_schema Env.empty) cty.cty_params + || nongen_class_type cty.cty_type + + +(* Normalize a type before printing, saving... *) +(* Cannot use mark_type because deep_occur uses it too *) +let rec normalize_type_rec visited ty = + 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 get_desc tm 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 get_desc ty with + | Tvariant row -> + let Row {fields = orig_fields; more; name; fixed; closed} = + row_repr row in + let fields = List.map + (fun (l,f) -> + l, + match row_field_repr f with Reither(b, ty::(_::_ as tyl), m) -> + let tyl' = + List.fold_left + (fun tyl ty -> + if List.exists + (fun ty' -> is_equal Env.empty false [ty] [ty']) + tyl + then tyl + else ty::tyl) + [ty] tyl + in + if List.length tyl' <= List.length tyl then + rf_either (List.rev tyl') ~use_ext_of:f ~no_arg:b ~matched:m + else f + | _ -> f) + orig_fields in + let fields = + List.sort (fun (p,_) (q,_) -> compare p q) + (List.filter (fun (_,fi) -> row_field_repr fi <> Rabsent) fields) in + set_type_desc ty (Tvariant + (create_row ~fields ~more ~name ~fixed ~closed)) + | 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 + begin match get_desc v with + | Tvar _ | Tunivar _ -> () + | Tnil -> set_type_desc ty (Tconstr (n, l, ref Mnil)) + | _ -> set_name nm None + end + | _ -> + fatal_error "Ctype.normalize_type_rec" + end; + let level = get_level fi in + if level < lowest_level then () else + let fields, row = flatten_fields fi in + let fi' = build_fields level fields row in + set_type_desc fi (get_desc fi') + | _ -> () + 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 get_desc ty with + Tvar _ | Tunivar _ -> ty + | _ -> try TypeHash.find nondep_hash ty + with Not_found -> + let ty' = newgenstub ~scope:(get_scope ty) in + TypeHash.add nondep_hash ty ty'; + let desc = + match get_desc ty with + | Tconstr(p, tl, _abbrev) as desc -> + 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 ~level:(get_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 more = row_more row 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_name row with + Some (p, _tl) when Path.exists_free ids p -> + Tvariant (set_row_name row None) + | _ -> Tvariant row + end + | desc -> copy_type_desc (nondep_type_rec env ids) desc + in + Transient_expr.set_stub_desc ty' desc; + 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 get_desc ty' 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_self_row = nondep_type_rec env id sign.csig_self_row; + csig_vars = + Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) + sign.csig_vars; + csig_meths = + Meths.map (function (p, v, t) -> (p, v, nondep_type_rec env id t)) + sign.csig_meths } + +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 id = get_id ty in + if List.memq id visited then () else + let visited = id :: visited in + match get_desc ty with + Tvariant row -> + List.iter + (fun (_l,fi) -> + match row_field_repr fi with + Reither (_c, t1::(_::_ as tl), _m) -> + List.iter (unify env t1) tl + | _ -> + ()) + (row_fields row); + 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 get_desc t1, get_desc t2 with + | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2 + | _ -> false + +let () = + Env.same_constr := same_constr + +let immediacy env typ = + match get_desc typ 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 -> + (* if all labels are devoid of arguments, not a pointer *) + if + not (row_closed row) + || List.exists + (fun (_, f) -> match row_field_repr f with + | Rpresent (Some _) | Reither (false, _, _) -> true + | _ -> false) + (row_fields row) + then + Type_immediacy.Unknown + else + Type_immediacy.Always + | _ -> Type_immediacy.Unknown diff --git a/upstream/ocaml_500/typing/ctype.mli b/upstream/ocaml_500/typing/ctype.mli new file mode 100644 index 0000000000..0e3aefc2c0 --- /dev/null +++ b/upstream/ocaml_500/typing/ctype.mli @@ -0,0 +1,426 @@ +(**************************************************************************) +(* *) +(* 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 + +exception Unify of Errortrace.unification_error +exception Equality of Errortrace.equality_error +exception Moregen of Errortrace.moregen_error +exception Subtype of Errortrace.Subtype.error + +exception Escape of type_expr Errortrace.escape + +exception Tags of label * label +exception Cannot_expand +exception Cannot_apply +exception Matches_failure of Env.t * Errortrace.unification_error + (* 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 new_scoped_ty: int -> 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 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 set_object_name: + Ident.t -> type_expr list -> type_expr -> unit +val remove_object_name: 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 lower_variables_only: Env.t -> int -> type_expr -> unit + (* Lower all variables to the given level *) +val generalize_structure: type_expr -> unit + (* Generalize the structure of a type, lowering variables + to !current_level *) +val generalize_class_type : class_type -> unit + (* Generalize the components of a class type *) +val generalize_class_type_structure : class_type -> unit + (* Generalize the structure of the components of a class type *) +val generalize_class_signature_spine : Env.t -> class_signature -> unit + (* Special function to generalize methods 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 limited_generalize_class_type: type_expr -> class_type -> unit + (* Same, but for class types *) + +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. *) + +(** Expansion of types for error traces; lives here instead of in [Errortrace] + because the expansion machinery lives here. *) + +(** Create an [Errortrace.Diff] by expanding the two types *) +val expanded_diff : + Env.t -> + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +(** Create an [Errortrace.Diff] by *duplicating* the two types, so that each + one's expansion is identical to itself. Despite the name, does create + [Errortrace.expanded_type]s. *) +val unexpanded_diff : + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +val full_expand: may_forget_scope:bool -> Env.t -> type_expr -> type_expr + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + (* The original path of the types, and the first concrete + type declaration found expanding it. *) + | Has_no_typedecl + | May_have_typedecl + +val extract_concrete_typedecl: + Env.t -> type_expr -> typedecl_extraction_result + +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 -> Btype.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]. Raises + [Filter_arrow_failed] instead of [Unify]. *) +val filter_method: Env.t -> string -> type_expr -> type_expr + (* A special case of unification (with {m : 'a; 'b}). Raises + [Filter_method_failed] instead of [Unify]. *) +val occur_in: Env.t -> type_expr -> type_expr -> bool +val deep_occur: type_expr -> type_expr -> bool +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: expand_error_trace:bool -> Env.t -> type_expr -> type_expr -> unit + (* Same as [moregeneral false], implemented using the two above + functions and backtracking. Ignore levels. The [expand_error_trace] + flag controls whether the error raised performs expansion; this + should almost always be [true]. *) +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. *) + +(* Exceptions for special cases of unify *) + +type filter_arrow_failure = + | Unification_error of Errortrace.unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +type filter_method_failure = + | Unification_error of Errortrace.unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + +type class_match_failure = + CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of Env.t * Errortrace.equality_error + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of Env.t * Errortrace.moregen_error + | CM_Val_type_mismatch of string * Env.t * Errortrace.comparison_error + | CM_Meth_type_mismatch of string * Env.t * Errortrace.comparison_error + | 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. *) + +(* Operations on class signatures *) + +val new_class_signature : unit -> class_signature +val add_dummy_method : Env.t -> scope:int -> class_signature -> unit + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +val add_method : Env.t -> + label -> private_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +val add_instance_variable : strict:bool -> Env.t -> + label -> mutable_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +val inherit_class_signature : strict:bool -> Env.t -> + class_signature -> class_signature -> unit + +val update_class_signature : + Env.t -> class_signature -> label list * label list + +val hide_private_methods : Env.t -> class_signature -> unit + +val close_class_signature : Env.t -> class_signature -> bool + +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 nongen_schema: Env.t -> type_expr -> bool + (* Check whether the given type scheme contains no non-generic + type variables *) + +val nongen_class_declaration: class_declaration -> bool + (* Check whether the given class type contains no non-generic + type variables. Uses the empty environment. *) + +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 +val closed_class: + type_expr list -> class_signature -> + (type_expr * bool * string * type_expr) option + (* Check whether all type variables are bound *) + +val unalias: type_expr -> type_expr + +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 + +(* 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_500/typing/datarepr.ml b/upstream/ocaml_500/typing/datarepr.ml new file mode 100644 index 0000000000..75b3a1e660 --- /dev/null +++ b/upstream/ocaml_500/typing/datarepr.ml @@ -0,0 +1,238 @@ +(**************************************************************************) +(* *) +(* 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 = + if try_mark_node ty then + match get_desc ty with + | Tvar _ -> + ret := TypeSet.add ty !ret + | Tvariant row -> + iter_row loop row; + if not (static_row row) then begin + match get_desc (row_more row) with + | Tvar _ when param -> ret := TypeSet.add ty !ret + | _ -> loop (row_more row) + 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 in + List.iter + (fun {cd_args; _} -> + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts) + 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_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_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 = + create_expr (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_500/typing/datarepr.mli b/upstream/ocaml_500/typing/datarepr.mli new file mode 100644 index 0000000000..38f05f74f0 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/env.ml b/upstream/ocaml_500/typing/env.ml new file mode 100644 index 0000000000..88d0861fa0 --- /dev/null +++ b/upstream/ocaml_500/typing/env.ml @@ -0,0 +1,3667 @@ +(**************************************************************************) +(* *) +(* 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 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 + +let uid_to_loc : Location.t Types.Uid.Tbl.t ref = + s_table Types.Uid.Tbl.create 16 + +let register_uid uid loc = Types.Uid.Tbl.add !uid_to_loc uid loc + +let get_uid_to_loc_tbl () = !uid_to_loc + +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_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_prefixing_subst: Subst.t; + cm_path: Path.t; + cm_addr: address_lazy; + cm_mty: Subst.Lazy.modtype; + cm_shape: Shape.t; +} + +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_shape: Shape.t; + 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; + vda_shape : Shape.t } + +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; + cda_shape: Shape.t; } + +and label_data = label_description + +and type_data = + { tda_declaration : type_declaration; + tda_descriptions : type_descriptions; + tda_shape : Shape.t; } + +and module_data = + { mda_declaration : Subst.Lazy.module_decl; + mda_components : module_components; + mda_address : address_lazy; + mda_shape: Shape.t; } + +and module_entry = + | Mod_local of module_data + | Mod_persistent + | Mod_unbound of module_unbound_reason + +and modtype_data = + { mtda_declaration : Subst.Lazy.modtype_declaration; + mtda_shape : Shape.t; } + +and class_data = + { clda_declaration : class_declaration; + clda_address : address_lazy; + clda_shape : Shape.t } + +and cltype_data = + { cltda_declaration : class_type_declaration; + cltda_shape : Shape.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 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 -> Subst.Lazy.modtype -> + Path.t -> Subst.Lazy.modtype) + +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 ps path addr mty shape = + { + alerts; + uid; + comps = Lazy_backtrack.create { + cm_env = env; + cm_prefixing_subst = ps; + cm_path = path; + cm_addr = addr; + cm_mty = mty; + cm_shape = shape; + } + } + +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 = + Subst.(Lazy.module_decl Make_local identity (Lazy.of_module_decl md)) + in + let mda_shape = Shape.for_persistent_unit name in + let mda_components = + let mty = Subst.Lazy.of_modtype (Mty_signature sign) in + let mty = + if freshen then + Subst.Lazy.modtype (Subst.Rescope (Path.scope path)) + Subst.identity mty + else mty + in + components_of_module ~alerts ~uid:md.md_uid + empty Subst.identity + path mda_address mty mda_shape + in + { + mda_declaration; + mda_components; + mda_address; + mda_shape; + } + +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; + Types.Uid.Tbl.clear !uid_to_loc; + () + +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 + Subst.Lazy.force_module_decl data.mda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + Subst.Lazy.force_module_decl 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_module_lazy ~alias path env = + match path with + | Pident id -> + let data = find_ident_module id env in + data.mda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + data.mda_declaration + | Papply(p1, p2) -> + let fc = find_functor_components p1 env in + let md = + if alias then md (fc.fcomp_res) + else md (modtype_of_functor_appl fc p1 p2) + in + Subst.Lazy.of_module_decl md + +let find_strengthened_module ~aliasable path env = + let md = find_module_lazy ~alias:true path env in + let mty = !strengthen ~aliasable env md.mdl_type path in + Subst.Lazy.force_modtype mty + +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_lazy path env = + match path with + | Pident id -> (IdTbl.find_same id env.modtypes).mtda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_modtypes).mtda_declaration + | Papply _ -> raise Not_found + +let find_modtype path env = + Subst.Lazy.force_modtype_decl (find_modtype_lazy path env) + +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).cltda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_cltypes).cltda_declaration + | 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); + tda_shape = Shape.leaf decl.type_uid; + } + | _ -> 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; + tda_shape = Shape.leaf decl.type_uid; + } + | 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 find_shape env (ns : Shape.Sig_component_kind.t) id = + match ns with + | Type -> + (IdTbl.find_same id env.types).tda_shape + | Extension_constructor -> + (TycompTbl.find_same id env.constrs).cda_shape + | Value -> + begin match IdTbl.find_same id env.values with + | Val_bound x -> x.vda_shape + | Val_unbound _ -> raise Not_found + end + | Module -> + begin match IdTbl.find_same id env.modules with + | Mod_local { mda_shape; _ } -> mda_shape + | Mod_persistent -> Shape.for_persistent_unit (Ident.name id) + | Mod_unbound _ -> + (* Only present temporarily while approximating the environment for + recursive modules. + [find_shape] is only ever called after the environment gets + properly populated. *) + assert false + | exception Not_found + when Ident.persistent id && not (Current_unit_name.is_ident id) -> + Shape.for_persistent_unit (Ident.name id) + end + | Module_type -> + (IdTbl.find_same id env.modtypes).mtda_shape + | Class -> + (IdTbl.find_same id env.classes).clda_shape + | Class_type -> + (IdTbl.find_same id env.cltypes).cltda_shape + +let shape_of_path ~namespace env = + Shape.of_path ~namespace ~find_shape:(find_shape env) + +let shape_or_leaf uid = function + | None -> Shape.leaf uid + | Some shape -> shape + +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_lazy ~alias:true path env with + {mdl_type=MtyL_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_lazy path env).mtdl_type with + | Some (MtyL_ident path) -> normalize_modtype_path env path + | _ | exception Not_found -> path + +let find_module path env = + find_module ~alias:false path env + +let find_module_lazy path env = + find_module_lazy ~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_lazy path env = + match (find_modtype_lazy path env).mtdl_type with + | None -> raise Not_found + | Some mty -> mty + +let find_modtype_expansion path env = + Subst.Lazy.force_modtype (find_modtype_expansion_lazy path env) + +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 (get_id t) + with Not_found -> + let t2 = Subst.type_expr Subst.identity t in + Hashtbl.add memo (get_id t) 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} + ) + +(* 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 mty = + let open Subst.Lazy in + match mty with + | MtyL_alias path -> begin + match 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 (find_module_lazy path env).mdl_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; _ } -> + scrape_alias_for_visit env 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 -> String.Set.add s r) + String.Set.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 ?path mty = + let open Subst.Lazy in + match mty, path with + MtyL_ident p, _ -> + begin try + scrape_alias env (find_modtype_expansion_lazy p env) ?path + with Not_found -> + mty + end + | MtyL_alias path, _ -> + begin try + scrape_alias env ((find_module_lazy path env).mdl_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 prefixing_sub sg = + let open Subst.Lazy in + let rec prefix_idents root items_and_paths prefixing_sub = + function + | [] -> (List.rev items_and_paths, prefixing_sub) + | SigL_value(id, _, _) as item :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((item, p) :: items_and_paths) prefixing_sub rem + | SigL_type(id, td, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_type(id, td, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_typext(id, ec, es, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + (* we extend the substitution in case of an inlined record *) + prefix_idents root + ((SigL_typext(id, ec, es, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_module(id, pres, md, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_module(id, pres, md, rs, vis), p) :: items_and_paths) + (Subst.add_module id p prefixing_sub) + rem + | SigL_modtype(id, mtd, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_modtype(id, mtd, vis), p) :: items_and_paths) + (Subst.add_modtype id (Mty_ident p) prefixing_sub) + rem + | SigL_class(id, cd, rs, vis) :: rem -> + (* pretend this is a type, cf. PR#6650 *) + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_class(id, cd, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_class_type(id, ctd, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_class_type(id, ctd, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + in + let sg = Subst.Lazy.force_signature_once sg in + prefix_idents root [] 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 + let open Subst.Lazy in + match md.mdl_type with + | MtyL_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_prefixing_subst; + cm_path; cm_addr; cm_mty; cm_shape} : _ result = + match scrape_alias cm_env cm_mty with + MtyL_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, sub = + prefix_idents cm_path 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 + List.iter (fun ((item : Subst.Lazy.signature_item), path) -> + match item with + SigL_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_shape = Shape.proj cm_shape (Shape.Item.value id) in + let vda = + { vda_description = decl'; vda_address = addr; vda_shape } + in + c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values; + | SigL_type(id, decl, _, _) -> + let final_decl = Subst.type_declaration sub decl in + Btype.set_static_row_name final_decl + (Subst.type_path 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_shape = Shape.leaf descr.cstr_uid in + let cda = { + cda_description = descr; + cda_address = None; + cda_shape } + 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 shape = Shape.proj cm_shape (Shape.Item.type_ id) in + let tda = + { tda_declaration = final_decl; + tda_descriptions = descrs; + tda_shape = shape; } + in + c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types; + env := store_type_infos ~tda_shape:shape id decl !env + | SigL_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_shape = + Shape.proj cm_shape (Shape.Item.extension_constructor id) + in + let cda = + { cda_description = descr; cda_address = Some addr; cda_shape } + in + c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs + | SigL_module(id, pres, md, _, _) -> + let md' = + (* The prefixed items get the same scope as [cm_path], which is + the prefix. *) + Subst.Lazy.module_decl + (Subst.Rescope (Path.scope cm_path)) sub md + in + let addr = + match pres with + | Mp_absent -> begin + match md.mdl_type with + | MtyL_alias path -> + Lazy_backtrack.create (ModAlias {env = !env; path}) + | _ -> assert false + end + | Mp_present -> next_address () + in + let alerts = + Builtin_attributes.alerts_of_attrs md.mdl_attributes + in + let shape = Shape.proj cm_shape (Shape.Item.module_ id) in + let comps = + components_of_module ~alerts ~uid:md.mdl_uid !env + sub path addr md.mdl_type shape + in + let mda = + { mda_declaration = md'; + mda_components = comps; + mda_address = addr; + mda_shape = shape; } + in + c.comp_modules <- + NameMap.add (Ident.name id) mda c.comp_modules; + env := + store_module ~update_summary:false ~check:None + id addr pres md shape !env + | SigL_modtype(id, decl, _) -> + let final_decl = + (* The prefixed items get the same scope as [cm_path], which is + the prefix. *) + Subst.Lazy.modtype_decl (Rescope (Path.scope cm_path)) + sub decl + in + let shape = Shape.proj cm_shape (Shape.Item.module_type id) in + let mtda = + { mtda_declaration = final_decl; + mtda_shape = shape; } + in + c.comp_modtypes <- + NameMap.add (Ident.name id) mtda c.comp_modtypes; + env := store_modtype ~update_summary:false id decl shape !env + | SigL_class(id, decl, _, _) -> + let decl' = Subst.class_declaration sub decl in + let addr = next_address () in + let shape = Shape.proj cm_shape (Shape.Item.class_ id) in + let clda = + { clda_declaration = decl'; + clda_address = addr; + clda_shape = shape; } + in + c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes + | SigL_class_type(id, decl, _, _) -> + let decl' = Subst.cltype_declaration sub decl in + let shape = Shape.proj cm_shape (Shape.Item.class_type id) in + let cltda = { cltda_declaration = decl'; cltda_shape = shape } in + c.comp_cltypes <- + NameMap.add (Ident.name id) cltda c.comp_cltypes) + items_and_paths; + Ok (Structure_comps c) + | MtyL_functor(arg, ty_res) -> + let sub = cm_prefixing_subst in + let scoping = Subst.Rescope (Path.scope cm_path) in + let open Subst.Lazy 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, force_modtype (modtype scoping sub ty_arg))); + fcomp_res = force_modtype (modtype scoping sub ty_res); + fcomp_shape = cm_shape; + fcomp_cache = Hashtbl.create 17; + fcomp_subst_cache = Hashtbl.create 17 }) + | MtyL_ident _ -> Error No_components_abstract + | MtyL_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 shape 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; + vda_shape = shape } + 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; + let cda_shape = Shape.leaf cstr.cstr_uid in + { env with + constrs = + TycompTbl.add cstr_id + { cda_description = cstr; cda_address = None; cda_shape } 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 shape 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; + tda_shape = shape } + in + { env with + types = IdTbl.add id tda env.types; + summary = Env_type(env.summary, id, info) } + +and store_type_infos ~tda_shape 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; + tda_shape + } + 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 shape 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; + cda_shape = shape } + 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 ?(update_summary=true) ~check + id addr presence md shape env = + let open Subst.Lazy in + let loc = md.mdl_loc in + Option.iter + (fun f -> check_usage loc id md.mdl_uid f !module_declarations) check; + let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in + let comps = + components_of_module ~alerts ~uid:md.mdl_uid + env Subst.identity (Pident id) addr md.mdl_type shape + in + let mda = + { mda_declaration = md; + mda_components = comps; + mda_address = addr; + mda_shape = shape } + in + let summary = + if not update_summary then env.summary + else Env_module (env.summary, id, presence, force_module_decl md) in + { env with + modules = IdTbl.add id (Mod_local mda) env.modules; + summary } + +and store_modtype ?(update_summary=true) id info shape env = + let mtda = { mtda_declaration = info; mtda_shape = shape } in + let summary = + if not update_summary then env.summary + else Env_modtype (env.summary, id, Subst.Lazy.force_modtype_decl info) in + { env with + modtypes = IdTbl.add id mtda env.modtypes; + summary } + +and store_class id addr desc shape env = + let clda = + { clda_declaration = desc; + clda_address = addr; + clda_shape = shape; } + in + { env with + classes = IdTbl.add id clda env.classes; + summary = Env_class(env.summary, id, desc) } + +and store_cltype id desc shape env = + let cltda = { cltda_declaration = desc; cltda_shape = shape } in + { env with + cltypes = IdTbl.add id cltda env.cltypes; + summary = Env_cltype(env.summary, id, desc) } + +let scrape_alias env mty = scrape_alias env 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 shape_arg = + shape_of_path ~namespace:Shape.Sig_component_kind.Module env arg + in + let shape = Shape.app f_comp.fcomp_shape ~arg:shape_arg in + let comps = + components_of_module ~alerts:Misc.Stdlib.String.Map.empty + ~uid:Uid.internal_not_actually_unique + (*???*) + env Subst.identity p addr (Subst.Lazy.of_modtype mty) shape + 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 ?shape id desc env = + let addr = value_declaration_address env id desc in + let shape = shape_or_leaf desc.val_uid shape in + store_value ?check id addr desc shape env + +let add_type ~check ?shape id info env = + let shape = shape_or_leaf info.type_uid shape in + store_type ~check id info shape env + +and add_extension ~check ?shape ~rebind id ext env = + let addr = extension_declaration_address env id ext in + let shape = shape_or_leaf ext.ext_uid shape in + store_extension ~check ~rebind id addr ext shape env + +and add_module_declaration ?(arg=false) ?shape ~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 md = Subst.Lazy.of_module_decl md in + let addr = module_declaration_address env id presence md in + let shape = shape_or_leaf md.mdl_uid shape in + let env = store_module ~check id addr presence md shape env in + if arg then add_functor_arg id env else env + +and add_module_declaration_lazy ~update_summary id presence md env = + let addr = module_declaration_address env id presence md in + let shape = Shape.leaf md.Subst.Lazy.mdl_uid in + let env = + store_module ~update_summary ~check:None id addr presence md shape env + in + env + +and add_modtype ?shape id info env = + let shape = shape_or_leaf info.mtd_uid shape in + store_modtype id (Subst.Lazy.of_modtype_decl info) shape env + +and add_modtype_lazy ~update_summary id info env = + let shape = Shape.leaf info.Subst.Lazy.mtdl_uid in + store_modtype ~update_summary id info shape env + +and add_class ?shape id ty env = + let addr = class_declaration_address env id ty in + let shape = shape_or_leaf ty.cty_uid shape in + store_class id addr ty shape env + +and add_cltype ?shape id ty env = + let shape = shape_or_leaf ty.clty_uid shape in + store_cltype id ty shape env + +let add_module ?arg ?shape id presence mty env = + add_module_declaration ~check:false ?arg ?shape id presence (md mty) env + +let add_local_type path info env = + { env with + local_constraints = Path.Map.add path info env.local_constraints } + +(* Non-lazy version of scrape_alias *) +let scrape_alias t mty = + mty |> Subst.Lazy.of_modtype |> scrape_alias t |> Subst.Lazy.force_modtype + +(* 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 (Shape.leaf desc.val_uid) 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 (Shape.leaf info.type_uid) 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 shape = Shape.leaf ext.ext_uid in + let env = store_extension ~check:true ~rebind id addr ext shape env in + (id, env) + +let enter_module_declaration ~scope ?arg ?shape s presence md env = + let id = Ident.create_scoped ~scope s in + (id, add_module_declaration ?arg ?shape ~check:true id presence md env) + +let enter_modtype ~scope name mtd env = + let id = Ident.create_scoped ~scope name in + let shape = Shape.leaf mtd.mtd_uid in + let env = store_modtype id (Subst.Lazy.of_modtype_decl mtd) shape 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 (Shape.leaf desc.cty_uid) 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 (Shape.leaf desc.clty_uid) 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 (map, mod_shape) comp env = + let proj_shape item = + match mod_shape with + | None -> map, None + | Some mod_shape -> + let shape = Shape.proj mod_shape item in + Shape.Map.add map item shape, Some shape + in + match comp with + | Sig_value(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.value id) in + map, add_value ?shape id decl env + | Sig_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.type_ id) in + map, add_type ~check:false ?shape id decl env + | Sig_typext(id, ext, _, _) -> + let map, shape = proj_shape (Shape.Item.extension_constructor id) in + map, add_extension ~check:false ?shape ~rebind:false id ext env + | Sig_module(id, presence, md, _, _) -> + let map, shape = proj_shape (Shape.Item.module_ id) in + map, add_module_declaration ~check:false ?shape id presence md env + | Sig_modtype(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.module_type id) in + map, add_modtype ?shape id decl env + | Sig_class(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_ id) in + map, add_class ?shape id decl env + | Sig_class_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_type id) in + map, add_cltype ?shape id decl env + +let rec add_signature (map, mod_shape) sg env = + match sg with + [] -> map, env + | comp :: rem -> + let map, env = add_item (map, mod_shape) comp env in + add_signature (map, mod_shape) rem env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + let sg = Subst.signature (Rescope scope) Subst.identity sg in + let shape, env = add_signature (parent_shape, mod_shape) sg env in + sg, shape, env + +let enter_signature ?mod_shape ~scope sg env = + let sg, _, env = + enter_signature_and_shape ~scope ~parent_shape:Shape.Map.empty + mod_shape sg env + in + sg, env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env + +let add_value = add_value ?shape:None +let add_type = add_type ?shape:None +let add_extension = add_extension ?shape:None +let add_class = add_class ?shape:None +let add_cltype = add_cltype ?shape:None +let add_modtype = add_modtype ?shape:None +let add_signature sg env = + let _, env = add_signature (Shape.Map.empty, None) sg env in + 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 = Subst.Lazy.force_module_decl 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 = + 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 = Btype.cstr_type_path cstr 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 get_desc lbl.lbl_res with + | 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 = + let open Subst.Lazy in + if use then begin + mark_modtype_used desc.mtdl_uid; + Builtin_attributes.check_alerts loc desc.mtdl_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) -> + use_modtype ~use ~loc path data.mtda_declaration; + (path, data.mtda_declaration) + | 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, cltda -> + use_cltype ~use ~loc path cltda.cltda_declaration; + path, cltda.cltda_declaration + | 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 = Subst.Lazy.force_module_decl data.mda_declaration in + path, md + | Ldot(l, s) -> + let path, data = lookup_dot_module ~errors ~use ~loc l s env in + let md = Subst.Lazy.force_module_decl 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 + | mta -> + let path = Pdot(p, s) in + use_modtype ~use ~loc path mta.mtda_declaration; + (path, mta.mtda_declaration) + | 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 + | cltda -> + let path = Pdot(p, s) in + use_cltype ~use ~loc path cltda.cltda_declaration; + (path, cltda.cltda_declaration) + | 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 + | _ -> + 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_lazy ~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_modtype ~errors ~use ~loc lid env = + let (path, mt) = lookup_modtype_lazy ~errors ~use ~loc lid env in + path, Subst.Lazy.force_modtype_decl mt + +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_modtype_path ?(use=true) ~loc lid env = + fst (lookup_modtype_lazy ~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 = + Subst.Lazy.force_module_decl 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 = + Subst.Lazy.force_module_decl 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 = + Subst.Lazy.force_module_decl 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 = + let f l path data acc = f l path (Subst.Lazy.force_modtype_decl data) acc in + find_all wrap_identity + (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + (fun k p mta acc -> f k p mta.mtda_declaration acc) +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) + (fun k p cltda acc -> f k p cltda.cltda_declaration acc) + +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 "@[@["; + 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_500/typing/env.mli b/upstream/ocaml_500/typing/env.mli new file mode 100644 index 0000000000..ae8e2cf8dc --- /dev/null +++ b/upstream/ocaml_500/typing/env.mli @@ -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. *) +(* *) +(**************************************************************************) + +(* Environment handling *) + +open Types +open Misc + +val register_uid : Uid.t -> Location.t -> unit + +val get_uid_to_loc_tbl : unit -> Location.t Types.Uid.Tbl.t + +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: 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 -> Stdlib.String.Set.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_strengthened_module: + aliasable:bool -> Path.t -> t -> module_type + +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_modtype_expansion_lazy: Path.t -> t -> Subst.Lazy.modtype + +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 shape_of_path: + namespace:Shape.Sig_component_kind.t -> t -> Path.t -> Shape.t + +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_modtype_path: + ?use:bool -> loc:Location.t -> 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 -> ?shape:Shape.t -> + Ident.t -> module_presence -> module_type -> t -> t +val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> + Ident.t -> module_presence -> module_declaration -> t -> t +val add_module_declaration_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.module_decl -> t -> t +val add_modtype: Ident.t -> modtype_declaration -> t -> t +val add_modtype_lazy: update_summary:bool -> + Ident.t -> Subst.Lazy.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_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 -> ?shape:Shape.t -> 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: ?mod_shape:Shape.t -> scope:int -> signature -> t -> + signature * t + +(* Same as [enter_signature] but also extends the shape map ([parent_shape]) + with all the the items from the signature, their shape being a projection + from the given shape. *) +val enter_signature_and_shape: scope:int -> parent_shape:Shape.Map.t -> + Shape.t -> signature -> t -> signature * Shape.Map.t * 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 -> Subst.Lazy.modtype -> + Path.t -> Subst.Lazy.modtype) 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_500/typing/envaux.ml b/upstream/ocaml_500/typing/envaux.ml new file mode 100644 index 0000000000..a0bbbc2684 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/envaux.mli b/upstream/ocaml_500/typing/envaux.mli new file mode 100644 index 0000000000..2869890a14 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/errortrace.ml b/upstream/ocaml_500/typing/errortrace.ml new file mode 100644 index 0000000000..ec380329be --- /dev/null +++ b/upstream/ocaml_500/typing/errortrace.ml @@ -0,0 +1,194 @@ +(**************************************************************************) +(* *) +(* 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 expanded_type = { ty: type_expr; expanded: type_expr } + +let trivial_expansion ty = { ty; expanded = ty } + +type 'a diff = { got: 'a; expected: 'a } + +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 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 map_escape f esc = + {esc with kind = match esc.kind with + | Equation eq -> Equation (f eq) + | (Constructor _ | Univ _ | Self | Module_type _ | Constraint) as c -> c} + +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 *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | 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 ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +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 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 + +type unification_error = { trace : unification error } [@@unboxed] + +type equality_error = + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = { trace : comparison error } [@@unboxed] + +let unification_error ~trace : unification_error = + assert (trace <> []); + { trace } + +let equality_error ~trace ~subst : equality_error = + assert (trace <> []); + { trace; subst } + +let moregen_error ~trace : moregen_error = + assert (trace <> []); + { trace } + +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +let swap_unification_error ({trace} : unification_error) = + ({trace = swap_trace trace} : unification_error) + +module Subtype = struct + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = + { trace : error_trace + ; unification_trace : unification error } + + let error ~trace ~unification_trace = + assert (trace <> []); + { trace; unification_trace } + + let map_elt f = function + | Diff x -> Diff (map_diff f x) + + let map f t = List.map (map_elt f) t +end diff --git a/upstream/ocaml_500/typing/errortrace.mli b/upstream/ocaml_500/typing/errortrace.mli new file mode 100644 index 0000000000..90148893fe --- /dev/null +++ b/upstream/ocaml_500/typing/errortrace.mli @@ -0,0 +1,168 @@ +(**************************************************************************) +(* *) +(* 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 expanded_type = { ty: type_expr; expanded: type_expr } + +(** [trivial_expansion ty] creates an [expanded_type] whose expansion is also + [ty]. Usually, you want [Ctype.expand_type] instead, since the expansion + carries useful information; however, in certain circumstances, the error is + about the expansion of the type, meaning that actually performing the + expansion produces more confusing or inaccurate output. *) +val trivial_expansion : type_expr -> expanded_type + +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 map_escape : ('a -> 'b) -> 'a escape -> 'b escape + +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 *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | 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 ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +val map : ('a -> 'b) -> ('a, 'variety) t -> ('b, 'variety) t + +val incompatible_fields : + name:string -> got:type_expr -> expected:type_expr -> (type_expr, _) elt + +val swap_trace : ('a, 'variety) t -> ('a, 'variety) t + +(** The traces (['variety t]) are the core error types. However, we bundle them + up into three "top-level" error types, which are used elsewhere: + [unification_error], [equality_error], and [moregen_error]. In the case of + [equality_error], this has to bundle in extra information; in general, it + distinguishes the three types of errors and allows us to distinguish traces + that are being built (or processed) from those that are complete and have + become the final error. These error types have the invariants that their + traces are nonempty; we ensure that through three smart constructors with + matching names. *) + +type unification_error = private { trace : unification error } [@@unboxed] + +type equality_error = private + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = private { trace : comparison error } [@@unboxed] + +val unification_error : trace:unification error -> unification_error + +val equality_error : + trace:comparison error -> subst:(type_expr * type_expr) list -> equality_error + +val moregen_error : trace:comparison error -> moregen_error + +(** Wraps up the two different kinds of [comparison] errors in one type *) +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +(** Lift [swap_trace] to [unification_error] *) +val swap_unification_error : unification_error -> unification_error + +module Subtype : sig + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + (** Just as outside [Subtype], we split traces, completed traces, and complete + errors. However, in a minor asymmetry, the name [Subtype.error_trace] + corresponds to the outside [error] type, and [Subtype.error] corresponds + to the outside [*_error] types (e.g., [unification_error]). This [error] + type has the invariant that the subtype trace is nonempty; note that no + such invariant is imposed on the unification trace. *) + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = private + { trace : error_trace + ; unification_trace : unification error } + + val error : + trace:error_trace -> unification_trace:unification_error_trace -> error + + val map : ('a -> 'b) -> 'a t -> 'b t +end diff --git a/upstream/ocaml_500/typing/ident.ml b/upstream/ocaml_500/typing/ident.ml new file mode 100644 index 0000000000..feb590d024 --- /dev/null +++ b/upstream/ocaml_500/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 + "_", 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_500/typing/ident.mli b/upstream/ocaml_500/typing/ident.mli new file mode 100644 index 0000000000..ff48efb3ad --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/includeclass.ml b/upstream/ocaml_500/typing/includeclass.ml new file mode 100644 index 0000000000..3a2cd57694 --- /dev/null +++ b/upstream/ocaml_500/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 mode 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, err) -> + Printtyp.report_equality_error ppf mode env err + (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, err) -> + Printtyp.report_moregen_error ppf mode env err + (function ppf -> + fprintf ppf "A parameter has type") + (function ppf -> + fprintf ppf "but is expected to have type") + | CM_Val_type_mismatch (lab, env, err) -> + Printtyp.report_comparison_error ppf mode env err + (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, err) -> + Printtyp.report_comparison_error ppf mode env err + (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 mode ppf = function + | [] -> () + | err :: errs -> + let print_errs ppf errs = + List.iter (fun err -> fprintf ppf "@ %a" (include_err mode) err) errs in + fprintf ppf "@[%a%a@]" (include_err mode) err print_errs errs diff --git a/upstream/ocaml_500/typing/includeclass.mli b/upstream/ocaml_500/typing/includeclass.mli new file mode 100644 index 0000000000..84de6212c4 --- /dev/null +++ b/upstream/ocaml_500/typing/includeclass.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* 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 : + Printtyp.type_or_scheme -> formatter -> class_match_failure list -> unit diff --git a/upstream/ocaml_500/typing/includecore.ml b/upstream/ocaml_500/typing/includecore.ml new file mode 100644 index 0000000000..1cfc973134 --- /dev/null +++ b/upstream/ocaml_500/typing/includecore.ml @@ -0,0 +1,993 @@ +(**************************************************************************) +(* *) +(* 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 Errortrace.moregen_error + +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 err -> raise (Dont_match (Type err)) + | () -> 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 manifest types (particularly for private row types) *) + +let is_absrow env ty = + match get_desc ty with + | Tconstr(Pident _, _, _) -> + (* This function is checking for an abstract row on the side that is being + included into (usually numbered with "2" in this file). In this case, + the abstract row variable has been substituted for an object or variant + type. *) + begin match get_desc (Ctype.expand_head env ty) with + | 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 + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type label_mismatch = + | Type of Errortrace.equality_error + | Mutability of position + +type record_change = + (Types.label_declaration, Types.label_declaration, label_mismatch) + Diffing_with_keys.change + +type record_mismatch = + | Label_mismatch of record_change list + | Unboxed_float_representation of position + +type constructor_mismatch = + | Type of Errortrace.equality_error + | Arity + | Inline_record of record_change list + | Kind of position + | Explicit_return_type of position + +type extension_constructor_mismatch = + | Constructor_privacy + | Constructor_mismatch of Ident.t + * Types.extension_constructor + * Types.extension_constructor + * constructor_mismatch + +type private_variant_mismatch = + | Only_outer_closed (* It's only dangerous in one direction *) + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type variant_change = + (Types.constructor_declaration as 'l, 'l, constructor_mismatch) + Diffing_with_keys.change + +type type_mismatch = + | Arity + | Privacy of privacy_mismatch + | Kind + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | 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_change list + | Unboxed_representation of position + | Immediate of Type_immediacy.Violation.t + +let report_primitive_mismatch first second ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : primitive_mismatch) with + | Name -> + pr "The names of the primitives are not the same" + | Arity -> + pr "The syntactic arities of these primitives were not the same.@ \ + (They must have the same number of arrows present in the source.)" + | No_alloc ord -> + pr "%s primitive is [@@@@noalloc] but %s is not" + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + | Native_name -> + pr "The native names of the primitives are not the same" + | Result_repr -> + pr "The two primitives' results have different representations" + | Argument_repr n -> + pr "The two primitives' %d%s arguments have different representations" + n (Misc.ordinal_suffix n) + +let report_value_mismatch first second env ppf err = + let pr fmt = Format.fprintf ppf fmt in + pr "@ "; + match (err : value_mismatch) with + | Primitive_mismatch pm -> + report_primitive_mismatch first second ppf pm + | Not_a_primitive -> + pr "The implementation is not a primitive." + | Type trace -> + Printtyp.report_moregen_error ppf Type_scheme env trace + (fun ppf -> Format.fprintf ppf "The type") + (fun ppf -> Format.fprintf ppf "is not compatible with the type") + +let report_type_inequality env ppf err = + Printtyp.report_equality_error ppf Type_scheme env err + (fun ppf -> Format.fprintf ppf "The type") + (fun ppf -> Format.fprintf ppf "is not equal to the type") + +let report_privacy_mismatch ppf err = + let singular, item = + match err with + | Private_type_abbreviation -> true, "type abbreviation" + | Private_variant_type -> false, "variant constructor(s)" + | Private_record_type -> true, "record constructor" + | Private_extensible_variant -> true, "extensible variant" + | Private_row_type -> true, "row type" + in Format.fprintf ppf "%s %s would be revealed." + (if singular then "A private" else "Private") + item + +let report_label_mismatch first second env ppf err = + match (err : label_mismatch) with + | Type err -> + report_type_inequality env ppf err + | Mutability ord -> + Format.fprintf ppf "%s is mutable and %s is not." + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + +let pp_record_diff first second prefix decl env ppf (x : record_change) = + match x with + | Delete cd -> + Format.fprintf ppf "%aAn extra field, %s, is provided in %s %s." + prefix x (Ident.name cd.delete.ld_id) first decl + | Insert cd -> + Format.fprintf ppf "%aA field, %s, is missing in %s %s." + prefix x (Ident.name cd.insert.ld_id) first decl + | Change Type {got=lbl1; expected=lbl2; reason} -> + Format.fprintf ppf + "@[%aFields do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + Printtyp.label lbl1 + Printtyp.label lbl2 + (report_label_mismatch first second env) reason + | Change Name n -> + Format.fprintf ppf "%aFields have different names, %s and %s." + prefix x n.got n.expected + | Swap sw -> + Format.fprintf ppf "%aFields %s and %s have been swapped." + prefix x sw.first sw.last + | Move {name; got; expected } -> + Format.fprintf ppf + "@[<2>%aField %s has been moved@ from@ position %d@ to %d.@]" + prefix x name expected got + +let report_patch pr_diff first second decl env ppf patch = + let nl ppf () = Format.fprintf ppf "@," in + let no_prefix _ppf _ = () in + match patch with + | [ elt ] -> + Format.fprintf ppf "@[%a@]" + (pr_diff first second no_prefix decl env) elt + | _ -> + let pp_diff = pr_diff first second Diffing_with_keys.prefix decl env in + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list ~pp_sep:nl pp_diff) patch + +let report_record_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match err with + | Label_mismatch patch -> + report_patch pp_record_diff first second decl env ppf patch + | Unboxed_float_representation ord -> + pr "@[Their internal representations differ:@ %s %s %s.@]" + (choose ord first second) decl + "uses unboxed float representation" + +let report_constructor_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : constructor_mismatch) with + | Type err -> report_type_inequality env ppf err + | Arity -> pr "They have different arities." + | Inline_record err -> + report_patch pp_record_diff first second decl env 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 pp_variant_diff first second prefix decl env ppf (x : variant_change) = + match x with + | Delete cd -> + Format.fprintf ppf "%aAn extra constructor, %s, is provided in %s %s." + prefix x (Ident.name cd.delete.cd_id) first decl + | Insert cd -> + Format.fprintf ppf "%aA constructor, %s, is missing in %s %s." + prefix x (Ident.name cd.insert.cd_id) first decl + | Change Type {got; expected; reason} -> + Format.fprintf ppf + "@[%aConstructors do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + Printtyp.constructor got + Printtyp.constructor expected + (report_constructor_mismatch first second decl env) reason + | Change Name n -> + Format.fprintf ppf + "%aConstructors have different names, %s and %s." + prefix x n.got n.expected + | Swap sw -> + Format.fprintf ppf + "%aConstructors %s and %s have been swapped." + prefix x sw.first sw.last + | Move {name; got; expected} -> + Format.fprintf ppf + "@[<2>%aConstructor %s has been moved@ from@ position %d@ to %d.@]" + prefix x name expected got + +let report_extension_constructor_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : extension_constructor_mismatch) with + | Constructor_privacy -> + pr "Private extension constructor(s) would be revealed." + | Constructor_mismatch (id, ext1, ext2, err) -> + pr "@[Constructors do not match:@;<1 2>%a@ is not the same as:\ + @;<1 2>%a@ %a@]" + (Printtyp.extension_only_constructor id) ext1 + (Printtyp.extension_only_constructor id) ext2 + (report_constructor_mismatch first second decl env) err + +let report_private_variant_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : private_variant_mismatch) with + | Only_outer_closed -> + (* It's only dangerous in one direction, so we don't have a position *) + pr "%s is private and closed, but %s is not closed" + (String.capitalize_ascii second) first + | Missing (ord, name) -> + pr "The constructor %s is only present in %s %s." + name (choose ord first second) decl + | Presence s -> + pr "The tag `%s is present in the %s %s,@ but might not be in the %s" + s second decl first + | Incompatible_types_for s -> pr "Types for tag `%s are incompatible" s + | Types err -> + report_type_inequality env ppf err + +let report_private_object_mismatch env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : private_object_mismatch) with + | Missing s -> pr "The implementation is missing the method %s" s + | Types err -> report_type_inequality env ppf err + +let report_type_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + pr "@ "; + match err with + | Arity -> + pr "They have different arities." + | Privacy err -> + report_privacy_mismatch ppf err + | Kind -> + pr "Their kinds differ." + | Constraint err -> + (* This error can come from implicit parameter disagreement or from + explicit `constraint`s. Both affect the parameters, hence this choice + of explanatory text *) + pr "Their parameters differ@,"; + report_type_inequality env ppf err + | Manifest err -> + report_type_inequality env ppf err + | Private_variant (_ty1, _ty2, mismatch) -> + report_private_variant_mismatch first second decl env ppf mismatch + | Private_object (_ty1, _ty2, mismatch) -> + report_private_object_mismatch env ppf mismatch + | Variance -> + pr "Their variances do not agree." + | Record_mismatch err -> + report_record_mismatch first second decl env ppf err + | Variant_mismatch err -> + report_patch pp_variant_diff first second decl env 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 + +module Record_diffing = struct + + let 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 + 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 err -> + Some (Type err : label_mismatch) + | () -> None + + let rec equal ~loc env params1 params2 + (labels1 : Types.label_declaration list) + (labels2 : Types.label_declaration list) = + match labels1, labels2 with + | [], [] -> true + | _ :: _ , [] | [], _ :: _ -> false + | ld1 :: rem1, ld2 :: rem2 -> + if Ident.name ld1.ld_id <> Ident.name ld2.ld_id + then false + 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 _ -> false + (* add arguments to the parameters, cf. PR#7378 *) + | None -> + equal ~loc env + (ld1.ld_type::params1) (ld2.ld_type::params2) + rem1 rem2 + end + + module Defs = struct + type left = Types.label_declaration + type right = left + type diff = label_mismatch + type state = type_expr list * type_expr list + end + module Diff = Diffing_with_keys.Define(Defs) + + let update (d:Diff.change) (params1,params2 as st) = + match d with + | Insert _ | Change _ | Delete _ -> st + | Keep (x,y,_) -> + (* We need to add equality between existential type parameters + (in inline records) *) + x.data.ld_type::params1, y.data.ld_type::params2 + + let test _loc env (params1,params2) + ({pos; data=lbl1}: Diff.left) + ({data=lbl2; _ }: Diff.right) + = + let name1, name2 = Ident.name lbl1.ld_id, Ident.name lbl2.ld_id in + if name1 <> name2 then + let types_match = + match compare_labels env params1 params2 lbl1 lbl2 with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_labels env params1 params2 lbl1 lbl2 with + | Some reason -> + Error ( + Diffing_with_keys.Type {pos; got=lbl1; expected=lbl2; reason} + ) + | None -> Ok () + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name t ) -> + if t.types_match then 10 else 15 + | Change _ -> 10 + + + + let key (x: Defs.left) = Ident.name x.ld_id + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let module Compute = Diff.Simple(struct + let key_left = key + let key_right = key + let update = update + let test = test loc env + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + + let compare_with_representation ~loc env params1 params2 l r rep1 rep2 = + if not (equal ~loc env params1 params2 l r) then + let patch = diffing loc env params1 params2 l r in + Some (Record_mismatch (Label_mismatch patch)) + else + 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 + +end + + +module Variant_diffing = struct + + let 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 err -> Some (Type err) + | () -> None + end + | Types.Cstr_record l1, Types.Cstr_record l2 -> + Option.map + (fun rec_err -> Inline_record rec_err) + (Record_diffing.compare env ~loc params1 params2 l1 l2) + | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch) + | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch) + + let 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 err -> Some (Type err) + | () -> 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 + + let equal ~loc env params1 params2 + (cstrs1 : Types.constructor_declaration list) + (cstrs2 : Types.constructor_declaration list) = + List.length cstrs1 = List.length cstrs2 && + List.for_all2 (fun (cd1:Types.constructor_declaration) + (cd2:Types.constructor_declaration) -> + Ident.name cd1.cd_id = Ident.name cd2.cd_id + && + 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 _ -> false + | None -> true + end) cstrs1 cstrs2 + + module Defs = struct + type left = Types.constructor_declaration + type right = left + type diff = constructor_mismatch + type state = type_expr list * type_expr list + end + module D = Diffing_with_keys.Define(Defs) + + let update _ st = st + + let weight: D.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name t) -> + if t.types_match then 10 else 15 + | Change _ -> 10 + + + let test loc env (params1,params2) + ({pos; data=cd1}: D.left) + ({data=cd2; _}: D.right) = + let name1, name2 = Ident.name cd1.cd_id, Ident.name cd2.cd_id in + if name1 <> name2 then + let types_match = + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some reason -> + Error (Diffing_with_keys.Type {pos; got=cd1; expected=cd2; reason}) + | None -> Ok () + + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let key (x:Defs.left) = Ident.name x.cd_id in + let module Compute = D.Simple(struct + let key_left = key + let key_right = key + let test = test loc env + let update = update + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + let compare_with_representation ~loc env params1 params2 + cstrs1 cstrs2 rep1 rep2 + = + let err = compare ~loc env params1 params2 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) +end + +(* Inclusion between "private" annotations *) +let privacy_mismatch env decl1 decl2 = + match decl1.type_private, decl2.type_private with + | Private, Public -> begin + match decl1.type_kind, decl2.type_kind with + | Type_record _, Type_record _ -> Some Private_record_type + | Type_variant _, Type_variant _ -> Some Private_variant_type + | Type_open, Type_open -> Some Private_extensible_variant + | Type_abstract, Type_abstract + when Option.is_some decl2.type_manifest -> begin + match decl1.type_manifest with + | Some ty1 -> begin + let ty1 = Ctype.expand_head env ty1 in + match get_desc ty1 with + | Tvariant row when Btype.is_constr_row ~allow_ident:true + (row_more row) -> + Some Private_row_type + | Tobject (fi, _) when Btype.is_constr_row ~allow_ident:true + (snd (Ctype.flatten_fields fi)) -> + Some Private_row_type + | _ -> + Some Private_type_abbreviation + end + | None -> + None + end + | _, _ -> + None + end + | _, _ -> + None + +let private_variant env row1 params1 row2 params2 = + let r1, r2, pairs = + Ctype.merge_row_fields (row_fields row1) (row_fields row2) + in + let row1_closed = row_closed row1 in + let row2_closed = row_closed row2 in + let err = + if row2_closed && not row1_closed then Some Only_outer_closed + else begin + match row2_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 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 err -> + Some (Types err : private_variant_mismatch) + | () -> None + end + | (s, f1, f2) :: pairs -> begin + match row_field_repr f1, 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 err -> Some (Types err) + | () -> None + end + +let type_manifest env ty1 params1 ty2 params2 priv2 kind2 = + let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in + match get_desc ty1', get_desc ty2' with + | Tvariant row1, Tvariant row2 + when is_absrow env (row_more row2) -> begin + assert (Ctype.is_equal env true (ty1::params1) (row_more row2::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 + let is_private_abbrev_2 = + match priv2, kind2 with + | Private, Type_abstract -> begin + (* Same checks as the [when] guards from above, inverted *) + match get_desc ty2' with + | Tvariant row -> + not (is_absrow env (row_more row)) + | Tobject (fi, _) -> + not (is_absrow env (snd (Ctype.flatten_fields fi))) + | _ -> true + end + | _, _ -> false + in + match + if is_private_abbrev_2 then + Ctype.equal_private env params1 ty1 params2 ty2 + else + Ctype.equal env true (params1 @ [ty1]) (params2 @ [ty2]) + with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> 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 + let err = + match privacy_mismatch env decl1 decl2 with + | Some err -> Some (Privacy err) + | None -> None + in + if err <> None then err 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 err -> Some (Constraint err) + | () -> None + end + | (Some ty1, Some ty2) -> + type_manifest env ty1 decl1.type_params ty2 decl2.type_params + decl2.type_private decl2.type_kind + | (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 err -> Some (Constraint err) + | () -> + match Ctype.equal env false [ty1] [ty2] with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> 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; + Variant_diffing.compare_with_representation ~loc env + decl1.type_params + decl2.type_params + 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; + Record_diffing.compare_with_representation ~loc env + decl1.type_params decl2.type_params + 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 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 err -> + Some (Constructor_mismatch (id, ext1, ext2, Type err)) + | () -> + let r = + Variant_diffing.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_500/typing/includecore.mli b/upstream/ocaml_500/typing/includecore.mli new file mode 100644 index 0000000000..be1687b620 --- /dev/null +++ b/upstream/ocaml_500/typing/includecore.mli @@ -0,0 +1,131 @@ +(**************************************************************************) +(* *) +(* 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 Errortrace.moregen_error + +exception Dont_match of value_mismatch + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type label_mismatch = + | Type of Errortrace.equality_error + | Mutability of position + +type record_change = + (Types.label_declaration as 'ld, 'ld, label_mismatch) Diffing_with_keys.change + +type record_mismatch = + | Label_mismatch of record_change list + | Unboxed_float_representation of position + +type constructor_mismatch = + | Type of Errortrace.equality_error + | Arity + | Inline_record of record_change list + | Kind of position + | Explicit_return_type of position + +type extension_constructor_mismatch = + | Constructor_privacy + | Constructor_mismatch of Ident.t + * extension_constructor + * extension_constructor + * constructor_mismatch +type variant_change = + (Types.constructor_declaration as 'cd, 'cd, constructor_mismatch) + Diffing_with_keys.change + +type private_variant_mismatch = + | Only_outer_closed + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type type_mismatch = + | Arity + | Privacy of privacy_mismatch + | Kind + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | 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_change list + | 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_value_mismatch : + string -> string -> + Env.t -> + Format.formatter -> value_mismatch -> unit + +val report_type_mismatch : + string -> string -> string -> + Env.t -> + Format.formatter -> type_mismatch -> unit + +val report_extension_constructor_mismatch : + string -> string -> string -> + Env.t -> + Format.formatter -> extension_constructor_mismatch -> unit diff --git a/upstream/ocaml_500/typing/includemod.ml b/upstream/ocaml_500/typing/includemod.ml new file mode 100644 index 0000000000..b2bf46a367 --- /dev/null +++ b/upstream/ocaml_500/typing/includemod.ml @@ -0,0 +1,1238 @@ +(**************************************************************************) +(* *) +(* 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, Includecore.value_mismatch) 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; + leftovers: (signature_item * signature_item * int) 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 (diff vd1 vd2 err))) + +(* 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 ~strengthen env path = + match + if strengthen then Env.find_strengthened_module ~aliasable:true path env + else (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 ~strengthen:false 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. *) + +(* When computing a signature difference, we need to distinguish between + recoverable errors at the value level and unrecoverable errors at the type + level that require us to stop the computation of the difference due to + incoherent types. +*) +type 'a recoverable_error = { error: 'a; recoverable:bool } +let mark_error_as_recoverable r = + Result.map_error (fun error -> { error; recoverable=true}) r +let mark_error_as_unrecoverable r = + Result.map_error (fun error -> { error; recoverable=false}) r + + +module Sign_diff = struct + type t = { + runtime_coercions: (int * Typedtree.module_coercion) list; + shape_map: Shape.Map.t; + deep_modifications:bool; + errors: (Ident.t * Error.sigitem_symptom) list; + leftovers: ((Types.signature_item as 'it) * 'it * int) list + } + + let empty = { + runtime_coercions = []; + shape_map = Shape.Map.empty; + deep_modifications = false; + errors = []; + leftovers = [] + } + + let merge x y = + { + runtime_coercions = x.runtime_coercions @ y.runtime_coercions; + shape_map = y.shape_map; + (* the shape map is threaded the map during the difference computation, + the last shape map contains all previous elements. *) + deep_modifications = x.deep_modifications || y.deep_modifications; + errors = x.errors @ y.errors; + leftovers = x.leftovers @ y.leftovers + } +end + +(** + In the group of mutual functions below, the [~in_eq] argument is [true] when + we are in fact checking equality of module types. + + The module subtyping relation [A <: B] checks that [A.T = B.T] when [A] + and [B] define a module type [T]. The relation [A.T = B.T] is equivalent + to [(A.T <: B.T) and (B.T <: A.T)], but checking both recursively would lead + to an exponential slowdown (see #10598 and #10616). + To avoid this issue, when [~in_eq] is [true], we compute a coarser relation + [A << B] which is the same as [A <: B] except that module types [T] are + checked only for [A.T << B.T] and not the reverse. + Thus, we can implement a cheap module type equality check [A.T = B.T] by + computing [(A.T << B.T) and (B.T << A.T)], avoiding the exponential slowdown + described above. +*) + +let rec modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape = + match try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape 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 ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = + 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, orig_shape) + | (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 ~strengthen:false env p1 with + | Error e -> Error (Error.Mt_core e) + | Ok mty1 -> + match strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark + subst mty1 p1 mty2 orig_shape + 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, orig_shape) + else + begin match expand_modtype_path env p1, expand_modtype_path env p2 with + | Some mty1, Some mty2 -> + try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape + | 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 ~in_eq ~loc env ~mark subst p1 mty2 orig_shape + | 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 ~in_eq ~loc env ~mark subst mty1 p2 orig_shape + | 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 ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape + 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 ~in_eq ~loc env ~mark:(negate_mark mark) + subst param1 param2 + in + let var, res_shape = + match Shape.decompose_abs orig_shape with + | Some (var, res_shape) -> var, res_shape + | None -> + (* Using a fresh variable with a placeholder uid here is fine: users + will never try to jump to the definition of that variable. + If they try to jump to the parameter from inside the functor, + they will use the variable shape that is stored in the local + environment. *) + let var, shape_var = + Shape.fresh_var Uid.internal_not_actually_unique + in + var, Shape.app orig_shape ~arg:shape_var + in + let cc_res = modtypes ~in_eq ~loc env ~mark subst res1 res2 res_shape in + begin match cc_arg, cc_res with + | Ok Tcoerce_none, Ok (Tcoerce_none, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_none, final_shape) + | Ok cc_arg, Ok (cc_res, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_functor(cc_arg, cc_res), final_shape) + | _, 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 ~in_eq ~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 ~in_eq ~loc env ~mark Subst.identity arg2' arg1 + Shape.dummy_mod + 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 -> + let id1 = Ident.rename id2 in + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) 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 ~in_eq ~loc ~aliasable env ~mark + subst mty1 path1 mty2 shape = + match mty1, mty2 with + | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> + Ok (Tcoerce_none, shape) + | _, _ -> + let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in + modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape + +and strengthened_module_decl ~loc ~aliasable env ~mark + subst md1 path1 md2 shape = + 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, shape) + | _, _ -> + let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in + modtypes ~in_eq:false ~loc env ~mark subst md1.md_type md2.md_type shape + +(* Inclusion between signatures *) + +and signatures ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = + (* 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 nb_exported pos tbl = function + [] -> nb_exported, pos, tbl + | item :: rem -> + let pos, nextpos = + if is_runtime_component item then pos, pos + 1 + else -1, pos + in + match item_visibility item with + | Hidden -> + (* do not pair private items. *) + build_component_table nb_exported nextpos tbl rem + | Exported -> + let (id, _loc, name) = item_ident_name item in + build_component_table (nb_exported + 1) nextpos + (FieldMap.add name (id, item, pos) tbl) rem + in + let exported_len1, runtime_len1, comps1 = + build_component_table 0 0 FieldMap.empty sig1 + in + let exported_len2, runtime_len2 = + List.fold_left (fun (el, rl) i -> + let el = match item_visibility i with Hidden -> el | Exported -> el + 1 in + let rl = if is_runtime_component i then rl + 1 else rl in + el, rl + ) (0, 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 open Sign_diff in + let d = + signature_components ~in_eq ~loc env ~mark new_env subst mod_shape + Shape.Map.empty + (List.rev paired) + in + begin match unpaired, d.errors, d.runtime_coercions, d.leftovers with + | [], [], cc, [] -> + let shape = + if not d.deep_modifications && exported_len1 = exported_len2 + then mod_shape + else Shape.str ?uid:mod_shape.Shape.uid d.shape_map + in + if runtime_len1 = runtime_len2 then (* see PR#5098 *) + Ok (simplify_structure_coercion cc id_pos_list, shape) + else + Ok (Tcoerce_structure (cc, id_pos_list), shape) + | missings, incompatibles, runtime_coercions, leftovers -> + Error { + Error.env=new_env; + missings; + incompatibles; + oks=runtime_coercions; + leftovers; + } + 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 match FieldMap.find name2 comps1 with + | (id1, item1, pos1) -> + 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 + | exception 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 ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map paired = + match paired with + | [] -> Sign_diff.{ empty with shape_map } + | (sigi1, sigi2, pos) :: rem -> + let shape_modified = ref false in + let id, item, shape_map, 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 item = mark_error_as_recoverable item in + let present_at_runtime = match valdecl2.val_kind with + | Val_prim _ -> false + | _ -> true + in + let shape_map = Shape.Map.add_value_proj shape_map id1 orig_shape in + id1, item, shape_map, 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 + let item = mark_error_as_unrecoverable item in + let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in + id1, item, shape_map, false + | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> + let item = + extension_constructors ~loc env ~mark subst id1 ext1 ext2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_extcons_proj shape_map id1 orig_shape + in + id1, item, shape_map, true + | Sig_module(id1, pres1, mty1, _, _), Sig_module(_, pres2, mty2, _, _) + -> begin + let orig_shape = + Shape.(proj orig_shape (Item.module_ id1)) + in + let item = + module_declarations ~in_eq ~loc env ~mark subst id1 mty1 mty2 + orig_shape + in + let item, shape_map = + match item with + | Ok (cc, shape) -> + if shape != orig_shape then shape_modified := true; + let mod_shape = Shape.set_uid_if_none shape mty1.md_uid in + Ok cc, Shape.Map.add_module shape_map id1 mod_shape + | Error diff -> + Error (Error.Module_type diff), + (* We add the original shape to the map, even though + there is a type error. + It could still be useful for merlin. *) + Shape.Map.add_module shape_map id1 orig_shape + 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 + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, present_at_runtime + end + | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) -> + let item = + modtype_infos ~in_eq ~loc env ~mark subst id1 info1 info2 + in + let shape_map = + Shape.Map.add_module_type_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, false + | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) -> + let item = + class_declarations ~old_env env subst decl1 decl2 + in + let shape_map = + Shape.Map.add_class_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, true + | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) -> + let item = + class_type_declarations ~loc ~old_env env subst info1 info2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_class_type_proj shape_map id1 orig_shape + in + id1, item, shape_map, false + | _ -> + assert false + in + let deep_modifications = !shape_modified in + let first = + match item with + | Ok x -> + let runtime_coercions = + if present_at_runtime then [pos,x] else [] + in + Sign_diff.{ empty with deep_modifications; runtime_coercions } + | Error { error; recoverable=_ } -> + Sign_diff.{ empty with errors=[id,error]; deep_modifications } + in + let continue = match item with + | Ok _ -> true + | Error x -> x.recoverable + in + let rest = + if continue then + signature_components ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map rem + else Sign_diff.{ empty with leftovers=rem } + in + Sign_diff.merge first rest + +and module_declarations ~in_eq ~loc env ~mark subst id1 md1 md2 orig_shape = + 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 ~in_eq ~loc ~aliasable:true env ~mark subst + md1.md_type p1 md2.md_type orig_shape + +(* Inclusion between module type specifications *) + +and modtype_infos ~in_eq ~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 ~in_eq ~loc env ~mark mty1 mty2 + | (None, Some mty2) -> + let mty1 = Mty_ident(Path.Pident id) in + check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 in + match r with + | Ok _ as ok -> ok + | Error e -> Error Error.(Module_type_declaration (diff info1 info2 e)) + +and check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 = + let c1 = + modtypes ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2 Shape.dummy_mod + in + let c2 = + (* For nested module type paths, we check only one side of the equivalence: + the outer module type is the one responsible for checking the other side + of the equivalence. + *) + if in_eq then None + else + let mark = negate_mark mark in + Some ( + modtypes ~in_eq:true ~loc env ~mark Subst.identity + mty2 mty1 Shape.dummy_mod + ) + in + match c1, c2 with + | Ok (Tcoerce_none, _), (Some Ok (Tcoerce_none, _)|None) -> Ok Tcoerce_none + | Ok (c1, _), (Some Ok _ | None) -> + (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." + print_coercion _c1 print_coercion _c2; *) + Error Error.(Illegal_permutation c1) + | Ok _, Some Error e -> Error Error.(Not_greater_than e) + | Error e, (Some Ok _ | None) -> Error Error.(Not_less_than e) + | Error less_than, Some 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 ~in_eq:false ~loc ~aliasable env ~mark:Mark_both + Subst.identity mty1 path1 mty2 Shape.dummy_mod + |> Result.map fst + +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 unit_shape = + match + signatures ~in_eq:false ~loc:(Location.in_file impl_name) env ~mark + Subst.identity impl_sig intf_sig unit_shape + 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 + + module Defs = struct + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state = { + res: module_type option; + env: Env.t; + subst: Subst.t; + } + end + open Defs + + module Diff = Diffing.Define(Defs) + + let param_name = function + | Named(x,_) -> x + | Unit -> None + + let weight: Diff.change -> _ = 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 + + + + 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:Diff.change) 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 module Compute = Diff.Left_variadic(struct + let test st mty1 mty2 = + let loc = Location.none in + let res, _, _ = + functor_param ~in_eq:false ~loc st.env ~mark:Mark_neither + st.subst mty1 mty2 + in + res + let update = update + let weight = weight + end) + 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 + Compute.diff state param1 param2 + +end + +module Functor_app_diff = struct + module I = Functor_inclusion_diff + module Defs= struct + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state = I.Defs.state + end + module Diff = Diffing.Define(Defs) + + let weight: Diff.change -> _ = 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: Diff.change) (st:Defs.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 module Compute = Diff.Right_variadic(struct + let update = update + let test (state:Defs.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 ~in_eq:false ~loc state.env ~mark:Mark_neither + state.subst arg_mty param Shape.dummy_mod + with + | Error mty -> Result.Error (Error.Mismatch mty) + | Ok (cc, _) -> Ok cc + in + res + let weight = weight + end) + in + let args = Array.of_list args in + let params = Array.of_list params in + let state : Defs.state = + { env; subst = Subst.identity; res = I.keep_expansible_param res } + in + Compute.diff state args params + +end + +(* Hide the context and substitution parameters to the outside world *) + +let modtypes_with_shape ~shape ~loc env ~mark mty1 mty2 = + match modtypes ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 shape + with + | Ok (cc, shape) -> cc, shape + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let modtypes ~loc env ~mark mty1 mty2 = + match modtypes ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let signatures env ~mark sig1 sig2 = + match signatures ~in_eq:false ~loc:Location.none env ~mark + Subst.identity sig1 sig2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | 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 Shape.dummy_mod with + | Ok (x, _shape) -> x + | Error mdiff -> + raise (Error(env,Error.(In_Module_type mdiff))) + +let expand_module_alias ~strengthen env path = + match expand_module_alias ~strengthen 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 ~in_eq:false ~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_500/typing/includemod.mli b/upstream/ocaml_500/typing/includemod.mli new file mode 100644 index 0000000000..8846c4510c --- /dev/null +++ b/upstream/ocaml_500/typing/includemod.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. *) +(* *) +(**************************************************************************) + +(* 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, Includecore.value_mismatch) 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; + leftovers: ((Types.signature_item as 'it) * 'it * int) list + (** signature items that could not be compared due to type divergence *) + } + 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 modtypes_with_shape: + shape:Shape.t -> loc:Location.t -> Env.t -> mark:mark -> + module_type -> module_type -> module_coercion * Shape.t + +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 -> Shape.t -> module_coercion * Shape.t + +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: strengthen:bool -> Env.t -> Path.t -> Types.module_type + +module Functor_inclusion_diff: sig + module Defs: sig + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state + end + val diff: Env.t -> + Types.functor_parameter list * Types.module_type -> + Types.functor_parameter list * Types.module_type -> + Diffing.Define(Defs).patch +end + +module Functor_app_diff: sig + module Defs: sig + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state + end + val diff: + Env.t -> + f:Types.module_type -> + args:(Error.functor_arg_descr * Types.module_type) list -> + Diffing.Define(Defs).patch +end diff --git a/upstream/ocaml_500/typing/includemod_errorprinter.ml b/upstream/ocaml_500/typing/includemod_errorprinter.ml new file mode 100644 index 0000000000..24d452fddc --- /dev/null +++ b/upstream/ocaml_500/typing/includemod_errorprinter.ml @@ -0,0 +1,926 @@ +(**************************************************************************) +(* *) +(* 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 "" + 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 "@[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 "@[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 + "@[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 *) + open Diffing + 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 + | Insert mty -> + Insert (add_shorthand Expected pos mty) + | Delete mty -> + Delete (add_shorthand (elide_if_app ctx Got) pos mty) + | Change (g, e, p) -> + Change + (add_shorthand Got pos g, + add_shorthand Expected pos e, p) + | Keep (g, e, p) -> + 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 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 = Diffing.(style @@ classify 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: _ Diffing.change -> _ = function + | Insert mty + | Keep(_,mty,_) + | Change (_,mty,_) as x -> + Some (param_id mty,(x, mty)) + | 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: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (param_id mty,(x,mty)) + | 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: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (None,(x,mty)) + | 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@[%t@]%a" + Format.pp_print_tab () + Format.pp_open_tbox () + Diffing.prefix (pos, Diffing.classify 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@[%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 env id x = + match x with + | Err.Value_descriptions diff -> + Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + "Values do not match" + !Oprint.out_sig_item + (Printtyp.tree_of_value_description id diff.got) + "is not included in" + !Oprint.out_sig_item + (Printtyp.tree_of_value_description id diff.expected) + (Includecore.report_value_mismatch + "the first" "the second" env) diff.symptom + show_locs (diff.got.val_loc, diff.expected.val_loc) + Printtyp.Conflicts.print_explanations + | Err.Type_declarations diff -> + Format.dprintf "@[@[%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" env) diff.symptom + show_locs (diff.got.type_loc, diff.expected.type_loc) + Printtyp.Conflicts.print_explanations + | Err.Extension_constructors diff -> + Format.dprintf "@[@[%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" env) diff.symptom + show_locs (diff.got.ext_loc, diff.expected.ext_loc) + Printtyp.Conflicts.print_explanations + | Err.Class_type_declarations diff -> + Format.dprintf + "@[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 Type_scheme) 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 + "@[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 Type_scheme) 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 + "@[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 + "@[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 + "@[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 + "@[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 env 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 (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.Inclusion.insert mty + | Delete mty -> Functor_suberror.Inclusion.delete mty + | Keep (x, y, _) -> Functor_suberror.Inclusion.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.Inclusion.incompatible i + | 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 (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.App.insert mty + | Delete mty -> Functor_suberror.App.delete mty + | Keep (x, y, _) -> Functor_suberror.App.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.App.incompatible i + | 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 env 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 *) + | [ _, Change (_, _, Err.Incompatible_params (i,_)) ] -> + Location.errorf ~loc "%t" (Functor_suberror.App.incompatible i) + | [ _, 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 + "@[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_500/typing/includemod_errorprinter.mli b/upstream/ocaml_500/typing/includemod_errorprinter.mli new file mode 100644 index 0000000000..12ea2169b0 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/mtype.ml b/upstream/ocaml_500/typing/mtype.ml new file mode 100644 index 0000000000..d649bcdc87 --- /dev/null +++ b/upstream/ocaml_500/typing/mtype.ml @@ -0,0 +1,558 @@ +(**************************************************************************) +(* *) +(* 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_lazy env mty = + let open Subst.Lazy in + match mty with + MtyL_ident p -> + begin try + scrape_lazy env (Env.find_modtype_expansion_lazy p env) + with Not_found -> + mty + end + | _ -> mty + +let scrape env mty = + match mty with + Mty_ident p -> + Subst.Lazy.force_modtype (scrape_lazy env (MtyL_ident p)) + | _ -> mty + +let freshen ~scope mty = + Subst.modtype (Rescope scope) Subst.identity mty + +let rec strengthen_lazy ~aliasable env mty p = + let open Subst.Lazy in + match scrape_lazy env mty with + MtyL_signature sg -> + MtyL_signature(strengthen_lazy_sig ~aliasable env sg p) + | MtyL_functor(Named (Some param, arg), res) + when !Clflags.applicative_functors -> + MtyL_functor(Named (Some param, arg), + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) + | MtyL_functor(Named (None, arg), res) + when !Clflags.applicative_functors -> + let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in + MtyL_functor(Named (Some param, arg), + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) + | mty -> + mty + +and strengthen_lazy_sig' ~aliasable env sg p = + let open Subst.Lazy in + match sg with + [] -> [] + | (SigL_value(_, _, _) as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | SigL_type(id, {type_kind=Type_abstract}, _, _) :: rem + when Btype.is_row_name (Ident.name id) -> + strengthen_lazy_sig' ~aliasable env rem p + | SigL_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 + SigL_type(id, newdecl, rs, vis) :: + strengthen_lazy_sig' ~aliasable env rem p + | (SigL_typext _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | SigL_module(id, pres, md, rs, vis) :: rem -> + let str = + strengthen_lazy_decl ~aliasable env md (Pdot(p, Ident.name id)) + in + let env = + Env.add_module_declaration_lazy ~update_summary:false id pres md env in + SigL_module(id, pres, str, rs, vis) + :: strengthen_lazy_sig' ~aliasable env rem p + (* Need to add the module in case it defines manifest module types *) + | SigL_modtype(id, decl, vis) :: rem -> + let newdecl = + match decl.mtdl_type with + | Some _ when not aliasable -> + (* [not alisable] condition needed because of recursive modules. + See [Typemod.check_recmodule_inclusion]. *) + decl + | _ -> + {decl with mtdl_type = Some(MtyL_ident(Pdot(p,Ident.name id)))} + in + let env = Env.add_modtype_lazy ~update_summary:false id decl env in + SigL_modtype(id, newdecl, vis) :: + strengthen_lazy_sig' ~aliasable env rem p + (* Need to add the module type in case it is manifest *) + | (SigL_class _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | (SigL_class_type _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + +and strengthen_lazy_sig ~aliasable env sg p = + let sg = Subst.Lazy.force_signature_once sg in + let sg = strengthen_lazy_sig' ~aliasable env sg p in + Subst.Lazy.of_signature_items sg + +and strengthen_lazy_decl ~aliasable env md p = + let open Subst.Lazy in + match md.mdl_type with + | MtyL_alias _ -> md + | _ when aliasable -> {md with mdl_type = MtyL_alias p} + | mty -> {md with mdl_type = strengthen_lazy ~aliasable env mty p} + +let () = Env.strengthen := strengthen_lazy + +let strengthen ~aliasable env mty p = + let mty = strengthen_lazy ~aliasable env (Subst.Lazy.of_modtype mty) p in + Subst.Lazy.force_modtype mty + +let strengthen_decl ~aliasable env md p = + let md = strengthen_lazy_decl ~aliasable env + (Subst.Lazy.of_module_decl md) p in + Subst.Lazy.force_module_decl md + +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 = + match get_desc ty with + Tvar _ -> + let level = get_level ty in + 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_500/typing/mtype.mli b/upstream/ocaml_500/typing/mtype.mli new file mode 100644 index 0000000000..68d290b36f --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/oprint.ml b/upstream/ocaml_500/typing/oprint.ml new file mode 100644 index 0000000000..2259e8dcd0 --- /dev/null +++ b/upstream/ocaml_500/typing/oprint.ml @@ -0,0 +1,848 @@ +(**************************************************************************) +(* *) +(* 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 maxlen = max maxlen 8 in (* always show a little prefix *) + 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 "" + 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 "@[%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>> @[%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@[[%s@[@[%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 "@[`%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 "@[@[<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 constructor_of_extension_constructor + (ext : out_extension_constructor) : out_constructor += + { + ocstr_name = ext.oext_name; + ocstr_args = ext.oext_args; + ocstr_return_type = ext.oext_ret_type; + } + +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 "@[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 + (constructor_of_extension_constructor ext :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [constructor_of_extension_constructor ext] + 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 (constructor_of_extension_constructor ext) + | 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>@[%t%a@]%t%t%t@]" + print_name_params + print_out_tkind ty + print_constraints + print_immediate + print_unboxed + +and print_out_constr ppf constr = + let { + ocstr_name = name; + ocstr_args = tyl; + ocstr_return_type = return_type; + } = constr in + let name = + match name with + | "::" -> "(::)" (* #7200 *) + | s -> s + in + match return_type 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 "@[type %t +=%s@;<1 2>%a@]" + print_extended_type + (if ext.oext_private = Asttypes.Private then " private" else "") + print_out_constr + (constructor_of_extension_constructor ext) + +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 "@[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 + (constructor_of_extension_constructor ext :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [constructor_of_extension_constructor ext] + 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 "@[%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_500/typing/oprint.mli b/upstream/ocaml_500/typing/oprint.mli new file mode 100644 index 0000000000..baa733d824 --- /dev/null +++ b/upstream/ocaml_500/typing/oprint.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* 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 -> out_constructor -> 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_500/typing/outcometree.mli b/upstream/ocaml_500/typing/outcometree.mli new file mode 100644 index 0000000000..8e8dfcac3e --- /dev/null +++ b/upstream/ocaml_500/typing/outcometree.mli @@ -0,0 +1,156 @@ +(**************************************************************************) +(* *) +(* 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 out_constructor 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_constructor = { + ocstr_name: string; + ocstr_args: out_type list; + ocstr_return_type: out_type option; +} + +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: out_constructor 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_500/typing/parmatch.ml b/upstream/ocaml_500/typing/parmatch.ml new file mode 100644 index 0000000000..0ec2ddada7 --- /dev/null +++ b/upstream/ocaml_500/typing/parmatch.ml @@ -0,0 +1,2482 @@ +(**************************************************************************) +(* *) +(* 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 = row_field_repr (get_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 get_level ty = Btype.generic_level then ty + else Subst.type_expr Subst.identity ty + +let get_constructor_type_path ty tenv = + let ty = Ctype.expand_head tenv (clean_copy ty) in + match get_desc ty 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 {fields; more; name=orig_name; closed; fixed} = row_repr row in + let name, static = + List.fold_left + (fun (nm, static) (_tag,f) -> + match row_field_repr f with + | Reither(_, _, false) -> + (* fixed=false means that this tag is not explicitly matched *) + link_row_field_ext ~inside:f rf_absent; + (None, static) + | Reither (_, _, true) -> (nm, false) + | Rabsent | Rpresent _ -> (nm, static)) + (orig_name, true) fields in + if not closed || name != orig_name then begin + let more' = if static then Btype.newgenty Tnil else Btype.newgenvar () in + (* this unification cannot fail *) + Ctype.unify env more + (Btype.newgenty + (Tvariant + (create_row ~fields:[] ~more:more' + ~closed:true ~name ~fixed))) + 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.has_fixed_explanation row) then + (* closing=true, we are considering the variant as closed *) + List.for_all + (fun (tag,f) -> + match 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_fields row) + else + row_closed row && + List.for_all + (fun (tag,f) -> + row_field_repr f = Rabsent || List.mem tag fields) + (row_fields row) + | 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 get_desc ty' 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 get_desc ty 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 = "" + +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 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_fields row) + with + [] -> + let tag = + if Btype.has_fixed_explanation 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.has_fixed_explanation 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 _ + | 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_500/typing/parmatch.mli b/upstream/ocaml_500/typing/parmatch.mli new file mode 100644 index 0000000000..fc81476bc4 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/path.ml b/upstream/ocaml_500/typing/path.ml new file mode 100644 index 0000000000..4190c27e6a --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/path.mli b/upstream/ocaml_500/typing/path.mli new file mode 100644 index 0000000000..bddf9d670a --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/patterns.ml b/upstream/ocaml_500/typing/patterns.ml new file mode 100644 index 0000000000..55f9d4ff43 --- /dev/null +++ b/upstream/ocaml_500/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 get_desc (Ctype.expand_head q.pat_env q.pat_type) with + | Tvariant type_row -> 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_500/typing/patterns.mli b/upstream/ocaml_500/typing/patterns.mli new file mode 100644 index 0000000000..66dd2d05a4 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/persistent_env.ml b/upstream/ocaml_500/typing/persistent_env.ml new file mode 100644 index 0000000000..e29017bb3f --- /dev/null +++ b/upstream/ocaml_500/typing/persistent_env.ml @@ -0,0 +1,359 @@ +(**************************************************************************) +(* *) +(* 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 + +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 _ -> () + | 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)) + | 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 + 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 []; + [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 + "@[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 + "@[Invalid import of %s, which uses recursive types.@ %s@]" + import "The compilation flag -rectypes is required" + +let () = + Location.register_error_of_exn + (function + | Error err -> + Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/upstream/ocaml_500/typing/persistent_env.mli b/upstream/ocaml_500/typing/persistent_env.mli new file mode 100644 index 0000000000..618ea3991e --- /dev/null +++ b/upstream/ocaml_500/typing/persistent_env.mli @@ -0,0 +1,104 @@ +(**************************************************************************) +(* *) +(* 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 + +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_500/typing/predef.ml b/upstream/ocaml_500/typing/predef.ml new file mode 100644 index 0000000000..af932a53fd --- /dev/null +++ b/upstream/ocaml_500/typing/predef.ml @@ -0,0 +1,259 @@ +(**************************************************************************) +(* *) +(* 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" +and ident_continuation_already_taken = + ident_create "Continuation_already_taken" +and ident_unhandled = ident_create "Unhandled" + +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; + ident_continuation_already_taken; + ident_unhandled; +] + +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 build_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 + let variant constrs = Type_variant (constrs, Variant_regular) in + empty_env + (* Predefined types - alphabetical order *) + |> add_type1 ident_array + ~variance:Variance.full + ~separability:Separability.Ind + |> add_type ident_bool + ~immediate:Always + ~kind:(variant [cstr ident_false []; cstr ident_true []]) + |> add_type ident_char ~immediate:Always + |> add_type ident_exn ~kind:Type_open + |> add_type ident_extension_constructor + |> add_type ident_float + |> add_type ident_floatarray + |> add_type ident_int ~immediate:Always + |> add_type ident_int32 + |> add_type ident_int64 + |> add_type1 ident_lazy_t + ~variance:Variance.covariant + ~separability:Separability.Ind + |> add_type1 ident_list + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]) + |> add_type ident_nativeint + |> add_type1 ident_option + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_none []; cstr ident_some [tvar]]) + |> add_type ident_string + |> add_type ident_bytes + |> add_type ident_unit + ~immediate:Always + ~kind:(variant [cstr ident_void []]) + (* Predefined exceptions - alphabetical order *) + |> add_extension ident_assert_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_continuation_already_taken [] + |> add_extension ident_division_by_zero [] + |> add_extension ident_end_of_file [] + |> add_extension ident_failure [type_string] + |> add_extension ident_invalid_argument [type_string] + |> add_extension ident_match_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_not_found [] + |> add_extension ident_out_of_memory [] + |> add_extension ident_stack_overflow [] + |> add_extension ident_sys_blocked_io [] + |> add_extension ident_sys_error [type_string] + |> add_extension ident_undefined_recursive_module + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_unhandled [] + +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_500/typing/predef.mli b/upstream/ocaml_500/typing/predef.mli new file mode 100644 index 0000000000..4fde9cce6b --- /dev/null +++ b/upstream/ocaml_500/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 + +(* 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_500/typing/primitive.ml b/upstream/ocaml_500/typing/primitive.ml new file mode 100644 index 0000000000..bf4fe83248 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/primitive.mli b/upstream/ocaml_500/typing/primitive.mli new file mode 100644 index 0000000000..e8376ad552 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/printpat.ml b/upstream/ocaml_500/typing/printpat.ml new file mode 100644 index 0000000000..64094b63ec --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/printpat.mli b/upstream/ocaml_500/typing/printpat.mli new file mode 100644 index 0000000000..1865a2ab29 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/printtyp.ml b/upstream/ocaml_500/typing/printtyp.ml new file mode 100644 index 0000000000..b0bf36cebd --- /dev/null +++ b/upstream/ocaml_500/typing/printtyp.ml @@ -0,0 +1,2533 @@ +(**************************************************************************) +(* *) +(* 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 "@[%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 "@[%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 identifiers 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 string_of_field_kind v = + match field_kind_repr v with + | Fpublic -> "Fpublic" + | Fabsent -> "Fabsent" + | Fprivate -> "Fprivate" + +let rec safe_repr v t = + match Transient_expr.coerce t with + {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 "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" + (string_of_label l) raw_type t1 raw_type t2 + (if is_commu_ok c then "Cok" else "Cunknown") + | Ttuple tl -> + fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl + | Tconstr (p, tl, abbrev) -> + fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p + raw_type_list tl + (raw_list path) (list_of_memo !abbrev) + | Tobject (t, nm) -> + fprintf ppf "@[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 "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f + (string_of_field_kind 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 "@[Tpoly(@,%a,@,%a)@]" + raw_type t + raw_type_list tl + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + fprintf ppf + "@[{@[%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)) + fields + "row_more=" raw_type more + "row_closed=" closed + "row_fixed=" raw_row_fixed fixed + "row_name=" + (fun ppf -> + match 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 "@[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 rf = + match_row_field + ~absent:(fun _ -> fprintf ppf "RFabsent") + ~present:(function + | None -> + fprintf ppf "RFpresent None" + | Some t -> + fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) + ~either:(fun c tl m e -> + fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c + raw_type_list tl m + (fun ppf -> + match e with None -> fprintf ppf " RFnone" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) + rf + +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 String.Set.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 rec index l x = + match l with + [] -> raise Not_found + | a :: l -> if eq_type x a then 0 else 1 + index l x + +let rec uniq = function + [] -> true + | a :: l -> not (List.memq (a : int) l) && uniq l + +let rec normalize_type_path ?(cache=false) env p = + try + let (params, ty, _) = Env.find_type_expansion p env in + match get_desc ty with + Tconstr (p1, tyl, _) -> + if List.length params = List.length tyl + && List.for_all2 eq_type params tyl + then normalize_type_path ~cache env p1 + else if cache || List.length params <= List.length tyl + || not (uniq (List.map get_id 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) + | _ -> + (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 && String.Set.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 proxy ty = Transient_expr.repr (proxy ty) + +(* When printing a type scheme, we print weak names. When printing a plain + type, we do not. This type controls that behavior *) +type type_or_scheme = Type | Type_scheme + +let is_non_gen mode ty = + match mode with + | Type_scheme -> is_Tvar ty && get_level ty <> generic_level + | Type -> false + +let nameable_row row = + row_name row <> None && + List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither(c, l, _) -> + row_closed row && if c then l = [] else List.length l = 1 + | _ -> true) + (row_fields row) + +(* This specialized version of [Btype.iter_type_expr] normalizes and + short-circuits the traversal of the [type_expr], so that it covers only the + subterms that would be printed by the type printer. *) +let printer_iter_type_expr f ty = + match get_desc ty with + | Tconstr(p, tyl, _) -> + let (_p', s) = best_type_path p in + List.iter f (apply_subst s tyl) + | Tvariant row -> begin + match row_name row with + | Some(_p, tyl) when nameable_row row -> + List.iter f tyl + | _ -> + iter_row f row + end + | Tobject (fi, nm) -> begin + match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpublic then + f ty) + fields + | Some (_, l) -> + List.iter f (List.tl l) + end + | Tfield(_, kind, ty1, ty2) -> + if field_kind_repr kind = Fpublic then + f ty1; + f ty2 + | _ -> + Btype.iter_type_expr f ty + +module Names : sig + val reset_names : unit -> unit + + val add_named_vars : type_expr -> unit + val add_subst : (type_expr * type_expr) list -> unit + + val new_name : unit -> string + val new_weak_name : type_expr -> unit -> string + + val name_of_type : (unit -> string) -> transient_expr -> string + val check_name_of_type : transient_expr -> unit + + val remove_names : transient_expr list -> unit + + val with_local_names : (unit -> 'a) -> 'a + + (* Refresh the weak variable map in the toplevel; for [print_items], which is + itself for the toplevel *) + val refresh_weak : unit -> unit +end = struct + (* We map from types to names, but not directly; we also store a substitution, + which maps from types to types. The lookup process is + "type -> apply substitution -> find name". The substitution is presumed to + be acyclic. *) + let names = ref ([] : (transient_expr * string) list) + let name_subst = ref ([] : (transient_expr * transient_expr) list) + let name_counter = ref 0 + let named_vars = ref ([] : string list) + let visited_for_named_vars = ref ([] : transient_expr 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_subst := []; + name_counter := 0; + named_vars := []; + visited_for_named_vars := [] + + let add_named_var tty = + match tty.desc with + Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else + named_vars := name :: !named_vars + | _ -> () + + let rec add_named_vars ty = + let tty = Transient_expr.repr ty in + let px = proxy ty in + if not (List.memq px !visited_for_named_vars) then begin + visited_for_named_vars := px :: !visited_for_named_vars; + match tty.desc with + | Tvar _ | Tunivar _ -> + add_named_var tty + | _ -> + printer_iter_type_expr add_named_vars ty + end + + let rec substitute ty = + match List.assq ty !name_subst with + | ty' -> substitute ty' + | exception Not_found -> ty + + let add_subst subst = + name_subst := + List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) + subst + @ !name_subst + + 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. *) + let t = substitute t in + try List.assq t !names with Not_found -> + try TransientTypeMap.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 substitute tyl in + names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names + + let with_local_names f = + let old_names = !names in + let old_subst = !name_subst in + names := []; + name_subst := []; + try_finally + ~always:(fun () -> + names := old_names; + name_subst := old_subst) + f + + let refresh_weak () = + let refresh t name (m,s) = + if is_non_gen Type_scheme 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 +end + +let reserve_names ty = + normalize_type ty; + Names.add_named_vars ty + +let visited_objects = ref ([] : transient_expr list) +let aliased = ref ([] : transient_expr list) +let delayed = ref ([] : transient_expr list) +let printed_aliases = ref ([] : transient_expr list) + +(* [printed_aliases] is a subset of [aliased] that records only those aliased + types that have actually been printed; this allows us to avoid naming loops + that the user will never see. *) + +let add_delayed t = + if not (List.memq t !delayed) then delayed := t :: !delayed + +let is_aliased_proxy px = List.memq px !aliased + +let add_alias_proxy px = + if not (is_aliased_proxy px) then + aliased := px :: !aliased + +let add_alias ty = add_alias_proxy (proxy ty) + +let add_printed_alias_proxy px = + Names.check_name_of_type px; + printed_aliases := px :: !printed_aliases + +let add_printed_alias ty = add_printed_alias_proxy (proxy ty) + +let aliasable ty = + match get_desc ty with + Tvar _ | Tunivar _ | Tpoly _ -> false + | Tconstr (p, _, _) -> + not (is_nth (snd (best_type_path p))) + | _ -> true + +let should_visit_object ty = + match get_desc ty with + | Tvariant row -> not (static_row row) + | Tobject _ -> opened_object ty + | _ -> false + +let rec mark_loops_rec visited ty = + let px = proxy ty in + if List.memq px visited && aliasable ty then add_alias_proxy px else + let tty = Transient_expr.repr ty in + let visited = px :: visited in + match tty.desc with + | Tvariant _ | Tobject _ -> + if List.memq px !visited_objects then add_alias_proxy px else begin + if should_visit_object ty then + visited_objects := px :: !visited_objects; + printer_iter_type_expr (mark_loops_rec visited) ty + end + | Tpoly(ty, tyl) -> + List.iter add_alias tyl; + mark_loops_rec visited ty + | _ -> + printer_iter_type_expr (mark_loops_rec visited) ty + +let mark_loops ty = + mark_loops_rec [] ty + +let prepare_type ty = + reserve_names ty; + mark_loops ty + +let reset_loop_marks () = + visited_objects := []; aliased := []; delayed := []; printed_aliases := [] + +let reset_except_context () = + Names.reset_names (); reset_loop_marks () + +let reset () = + reset_naming_context (); Conflicts.reset (); + reset_except_context () + +let prepare_for_printing tyl = + reset_except_context (); List.iter prepare_type tyl + +(* Disabled in classic mode when printing an unification error *) +let print_labels = ref true + +let rec tree_of_typexp mode ty = + let px = proxy ty in + if List.memq px !printed_aliases && not (List.memq px !delayed) then + let mark = is_non_gen mode ty in + let name = Names.name_of_type + (if mark then Names.new_weak_name ty else Names.new_name) + px + in + Otyp_var (mark, name) else + + let pr_typ () = + let tty = Transient_expr.repr ty in + match tty.desc with + | Tvar _ -> + let non_gen = is_non_gen mode ty in + let name_gen = + if non_gen then Names.new_weak_name ty else Names.new_name + in + Otyp_var (non_gen, Names.name_of_type name_gen tty) + | 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 get_desc ty1 with + | Tconstr(path, [ty], _) + when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty1 in + Otyp_arrow (lab, t1, tree_of_typexp mode ty2) + | Ttuple tyl -> + Otyp_tuple (tree_of_typlist mode 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 mode (List.hd tyl') + else Otyp_constr (tree_of_path Type p', tree_of_typlist mode tyl') + | Tvariant row -> + let Row {fields; name; closed} = row_repr row in + let fields = + if closed then + List.filter (fun (_, f) -> row_field_repr f <> Rabsent) + fields + else 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 name with + | Some(p, tyl) when nameable_row row -> + let (p', s) = best_type_path p in + let id = tree_of_path Type p' in + let args = tree_of_typlist mode (apply_subst s tyl) in + let out_variant = + if is_nth s then List.hd args else Otyp_constr (id, args) in + if closed && all_present then + out_variant + else + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (non_gen, Ovar_typ out_variant, closed, tags) + | _ -> + let non_gen = + not (closed && all_present) && + is_non_gen mode (Transient_expr.type_expr px) in + let fields = List.map (tree_of_row_field mode) fields in + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (non_gen, Ovar_fields fields, closed, tags) + end + | Tobject (fi, nm) -> + tree_of_typobject mode fi !nm + | Tnil | Tfield _ -> + tree_of_typobject mode ty None + | Tsubst _ -> + (* This case should only happen when debugging the compiler *) + Otyp_stuff "" + | Tlink _ -> + fatal_error "Printtyp.tree_of_typexp" + | Tpoly (ty, []) -> + tree_of_typexp mode ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + if tyl = [] then tree_of_typexp mode ty else begin + let tyl = List.map Transient_expr.repr tyl in + 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 (Names.name_of_type Names.new_name) tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode ty) in + (* Forget names when we leave scope *) + Names.remove_names tyl; + delayed := old_delayed; tr + end + | Tunivar _ -> + Otyp_var (false, Names.name_of_type Names.new_name tty) + | Tpackage (p, fl) -> + let fl = + List.map + (fun (li, ty) -> ( + String.concat "." (Longident.flatten li), + tree_of_typexp mode 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_proxy px && aliasable ty then begin + add_printed_alias_proxy px; + Otyp_alias (pr_typ (), Names.name_of_type Names.new_name px) end + else pr_typ () + +and tree_of_row_field mode (l, f) = + match row_field_repr f with + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) + | Reither(c, tyl, _) -> + if c (* contradiction: constant constructor with an argument *) + then (l, true, tree_of_typlist mode tyl) + else (l, false, tree_of_typlist mode tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode) tyl + +and tree_of_typobject mode 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 + | Fpublic -> (n, t) :: l + | _ -> l) + fields [] in + let sorted_fields = + List.sort + (fun (n, _) (n', _) -> String.compare n n') present_fields in + tree_of_typfields mode 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 mode ty in + let args = tree_of_typlist mode 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 tree_of_typfields mode rest = function + | [] -> + let rest = + match get_desc rest with + | Tvar _ | Tunivar _ -> Some (is_non_gen mode rest) + | Tconstr _ -> Some false + | Tnil -> None + | _ -> fatal_error "typfields (1)" + in + ([], rest) + | (s, t) :: l -> + let field = (s, tree_of_typexp mode t) in + let (fields, rest) = tree_of_typfields mode rest l in + (field :: fields, rest) + +let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + +let prepared_type_expr ppf ty = typexp Type 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 *) + prepare_for_printing [ty]; + prepared_type_expr ppf ty + +(* "Half-prepared" type expression: [ty] should have had its names reserved, but + should not have had its loops marked. *) +let type_expr_with_reserved_names ppf ty = + reset_loop_marks (); + mark_loops ty; + prepared_type_expr ppf ty + +let shared_type_scheme ppf ty = + prepare_type ty; + typexp Type_scheme ppf ty + +let type_scheme ppf ty = + prepare_for_printing [ty]; + typexp Type_scheme 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 + +let tree_of_type_scheme ty = + prepare_for_printing [ty]; + tree_of_typexp Type_scheme 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 Type_scheme ty in + (tr, tree_of_typexp Type_scheme ty') :: list + else list) + params [] + +let filter_params tyl = + let params = + List.fold_left + (fun tyl ty -> + if List.exists (eq_type ty) tyl + then newty2 ~level:generic_level (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 prepare_type_constructor_arguments = function + | Cstr_tuple l -> List.iter prepare_type l + | Cstr_record l -> List.iter (fun l -> prepare_type 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 + (fun ty -> + if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + params + | None -> () + end; + + List.iter add_alias params; + List.iter prepare_type params; + List.iter add_printed_alias params; + let ty_manifest = + match decl.type_manifest with + | None -> None + | Some ty -> + let ty = + (* Special hack to hide variant name *) + match get_desc ty with + Tvariant row -> + begin match row_name row with + Some (Pident id', _) when Ident.same id id' -> + newgenty (Tvariant (set_row_name row None)) + | _ -> ty + end + | _ -> ty + in + prepare_type ty; + Some ty + in + begin match decl.type_kind with + | Type_abstract -> () + | Type_variant (cstrs, _rep) -> + List.iter + (fun c -> + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) + cstrs + | Type_record(l, _rep) -> + List.iter (fun l -> prepare_type 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 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 Type ty), cocn) + params vari) + in + let tree_of_manifest ty1 = + match ty_manifest with + | None -> ty1 + | Some ty -> Otyp_manifest (tree_of_typexp Type 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 Type 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 Type 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 -> { + ocstr_name = name; + ocstr_args = arg (); + ocstr_return_type = None; + } + | Some res -> + Names.with_local_names (fun () -> + let ret = tree_of_typexp Type res in + let args = arg () in + { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = Some ret; + }) + +and tree_of_label l = + (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type 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 -> + Names.with_local_names (fun () -> + let ret = tree_of_typexp Type res in + let args = tree_of_constructor_arguments ext_args in + (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 prepare_type ty_params; + List.iter add_printed_alias ty_params; + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type 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 Type 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 "@[%a@]" + !Oprint.out_constr { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = 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 priv ty = + match priv, get_desc ty with + | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) + | _ , _ -> (ty, []) + +let prepare_method _lab (priv, _virt, ty) = + let ty, _ = method_type priv ty in + prepare_type ty + +let tree_of_method mode (lab, priv, virt, ty) = + let (ty, tyl) = method_type priv ty in + let tty = tree_of_typexp mode ty in + Names.remove_names (List.map Transient_expr.repr tyl); + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, tty) + +let rec prepare_class_type params = function + | Cty_constr (_p, tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects + || not (List.for_all is_Tvar params) + || List.exists (deep_occur row) tyl + then prepare_class_type params cty + else List.iter prepare_type tyl + | Cty_signature sign -> + (* Self may have a name *) + let px = proxy sign.csig_self_row in + if List.memq px !visited_objects then add_alias_proxy px + else visited_objects := px :: !visited_objects; + Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; + Meths.iter prepare_method sign.csig_meths + | Cty_arrow (_, ty, cty) -> + prepare_type ty; + prepare_class_type params cty + +let rec tree_of_class_type mode params = + function + | Cty_constr (p', tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects + || not (List.for_all is_Tvar params) + then + tree_of_class_type mode params cty + else + let namespace = Namespace.best_class_namespace p' in + Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl) + | Cty_signature sign -> + let px = proxy sign.csig_self_row in + let self_ty = + if is_aliased_proxy px then + Some + (Otyp_var (false, Names.name_of_type Names.new_name px)) + else None + 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 mode t) + :: csil) + csil all_vars + in + let all_meths = + Meths.fold + (fun l (p, v, t) all -> (l, p, v, t) :: all) + sign.csig_meths [] + in + let all_meths = List.rev all_meths in + let csil = + List.fold_left + (fun csil meth -> tree_of_method mode meth :: csil) + csil all_meths + 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 get_desc ty with + | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty in + Octy_arrow (lab, tr, tree_of_class_type mode params cty) + +let class_type ppf cty = + reset (); + prepare_class_type [] cty; + !Oprint.out_class_type ppf (tree_of_class_type Type [] cty) + +let tree_of_class_param param variance = + (match tree_of_typexp Type_scheme param with + Otyp_var (_, s) -> s + | _ -> "?"), + if is_Tvar 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 px = proxy (Btype.self_type_row cl.cty_type) in + List.iter prepare_type params; + + List.iter add_printed_alias params; + if is_aliased_proxy px then add_printed_alias_proxy px; + + 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 Type_scheme 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 = cl.clty_params in + + reset_except_context (); + List.iter add_alias params; + prepare_class_type params cl.clty_type; + let px = proxy (Btype.self_type_row cl.clty_type) in + List.iter prepare_type params; + + List.iter add_printed_alias params; + if is_aliased_proxy px then add_printed_alias_proxy px; + + let sign = Btype.signature_of_class_type cl.clty_type in + let has_virtual_vars = + Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_vars false + in + let has_virtual_meths = + Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_meths false + in + Osig_class_type + (has_virtual_vars || has_virtual_meths, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.clty_variance), + tree_of_class_type Type_scheme 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? *) + +let print_items showval env x = + Names.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 "@[%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 + +(* Trace-specific printing *) + +(* 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" + +(* Print a unification error *) + +let same_path t t' = + eq_type t t' || + match get_desc t, get_desc t' 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 eq_type tl tl' + | _ -> false + end + | _ -> + false + +type 'a diff = Same of 'a | Diff of 'a * 'a + +let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = + reset_loop_marks (); + mark_loops t; + if same_path t t' + then begin add_delayed (proxy t); Same (tree_of_typexp mode t) end + else begin + mark_loops t'; + 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 mode t in + let second = tree_of_typexp mode t' in + if first = second then Same first + else Diff(first,second) + end + +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 mode = + List.map (Errortrace.map_diff (trees_of_type_expansion mode)) + +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 = {ty = t1; expanded = t1'}; + expected = {ty = t2; expanded = 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 + +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.map 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 : 'variety trace_format) + keep_last + : ('a, 'variety) Errortrace.t -> _ = 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 get_desc t with + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + if name = None then t else + newty2 ~level:(get_level t) + (Tvariant + (create_row ~fields ~fixed ~closed ~name:None + ~more:(newvar2 (get_level more)))) + | _ -> t + +let prepare_expansion Errortrace.{ty; expanded} = + let expanded = hide_variant_name expanded in + reserve_names ty; + if not (same_path ty expanded) then reserve_names expanded; + Errortrace.{ty; expanded} + +let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = + match get_desc expanded with + Tvariant _ | Tobject _ when compact -> + reserve_names ty; Errortrace.{ty; expanded = ty} + | _ -> prepare_expansion ty_exp + +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 get_desc (Ctype.expand_head env ty) 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 get_desc t3, get_desc t4 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 -> + reserve_names x; + dprintf "The %a variant type is bound to the universal type variable %a" + Errortrace.print_pos pos type_expr_with_reserved_names 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)@ @[%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.Presence_not_guaranteed_for (pos, s) -> Some( + dprintf + "@,@[The tag `%s is guaranteed to be present in the %a variant type,\ + @ but not in the %a@]" + s + Errortrace.print_pos (Errortrace.swap_position pos) + Errortrace.print_pos pos + ) + | 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 -> + reserve_names u; + Some( + dprintf "%t@,The universal variable %a would escape its scope" + pre type_expr_with_reserved_names 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 Errortrace.{ty = _; expanded = t} -> + reserve_names t; + Some( + dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" + pre type_expr_with_reserved_names 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 + : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function + | Errortrace.Diff {got; expected} -> + explanation_diff env got.expanded expected.expanded + | Errortrace.Escape {kind; context} -> + let pre = + match context, kind, prev with + | Some ctx, _, _ -> + reserve_names ctx; + dprintf "@[%t@;<1 2>%a@]" intro type_expr_with_reserved_names ctx + | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> + reserve_names diff.got; + reserve_names diff.expected; + dprintf "@,@[The method %s has type@ %a,@ \ + but the expected method type was@ %a@]" + name + type_expr_with_reserved_names diff.got + type_expr_with_reserved_names 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) -> + reserve_names x; + reserve_names y; + begin match get_desc x with + | Tvar _ | Tunivar _ -> + Some(fun ppf -> + reset_loop_marks (); + mark_loops x; + mark_loops y; + dprintf "@,@[The type variable %a occurs inside@ %a@]" + prepared_type_expr x prepared_type_expr y + ppf) + | _ -> + (* 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 get_desc t 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 mode txt_got txt_but = function + | None -> ignore + | Some d -> + let d = Errortrace.map_diff (trees_of_type_expansion mode) 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 = {ty=te1; expanded=_}; + expected = {ty=te2; expanded=_} } -> + warn_on_missing_def env ppf te1; + warn_on_missing_def env ppf te2 + +(* [subst] comes out of equality, and is [[]] otherwise *) +let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = + reset (); + (* We want to substitute in the opposite order from [Eqtype] *) + Names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); + let tr = + prepare_trace + (fun ty_exp -> + Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) + 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 mode txt1 txt2 head in + let tr = trees_of_trace mode tr in + fprintf ppf + "@[\ + @[%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 mode env tr + ?(subst = []) + ?(type_expected_explanation = fun _ -> ()) + txt1 txt2 = + wrap_printing_env ~error:true env (fun () -> + error trace_format mode subst env tr txt1 ppf txt2 + type_expected_explanation) + +let report_unification_error + ppf env ({trace} : Errortrace.unification_error) = + report_error Unification ppf Type env + ?subst:None trace + +let report_equality_error + ppf mode env ({subst; trace} : Errortrace.equality_error) = + report_error Equality ppf mode env + ~subst ?type_expected_explanation:None trace + +let report_moregen_error + ppf mode env ({trace} : Errortrace.moregen_error) = + report_error Moregen ppf mode env + ?subst:None ?type_expected_explanation:None trace + +let report_comparison_error ppf mode env = function + | Errortrace.Equality_error error -> report_equality_error ppf mode env error + | Errortrace.Moregen_error error -> report_moregen_error ppf mode env error + +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.map 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 Type + @@ 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 Type) diff) + | _ -> None + + let subtype_get_diff = function + | Errortrace.Subtype.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + + let report_error + ppf + env + (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) + txt1 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tr_sub = prepare_trace prepare_expansion tr_sub in + let tr_unif = prepare_unification_trace prepare_expansion tr_unif in + let keep_first = match tr_unif with + | [Obj _ | Variant _ | Escape _ ] | [] -> true + | _ -> false in + fprintf ppf "@[%a" + (trace filter_subtype_trace subtype_get_diff true keep_first txt1) + tr_sub; + if tr_unif = [] then fprintf ppf "@]" else + let mis = mismatch (dprintf "Within this type") env tr_unif in + fprintf ppf "%a%t%t@]" + (trace filter_unification_trace unification_get_diff false + (mis = None) "is not compatible with type") tr_unif + (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>@[%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 mode ppf ty_exp = + type_expansion ppf (trees_of_type_expansion mode ty_exp) +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_500/typing/printtyp.mli b/upstream/ocaml_500/typing/printtyp.mli new file mode 100644 index 0000000000..13b2ed95e8 --- /dev/null +++ b/upstream/ocaml_500/typing/printtyp.mli @@ -0,0 +1,241 @@ +(**************************************************************************) +(* *) +(* 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 + +(** Print out a type. This will pick names for type variables, and will not + reuse names for common type variables shared across multiple type + expressions. (It will also reset the printing state, which matters for + other type formatters such as [prepared_type_expr].) If you want multiple + types to use common names for type variables, see [prepare_for_printing] and + [prepared_type_expr]. *) +val type_expr: formatter -> type_expr -> unit + +(** [prepare_for_printing] resets the global printing environment, a la [reset], + and prepares the types for printing by reserving names and marking loops. + Any type variables that are shared between multiple types in the input list + will be given the same name when printed with [prepared_type_expr]. *) +val prepare_for_printing: type_expr list -> unit +val prepared_type_expr: formatter -> type_expr -> unit +(** The function [prepared_type_expr] is a less-safe but more-flexible version + of [type_expr] that should only be called on [type_expr]s that have been + passed to [prepare_for_printing]. Unlike [type_expr], this function does no + extra work before printing a type; in particular, this means that any loops + in the type expression may cause a stack overflow (see #8860) since this + function does not mark any loops. The benefit of this is that if multiple + type expressions are prepared simultaneously and then printed with + [prepared_type_expr], they will use the same names for the same type + variables. *) + +val constructor_arguments: formatter -> constructor_arguments -> unit +val tree_of_type_scheme: type_expr -> out_type +val type_scheme: formatter -> type_expr -> unit +val shared_type_scheme: formatter -> type_expr -> unit +(** [shared_type_scheme] is very similar to [type_scheme], but does not reset + the printing context first. This is intended to be used in cases where the + printing should have a particularly wide context, such as documentation + generators; most use cases, such as error messages, have narrower contexts + for which [type_scheme] is better suited. *) + +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 + +type type_or_scheme = Type | Type_scheme + +val tree_of_signature: Types.signature -> out_sig_item list +val tree_of_typexp: type_or_scheme -> 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_or_scheme -> Format.formatter -> Errortrace.expanded_type -> unit +val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type +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_error -> + ?type_expected_explanation:(formatter -> unit) -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_equality_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.equality_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_moregen_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.moregen_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_comparison_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.comparison_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +module Subtype : sig + val report_error : + formatter -> + Env.t -> + Errortrace.Subtype.error -> + string -> + 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_500/typing/printtyped.ml b/upstream/ocaml_500/typing/printtyped.ml new file mode 100644 index 0000000000..e02b718d00 --- /dev/null +++ b/upstream/ocaml_500/typing/printtyped.ml @@ -0,0 +1,954 @@ +(**************************************************************************) +(* *) +(* 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 typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + +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 + begin match x.pat_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (pattern_extra (i+1) ppf) extra; + end; + 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 = i+1 in + begin match x.exp_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (expression_extra (i+1) ppf) extra; + end; + 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) -> + line i ppf "Texp_send \"%s\"\n" s; + expression i ppf e + | Texp_send (e, Tmeth_val s) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e + | Texp_send (e, Tmeth_ancestor(s, _)) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e + | 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(v, a, r) -> + line i ppf "Text_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; + 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 " %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_vars; + 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; + if cd_vars <> [] then line (i+1) ppf "cd_vars =%a\n" typevars cd_vars; + 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 "\n"; + pattern (i+1) ppf c_lhs; + begin match c_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf c_rhs; + +and value_binding i ppf x = + line i ppf "\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 " \"%a\"\n" fmt_ident 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 "" + +and label_x_expression i ppf (l, e) = + line i ppf "\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 " \"%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_500/typing/printtyped.mli b/upstream/ocaml_500/typing/printtyped.mli new file mode 100644 index 0000000000..43539ead9d --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/rec_check.ml b/upstream/ocaml_500/typing/rec_check.ml new file mode 100644 index 0000000000..1980b82d02 --- /dev/null +++ b/upstream/ocaml_500/typing/rec_check.ml @@ -0,0 +1,1260 @@ +(**************************************************************************) +(* *) +(* 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 |- : m -| G' + G' |- body : m + ------------------------------- + G |- let 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, _) -> + (* + G |- e: m[Dereference] + ---------------------- (plus weird 'eo' option) + G |- e#x: m + *) + join [ + expression e1 << 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 |- : 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 = + match expr.exp_desc with + | Texp_function _ -> + (* Fast path: functions can never have invalid recursive references *) + true + | _ -> + match classify_expression expr with + | Static -> + (* The expression has known size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] + | Dynamic -> + (* The expression has unknown size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] + +(* 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_500/typing/rec_check.mli b/upstream/ocaml_500/typing/rec_check.mli new file mode 100644 index 0000000000..aa5c1ca3c1 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/shape.ml b/upstream/ocaml_500/typing/shape.ml new file mode 100644 index 0000000000..f82e5343fa --- /dev/null +++ b/upstream/ocaml_500/typing/shape.ml @@ -0,0 +1,521 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* 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 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 "" + | Predef name -> Format.fprintf fmt "" 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 + +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" + + let can_appear_in_types = function + | Value + | Extension_constructor -> + false + | Type + | Module + | Module_type + | Class + | Class_type -> + true +end + +module Item = struct + module T = struct + type t = string * Sig_component_kind.t + let compare = compare + + let make str ns = str, ns + + let value id = Ident.name id, Sig_component_kind.Value + let type_ id = Ident.name id, Sig_component_kind.Type + let module_ id = Ident.name id, Sig_component_kind.Module + let module_type id = Ident.name id, Sig_component_kind.Module_type + let extension_constructor id = + Ident.name id, Sig_component_kind.Extension_constructor + let class_ id = + Ident.name id, Sig_component_kind.Class + let class_type id = + Ident.name id, Sig_component_kind.Class_type + + let print fmt (name, ns) = + Format.fprintf fmt "%S[%s]" + name + (Sig_component_kind.to_string ns) + end + + include T + + module Map = Map.Make(T) +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + +let print fmt = + let print_uid_opt = + Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print) + in + let rec aux fmt { uid; desc } = + match desc with + | Var id -> + Format.fprintf fmt "%a%a" Ident.print id print_uid_opt uid + | Abs (id, t) -> + Format.fprintf fmt "Abs@[%a@,(@[%a,@ @[%a@]@])@]" + print_uid_opt uid Ident.print id aux t + | App (t1, t2) -> + Format.fprintf fmt "@[%a(@,%a)%a@]" aux t1 aux t2 + print_uid_opt uid + | Leaf -> + Format.fprintf fmt "<%a>" (Format.pp_print_option Uid.print) uid + | Proj (t, item) -> + begin match uid with + | None -> + Format.fprintf fmt "@[%a@ .@ %a@]" + aux t + Item.print item + | Some uid -> + Format.fprintf fmt "@[(%a@ .@ %a)<%a>@]" + aux t + Item.print item + Uid.print uid + end + | Comp_unit name -> Format.fprintf fmt "CU %s" name + | Struct map -> + let print_map fmt = + Item.Map.iter (fun item t -> + Format.fprintf fmt "@[%a ->@ %a;@]@," + Item.print item + aux t + ) + in + Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + in + Format.fprintf fmt"@[%a@]@;" aux + +let fresh_var ?(name="shape-var") uid = + let var = Ident.create_local name in + var, { uid = Some uid; desc = Var var } + +let for_unnamed_functor_param = Ident.create_local "()" + +let var uid id = + { uid = Some uid; desc = Var id } + +let abs ?uid var body = + { uid; desc = Abs (var, body) } + +let str ?uid map = + { uid; desc = Struct map } + +let leaf uid = + { uid = Some uid; desc = Leaf } + +let proj ?uid t item = + match t.desc with + | Leaf -> + (* When stuck projecting in a leaf we propagate the leaf + as a best effort *) + t + | Struct map -> + begin try Item.Map.find item map + with Not_found -> t (* ill-typed program *) + end + | _ -> + { uid; desc = Proj (t, item) } + +let app ?uid f ~arg = + { uid; desc = App (f, arg) } + +let decompose_abs t = + match t.desc with + | Abs (x, t) -> Some (x, t) + | _ -> None + +module Make_reduce(Params : sig + type env + val fuel : int + val read_unit_shape : unit_name:string -> t option + val find_shape : env -> Ident.t -> t +end) = struct + (* We implement a strong call-by-need reduction, following an + evaluator from Nathanaelle Courant. *) + + type nf = { uid: Uid.t option; desc: nf_desc } + and nf_desc = + | NVar of var + | NApp of nf * nf + | NAbs of local_env * var * t * delayed_nf + | NStruct of delayed_nf Item.Map.t + | NProj of nf * Item.t + | NLeaf + | NComp_unit of string + | NoFuelLeft of desc + (* A type of normal forms for strong call-by-need evaluation. + The normal form of an abstraction + Abs(x, t) + is a closure + NAbs(env, x, t, dnf) + when [env] is the local environment, and [dnf] is a delayed + normal form of [t]. + + A "delayed normal form" is morally equivalent to (nf Lazy.t), but + we use a different representation that is compatible with + memoization (lazy values are not hashable/comparable by default + comparison functions): we represent a delayed normal form as + just a not-yet-computed pair [local_env * t] of a term in a + local environment -- we could also see this as a term under + an explicit substitution. This delayed thunked is "forced" + by calling the normalization function as usual, but duplicate + computations are precisely avoided by memoization. + *) + and delayed_nf = Thunk of local_env * t + + and local_env = delayed_nf option Ident.Map.t + (* When reducing in the body of an abstraction [Abs(x, body)], we + bind [x] to [None] in the environment. [Some v] is used for + actual substitutions, for example in [App(Abs(x, body), t)], when + [v] is a thunk that will evaluate to the normal form of [t]. *) + + let improve_uid uid (nf : nf) = + match nf.uid with + | Some _ -> nf + | None -> { nf with uid } + + let in_memo_table memo_table memo_key f arg = + match Hashtbl.find memo_table memo_key with + | res -> res + | exception Not_found -> + let res = f arg in + Hashtbl.replace memo_table memo_key res; + res + + type env = { + fuel: int ref; + global_env: Params.env; + local_env: local_env; + reduce_memo_table: (local_env * t, nf) Hashtbl.t; + read_back_memo_table: (nf, t) Hashtbl.t; + } + + let bind env var shape = + { env with local_env = Ident.Map.add var shape env.local_env } + + let rec reduce_ env t = + let memo_key = (env.local_env, t) in + in_memo_table env.reduce_memo_table memo_key (reduce__ env) t + (* Memoization is absolutely essential for performance on this + problem, because the normal forms we build can in some real-world + cases contain an exponential amount of redundancy. Memoization + can avoid the repeated evaluation of identical subterms, + providing a large speedup, but even more importantly it + implicitly shares the memory of the repeated results, providing + much smaller normal forms (that blow up again if printed back + as trees). A functor-heavy file from Irmin has its shape normal + form decrease from 100Mio to 2.5Mio when memoization is enabled. + + Note: the local environment is part of the memoization key, while + it is defined using a type Ident.Map.t of non-canonical balanced + trees: two maps could have exactly the same items, but be + balanced differently and therefore hash differently, reducing + the effectivenss of memoization. + This could in theory happen, say, with the two programs + (fun x -> fun y -> ...) + and + (fun y -> fun x -> ...) + having "the same" local environments, with additions done in + a different order, giving non-structurally-equal trees. Should we + define our own hash functions to provide robust hashing on + environments? + + We believe that the answer is "no": this problem does not occur + in practice. We can assume that identifiers are unique on valid + typedtree fragments (identifier "stamps" distinguish + binding positions); in particular the two program fragments above + in fact bind *distinct* identifiers x (with different stamps) and + different identifiers y, so the environments are distinct. If two + environments are structurally the same, they must correspond to + the evaluation evnrionments of two sub-terms that are under + exactly the same scope of binders. So the two environments were + obtained by the same term traversal, adding binders in the same + order, giving the same balanced trees: the environments have the + same hash. +*) + + and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) = + let reduce env t = reduce_ env t in + let delay_reduce env t = Thunk (env.local_env, t) in + let force (Thunk (local_env, t)) = + reduce { env with local_env } t in + let return desc : nf = { uid = t.uid; desc } in + if !fuel < 0 then return (NoFuelLeft t.desc) + else + match t.desc with + | Comp_unit unit_name -> + begin match Params.read_unit_shape ~unit_name with + | Some t -> reduce env t + | None -> return (NComp_unit unit_name) + end + | App(f, arg) -> + let f = reduce env f in + begin match f.desc with + | NAbs(clos_env, var, body, _body_nf) -> + let arg = delay_reduce env arg in + let env = bind { env with local_env = clos_env } var (Some arg) in + reduce env body + |> improve_uid t.uid + | _ -> + let arg = reduce env arg in + return (NApp(f, arg)) + end + | Proj(str, item) -> + let str = reduce env str in + let nored () = return (NProj(str, item)) in + begin match str.desc with + | NStruct (items) -> + begin match Item.Map.find item items with + | exception Not_found -> nored () + | nf -> + force nf + |> improve_uid t.uid + end + | _ -> + nored () + end + | Abs(var, body) -> + let body_nf = delay_reduce (bind env var None) body in + return (NAbs(local_env, var, body, body_nf)) + | Var id -> + begin match Ident.Map.find id local_env with + (* Note: instead of binding abstraction-bound variables to + [None], we could unify it with the [Some v] case by + binding the bound variable [x] to [NVar x]. + + One reason to distinguish the situations is that we can + provide a different [Uid.t] location; for bound + variables, we use the [Uid.t] of the bound occurrence + (not the binding site), whereas for bound values we use + their binding-time [Uid.t]. *) + | None -> return (NVar id) + | Some def -> force def + | exception Not_found -> + match Params.find_shape global_env id with + | exception Not_found -> return (NVar id) + | res when res = t -> return (NVar id) + | res -> + decr fuel; + reduce env res + end + | Leaf -> return NLeaf + | Struct m -> + let mnf = Item.Map.map (delay_reduce env) m in + return (NStruct mnf) + + let rec read_back env (nf : nf) : t = + in_memo_table env.read_back_memo_table nf (read_back_ env) nf + (* The [nf] normal form we receive may contain a lot of internal + sharing due to the use of memoization in the evaluator. We have + to memoize here again, otherwise the sharing is lost by mapping + over the term as a tree. *) + + and read_back_ env (nf : nf) : t = + { uid = nf.uid; desc = read_back_desc env nf.desc } + + and read_back_desc env desc = + let read_back nf = read_back env nf in + let read_back_force (Thunk (local_env, t)) = + read_back (reduce_ { env with local_env } t) in + match desc with + | NVar v -> + Var v + | NApp (nft, nfu) -> + App(read_back nft, read_back nfu) + | NAbs (_env, x, _t, nf) -> + Abs(x, read_back_force nf) + | NStruct nstr -> + Struct (Item.Map.map read_back_force nstr) + | NProj (nf, item) -> + Proj (read_back nf, item) + | NLeaf -> Leaf + | NComp_unit s -> Comp_unit s + | NoFuelLeft t -> t + + let reduce global_env t = + let fuel = ref Params.fuel in + let reduce_memo_table = Hashtbl.create 42 in + let read_back_memo_table = Hashtbl.create 42 in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table; + read_back_memo_table; + local_env; + } in + reduce_ env t |> read_back env +end + +module Local_reduce = + (* Note: this definition with [type env = unit] is only suitable for + reduction of toplevel shapes -- shapes of compilation units, + where free variables are only Comp_unit names. If we wanted to + reduce shapes inside module signatures, we would need to take + a typing environment as parameter. *) + Make_reduce(struct + type env = unit + let fuel = 10 + let read_unit_shape ~unit_name:_ = None + let find_shape _env _id = raise Not_found + end) + +let local_reduce shape = + Local_reduce.reduce () shape + +let dummy_mod = { uid = None; desc = Struct Item.Map.empty } + +let of_path ~find_shape ~namespace = + let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function + | Pident id -> find_shape ns id + | Pdot (path, name) -> proj (aux Module path) (name, ns) + | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) + in + aux namespace + +let for_persistent_unit s = + { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s)); + desc = Comp_unit s } + +let leaf_for_unpack = { uid = None; desc = Leaf } + +let set_uid_if_none t uid = + match t.uid with + | None -> { t with uid = Some uid } + | _ -> t + +module Map = struct + type shape = t + type nonrec t = t Item.Map.t + + let empty = Item.Map.empty + + let add t item shape = Item.Map.add item shape t + + let add_value t id uid = Item.Map.add (Item.value id) (leaf uid) t + let add_value_proj t id shape = + let item = Item.value id in + Item.Map.add item (proj shape item) t + + let add_type t id uid = Item.Map.add (Item.type_ id) (leaf uid) t + let add_type_proj t id shape = + let item = Item.type_ id in + Item.Map.add item (proj shape item) t + + let add_module t id shape = Item.Map.add (Item.module_ id) shape t + let add_module_proj t id shape = + let item = Item.module_ id in + Item.Map.add item (proj shape item) t + + let add_module_type t id uid = + Item.Map.add (Item.module_type id) (leaf uid) t + let add_module_type_proj t id shape = + let item = Item.module_type id in + Item.Map.add item (proj shape item) t + + let add_extcons t id uid = + Item.Map.add (Item.extension_constructor id) (leaf uid) t + let add_extcons_proj t id shape = + let item = Item.extension_constructor id in + Item.Map.add item (proj shape item) t + + let add_class t id uid = Item.Map.add (Item.class_ id) (leaf uid) t + let add_class_proj t id shape = + let item = Item.class_ id in + Item.Map.add item (proj shape item) t + + let add_class_type t id uid = Item.Map.add (Item.class_type id) (leaf uid) t + let add_class_type_proj t id shape = + let item = Item.class_type id in + Item.Map.add item (proj shape item) t +end diff --git a/upstream/ocaml_500/typing/shape.mli b/upstream/ocaml_500/typing/shape.mli new file mode 100644 index 0000000000..8a5aaca4fb --- /dev/null +++ b/upstream/ocaml_500/typing/shape.mli @@ -0,0 +1,157 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* 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 Uid : sig + type t = private + | Compilation_unit of string + | Item of { comp_unit: string; id: int } + | Internal + | Predef of string + + 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 + +module Sig_component_kind : sig + type t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + val to_string : t -> string + + (** Whether the name of a component of that kind can appear in a type. *) + val can_appear_in_types : t -> bool +end + +module Item : sig + type t + + val make : string -> Sig_component_kind.t -> t + + val value : Ident.t -> t + val type_ : Ident.t -> t + val module_ : Ident.t -> t + val module_type : Ident.t -> t + val extension_constructor : Ident.t -> t + val class_ : Ident.t -> t + val class_type : Ident.t -> t + + module Map : Map.S with type key = t +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + +val print : Format.formatter -> t -> unit + +(* Smart constructors *) + +val for_unnamed_functor_param : var +val fresh_var : ?name:string -> Uid.t -> var * t + +val var : Uid.t -> Ident.t -> t +val abs : ?uid:Uid.t -> var -> t -> t +val app : ?uid:Uid.t -> t -> arg:t -> t +val str : ?uid:Uid.t -> t Item.Map.t -> t +val proj : ?uid:Uid.t -> t -> Item.t -> t +val leaf : Uid.t -> t + +val decompose_abs : t -> (var * t) option + +val for_persistent_unit : string -> t +val leaf_for_unpack : t + +module Map : sig + type shape = t + type nonrec t = t Item.Map.t + + val empty : t + + val add : t -> Item.t -> shape -> t + + val add_value : t -> Ident.t -> Uid.t -> t + val add_value_proj : t -> Ident.t -> shape -> t + + val add_type : t -> Ident.t -> Uid.t -> t + val add_type_proj : t -> Ident.t -> shape -> t + + val add_module : t -> Ident.t -> shape -> t + val add_module_proj : t -> Ident.t -> shape -> t + + val add_module_type : t -> Ident.t -> Uid.t -> t + val add_module_type_proj : t -> Ident.t -> shape -> t + + val add_extcons : t -> Ident.t -> Uid.t -> t + val add_extcons_proj : t -> Ident.t -> shape -> t + + val add_class : t -> Ident.t -> Uid.t -> t + val add_class_proj : t -> Ident.t -> shape -> t + + val add_class_type : t -> Ident.t -> Uid.t -> t + val add_class_type_proj : t -> Ident.t -> shape -> t +end + +val dummy_mod : t + +val of_path : + find_shape:(Sig_component_kind.t -> Ident.t -> t) -> + namespace:Sig_component_kind.t -> Path.t -> t + +val set_uid_if_none : t -> Uid.t -> t + +(** The [Make_reduce] functor is used to generate a reduction function for + shapes. + + It is parametrized by: + - an environment and a function to find shapes by path in that environment + - a function to load the shape of an external compilation unit + - some fuel, which is used to bound recursion when dealing with recursive + shapes introduced by recursive modules. (FTR: merlin currently uses a + fuel of 10, which seems to be enough for most practical examples) +*) +module Make_reduce(Context : sig + type env + + val fuel : int + + val read_unit_shape : unit_name:string -> t option + + val find_shape : env -> Ident.t -> t + end) : sig + val reduce : Context.env -> t -> t +end + +val local_reduce : t -> t diff --git a/upstream/ocaml_500/typing/signature_group.ml b/upstream/ocaml_500/typing/signature_group.ml new file mode 100644 index 0000000000..b2cc7d4910 --- /dev/null +++ b/upstream/ocaml_500/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 + syntactic 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/upstream/ocaml_500/typing/signature_group.mli b/upstream/ocaml_500/typing/signature_group.mli new file mode 100644 index 0000000000..0b736a5b45 --- /dev/null +++ b/upstream/ocaml_500/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 + syntactic 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/upstream/ocaml_500/typing/stypes.ml b/upstream/ocaml_500/typing/stypes.ml new file mode 100644 index 0000000000..c3db19a552 --- /dev/null +++ b/upstream/ocaml_500/typing/stypes.ml @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* 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; + Format.pp_print_string Format.str_formatter " "; + Printtyp.wrap_printing_env ~error:false env + (fun () -> Printtyp.shared_type_scheme 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_500/typing/stypes.mli b/upstream/ocaml_500/typing/stypes.mli new file mode 100644 index 0000000000..3a86d27a57 --- /dev/null +++ b/upstream/ocaml_500/typing/stypes.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* 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_500/typing/subst.ml b/upstream/ocaml_500/typing/subst.ml new file mode 100644 index 0000000000..759f567dce --- /dev/null +++ b/upstream/ocaml_500/typing/subst.ml @@ -0,0 +1,766 @@ +(**************************************************************************) +(* *) +(* 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; + create_expr + 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 desc = get_desc ty in + match desc with + Tvar _ | Tunivar _ -> + if s.for_saving || get_id ty < 0 then + let ty' = + if s.for_saving then newpersty (norm desc) + else newty2 ~level:(get_level ty) desc + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + ty' + else ty + | Tsubst (ty, _) -> + ty + | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method + && field_kind_repr k <> Fabsent && get_level ty < 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 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 newgenstub ~scope:(get_scope ty) + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + let desc = + if has_fixed_row then + match get_desc tm 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 more = row_more row in + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + begin match mored with + Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + let dup = + s.for_saving || get_level more = generic_level || + static_row row || is_Tconstr more in + (* Various cases for the row variable *) + let more' = + match mored with + Tsubst (ty, None) -> ty + | Tconstr _ | Tnil -> typexp copy_scope s more + | Tunivar _ | Tvar _ -> + if s.for_saving then newpersty (norm mored) + else if dup && is_Tvar more then newgenty mored + else more + | _ -> assert false + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope 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_name row with + | Some (p, tl) -> + let name = + if to_subst_by_type_function s p then None + else Some (type_path s p, tl) + in + Tvariant (set_row_name row name) + | 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 + in + Transient_expr.set_stub_desc ty' desc; + 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_self_row = typexp copy_scope s sign.csig_self_row; + csig_vars = + Vars.map + (function (m, v, t) -> (m, v, typexp copy_scope s t)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, t) -> (p, v, typexp copy_scope s t)) + sign.csig_meths; + } + +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) + + +(* 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 }) + +type scoping = + | Keep + | Make_local + | Rescope of int + +module Lazy_types = struct + + type module_decl = + { + mdl_type: modtype; + mdl_attributes: Parsetree.attributes; + mdl_loc: Location.t; + mdl_uid: Uid.t; + } + + and modtype = + | MtyL_ident of Path.t + | MtyL_signature of signature + | MtyL_functor of functor_parameter * modtype + | MtyL_alias of Path.t + + and modtype_declaration = + { + mtdl_type: modtype option; + mtdl_attributes: Parsetree.attributes; + mtdl_loc: Location.t; + mtdl_uid: Uid.t; + } + + and signature' = + | S_eager of Types.signature + | S_lazy of signature_item list + + and signature = + (scoping * t * signature', signature') Lazy_backtrack.t + + and signature_item = + SigL_value of Ident.t * value_description * visibility + | SigL_type of Ident.t * type_declaration * rec_status * visibility + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility + | SigL_module of + Ident.t * module_presence * module_decl * rec_status * visibility + | SigL_modtype of Ident.t * modtype_declaration * visibility + | SigL_class of Ident.t * class_declaration * rec_status * visibility + | SigL_class_type of Ident.t * class_type_declaration * + rec_status * visibility + + and functor_parameter = + | Unit + | Named of Ident.t option * modtype + +end +open Lazy_types + +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 + | SigL_type(id, td, rs, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_type id (Pident id') s) + (SigL_type(id', td, rs, vis) :: sg) + rest + | SigL_module(id, pres, md, rs, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_module id (Pident id') s) + (SigL_module (id', pres, md, rs, vis) :: sg) + rest + | SigL_modtype(id, mtd, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_modtype id (Mty_ident(Pident id')) s) + (SigL_modtype(id', mtd, vis) :: sg) + rest + | SigL_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) + (SigL_class(id', cd, rs, vis) :: sg) + rest + | SigL_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) + (SigL_class_type(id', ctd, rs, vis) :: sg) + rest + | SigL_value(id, vd, vis) :: rest -> + (* scope doesn't matter for value identifiers. *) + let id' = Ident.rename id in + rename_bound_idents s (SigL_value(id', vd, vis) :: sg) rest + | SigL_typext(id, ec, es, vis) :: rest -> + let id' = rename id in + rename_bound_idents s (SigL_typext(id',ec,es,vis) :: sg) rest + in + rename_bound_idents s [] sg + +let rec lazy_module_decl md = + { mdl_type = lazy_modtype md.md_type; + mdl_attributes = md.md_attributes; + mdl_loc = md.md_loc; + mdl_uid = md.md_uid } + +and subst_lazy_module_decl scoping s md = + let mdl_type = subst_lazy_modtype scoping s md.mdl_type in + { mdl_type; + mdl_attributes = attrs s md.mdl_attributes; + mdl_loc = loc s md.mdl_loc; + mdl_uid = md.mdl_uid } + +and force_module_decl md = + let md_type = force_modtype md.mdl_type in + { md_type; + md_attributes = md.mdl_attributes; + md_loc = md.mdl_loc; + md_uid = md.mdl_uid } + +and lazy_modtype = function + | Mty_ident p -> MtyL_ident p + | Mty_signature sg -> + MtyL_signature (Lazy_backtrack.create_forced (S_eager sg)) + | Mty_functor (Unit, mty) -> MtyL_functor (Unit, lazy_modtype mty) + | Mty_functor (Named (id, arg), res) -> + MtyL_functor (Named (id, lazy_modtype arg), lazy_modtype res) + | Mty_alias p -> MtyL_alias p + +and subst_lazy_modtype scoping s = function + | MtyL_ident p -> + begin match Path.Map.find p s.modtypes with + | mty -> lazy_modtype mty + | exception Not_found -> + begin match p with + | Pident _ -> MtyL_ident p + | Pdot(p, n) -> + MtyL_ident(Pdot(module_path s p, n)) + | Papply _ -> + fatal_error "Subst.modtype" + end + end + | MtyL_signature sg -> + MtyL_signature(subst_lazy_signature scoping s sg) + | MtyL_functor(Unit, res) -> + MtyL_functor(Unit, subst_lazy_modtype scoping s res) + | MtyL_functor(Named (None, arg), res) -> + MtyL_functor(Named (None, (subst_lazy_modtype scoping s) arg), + subst_lazy_modtype scoping s res) + | MtyL_functor(Named (Some id, arg), res) -> + let id' = Ident.rename id in + MtyL_functor(Named (Some id', (subst_lazy_modtype scoping s) arg), + subst_lazy_modtype scoping (add_module id (Pident id') s) res) + | MtyL_alias p -> + MtyL_alias (module_path s p) + +and force_modtype = function + | MtyL_ident p -> Mty_ident p + | MtyL_signature sg -> Mty_signature (force_signature sg) + | MtyL_functor (param, res) -> + let param : Types.functor_parameter = + match param with + | Unit -> Unit + | Named (id, mty) -> Named (id, force_modtype mty) in + Mty_functor (param, force_modtype res) + | MtyL_alias p -> Mty_alias p + +and lazy_modtype_decl mtd = + let mtdl_type = Option.map lazy_modtype mtd.mtd_type in + { mtdl_type; + mtdl_attributes = mtd.mtd_attributes; + mtdl_loc = mtd.mtd_loc; + mtdl_uid = mtd.mtd_uid } + +and subst_lazy_modtype_decl scoping s mtd = + { mtdl_type = Option.map (subst_lazy_modtype scoping s) mtd.mtdl_type; + mtdl_attributes = attrs s mtd.mtdl_attributes; + mtdl_loc = loc s mtd.mtdl_loc; + mtdl_uid = mtd.mtdl_uid } + +and force_modtype_decl mtd = + let mtd_type = Option.map force_modtype mtd.mtdl_type in + { mtd_type; + mtd_attributes = mtd.mtdl_attributes; + mtd_loc = mtd.mtdl_loc; + mtd_uid = mtd.mtdl_uid } + +and subst_lazy_signature scoping s sg = + match Lazy_backtrack.get_contents sg with + | Left (scoping', s', sg) -> + let scoping = + match scoping', scoping with + | sc, Keep -> sc + | _, (Make_local|Rescope _) -> scoping + in + let s = compose s' s in + Lazy_backtrack.create (scoping, s, sg) + | Right sg -> + Lazy_backtrack.create (scoping, s, sg) + +and force_signature sg = + List.map force_signature_item (force_signature_once sg) + +and force_signature_once sg = + lazy_signature' (Lazy_backtrack.force force_signature_once' sg) + +and lazy_signature' = function + | S_lazy sg -> sg + | S_eager sg -> List.map lazy_signature_item sg + +and force_signature_once' (scoping, s, sg) = + let sg = lazy_signature' sg in + (* 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 -> + S_lazy (List.rev_map (subst_lazy_signature_item' copy_scope scoping s') sg') + ) + +and lazy_signature_item = function + | Sig_value(id, d, vis) -> + SigL_value(id, d, vis) + | Sig_type(id, d, rs, vis) -> + SigL_type(id, d, rs, vis) + | Sig_typext(id, ext, es, vis) -> + SigL_typext(id, ext, es, vis) + | Sig_module(id, res, d, rs, vis) -> + SigL_module(id, res, lazy_module_decl d, rs, vis) + | Sig_modtype(id, d, vis) -> + SigL_modtype(id, lazy_modtype_decl d, vis) + | Sig_class(id, d, rs, vis) -> + SigL_class(id, d, rs, vis) + | Sig_class_type(id, d, rs, vis) -> + SigL_class_type(id, d, rs, vis) + +and subst_lazy_signature_item' copy_scope scoping s comp = + match comp with + SigL_value(id, d, vis) -> + SigL_value(id, value_description' copy_scope s d, vis) + | SigL_type(id, d, rs, vis) -> + SigL_type(id, type_declaration' copy_scope s d, rs, vis) + | SigL_typext(id, ext, es, vis) -> + SigL_typext(id, extension_constructor' copy_scope s ext, es, vis) + | SigL_module(id, pres, d, rs, vis) -> + SigL_module(id, pres, subst_lazy_module_decl scoping s d, rs, vis) + | SigL_modtype(id, d, vis) -> + SigL_modtype(id, subst_lazy_modtype_decl scoping s d, vis) + | SigL_class(id, d, rs, vis) -> + SigL_class(id, class_declaration' copy_scope s d, rs, vis) + | SigL_class_type(id, d, rs, vis) -> + SigL_class_type(id, cltype_declaration' copy_scope s d, rs, vis) + +and force_signature_item = function + | SigL_value(id, vd, vis) -> Sig_value(id, vd, vis) + | SigL_type(id, d, rs, vis) -> Sig_type(id, d, rs, vis) + | SigL_typext(id, ext, es, vis) -> Sig_typext(id, ext, es, vis) + | SigL_module(id, pres, d, rs, vis) -> + Sig_module(id, pres, force_module_decl d, rs, vis) + | SigL_modtype(id, d, vis) -> + Sig_modtype (id, force_modtype_decl d, vis) + | SigL_class(id, d, rs, vis) -> Sig_class(id, d, rs, vis) + | SigL_class_type(id, d, rs, vis) -> Sig_class_type(id, d, rs, vis) + +and modtype scoping s t = + t |> lazy_modtype |> subst_lazy_modtype scoping s |> force_modtype + +(* Composition of substitutions: + apply (compose s1 s2) x = apply s2 (apply s1 x) *) + +and compose s1 s2 = + if s1 == identity then s2 else + if s2 == identity then s1 else + { 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; + } + + +let subst_lazy_signature_item scoping s comp = + For_copy.with_scope + (fun copy_scope -> subst_lazy_signature_item' copy_scope scoping s comp) + +module Lazy = struct + include Lazy_types + + let of_module_decl = lazy_module_decl + let of_modtype = lazy_modtype + let of_modtype_decl = lazy_modtype_decl + let of_signature sg = Lazy_backtrack.create_forced (S_eager sg) + let of_signature_items sg = Lazy_backtrack.create_forced (S_lazy sg) + let of_signature_item = lazy_signature_item + + let module_decl = subst_lazy_module_decl + let modtype = subst_lazy_modtype + let modtype_decl = subst_lazy_modtype_decl + let signature = subst_lazy_signature + let signature_item = subst_lazy_signature_item + + let force_module_decl = force_module_decl + let force_modtype = force_modtype + let force_modtype_decl = force_modtype_decl + let force_signature = force_signature + let force_signature_once = force_signature_once + let force_signature_item = force_signature_item +end + +let signature sc s sg = + Lazy.(sg |> of_signature |> signature sc s |> force_signature) + +let signature_item sc s comp = + Lazy.(comp|> of_signature_item |> signature_item sc s |> force_signature_item) + +let modtype_declaration sc s decl = + Lazy.(decl |> of_modtype_decl |> modtype_decl sc s |> force_modtype_decl) + +let module_declaration scoping s decl = + Lazy.(decl |> of_module_decl |> module_decl scoping s |> force_module_decl) diff --git a/upstream/ocaml_500/typing/subst.mli b/upstream/ocaml_500/typing/subst.mli new file mode 100644 index 0000000000..b55d2cc6f2 --- /dev/null +++ b/upstream/ocaml_500/typing/subst.mli @@ -0,0 +1,152 @@ +(**************************************************************************) +(* *) +(* 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 + + +module Lazy : sig + type module_decl = + { + mdl_type: modtype; + mdl_attributes: Parsetree.attributes; + mdl_loc: Location.t; + mdl_uid: Uid.t; + } + + and modtype = + | MtyL_ident of Path.t + | MtyL_signature of signature + | MtyL_functor of functor_parameter * modtype + | MtyL_alias of Path.t + + and modtype_declaration = + { + mtdl_type: modtype option; (* Note: abstract *) + mtdl_attributes: Parsetree.attributes; + mtdl_loc: Location.t; + mtdl_uid: Uid.t; + } + + and signature + + and signature_item = + SigL_value of Ident.t * value_description * visibility + | SigL_type of Ident.t * type_declaration * rec_status * visibility + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility + | SigL_module of + Ident.t * module_presence * module_decl * rec_status * visibility + | SigL_modtype of Ident.t * modtype_declaration * visibility + | SigL_class of Ident.t * class_declaration * rec_status * visibility + | SigL_class_type of Ident.t * class_type_declaration * + rec_status * visibility + + and functor_parameter = + | Unit + | Named of Ident.t option * modtype + + + val of_module_decl : Types.module_declaration -> module_decl + val of_modtype : Types.module_type -> modtype + val of_modtype_decl : Types.modtype_declaration -> modtype_declaration + val of_signature : Types.signature -> signature + val of_signature_items : signature_item list -> signature + val of_signature_item : Types.signature_item -> signature_item + + val module_decl : scoping -> t -> module_decl -> module_decl + val modtype : scoping -> t -> modtype -> modtype + val modtype_decl : scoping -> t -> modtype_declaration -> modtype_declaration + val signature : scoping -> t -> signature -> signature + val signature_item : scoping -> t -> signature_item -> signature_item + + val force_module_decl : module_decl -> Types.module_declaration + val force_modtype : modtype -> Types.module_type + val force_modtype_decl : modtype_declaration -> Types.modtype_declaration + val force_signature : signature -> Types.signature + val force_signature_once : signature -> signature_item list + val force_signature_item : signature_item -> Types.signature_item +end diff --git a/upstream/ocaml_500/typing/tast_iterator.ml b/upstream/ocaml_500/typing/tast_iterator.ml new file mode 100644 index 0000000000..a700c0d91b --- /dev/null +++ b/upstream/ocaml_500/typing/tast_iterator.ml @@ -0,0 +1,515 @@ +(**************************************************************************) +(* *) +(* 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, _) -> + sub.expr sub exp + | 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_500/typing/tast_iterator.mli b/upstream/ocaml_500/typing/tast_iterator.mli new file mode 100644 index 0000000000..e126128edf --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/tast_mapper.ml b/upstream/ocaml_500/typing/tast_mapper.ml new file mode 100644 index 0000000000..87079db4fc --- /dev/null +++ b/upstream/ocaml_500/typing/tast_mapper.ml @@ -0,0 +1,748 @@ +(**************************************************************************) +(* *) +(* 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(v, ctl, cto) -> + Text_decl(v, 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, mut) -> label, Kept (t, mut) + | 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) -> + Texp_send + ( + sub.expr sub exp, + meth + ) + | 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_500/typing/tast_mapper.mli b/upstream/ocaml_500/typing/tast_mapper.mli new file mode 100644 index 0000000000..ea6543d04f --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/type_immediacy.ml b/upstream/ocaml_500/typing/type_immediacy.ml new file mode 100644 index 0000000000..557ed4271a --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/type_immediacy.mli b/upstream/ocaml_500/typing/type_immediacy.mli new file mode 100644 index 0000000000..3fc2e3b4f9 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/typeclass.ml b/upstream/ocaml_500/typing/typeclass.ml new file mode 100644 index 0000000000..048ee998b0 --- /dev/null +++ b/upstream/ocaml_500/typing/typeclass.ml @@ -0,0 +1,2136 @@ +(**************************************************************************) +(* *) +(* 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 kind = + | Object + | Class + | Class_type + +type final = + | Final + | Not_final + +let kind_of_final = function + | Final -> Object + | Not_final -> Class + +type error = + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string + | 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_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of Errortrace.unification_error + | 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) * (type_expr * bool * string * type_expr) + | 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_error + | Self_clash of Errortrace.unification_error + | Mutability_mismatch of string * mutable_flag + | No_overriding of string * string + | Duplicate of string * string + | Closing_self_type of class_signature + +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 = [] } + +(* + 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 *) + (************************************) + +let extract_constraints cty = + let sign = Btype.signature_of_class_type cty in + (Btype.instance_vars sign, + Btype.methods sign, + Btype.concrete_methods sign) + +(* Record a class type *) +let rc node = + Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); + node + +let update_class_signature loc env ~warn_implicit_public virt kind sign = + let implicit_public, implicit_declared = + Ctype.update_class_signature env sign + in + if implicit_declared <> [] then begin + match virt with + | Virtual -> () (* Should perhaps emit warning 17 here *) + | Concrete -> + raise (Error(loc, env, Undeclared_methods(kind, implicit_declared))) + end; + if warn_implicit_public && implicit_public <> [] then begin + Location.prerr_warning + loc (Warnings.Implicit_public_methods implicit_public) + end + +let complete_class_signature loc env virt kind sign = + update_class_signature loc env ~warn_implicit_public:false virt kind sign; + Ctype.hide_private_methods env sign + +let complete_class_type loc env virt kind typ = + let sign = Btype.signature_of_class_type typ in + complete_class_signature loc env virt kind sign + +let check_virtual loc env virt kind sign = + match virt with + | Virtual -> () + | Concrete -> + match Btype.virtual_methods sign, Btype.virtual_instance_vars sign with + | [], [] -> () + | meths, vars -> + raise(Error(loc, env, Virtual_class(kind, meths, vars))) + +(* 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, commu_ok)) + + (***********************************) + (* Primitives for typing classes *) + (***********************************) + +let raise_add_method_failure loc env label sign failure = + match (failure : Ctype.add_method_failure) with + | Ctype.Unexpected_method -> + raise(Error(loc, env, Unexpected_field (sign.Types.csig_self, label))) + | Ctype.Type_mismatch trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +let raise_add_instance_variable_failure loc env label failure = + match (failure : Ctype.add_instance_variable_failure) with + | Ctype.Mutability_mismatch mut -> + raise (Error(loc, env, Mutability_mismatch(label, mut))) + | Ctype.Type_mismatch trace -> + raise (Error(loc, env, + Field_type_mismatch("instance variable", label, trace))) + +let raise_inherit_class_signature_failure loc env sign = function + | Ctype.Self_type_mismatch trace -> + raise(Error(loc, env, Self_clash trace)) + | Ctype.Method(label, failure) -> + raise_add_method_failure loc env label sign failure + | Ctype.Instance_variable(label, failure) -> + raise_add_instance_variable_failure loc env label failure + +let add_method loc env label priv virt ty sign = + match Ctype.add_method env label priv virt ty sign with + | () -> () + | exception Ctype.Add_method_failed failure -> + raise_add_method_failure loc env label sign failure + +let add_instance_variable ~strict loc env label mut virt ty sign = + match Ctype.add_instance_variable ~strict env label mut virt ty sign with + | () -> () + | exception Ctype.Add_instance_variable_failed failure -> + raise_add_instance_variable_failure loc env label failure + +let inherit_class_signature ~strict loc env sign1 sign2 = + match Ctype.inherit_class_signature ~strict env sign1 sign2 with + | () -> () + | exception Ctype.Inherit_class_signature_failed failure -> + raise_inherit_class_signature_failure loc env sign1 failure + +let inherit_class_type ~strict loc env sign1 cty2 = + let sign2 = + match Btype.scrape_class_type cty2 with + | Cty_signature sign2 -> sign2 + | _ -> + raise(Error(loc, env, Structure_expected cty2)) + in + inherit_class_signature ~strict loc env sign1 sign2 + +let unify_delayed_method_type loc env label ty expected_ty= + match Ctype.unify env ty expected_ty with + | () -> () + | exception Ctype.Unify trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +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 err -> + raise(Error(loc, val_env, Unconsistent_constraint err)); + 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 delayed_meth_specs = ref [] + +let rec class_type_field env sign self_scope ctf = + let loc = ctf.pctf_loc in + let mkctf desc = + { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } + in + let mkctf_with_attrs f = + Builtin_attributes.warning_scope ctf.pctf_attributes + (fun () -> mkctf (f ())) + in + match ctf.pctf_desc with + | Pctf_inherit sparent -> + mkctf_with_attrs + (fun () -> + let parent = class_type env Virtual self_scope sparent in + complete_class_type parent.cltyp_loc + env Virtual Class_type parent.cltyp_type; + inherit_class_type ~strict:false loc env sign parent.cltyp_type; + Tctf_inherit parent) + | Pctf_val ({txt=lab}, mut, virt, sty) -> + mkctf_with_attrs + (fun () -> + let cty = transl_simple_type env false sty in + let ty = cty.ctyp_type in + add_instance_variable ~strict:false loc env lab mut virt ty sign; + Tctf_val (lab, mut, virt, cty)) + + | Pctf_method ({txt=lab}, priv, virt, sty) -> + mkctf_with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + match sty.ptyp_desc, priv with + | Ptyp_poly ([],sty'), Public -> + let expected_ty = Ctype.newvar () in + add_method loc env lab priv virt expected_ty sign; + let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) env loc in + delayed_meth_specs := + Warnings.mk_lazy (fun () -> + let cty = transl_simple_type_univars env sty' in + let ty = cty.ctyp_type in + unify_delayed_method_type loc env lab ty expected_ty; + returned_cty.ctyp_desc <- Ttyp_poly ([], cty); + returned_cty.ctyp_type <- ty; + ) :: !delayed_meth_specs; + Tctf_method (lab, priv, virt, returned_cty) + | _ -> + let cty = transl_simple_type env false sty in + let ty = cty.ctyp_type in + add_method loc env lab priv virt ty sign; + Tctf_method (lab, priv, virt, cty)) + + | Pctf_constraint (sty, sty') -> + mkctf_with_attrs + (fun () -> + let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in + Tctf_constraint (cty, cty')) + + | Pctf_attribute x -> + Builtin_attributes.warning_attribute x; + mkctf (Tctf_attribute x) + + | Pctf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_signature virt env pcsig self_scope loc = + let {pcsig_self=sty; pcsig_fields=psign} = pcsig in + let sign = Ctype.new_class_signature () in + (* Introduce a dummy method preventing self type from being closed. *) + Ctype.add_dummy_method env ~scope:self_scope sign; + + let self_cty = transl_simple_type env false sty in + let self_type = self_cty.ctyp_type in + begin try + Ctype.unify env self_type sign.csig_self + with Ctype.Unify _ -> + raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type)) + end; + + (* Class type fields *) + let fields = + Builtin_attributes.warning_scope [] + (fun () -> List.map (class_type_field env sign self_scope) psign) + in + check_virtual loc env virt Class_type sign; + { csig_self = self_cty; + csig_fields = fields; + csig_type = sign; } + +and class_type env virt self_scope scty = + Builtin_attributes.warning_scope scty.pcty_attributes + (fun () -> class_type_aux env virt self_scope scty) + +and class_type_aux env virt self_scope 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 + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method env ~scope:self_scope + (Btype.signature_of_class_type clty); + 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 err -> + raise(Error(sty.ptyp_loc, env, Parameter_mismatch err)) + 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 virt env pcsig self_scope scty.pcty_loc 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 virt self_scope 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 virt self_scope 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 virt self_scope scty = + delayed_meth_specs := []; + let cty = class_type env virt self_scope scty in + List.iter Lazy.force (List.rev !delayed_meth_specs); + delayed_meth_specs := []; + cty + +(*******************************) + +let enter_ancestor_val name val_env = + Env.enter_unbound_value name Val_unbound_ancestor val_env + +let enter_self_val name val_env = + Env.enter_unbound_value name Val_unbound_self val_env + +let enter_instance_var_val name val_env = + Env.enter_unbound_value name Val_unbound_instance_variable val_env + +let enter_ancestor_met ~loc name ~sign ~meths ~cl_num ~ty ~attrs met_env = + let check s = Warnings.Unused_ancestor s in + let kind = Val_anc (sign, meths, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.enter_value ~check name desc met_env + +let add_self_met loc id sign self_var_kind vars cl_num + as_var ty attrs met_env = + let check = + if as_var then (fun s -> Warnings.Unused_var s) + else (fun s -> Warnings.Unused_var_strict s) + in + let kind = Val_self (sign, self_var_kind, vars, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.add_value ~check id desc met_env + +let add_instance_var_met loc label id sign cl_num attrs met_env = + let mut, ty = + match Vars.find label sign.csig_vars with + | (mut, _, ty) -> mut, ty + | exception Not_found -> assert false + in + let kind = Val_ivar (mut, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.add_value id desc met_env + +let add_instance_vars_met loc vars sign cl_num met_env = + List.fold_left + (fun met_env (label, id) -> + add_instance_var_met loc label id sign cl_num [] met_env) + met_env vars + +type intermediate_class_field = + | Inherit of + { override : override_flag; + parent : class_expr; + super : string option; + inherited_vars : (string * Ident.t) list; + super_meths : (string * Ident.t) list; + loc : Location.t; + attributes : attribute list; } + | Virtual_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + cty : core_type; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Concrete_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + override : override_flag; + definition : expression; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Virtual_method of + { label : string loc; + priv : private_flag; + cty : core_type; + loc : Location.t; + attributes : attribute list; } + | Concrete_method of + { label : string loc; + priv : private_flag; + override : override_flag; + sdefinition : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Constraint of + { cty1 : core_type; + cty2 : core_type; + loc : Location.t; + attributes : attribute list; } + | Initializer of + { sexpr : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Attribute of + { attribute : attribute; + loc : Location.t; + attributes : attribute list; } + +type first_pass_accummulater = + { rev_fields : intermediate_class_field list; + val_env : Env.t; + par_env : Env.t; + concrete_meths : MethSet.t; + concrete_vals : VarSet.t; + local_meths : MethSet.t; + local_vals : VarSet.t; + vars : Ident.t Vars.t; + meths : Ident.t Meths.t; } + +let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = + let { rev_fields; val_env; par_env; concrete_meths; concrete_vals; + local_meths; local_vals; vars; meths } = acc + in + let loc = cf.pcf_loc in + let attributes = cf.pcf_attributes in + let with_attrs f = Builtin_attributes.warning_scope attributes f in + match cf.pcf_desc with + | Pcf_inherit (override, sparent, super) -> + with_attrs + (fun () -> + let parent = + class_expr cl_num val_env par_env + Virtual self_scope sparent + in + complete_class_type parent.cl_loc + par_env Virtual Class parent.cl_type; + inherit_class_type ~strict:true loc val_env sign parent.cl_type; + let parent_sign = Btype.signature_of_class_type parent.cl_type in + let new_concrete_meths = Btype.concrete_methods parent_sign in + let new_concrete_vals = Btype.concrete_instance_vars parent_sign in + let over_meths = MethSet.inter new_concrete_meths concrete_meths in + let over_vals = VarSet.inter new_concrete_vals concrete_vals in + begin match override with + | Fresh -> + let cname = + match parent.cl_type with + | Cty_constr (p, _, _) -> Path.name p + | _ -> "inherited" + in + if not (MethSet.is_empty over_meths) then + Location.prerr_warning loc + (Warnings.Method_override + (cname :: MethSet.elements over_meths)); + if not (VarSet.is_empty over_vals) then + Location.prerr_warning loc + (Warnings.Instance_variable_override + (cname :: VarSet.elements over_vals)); + | Override -> + if MethSet.is_empty over_meths && VarSet.is_empty over_vals then + raise (Error(loc, val_env, No_overriding ("",""))) + end; + let concrete_vals = VarSet.union new_concrete_vals concrete_vals in + let concrete_meths = + MethSet.union new_concrete_meths concrete_meths + in + let val_env, par_env, inherited_vars, vars = + Vars.fold + (fun label _ (val_env, par_env, inherited_vars, vars) -> + let val_env = enter_instance_var_val label val_env in + let par_env = enter_instance_var_val label par_env in + let id = Ident.create_local label in + let inherited_vars = (label, id) :: inherited_vars in + let vars = Vars.add label id vars in + (val_env, par_env, inherited_vars, vars)) + parent_sign.csig_vars (val_env, par_env, [], vars) + in + let meths = + Meths.fold + (fun label _ meths -> + if Meths.mem label meths then meths + else Meths.add label (Ident.create_local label) meths) + parent_sign.csig_meths meths + in + (* Methods available through super *) + let super_meths = + MethSet.fold + (fun label acc -> (label, Ident.create_local label) :: acc) + new_concrete_meths [] + in + (* Super *) + let (val_env, par_env, super) = + match super with + | None -> (val_env, par_env, None) + | Some {txt=name} -> + let val_env = enter_ancestor_val name val_env in + let par_env = enter_ancestor_val name par_env in + (val_env, par_env, Some name) + in + let field = + Inherit + { override; parent; super; inherited_vars; + super_meths; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; + concrete_meths; concrete_vals; vars; meths }) + | Pcf_val (label, mut, Cfk_virtual styp) -> + with_attrs + (fun () -> + 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; + add_instance_variable ~strict:true loc val_env + label.txt mut Virtual ty sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Virtual_val + { label; mut; id; cty; already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; vars }) + | Pcf_val (label, mut, Cfk_concrete (override, sdefinition)) -> + with_attrs + (fun () -> + if VarSet.mem label.txt local_vals then + raise(Error(loc, val_env, + Duplicate ("instance variable", label.txt))); + if VarSet.mem label.txt concrete_vals then begin + if override = Fresh then + Location.prerr_warning label.loc + (Warnings.Instance_variable_override[label.txt]) + end else begin + if override = Override then + raise(Error(loc, val_env, + No_overriding ("instance variable", label.txt))) + end; + if !Clflags.principal then Ctype.begin_def (); + let definition = type_exp val_env sdefinition in + if !Clflags.principal then begin + Ctype.end_def (); + Ctype.generalize_structure definition.exp_type + end; + add_instance_variable ~strict:true loc val_env + label.txt mut Concrete definition.exp_type sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Concrete_val + { label; mut; id; override; definition; + already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_vals = VarSet.add label.txt concrete_vals in + let local_vals = VarSet.add label.txt local_vals in + { acc with rev_fields; val_env; par_env; + concrete_vals; local_vals; vars }) + + | Pcf_method (label, priv, Cfk_virtual sty) -> + with_attrs + (fun () -> + 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 + add_method loc val_env label.txt priv Virtual ty sign; + let meths = + if Meths.mem label.txt meths then meths + else Meths.add label.txt (Ident.create_local label.txt) meths + in + let field = + Virtual_method { label; priv; cty; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; meths }) + + | Pcf_method (label, priv, Cfk_concrete (override, expr)) -> + with_attrs + (fun () -> + if MethSet.mem label.txt local_meths then + raise(Error(loc, val_env, Duplicate ("method", label.txt))); + if MethSet.mem label.txt concrete_meths then begin + if override = Fresh then begin + Location.prerr_warning loc + (Warnings.Method_override [label.txt]) + end + end else begin + if override = Override then begin + raise(Error(loc, val_env, No_overriding("method", label.txt))) + end + end; + let expr = + match expr.pexp_desc with + | Pexp_poly _ -> expr + | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None + in + let sbody, sty = + match expr.pexp_desc with + | Pexp_poly (sbody, sty) -> sbody, sty + | _ -> assert false + in + let ty = + match sty with + | None -> Ctype.newvar () + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty' = + Typetexp.transl_simple_type val_env false sty + in + cty'.ctyp_type + in + add_method loc val_env label.txt priv Concrete ty sign; + begin + try + match get_desc ty 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 + with Ctype.Unify err -> + raise(Error(loc, val_env, + Field_type_mismatch ("method", label.txt, err))) + end; + let meths = + if Meths.mem label.txt meths then meths + else Meths.add label.txt (Ident.create_local label.txt) meths + in + let sdefinition = make_method self_loc cl_num expr in + let warning_state = Warnings.backup () in + let field = + Concrete_method + { label; priv; override; sdefinition; + warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_meths = MethSet.add label.txt concrete_meths in + let local_meths = MethSet.add label.txt local_meths in + { acc with rev_fields; concrete_meths; local_meths; meths }) + + | Pcf_constraint (sty1, sty2) -> + with_attrs + (fun () -> + let (cty1, cty2) = type_constraint val_env sty1 sty2 loc in + let field = + Constraint { cty1; cty2; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_initializer sexpr -> + with_attrs + (fun () -> + let sexpr = make_method self_loc cl_num sexpr in + let warning_state = Warnings.backup () in + let field = + Initializer { sexpr; warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + | Pcf_attribute attribute -> + Builtin_attributes.warning_attribute attribute; + let field = Attribute { attribute; loc; attributes } in + let rev_fields = field :: rev_fields in + { acc with rev_fields } + | Pcf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env cfs = + let rev_fields = [] in + let concrete_meths = MethSet.empty in + let concrete_vals = VarSet.empty in + let local_meths = MethSet.empty in + let local_vals = VarSet.empty in + let vars = Vars.empty in + let meths = Meths.empty in + let init_acc = + { rev_fields; val_env; par_env; + concrete_meths; concrete_vals; + local_meths; local_vals; vars; meths } + in + let acc = + Builtin_attributes.warning_scope [] + (fun () -> + List.fold_left + (class_field_first_pass self_loc cl_num sign self_scope) + init_acc cfs) + in + List.rev acc.rev_fields, acc.vars, acc.meths + +and class_field_second_pass cl_num sign met_env field = + let mkcf desc loc attrs = + { cf_desc = desc; cf_loc = loc; cf_attributes = attrs } + in + match field with + | Inherit { override; parent; super; + inherited_vars; super_meths; loc; attributes } -> + let met_env = + add_instance_vars_met loc inherited_vars sign cl_num met_env + in + let met_env = + match super with + | None -> met_env + | Some name -> + let meths = + List.fold_left + (fun acc (label, id) -> Meths.add label id acc) + Meths.empty super_meths + in + let ty = Btype.self_type parent.cl_type in + let attrs = [] in + let _id, met_env = + enter_ancestor_met ~loc name ~sign ~meths + ~cl_num ~ty ~attrs met_env + in + met_env + in + let desc = + Tcf_inherit(override, parent, super, inherited_vars, super_meths) + in + met_env, mkcf desc loc attributes + | Virtual_val { label; mut; id; cty; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end + in + let kind = Tcfk_virtual cty in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Concrete_val { label; mut; id; override; + definition; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end + in + let kind = Tcfk_concrete(override, definition) in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Virtual_method { label; priv; cty; loc; attributes } -> + let kind = Tcfk_virtual cty in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes + | Concrete_method { label; priv; override; + sdefinition; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + let ty = Btype.method_type label.txt sign in + let self_type = sign.Types.csig_self in + let meth_type = + mk_expected + (Btype.newgenty (Tarrow(Nolabel, self_type, ty, commu_ok))) + in + Ctype.raise_nongen_level (); + let texp = type_expect met_env sdefinition meth_type in + Ctype.end_def (); + let kind = Tcfk_concrete (override, texp) in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes) + | Constraint { cty1; cty2; loc; attributes } -> + let desc = Tcf_constraint(cty1, cty2) in + met_env, mkcf desc loc attributes + | Initializer { sexpr; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + Ctype.raise_nongen_level (); + let unit_type = Ctype.instance Predef.type_unit in + let self_type = sign.Types.csig_self in + let meth_type = + mk_expected + (Ctype.newty (Tarrow (Nolabel, self_type, unit_type, commu_ok))) + in + let texp = type_expect met_env sexpr meth_type in + Ctype.end_def (); + let desc = Tcf_initializer texp in + met_env, mkcf desc loc attributes) + | Attribute { attribute; loc; attributes; } -> + let desc = Tcf_attribute attribute in + met_env, mkcf desc loc attributes + +and class_fields_second_pass cl_num sign met_env fields = + let _, rev_cfs = + List.fold_left + (fun (met_env, cfs) field -> + let met_env, cf = + class_field_second_pass cl_num sign met_env field + in + met_env, cf :: cfs) + (met_env, []) fields + in + List.rev rev_cfs + +(* 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 virt self_scope 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 sign = Ctype.new_class_signature () in + + (* Adding a dummy method to the signature prevents it from being closed / + escaping. That isn't needed for objects though. *) + begin match final with + | Not_final -> Ctype.add_dummy_method val_env ~scope:self_scope sign; + | Final -> () + end; + + (* Self binder *) + let (self_pat, self_pat_vars) = type_self_pattern val_env spat in + let val_env, par_env = + List.fold_right + (fun {pv_id; _} (val_env, par_env) -> + let name = Ident.name pv_id in + let val_env = enter_self_val name val_env in + let par_env = enter_self_val name par_env in + val_env, par_env) + self_pat_vars (val_env, par_env) + in + + (* Check that the binder has a correct type *) + begin try Ctype.unify val_env self_pat.pat_type sign.csig_self with + Ctype.Unify _ -> + raise(Error(spat.ppat_loc, val_env, + Pattern_type_clash self_pat.pat_type)) + end; + + (* Typing of class fields *) + let (fields, vars, meths) = + class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env str + in + let kind = kind_of_final final in + + (* Check for unexpected virtual methods *) + check_virtual loc val_env virt kind sign; + + (* Update the class signature *) + update_class_signature loc val_env + ~warn_implicit_public:false virt kind sign; + + (* Close the signature if it is final *) + begin match final with + | Not_final -> () + | Final -> + if not (Ctype.close_class_signature val_env sign) then + raise(Error(loc, val_env, Closing_self_type sign)); + end; + (* Typing of method bodies *) + Ctype.generalize_class_signature_spine val_env sign; + let self_var_kind = + match virt with + | Virtual -> Self_virtual(ref meths) + | Concrete -> Self_concrete meths + in + let met_env = + List.fold_right + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} met_env -> + add_self_met pv_loc pv_id sign self_var_kind vars + cl_num pv_as_var pv_type pv_attributes met_env) + self_pat_vars met_env + in + let fields = + class_fields_second_pass cl_num sign met_env fields + in + + (* Update the class signature and warn about public methods made private *) + update_class_signature loc val_env + ~warn_implicit_public:true virt kind sign; + + let meths = + match self_var_kind with + | Self_virtual meths_ref -> !meths_ref + | Self_concrete meths -> meths + in + { cstr_self = self_pat; + cstr_fields = fields; + cstr_type = sign; + cstr_meths = meths; } + +and class_expr cl_num val_env met_env virt self_scope scl = + Builtin_attributes.warning_scope scl.pcl_attributes + (fun () -> class_expr_aux cl_num val_env met_env virt self_scope scl) + +and class_expr_aux cl_num val_env met_env virt self_scope 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' = Btype.abbreviate_class_type path params clty in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type clty'); + 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 err -> + raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch err))) + 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 = + class_structure cl_num virt self_scope Not_final + 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 desc.cstr_type; + 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 virt self_scope 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 virt self_scope 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 virt self_scope scl' in + if !Clflags.principal then begin + Ctype.end_def (); + Ctype.generalize_class_type_structure 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 virt self_scope 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 virt self_scope scl' in + complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type; + Typetexp.widen context; + let context = Typetexp.narrow () in + let clty = class_type val_env virt self_scope scty in + complete_class_type clty.cltyp_loc val_env virt Class clty.cltyp_type; + Typetexp.widen context; + Ctype.end_def (); + + Ctype.limited_generalize_class_type + (Btype.self_type_row cl.cl_type) cl.cl_type; + Ctype.limited_generalize_class_type + (Btype.self_type_row 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 + let ty = snd (Ctype.instance_class [] clty.cltyp_type) in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type ty); + rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); + cl_loc = scl.pcl_loc; + cl_type = ty; + 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 virt self_scope 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, commu_ok)) + | 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, commu_ok)) + | _ -> 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 *) + if !Clflags.principal then Ctype.begin_def (); + let constr_type = approx cl.pci_expr in + if !Clflags.principal then begin + Ctype.end_def (); + Ctype.generalize_structure constr_type; + end; + let dummy_cty = Cty_signature (Ctype.new_class_signature ()) 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_virt cl.pci_expr in + Typecore.self_coercion := List.tl !Typecore.self_coercion; + res + with exn -> + Typecore.self_coercion := []; raise exn + in + let sign = Btype.signature_of_class_type typ in + + Ctype.end_def (); + + (* Generalize the row variable *) + List.iter (Ctype.limited_generalize sign.csig_self_row) params; + Ctype.limited_generalize_class_type sign.csig_self_row 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 row = Btype.self_type_row obj_type in + Ctype.unify env row (Ctype.newty Tnil); + 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; + let ty = Btype.self_type obj_type in + 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; + + Ctype.set_object_name obj_id params (Btype.self_type typ); + + (* Check the other temporary abbreviation (#-type) *) + begin + let (cl_params', cl_type) = Ctype.instance_class params typ in + let ty = Btype.self_type cl_type in + 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 err -> + raise(Error(cl.pci_loc, env, + Constructor_type_mismatch (cl.pci_name.txt, err))) + 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 = Btype.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 + + (* Misc. *) + let arity = Btype.class_type_arity typ in + let pub_meths = Btype.public_methods sign in + + (* Final definitions *) + let (params', typ') = Ctype.instance_class params typ in + let cltydef = + {clty_params = params'; clty_type = Btype.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 (Btype.self_type typ) + in + Ctype.set_object_name obj_id 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 err -> + raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, err))) + end; + + List.iter Ctype.generalize clty.cty_params; + Ctype.generalize_class_type 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 Ctype.nongen_class_declaration clty then + raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty))); + + begin match + Ctype.closed_class clty.cty_params + (Btype.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 err -> + raise(Typecore.Error(loc, env, Typecore.Not_subtype err)) + 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 virt sexpr = + incr class_num; + let self_scope = Ctype.get_current_level () in + let expr = + class_expr (Int.to_string !class_num) env env virt self_scope sexpr + in + complete_class_type expr.cl_loc env virt Class expr.cl_type; + (expr, expr.cl_type) + +let class_description env virt sexpr = + let self_scope = Ctype.get_current_level () in + let expr = class_type env virt self_scope sexpr in + complete_class_type expr.cltyp_loc env virt Class_type expr.cltyp_type; + (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 type_object env loc s = + incr class_num; + let desc = + class_structure (Int.to_string !class_num) + Concrete Btype.lowest_level Final env env loc s + in + complete_class_signature loc env Concrete Object desc.cstr_type; + let meths = Btype.public_methods desc.cstr_type in + (desc, 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 non_virtual_string_of_kind = function + | Object -> "object" + | Class -> "non-virtual class" + | Class_type -> "non-virtual class type" + +let report_error env ppf = function + | Repeated_parameter -> + fprintf ppf "A type parameter occurs several times" + | Unconsistent_constraint err -> + fprintf ppf "@[The class constraints are not consistent.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type"); + fprintf ppf "@]" + | Field_type_mismatch (k, m, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The %s %s@ has type" k m) + (function ppf -> + fprintf ppf "but is expected to have type") + | Unexpected_field (ty, lab) -> + Printtyp.prepare_for_printing [ty]; + fprintf ppf + "@[@[<2>This object is expected to have type :@ %a@]\ + @ This type does not have a method %s." + Printtyp.type_expr ty lab + | 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.prepare_for_printing [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 Type abbrev) + !Oprint.out_type (Printtyp.tree_of_typexp Type actual) + !Oprint.out_type (Printtyp.tree_of_typexp Type expected) + | Constructor_type_mismatch (c, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The expression \"new %s\" has type" c) + (function ppf -> + fprintf ppf "but is used with type") + | Virtual_class (kind, mets, vals) -> + let kind = non_virtual_string_of_kind kind in + let missings = + match mets, vals with + [], _ -> "variables" + | _, [] -> "methods" + | _ -> "methods and variables" + in + fprintf ppf + "@[This %s has virtual %s.@ \ + @[<2>The following %s are virtual : %a@]@]" + kind missings missings + (pp_print_list ~pp_sep:pp_print_space pp_print_string) (mets @ vals) + | Undeclared_methods(kind, mets) -> + let kind = non_virtual_string_of_kind kind in + fprintf ppf + "@[This %s has undeclared virtual methods.@ \ + @[<2>The following methods were not declared : %a@]@]" + kind (pp_print_list ~pp_sep:pp_print_space pp_print_string) mets + | 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 err -> + Printtyp.report_unification_error ppf env err + (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.prepare_for_printing [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 Type params) + !Oprint.out_type (Printtyp.tree_of_typexp Type cstrs) + | Class_match_failure error -> + Includeclass.report_error Type ppf error + | Unbound_val lab -> + fprintf ppf "Unbound instance variable %s" lab + | Unbound_type_var (printer, reason) -> + let print_reason ppf (ty0, real, lab, ty) = + let ty1 = + if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in + Printtyp.prepare_for_printing [ty; ty1]; + fprintf ppf + "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound" + lab + !Oprint.out_type (Printtyp.tree_of_typexp Type ty) + !Oprint.out_type (Printtyp.tree_of_typexp Type ty0) + in + fprintf ppf + "@[@[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, err) -> + 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 err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type") + ) + | Self_clash err -> + Printtyp.report_unification_error ppf env err + (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 sign -> + 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 sign.csig_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_500/typing/typeclass.mli b/upstream/ocaml_500/typing/typeclass.mli new file mode 100644 index 0000000000..bf89e44648 --- /dev/null +++ b/upstream/ocaml_500/typing/typeclass.mli @@ -0,0 +1,136 @@ +(**************************************************************************) +(* *) +(* 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 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 kind = + | Object + | Class + | Class_type + +type error = + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string + | 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_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of Errortrace.unification_error + | 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) * (type_expr * bool * string * type_expr) + | 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_error + | Self_clash of Errortrace.unification_error + | Mutability_mismatch of string * mutable_flag + | No_overriding of string * string + | Duplicate of string * string + | Closing_self_type of class_signature + +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_500/typing/typecore.ml b/upstream/ocaml_500/typing/typecore.ml new file mode 100644 index 0000000000..5b9a00ae37 --- /dev/null +++ b/upstream/ocaml_500/typing/typecore.ml @@ -0,0 +1,5931 @@ +(**************************************************************************) +(* *) +(* 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 wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +let wrong_kind_sort_of_constructor (lid : Longident.t) = + match lid with + | Lident "true" | Lident "false" | Ldot(_, "true") | Ldot(_, "false") -> + Boolean + | Lident "[]" | Lident "::" | Ldot(_, "[]") | Ldot(_, "::") -> List + | Lident "()" | Ldot(_, "()") -> Unit + | _ -> Constructor + +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_error + | Pattern_type_clash : + Errortrace.unification_error * _ pattern_desc option -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * 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 + | Not_an_object of type_expr * type_forcing_context option + | Undefined_method of type_expr * string * string list option + | Undefined_self_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.error + | Outside_class + | Value_multiply_overridden of string + | Coercion_failure of + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } + | Scoping_let_module of string * type_expr + | Not_a_polymorphic_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * Errortrace.unification_error + | 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_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + +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 * Shape.t) + +(* 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 * 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 get_desc (expand_head env ty) with + Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty + | _ -> assert false + +type record_extraction_result = + | Record_type of Path.t * Path.t * Types.label_declaration list + | Not_a_record_type + | Maybe_a_record_type + +let extract_concrete_record env ty = + match extract_concrete_typedecl env ty with + | Typedecl(p0, p, {type_kind=Type_record (fields, _)}) -> + Record_type (p0, p, fields) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_record_type + | May_have_typedecl -> Maybe_a_record_type + +type variant_extraction_result = + | Variant_type of Path.t * Path.t * Types.constructor_declaration list + | Not_a_variant_type + | Maybe_a_variant_type + +let extract_concrete_variant env ty = + match extract_concrete_typedecl env ty with + | Typedecl(p0, p, {type_kind=Type_variant (cstrs, _)}) -> + Variant_type (p0, p, cstrs) + | Typedecl(p0, p, {type_kind=Type_open}) -> + Variant_type (p0, p, []) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_variant_type + | May_have_typedecl -> Maybe_a_variant_type + +let extract_label_names env ty = + match extract_concrete_record env ty with + | Record_type (_, _,fields) -> List.map (fun l -> l.Types.ld_id) fields + | Not_a_record_type | Maybe_a_record_type -> assert false + +let is_principal ty = + not !Clflags.principal || get_level ty = generic_level + +(* 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 err -> + raise(Error(loc, env, Expr_type_clash(err, 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 err -> + raise(Error(loc, !env, Pattern_type_clash(err, 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(err, None)) -> + raise(Error(loc, env, Pattern_type_clash(err, 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 = cstr_type_path constr 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 get_desc (expand_head pat.pat_env pat.pat_type) with + Tvariant row -> r := row; row + | _ -> assert false + in + let f = get_row_field tag row in + begin match row_field_repr f with + | Rabsent -> () (* assert false *) + | Reither (true, [], _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present None) + | Reither (false, ty::tl, _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present (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) when not (has_fixed_explanation row) -> + link_row_field_ext ~inside:f (rf_either [] ~no_arg:c ~matched:false) + | _ -> () + 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 err -> + raise(Error(loc, env, Or_pattern_type_clash(x1, err))) + 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 ~refine (env : Env.t ref) p = + let as_ty = build_as_type_aux ~refine 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_pat_types ~refine p.pat_loc env (instance as_ty) (instance ty); + ty + ) as_ty p.pat_extra + +and build_as_type_aux ~refine (env : Env.t ref) p = + let build_as_type = build_as_type ~refine in + 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 ~refine 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 + let fields = [l, rf_present ty] in + newty (Tvariant (create_row ~fields ~more:(newvar()) + ~name:None ~fixed:None ~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 ~refine env {p with pat_type = ty} ty_res; + let refinable = + lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && + match get_desc lbl.lbl_arg with Tpoly _ -> false | _ -> true in + if refinable then begin + let arg = List.assoc lbl.lbl_pos ppl in + unify_pat ~refine 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_pat_types ~refine p.pat_loc env ty_arg ty_arg'; + unify_pat ~refine 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 ~refine env {p2 with pat_type = ty2} ty1; + ty1 + | Some row -> + let Row {fields; fixed; name} = row_repr row in + newty (Tvariant (create_row ~fields ~fixed ~name + ~closed:false ~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 get_desc ty 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 ~refine env pat = + begin_def (); + let ty_var = build_as_type ~refine 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 get_desc (expand_head !env ty2) with + 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 get_desc tv with + 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 + if constr.cstr_existentials <> [] then + lower_variables_only !env expansion_scope ty_res; + end_def (); + generalize_structure expected_ty; + generalize_structure ty_res; + List.iter generalize_structure ty_args; + if !Clflags.principal && refine = None then begin + (* Do not warn for couter examples *) + 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(err, _)) -> + raise(Error(label_lid.loc, !env, + Label_mismatch(label_lid.txt, err))) + 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 no_arg expected_ty = + let arg_type = if no_arg then [] else [newgenvar()] in + let fields = [tag, rf_either ~no_arg arg_type ~matched:true] in + let make_row more = + create_row ~fields ~closed:false ~more ~fixed:None ~name:None + in + let row = make_row (newgenvar ()) 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, make_row (newvar ()), 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 get_desc ty with + Tvariant row when static_row row -> row + | _ -> raise(Error(lid.loc, env, Not_a_polymorphic_variant_type lid.txt)) + in + let pats, fields = + List.fold_left + (fun (pats,fields) (l,f) -> + match row_field_repr f with + Rpresent None -> + let f = rf_either [] ~no_arg:true ~matched:true in + (l,None) :: pats, + (l, f) :: fields + | Rpresent (Some ty) -> + let f = rf_either [ty] ~no_arg:false ~matched:true in + (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; + pat_type=ty; pat_extra=[]; pat_attributes=[]}) + :: pats, + (l, f) :: fields + | _ -> pats, fields) + ([],[]) (row_fields row0) in + let fields = List.rev fields in + let name = Some (path, tyl) in + let make_row more = + create_row ~fields ~more ~closed:false ~fixed:None ~name in + let ty = newty (Tvariant (make_row (newvar()))) in + let gloc = {loc with Location.loc_ghost=true} in + let row' = ref (make_row (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_polymorphic_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 get_desc ty with + 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 get_desc ty 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 = + if Warnings.is_active (Ambiguous_name ([],[],false,"")) then begin + 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)) + end + + (* 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 = + if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin + 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)) + end + + (* 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 esc -> + (* We don't expand the type here because if we do, we might expand to the + type that escaped, leading to confusing error messages. *) + let trace = Errortrace.[Escape (map_escape trivial_expansion esc)] in + raise (Error(loc, + env, + Pattern_type_clash(Errortrace.unification_error ~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: 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 ~refine 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 = + match extract_concrete_variant !env expected_ty with + | Variant_type(p0, p, _) -> + Some (p0, p, is_principal expected_ty) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let error = Wrong_expected_kind(srt, Pattern, expected_ty) in + raise (Error (loc, !env, error)) + 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); + 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 = + match extract_concrete_record !env expected_ty with + | Record_type(p0, p, _) -> + let ty = generic_instance expected_ty in + Some (p0, p, is_principal expected_ty), ty + | Maybe_a_record_type -> None, newvar () + | Not_a_record_type -> + let error = Wrong_expected_kind(Record, Pattern, expected_ty) in + raise (Error (loc, !env, error)) + 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 env spat = + let open Ast_helper in + let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in + reset_pattern false; + let nv = newvar() in + let pat = + type_pat Value ~no_existentials:In_self_pattern (ref env) spat nv in + List.iter (fun f -> f()) (get_ref pattern_force); + let pv = !pattern_variables in + pattern_variables := []; + pat, pv + +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) -> Btype.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, commu_ok)) + | 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, commu_ok)) + | Pexp_function ({pc_rhs=e}::_) -> + newty (Tarrow(Nolabel, newvar (), type_approx env e, commu_ok)) + | 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 err -> + raise(Error(sexp.pexp_loc, env, Expr_type_clash (err, 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 err -> + raise(Error(sexp.pexp_loc, env, Expr_type_clash (err, 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 TypeSet.mem ty visited then + List.rev ls, false + else match get_desc ty with + Tarrow (l, _, ty_res, _) -> + list_labels_aux env (TypeSet.add 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 TypeSet.empty []) 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 get_desc pty 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.unification_error + ~trace:[Ctype.expanded_diff env + ~got:ty ~expected: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 + +(* [check_statement] implements the [non-unit-statement] check. + + This check is called in contexts where the value of the expression is known + to be discarded (eg. the lhs of a sequence). We check that [exp] has type + unit, or has an explicit type annotation; otherwise we raise the + [non-unit-statement] warning. *) + +let check_statement exp = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () + | Tvar _ -> () + | _ -> + 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 + + +(* [check_partial_application] implements the [ignored-partial-application] + warning (and if [statement] is [true], also [non-unit-statement]). + + If [exp] has a function type, we check that it is not syntactically the + result of a function application, as this is often a bug in certain contexts + (eg the rhs of a let-binding or in the argument of [ignore]). For example, + [ignore (List.map print_int)] written by mistake instad of [ignore (List.map + print_int li)]. + + The check can be disabled by explicitly annotating the expression with a type + constraint, eg [(e : _ -> _)]. + + If [statement] is [true] and the [ignored-partial-application] is {em not} + triggered, then the [non-unit-statement] check is performaed (see + [check_statement]). + + If the type of [exp] is not known at the time this function is called, the + check is retried again after typechecking. *) + +let check_partial_application ~statement exp = + let check_statement () = if statement then check_statement exp in + let doit () = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty 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 + | _ -> + check_statement () + in + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tvar _ -> + (* The type of [exp] is not known. Delay the check until after + typechecking in order to give a chance for the type to become known + through unification. *) + add_delayed_check doit + | _ -> + doit () + +(* Check that a type is generalizable at some level *) +let generalizable level ty = + let rec check ty = + if not_marked_node ty then + if get_level ty <= 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 = + if try_mark_node ty then + begin match get_desc ty with + Tvariant row -> + if not (is_fixed row) then + List.iter + (fun (_,f) -> + match row_field_repr f with Reither _ -> raise Exit | _ -> ()) + (row_fields row); + 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 in + if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent) + (row_fields row) + || 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 fields = [s, rf_either ty_arg ~no_arg:(arg=None) ~matched:true] in + let row' = + create_row ~fields + ~more:(newvar ()) ~closed:false ~fixed:None ~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(err, tfc, None)) -> + raise (Error(loc, env, Expr_type_clash(err, 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 get_desc typ with + | Tarrow (Nolabel,a,b,_) -> + begin match get_desc b with + | Tarrow(Nolabel,c,d,_) -> + let f, x, res = + match prim with + | Apply -> a, c, d + | Revapply -> c, a, d + in + begin match get_desc f with + | Tarrow(Nolabel,fl,fr,_) -> + is_Tvar fl && is_Tvar fr && is_Tvar x && is_Tvar res + && Types.eq_type fl x && Types.eq_type 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(err', None, exp')) + when not loc'.Location.loc_ghost -> + let err = Expr_type_clash(err', 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 get_desc ty_exp with + | Tconstr(path, _, _) when Path.same path fmt6_path -> + if !Clflags.principal && get_level ty_exp <> 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 TypeSet.mem ty seen then () else + match get_desc ty with + Tarrow (_l, ty_arg, ty_fun, _com) -> + (try unify_var env (newvar()) ty_arg + with Unify _ -> assert false); + lower_args (TypeSet.add 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 TypeSet.empty) 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 ~statement: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, get_desc (expand_head env ty_expected), + get_desc (expand_head env ty_expected0) + with + | Some sarg, Tvariant row, Tvariant row0 -> + begin match + row_field_repr (get_row_field l row), + row_field_repr (get_row_field l row0) + 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 Exit + end + | _ -> raise Exit + with Exit -> + let arg = Option.map (type_exp env) sarg in + let arg_type = Option.map (fun arg -> arg.exp_type) arg in + let row = + create_row + ~fields: [l, rf_present arg_type] + ~more: (newvar ()) + ~closed: false + ~fixed: None + ~name: None + in + rue { + exp_desc = Texp_variant(l, arg); + exp_loc = loc; exp_extra = []; + exp_type = newty (Tvariant row); + 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 expected_opath = + match extract_concrete_record env ty_expected with + | Record_type (p0, p, _) -> Some (p0, p, is_principal ty_expected) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = + Wrong_expected_kind(Record, Expression explanation, ty_expected) + in + raise (Error (loc, env, error)) + in + let opt_exp_opath = + match opt_exp with + | None -> None + | Some exp -> + match extract_concrete_record env exp.exp_type with + | Record_type (p0, p, _) -> Some (p0, p, is_principal exp.exp_type) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type exp.exp_type in + raise (Error (exp.exp_loc, env, error)) + in + match expected_opath, opt_exp_opath with + | None, None -> newvar (), None + | Some _, None -> ty_expected, expected_opath + | Some(_, _, true), Some _ -> ty_expected, expected_opath + | (None | Some (_, _, false)), Some (_, p', _) -> + 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, opt_exp_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, lbl.lbl_mut) + 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 (get_level tv) arg.exp_type in + unify_var env tv arg.exp_type; + begin match arg.exp_desc, !self_coercion, get_desc ty' 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 err -> + (* prerr_endline "coercion failed"; *) + raise (Error(loc, env, Not_subtype err)) + end; + | _ -> + let ty, b = enlarge_type env ty' in + force (); + begin try Ctype.unify env arg.exp_type ty with Unify err -> + let expanded = full_expand ~may_forget_scope:true env ty' in + raise(Error(sarg.pexp_loc, env, + Coercion_failure({ty = ty'; expanded}, err, 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 + end_def (); + generalize_structure ty; + generalize_structure ty'; + begin try + let force'' = subtype env (instance ty) (instance ty') in + force (); force' (); force'' () + with Subtype err -> + raise (Error(loc, env, Not_subtype err)) + end; + (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 (meth, typ) = + match obj.exp_desc with + | Texp_ident(_, _, {val_kind = Val_self(sign, meths, _, _)}) -> + let id, typ = + match meths with + | Self_concrete meths -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (Error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + id, typ + | Self_virtual meths_ref -> begin + match Meths.find met !meths_ref with + | id -> id, Btype.method_type met sign + | exception Not_found -> + let id = Ident.create_local met in + let ty = newvar () in + meths_ref := Meths.add met id !meths_ref; + add_method env met Private Virtual ty sign; + Location.prerr_warning loc + (Warnings.Undeclared_virtual_method met); + id, ty + end + in + Tmeth_val id, typ + | Texp_ident(_, _, {val_kind = Val_anc (sign, meths, cl_num)}) -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (Error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + let (self_path, _) = + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env + in + Tmeth_ancestor(id, self_path), typ + | _ -> + let ty = + match filter_method env met obj.exp_type with + | ty -> ty + | exception Filter_method_failed err -> + let error = + match err with + | Unification_error err -> + Expr_type_clash(err, explanation, None) + | Not_an_object ty -> + Not_an_object(ty, explanation) + | Not_a_method -> + let valid_methods = + match get_desc (expand_head env obj.exp_type) with + | Tobject (fields, _) -> + let (fields, _) = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if field_kind_repr meth_kind = Fpublic + then meth::li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None + in + Undefined_method(obj.exp_type, met, valid_methods) + in + raise (Error(e.pexp_loc, env, error)) + in + Tmeth_name met, ty + in + if !Clflags.principal then begin + end_def (); + generalize_structure typ; + end; + let typ = + match get_desc typ with + | Tpoly (ty, []) -> + instance ty + | Tpoly (ty, tl) -> + if !Clflags.principal && get_level typ <> generic_level then + Location.prerr_warning loc + (Warnings.Not_principal "this use of a polymorphic method"); + snd (instance_poly false tl ty) + | Tvar _ -> + let ty' = newvar () in + unify env (instance typ) (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_loc = loc; exp_extra = []; + exp_type = typ; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | 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 (sign, _, vars, _)}), + (path_self, _) -> + let type_override (lab, snewval) = + begin try + let id = Vars.find lab.txt vars in + let ty = Btype.instance_variable_type lab.txt sign in + (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, md_shape = !type_module env smodl in + Mtype.lower_nongen (get_level ty) 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 ~shape:md_shape 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, meths = !type_object env loc s in + rue { + exp_desc = Texp_object (desc, meths); + exp_loc = loc; exp_extra = []; + exp_type = desc.cstr_type.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 -> ty_expected, None + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = Typetexp.transl_simple_type env false sty in + 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 get_desc (expand_head env ty) 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 (get_id t) then () + else begin + Hashtbl.add seen (get_id t) (); + match get_desc t 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 get_desc (Ctype.expand_head env (instance ty_expected)) with + Tpackage (p, fl) -> + if !Clflags.principal && + get_level (Ctype.expand_head env ty_expected) + < Btype.generic_level + then + Location.prerr_warning loc + (Warnings.Not_principal "this module packing"); + (p, fl) + | 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, commu_ok)) 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, commu_ok)), commu_ok)) + in + begin try + unify env op_type ty_op + with Unify err -> + raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err))) + 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 get_desc desc.val_type with + | Tconstr(p, _, _) -> Path.is_constructor_typath p + | _ -> false + in + begin match is_recarg, recarg, get_desc desc.val_type 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 Filter_arrow_failed err -> + let err = match err with + | Unification_error unif_err -> + Expr_type_clash(unif_err, explanation, None) + | Label_mismatch { got; expected; expected_type} -> + Abstract_wrong_label { got; expected; expected_type; explanation } + | Not_a_function -> begin + match in_function with + | Some _ -> Too_many_arguments(ty_fun, explanation) + | None -> Not_a_function(ty_fun, explanation) + end + in + raise (Error(loc_fun, env, err)) + 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, commu_ok))); + 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 = + match extract_concrete_record env ty_exp with + | Record_type(p0, p, _) -> + Some(p0, p, is_principal ty_exp) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type ty_exp in + raise (Error (record.exp_loc, env, error)) + 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 err -> + raise (Error(lid.loc, env, Label_mismatch(lid.txt, err))) + 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 () = + let te = expand_head env ty_expected' in + match get_desc te with + Tarrow(Nolabel,_,ty_res0,_) -> + Some (no_labels ty_res0, get_level te) + | _ -> 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 get_desc (expand_head env ty_fun) 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 || get_level ty_fun' <> generic_level) + and ty_fun = instance ty_fun' in + let ty_arg, ty_res = + match get_desc (expand_head env ty_expected') with + 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 ~level:lv (Tarrow(l,ty,ty_fun,commu_ok))) + 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 get_desc ty_fun with + | Tvar _ -> + let t1 = newvar () and t2 = newvar () in + if get_level ty_fun >= get_level t1 && + 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,commu_var ()))); + (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 get_desc ty_res 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 = + let ty_fun' = expand_head env ty_fun in + match get_desc ty_fun', get_desc (expand_head env ty_fun0) with + | Tarrow (l, ty, ty_fun, com), Tarrow (_, ty0, ty_fun0, _) + when sargs <> [] && is_commu_ok com -> + let lv = get_level ty_fun' in + 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 Filter_arrow_failed _ -> 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 ~statement: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 = + match extract_concrete_variant env ty_expected with + | Variant_type(p0, p,_) -> + Some(p0, p, is_principal ty_expected) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let ctx = Expression explanation in + let error = Wrong_expected_kind(srt, ctx, ty_expected) in + raise (Error (loc, env, error)) + 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 && get_level ty > get_level tv 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 ~statement: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 = + if unpacks = [] then type_expect ?in_function env sbody expected_ty else + 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, md_shape = + !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 (get_level ty) 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 ~shape:md_shape + 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 get_desc pat.pat_type 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 get_desc pat.pat_type 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 = + ]} + 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 ~statement: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, commu_ok)) in + let ty_op = newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, commu_ok)) in + begin try + unify env op_type ty_op + with Unify err -> + raise(Error(sop.loc, env, Andop_type_clash(sop.txt, err))) + 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 err -> + raise(Error(loc, env, Bindings_type_clash(err))) + 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 tr -> + begin match get_desc Errortrace.(tr.expected.ty) with + Tconstr (typ, [], _) -> + report_literal_type_constraint typ const + | _ -> [] + end + | 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 err + ?type_expected_explanation txt1 txt2 = + Location.error_of_printer ~loc ?sub (fun ppf () -> + Printtyp.report_unification_error ppf env err + ?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, err) -> + report_unification_error ~loc env err + (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 (err, pat) -> + let diff = type_clash_of_trace err.trace in + let sub = report_pattern_type_clash_hints pat diff in + report_unification_error ~loc ~sub env err + (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, err) -> + report_unification_error ~loc env err + (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 (err, explanation, exp) -> + let diff = type_clash_of_trace err.trace in + let sub = report_expr_type_clash_hints exp diff in + report_unification_error ~loc ~sub env err + ~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 get_desc typ with + Tarrow _ -> + Location.errorf ~loc + "@[@[<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 "@[@[<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 + "@[@[<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 "@[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 + | Not_an_object (ty, explanation) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "This expression is not an object;@ \ + it has type %a" + Printtyp.type_expr ty; + report_type_expected_explanation_opt explanation ppf + ) () + | Undefined_method (ty, me, valid_methods) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.wrap_printing_env ~error:true env (fun () -> + fprintf ppf + "@[@[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_self_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 err -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.Subtype.report_error ppf env err "is not a subtype of" + ) () + | 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_exp, err, b) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.report_unification_error ppf env err + (function ppf -> + let ty_exp = Printtyp.prepare_expansion ty_exp in + fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \ + it has type" + (Printtyp.type_expansion Type) ty_exp) + (function ppf -> + fprintf ppf "but is here used with type"); + if b then + fprintf ppf ".@.@[%s@ %s@ %s@]" + "This simple coercion was not fully general." + "Hint: Consider using a fully explicit coercion" + "of the form: `(foo : ty1 :> ty2)'." + ) () + | Not_a_function (ty, explanation) -> + 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) + | Too_many_arguments (ty, explanation) -> + 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) + | Abstract_wrong_label {got; expected; expected_type; explanation} -> + let label ~long = function + | Nolabel -> "unlabeled" + | l -> (if long then "labeled " else "") ^ prefixed_label_name l + in + let second_long = match got, expected with + | Nolabel, _ | _, Nolabel -> true + | _ -> false + in + Location.errorf ~loc + "@[@[<2>This function should have type@ %a%t@]@,\ + @[but its first argument is %s@ instead of %s%s@]@]" + Printtyp.type_expr expected_type + (report_type_expected_explanation_opt explanation) + (label ~long:true got) + (if second_long then "being " else "") + (label ~long:second_long expected) + | 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_polymorphic_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, err) -> + report_unification_error ~loc env err + (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, err) -> + report_unification_error ~loc env err + (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, err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "The operator %s has type" name) + (function ppf -> + fprintf ppf "but it was expected to have type") + | Bindings_type_clash(err) -> + report_unification_error ~loc env err + (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." + | Wrong_expected_kind(sort, ctx, ty) -> + let ctx, explanation = + match ctx with + | Expression explanation -> "expression", explanation + | Pattern -> "pattern", None + in + let sort = + match sort with + | Constructor -> "constructor" + | Boolean -> "boolean literal" + | List -> "list literal" + | Unit -> "unit literal" + | Record -> "record" + in + Location.errorf ~loc + "This %s should not be a %s,@ \ + the expected type is@ %a%t" + ctx sort Printtyp.type_expr ty + (report_type_expected_explanation_opt explanation) + | Expr_not_a_record_type ty -> + Location.errorf ~loc + "This expression has type %a@ \ + which is not a record type." + Printtyp.type_expr ty + +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_500/typing/typecore.mli b/upstream/ocaml_500/typing/typecore.mli new file mode 100644 index 0000000000..2f56bb49f0 --- /dev/null +++ b/upstream/ocaml_500/typing/typecore.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. *) +(* *) +(**************************************************************************) + +(* 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; +} + +(* Variables in patterns *) +type pattern_variable = + { + pv_id: Ident.t; + pv_type: type_expr; + pv_loc: Location.t; + pv_as_var: bool; + pv_attributes: Typedtree.attributes; + } + +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 wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +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: + Env.t -> Parsetree.pattern -> + Typedtree.pattern * pattern_variable list +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_error + | Pattern_type_clash : + Errortrace.unification_error * _ Typedtree.pattern_desc option + -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * 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 + | Not_an_object of type_expr * type_forcing_context option + | Undefined_method of type_expr * string * string list option + | Undefined_self_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.error + | Outside_class + | Value_multiply_overridden of string + | Coercion_failure of + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } + | Scoping_let_module of string * type_expr + | Not_a_polymorphic_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * Errortrace.unification_error + | 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_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + +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 * Shape.t) 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 * 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_500/typing/typedecl.ml b/upstream/ocaml_500/typing/typedecl.ml new file mode 100644 index 0000000000..9d38ebe97e --- /dev/null +++ b/upstream/ocaml_500/typing/typedecl.ml @@ -0,0 +1,1915 @@ +(**************************************************************************) +(* *) +(* 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 * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error + | 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 * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error + | 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 err -> + raise (Error(loc, Type_clash (env, err))) + +(* Determine if a type's values are represented by floats at run-time. *) +let is_float env ty = + match Typedecl_unboxed.get_unboxed_type_representation env ty with + Some ty' -> + begin match get_desc ty' with + Tconstr(p, _, _) -> Path.same p Predef.path_float + | _ -> false + end + | _ -> 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 get_desc tm with + Tvariant row -> + let Row {fields; more; closed; name} = row_repr row in + set_type_desc tm + (Tvariant (create_row ~fields ~more ~closed ~name + ~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 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 + 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 univars 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 ?univars 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 get_desc ty 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 univars closed = function + | Pcstr_tuple l -> + let l = List.map (transl_simple_type env ?univars 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 univars closed l in + Types.Cstr_record lbls', + Cstr_record lbls + +let make_constructor env loc type_path type_params svars sargs sret_type = + match sret_type with + | None -> + let args, targs = + transl_constructor_arguments env None 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 univars, closed = + match svars with + | [] -> None, false + | vs -> + Ctype.begin_def(); + Some (make_poly_univars (List.map (fun v -> v.txt) vs)), true + in + let args, targs = + transl_constructor_arguments env univars closed sargs + in + let tret_type = transl_simple_type env ?univars closed sret_type in + let ret_type = tret_type.ctyp_type in + (* TODO add back type_path as a parameter ? *) + begin match get_desc ret_type with + | Tconstr (p', _, _) when Path.same type_path p' -> () + | _ -> + let trace = + (* Expansion is not helpful here -- the restriction on GADT return + types is purely syntactic. (In the worst case, expansion + produces gibberish.) *) + [Ctype.unexpanded_diff + ~got:ret_type + ~expected:(Ctype.newconstr type_path type_params)] + in + raise (Error(sret_type.ptyp_loc, + Constraint_failed(env, + Errortrace.unification_error ~trace))) + end; + begin match univars with + | None -> () + | Some univars -> + Ctype.end_def(); + Btype.iter_type_expr_cstr_args Ctype.generalize args; + Ctype.generalize ret_type; + let _vars = instance_poly_univars env loc univars in + let set_level t = Ctype.unify_var env (Ctype.newvar()) t in + Btype.iter_type_expr_cstr_args set_level args; + set_level ret_type; + 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 scstr.pcd_loc (Path.Pident id) params + scstr.pcd_vars scstr.pcd_args scstr.pcd_res + in + let tcstr = + { cd_id = name; + cd_name = scstr.pcd_name; + cd_vars = scstr.pcd_vars; + 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 None 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 err -> + raise(Error(loc, Inconsistent_constraint (env, err)))) + 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 = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty 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 + (* We don't expand the error trace because that produces types that + *already* violate the constraints -- we need to report a problem with + the unexpanded types, or we get errors that talk about the same type + twice. This is generally true for constraint errors. *) + try Ctype.matches ~expand_error_trace:false env ty ty' + with Ctype.Matches_failure (env, err) -> + raise (Error(loc, Constraint_failed (env, err))) + 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 get_desc ty 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 err -> + Some (Includecore.Constraint err) + | () -> + 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, env, err))) + with Not_found -> + raise(Error(loc, Unavailable_type_constructor path)) + end + | _ -> raise(Error(loc, Definition_mismatch (ty, env, 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 = + if TypeSet.mem ty parents then begin + (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) + if match get_desc ty0 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 get_desc ty 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 get_desc ty 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 TypeSet.empty in + + let rec check_regular cpath args prev_exp prev_expansions ty = + if not (TypeSet.mem ty !visited) then begin + visited := TypeSet.add ty !visited; + match get_desc ty 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 err -> + raise (Error(loc, Constraint_failed (orig_env, err))); + 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' = newty2 ~level:(get_level ty) (get_desc ty) in + if Ctype.deep_occur ty ty' then + let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in + link_type ty (newty2 ~level:(get_level ty) 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(svars, sargs, sret_type) -> + let targs, tret_type, args, ret_type = + make_constructor env sext.pext_loc type_path typext_params + svars sargs sret_type + in + args, ret_type, Text_decl(svars, 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 err -> + raise (Error(lid.loc, + Rebind_wrong_type(lid.txt, env, err))) + 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 + (fun ty -> + if get_desc ty = Tvar (Some "_") + && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + typext_params + end; + (* Ensure that constructor's type matches the type being extended *) + let cstr_type_path = Btype.cstr_type_path cdescr in + let cstr_type_params = (Env.find_type cstr_type_path env).type_params 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 List.map get_desc args with + | [ 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, env, 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, get_desc (Ctype.expand_head_opt env ty) 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, get_desc ty, + 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_poly (_, t), _, _ -> + parse_native_repr_attributes env t ty ~global_repr + | 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.expand_head_opt env ty in + try match get_desc ty 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 err -> + raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, err))) + ) 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 err -> + raise(Error(loc, Inconsistent_constraint (env, err))) + ) 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.prepare_for_printing [typ ti; ty0]; + fprintf ppf + ".@ @[In %s@ %a@;<1 -2>the variable %a is unbound@]" + kwd pr ti Printtyp.prepared_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.prepared_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 get_desc ty with + Tobject(fi,_) -> + let (tl, rv) = Ctype.flatten_fields fi in + if eq_type rv tv then trivial ty else + explain_unbound ppf tv tl (fun (_,_,t) -> t) + "method" (fun (lab,_,_) -> lab ^ ": ") + | Tvariant row -> + if eq_type (row_more row) tv then trivial ty else + explain_unbound ppf tv (row_fields row) + (fun (_l,f) -> match 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 "@[The definition of %s contains a cycle:@ %a@]" + s Printtyp.type_expr ty + | Definition_mismatch (ty, _env, None) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" + "This variant or record definition" "does not match that of type" + Printtyp.type_expr ty + | Definition_mismatch (ty, env, Some err) -> + fprintf ppf "@[@[%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" env) + err + | Constraint_failed (env, err) -> + fprintf ppf "@[Constraints are not satisfied in this type.@ "; + Printtyp.report_unification_error ppf env err + (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.prepare_for_printing [used_as; defined_as]; + Printtyp.Naming_context.reset (); + begin match expansions with + | [] -> + fprintf ppf + "@[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 Type defined_as) + !Oprint.out_type (Printtyp.tree_of_typexp Type used_as) + | _ :: _ -> + fprintf ppf + "@[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 Type defined_as) + !Oprint.out_type (Printtyp.tree_of_typexp Type used_as) + pp_expansions expansions + end + | Inconsistent_constraint (env, err) -> + fprintf ppf "@[The type constraints are not consistent.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type"); + fprintf ppf "@]" + | Type_clash (env, err) -> + Printtyp.report_unification_error ppf env err + (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 "@[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"; + 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, env, err) -> + fprintf ppf "@[@[%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" env) + err + | Rebind_wrong_type (lid, env, err) -> + Printtyp.report_unification_error ppf env err + (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 + (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 (Misc.ordinal_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 + "@[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.@]@,\ + @[@[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_500/typing/typedecl.mli b/upstream/ocaml_500/typing/typedecl.mli new file mode 100644 index 0000000000..0fb68edf42 --- /dev/null +++ b/upstream/ocaml_500/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 + +(* 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 + +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 * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error + | 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 * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error + | 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_500/typing/typedecl_immediacy.ml b/upstream/ocaml_500/typing/typedecl_immediacy.ml new file mode 100644 index 0000000000..4a57f37cf9 --- /dev/null +++ b/upstream/ocaml_500/typing/typedecl_immediacy.ml @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* 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 + | None -> Type_immediacy.Unknown + | Some argrepr -> Ctype.immediacy env argrepr + 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_500/typing/typedecl_immediacy.mli b/upstream/ocaml_500/typing/typedecl_immediacy.mli new file mode 100644 index 0000000000..17fb985c80 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/typedecl_properties.ml b/upstream/ocaml_500/typing/typedecl_properties.ml new file mode 100644 index 0000000000..28a1bb6673 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/typedecl_properties.mli b/upstream/ocaml_500/typing/typedecl_properties.mli new file mode 100644 index 0000000000..153c3f719c --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/typedecl_separability.ml b/upstream/ocaml_500/typing/typedecl_separability.ml new file mode 100644 index 0000000000..c6ded4cf6a --- /dev/null +++ b/upstream/ocaml_500/typing/typedecl_separability.ml @@ -0,0 +1,668 @@ +(**************************************************************************) +(* *) +(* 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 get_desc ret_type with + | Tconstr (_, tyl, _) -> 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 get_desc ty 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 get_desc ty 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 (row_fields desc) in + let add_row acc = + let row = row_more desc in + match get_desc row with + | Tvariant more -> immediate_subtypes_variant_row acc more + | _ -> row :: acc + in + add_row (add_subtypes acc) + +and immediate_subtypes_variant_row_field acc f = + match row_field_repr f with + | Rpresent(None) + | Rabsent -> acc + | Rpresent(Some(ty)) -> ty :: acc + | Reither(_,field_types,_) -> + List.rev_append field_types acc + +let free_variables ty = + Ctype.free_variables ty + |> List.map (fun ty -> + match get_desc ty with + Tvar text -> {text; id = get_id ty} + | _ -> + (* 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 = + 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 (get_desc ty, 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 = get_id ty} 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 = ) + for each type parameter 'a of the type constructor. For each + such equation, we should "strengthen" the current context in + the following way: + - if is another variable 'b, + the mode of 'a is set to the mode of 'b, + and 'b is set to Ind + - if 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 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 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 get_desc param_instance with + | Tvar text -> + let var = {text; id = get_id param_instance} 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_500/typing/typedecl_separability.mli b/upstream/ocaml_500/typing/typedecl_separability.mli new file mode 100644 index 0000000000..079e640807 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/typedecl_unboxed.ml b/upstream/ocaml_500/typing/typedecl_unboxed.ml new file mode 100644 index 0000000000..16290f0fbb --- /dev/null +++ b/upstream/ocaml_500/typing/typedecl_unboxed.ml @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* 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 + +(* 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 None else + let ty = Ctype.expand_head_opt env ty in + match get_desc ty with + | Tconstr (p, args, _) -> + begin match Env.find_type p env with + | exception Not_found -> Some ty + | {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 get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in + get_unboxed_type_representation env + (Ctype.apply env type_params ty2 args) (fuel - 1) + | _ -> Some ty + end + | _ -> Some 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_500/typing/typedecl_unboxed.mli b/upstream/ocaml_500/typing/typedecl_unboxed.mli new file mode 100644 index 0000000000..9e860dc128 --- /dev/null +++ b/upstream/ocaml_500/typing/typedecl_unboxed.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* 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 + +(* for typeopt.ml *) +val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option diff --git a/upstream/ocaml_500/typing/typedecl_variance.ml b/upstream/ocaml_500/typing/typedecl_variance.ml new file mode 100644 index 0000000000..05b0c2eba6 --- /dev/null +++ b/upstream/ocaml_500/typing/typedecl_variance.ml @@ -0,0 +1,418 @@ +(**************************************************************************) +(* *) +(* 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 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 get_desc ty 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 -> + List.iter + (fun (_,f) -> + match 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_fields row); + compute_same (row_more row) + | 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 = 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 = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + if mem Inj (get_variance ty tvl) then () else + match get_desc ty 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 eq_type 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.exists (eq_type 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 = + 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.exists (eq_type 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 get_desc ty with + | Tvar _ -> List.exists (List.exists (eq_type ty)) 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 get_desc ret_type with + | Tconstr (_, tyl, _) -> + (* let tyl = List.map (Ctype.expand_head env) 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_500/typing/typedecl_variance.mli b/upstream/ocaml_500/typing/typedecl_variance.mli new file mode 100644 index 0000000000..941ab99299 --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/typedtree.ml b/upstream/ocaml_500/typing/typedtree.ml new file mode 100644 index 0000000000..9e2257c0f7 --- /dev/null +++ b/upstream/ocaml_500/typing/typedtree.ml @@ -0,0 +1,847 @@ +(**************************************************************************) +(* *) +(* 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 + | 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 * (Ident.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 + | Tmeth_ancestor of Ident.t * Path.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 * mutable_flag + | 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 * MethSet.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_vars: string loc list; + 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 string loc list * 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; + shape: Shape.t; +} + + +(* 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_500/typing/typedtree.mli b/upstream/ocaml_500/typing/typedtree.mli new file mode 100644 index 0000000000..440a28cace --- /dev/null +++ b/upstream/ocaml_500/typing/typedtree.mli @@ -0,0 +1,826 @@ +(**************************************************************************) +(* *) +(* 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 + | 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 * (Ident.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 + | Tmeth_ancestor of Ident.t * Path.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 * mutable_flag + | 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.MethSet.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_vars: string loc list; + 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 string loc list * 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; + shape: Shape.t; +} +(** 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_500/typing/typemod.ml b/upstream/ocaml_500/typing/typemod.ml new file mode 100644 index 0000000000..dab2a3552c --- /dev/null +++ b/upstream/ocaml_500/typing/typemod.ml @@ -0,0 +1,3343 @@ +(**************************************************************************) +(* *) +(* 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 Sig_component_kind = Shape.Sig_component_kind +module String = Misc.Stdlib.String + +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_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 ~initially_opened_module + ~open_implicit_modules = + let env = Env.initial 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 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 get_desc ty 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 get_desc hd 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 = + Env.lookup_modtype_path ~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_path ~use:false ~load:false + ~loc:lid'.loc lid'.txt env) + | Pwith_modsubst (_, lid') -> + ignore (Env.lookup_module_path ~use:false ~load: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 = + Env.lookup_modtype_path ~loc lid env + +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; + Env.register_uid tdesc.val_val.val_uid tdesc.val_loc; + 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; + if not (Btype.is_row_name (Ident.name td.typ_id)) then + Env.register_uid td.typ_type.type_uid td.typ_loc + ) 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; + Env.register_uid td.typ_type.type_uid td.typ_loc + ) 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; + Env.register_uid ext.ext_type.ext_uid ext.ext_loc + ) 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; + Env.register_uid + constructor.ext_type.ext_uid + constructor.ext_loc; + 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 + Env.register_uid md.md_uid md.md_loc; + 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; + Env.register_uid md.md_uid md.md_loc; + 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, uid) -> + Signature_names.check_module names md.md_loc id; + Env.register_uid uid md.md_loc + ) decls; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_recmodule (List.map (fun (md, _, _) -> md) 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, decl = transl_modtype_decl env pmtd in + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + Env.register_uid decl.mtd_uid mtd.mtd_loc; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_modtype mtd) env loc :: trem, + Sig_modtype (mtd.mtd_id, decl, Exported) :: rem, + final_env + | Psig_modtypesubst pmtd -> + let newenv, mtd, decl = 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; + Env.register_uid decl.mtd_uid mtd.mtd_loc; + 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; + Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc; + ) 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; + Env.register_uid + decl.clsty_ty_decl.clty_uid + decl.clsty_ty_decl.clty_loc; + ) 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, decl + +and transl_recmodule_modtypes env sdecls = + let make_env curr = + List.fold_left (fun env (id_shape, _, md, _) -> + Option.fold ~none:env ~some:(fun (id, shape) -> + Env.add_module_declaration ~check:true ~shape ~arg:true + id Mp_present md env + ) id_shape + ) env curr + in + let transition env_c curr = + List.map2 + (fun pmd (id_shape, 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_shape, id_loc, md, tmty)) + sdecls curr in + let map_mtys curr = + List.filter_map + (fun (id_shape, _, md, _) -> + Option.map (fun (id, _) -> (id, md)) id_shape) + 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_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let md = + { md_type = approx_modtype approx_env pmd.pmd_type; + md_loc = pmd.pmd_loc; + md_attributes = pmd.pmd_attributes; + md_uid } + in + let id_shape = + Option.map (fun id -> id, Shape.var md_uid id) id + in + (id_shape, 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_shape, id_loc, md, mty) -> + let tmd = + {md_id=Option.map fst id_shape; 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, Option.map snd id_shape + ) 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 + do not contain non-generalized type variable *) + +let rec nongen_modtype env = function + Mty_ident _ -> false + | Mty_alias _ -> false + | Mty_signature sg -> + let env = Env.add_signature sg env in + List.exists (nongen_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 + nongen_modtype env body + +and nongen_signature_item env = function + Sig_value(_id, desc, _) -> Ctype.nongen_schema env desc.val_type + | Sig_module(_id, _, md, _, _) -> nongen_modtype env md.md_type + | _ -> false + +let check_nongen_signature_item env sig_item = + match sig_item with + Sig_value(_id, vd, _) -> + if Ctype.nongen_schema env vd.val_type then + raise (Error (vd.val_loc, env, Non_generalizable vd.val_type)) + | Sig_module (_id, _, md, _, _) -> + if nongen_modtype env md.md_type then + raise(Error(md.md_loc, env, Non_generalizable_module md.md_type)) + | _ -> () + +let check_nongen_signature env sg = + List.iter (check_nongen_signature_item 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, shape, _uid) -> + let ids = + Option.map + (fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id + in + (ids, mty_actual, shape)) + 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, shape) -> + 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 ~shape 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, _shape) -> + 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, shape, 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, shape = + try + Includemod.modtypes_with_shape ~shape + ~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, shape, 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 } + +let wrap_constraint_with_shape env mark arg mty + shape explicit = + let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let coercion, shape = + try + Includemod.modtypes_with_shape ~shape ~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 }, shape + +(* 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; + shape: Shape.t +} + +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 shape = + Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path + in + let md = + if alias && aliasable then + (Env.add_required_global (Path.head path); md) + else begin + let mty = + if sttn then + Env.find_strengthened_module ~aliasable path env + else + (Env.find_module path env).md_type + in + match mty 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 + ~strengthen:sttn env p1 in + { md with + mod_desc = + Tmod_constraint (md, mty, Tmodtype_implicit, + Tcoerce_alias (env, path, Tcoerce_none)); + mod_type = mty } + | mty -> + { md with mod_type = mty } + end + in + md, shape + | Pmod_structure sstr -> + let (str, sg, names, shape, _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, shape else + wrap_constraint_with_shape env false md + (Mty_signature sg') shape Tmodtype_implicit + | Pmod_functor(arg_opt, sbody) -> + let t_arg, ty_arg, newenv, funct_shape_param, funct_body = + match arg_opt with + | Unit -> + Unit, Types.Unit, env, Shape.for_unnamed_functor_param, false + | Named (param, smty) -> + let mty = transl_modtype_functor_arg env smty in + let scope = Ctype.create_scope () in + let (id, newenv, var) = + match param.txt with + | None -> None, env, Shape.for_unnamed_functor_param + | Some name -> + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let arg_md = + { md_type = mty.mty_type; + md_attributes = []; + md_loc = param.loc; + md_uid; + } + in + let id = Ident.create_scoped ~scope name in + let shape = Shape.var md_uid id in + let newenv = Env.add_module_declaration + ~shape ~arg:true ~check:true id Mp_present arg_md env + in + Some id, newenv, id + in + Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, + var, true + in + let body, body_shape = 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 }, + Shape.abs funct_shape_param body_shape + | Pmod_apply _ -> + type_application smod.pmod_loc sttn funct_body env smod + | Pmod_constraint(sarg, smty) -> + let arg, arg_shape = type_module ~alias true funct_body anchor env sarg in + let mty = transl_modtype env smty in + let md, final_shape = + wrap_constraint_with_shape env true arg mty.mty_type arg_shape + (Tmodtype_explicit mty) + in + { md with + mod_loc = smod.pmod_loc; + mod_attributes = smod.pmod_attributes; + }, + final_shape + | 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 get_desc (Ctype.expand_head env exp.exp_type) with + 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 + | 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 }, + Shape.leaf_for_unpack + | 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, shape = 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; + shape + } + in + extract_application funct_body env (summary::sargs) f + | _ -> smod, sargs + in + let sfunct, args = extract_application funct_body env [] smod in + let funct, funct_shape = + 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, funct_shape) args + +and type_one_application ~ctx:(apply_loc,md_f,args) + funct_body env (funct, funct_shape) 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 }, + Shape.app funct_shape ~arg:app_view.shape + | 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 }, + Shape.app ~arg:app_view.shape funct_shape + | 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, mod_shape = type_module true funct_body None env od.popen_expr in + let scope = Ctype.create_scope () in + let sg, newenv = + Env.enter_signature ~scope ~mod_shape + (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 shape_map {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), [], shape_map, 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. *) + let items, shape_map = + List.fold_left + (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ)-> + Signature_names.check_value names loc id; + let vd = Env.find_value (Pident id) newenv in + Env.register_uid vd.val_uid vd.val_loc; + Sig_value(id, vd, Exported) :: acc, + Shape.Map.add_value shape_map id vd.val_uid + ) + ([], shape_map) + (let_bound_idents_full defs) + in + Tstr_value(rec_flag, defs), + List.rev items, + shape_map, + 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; + Env.register_uid desc.val_val.val_uid desc.val_val.val_loc; + Tstr_primitive desc, + [Sig_value(desc.val_id, desc.val_val, Exported)], + Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid, + 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; + let items = map_rec_type_with_row_types ~rec_flag + (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported)) + decls [] + in + let shape_map = List.fold_left + (fun shape_map -> function + | Sig_type (id, vd, _, _) -> + if not (Btype.is_row_name (Ident.name id)) then begin + Env.register_uid vd.type_uid vd.type_loc; + Shape.Map.add_type shape_map id vd.type_uid + end else shape_map + | _ -> assert false + ) + shape_map + items + in + Tstr_type (rec_flag, decls), + items, + shape_map, + 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 + let shape_map = List.fold_left (fun shape_map ext -> + Signature_names.check_typext names ext.ext_loc ext.ext_id; + Env.register_uid ext.ext_type.ext_uid ext.ext_loc; + Shape.Map.add_extcons shape_map ext.ext_id ext.ext_type.ext_uid + ) shape_map constructors + in + (Tstr_typext tyext, + map_ext + (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported)) + constructors [], + shape_map, + 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; + Env.register_uid + constructor.ext_type.ext_uid + constructor.ext_loc; + Tstr_exception ext, + [Sig_typext(constructor.ext_id, + constructor.ext_type, + Text_exception, + Exported)], + Shape.Map.add_extcons shape_map + constructor.ext_id + constructor.ext_type.ext_uid, + 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, md_shape = + 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 + let md_shape = Shape.set_uid_if_none md_shape md_uid in + Env.register_uid md_uid pmb_loc; + (*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 ~shape:md_shape 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 + let shape_map = match id with + | Some id -> Shape.Map.add_module shape_map id md_shape + | None -> shape_map + in + Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; + mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; }, + sg, + shape_map, + 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, _prev_shape) + (name, _, smodl, attrs, loc) -> + let modl, shape = + 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, shape, uid)) + decls sbind in + let newenv = (* allow aliasing recursive modules from outside *) + List.fold_left + (fun env (id_opt, _, mty, _, _, attrs, loc, shape, uid) -> + match id_opt with + | None -> env + | Some id -> + let mdecl = + { + md_type = mty.mty_type; + md_attributes = attrs; + md_loc = loc; + md_uid = uid; + } + in + Env.add_module_declaration ~check:true ~shape + id Mp_present mdecl env + ) + env bindings1 + in + let bindings2 = + check_recmodule_inclusion newenv bindings1 in + let mbs = + List.filter_map (fun (mb, shape, uid) -> + Option.map (fun id -> id, mb, uid, shape) mb.mb_id + ) bindings2 + in + let shape_map = + List.fold_left (fun map (id, mb, uid, shape) -> + Env.register_uid uid mb.mb_loc; + Shape.Map.add_module map id shape + ) shape_map mbs + in + Tstr_recmodule (List.map (fun (mb, _, _) -> mb) bindings2), + map_rec (fun rs (id, mb, uid, _shape) -> + 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 [], + shape_map, + newenv + | Pstr_modtype pmtd -> + (* check that it is non-abstract *) + let newenv, mtd, decl = transl_modtype_decl env pmtd in + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + Env.register_uid decl.mtd_uid decl.mtd_loc; + let id = mtd.mtd_id in + let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in + Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv + | Pstr_open sod -> + let (od, sg, newenv) = + type_open_decl ~toplevel funct_body names env sod + in + Tstr_open od, sg, shape_map, newenv + | Pstr_class cl -> + let (classes, new_env) = Typeclass.class_declarations env cl in + let shape_map = List.fold_left (fun acc 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; + Env.register_uid cls.cls_decl.cty_uid loc; + let map f id acc = f acc id cls.cls_decl.cty_uid in + map Shape.Map.add_class cls.cls_id acc + |> map Shape.Map.add_class_type cls.cls_ty_id + |> map Shape.Map.add_type cls.cls_obj_id + |> map Shape.Map.add_type cls.cls_typesharp_id + ) shape_map classes + in + 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 []), + shape_map, + new_env + | Pstr_class_type cl -> + let (classes, new_env) = Typeclass.class_type_declarations env cl in + let shape_map = List.fold_left (fun acc 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; + Env.register_uid decl.clsty_ty_decl.clty_uid loc; + let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in + map Shape.Map.add_class_type decl.clsty_ty_id acc + |> map Shape.Map.add_type decl.clsty_obj_id + |> map Shape.Map.add_type decl.clsty_typesharp_id + ) shape_map classes + in + 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 []), + shape_map, + new_env + | Pstr_include sincl -> + let smodl = sincl.pincl_mod in + let modl, modl_shape = + 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, shape, new_env = + Env.enter_signature_and_shape ~scope ~parent_shape:shape_map + modl_shape (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, shape, 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, [], shape_map, env + in + let rec type_struct env shape_map sstr = + match sstr with + | [] -> ([], [], shape_map, env) + | pstr :: srem -> + let previous_saved_types = Cmt_format.get_saved_types () in + let desc, sg, shape_map, new_env = type_str_item env shape_map 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, shape_map, final_env) = + type_struct new_env shape_map srem + in + (str :: str_rem, sg @ sig_rem, shape_map, final_env) + in + let previous_saved_types = Cmt_format.get_saved_types () in + let run () = + let (items, sg, shape_map, final_env) = + type_struct env Shape.Map.empty 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, Shape.str shape_map, final_env + in + if toplevel then run () + else Builtin_attributes.warning_scope [] run + +let type_toplevel_phrase env s = + Env.reset_required_globals (); + type_structure ~toplevel:true false None env s + +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 } + | _ -> + let me, _shape = type_module env smod in + me + 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 nongen_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, _mod_shape = 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, shape, finalenv) = + type_structure initial_env ast in + let shape = + Shape.set_uid_if_none shape + (Uid.of_compilation_unit_id (Ident.create_persistent modulename)) + in + let simple_sg = Signature_names.simplify finalenv names sg in + if !Clflags.print_types then begin + Typecore.force_delayed_checks (); + let shape = Shape.local_reduce shape in + 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; + shape; + signature = simple_sg + } (* result is ignored by Compile.implementation *) + end else begin + let sourceintf = + Filename.remove_extension sourcefile ^ !Config.interface_suffix in + if !Clflags.cmi_file <> None || Sys.file_exists sourceintf then begin + let intf_file = + match !Clflags.cmi_file with + | None -> + (try + Load_path.find_uncap (modulename ^ ".cmi") + with Not_found -> + raise(Error(Location.in_file sourcefile, Env.empty, + Interface_not_compiled sourceintf))) + | Some cmi_file -> cmi_file + in + let dclsig = Env.read_signature modulename intf_file in + let coercion, shape = + Includemod.compunit initial_env ~mark:Mark_positive + sourcefile sg intf_file dclsig shape + 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 shape = Shape.local_reduce shape in + let annots = Cmt_format.Implementation str in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + annots (Some sourcefile) initial_env None (Some shape); + gen_annot outputprefix sourcefile annots; + { structure = str; + coercion; + shape; + signature = dclsig + } + end else begin + Location.prerr_warning (Location.in_file sourcefile) + Warnings.Missing_mli; + let coercion, shape = + Includemod.compunit initial_env ~mark:Mark_positive + sourcefile sg "(inferred signature)" simple_sg shape + in + check_nongen_signature finalenv simple_sg; + normalize_signature simple_sg; + Typecore.force_delayed_checks (); + (* See comment above. Here the target signature contains all + the values 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. *) + let shape = Shape.local_reduce shape in + 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) (Some shape); + gen_annot outputprefix sourcefile annots + end; + { structure = str; + coercion; + shape; + 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 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) None + +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 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 + (* Compute the shape of the package *) + let prefix = Filename.remove_extension cmifile in + let pack_uid = Uid.of_compilation_unit_id (Ident.create_persistent prefix) in + let shape = + List.fold_left (fun map (name, _sg) -> + let id = Ident.create_persistent name in + Shape.Map.add_module map id (Shape.for_persistent_unit name) + ) Shape.Map.empty units + |> Shape.str ~uid:pack_uid + in + (* See if explicit interface is provided *) + 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 + let cc, _shape = + Includemod.compunit initial_env ~mark:Mark_both + "(obtained by packing)" sg mlifile dclsig shape + in + Cmt_format.save_cmt (prefix ^ ".cmt") modulename + (Cmt_format.Packed (sg, objfiles)) None initial_env None (Some shape); + cc + 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) (Some shape); + 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 "@[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 + "@[\ + @[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 + "@[\ + @[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 + "@[\ + @[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 + "@[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_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 + "@[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 + "@[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_500/typing/typemod.mli b/upstream/ocaml_500/typing/typemod.mli new file mode 100644 index 0000000000..f0073a8c4c --- /dev/null +++ b/upstream/ocaml_500/typing/typemod.mli @@ -0,0 +1,140 @@ +(**************************************************************************) +(* *) +(* 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 * Shape.t +val type_structure: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Signature_names.t * Shape.t * + Env.t +val type_toplevel_phrase: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Signature_names.t * Shape.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_signature: + 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 -> + 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_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_500/typing/typeopt.ml b/upstream/ocaml_500/typing/typeopt.ml new file mode 100644 index 0000000000..0015252bc4 --- /dev/null +++ b/upstream/ocaml_500/typing/typeopt.ml @@ -0,0 +1,231 @@ +(**************************************************************************) +(* *) +(* 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 = + match get_desc ty with + | Tconstr _ -> + let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in + begin match get_desc ty with + | Tconstr (p, _, _) -> + begin match Env.find_type p env with + | {type_kind = ( Type_variant (_, Variant_unboxed) + | Type_record (_, Record_unboxed _) ); _} -> begin + match Typedecl_unboxed.get_unboxed_type_representation env ty with + | None -> ty + | Some ty2 -> ty2 + end + | _ -> ty + | exception Not_found -> ty + end + | _ -> + ty + end + | _ -> ty + +let scrape env ty = + get_desc (scrape_ty env ty) + +let scrape_poly env ty = + let ty = scrape_ty env ty in + match get_desc ty with + | Tpoly (ty, _) -> get_desc ty + | d -> d + +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 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 maybe_pointer_type env ty = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Immediate + else Pointer + +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 get_desc ty 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_poly env ty with + | 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, [], _) 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 = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Pintval + else begin + match get_desc ty with + | 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 + end + +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_500/typing/typeopt.mli b/upstream/ocaml_500/typing/typeopt.mli new file mode 100644 index 0000000000..0f6b9f373f --- /dev/null +++ b/upstream/ocaml_500/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_500/typing/types.ml b/upstream/ocaml_500/typing/types.ml new file mode 100644 index 0000000000..739c7f18af --- /dev/null +++ b/upstream/ocaml_500/typing/types.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. *) +(* *) +(**************************************************************************) + +(* Representation of types and declarations *) + +open Asttypes + +(* Type expressions for the core language *) + +type transient_expr = + { mutable desc: type_desc; + mutable level: int; + mutable scope: int; + id: int } + +and type_expr = transient_expr + +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_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 = [`some] row_field_gen +and _ row_field_gen = + RFpresent : type_expr option -> [> `some] row_field_gen + | RFeither : + { no_arg: bool; + arg_type: type_expr list; + matched: bool; + ext: [`some | `none] row_field_gen ref} -> [> `some] row_field_gen + | RFabsent : [> `some] row_field_gen + | RFnone : [> `none] row_field_gen + +and abbrev_memo = + Mnil + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo + | Mlink of abbrev_memo ref + +and any = [`some | `none | `var] +and field_kind = [`some|`var] field_kind_gen +and _ field_kind_gen = + FKvar : {mutable field_kind: any field_kind_gen} -> [> `var] field_kind_gen + | FKprivate : [> `none] field_kind_gen (* private method; only under FKvar *) + | FKpublic : [> `some] field_kind_gen (* public method *) + | FKabsent : [> `some] field_kind_gen (* hidden private method *) + +and commutable = [`some|`var] commutable_gen +and _ commutable_gen = + Cok : [> `some] commutable_gen + | Cunknown : [> `none] commutable_gen + | Cvar : {mutable commu: any commutable_gen} -> [> `var] commutable_gen + +module TransientTypeOps = 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 = Shape.Uid + +(* Maps of methods and instance variables *) + +module MethSet = Misc.Stdlib.String.Set +module VarSet = Misc.Stdlib.String.Set + +module Meths = Misc.Stdlib.String.Map +module Vars = Misc.Stdlib.String.Map + + +(* 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 + class_signature * self_meths * Ident.t Vars.t * string + (* Self *) + | Val_anc of class_signature * Ident.t Meths.t * string + (* Ancestor *) + +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + +(* 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 *) + +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 + +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_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) + +let item_visibility = function + | Sig_value (_, _, vis) + | Sig_type (_, _, _, vis) + | Sig_typext (_, _, _, vis) + | Sig_module (_, _, _, _, vis) + | Sig_modtype (_, _, vis) + | Sig_class (_, _, _, vis) + | Sig_class_type (_, _, _, vis) -> vis + +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 + +(**** 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 [`none|`some] row_field_gen ref + | Ckind of [`var] field_kind_gen + | Ccommu of [`var] commutable_gen + | Cuniv of type_expr option ref * type_expr option + +type changes = + Change of change * changes ref + | Unchanged + | Invalid + +let trail = Local_store.s_table ref Unchanged + +let log_change ch = + let r' = ref Unchanged in + !trail := Change (ch, r'); + trail := r' + +(* constructor and accessors for [field_kind] *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +let rec field_kind_internal_repr : field_kind -> field_kind = function + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as fk} -> + field_kind_internal_repr fk + | kind -> kind + +let field_kind_repr fk = + match field_kind_internal_repr fk with + | FKvar _ -> Fprivate + | FKpublic -> Fpublic + | FKabsent -> Fabsent + +let field_public = FKpublic +let field_absent = FKabsent +let field_private () = FKvar {field_kind=FKprivate} + +(* Constructor and accessors for [commutable] *) + +let rec is_commu_ok : type a. a commutable_gen -> bool = function + | Cvar {commu} -> is_commu_ok commu + | Cunknown -> false + | Cok -> true + +let commu_ok = Cok +let commu_var () = Cvar {commu=Cunknown} + +(**** Representative of a type ****) + +let rec repr_link (t : type_expr) d : type_expr -> type_expr = + function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> + log_change (Ccompress (t, t.desc, d)); + t.desc <- d; + t' + +let repr_link1 t = function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> t' + +let repr t = + match t.desc with + Tlink t' -> + repr_link1 t t' + | Tfield (_, k, _, t') when field_kind_internal_repr k = FKabsent -> + repr_link1 t t' + | _ -> t + +(* getters for type_expr *) + +let get_desc t = (repr t).desc +let get_level t = (repr t).level +let get_scope t = (repr t).scope +let get_id t = (repr t).id + +(* transient type_expr *) + +module Transient_expr = struct + let create desc ~level ~scope ~id = {desc; level; scope; id} + let set_desc ty d = ty.desc <- d + let set_stub_desc ty d = assert (ty.desc = Tvar None); ty.desc <- d + let set_level ty lv = ty.level <- lv + let set_scope ty sc = ty.scope <- sc + let coerce ty = ty + let repr = repr + let type_expr ty = ty +end + +(* Comparison for [type_expr]; cannot be used for functors *) + +let eq_type t1 t2 = t1 == t2 || repr t1 == repr t2 +let compare_type t1 t2 = compare (get_id t1) (get_id t2) + +(* Constructor and accessors for [row_desc] *) + +let create_row ~fields ~more ~closed ~fixed ~name = + { row_fields=fields; row_more=more; + row_closed=closed; row_fixed=fixed; row_name=name } + +(* [row_fields] subsumes the original [row_repr] *) +let rec row_fields row = + match get_desc row.row_more with + | Tvariant row' -> + row.row_fields @ row_fields row' + | _ -> + row.row_fields + +let rec row_repr_no_fields row = + match get_desc row.row_more with + | Tvariant row' -> row_repr_no_fields row' + | _ -> row + +let row_more row = (row_repr_no_fields row).row_more +let row_closed row = (row_repr_no_fields row).row_closed +let row_fixed row = (row_repr_no_fields row).row_fixed +let row_name row = (row_repr_no_fields row).row_name + +let rec get_row_field tag row = + let rec find = function + | (tag',f) :: fields -> + if tag = tag' then f else find fields + | [] -> + match get_desc row.row_more with + | Tvariant row' -> get_row_field tag row' + | _ -> RFabsent + in find row.row_fields + +let set_row_name row row_name = + let row_fields = row_fields row in + let row = row_repr_no_fields row in + {row with row_fields; row_name} + +type row_desc_repr = + Row of { fields: (label * row_field) list; + more:type_expr; + closed:bool; + fixed:fixed_explanation option; + name:(Path.t * type_expr list) option } + +let row_repr row = + let fields = row_fields row in + let row = row_repr_no_fields row in + Row { fields; + more = row.row_more; + closed = row.row_closed; + fixed = row.row_fixed; + name = row.row_name } + +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +let rec row_field_repr_aux tl : row_field -> row_field = function + | RFeither ({ext = {contents = RFnone}} as r) -> + RFeither {r with arg_type = tl@r.arg_type} + | RFeither {arg_type; + ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_repr_aux (tl@arg_type) rf + | RFpresent (Some _) when tl <> [] -> + RFpresent (Some (List.hd tl)) + | RFpresent _ as rf -> rf + | RFabsent -> RFabsent + +let row_field_repr fi = + match row_field_repr_aux [] fi with + | RFeither {no_arg; arg_type; matched} -> Reither (no_arg, arg_type, matched) + | RFpresent t -> Rpresent t + | RFabsent -> Rabsent + +let rec row_field_ext (fi : row_field) = + match fi with + | RFeither {ext = {contents = RFnone} as ext} -> ext + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_ext rf + | _ -> Misc.fatal_error "Types.row_field_ext " + +let rf_present oty = RFpresent oty +let rf_absent = RFabsent +let rf_either ?use_ext_of ~no_arg arg_type ~matched = + let ext = + match use_ext_of with + Some rf -> row_field_ext rf + | None -> ref RFnone + in + RFeither {no_arg; arg_type; matched; ext} + +let rf_either_of = function + | None -> + RFeither {no_arg=true; arg_type=[]; matched=false; ext=ref RFnone} + | Some ty -> + RFeither {no_arg=false; arg_type=[ty]; matched=false; ext=ref RFnone} + +let eq_row_field_ext rf1 rf2 = + row_field_ext rf1 == row_field_ext rf2 + +let changed_row_field_exts l f = + let exts = List.map row_field_ext l in + f (); + List.exists (fun r -> !r <> RFnone) exts + +let match_row_field ~present ~absent ~either (f : row_field) = + match f with + | RFabsent -> absent () + | RFpresent t -> present t + | RFeither {no_arg; arg_type; matched; ext} -> + let e : row_field option = + match !ext with + | RFnone -> None + | RFeither _ | RFpresent _ | RFabsent as e -> Some e + in + either no_arg arg_type matched e + + +(**** Some type creators ****) + +let new_id = Local_store.s_ref (-1) + +let create_expr = Transient_expr.create + +let newty3 ~level ~scope desc = + incr new_id; + create_expr desc ~level ~scope ~id:!new_id + +let newty2 ~level desc = + newty3 ~level ~scope:Ident.lowest_scope desc + + (**********************************) + (* Utilities for backtracking *) + (**********************************) + +let undo_change = function + Ctype (ty, desc) -> Transient_expr.set_desc ty desc + | Ccompress (ty, desc, _) -> Transient_expr.set_desc ty desc + | Clevel (ty, level) -> Transient_expr.set_level ty level + | Cscope (ty, scope) -> Transient_expr.set_scope ty scope + | Cname (r, v) -> r := v + | Crow r -> r := RFnone + | Ckind (FKvar r) -> r.field_kind <- FKprivate + | Ccommu (Cvar r) -> r.commu <- Cunknown + | Cuniv (r, v) -> r := v + +type snapshot = changes ref * int +let last_snapshot = Local_store.s_ref 0 + +let log_type ty = + if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) +let link_type ty ty' = + let ty = repr ty in + let ty' = repr ty' in + log_type ty; + let desc = ty.desc in + Transient_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'; Transient_expr.set_desc ty' (Tvar name) + | None, Some _ -> () + | Some _, Some _ -> + if ty.level < ty'.level then + (log_type ty'; Transient_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 = + let ty = repr ty in + if td != ty.desc then begin + log_type ty; + Transient_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 = + let ty = repr ty in + if level <> ty.level then begin + if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); + Transient_expr.set_level ty level + end +(* TODO: introduce a guard and rename it to set_higher_scope? *) +let set_scope ty scope = + let ty = repr ty in + if scope <> ty.scope then begin + if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); + Transient_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 rec link_row_field_ext ~(inside : row_field) (v : row_field) = + match inside with + | RFeither {ext = {contents = RFnone} as e} -> + let RFeither _ | RFpresent _ | RFabsent as v = v in + log_change (Crow e); e := v + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + link_row_field_ext ~inside:rf v + | _ -> invalid_arg "Types.link_row_field_ext" + +let rec link_kind ~(inside : field_kind) (k : field_kind) = + match inside with + | FKvar ({field_kind = FKprivate} as rk) as inside -> + (* prevent a loop by normalizing k and comparing it with inside *) + let FKvar _ | FKpublic | FKabsent as k = field_kind_internal_repr k in + if k != inside then begin + log_change (Ckind inside); + rk.field_kind <- k + end + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as inside} -> + link_kind ~inside k + | _ -> invalid_arg "Types.link_kind" + +let rec commu_repr : commutable -> commutable = function + | Cvar {commu = Cvar _ | Cok as commu} -> commu_repr commu + | c -> c + +let rec link_commu ~(inside : commutable) (c : commutable) = + match inside with + | Cvar ({commu = Cunknown} as rc) as inside -> + (* prevent a loop by normalizing c and comparing it with inside *) + let Cvar _ | Cok as c = commu_repr c in + if c != inside then begin + log_change (Ccommu inside); + rc.commu <- c + end + | Cvar {commu = Cvar _ | Cok as inside} -> + link_commu ~inside c + | _ -> invalid_arg "Types.link_commu" + +let set_commu_ok c = link_commu ~inside:c Cok + +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 ~cleanup_abbrev (changes, old) = + match !changes with + Unchanged -> last_snapshot := old + | Invalid -> failwith "Types.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 undo_first_change_after (changes, _) = + match !changes with + | Change (ch, _) -> + undo_change ch + | _ -> () + +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 -> + Transient_expr.set_desc ty desc; r := !next + | _ -> ()) + log diff --git a/upstream/ocaml_500/typing/types.mli b/upstream/ocaml_500/typing/types.mli new file mode 100644 index 0000000000..9254599787 --- /dev/null +++ b/upstream/ocaml_500/typing/types.mli @@ -0,0 +1,725 @@ +(**************************************************************************) +(* *) +(* 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 +type row_desc +type row_field +type field_kind +type commutable + +type 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", field_public, 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). *) + +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 *) + +(** [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 *) + +(** [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 [commu_ok] arrows, otherwise as + [commu_var ()]. + + 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 must rely on [is_commu_ok] arrows, + otherwise they 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. +*) + +val is_commu_ok: commutable -> bool +val commu_ok: commutable +val commu_var: unit -> commutable + +(** [field_kind] indicates the accessibility of a method. + + An [Fprivate] field may become [Fpublic] or [Fabsent] during unification, + but not the other way round. + + The same [field_kind] is kept shared when copying [Tfield] nodes + so that the copies of the self-type of a class share the same accessibility + (see also PR#10539). + *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +val field_kind_repr: field_kind -> field_kind_view +val field_public: field_kind +val field_absent: field_kind +val field_private: unit -> field_kind +val field_kind_internal_repr: field_kind -> field_kind + (* Removes indirections in [field_kind]. + Only needed for performance. *) + +(** Getters for type_expr; calls repr before answering a value *) + +val get_desc: type_expr -> type_desc +val get_level: type_expr -> int +val get_scope: type_expr -> int +val get_id: type_expr -> int + +(** Transient [type_expr]. + Should only be used immediately after [Transient_expr.repr] *) +type transient_expr = private + { mutable desc: type_desc; + mutable level: int; + mutable scope: int; + id: int } + +module Transient_expr : sig + (** Operations on [transient_expr] *) + + val create: type_desc -> level: int -> scope: int -> id: int -> transient_expr + val set_desc: transient_expr -> type_desc -> unit + val set_level: transient_expr -> int -> unit + val set_scope: transient_expr -> int -> unit + val repr: type_expr -> transient_expr + val type_expr: transient_expr -> type_expr + val coerce: type_expr -> transient_expr + (** Coerce without normalizing with [repr] *) + + val set_stub_desc: type_expr -> type_desc -> unit + (** Instantiate a not yet instantiated stub. + Fail if already instantiated. *) +end + +val create_expr: type_desc -> level: int -> scope: int -> id: int -> type_expr + +(** Functions and definitions moved from Btype *) + +val newty3: level:int -> scope:int -> type_desc -> type_expr + (** Create a type with a fresh id *) + +val newty2: level:int -> type_desc -> type_expr + (** Create a type with a fresh id and no scope *) + +module TransientTypeOps : sig + (** Comparisons for functors *) + + type t = transient_expr + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +(** Comparisons for [type_expr]; cannot be used for functors *) + +val eq_type: type_expr -> type_expr -> bool +val compare_type: type_expr -> type_expr -> int + +(** Constructor and accessors for [row_desc] *) + +(** [ `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 = _; + _ }; + _ }; + _ + } + +*) + +val create_row: + fields:(label * row_field) list -> + more:type_expr -> + closed:bool -> + fixed:fixed_explanation option -> + name:(Path.t * type_expr list) option -> row_desc + +val row_fields: row_desc -> (label * row_field) list +val row_more: row_desc -> type_expr +val row_closed: row_desc -> bool +val row_fixed: row_desc -> fixed_explanation option +val row_name: row_desc -> (Path.t * type_expr list) option + +val set_row_name: row_desc -> (Path.t * type_expr list) option -> row_desc + +val get_row_field: label -> row_desc -> row_field + +(** get all fields at once; different from the old [row_repr] *) +type row_desc_repr = + Row of { fields: (label * row_field) list; + more: type_expr; + closed: bool; + fixed: fixed_explanation option; + name: (Path.t * type_expr list) option } + +val row_repr: row_desc -> row_desc_repr + +(** Current contents of a row field *) +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +val row_field_repr: row_field -> row_field_view +val rf_present: type_expr option -> row_field +val rf_absent: row_field +val rf_either: + ?use_ext_of:row_field -> + no_arg:bool -> type_expr list -> matched:bool -> row_field +val rf_either_of: type_expr option -> row_field + +val eq_row_field_ext: row_field -> row_field -> bool +val changed_row_field_exts: row_field list -> (unit -> unit) -> bool + +val match_row_field: + present:(type_expr option -> 'a) -> + absent:(unit -> 'a) -> + either:(bool -> type_expr list -> bool -> row_field option ->'a) -> + row_field -> 'a + +(* *) + +module Uid = Shape.Uid + +(* Sets and maps of methods and instance variables *) + +module MethSet : Set.S with type elt = string +module VarSet : Set.S with type elt = string + +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 class_signature * self_meths * Ident.t Vars.t * string + (* Self *) + | Val_anc of class_signature * Ident.t Meths.t * string + (* Ancestor *) + +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + (* The [field_kind] is always [Fabsent] in a complete class type. *) + +(* 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 *) + +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 + +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 + +val item_visibility : signature_item -> visibility + +(* 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_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 + +(**** Utilities for backtracking ****) + +type snapshot + (* A snapshot for backtracking *) +val snapshot: unit -> snapshot + (* Make a snapshot for later backtracking. Costs nothing *) +val backtrack: cleanup_abbrev:(unit -> unit) -> 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_first_change_after: snapshot -> unit + (* Backtrack only the first change after a snapshot. + Does not update the list of changes *) +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?). + The old values are logged and reverted on backtracking. + *) + +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 link_row_field_ext: inside:row_field -> row_field -> unit + (* Extract the extension variable of [inside] and set it to the + second argument *) +val set_univar: type_expr option ref -> type_expr -> unit +val link_kind: inside:field_kind -> field_kind -> unit +val link_commu: inside:commutable -> commutable -> unit +val set_commu_ok: commutable -> unit diff --git a/upstream/ocaml_500/typing/typetexp.ml b/upstream/ocaml_500/typing/typetexp.ml new file mode 100644 index 0000000000..b4a7a5981e --- /dev/null +++ b/upstream/ocaml_500/typing/typetexp.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. *) +(* *) +(**************************************************************************) + +(* 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_error + | Alias_type_mismatch of Errortrace.unification_error + | 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 poly_univars = (string * type_expr) list +let make_poly_univars vars = + List.map (fun name -> name, newvar ~name ()) vars + +let check_poly_univars env loc vars = + vars |> List.iter (fun (_, v) -> generalize v); + vars |> List.map (fun (name, ty1) -> + let v = Btype.proxy ty1 in + begin match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name) + | _ -> + raise (Error (loc, env, Cannot_quantify(name, v))) + end; + v) + +let instance_poly_univars env loc vars = + let vs = check_poly_univars env loc vars in + vs |> List.iter (fun v -> + match get_desc v with + | Tunivar name -> + set_type_desc v (Tvar name) + | _ -> assert false); + vs + + +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, commu_ok)) 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 get_level ty = 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 err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) + ) + (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 get_desc ty 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 err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) + ) + (List.combine stl args) params; + let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in + let ty = Ctype.expand_head env (newconstr path ty_args) in + let ty = match get_desc ty with + Tvariant row -> + let fields = + List.map + (fun (l,f) -> l, + match row_field_repr f with + | Rpresent oty -> rf_either_of oty + | _ -> f) + (row_fields row) + in + (* NB: row is always non-static here; more is thus never Tnil *) + let more = + if policy = Univars then new_pre_univar () else newvar () in + let row = + create_row ~fields ~more + ~closed:true ~fixed:None ~name:(Some (path, ty_args)) 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 err -> + let err = Errortrace.swap_unification_error err in + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) + 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 err -> + let err = Errortrace.swap_unification_error err in + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) + 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 get_desc px with + | Tvar None -> set_type_desc px (Tvar (Some alias)) + | Tunivar None -> 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 (create_row ~fields:[l,f] ~more:(newvar()) + ~closed:true ~fixed:None ~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 + rf_either ty_tl ~no_arg:c ~matched:false + | _ -> + if List.length stl > 1 || c && stl <> [] then + raise(Error(styp.ptyp_loc, env, + Present_has_conjunction l.txt)); + match tl with [] -> rf_present None + | st :: _ -> rf_present (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 get_desc cty.ctyp_type with + Tconstr(p, tl, _) -> Some(p, tl) + | _ -> None + in + name := if Hashtbl.length hfields <> 0 then None else nm; + let fl = match get_desc (expand_head env cty.ctyp_type), nm with + Tvariant row, _ when Btype.static_row row -> + row_fields row + | 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 row_field_repr f with + Rpresent oty -> rf_either_of oty + | _ -> 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 = List.rev (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 name = !name in + let make_row more = + create_row ~fields ~more ~closed:(closed = Closed) ~fixed:None ~name + in + let more = + if Btype.static_row (make_row (newvar ())) then newty Tnil else + if policy = Univars then new_pre_univar () else newvar () + in + let ty = newty (Tvariant (make_row more)) 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 = make_poly_univars 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 = check_poly_univars env styp.ptyp_loc new_univars in + let ty_list = List.filter (fun v -> deep_occur v ty) ty_list in + let ty' = Btype.newgenty (Tpoly(ty, 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_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_type env policy (Ast_helper.Typ.force_poly 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 get_desc cty.ctyp_type with + Tconstr(p, _, _) -> Some p + | _ -> None in + let t = expand_head env cty.ctyp_type in + match get_desc t, nm with + Tobject (tf, _), _ + when (match get_desc tf with Tfield _ | Tnil -> true | _ -> false) -> + begin + if opened_object t then + raise (Error (sty.ptyp_loc, env, Opened_object nm)); + let rec iter_add ty = + match get_desc ty with + | Tfield (s, _k, ty1, ty2) -> + add_typed_field sty.ptyp_loc s ty1; + iter_add ty2 + | Tnil -> () + | _ -> assert false + in + iter_add tf; + OTinherit cty + end + | 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, field_public, 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 = + if Btype.try_mark_node ty then + begin match get_desc ty with + | Tvariant row -> + let Row {fields; more; name; closed} = row_repr row in + if Btype.is_Tunivar more then + let fields = + List.map + (fun (s,f as p) -> match row_field_repr f with + Reither (no_arg, tl, _m) -> + s, rf_either tl ~use_ext_of:f ~no_arg ~matched:true + | _ -> p) + fields + in + set_type_desc ty + (Tvariant + (create_row ~fields ~more ~name ~closed + ~fixed:(Some (Univar more)))); + 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 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 err -> + raise (Error(loc, env, Type_mismatch err))) + !r + +let transl_simple_type env ?univars:(uvs=[]) fixed styp = + univars := uvs; 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 -> + match get_desc v with + Tvar name when get_level v = Btype.generic_level -> + 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(); + match styp.ptyp_desc with + | Ptyp_poly (vars, st) -> + begin_def(); + let vars = List.map (fun v -> v.txt) vars in + let univars = make_poly_univars vars in + let typ = transl_simple_type env ~univars true st in + end_def(); + generalize typ.ctyp_type; + let _ = instance_poly_univars env styp.ptyp_loc univars in + { ctyp_desc = Ttyp_poly (vars, typ); + ctyp_type = typ.ctyp_type; + ctyp_env = env; + ctyp_loc = styp.ptyp_loc; + ctyp_attributes = styp.ptyp_attributes } + | _ -> + 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 + "@[@[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.prepare_for_printing [ty; ty']; + fprintf ppf "@[%s %a@ %s@ %a@]" + "This variant type contains a constructor" + !Oprint.out_type (tree_of_typexp Type ty) + "which should be" + !Oprint.out_type (tree_of_typexp Type ty')) + | Not_a_variant ty -> + fprintf ppf + "@[The type %a@ does not expand to a polymorphic variant type@]" + Printtyp.type_expr ty; + begin match get_desc ty 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 + "@[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 "@[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_500/typing/typetexp.mli b/upstream/ocaml_500/typing/typetexp.mli new file mode 100644 index 0000000000..c264ab599a --- /dev/null +++ b/upstream/ocaml_500/typing/typetexp.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. *) +(* *) +(**************************************************************************) + +(* Typechecking of type expressions for the core language *) + +open Types + +val valid_tyvar_name : string -> bool + +type poly_univars +val make_poly_univars : string list -> poly_univars + (* Create a set of univars with given names *) +val check_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (* Verify that the given univars are universally quantified, + and return the list of variables. The type in which the + univars are used must be generalised *) +val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (* Same as [check_poly_univars], but instantiates the resulting + type scheme (i.e. variables become Tvar rather than Tunivar) *) + +val transl_simple_type: + Env.t -> ?univars:poly_univars -> 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_error + | Alias_type_mismatch of Errortrace.unification_error + | 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_500/typing/untypeast.ml b/upstream/ocaml_500/typing/untypeast.ml new file mode 100644 index 0000000000..84af674ad2 --- /dev/null +++ b/upstream/ocaml_500/typing/untypeast.ml @@ -0,0 +1,916 @@ +(**************************************************************************) +(* *) +(* 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 + ~vars:cd.cd_vars + ~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 (vs, args, ret) -> + Pext_decl (vs, 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 + | Tmeth_ancestor(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_500/typing/untypeast.mli b/upstream/ocaml_500/typing/untypeast.mli new file mode 100644 index 0000000000..809df9ad08 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/Makefile b/upstream/ocaml_500/utils/Makefile new file mode 100644 index 0000000000..7142afbd08 --- /dev/null +++ b/upstream/ocaml_500/utils/Makefile @@ -0,0 +1,118 @@ +#************************************************************************** +#* * +#* 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,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) \ + $(call SUBST,FORCE_INSTRUMENTED_RUNTIME) \ + $< > $@ + +# 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_500/utils/arg_helper.ml b/upstream/ocaml_500/utils/arg_helper.ml new file mode 100644 index 0000000000..fa80007ad4 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/arg_helper.mli b/upstream/ocaml_500/utils/arg_helper.mli new file mode 100644 index 0000000000..18f60fea5c --- /dev/null +++ b/upstream/ocaml_500/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 + | =[,...] + + (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_500/utils/binutils.ml b/upstream/ocaml_500/utils/binutils.ml new file mode 100644 index 0000000000..cf8a53e70a --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/binutils.mli b/upstream/ocaml_500/utils/binutils.mli new file mode 100644 index 0000000000..44e17fec38 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/build_path_prefix_map.ml b/upstream/ocaml_500/utils/build_path_prefix_map.ml new file mode 100644 index 0000000000..65d951f1c3 --- /dev/null +++ b/upstream/ocaml_500/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.ksprintf (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_500/utils/build_path_prefix_map.mli b/upstream/ocaml_500/utils/build_path_prefix_map.mli new file mode 100644 index 0000000000..dbcc8dc16f --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/ccomp.ml b/upstream/ocaml_500/utils/ccomp.ml new file mode 100644 index 0000000000..955968d1cd --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/ccomp.mli b/upstream/ocaml_500/utils/ccomp.mli new file mode 100644 index 0000000000..46f58a982e --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/clflags.ml b/upstream/ocaml_500/utils/clflags.ml new file mode 100644 index 0000000000..53319aedfd --- /dev/null +++ b/upstream/ocaml_500/utils/clflags.ml @@ -0,0 +1,578 @@ +(**************************************************************************) +(* *) +(* 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 cmi_file = ref None + +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 (* -bin-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_shape = ref false (* -dshape *) +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_tmc = ref false (* -force-tmc *) +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 (match Config.force_instrumented_runtime with (* -runtime-variant *) + | true -> "i" + | false -> "") + +let with_runtime = ref true (* -with-runtime *) + +let keep_docs = ref false (* -keep-docs *) +let keep_locs = ref true (* -keep-locs *) + +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 *) +let dump_dir: string option ref = ref None (* -dump-dir *) + +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 \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_500/utils/clflags.mli b/upstream/ocaml_500/utils/clflags.mli new file mode 100644 index 0000000000..ec852553df --- /dev/null +++ b/upstream/ocaml_500/utils/clflags.mli @@ -0,0 +1,273 @@ +(**************************************************************************) +(* *) +(* 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 cmi_file : string option 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_shape : 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_tmc : bool ref +val force_slash : bool ref +val keep_docs : bool ref +val keep_locs : 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 +val dump_dir : string option 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_500/utils/config.mli b/upstream/ocaml_500/utils/config.mli new file mode 100644 index 0000000000..29f482d261 --- /dev/null +++ b/upstream/ocaml_500/utils/config.mli @@ -0,0 +1,263 @@ +(**************************************************************************) +(* *) +(* 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 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 naked_pointers : bool +(** Whether the runtime supports naked pointers + + @since 4.14.0 *) + +val supports_shared_libraries: bool +(** Whether shared libraries are supported + + @since 4.08.0 *) + +val force_instrumented_runtime: bool +(** Force runtime-variant to be "i" at configure time + when ocamlc or ocamlopt link executables. *) + +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_500/utils/config.mlp b/upstream/ocaml_500/utils/config.mlp new file mode 100644 index 0000000000..fc92ba77ec --- /dev/null +++ b/upstream/ocaml_500/utils/config.mlp @@ -0,0 +1,248 @@ +#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 ../build-aux/ocaml_version.m4 *) +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 = true +let default_safe_string = true +let windows_unicode = %%WINDOWS_UNICODE%% != 0 +let naked_pointers = false +let force_instrumented_runtime = %%FORCE_INSTRUMENTED_RUNTIME%% + +let flat_float_array = %%FLAT_FLOAT_ARRAY%% + +let function_sections = %%FUNCTION_SECTIONS%% +let afl_instrument = %%AFL_INSTRUMENT%% + +let exec_magic_number = "Caml1999X031" + (* exec_magic_number is duplicated in runtime/caml/exec.h *) +and cmi_magic_number = "Caml1999I031" +and cmo_magic_number = "Caml1999O031" +and cma_magic_number = "Caml1999A031" +and cmx_magic_number = + if flambda then + "Caml1999y031" + else + "Caml1999Y031" +and cmxa_magic_number = + if flambda then + "Caml1999z031" + else + "Caml1999Z031" +and ast_impl_magic_number = "Caml1999M031" +and ast_intf_magic_number = "Caml1999N031" +and cmxs_magic_number = "Caml1999D031" +and cmt_magic_number = "Caml1999T031" +and linear_magic_number = "Caml1999L031" + +let interface_suffix = ref ".mli" + +let max_tag = 243 +(* 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 = 32 (* see runtime/caml/config.h *) +let stack_safety_margin = 6 + +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_bool "naked_pointers" naked_pointers; + + 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_500/utils/consistbl.ml b/upstream/ocaml_500/utils/consistbl.ml new file mode 100644 index 0000000000..b3299114a4 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/consistbl.mli b/upstream/ocaml_500/utils/consistbl.mli new file mode 100644 index 0000000000..5067addfa7 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/diffing.ml b/upstream/ocaml_500/utils/diffing.ml new file mode 100644 index 0000000000..e5b230e233 --- /dev/null +++ b/upstream/ocaml_500/utils/diffing.ml @@ -0,0 +1,447 @@ +(**************************************************************************) +(* *) +(* 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 + 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. + +*) + +(** Shared types *) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation + +let style = function + | Preservation -> Misc.Color.[ FG Green ] + | Deletion -> Misc.Color.[ FG Red; Bold] + | Insertion -> Misc.Color.[ FG Red; Bold] + | Modification -> 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 (let*) = Option.bind +let (let+) x f = Option.map f x +let (let*!) x f = Option.iter f x + +module type Defs = sig + type left + type right + type eq + type diff + type state +end + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +let classify = function + | Delete _ -> Deletion + | Insert _ -> Insertion + | Change _ -> Modification + | Keep _ -> Preservation + +module Define(D:Defs) = struct + open D + +type nonrec change = (left,right,eq,diff) change + +type patch = change list +module type S = sig + val diff: state -> left array -> right array -> patch +end + + +type full_state = { + line: left array; + column: right array; + state: state +} + +(* 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 t + + val make : shape -> t + val reshape : shape -> t -> t + + (** accessor functions *) + val diff : t -> int -> int -> change option + val state : t -> int -> int -> full_state option + val weight : t -> int -> int -> int + + val line : t -> int -> int -> left option + val column : t -> int -> int -> right option + + val set : + t -> int -> int -> + diff:change option -> + weight:int -> + state: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 t = + { states: full_state option array array; + weight: int array array; + 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 + + +(* 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) + +(* 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 + + module type Full_core = sig + type update_result + type update_state + val weight: change -> int + val test: state -> left -> right -> (eq, diff) result + val update: change -> update_state -> update_result + end + +module Generic + (X: Full_core + with type update_result := full_state + and type update_state := full_state) = struct + open X + + (* Boundary cell update *) + let compute_column0 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 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 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 m i j = + match i, j with + | _ when Matrix.diff m i j <> None -> () + | 0,0 -> () + | 0,j -> compute_line0 m j + | i,0 -> compute_column0 m i; + | _ -> compute_inner_cell 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 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 m i j + done + done; + loop m + else + m + in + loop m0 + end + + + module type Parameters = Full_core with type update_state := state + + module Simple(X:Parameters with type update_result := state) = struct + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = { fs with state = X.update d fs.state } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + + let may_append x = function + | [||] -> x + | y -> Array.append x y + + + module Left_variadic + (X:Parameters with type update_result := state * left array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; line = may_append fs.line a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + module Right_variadic + (X:Parameters with type update_result := state * right array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; column = may_append fs.column a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + +end diff --git a/upstream/ocaml_500/utils/diffing.mli b/upstream/ocaml_500/utils/diffing.mli new file mode 100644 index 0000000000..1d4588ba77 --- /dev/null +++ b/upstream/ocaml_500/utils/diffing.mli @@ -0,0 +1,148 @@ + +(**************************************************************************) +(* *) +(* 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 ). + + 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 core types of a diffing implementation *) +module type Defs = sig + type left + type right + type eq + (** Detailed equality trace *) + + type diff + (** Detailed difference trace *) + + type state + (** environment of a partial patch *) +end + +(** The kind of changes which is used to share printing and styling + across implementation*) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation +val prefix: Format.formatter -> (int * change_kind) -> unit +val style: change_kind -> Misc.Color.style list + + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +val classify: _ change -> change_kind + +(** [Define(Defs)] creates the diffing types from the types + defined in [Defs] and the functors that need to be instantatied + with the diffing algorithm parameters +*) +module Define(D:Defs): sig + open D + + (** The type of potential changes on a list. *) + type nonrec change = (left,right,eq,diff) change + type patch = change list + (** A patch is an ordered list of changes. *) + + module type Parameters = sig + type update_result + + val weight: change -> int + (** [weight ch] returns the weight of the change [ch]. + Used to find the smallest patch. *) + + val test: state -> left -> right -> (eq, diff) result + (** + [test st xl xr] tests if the elements [xl] and [xr] are + co mpatible ([Ok]) or not ([Error]). + *) + + val update: change -> state -> update_result + (** [update ch st] returns the new state after applying a change. + The [update_result] type also contains expansions in the variadic + case. + *) + end + + module type S = sig + val diff: state -> left array -> right array -> patch + (** [diff state l r] computes the optimal patch between [l] and [r], + using the initial state [state]. + *) + end + + + module Simple: (Parameters with type update_result := state) -> S + + (** {1 Variadic diffing} + + Variadic diffing allows to expand the lists being diffed during diffing. + in one specific direction. + *) + module Left_variadic: + (Parameters with type update_result := state * left array) -> S + + module Right_variadic: + (Parameters with type update_result := state * right array) -> S + +end diff --git a/upstream/ocaml_500/utils/diffing_with_keys.ml b/upstream/ocaml_500/utils/diffing_with_keys.ml new file mode 100644 index 0000000000..3e1ea13680 --- /dev/null +++ b/upstream/ocaml_500/utils/diffing_with_keys.ml @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + + +type 'a with_pos = {pos:int; data:'a} +let with_pos l = List.mapi (fun n data -> {pos=n+1; data}) l + +(** Composite change and mismatches *) +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +let prefix ppf x = + let kind = match x with + | Change _ | Swap _ | Move _ -> Diffing.Modification + | Insert _ -> Diffing.Insertion + | Delete _ -> Diffing.Deletion + in + let style k ppf inner = + let sty = Diffing.style k in + Format.pp_open_stag ppf (Misc.Color.Style sty); + Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner + in + match x with + | Change (Name {pos; _ } | Type {pos; _}) + | Insert { pos; _ } | Delete { pos; _ } -> + style kind ppf "%i. " pos + | Swap { pos = left, right; _ } -> + style kind ppf "%i<->%i. " left right + | Move { got; expected; _ } -> + style kind ppf "%i->%i. " expected got + + + +(** To detect [move] and [swaps], we are using the fact that + there are 2-cycles in the graph of name renaming. + - [Change (x,y,_) is then an edge from + [key_left x] to [key_right y]. + - [Insert x] is an edge between the special node epsilon and + [key_left x] + - [Delete x] is an edge between [key_right] and the epsilon node + Since for 2-cycle, knowing one edge is enough to identify the cycle + it might belong to, we are using maps of partial 2-cycles. +*) +module Two_cycle: sig + type t = private (string * string) + val create: string -> string -> t +end = struct + type t = string * string + let create kx ky = + if kx <= ky then kx, ky else ky, kx +end +module Swap = Map.Make(struct + type t = Two_cycle.t + let compare: t -> t -> int = Stdlib.compare + end) +module Move = Misc.Stdlib.String.Map + + +module Define(D:Diffing.Defs with type eq := unit) = struct + + module Internal_defs = struct + type left = D.left with_pos + type right = D.right with_pos + type diff = (D.left, D.right, D.diff) mismatch + type eq = unit + type state = D.state + end + module Diff = Diffing.Define(Internal_defs) + + type left = Internal_defs.left + type right = Internal_defs.right + type diff = (D.left, D.right, D.diff) mismatch + type composite_change = (D.left,D.right,D.diff) change + type nonrec change = (left, right, unit, diff) Diffing.change + type patch = composite_change list + + module type Parameters = sig + include Diff.Parameters with type update_result := D.state + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple(Impl:Parameters) = struct + open Impl + + (** Partial 2-cycles *) + type ('l,'r) partial_cycle = + | Left of int * D.state * 'l + | Right of int * D.state * 'r + | Both of D.state * 'l * 'r + + (** Compute the partial cycle and edge associated to an edge *) + let edge state (x:left) (y:right) = + let kx, ky = key_left x.data, key_right y.data in + let edge = + if kx <= ky then + Left (x.pos, state, (x,y)) + else + Right (x.pos,state, (x,y)) + in + Two_cycle.create kx ky, edge + + let merge_edge ex ey = match ex, ey with + | ex, None -> Some ex + | Left (lpos, lstate, l), Some Right (rpos, rstate,r) + | Right (rpos, rstate,r), Some Left (lpos, lstate, l) -> + let state = if lpos < rpos then rstate else lstate in + Some (Both (state,l,r)) + | Both _ as b, _ | _, Some (Both _ as b) -> Some b + | l, _ -> Some l + + let two_cycles state changes = + let add (state,(swaps,moves)) (d:change) = + update d state, + match d with + | Change (x,y,_) -> + let k, edge = edge state x y in + Swap.update k (merge_edge edge) swaps, moves + | Insert nx -> + let k = key_right nx.data in + let edge = Right (nx.pos, state,nx) in + swaps, Move.update k (merge_edge edge) moves + | Delete nx -> + let k, edge = key_left nx.data, Left (nx.pos, state, nx) in + swaps, Move.update k (merge_edge edge) moves + | _ -> swaps, moves + in + List.fold_left add (state,(Swap.empty,Move.empty)) changes + + (** Check if an edge belongs to a known 2-cycle *) + let swap swaps x y = + let kx, ky = key_left x.data, key_right y.data in + let key = Two_cycle.create kx ky in + match Swap.find_opt key swaps with + | None | Some (Left _ | Right _)-> None + | Some Both (state, (ll,lr),(rl,rr)) -> + match test state ll rr, test state rl lr with + | Ok _, Ok _ -> + Some ({pos=ll.pos; data=kx}, {pos=rl.pos; data=ky}) + | Error _, _ | _, Error _ -> None + + let move moves x = + let name = + match x with + | Either.Left x -> key_left x.data + | Either.Right x -> key_right x.data + in + match Move.find_opt name moves with + | None | Some (Left _ | Right _)-> None + | Some Both (state,got,expected) -> + match test state got expected with + | Ok _ -> + Some (Move {name; got=got.pos; expected=expected.pos}) + | Error _ -> None + + let refine state patch = + let _, (swaps, moves) = two_cycles state patch in + let filter: change -> composite_change option = function + | Keep _ -> None + | Insert x -> + begin match move moves (Either.Right x) with + | Some _ as move -> move + | None -> Some (Insert {pos=x.pos;insert=x.data}) + end + | Delete x -> + begin match move moves (Either.Left x) with + | Some _ -> None + | None -> Some (Delete {pos=x.pos; delete=x.data}) + end + | Change(x,y, reason) -> + match swap swaps x y with + | Some ({pos=pos1; data=first}, {pos=pos2; data=last}) -> + if x.pos = pos1 then + Some (Swap { pos = pos1, pos2; first; last}) + else None + | None -> Some (Change reason) + in + List.filter_map filter patch + + let diff state left right = + let left = with_pos left in + let right = with_pos right in + let module Raw = Diff.Simple(Impl) in + let raw = Raw.diff state (Array.of_list left) (Array.of_list right) in + refine state raw + + end +end diff --git a/upstream/ocaml_500/utils/diffing_with_keys.mli b/upstream/ocaml_500/utils/diffing_with_keys.mli new file mode 100644 index 0000000000..2da8268767 --- /dev/null +++ b/upstream/ocaml_500/utils/diffing_with_keys.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** + + When diffing lists where each element has a distinct key, we can refine + the diffing patch by introducing two composite edit moves: swaps and moves. + + [Swap]s exchange the position of two elements. [Swap] cost is set to + [2 * change - epsilon]. + [Move]s change the position of one element. [Move] cost is set to + [delete + addition - epsilon]. + + When the cost [delete + addition] is greater than [change] and with those + specific weights, the optimal patch with [Swap]s and [Move]s can be computed + directly and cheaply from the original optimal patch. + +*) + +type 'a with_pos = {pos: int; data:'a} +val with_pos: 'a list -> 'a with_pos list + +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +(** This specialized version of changes introduces two composite + changes: [Move] and [Swap] +*) +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +val prefix: Format.formatter -> ('l,'r,'diff) change -> unit + +module Define(D:Diffing.Defs with type eq := unit): sig + + type diff = (D.left, D.right, D.diff) mismatch + type left = D.left with_pos + type right = D.right with_pos + + (** Composite changes and patches *) + type composite_change = (D.left,D.right,D.diff) change + type patch = composite_change list + + (** Atomic changes *) + type change = (left,right,unit,diff) Diffing.change + + module type Parameters = sig + val weight: change -> int + val test: D.state -> left -> right -> (unit, diff) result + val update: change -> D.state -> D.state + + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple: Parameters -> sig + val diff: D.state -> D.left list -> D.right list -> patch + end + +end diff --git a/upstream/ocaml_500/utils/domainstate.ml.c b/upstream/ocaml_500/utils/domainstate.ml.c new file mode 100644 index 0000000000..6dbae1d07a --- /dev/null +++ b/upstream/ocaml_500/utils/domainstate.ml.c @@ -0,0 +1,38 @@ +/**************************************************************************/ +/* */ +/* 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. */ +/* */ +/**************************************************************************/ + +#define CAML_CONFIG_H_NO_TYPEDEFS +#include "config.h" +let stack_ctx_words = Stack_ctx_words + +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_500/utils/domainstate.mli.c b/upstream/ocaml_500/utils/domainstate.mli.c new file mode 100644 index 0000000000..66a4750d4c --- /dev/null +++ b/upstream/ocaml_500/utils/domainstate.mli.c @@ -0,0 +1,24 @@ +/**************************************************************************/ +/* */ +/* 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. */ +/* */ +/**************************************************************************/ + +val stack_ctx_words : int + +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_500/utils/identifiable.ml b/upstream/ocaml_500/utils/identifiable.ml new file mode 100644 index 0000000000..9bbfb65733 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/identifiable.mli b/upstream/ocaml_500/utils/identifiable.mli new file mode 100644 index 0000000000..0da5a66191 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/int_replace_polymorphic_compare.ml b/upstream/ocaml_500/utils/int_replace_polymorphic_compare.ml new file mode 100644 index 0000000000..7cd6bf1099 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/int_replace_polymorphic_compare.mli b/upstream/ocaml_500/utils/int_replace_polymorphic_compare.mli new file mode 100644 index 0000000000..689e741b66 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/lazy_backtrack.ml b/upstream/ocaml_500/utils/lazy_backtrack.ml new file mode 100644 index 0000000000..13e4eb4400 --- /dev/null +++ b/upstream/ocaml_500/utils/lazy_backtrack.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* 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 get_contents x = + match !x with + | Thunk a -> Either.Left a + | Done b -> Either.Right b + | Raise e -> raise e + +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_500/utils/lazy_backtrack.mli b/upstream/ocaml_500/utils/lazy_backtrack.mli new file mode 100644 index 0000000000..4e2fbd3808 --- /dev/null +++ b/upstream/ocaml_500/utils/lazy_backtrack.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* 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 get_contents : ('a,'b) t -> ('a,'b) Either.t +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_500/utils/load_path.ml b/upstream/ocaml_500/utils/load_path.ml new file mode 100644 index 0000000000..2b1d02654b --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/load_path.mli b/upstream/ocaml_500/utils/load_path.mli new file mode 100644 index 0000000000..1f9aba28bf --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/local_store.ml b/upstream/ocaml_500/utils/local_store.ml new file mode 100644 index 0000000000..4babf61d82 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/local_store.mli b/upstream/ocaml_500/utils/local_store.mli new file mode 100644 index 0000000000..f39cd12328 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/misc.ml b/upstream/ocaml_500/utils/misc.ml new file mode 100644 index 0000000000..3860e043f5 --- /dev/null +++ b/upstream/ocaml_500/utils/misc.ml @@ -0,0 +1,1125 @@ +(**************************************************************************) +(* *) +(* 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) + +let ordinal_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" + +(* 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 "@["; + 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_500/utils/misc.mli b/upstream/ocaml_500/utils/misc.mli new file mode 100644 index 0000000000..5fc95e61ad --- /dev/null +++ b/upstream/ocaml_500/utils/misc.mli @@ -0,0 +1,672 @@ +(**************************************************************************) +(* *) +(* 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 +*) + +val ordinal_suffix : int -> string +(** [ordinal_suffix n] is the appropriate suffix to append to the numeral [n] as + an ordinal number: [1] -> ["st"], [2] -> ["nd"], [3] -> ["rd"], + [4] -> ["th"], and so on. Handles larger numbers (e.g., [42] -> ["nd"]) and + the numbers 11--13 (which all get ["th"]) correctly. *) + +(* 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_500/utils/misc.mli.orig b/upstream/ocaml_500/utils/misc.mli.orig new file mode 100644 index 0000000000..6aea772091 --- /dev/null +++ b/upstream/ocaml_500/utils/misc.mli.orig @@ -0,0 +1,673 @@ +(**************************************************************************) +(* *) +(* 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 +*) + +val ordinal_suffix : int -> string +(** [ordinal_suffix n] is the appropriate suffix to append to the numeral [n] as + an ordinal number: [1] -> ["st"], [2] -> ["nd"], [3] -> ["rd"], + [4] -> ["th"], and so on. Handles larger numbers (e.g., [42] -> ["nd"]) and + the numbers 11--13 (which all get ["th"]) correctly. *) + +(* 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_500/utils/numbers.ml b/upstream/ocaml_500/utils/numbers.ml new file mode 100644 index 0000000000..1680675bab --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/numbers.mli b/upstream/ocaml_500/utils/numbers.mli new file mode 100644 index 0000000000..fa565e67e1 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/profile.ml b/upstream/ocaml_500/utils/profile.ml new file mode 100644 index 0000000000..27c92a5463 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/profile.mli b/upstream/ocaml_500/utils/profile.mli new file mode 100644 index 0000000000..7eff6957b6 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/strongly_connected_components.ml b/upstream/ocaml_500/utils/strongly_connected_components.ml new file mode 100644 index 0000000000..eb1501ca7c --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/strongly_connected_components.mli b/upstream/ocaml_500/utils/strongly_connected_components.mli new file mode 100644 index 0000000000..e700952792 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/targetint.ml b/upstream/ocaml_500/utils/targetint.ml new file mode 100644 index 0000000000..9d15a2ff56 --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/targetint.mli b/upstream/ocaml_500/utils/targetint.mli new file mode 100644 index 0000000000..a222f5d68c --- /dev/null +++ b/upstream/ocaml_500/utils/targetint.mli @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* 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 +(** [abs x] is the absolute value of [x]. On [min_int] this + is [min_int] itself and thus remains negative. *) + +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_500/utils/terminfo.ml b/upstream/ocaml_500/utils/terminfo.ml new file mode 100644 index 0000000000..1b4a3578eb --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/terminfo.mli b/upstream/ocaml_500/utils/terminfo.mli new file mode 100644 index 0000000000..10f5f5453f --- /dev/null +++ b/upstream/ocaml_500/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_500/utils/warnings.ml b/upstream/ocaml_500/utils/warnings.ml new file mode 100644 index 0000000000..097bd3b920 --- /dev/null +++ b/upstream/ocaml_500/utils/warnings.ml @@ -0,0 +1,1131 @@ +(**************************************************************************) +(* *) +(* 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 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + +(* 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 + | Unused_tmc_attribute -> 71 + | Tmc_breaks_tailcall -> 72 +;; +(* DO NOT REMOVE the ;; above: it is used by + the testsuite/ests/warnings/mnemonics.mll test to determine where + the definition of the number function above ends *) + +let last_warning_number = 72 + +type description = + { number : int; + names : string list; + (* 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. *) + description : string; } + +let descriptions = [ + { number = 1; + names = ["comment-start"]; + description = "Suspicious-looking start-of-comment mark." }; + { number = 2; + names = ["comment-not-end"]; + description = "Suspicious-looking end-of-comment mark." }; + { number = 3; + names = []; + description = "Deprecated synonym for the 'deprecated' alert." }; + { number = 4; + names = ["fragile-match"]; + description = + "Fragile pattern matching: matching that will remain complete even\n\ + \ if additional constructors are added to one of the variant types\n\ + \ matched." }; + { number = 5; + names = ["ignored-partial-application"]; + description = + "Partially applied function: expression whose result has function\n\ + \ type and is ignored." }; + { number = 6; + names = ["labels-omitted"]; + description = "Label omitted in function application." }; + { number = 7; + names = ["method-override"]; + description = "Method overridden." }; + { number = 8; + names = ["partial-match"]; + description = "Partial match: missing cases in pattern-matching." }; + { number = 9; + names = ["missing-record-field-pattern"]; + description = "Missing fields in a record pattern." }; + { number = 10; + names = ["non-unit-statement"]; + description = + "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)." }; + { number = 11; + names = ["redundant-case"]; + description = + "Redundant case in a pattern matching (unused match case)." }; + { number = 12; + names = ["redundant-subpat"]; + description = "Redundant sub-pattern in a pattern-matching." }; + { number = 13; + names = ["instance-variable-override"]; + description = "Instance variable overridden." }; + { number = 14; + names = ["illegal-backslash"]; + description = "Illegal backslash escape in a string constant." }; + { number = 15; + names = ["implicit-public-methods"]; + description = "Private method made public implicitly." }; + { number = 16; + names = ["unerasable-optional-argument"]; + description = "Unerasable optional argument." }; + { number = 17; + names = ["undeclared-virtual-method"]; + description = "Undeclared virtual method." }; + { number = 18; + names = ["not-principal"]; + description = "Non-principal type." }; + { number = 19; + names = ["non-principal-labels"]; + description = "Type without principality." }; + { number = 20; + names = ["ignored-extra-argument"]; + description = "Unused function argument." }; + { number = 21; + names = ["nonreturning-statement"]; + description = "Non-returning statement." }; + { number = 22; + names = ["preprocessor"]; + description = "Preprocessor warning." }; + { number = 23; + names = ["useless-record-with"]; + description = "Useless record \"with\" clause." }; + { number = 24; + names = ["bad-module-name"]; + description = + "Bad module name: the source file name is not a valid OCaml module name."}; + { number = 25; + names = []; + description = "Ignored: now part of warning 8." }; + { number = 26; + names = ["unused-var"]; + description = + "Suspicious unused variable: unused variable that is bound\n\ + \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character." }; + { number = 27; + names = ["unused-var-strict"]; + description = + "Innocuous unused variable: unused variable that is not bound with\n\ + \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character." }; + { number = 28; + names = ["wildcard-arg-to-constant-constr"]; + description = + "Wildcard pattern given as argument to a constant constructor." }; + { number = 29; + names = ["eol-in-string"]; + description = + "Unescaped end-of-line in a string constant (non-portable code)." }; + { number = 30; + names = ["duplicate-definitions"]; + description = + "Two labels or constructors of the same name are defined in two\n\ + \ mutually recursive types." }; + { number = 31; + names = ["module-linked-twice"]; + description = "A module is linked twice in the same executable." }; + { number = 32; + names = ["unused-value-declaration"]; + description = "Unused value declaration." }; + { number = 33; + names = ["unused-open"]; + description = "Unused open statement." }; + { number = 34; + names = ["unused-type-declaration"]; + description = "Unused type declaration." }; + { number = 35; + names = ["unused-for-index"]; + description = "Unused for-loop index." }; + { number = 36; + names = ["unused-ancestor"]; + description = "Unused ancestor variable." }; + { number = 37; + names = ["unused-constructor"]; + description = "Unused constructor." }; + { number = 38; + names = ["unused-extension"]; + description = "Unused extension constructor." }; + { number = 39; + names = ["unused-rec-flag"]; + description = "Unused rec flag." }; + { number = 40; + names = ["name-out-of-scope"]; + description = "Constructor or label name used out of scope." }; + { number = 41; + names = ["ambiguous-name"]; + description = "Ambiguous constructor or label name." }; + { number = 42; + names = ["disambiguated-name"]; + description = + "Disambiguated constructor or label name (compatibility warning)." }; + { number = 43; + names = ["nonoptional-label"]; + description = "Nonoptional label applied as optional." }; + { number = 44; + names = ["open-shadow-identifier"]; + description = "Open statement shadows an already defined identifier." }; + { number = 45; + names = ["open-shadow-label-constructor"]; + description = + "Open statement shadows an already defined label or constructor." }; + { number = 46; + names = ["bad-env-variable"]; + description = "Error in environment variable." }; + { number = 47; + names = ["attribute-payload"]; + description = "Illegal attribute payload." }; + { number = 48; + names = ["eliminated-optional-arguments"]; + description = "Implicit elimination of optional arguments." }; + { number = 49; + names = ["no-cmi-file"]; + description = "Absent cmi file when looking up module alias." }; + { number = 50; + names = ["unexpected-docstring"]; + description = "Unexpected documentation comment." }; + { number = 51; + names = ["wrong-tailcall-expectation"]; + description = + "Function call annotated with an incorrect @tailcall attribute" }; + { number = 52; + names = ["fragile-literal-pattern"]; + description = "Fragile constant pattern." }; + { number = 53; + names = ["misplaced-attribute"]; + description = "Attribute cannot appear in this context." }; + { number = 54; + names = ["duplicated-attribute"]; + description = "Attribute used more than once on an expression." }; + { number = 55; + names = ["inlining-impossible"]; + description = "Inlining impossible." }; + { number = 56; + names = ["unreachable-case"]; + description = + "Unreachable case in a pattern-matching (based on type information)." }; + { number = 57; + names = ["ambiguous-var-in-pattern-guard"]; + description = "Ambiguous or-pattern variables under guard." }; + { number = 58; + names = ["no-cmx-file"]; + description = "Missing cmx file." }; + { number = 59; + names = ["flambda-assignment-to-non-mutable-value"]; + description = "Assignment to non-mutable value." }; + { number = 60; + names = ["unused-module"]; + description = "Unused module declaration." }; + { number = 61; + names = ["unboxable-type-in-prim-decl"]; + description = "Unboxable type in primitive declaration." }; + { number = 62; + names = ["constraint-on-gadt"]; + description = "Type constraint on GADT type declaration." }; + { number = 63; + names = ["erroneous-printed-signature"]; + description = "Erroneous printed signature." }; + { number = 64; + names = ["unsafe-array-syntax-without-parsing"]; + description = + "-unsafe used with a preprocessor returning a syntax tree." }; + { number = 65; + names = ["redefining-unit"]; + description = "Type declaration defining a new '()' constructor." }; + { number = 66; + names = ["unused-open-bang"]; + description = "Unused open! statement." }; + { number = 67; + names = ["unused-functor-parameter"]; + description = "Unused functor parameter." }; + { number = 68; + names = ["match-on-mutable-state-prevent-uncurry"]; + description = + "Pattern-matching depending on mutable state prevents the remaining \n\ + \ arguments from being uncurried." }; + { number = 69; + names = ["unused-field"]; + description = "Unused record field." }; + { number = 70; + names = ["missing-mli"]; + description = "Missing interface file." }; + { number = 71; + names = ["unused-tmc-attribute"]; + description = "Unused @tail_mod_cons attribute" }; + { number = 72; + names = ["tmc-breaks-tailcall"]; + description = "A tail call is turned into a non-tail call \ + by the @tail_mod_cons transformation." }; +] + +let name_to_number = + let h = Hashtbl.create last_warning_number in + List.iter (fun {number; names; _} -> + List.iter (fun name -> Hashtbl.add h name number) 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 with_state state f = + let prev = backup () in + restore state; + try + let r = f () in + restore prev; + r + with exn -> + restore prev; + raise exn + +let mk_lazy f = + let state = backup () in + lazy (with_state state f) + +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 + "@[@[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." + | Instance_variable_override (cname :: slist) -> + String.concat " " + ("the following instance variables are overridden by the class" + :: cname :: ":\n " :: slist) + | 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 ' -> .'" + | 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." + | Unused_tmc_attribute -> + "This function is marked @tail_mod_cons but is never applied in \ + TMC position." + | Tmc_breaks_tailcall -> + "This call is in tail-modulo-cons position in a TMC function,\n\ + but the function called is not itself specialized for TMC,\n\ + so the call will not be transformed into a tail call.\n\ + Please either mark the called function with\n\ + the [@tail_mod_cons] attribute, or mark this call with\n\ + the [@tailcall false] attribute to make its non-tailness \ + explicit." + +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 {number; _} -> number = n) descriptions with + | Some {names = 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 {number; description; names} -> + let name = + match names with + | s :: _ -> " [" ^ s ^ "]" + | [] -> "" + in + Printf.printf "%3i%s %s\n" number name description) + 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_500/utils/warnings.ml.orig b/upstream/ocaml_500/utils/warnings.ml.orig new file mode 100644 index 0000000000..7f84a175b2 --- /dev/null +++ b/upstream/ocaml_500/utils/warnings.ml.orig @@ -0,0 +1,1137 @@ +(**************************************************************************) +(* *) +(* 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 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) +;; + +(* 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 + | Unused_tmc_attribute -> 71 + | Tmc_breaks_tailcall -> 72 +;; + +let last_warning_number = 72 +;; + +type description = + { number : int; + names : string list; + (* 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. *) + description : string; } + +let descriptions = [ + { number = 1; + names = ["comment-start"]; + description = "Suspicious-looking start-of-comment mark." }; + { number = 2; + names = ["comment-not-end"]; + description = "Suspicious-looking end-of-comment mark." }; + { number = 3; + names = []; + description = "Deprecated synonym for the 'deprecated' alert." }; + { number = 4; + names = ["fragile-match"]; + description = + "Fragile pattern matching: matching that will remain complete even\n\ + \ if additional constructors are added to one of the variant types\n\ + \ matched." }; + { number = 5; + names = ["ignored-partial-application"]; + description = + "Partially applied function: expression whose result has function\n\ + \ type and is ignored." }; + { number = 6; + names = ["labels-omitted"]; + description = "Label omitted in function application." }; + { number = 7; + names = ["method-override"]; + description = "Method overridden." }; + { number = 8; + names = ["partial-match"]; + description = "Partial match: missing cases in pattern-matching." }; + { number = 9; + names = ["missing-record-field-pattern"]; + description = "Missing fields in a record pattern." }; + { number = 10; + names = ["non-unit-statement"]; + description = + "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)." }; + { number = 11; + names = ["redundant-case"]; + description = + "Redundant case in a pattern matching (unused match case)." }; + { number = 12; + names = ["redundant-subpat"]; + description = "Redundant sub-pattern in a pattern-matching." }; + { number = 13; + names = ["instance-variable-override"]; + description = "Instance variable overridden." }; + { number = 14; + names = ["illegal-backslash"]; + description = "Illegal backslash escape in a string constant." }; + { number = 15; + names = ["implicit-public-methods"]; + description = "Private method made public implicitly." }; + { number = 16; + names = ["unerasable-optional-argument"]; + description = "Unerasable optional argument." }; + { number = 17; + names = ["undeclared-virtual-method"]; + description = "Undeclared virtual method." }; + { number = 18; + names = ["not-principal"]; + description = "Non-principal type." }; + { number = 19; + names = ["non-principal-labels"]; + description = "Type without principality." }; + { number = 20; + names = ["ignored-extra-argument"]; + description = "Unused function argument." }; + { number = 21; + names = ["nonreturning-statement"]; + description = "Non-returning statement." }; + { number = 22; + names = ["preprocessor"]; + description = "Preprocessor warning." }; + { number = 23; + names = ["useless-record-with"]; + description = "Useless record \"with\" clause." }; + { number = 24; + names = ["bad-module-name"]; + description = + "Bad module name: the source file name is not a valid OCaml module name."}; + { number = 25; + names = []; + description = "Ignored: now part of warning 8." }; + { number = 26; + names = ["unused-var"]; + description = + "Suspicious unused variable: unused variable that is bound\n\ + \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character." }; + { number = 27; + names = ["unused-var-strict"]; + description = + "Innocuous unused variable: unused variable that is not bound with\n\ + \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character." }; + { number = 28; + names = ["wildcard-arg-to-constant-constr"]; + description = + "Wildcard pattern given as argument to a constant constructor." }; + { number = 29; + names = ["eol-in-string"]; + description = + "Unescaped end-of-line in a string constant (non-portable code)." }; + { number = 30; + names = ["duplicate-definitions"]; + description = + "Two labels or constructors of the same name are defined in two\n\ + \ mutually recursive types." }; + { number = 31; + names = ["module-linked-twice"]; + description = "A module is linked twice in the same executable." }; + { number = 32; + names = ["unused-value-declaration"]; + description = "Unused value declaration." }; + { number = 33; + names = ["unused-open"]; + description = "Unused open statement." }; + { number = 34; + names = ["unused-type-declaration"]; + description = "Unused type declaration." }; + { number = 35; + names = ["unused-for-index"]; + description = "Unused for-loop index." }; + { number = 36; + names = ["unused-ancestor"]; + description = "Unused ancestor variable." }; + { number = 37; + names = ["unused-constructor"]; + description = "Unused constructor." }; + { number = 38; + names = ["unused-extension"]; + description = "Unused extension constructor." }; + { number = 39; + names = ["unused-rec-flag"]; + description = "Unused rec flag." }; + { number = 40; + names = ["name-out-of-scope"]; + description = "Constructor or label name used out of scope." }; + { number = 41; + names = ["ambiguous-name"]; + description = "Ambiguous constructor or label name." }; + { number = 42; + names = ["disambiguated-name"]; + description = + "Disambiguated constructor or label name (compatibility warning)." }; + { number = 43; + names = ["nonoptional-label"]; + description = "Nonoptional label applied as optional." }; + { number = 44; + names = ["open-shadow-identifier"]; + description = "Open statement shadows an already defined identifier." }; + { number = 45; + names = ["open-shadow-label-constructor"]; + description = + "Open statement shadows an already defined label or constructor." }; + { number = 46; + names = ["bad-env-variable"]; + description = "Error in environment variable." }; + { number = 47; + names = ["attribute-payload"]; + description = "Illegal attribute payload." }; + { number = 48; + names = ["eliminated-optional-arguments"]; + description = "Implicit elimination of optional arguments." }; + { number = 49; + names = ["no-cmi-file"]; + description = "Absent cmi file when looking up module alias." }; + { number = 50; + names = ["unexpected-docstring"]; + description = "Unexpected documentation comment." }; + { number = 51; + names = ["wrong-tailcall-expectation"]; + description = + "Function call annotated with an incorrect @tailcall attribute" }; + { number = 52; + names = ["fragile-literal-pattern"]; + description = "Fragile constant pattern." }; + { number = 53; + names = ["misplaced-attribute"]; + description = "Attribute cannot appear in this context." }; + { number = 54; + names = ["duplicated-attribute"]; + description = "Attribute used more than once on an expression." }; + { number = 55; + names = ["inlining-impossible"]; + description = "Inlining impossible." }; + { number = 56; + names = ["unreachable-case"]; + description = + "Unreachable case in a pattern-matching (based on type information)." }; + { number = 57; + names = ["ambiguous-var-in-pattern-guard"]; + description = "Ambiguous or-pattern variables under guard." }; + { number = 58; + names = ["no-cmx-file"]; + description = "Missing cmx file." }; + { number = 59; + names = ["flambda-assignment-to-non-mutable-value"]; + description = "Assignment to non-mutable value." }; + { number = 60; + names = ["unused-module"]; + description = "Unused module declaration." }; + { number = 61; + names = ["unboxable-type-in-prim-decl"]; + description = "Unboxable type in primitive declaration." }; + { number = 62; + names = ["constraint-on-gadt"]; + description = "Type constraint on GADT type declaration." }; + { number = 63; + names = ["erroneous-printed-signature"]; + description = "Erroneous printed signature." }; + { number = 64; + names = ["unsafe-array-syntax-without-parsing"]; + description = + "-unsafe used with a preprocessor returning a syntax tree." }; + { number = 65; + names = ["redefining-unit"]; + description = "Type declaration defining a new '()' constructor." }; + { number = 66; + names = ["unused-open-bang"]; + description = "Unused open! statement." }; + { number = 67; + names = ["unused-functor-parameter"]; + description = "Unused functor parameter." }; + { number = 68; + names = ["match-on-mutable-state-prevent-uncurry"]; + description = + "Pattern-matching depending on mutable state prevents the remaining \n\ + \ arguments from being uncurried." }; + { number = 69; + names = ["unused-field"]; + description = "Unused record field." }; + { number = 70; + names = ["missing-mli"]; + description = "Missing interface file." }; + { number = 71; + names = ["unused-tmc-attribute"]; + description = "Unused @tail_mod_cons attribute" }; + { number = 72; + names = ["tmc-breaks-tailcall"]; + description = "A tail call is turned into a non-tail call \ + by the @tail_mod_cons transformation." }; +] +;; + +let name_to_number = + let h = Hashtbl.create last_warning_number in + List.iter (fun {number; names; _} -> + List.iter (fun name -> Hashtbl.add h name number) 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 with_state state f = + let prev = backup () in + restore state; + try + let r = f () in + restore prev; + r + with exn -> + restore prev; + raise exn + +let mk_lazy f = + let state = backup () in + lazy (with_state state f) + +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 + "@[@[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." + | Instance_variable_override (cname :: slist) -> + String.concat " " + ("the following instance variables are overridden by the class" + :: cname :: ":\n " :: slist) + | 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 ' -> .'" + | 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." + | Unused_tmc_attribute -> + "This function is marked @tail_mod_cons but is never applied in \ + TMC position." + | Tmc_breaks_tailcall -> + "This call is in tail-modulo-cons position in a TMC function,\n\ + but the function called is not itself specialized for TMC,\n\ + so the call will not be transformed into a tail call.\n\ + Please either mark the called function with\n\ + the [@tail_mod_cons] attribute, or mark this call with\n\ + the [@tailcall false] attribute to make its non-tailness \ + explicit." +;; + +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 {number; _} -> number = n) descriptions with + | Some {names = 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 {number; description; names} -> + let name = + match names with + | s :: _ -> " [" ^ s ^ "]" + | [] -> "" + in + Printf.printf "%3i%s %s\n" number name description) + 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_500/utils/warnings.mli b/upstream/ocaml_500/utils/warnings.mli new file mode 100644 index 0000000000..6ec73928b0 --- /dev/null +++ b/upstream/ocaml_500/utils/warnings.mli @@ -0,0 +1,162 @@ +(**************************************************************************) +(* *) +(* 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 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + +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 with_state : state -> (unit -> 'a) -> 'a +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. *) + +type description = + { number : int; + names : string list; + description : string; } + +val descriptions : description list From a6fe261ac9771ef85fca85522c11d55a061cc122 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 10 Mar 2022 18:02:59 +0100 Subject: [PATCH 003/130] Merge changes from upstream --- src/analysis/construct.ml | 5 +- src/kernel/mconfig.ml | 17 ---- src/kernel/mconfig.mli | 1 - src/kernel/mocaml.ml | 1 - src/ocaml/merlin_specific/typer_raw.ml | 1 - src/ocaml/parsing/ast_mapper.ml | 4 +- src/ocaml/parsing/location.ml | 24 ++--- src/ocaml/parsing/pprintast.ml | 2 +- src/ocaml/parsing/printast.ml | 111 ++++++++++------------- src/ocaml/parsing/printast.mli | 10 +- src/ocaml/preprocess/lexer_raw.mll | 2 - src/ocaml/preprocess/parser_raw.ml | 6 +- src/ocaml/preprocess/parser_raw.mly | 6 +- src/ocaml/typing/annot.mli | 3 +- src/ocaml/typing/cmi_format.ml | 1 - src/ocaml/typing/cmi_format.mli | 1 - src/ocaml/typing/ctype.ml | 44 +++++---- src/ocaml/typing/ctype.mli | 9 +- src/ocaml/typing/env.ml | 4 +- src/ocaml/typing/env.mli | 3 +- src/ocaml/typing/parmatch.ml | 2 +- src/ocaml/typing/persistent_env.ml | 14 --- src/ocaml/typing/persistent_env.mli | 1 - src/ocaml/typing/predef.ml | 17 ++-- src/ocaml/typing/predef.mli | 2 +- src/ocaml/typing/printtyped.ml | 102 +++++++++------------ src/ocaml/typing/printtyped.mli | 10 +- src/ocaml/typing/short_paths_graph.ml | 7 +- src/ocaml/typing/stypes.ml | 36 +++----- src/ocaml/typing/stypes.mli | 13 ++- src/ocaml/typing/tast_mapper.ml | 2 +- src/ocaml/typing/typecore.ml | 37 +++++--- src/ocaml/typing/typedecl.ml | 4 +- src/ocaml/typing/typedecl_unboxed.ml | 1 - src/ocaml/typing/typedtree.ml | 2 +- src/ocaml/typing/typedtree.mli | 2 +- src/ocaml/typing/typemod.ml | 31 +++---- src/ocaml/typing/typemod.mli | 2 +- src/ocaml/utils/build_path_prefix_map.ml | 2 +- src/ocaml/utils/clflags.ml | 12 +-- src/ocaml/utils/clflags.mli | 2 +- src/ocaml/utils/config.ml | 2 - src/ocaml/utils/config.mli | 1 - src/ocaml/utils/diffing.mli | 1 - src/ocaml/utils/local_store.mli | 2 +- src/ocaml/utils/warnings.ml | 26 ++---- src/ocaml/utils/warnings.mli | 15 ++- src/utils/misc.ml | 7 +- src/utils/misc.mli | 3 +- 49 files changed, 264 insertions(+), 349 deletions(-) diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml index 5511c6a2b9..d5df2d0977 100644 --- a/src/analysis/construct.ml +++ b/src/analysis/construct.ml @@ -347,7 +347,10 @@ module Gen = struct (* [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 + let ty_args, ty_res, _ = Ctype.instance_constructor + Keep_existentials_flexible + cstr_descr + in match Util.unifiable env type_expr ty_res with | Some snap -> let lid = diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index e050014f92..de2f420aa5 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -15,7 +15,6 @@ type ocaml = { recursive_types : bool; strict_sequence : bool; applicative_functors : bool; - unsafe_string : bool; nopervasives : bool; strict_formats : bool; open_modules : string list; @@ -40,7 +39,6 @@ let dump_ocaml x = `Assoc [ "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; @@ -518,20 +516,6 @@ let ocaml_flags = [ 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}), @@ -608,7 +592,6 @@ let initial = { recursive_types = false; strict_sequence = false; applicative_functors = true; - unsafe_string = not Config.safe_string; nopervasives = false; strict_formats = false; open_modules = []; diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index 05d3197f23..e018a9418f 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -13,7 +13,6 @@ type ocaml = { recursive_types : bool; strict_sequence : bool; applicative_functors : bool; - unsafe_string : bool; nopervasives : bool; strict_formats : bool; open_modules : string list; diff --git a/src/kernel/mocaml.ml b/src/kernel/mocaml.ml index 6b4cd38dc9..7291588ef5 100644 --- a/src/kernel/mocaml.ml +++ b/src/kernel/mocaml.ml @@ -39,7 +39,6 @@ let setup_reader_config config = ( 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 ; diff --git a/src/ocaml/merlin_specific/typer_raw.ml b/src/ocaml/merlin_specific/typer_raw.ml index 0d83b8b20c..a880159c79 100644 --- a/src/ocaml/merlin_specific/typer_raw.ml +++ b/src/ocaml/merlin_specific/typer_raw.ml @@ -40,7 +40,6 @@ let fresh_env () = 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) diff --git a/src/ocaml/parsing/ast_mapper.ml b/src/ocaml/parsing/ast_mapper.ml index 1a91863dd4..356126c56a 100644 --- a/src/ocaml/parsing/ast_mapper.ml +++ b/src/ocaml/parsing/ast_mapper.ml @@ -843,7 +843,7 @@ module PpxContext = struct 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; + lid "unsafe_string", make_bool false; (* kept for compatibility *) get_cookies () ] in @@ -924,8 +924,6 @@ module PpxContext = struct 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 := diff --git a/src/ocaml/parsing/location.ml b/src/ocaml/parsing/location.ml index bfb71c08a0..92c467a648 100644 --- a/src/ocaml/parsing/location.ml +++ b/src/ocaml/parsing/location.ml @@ -16,21 +16,21 @@ open Lexing type t = Warnings.loc = - { loc_start: position; loc_end: position; loc_ghost: bool };; + { 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 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 <- { @@ -39,36 +39,36 @@ let init lexbuf fname = 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; @@ -735,7 +735,7 @@ let print_warning loc ppf w = | Some report -> print_report ppf report let prerr_warning_ref = - ref (fun loc w -> print_warning loc !formatter_for_warnings w);; + 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 = diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml index 5b2e8c425e..b6557de4c8 100644 --- a/src/ocaml/parsing/pprintast.ml +++ b/src/ocaml/parsing/pprintast.ml @@ -28,7 +28,7 @@ open Longident open Parsetree open Ast_helper -let prefix_symbols = [ '!'; '?'; '~' ] ;; +let prefix_symbols = [ '!'; '?'; '~' ] let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; '$'; '%'; '#' ] diff --git a/src/ocaml/parsing/printast.ml b/src/ocaml/parsing/printast.ml index 83f1cd98ba..559d01c4a9 100644 --- a/src/ocaml/parsing/printast.ml +++ b/src/ocaml/parsing/printast.ml @@ -13,11 +13,11 @@ (* *) (**************************************************************************) -open Asttypes;; -open Format;; -open Lexing;; -open Location;; -open Parsetree;; +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 @@ -25,7 +25,7 @@ let fmt_position with_name f l = 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 () @@ -35,29 +35,25 @@ let fmt_location f loc = (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.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; -;; + 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 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; -;; + 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; -;; + 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; -;; + fprintf f "\"%s\" %a" (Option.value x.txt ~default:"_") fmt_location x.loc let fmt_char_option f = function | None -> fprintf f "None" @@ -66,31 +62,27 @@ let fmt_char_option f = function 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_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 ; + 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; -;; + 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"; -;; + | 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"; -;; + | 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"; -;; + | Override -> fprintf f "Override" + | Fresh -> fprintf f "Fresh" let fmt_closed_flag f x = match x with @@ -99,53 +91,47 @@ let fmt_closed_flag f x = let fmt_rec_flag f x = match x with - | Nonrecursive -> fprintf f "Nonrec"; - | Recursive -> fprintf f "Rec"; -;; + | 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"; -;; + | 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"; -;; + | 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" | _ :: _ -> line i ppf "[\n"; List.iter (f (i+1) ppf) l; - line i ppf "]\n"; -;; + line i ppf "]\n" let option i f ppf x = match x with - | None -> line i ppf "None\n"; + | None -> line i ppf "None\n" | Some x -> line i ppf "Some\n"; - f (i+1) ppf x; -;; + 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 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 typevars ppf vs = List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs @@ -953,7 +939,7 @@ and label_x_bool_x_core_type_list i ppf x = | Rinherit (ct) -> line i ppf "Rinherit\n"; core_type (i+1) ppf ct -;; + let rec toplevel_phrase i ppf x = match x with @@ -968,15 +954,14 @@ let rec toplevel_phrase i ppf x = 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); -;; + | 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 interface ppf x = list 0 signature_item ppf x -let implementation ppf x = list 0 structure_item ppf x;; +let implementation ppf x = list 0 structure_item ppf x -let top_phrase ppf x = toplevel_phrase 0 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 index 8215654826..5bc496182f 100644 --- a/src/ocaml/parsing/printast.mli +++ b/src/ocaml/parsing/printast.mli @@ -20,12 +20,12 @@ *) -open Parsetree;; -open Format;; +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 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 diff --git a/src/ocaml/preprocess/lexer_raw.mll b/src/ocaml/preprocess/lexer_raw.mll index a28dfb3f04..3fce4ec5c4 100644 --- a/src/ocaml/preprocess/lexer_raw.mll +++ b/src/ocaml/preprocess/lexer_raw.mll @@ -283,14 +283,12 @@ let update_loc lexbuf _file line absolute chars = 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 *) diff --git a/src/ocaml/preprocess/parser_raw.ml b/src/ocaml/preprocess/parser_raw.ml index ee80fe7647..f1065c4a5e 100644 --- a/src/ocaml/preprocess/parser_raw.ml +++ b/src/ocaml/preprocess/parser_raw.ml @@ -317,13 +317,13 @@ let push_loc 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 };; + 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 };; + 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 };; + 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)) diff --git a/src/ocaml/preprocess/parser_raw.mly b/src/ocaml/preprocess/parser_raw.mly index daa2ce3163..1196412f78 100644 --- a/src/ocaml/preprocess/parser_raw.mly +++ b/src/ocaml/preprocess/parser_raw.mly @@ -101,13 +101,13 @@ let push_loc 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 };; + 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 };; + 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 };; + 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)) diff --git a/src/ocaml/typing/annot.mli b/src/ocaml/typing/annot.mli index 3cae8f2735..bbaade5b03 100644 --- a/src/ocaml/typing/annot.mli +++ b/src/ocaml/typing/annot.mli @@ -15,10 +15,9 @@ (* Data types for annotations (Stypes.ml) *) -type call = Tail | Stack | Inline;; +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/cmi_format.ml b/src/ocaml/typing/cmi_format.ml index 2c5999db01..01e27b7cd5 100644 --- a/src/ocaml/typing/cmi_format.ml +++ b/src/ocaml/typing/cmi_format.ml @@ -19,7 +19,6 @@ type pers_flags = | Rectypes | Alerts of alerts | Opaque - | Unsafe_string (* these type abbreviations are not exported; they are used to provide consistency across diff --git a/src/ocaml/typing/cmi_format.mli b/src/ocaml/typing/cmi_format.mli index 2ce923f968..179dce38c7 100644 --- a/src/ocaml/typing/cmi_format.mli +++ b/src/ocaml/typing/cmi_format.mli @@ -19,7 +19,6 @@ type pers_flags = | Rectypes | Alerts of alerts | Opaque - | Unsafe_string type cmi_infos = { cmi_name : modname; diff --git a/src/ocaml/typing/ctype.ml b/src/ocaml/typing/ctype.ml index 33578fc863..201cb55626 100644 --- a/src/ocaml/typing/ctype.ml +++ b/src/ocaml/typing/ctype.ml @@ -281,7 +281,7 @@ let in_current_module = function let in_pervasives p = in_current_module p && - try ignore (Env.find_type p Env.initial_safe_string); true + try ignore (Env.find_type p Env.initial); true with Not_found -> false let is_datatype decl= @@ -1194,28 +1194,32 @@ let existential_name cstr ty = | Tvar (Some name) -> "$" ^ cstr.cstr_name ^ "_'" ^ name | _ -> "$" ^ cstr.cstr_name -let instance_constructor ?in_pattern cstr = +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of { env: Env.t ref; scope: int } + +let instance_constructor existential_treatment 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 copy_existential = + match existential_treatment with + | Keep_existentials_flexible -> copy scope + | Make_existentials_abstract {env; scope = fresh_constr_scope} -> + fun 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; + tv + in + let ty_ex = List.map copy_existential cstr.cstr_existentials in 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) ) diff --git a/src/ocaml/typing/ctype.mli b/src/ocaml/typing/ctype.mli index 0fdd659bc7..186142d445 100644 --- a/src/ocaml/typing/ctype.mli +++ b/src/ocaml/typing/ctype.mli @@ -152,8 +152,12 @@ 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 -> + +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of { env: Env.t ref; scope: int } + +val instance_constructor: existential_treatment -> constructor_description -> type_expr list * type_expr * type_expr list (* Same, for a constructor. Also returns existentials. *) val instance_parameterized_type: @@ -424,4 +428,3 @@ val package_subtype : (* Raises [Incompatible] *) val mcomp : Env.t -> type_expr -> type_expr -> unit - diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml index 823da2ad43..f01e7c0703 100644 --- a/src/ocaml/typing/env.ml +++ b/src/ocaml/typing/env.ml @@ -2703,7 +2703,7 @@ let save_signature_with_imports ~alerts sg modname filename imports = ~alerts sg modname filename (* Make the initial environment *) -let (initial_safe_string, initial_unsafe_string) = +let initial = Predef.build_initial_env (add_type ~check:false ~predef:true ~long_path:false) (add_extension ~check:false ~rebind:false) @@ -3181,7 +3181,7 @@ let lookup_all_dot_constructors ~errors ~use ~loc usage l s env = | Longident.Lident "*predef*" -> (* Hack to support compilation of default arguments *) lookup_all_ident_constructors - ~errors ~use ~loc usage s initial_safe_string + ~errors ~use ~loc usage s initial | _ -> let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in match NameMap.find s comps.comp_constrs with diff --git a/src/ocaml/typing/env.mli b/src/ocaml/typing/env.mli index 03ae201cd7..f00d9f5f2c 100644 --- a/src/ocaml/typing/env.mli +++ b/src/ocaml/typing/env.mli @@ -57,8 +57,7 @@ type address = type t val empty: t -val initial_safe_string: t -val initial_unsafe_string: t +val initial: t val diff: t -> t -> Ident.t list type type_descr_kind = diff --git a/src/ocaml/typing/parmatch.ml b/src/ocaml/typing/parmatch.ml index e8ca641410..e85f7a1119 100644 --- a/src/ocaml/typing/parmatch.ml +++ b/src/ocaml/typing/parmatch.ml @@ -2149,7 +2149,7 @@ let inactive ~partial pat = true | Tpat_constant c -> begin match c with - | Const_string _ -> Config.safe_string + | Const_string _ | Const_int _ | Const_char _ | Const_float _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true end diff --git a/src/ocaml/typing/persistent_env.ml b/src/ocaml/typing/persistent_env.ml index 9b28a17791..42811ee430 100644 --- a/src/ocaml/typing/persistent_env.ml +++ b/src/ocaml/typing/persistent_env.ml @@ -27,7 +27,6 @@ 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) @@ -199,7 +198,6 @@ let save_pers_struct penv crc ps pm = (function | Rectypes -> () | Alerts _ -> () - | Unsafe_string -> () | Opaque -> register_import_as_opaque penv modname) ps.ps_flags; Consistbl.set crc_units modname crc ps.ps_filename; @@ -222,9 +220,6 @@ let acknowledge_pers_struct penv short_path_comps check modname pers_sig pm = | 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; @@ -289,9 +284,6 @@ let check_pers_struct penv f1 f2 ~loc 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 @@ -343,7 +335,6 @@ let make_cmi penv modname sign alerts = 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 @@ -395,11 +386,6 @@ let report_error ppf = fprintf ppf "@[Invalid import of %s, which uses recursive types.@ %s@]" import "The compilation flag -rectypes is required" - | Depend_on_unsafe_string_unit(import) -> - fprintf ppf - "@[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 diff --git a/src/ocaml/typing/persistent_env.mli b/src/ocaml/typing/persistent_env.mli index 60506f4b6a..afcea8ebc6 100644 --- a/src/ocaml/typing/persistent_env.mli +++ b/src/ocaml/typing/persistent_env.mli @@ -24,7 +24,6 @@ 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 diff --git a/src/ocaml/typing/predef.ml b/src/ocaml/typing/predef.ml index 6d28f25f1f..af932a53fd 100644 --- a/src/ocaml/typing/predef.ml +++ b/src/ocaml/typing/predef.ml @@ -96,6 +96,9 @@ 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" +and ident_continuation_already_taken = + ident_create "Continuation_already_taken" +and ident_unhandled = ident_create "Unhandled" let all_predef_exns = [ ident_match_failure; @@ -110,6 +113,8 @@ let all_predef_exns = [ ident_sys_blocked_io; ident_assert_failure; ident_undefined_recursive_module; + ident_continuation_already_taken; + ident_unhandled; ] let path_match_failure = Pident ident_match_failure @@ -155,7 +160,7 @@ let mk_add_type add_type type_ident in add_type type_ident decl env -let common_initial_env add_type add_extension empty_env = +let build_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 = @@ -225,12 +230,14 @@ let common_initial_env add_type add_extension empty_env = ~kind:(fun tvar -> variant [cstr ident_none []; cstr ident_some [tvar]]) |> add_type ident_string + |> add_type ident_bytes |> add_type ident_unit ~immediate:Always ~kind:(variant [cstr ident_void []]) (* Predefined exceptions - alphabetical order *) |> add_extension ident_assert_failure [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_continuation_already_taken [] |> add_extension ident_division_by_zero [] |> add_extension ident_end_of_file [] |> add_extension ident_failure [type_string] @@ -244,13 +251,7 @@ let common_initial_env add_type add_extension empty_env = |> add_extension ident_sys_error [type_string] |> add_extension ident_undefined_recursive_module [newgenty (Ttuple[type_string; type_int; type_int])] - -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) + |> add_extension ident_unhandled [] let builtin_values = List.map (fun id -> (Ident.name id, id)) all_predef_exns diff --git a/src/ocaml/typing/predef.mli b/src/ocaml/typing/predef.mli index 1edbb63ef9..ff67206f62 100644 --- a/src/ocaml/typing/predef.mli +++ b/src/ocaml/typing/predef.mli @@ -74,7 +74,7 @@ val ident_some : Ident.t val build_initial_env: (Ident.t -> type_declaration -> 'a -> 'a) -> (Ident.t -> extension_constructor -> 'a -> 'a) -> - 'a -> 'a * 'a + 'a -> 'a (* To initialize linker tables *) diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml index c3480379d2..d2976712ac 100644 --- a/src/ocaml/typing/printtyped.ml +++ b/src/ocaml/typing/printtyped.ml @@ -13,18 +13,18 @@ (* *) (**************************************************************************) -open Asttypes;; -open Format;; -open Lexing;; -open Location;; -open Typedtree;; +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 () @@ -32,17 +32,17 @@ let fmt_location f loc = 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; -;; + 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_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt let fmt_ident = Ident.print @@ -52,45 +52,40 @@ let fmt_modname f = function 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.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; -;; + 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_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_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; + 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; -;; + 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"; -;; + | 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"; -;; + | 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"; -;; + | Override -> fprintf f "Override" + | Fresh -> fprintf f "Fresh" let fmt_closed_flag f x = match x with @@ -99,35 +94,30 @@ let fmt_closed_flag f x = let fmt_rec_flag f x = match x with - | Nonrecursive -> fprintf f "Nonrec"; - | Recursive -> fprintf f "Rec"; -;; + | 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"; -;; + | 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"; -;; + | 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" | _ :: _ -> line i ppf "[\n"; List.iter (f (i+1) ppf) l; - line i ppf "]\n"; -;; + line i ppf "]\n" let array i f ppf a = if Array.length a = 0 then @@ -137,27 +127,25 @@ let array i f ppf a = 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"; + | None -> line i ppf "None\n" | Some x -> line i ppf "Some\n"; - f (i+1) ppf x; -;; + 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 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 typevars ppf vs = List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs -;; + let record_representation i ppf = let open Types in function | Record_regular -> line i ppf "Record_regular\n" @@ -967,11 +955,11 @@ and label_x_bool_x_core_type_list i ppf x = | 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 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 index 7002986d4a..ae9a6ad4fd 100644 --- a/src/ocaml/typing/printtyped.mli +++ b/src/ocaml/typing/printtyped.mli @@ -13,14 +13,14 @@ (* *) (**************************************************************************) -open Typedtree;; -open Format;; +open Typedtree +open Format -val interface : formatter -> signature -> unit;; -val implementation : formatter -> structure -> unit;; +val interface : formatter -> signature -> unit +val implementation : formatter -> structure -> unit val implementation_with_coercion : - formatter -> Typedtree.implementation -> unit;; + formatter -> Typedtree.implementation -> unit (* Added by merlin for debugging purposes *) val pattern : int -> formatter -> _ general_pattern -> unit diff --git a/src/ocaml/typing/short_paths_graph.ml b/src/ocaml/typing/short_paths_graph.ml index 1b2fbde6ad..5266317120 100644 --- a/src/ocaml/typing/short_paths_graph.ml +++ b/src/ocaml/typing/short_paths_graph.ml @@ -243,8 +243,11 @@ let hidden_name name = 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) + (* if !Clflags.unsafe_string && Ident.equal id Predef.ident_bytes then true + else + + Since 5.0.0 unsafe_string is always false *) + hidden_name (Ident.name id) let hidden_definition deprecated name = match deprecated with diff --git a/src/ocaml/typing/stypes.ml b/src/ocaml/typing/stypes.ml index fed268f0d2..9d4a2ff70f 100644 --- a/src/ocaml/typing/stypes.ml +++ b/src/ocaml/typing/stypes.ml @@ -22,10 +22,10 @@ interesting in case of errors. *) -open Annot;; -open Lexing;; -open Location;; -open Typedtree;; +open Annot +open Lexing +open Location +open Typedtree let output_int oc i = output_string oc (Int.to_string i) @@ -36,7 +36,6 @@ type annotation = | 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 @@ -46,19 +45,16 @@ let get_location ti = | 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 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; -;; + if !Clflags.annotations then phrases := loc :: !phrases (* comparison order: the intervals are sorted by order of increasing upper bound @@ -68,10 +64,9 @@ 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 @@ -86,13 +81,11 @@ let print_position pp pos = 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; -;; + 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 @@ -105,8 +98,7 @@ let sort_filter_phrases () = then loop accu cur t else loop (loc :: accu) loc t in - phrases := loop [] Location.none ph; -;; + phrases := loop [] Location.none ph let rec printtyp_reset_maybe loc = match !phrases with @@ -115,14 +107,12 @@ let rec printtyp_reset_maybe loc = 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 @@ -142,7 +132,6 @@ let print_ident_annot pp str k = 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. *) @@ -184,13 +173,11 @@ let print_info pp prev_loc ti = 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 @@ -206,5 +193,4 @@ let dump filename = phrases := []; end else begin annotations := []; - end; -;; + end diff --git a/src/ocaml/typing/stypes.mli b/src/ocaml/typing/stypes.mli index fda575fc02..3a86d27a57 100644 --- a/src/ocaml/typing/stypes.mli +++ b/src/ocaml/typing/stypes.mli @@ -17,7 +17,7 @@ (* Clflags.save_types must be true *) -open Typedtree;; +open Typedtree type annotation = | Ti_pat : 'k pattern_category * 'k general_pattern -> annotation @@ -26,11 +26,10 @@ type annotation = | 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 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;; +val get_location : annotation -> Location.t +val get_info : unit -> annotation list diff --git a/src/ocaml/typing/tast_mapper.ml b/src/ocaml/typing/tast_mapper.ml index fe7268676e..838d0cd19a 100644 --- a/src/ocaml/typing/tast_mapper.ml +++ b/src/ocaml/typing/tast_mapper.ml @@ -276,7 +276,7 @@ let expr sub x = 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, Kept (t, mut) -> label, Kept (t, mut) | label, Overridden (lid, exp) -> label, Overridden (lid, sub.expr sub exp)) fields diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index f83421683b..91f46fd009 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -307,15 +307,15 @@ let type_object = 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] *) @@ -550,8 +550,7 @@ let reset_pattern allow = pattern_variables := []; pattern_force := []; allow_modules := allow; - module_variables := []; -;; + module_variables := [] let maybe_add_pattern_variables_ghost loc_let env pv = List.fold_right @@ -658,7 +657,9 @@ and build_as_type_aux ~refine (env : Env.t ref) p = 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 + let ty_args, ty_res, _ = + instance_constructor Keep_existentials_flexible cstr + in List.iter2 (fun (p,ty) -> unify_pat ~refine env {p with pat_type = ty}) (List.combine pl tyl) ty_args; ty_res @@ -803,13 +804,22 @@ let solve_Ppat_construct ~refine env loc constr no_existentials match existential_styp with None -> let ty_args, ty_res, _ = - instance_constructor ~in_pattern:(env, expansion_scope) constr in + instance_constructor + (Make_existentials_abstract { env; scope = 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 existential_treatment = + if name_list = [] then + Make_existentials_abstract { env; scope = expansion_scope } + else + (* we will unify them (in solve_constructor_annotation) with the + local types provided by the user *) + Keep_existentials_flexible + in let ty_args, ty_res, ty_ex = - instance_constructor ?in_pattern constr in + instance_constructor existential_treatment 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 @@ -1340,7 +1350,6 @@ let type_label_a_list 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) *) @@ -3394,7 +3403,7 @@ and type_expect_ 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 + Kept (ty_arg1, lbl.lbl_mut) end in let label_definitions = Array.map unify_kept lbl.lbl_all in @@ -4971,7 +4980,9 @@ and type_construct env loc lid sarg ty_expected_explained attrs = (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 (ty_args, ty_res, _) = + instance_constructor Keep_existentials_flexible constr + in let texp = re { exp_desc = Texp_construct(lid, constr, []); diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index 502418335f..653a326359 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/src/ocaml/typing/typedecl.ml @@ -1012,7 +1012,9 @@ let transl_extension_constructor ~scope env type_path type_params 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 (args, cstr_res, _ex) = + Ctype.instance_constructor Keep_existentials_flexible cdescr + in let res, ret_type = if cdescr.cstr_generalized then let params = Ctype.instance_list type_params in diff --git a/src/ocaml/typing/typedecl_unboxed.ml b/src/ocaml/typing/typedecl_unboxed.ml index 10aaa0c523..16290f0fbb 100644 --- a/src/ocaml/typing/typedecl_unboxed.ml +++ b/src/ocaml/typing/typedecl_unboxed.ml @@ -41,4 +41,3 @@ let rec get_unboxed_type_representation env ty fuel = 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/typedtree.ml b/src/ocaml/typing/typedtree.ml index 19c3e15e83..8b8b9a7145 100644 --- a/src/ocaml/typing/typedtree.ml +++ b/src/ocaml/typing/typedtree.ml @@ -163,7 +163,7 @@ and 'k case = } and record_label_definition = - | Kept of Types.type_expr + | Kept of Types.type_expr * mutable_flag | Overridden of Longident.t loc * expression and binding_op = diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli index fffc5186e4..ba840ef71f 100644 --- a/src/ocaml/typing/typedtree.mli +++ b/src/ocaml/typing/typedtree.mli @@ -300,7 +300,7 @@ and 'k case = } and record_label_definition = - | Kept of Types.type_expr + | Kept of Types.type_expr * mutable_flag | Overridden of Longident.t loc * expression and binding_op = diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml index 7020d7d3c1..0acce8e415 100644 --- a/src/ocaml/typing/typemod.ml +++ b/src/ocaml/typing/typemod.ml @@ -115,14 +115,9 @@ let type_open_ ?used_slot ?toplevel ovf env loc lid = ignore (extract_sig_open env lid.loc md.md_type); assert false -let initial_env ~loc ~safe_string ~initially_opened_module +let initial_env ~loc ~initially_opened_module ~open_implicit_modules = - let env = - if safe_string then - Env.initial_safe_string - else - Env.initial_unsafe_string - in + let env = Env.initial in let open_module env m = let open Asttypes in let lid = {loc; txt = Longident.parse m } in @@ -452,7 +447,6 @@ let type_decl_is_alias sdecl = (* assuming no explicit constraint *) | () -> Some lid end | _ -> None -;; let params_are_constrained = let rec loop = function @@ -463,7 +457,6 @@ let params_are_constrained = | _ -> true in loop -;; type with_info = | With_type of Parsetree.type_declaration @@ -3198,13 +3191,17 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = end else begin let sourceintf = Filename.remove_extension sourcefile ^ !Config.interface_suffix in - if Sys.file_exists sourceintf then begin + if !Clflags.cmi_file <> None || 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 + match !Clflags.cmi_file with + | None -> + (try + Load_path.find_uncap (modulename ^ ".cmi") + with Not_found -> + raise(Error(Location.in_file sourcefile, Env.empty, + Interface_not_compiled sourceintf))) + | Some cmi_file -> cmi_file + in let dclsig = Env.read_signature modulename intf_file in let coercion, shape = Includemod.compunit initial_env ~mark:Mark_positive @@ -3234,7 +3231,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = 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 + the values 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. *) let shape = Shape.local_reduce shape in @@ -3314,7 +3311,7 @@ let package_units initial_env objfiles cmifile modulename = 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) + not(Mtype.no_code_needed_sig Env.initial sg) then raise(Error(Location.none, Env.empty, Implementation_is_required f)); (modname, Env.read_signature modname (pref ^ ".cmi"))) diff --git a/src/ocaml/typing/typemod.mli b/src/ocaml/typing/typemod.mli index 6f4075882b..24bccb2cba 100644 --- a/src/ocaml/typing/typemod.mli +++ b/src/ocaml/typing/typemod.mli @@ -68,7 +68,7 @@ val package_units: (* Should be in Envaux, but it breaks the build of the debugger *) val initial_env: - loc:Location.t -> safe_string:bool -> + loc:Location.t -> initially_opened_module:string option -> open_implicit_modules:string list -> Env.t diff --git a/src/ocaml/utils/build_path_prefix_map.ml b/src/ocaml/utils/build_path_prefix_map.ml index c204d3a6b3..65d951f1c3 100644 --- a/src/ocaml/utils/build_path_prefix_map.ml +++ b/src/ocaml/utils/build_path_prefix_map.ml @@ -17,7 +17,7 @@ type path = string type path_prefix = string type error_message = string -let errorf fmt = Printf.kprintf (fun err -> Error err) fmt +let errorf fmt = Printf.ksprintf (fun err -> Error err) fmt let encode_prefix str = let buf = Buffer.create (String.length str) in diff --git a/src/ocaml/utils/clflags.ml b/src/ocaml/utils/clflags.ml index 2c4bd6631e..8cf427497a 100644 --- a/src/ocaml/utils/clflags.ml +++ b/src/ocaml/utils/clflags.ml @@ -1,5 +1,5 @@ (** {0 OCaml compiler compatible command-line parameters} *) - +let cmi_file = ref None let include_dirs = ref [] let fast = ref false let classic = ref false @@ -9,16 +9,6 @@ let recursive_types = ref false let strict_sequence = ref false let applicative_functors = ref true -let unsafe_string = - ref ( - match Merlin_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 [] diff --git a/src/ocaml/utils/clflags.mli b/src/ocaml/utils/clflags.mli index e06b7a4c6b..6294b08de6 100644 --- a/src/ocaml/utils/clflags.mli +++ b/src/ocaml/utils/clflags.mli @@ -6,6 +6,7 @@ (** {1 Relevant settings} Parameters from OCaml compiler which affect Merlin behavior. *) +val cmi_file : string option ref val include_dirs : string list ref val fast : bool ref val classic : bool ref @@ -14,7 +15,6 @@ 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 diff --git a/src/ocaml/utils/config.ml b/src/ocaml/utils/config.ml index 77ed946042..7ed564ea6c 100644 --- a/src/ocaml/utils/config.ml +++ b/src/ocaml/utils/config.ml @@ -51,8 +51,6 @@ and cmt_magic_number = "Caml1999T031" 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 index 3cea743f6c..02713f5086 100644 --- a/src/ocaml/utils/config.mli +++ b/src/ocaml/utils/config.mli @@ -45,7 +45,6 @@ val cmt_magic_number: string 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 (**/**) diff --git a/src/ocaml/utils/diffing.mli b/src/ocaml/utils/diffing.mli index 8fb115feec..80cfa5e279 100644 --- a/src/ocaml/utils/diffing.mli +++ b/src/ocaml/utils/diffing.mli @@ -1,4 +1,3 @@ - (**************************************************************************) (* *) (* OCaml *) diff --git a/src/ocaml/utils/local_store.mli b/src/ocaml/utils/local_store.mli index ebd5069393..94346b96d7 100644 --- a/src/ocaml/utils/local_store.mli +++ b/src/ocaml/utils/local_store.mli @@ -23,7 +23,7 @@ (** {1 Creators} *) val s_ref : 'a -> 'a ref -(** Similar to {!val:ref}, except the allocated reference is registered into +(** Similar to {!Stdlib.ref}, except the allocated reference is registered into the store. *) val s_table : ('a -> 'b) -> 'a -> 'b ref diff --git a/src/ocaml/utils/warnings.ml b/src/ocaml/utils/warnings.ml index bdc931a19c..81657c5efb 100644 --- a/src/ocaml/utils/warnings.ml +++ b/src/ocaml/utils/warnings.ml @@ -107,7 +107,6 @@ type t = | Missing_mli (* 70 *) | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) -;; (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -190,9 +189,11 @@ let number = function | Unused_tmc_attribute -> 71 | Tmc_breaks_tailcall -> 72 ;; +(* DO NOT REMOVE the ;; above: it is used by + the testsuite/ests/warnings/mnemonics.mll test to determine where + the definition of the number function above ends *) let last_warning_number = 72 -;; type description = { number : int; @@ -447,7 +448,6 @@ let descriptions = [ description = "A tail call is turned into a non-tail call \ by the @tail_mod_cons transformation." }; ] -;; let name_to_number = let h = Hashtbl.create last_warning_number in @@ -455,7 +455,6 @@ let name_to_number = List.iter (fun name -> Hashtbl.add h name number) names ) descriptions; fun s -> Hashtbl.find_opt h s -;; (* Must be the max number returned by the [number] function. *) @@ -489,7 +488,6 @@ let letter = function | 'y' -> [26] | 'z' -> [27] | _ -> assert false -;; type state = { @@ -773,7 +771,6 @@ let parse_opt error active errflag s = | '@', Some n -> action Set_all n; None | _ -> parse_and_eval s end -;; let parse_options errflag s = let error = Array.copy (!current).error in @@ -783,11 +780,11 @@ let parse_options errflag s = 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 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 () = 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 @@ -1054,7 +1051,7 @@ let message = function to make its non-tailness explicit." ;; -let nerrors = ref 0;; +let nerrors = ref 0 type reporting_information = { id : string @@ -1116,7 +1113,7 @@ let report_alert (alert : alert) = sub_locs; } -exception Errors;; +exception Errors let reset_fatal () = nerrors := 0 @@ -1125,8 +1122,7 @@ let check_fatal () = if !nerrors > 0 then begin nerrors := 0; raise Errors; - end; -;; + end let help_warnings () = List.iter @@ -1151,7 +1147,6 @@ let help_warnings () = (String.concat ", " (List.map Int.to_string l)) done; exit 0 -;; (* merlin *) @@ -1188,4 +1183,3 @@ let dump ?(verbose=false) () = "alerts", alerts !current.alerts; "alerts_error", alerts !current.alert_errors; ] -;; diff --git a/src/ocaml/utils/warnings.mli b/src/ocaml/utils/warnings.mli index 4691427df0..79f9f97372 100644 --- a/src/ocaml/utils/warnings.mli +++ b/src/ocaml/utils/warnings.mli @@ -109,11 +109,10 @@ type t = | Missing_mli (* 70 *) | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) -;; type alert = {kind:string; message:string; def:loc; use:loc} -val parse_options : bool -> string -> alert option;; +val parse_options : bool -> string -> alert option val parse_alert_option: string -> unit (** Disable/enable alerts based on the parameter to the -alert @@ -124,11 +123,11 @@ val parse_alert_option: string -> unit 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 is_active : t -> bool +val is_error : t -> bool -val defaults_w : string;; -val defaults_warn_error : string;; +val defaults_w : string +val defaults_warn_error : string type reporting_information = { id : string @@ -140,9 +139,9 @@ type reporting_information = val report : t -> [ `Active of reporting_information | `Inactive ] val report_alert : alert -> [ `Active of reporting_information | `Inactive ] -exception Errors;; +exception Errors -val check_fatal : unit -> unit;; +val check_fatal : unit -> unit val reset_fatal: unit -> unit val help_warnings: unit -> unit diff --git a/src/utils/misc.ml b/src/utils/misc.ml index 1c1c2f4093..9b7d4b4170 100644 --- a/src/utils/misc.ml +++ b/src/utils/misc.ml @@ -271,9 +271,9 @@ let find_in_path_uncap ?(fallback="") path name = 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" + else + let () = Logger.log + ~section:"locate" ~title:"find_in_path_uncap" "Failed to load %s/%s" dirname name in @@ -640,7 +640,6 @@ module Color = struct | Magenta | Cyan | White - ;; type style = | FG of color (* foreground *) diff --git a/src/utils/misc.mli b/src/utils/misc.mli index 2d8e0fde11..3e0ee0208b 100644 --- a/src/utils/misc.mli +++ b/src/utils/misc.mli @@ -139,7 +139,7 @@ val output_to_file_via_temporary: the channel is closed and the temporary file is renamed to [filename]. *) -val input_bytes : in_channel -> int -> bytes;; +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. *) @@ -326,7 +326,6 @@ module Color : sig | Magenta | Cyan | White - ;; type style = | FG of color (* foreground *) From 21365b818eed200f48d2ea81194feeecb125b1ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 10 Mar 2022 18:04:30 +0100 Subject: [PATCH 004/130] Update CI and opam file --- .github/workflows/main.yml | 2 +- merlin.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 6361d80070..635a80b9f2 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -40,7 +40,7 @@ jobs: - ubuntu-latest - windows-latest ocaml-compiler: - - 4.14.x + - ocaml-variants.5.0.0+trunk # The type of runner that the job will run on runs-on: ${{ matrix.os }} diff --git a/merlin.opam b/merlin.opam index 907a1b3aa8..9d6cdcff41 100644 --- a/merlin.opam +++ b/merlin.opam @@ -11,7 +11,7 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] depends: [ - "ocaml" {>= "4.14" & < "4.15"} + "ocaml" {>= "5.0" & < "5.1"} "dune" {>= "2.9.0"} "merlin-lib" {= version} "dot-merlin-reader" {>= "4.9"} From d5b9598b656109acda9b528e00bfd0751b71f9da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 11 Mar 2022 12:12:51 +0100 Subject: [PATCH 005/130] Add OCaml 5.0.0 version to gen_config --- src/config/gen_config.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/config/gen_config.ml b/src/config/gen_config.ml index 9919271aa3..56d0c0cb7a 100644 --- a/src/config/gen_config.ml +++ b/src/config/gen_config.ml @@ -17,5 +17,5 @@ let ocamlversion : | `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 - | `OCaml_4_14_0 ] = %s + | `OCaml_4_14_0 | `OCaml_5_0_0 ] = %s |} ocaml_version_val From de1c084cf474f7214304777bb84dece5be0e5885 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 11 Mar 2022 12:13:32 +0100 Subject: [PATCH 006/130] Compat with 5.0.0 --- src/utils/std.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/utils/std.ml b/src/utils/std.ml index 433e1b9527..582a9cf070 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -453,11 +453,11 @@ module String = struct [_ascii] version. *) [@@@ocaml.warning "-3"] - let capitalize = capitalize - let uncapitalize = uncapitalize + let capitalize = capitalize_ascii + let uncapitalize = uncapitalize_ascii - let lowercase = lowercase - let uppercase = uppercase + let lowercase = lowercase_ascii + let uppercase = uppercase_ascii let split_on_char_ c s = match String.index s c with @@ -623,8 +623,8 @@ module Char = struct [@@@ocaml.warning "-3"] include Char - let is_lowercase c = lowercase c = c - let is_uppercase c = uppercase c = c + let is_lowercase c = lowercase_ascii c = c + let is_uppercase c = uppercase_ascii c = c let is_strictly_lowercase c = not (is_uppercase c) let is_strictly_uppercase c = not (is_lowercase c) end From 0b53f2a1bd2486f195e12ccb49a05fbe055bf0fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 11 Mar 2022 12:14:01 +0100 Subject: [PATCH 007/130] Test update --- tests/test-dirs/occurrences/issue1404.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/test-dirs/occurrences/issue1404.t b/tests/test-dirs/occurrences/issue1404.t index 10098869e8..6be194cb13 100644 --- a/tests/test-dirs/occurrences/issue1404.t +++ b/tests/test-dirs/occurrences/issue1404.t @@ -83,7 +83,7 @@ locate position 2:1 returns the definition of [(+)] { "file": "lib/ocaml/stdlib.mli", "pos": { - "line": 347, + "line": 335, "col": 0 } } From 9a76e84fe760e755e53bdd060f6b105615401a68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 23 Jun 2022 11:34:59 +0200 Subject: [PATCH 008/130] Update Merlin lib ocaml version --- merlin-lib.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/merlin-lib.opam b/merlin-lib.opam index 1a9eb26aa1..b22d70774c 100644 --- a/merlin-lib.opam +++ b/merlin-lib.opam @@ -10,7 +10,7 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "ocaml" {>= "4.14" & < "4.15"} + "ocaml" {>= "5.0" & < "5.1"} "dune" {>= "2.9.0"} "csexp" {>= "1.5.1"} "menhir" {dev & >= "20201216"} From a9d4f0dd2b65163a1de0ccba630e87e6f97c124d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 23 Jun 2022 16:15:24 +0200 Subject: [PATCH 009/130] Update upstream 5.0 to 2b2bd86c61c1f06b68c7db214bd88474ed28d3fc --- upstream/ocaml_500/base-rev.txt | 2 +- upstream/ocaml_500/parsing/ast_iterator.mli | 7 +- upstream/ocaml_500/parsing/ast_mapper.ml | 11 +- upstream/ocaml_500/parsing/asttypes.mli | 4 +- upstream/ocaml_500/parsing/location.ml | 30 +- upstream/ocaml_500/parsing/location.mli | 7 + upstream/ocaml_500/parsing/parsetree.mli | 990 ++++++++-------- upstream/ocaml_500/parsing/pprintast.ml | 10 +- upstream/ocaml_500/typing/ctype.ml | 47 +- upstream/ocaml_500/typing/ctype.mli | 8 +- upstream/ocaml_500/typing/ident.ml | 13 + upstream/ocaml_500/typing/ident.mli | 31 +- upstream/ocaml_500/typing/typeclass.ml | 40 +- upstream/ocaml_500/typing/typecore.ml | 31 +- upstream/ocaml_500/typing/typedecl.ml | 4 +- upstream/ocaml_500/typing/typemod.ml | 15 +- upstream/ocaml_500/typing/types.ml | 2 + upstream/ocaml_500/utils/Makefile | 118 -- upstream/ocaml_500/utils/ccomp.ml | 8 +- upstream/ocaml_500/utils/clflags.ml | 1 + upstream/ocaml_500/utils/clflags.mli | 1 + upstream/ocaml_500/utils/config.common.ml | 162 +++ upstream/ocaml_500/utils/config.fixed.ml | 70 ++ upstream/ocaml_500/utils/config.mli | 3 - upstream/ocaml_500/utils/config.mlp | 176 +-- upstream/ocaml_500/utils/diffing.mli | 3 +- upstream/ocaml_500/utils/load_path.ml | 74 +- upstream/ocaml_500/utils/load_path.mli | 49 +- upstream/ocaml_500/utils/local_store.mli | 10 +- upstream/ocaml_500/utils/misc.mli | 6 +- upstream/ocaml_500/utils/misc.mli.orig | 673 ----------- upstream/ocaml_500/utils/warnings.ml | 276 +++-- upstream/ocaml_500/utils/warnings.ml.orig | 1137 ------------------- upstream/ocaml_500/utils/warnings.mli | 6 +- 34 files changed, 1257 insertions(+), 2768 deletions(-) delete mode 100644 upstream/ocaml_500/utils/Makefile create mode 100644 upstream/ocaml_500/utils/config.common.ml create mode 100644 upstream/ocaml_500/utils/config.fixed.ml delete mode 100644 upstream/ocaml_500/utils/misc.mli.orig delete mode 100644 upstream/ocaml_500/utils/warnings.ml.orig diff --git a/upstream/ocaml_500/base-rev.txt b/upstream/ocaml_500/base-rev.txt index 767843f768..f9a215ed0f 100644 --- a/upstream/ocaml_500/base-rev.txt +++ b/upstream/ocaml_500/base-rev.txt @@ -1 +1 @@ -c3a5ebd4926ac0c8cde7c512fa1f350134b27b58 +2b2bd86c61c1f06b68c7db214bd88474ed28d3fc diff --git a/upstream/ocaml_500/parsing/ast_iterator.mli b/upstream/ocaml_500/parsing/ast_iterator.mli index 26308d20de..638ac5e8b6 100644 --- a/upstream/ocaml_500/parsing/ast_iterator.mli +++ b/upstream/ocaml_500/parsing/ast_iterator.mli @@ -13,9 +13,10 @@ (* *) (**************************************************************************) -(** {!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. +(** {!Ast_iterator.iterator} enables AST inspection using open recursion. A + typical mapper would be based on {!Ast_iterator.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}. diff --git a/upstream/ocaml_500/parsing/ast_mapper.ml b/upstream/ocaml_500/parsing/ast_mapper.ml index f6c992ba45..23e206ad74 100644 --- a/upstream/ocaml_500/parsing/ast_mapper.ml +++ b/upstream/ocaml_500/parsing/ast_mapper.ml @@ -903,7 +903,16 @@ module PpxContext = struct | "include_dirs" -> Clflags.include_dirs := get_list get_string payload | "load_path" -> - Load_path.init (get_list get_string payload) + (* Duplicates Compmisc.auto_include, since we can't reference Compmisc + from this module. *) + let auto_include find_in_dir fn = + if !Clflags.no_std_include then + raise Not_found + else + let alert = Location.auto_include_alert in + Load_path.auto_include_otherlibs alert find_in_dir fn + in + Load_path.init ~auto_include (get_list get_string payload) | "open_modules" -> Clflags.open_modules := get_list get_string payload | "for_package" -> diff --git a/upstream/ocaml_500/parsing/asttypes.mli b/upstream/ocaml_500/parsing/asttypes.mli index f4745fb7ab..7a4f1c1913 100644 --- a/upstream/ocaml_500/parsing/asttypes.mli +++ b/upstream/ocaml_500/parsing/asttypes.mli @@ -48,8 +48,8 @@ type label = string type arg_label = Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) + | Labelled of string (** [label:T -> ...] *) + | Optional of string (** [?label:T -> ...] *) type 'a loc = 'a Location.loc = { txt : 'a; diff --git a/upstream/ocaml_500/parsing/location.ml b/upstream/ocaml_500/parsing/location.ml index 209797a3f5..424324d913 100644 --- a/upstream/ocaml_500/parsing/location.ml +++ b/upstream/ocaml_500/parsing/location.ml @@ -18,9 +18,7 @@ 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 in_file = Warnings.ghost_loc_in_file let none = in_file "_none_" let is_none l = (l = none) @@ -897,6 +895,32 @@ let alert ?(def = none) ?(use = none) ~kind loc message = let deprecated ?def ?use loc message = alert ?def ?use ~kind:"deprecated" loc message +let auto_include_alert lib = + let message = Printf.sprintf "\ + OCaml's lib directory layout changed in 5.0. The %s subdirectory has been \ + automatically added to the search path, but you should add -I +%s to the \ + command-line to silence this alert (e.g. by adding %s to the list of \ + libraries in your dune file, or adding use_%s to your _tags file for \ + ocamlbuild, or using -package %s for ocamlfind)." lib lib lib lib lib in + let alert = + {Warnings.kind="ocaml_deprecated_auto_include"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + +let deprecated_script_alert program = + let message = Printf.sprintf "\ + Running %s where the first argument is an implicit basename with no \ + extension (e.g. %s script-file) is deprecated. Either rename the script \ + (%s script-file.ml) or qualify the basename (%s ./script-file)" + program program program program + in + let alert = + {Warnings.kind="ocaml_deprecated_cli"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + (******************************************************************************) (* Reporting errors on exceptions *) diff --git a/upstream/ocaml_500/parsing/location.mli b/upstream/ocaml_500/parsing/location.mli index 5ba80b04da..d68710020b 100644 --- a/upstream/ocaml_500/parsing/location.mli +++ b/upstream/ocaml_500/parsing/location.mli @@ -243,6 +243,13 @@ val deprecated: ?def:t -> ?use:t -> t -> string -> unit val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit (** Prints an arbitrary alert. *) +val auto_include_alert: string -> unit +(** Prints an alert that -I +lib has been automatically added to the load + path *) + +val deprecated_script_alert: string -> unit +(** [deprecated_script_alert command] prints an alert that [command foo] has + been deprecated in favour of [command ./foo] *) (** {1 Reporting errors} *) diff --git a/upstream/ocaml_500/parsing/parsetree.mli b/upstream/ocaml_500/parsing/parsetree.mli index e806a16091..d0e64bd4fd 100644 --- a/upstream/ocaml_500/parsing/parsetree.mli +++ b/upstream/ocaml_500/parsing/parsetree.mli @@ -23,22 +23,21 @@ open Asttypes type constant = - Pconst_integer of string * char option - (* 3 3l 3L 3n + | Pconst_integer of string * char option + (** Integer constants such as [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 + 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_char of char (** Character such as ['c']. *) | Pconst_string of string * Location.t * string option - (* "constant" - {delim|other constant|delim} + (** Constant string such as ["constant"] or + [{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 + (** Float constant such as [3.4], [2e5] or [1.4e-4]. Suffixes [g-z][G-Z] are accepted by the parser. Suffixes are rejected by the typechecker. @@ -53,16 +52,14 @@ type attribute = { attr_payload : payload; attr_loc : Location.t; } - (* [@id ARG] - [@@id ARG] +(** Attributes such as [[\@id ARG]] and [[\@\@id ARG]]. Metadata containers passed around within the AST. The compiler ignores unknown attributes. *) and extension = string loc * payload - (* [%id ARG] - [%%id ARG] +(** Extension points such as [[%id ARG] and [%%id ARG]]. Sub-language placeholder -- rejected by the typechecker. *) @@ -71,90 +68,111 @@ 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 *) + | PSig of signature (** [: SIG] in an attribute or an extension point *) + | PTyp of core_type (** [: T] in an attribute or an extension point *) + | PPat of pattern * expression option + (** [? P] or [? P when E], in an attribute or an extension point *) (** {1 Core language} *) - -(* Type expressions *) +(** {2 Type expressions} *) and core_type = { ptyp_desc: core_type_desc; ptyp_loc: Location.t; ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) + ptyp_attributes: attributes; (** [... [\@id1] [\@id2]] *) } and core_type_desc = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) + | Ptyp_any (** [_] *) + | Ptyp_var of string (** A type variable such as ['a] *) | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional + (** [Ptyp_arrow(lbl, T1, T2)] represents: + - [T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Labelled}[Labelled]}, + - [?l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Optional}[Optional]}. *) | Ptyp_tuple of core_type list - (* T1 * ... * Tn + (** [Ptyp_tuple([T1 ; ... ; Tn])] + represents a product type [T1 * ... * Tn]. - Invariant: n >= 2 + Invariant: [n >= 2]. *) | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr + (** [Ptyp_constr(lident, l)] represents: + - [tconstr] when [l=[]], + - [T tconstr] when [l=[T]], + - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. *) | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) + (** [Ptyp_object([ l1:T1; ...; ln:Tn ], flag)] represents: + - [< l1:T1; ...; ln:Tn >] when [flag] is + {{!Asttypes.closed_flag.Closed}[Closed]}, + - [< l1:T1; ...; ln:Tn; .. >] when [flag] is + {{!Asttypes.closed_flag.Open}[Open]}. *) | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr + (** [Ptyp_class(tconstr, l)] represents: + - [#tconstr] when [l=[]], + - [T #tconstr] when [l=[T]], + - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. *) - | Ptyp_alias of core_type * string - (* T as 'a *) + | 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_variant([`A;`B], flag, labels)] represents: + - [[ `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [None], + - [[> `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]}, + and [labels] is [None], + - [[< `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some []], + - [[< `A|`B > `X `Y ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some ["X";"Y"]]. *) | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T + (** ['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 ... + - As the {!core_type} of a + {{!pattern_desc.Ppat_constraint}[Ppat_constraint]} node corresponding + to a constraint on a let-binding: + {[let x : 'a1 ... 'an. T = e ...]} - - Under Cfk_virtual for methods (not values). + - Under {{!class_field_kind.Cfk_virtual}[Cfk_virtual]} for methods + (not values). - - As the core_type of a Pctf_method node. + - As the {!core_type} of a + {{!class_type_field_desc.Pctf_method}[Pctf_method]} node. - - As the core_type of a Pexp_poly node. + - As the {!core_type} of a {{!expression_desc.Pexp_poly}[Pexp_poly]} + node. - - As the pld_type field of a label_declaration. + - As the {{!label_declaration.pld_type}[pld_type]} field of a + {!label_declaration}. - - As a core_type of a Ptyp_object node. + - As a {!core_type} of a {{!core_type_desc.Ptyp_object}[Ptyp_object]} + node. - - As the pval_type field of a value_description. + - As the {{!value_description.pval_type}[pval_type]} field of a + {!value_description}. *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) + | 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) +(** As {!package_type} typed values: + - [(S, [])] represents [(module S)], + - [(S, [(t1, T1) ; ... ; (tn, Tn)])] + represents [(module S with type t1 = T1 and ... and tn = Tn)]. *) and row_field = { @@ -165,18 +183,18 @@ and row_field = { 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] ) + (** [Rtag(`A, b, l)] represents: + - [`A] when [b] is [true] and [l] is [[]], + - [`A of T] when [b] is [false] and [l] is [[T]], + - [`A of T1 & .. & Tn] when [b] is [false] and [l] is [[T1;...Tn]], + - [`A of & T1 & .. & Tn] when [b] is [true] and [l] is [[T1;...Tn]]. - - The 'bool' field is true if the tag contains a + - The [bool] field is true if the tag contains a constant (empty) constructor. - - '&' occurs when several types are used for the same constructor + - [&] occurs when several types are used for the same constructor (see 4.2 in the manual) *) - | Rinherit of core_type - (* [ | t ] *) + | Rinherit of core_type (** [[ | t ]] *) and object_field = { pof_desc : object_field_desc; @@ -188,214 +206,224 @@ and object_field_desc = | Otag of label loc * core_type | Oinherit of core_type -(* Patterns *) +(** {2 Patterns} *) and pattern = { ppat_desc: pattern_desc; ppat_loc: Location.t; ppat_loc_stack: location_stack; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) + ppat_attributes: attributes; (** [... [\@id1] [\@id2]] *) } and pattern_desc = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) + | Ppat_any (** The pattern [_]. *) + | Ppat_var of string loc (** A variable pattern such as [x] *) | Ppat_alias of pattern * string loc - (* P as 'a *) + (** An alias pattern such as [P as 'a] *) | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) | Ppat_interval of constant * constant - (* 'a'..'z' + (** Patterns such as ['a'..'z']. Other forms of interval are recognized by the parser but rejected by the type-checker. *) | Ppat_tuple of pattern list - (* (P1, ..., Pn) + (** Patterns [(P1, ..., Pn)]. - Invariant: n >= 2 + 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_construct of Longident.t loc * (string loc list * pattern) option + (** [Ppat_construct(C, args)] represents: + - [C] when [args] is [None], + - [C P] when [args] is [Some ([], P)] + - [C (P1, ..., Pn)] when [args] is + [Some ([], Ppat_tuple [P1; ...; Pn])] + - [C (type a b) P] when [args] is [Some ([a; b], P)] *) | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) + (** [Ppat_variant(`A, pat)] represents: + - [`A] when [pat] is [None], + - [`A P] when [pat] is [Some P] *) | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) + (** [Ppat_record([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: + - [{ l1=P1; ...; ln=Pn }] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]} + - [{ l1=P1; ...; ln=Pn; _}] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]} - Invariant: n > 0 + 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_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) + | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) + | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) + | Ppat_type of Longident.t loc (** Pattern [#tconst] *) + | Ppat_lazy of pattern (** Pattern [lazy P] *) | Ppat_unpack of string option loc - (* (module P) Some "P" - (module _) None + (** [Ppat_unpack(s)] represents: + - [(module P)] when [s] is [Some "P"] + - [(module _)] when [s] is [None] - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) + Note: [(module P : S)] is represented as + [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) + | Ppat_exception of pattern (** Pattern [exception P] *) + | Ppat_extension of extension (** Pattern [[%id]] *) + | Ppat_open of Longident.t loc * pattern (** Pattern [M.(P)] *) -(* Value expressions *) +(** {2 Value expressions} *) and expression = { pexp_desc: expression_desc; pexp_loc: Location.t; pexp_loc_stack: location_stack; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) + pexp_attributes: attributes; (** [... [\@id1] [\@id2]] *) } and expression_desc = | Pexp_ident of Longident.t loc - (* x - M.x + (** Identifiers such as [x] and [M.x] *) | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + (** Expressions constant such as [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_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: + - [let P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) + | 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) + (** [Pexp_fun(lbl, exp0, P, E1)] represents: + - [fun P -> E1] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [fun ~l:P -> E1] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [fun ?l:P -> E1] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [fun ?l:(P = E0) -> E1] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [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. + - If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + - [fun P1 P2 .. Pn -> E1] is represented as nested + {{!expression_desc.Pexp_fun}[Pexp_fun]}. + - [let f P = E] is represented using + {{!expression_desc.Pexp_fun}[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). + (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] + represents [E0 ~l1:E1 ... ~ln:En] - Invariant: n > 0 + [li] can be + {{!Asttypes.arg_label.Nolabel}[Nolabel]} (non labeled argument), + {{!Asttypes.arg_label.Labelled}[Labelled]} (labelled arguments) or + {{!Asttypes.arg_label.Optional}[Optional]} (optional argument). + + Invariant: [n > 0] *) | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) + (** [match E0 with P1 -> E1 | ... | Pn -> En] *) | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) + (** [try E0 with P1 -> E1 | ... | Pn -> En] *) | Pexp_tuple of expression list - (* (E1, ..., En) + (** Expressions [(E1, ..., En)] - Invariant: n >= 2 + 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_construct(C, exp)] represents: + - [C] when [exp] is [None], + - [C E] when [exp] is [Some E], + - [C (E1, ..., En)] when [exp] is [Some (Pexp_tuple[E1;...;En])] *) | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) + (** [Pexp_variant(`A, exp)] represents + - [`A] when [exp] is [None] + - [`A E] when [exp] is [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) + (** [Pexp_record([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents + - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] + - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] - Invariant: n > 0 + Invariant: [n > 0] *) - | Pexp_field of expression * Longident.t loc - (* E.l *) + | 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 |] *) + (** [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) + (** [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 + (** [Pexp_for(i, E1, E2, direction, E3)] represents: + - [for i = E1 to E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Upto}[Upto]} + - [for i = E1 downto E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} *) - | Pexp_constraint of expression * core_type - (* (E : T) *) + | 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_coerce(E, from, T)] represents + - [(E :> T)] when [from] is [None], + - [(E : T0 :> T)] when [from] is [Some T0]. *) - | 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_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 >} *) + (** [{< x1 = E1; ...; xn = En >}] *) | Pexp_letmodule of string option loc * module_expr * expression - (* let module M = ME in E *) + (** [let module M = ME in E] *) | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) + (** [let exception C in E] *) | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the + (** [assert E]. + + Note: [assert false] is treated in a special way by the type-checker. *) - | Pexp_lazy of expression - (* lazy E *) + | 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 *) + (** Used for method bodies. + + Can only be used as the expression under + {{!class_field_kind.Cfk_concrete}[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)]. - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) + [(module ME : S)] is represented as + [Pexp_constraint(Pexp_pack ME, Ptyp_package S)] *) | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let open! M in E *) + (** - [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) *) + (** - [let* P = E0 in E1] + - [let* P0 = E00 and* P1 = E01 in E1] *) + | Pexp_extension of extension (** [[%id]] *) + | Pexp_unreachable (** [.] *) + +and case = { pc_lhs: pattern; pc_guard: expression option; pc_rhs: expression; } +(** Values of type {!case} represents [(P -> E)] or [(P when E0 -> E)] *) and letop = { @@ -412,53 +440,68 @@ and binding_op = pbop_loc : Location.t; } -(* Value descriptions *) +(** {2 Value descriptions} *) and value_description = { pval_name: string loc; pval_type: core_type; pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) + pval_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pval_loc: Location.t; } - -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +(** Values of type {!value_description} represents: + - [val x: T], + when {{!value_description.pval_prim}[pval_prim]} is [[]] + - [external x: T = "s1" ... "sn"] + when {{!value_description.pval_prim}[pval_prim]} is [["s1";..."sn"]] *) -(* Type declarations *) +(** {2 Type declarations} *) and type_declaration = { ptype_name: string loc; ptype_params: (core_type * (variance * injectivity)) list; - (* ('a1,...'an) t; None represents _*) + (** [('a1,...'an) t] *) ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) + (** [... 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_private: private_flag; (** for [= private ...] *) + ptype_manifest: core_type option; (** represents [= 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) +(** + Here are type declarations and their representation, + for various {{!type_declaration.ptype_kind}[ptype_kind]} + and {{!type_declaration.ptype_manifest}[ptype_manifest]} values: + - [type t] when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [None], + - [type t = T0] + when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [Some T0], + - [type t = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [None], + - [type t = T0 = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [Some T0], + - [type t = {l: T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [None], + - [type t = T0 = {l : T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [Some T0], + - [type t = ..] + when [type_kind] is {{!type_kind.Ptype_open}[Ptype_open]}, + and [manifest] is [None]. *) and type_kind = | Ptype_abstract | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) + | Ptype_record of label_declaration list (** Invariant: non-empty list *) | Ptype_open and label_declaration = @@ -467,13 +510,17 @@ and label_declaration = pld_mutable: mutable_flag; pld_type: core_type; pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) + pld_attributes: attributes; (** [l : T [\@id1] [\@id2]] *) } - -(* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. +(** + - [{ ...; l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Immutable}[Immutable]}, + - [{ ...; mutable l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Mutable}[Mutable]}. + + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. *) and constructor_declaration = @@ -483,20 +530,24 @@ and constructor_declaration = pcd_args: constructor_arguments; pcd_res: core_type option; pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) + 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) + (** Values of type {!constructor_declaration} + represents the constructor arguments of: + - [C of T1 * ... * Tn] when [res = None], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C: T0] when [res = Some T0], + and [args = Pcstr_tuple []], + - [C: T1 * ... * Tn -> T0] when [res = Some T0], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C of {...}] when [res = None], + and [args = Pcstr_record [...]], + - [C: {...} -> T0] when [res = Some T0], + and [args = Pcstr_record [...]]. *) and type_extension = @@ -506,100 +557,110 @@ and type_extension = ptyext_constructors: extension_constructor list; ptyext_private: private_flag; ptyext_loc: Location.t; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptyext_attributes: attributes; (** ... [\@\@id1] [\@\@id2] *) } -(* - type t += ... +(** + Definition of new extensions constructors for the extensive sum type [t] + ([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] *) + 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] *) + ptyexn_constructor : extension_constructor; + ptyexn_loc : Location.t; + ptyexn_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) } +(** Definition of a new exception ([exception E]). *) and extension_constructor_kind = - Pext_decl of string loc list * constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([], [T1; ...; Tn], None) - | C: T0 ([], [], Some T0) - | C: T1 * ... * Tn -> T0 ([], [T1; ...; Tn], Some T0) - | C: 'a... . T1... -> T0 (['a;...]; [T1;...], Some T0) + | Pext_decl of string loc list * constructor_arguments * core_type option + (** [Pext_decl(existentials, c_args, t_opt)] + describes a new extension constructor. It can be: + - [C of T1 * ... * Tn] when: + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [None]}.} + - [C: T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[]],} + {- [t_opt] is [Some T0].}} + - [C: T1 * ... * Tn -> T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [Some T0].}} + - [C: 'a... . T1 * ... * Tn -> T0] when + {ul {- [existentials] is [['a;...]],} + {- [c_args] is [[T1; ... ; Tn]],} + {- [t_opt] is [Some T0].}} *) | Pext_rebind of Longident.t loc - (* - | C = D - *) + (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) (** {1 Class language} *) - -(* Type expressions for the class language *) +(** {2 Type expressions for the class language} *) and class_type = { pcty_desc: class_type_desc; pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) + 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 *) + (** - [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_arrow(lbl, T, CT)] represents: + - [T -> CT] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]}, + - [?l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}. *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type - (* let open M in CT *) + | 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) - *) +(** Values of type [class_signature] represents: + - [object('selfpat) ... end] + - [object ... end] when {{!class_signature.pcsig_self}[pcsig_self]} + is {{!core_type_desc.Ptyp_any}[Ptyp_any]} +*) and class_type_field = { pctf_desc: class_type_field_desc; pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) + pctf_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) } and class_type_field_desc = - | Pctf_inherit of class_type - (* inherit CT *) + | 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 + (** [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] *) + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[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 = { @@ -608,98 +669,126 @@ and 'a class_infos = pci_name: string loc; pci_expr: 'a; pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) + pci_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) } -(* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... +(** Values of type [class_expr class_infos] represents: + - [class c = ...] + - [class ['a1,...,'an] c = ...] + - [class virtual c = ...] - Also used for "class type" declaration. + They are 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 *) +(** {2 Value expressions for the class language} *) and class_expr = { pcl_desc: class_expr_desc; pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) + 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 *) + (** [c] and [['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_fun(lbl, exp0, P, CE)] represents: + - [fun P -> CE] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None], + - [fun ~l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None], + - [fun ?l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None], + - [fun ?l:(P = E0) -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [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). + (** [Pcl_apply(CE, [(l1,E1) ; ... ; (ln,En)])] + represents [CE ~l1:E1 ... ~ln:En]. + [li] can be empty (non labeled argument) or start with [?] + (optional argument). - Invariant: n > 0 - *) + 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 *) - + (** [Pcl_let(rec, [(P1, E1); ... ; (Pn, En)], CE)] represents: + - [let P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Recursive}[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) - *) +(** Values of type {!class_structure} represents: + - [object(selfpat) ... end] + - [object ... end] when {{!class_structure.pcstr_self}[pcstr_self]} + is {{!pattern_desc.Ppat_any}[Ppat_any]} +*) and class_field = { pcf_desc: class_field_desc; pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) + 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_inherit(flag, CE, s)] represents: + - [inherit CE] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [None], + - [inherit CE as x] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [Some x], + - [inherit! CE] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [None], + - [inherit! CE as x] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [Some x] + *) | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) + (** [Pcf_val(x,flag, kind)] represents: + - [val x = E] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + - [val mutable x = E] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val mutable virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(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] *) + (** - [method x = E] + ([E] can be a {{!expression_desc.Pexp_poly}[Pexp_poly]}) + - [method virtual x: T] + ([T] can be a {{!core_type_desc.Ptyp_poly}[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 @@ -708,38 +797,31 @@ and class_field_kind = and class_declaration = class_expr class_infos (** {1 Module language} *) - -(* Type expressions for the module language *) +(** {2 Type expressions for the module language} *) and module_type = { pmty_desc: module_type_desc; pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) + pmty_attributes: attributes; (** [... [\@id1] [\@id2]] *) } and module_type_desc = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) + | Pmty_ident of Longident.t loc (** [Pmty_ident(S)] represents [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) *) + (** [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 - (* () *) + | Unit (** [()] *) | Named of string option loc * module_type - (* (X : MT) Some X, MT - (_ : MT) None, MT *) + (** [Named(name, MT)] represents: + - [(X : MT)] when [name] is [Some X], + - [(_ : MT)] when [name] is [None] *) and signature = signature_item list @@ -751,70 +833,61 @@ and signature_item = and signature_item_desc = | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" + (** - [val x: T] + - [external x: T = "s1" ... "sn"] *) | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) + (** [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 *) + (** [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] and [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 *) + (** [module rec X1 : MT1 and ... and Xn : MTn] *) | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) + (** [module type S = MT] and [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 *) + (** [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 : ... *) + (** [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] *) + (** [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_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pmd_loc: Location.t; } -(* S : MT *) +(** Values of type [module_declaration] represents [S : MT] *) and module_substitution = { pms_name: string loc; pms_manifest: Longident.t loc; - pms_attributes: attributes; (* ... [@@id1] [@@id2] *) + pms_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pms_loc: Location.t; } -(* S := M *) +(** Values of type [module_substitution] represents [S := M] *) and module_type_declaration = { pmtd_name: string loc; pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmtd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) pmtd_loc: Location.t; } -(* S = MT - S (abstract module type declaration, pmtd_type = None) +(** Values of type [module_type_declaration] represents: + - [S = MT], + - [S] for abstract module type declaration, + when {{!module_type_declaration.pmtd_type}[pmtd_type]} is [None]. *) and 'a open_infos = @@ -824,19 +897,24 @@ and 'a open_infos = popen_loc: Location.t; popen_attributes: attributes; } -(* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) +(** Values of type ['a open_infos] represents: + - [open! X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Override}[Override]} + (silences the "used identifier shadowing" warning) + - [open X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Fresh}[Fresh]} +*) and open_description = Longident.t loc open_infos -(* open M.N - open M(N).O *) +(** Values of type [open_description] represents: + - [open M.N] + - [open M(N).O] *) and open_declaration = module_expr open_infos -(* open M.N - open M(N).O - open struct ... end *) +(** Values of type [open_declaration] represents: + - [open M.N] + - [open M(N).O] + - [open struct ... end] *) and 'a include_infos = { @@ -846,52 +924,46 @@ and 'a include_infos = } and include_description = module_type include_infos -(* include MT *) +(** Values of type [include_description] represents [include MT] *) and include_declaration = module_expr include_infos -(* include ME *) +(** Values of type [include_declaration] represents [include ME] *) and with_constraint = | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... + (** [with type X.t = ...] - Note: the last component of the longident must match - the name of the type_declaration. *) + 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 *) + (** [with module X.Y = Z] *) | Pwith_modtype of Longident.t loc * module_type - (* with module type X.Y = Z *) + (** [with module type X.Y = Z] *) | Pwith_modtypesubst of Longident.t loc * module_type - (* with module type X.Y := sig end *) + (** [with module type X.Y := sig end] *) | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) + (** [with type X.t := ..., same format as [Pwith_type]] *) | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) + (** [with module X.Y := Z] *) -(* Value expressions for the module language *) +(** {2 Value expressions for the module language} *) and module_expr = { pmod_desc: module_expr_desc; pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) + pmod_attributes: attributes; (** [... [\@id1] [\@id2]] *) } and module_expr_desc = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) + | 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] *) + (** [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 @@ -902,40 +974,35 @@ and structure_item = } and structure_item_desc = - | Pstr_eval of expression * attributes - (* E *) + | 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_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: + - [let P1 = E1 and ... and Pn = EN] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN ] + when [rec] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) + (** - [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 += ... *) + (** [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 *) + (** - [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 *) + (** [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 = ... *) + (** [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] *) + (** [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 = { @@ -952,28 +1019,27 @@ and module_binding = pmb_attributes: attributes; pmb_loc: Location.t; } -(* X = ME *) +(** Values of type [module_binding] represents [module X = ME] *) (** {1 Toplevel} *) -(* Toplevel phrases *) +(** {2 Toplevel phrases} *) type toplevel_phrase = | Ptop_def of structure - | Ptop_dir of toplevel_directive - (* #use, #load ... *) + | Ptop_dir of toplevel_directive (** [#use], [#load] ... *) and toplevel_directive = { - pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : Location.t; + 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; + pdira_desc: directive_argument_desc; + pdira_loc: Location.t; } and directive_argument_desc = diff --git a/upstream/ocaml_500/parsing/pprintast.ml b/upstream/ocaml_500/parsing/pprintast.ml index eee4b5848f..12884b30bd 100644 --- a/upstream/ocaml_500/parsing/pprintast.ml +++ b/upstream/ocaml_500/parsing/pprintast.ml @@ -1068,19 +1068,17 @@ and module_type 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 + (type_params ctxt) 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_params ctxt) ls + longident_loc li (type_declaration ctxt) td | Pwith_modsubst (li, li2) -> pp f "module %a :=@ %a" longident_loc li longident_loc li2 diff --git a/upstream/ocaml_500/typing/ctype.ml b/upstream/ocaml_500/typing/ctype.ml index becdca2074..224d820560 100644 --- a/upstream/ocaml_500/typing/ctype.ml +++ b/upstream/ocaml_500/typing/ctype.ml @@ -1193,28 +1193,32 @@ let existential_name cstr ty = | Tvar (Some name) -> "$" ^ cstr.cstr_name ^ "_'" ^ name | _ -> "$" ^ cstr.cstr_name -let instance_constructor ?in_pattern cstr = +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of { env: Env.t ref; scope: int } + +let instance_constructor existential_treatment 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 copy_existential = + match existential_treatment with + | Keep_existentials_flexible -> copy scope + | Make_existentials_abstract {env; scope = fresh_constr_scope} -> + fun 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; + tv + in + let ty_ex = List.map copy_existential cstr.cstr_existentials in 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) ) @@ -1772,7 +1776,8 @@ let occur env ty0 ty = try while type_changed := false; - occur_rec env allow_recursive TypeSet.empty ty0 ty; + if not (eq_type ty0 ty) then + occur_rec env allow_recursive TypeSet.empty ty0 ty; !type_changed do () (* prerr_endline "changed" *) done; merge type_changed old @@ -2702,7 +2707,7 @@ and unify3 env t1 t1' t2 t2' = | _ -> begin match !umode with | Expression -> - occur_for Unify !env t1' t2'; + occur_for Unify !env t1' t2; link_type t1' t2 | Pattern -> add_type_equality t1' t2' diff --git a/upstream/ocaml_500/typing/ctype.mli b/upstream/ocaml_500/typing/ctype.mli index 0e3aefc2c0..186142d445 100644 --- a/upstream/ocaml_500/typing/ctype.mli +++ b/upstream/ocaml_500/typing/ctype.mli @@ -152,8 +152,12 @@ 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 -> + +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of { env: Env.t ref; scope: int } + +val instance_constructor: existential_treatment -> constructor_description -> type_expr list * type_expr * type_expr list (* Same, for a constructor. Also returns existentials. *) val instance_parameterized_type: diff --git a/upstream/ocaml_500/typing/ident.ml b/upstream/ocaml_500/typing/ident.ml index feb590d024..15259280db 100644 --- a/upstream/ocaml_500/typing/ident.ml +++ b/upstream/ocaml_500/typing/ident.ml @@ -152,6 +152,19 @@ let print_with_scope ppf id = print ~with_scope:true ppf id let print ppf id = print ~with_scope:false ppf id +(* For the documentation of ['a Ident.tbl], see ident.mli. + + The implementation is a copy-paste specialization of + a balanced-tree implementation similar to Map. + ['a tbl] + is a slightly more compact version of + [(Ident.t * 'a) list Map.Make(String)] + + This implementation comes from Caml Light where duplication was + unavoidable in absence of functors. It works well enough, and so + far we have not had strong incentives to do the deduplication work + (implementation, tests, benchmarks, etc.). +*) type 'a tbl = Empty | Node of 'a tbl * 'a data * 'a tbl * int diff --git a/upstream/ocaml_500/typing/ident.mli b/upstream/ocaml_500/typing/ident.mli index ff48efb3ad..117280cc2c 100644 --- a/upstream/ocaml_500/typing/ident.mli +++ b/upstream/ocaml_500/typing/ident.mli @@ -63,7 +63,36 @@ val highest_scope: int val reinit: unit -> unit type 'a tbl - (* Association tables from identifiers to type 'a. *) +(** ['a tbl] represents association tables from identifiers to values + of type ['a]. + + ['a tbl] plays the role of map, but bindings can be looked up + from either the full Ident using [find_same], or just its + user-visible name using [find_name]. In general the two lookups may + not return the same result, as an identifier may have been shadowed + in the environment by a distinct identifier with the same name. + + [find_all] returns the bindings for all idents of a given name, + most recently introduced first. + + In other words, + ['a tbl] + corresponds to + [(Ident.t * 'a) list Map.Make(String)] + and the implementation is very close to that representation. + + Note in particular that searching among idents of the same name + takes linear time, and that [add] simply extends the list without + checking for duplicates. So it is not a good idea to implement + union by repeated [add] calls, which may result in many duplicated + identifiers and poor [find_same] performance. It is even possible + to build overly large same-name lists such that non-recursive + functions like [find_all] or [fold_all] blow the stack. + + You should probably use [Map.Make(Ident)] instead, unless you + really need to query bindings by user-visible name, not just by + unique identifiers. +*) val empty: 'a tbl val add: t -> 'a -> 'a tbl -> 'a tbl diff --git a/upstream/ocaml_500/typing/typeclass.ml b/upstream/ocaml_500/typing/typeclass.ml index 048ee998b0..fedbc0e025 100644 --- a/upstream/ocaml_500/typing/typeclass.ml +++ b/upstream/ocaml_500/typing/typeclass.ml @@ -552,12 +552,11 @@ type first_pass_accummulater = concrete_vals : VarSet.t; local_meths : MethSet.t; local_vals : VarSet.t; - vars : Ident.t Vars.t; - meths : Ident.t Meths.t; } + vars : Ident.t Vars.t; } let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = let { rev_fields; val_env; par_env; concrete_meths; concrete_vals; - local_meths; local_vals; vars; meths } = acc + local_meths; local_vals; vars } = acc in let loc = cf.pcf_loc in let attributes = cf.pcf_attributes in @@ -612,13 +611,6 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = (val_env, par_env, inherited_vars, vars)) parent_sign.csig_vars (val_env, par_env, [], vars) in - let meths = - Meths.fold - (fun label _ meths -> - if Meths.mem label meths then meths - else Meths.add label (Ident.create_local label) meths) - parent_sign.csig_meths meths - in (* Methods available through super *) let super_meths = MethSet.fold @@ -641,7 +633,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = in let rev_fields = field :: rev_fields in { acc with rev_fields; val_env; par_env; - concrete_meths; concrete_vals; vars; meths }) + concrete_meths; concrete_vals; vars }) | Pcf_val (label, mut, Cfk_virtual styp) -> with_attrs (fun () -> @@ -723,15 +715,11 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = let cty = transl_simple_type val_env false sty in let ty = cty.ctyp_type in add_method loc val_env label.txt priv Virtual ty sign; - let meths = - if Meths.mem label.txt meths then meths - else Meths.add label.txt (Ident.create_local label.txt) meths - in let field = Virtual_method { label; priv; cty; loc; attributes } in let rev_fields = field :: rev_fields in - { acc with rev_fields; meths }) + { acc with rev_fields }) | Pcf_method (label, priv, Cfk_concrete (override, expr)) -> with_attrs @@ -785,10 +773,6 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = raise(Error(loc, val_env, Field_type_mismatch ("method", label.txt, err))) end; - let meths = - if Meths.mem label.txt meths then meths - else Meths.add label.txt (Ident.create_local label.txt) meths - in let sdefinition = make_method self_loc cl_num expr in let warning_state = Warnings.backup () in let field = @@ -799,7 +783,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = let rev_fields = field :: rev_fields in let concrete_meths = MethSet.add label.txt concrete_meths in let local_meths = MethSet.add label.txt local_meths in - { acc with rev_fields; concrete_meths; local_meths; meths }) + { acc with rev_fields; concrete_meths; local_meths }) | Pcf_constraint (sty1, sty2) -> with_attrs @@ -837,11 +821,10 @@ and class_fields_first_pass self_loc cl_num sign self_scope let local_meths = MethSet.empty in let local_vals = VarSet.empty in let vars = Vars.empty in - let meths = Meths.empty in let init_acc = { rev_fields; val_env; par_env; concrete_meths; concrete_vals; - local_meths; local_vals; vars; meths } + local_meths; local_vals; vars } in let acc = Builtin_attributes.warning_scope [] @@ -850,7 +833,7 @@ and class_fields_first_pass self_loc cl_num sign self_scope (class_field_first_pass self_loc cl_num sign self_scope) init_acc cfs) in - List.rev acc.rev_fields, acc.vars, acc.meths + List.rev acc.rev_fields, acc.vars and class_field_second_pass cl_num sign met_env field = let mkcf desc loc attrs = @@ -1003,7 +986,7 @@ and class_structure cl_num virt self_scope final val_env met_env loc end; (* Typing of class fields *) - let (fields, vars, meths) = + let (fields, vars) = class_fields_first_pass self_loc cl_num sign self_scope val_env par_env str in @@ -1016,6 +999,13 @@ and class_structure cl_num virt self_scope final val_env met_env loc update_class_signature loc val_env ~warn_implicit_public:false virt kind sign; + let meths = + Meths.fold + (fun label _ meths -> + Meths.add label (Ident.create_local label) meths) + sign.csig_meths Meths.empty + in + (* Close the signature if it is final *) begin match final with | Not_final -> () diff --git a/upstream/ocaml_500/typing/typecore.ml b/upstream/ocaml_500/typing/typecore.ml index 5b9a00ae37..72287808b2 100644 --- a/upstream/ocaml_500/typing/typecore.ml +++ b/upstream/ocaml_500/typing/typecore.ml @@ -557,7 +557,9 @@ and build_as_type_aux ~refine (env : Env.t ref) p = 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 + let ty_args, ty_res, _ = + instance_constructor Keep_existentials_flexible cstr + in List.iter2 (fun (p,ty) -> unify_pat ~refine env {p with pat_type = ty}) (List.combine pl tyl) ty_args; ty_res @@ -702,13 +704,22 @@ let solve_Ppat_construct ~refine env loc constr no_existentials match existential_styp with None -> let ty_args, ty_res, _ = - instance_constructor ~in_pattern:(env, expansion_scope) constr in + instance_constructor + (Make_existentials_abstract { env; scope = 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 existential_treatment = + if name_list = [] then + Make_existentials_abstract { env; scope = expansion_scope } + else + (* we will unify them (in solve_constructor_annotation) with the + local types provided by the user *) + Keep_existentials_flexible + in let ty_args, ty_res, ty_ex = - instance_constructor ?in_pattern constr in + instance_constructor existential_treatment 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 @@ -721,7 +732,7 @@ let solve_Ppat_construct ~refine env loc constr no_existentials generalize_structure ty_res; List.iter generalize_structure ty_args; if !Clflags.principal && refine = None then begin - (* Do not warn for couter examples *) + (* Do not warn for counter-examples *) let exception Warn_only_once in try TypePairs.iter @@ -2561,14 +2572,14 @@ let check_statement exp = If [exp] has a function type, we check that it is not syntactically the result of a function application, as this is often a bug in certain contexts (eg the rhs of a let-binding or in the argument of [ignore]). For example, - [ignore (List.map print_int)] written by mistake instad of [ignore (List.map + [ignore (List.map print_int)] written by mistake instead of [ignore (List.map print_int li)]. The check can be disabled by explicitly annotating the expression with a type constraint, eg [(e : _ -> _)]. If [statement] is [true] and the [ignored-partial-application] is {em not} - triggered, then the [non-unit-statement] check is performaed (see + triggered, then the [non-unit-statement] check is performed (see [check_statement]). If the type of [exp] is not known at the time this function is called, the @@ -4730,7 +4741,9 @@ and type_construct env loc lid sarg ty_expected_explained attrs = (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 (ty_args, ty_res, _) = + instance_constructor Keep_existentials_flexible constr + in let texp = re { exp_desc = Texp_construct(lid, constr, []); diff --git a/upstream/ocaml_500/typing/typedecl.ml b/upstream/ocaml_500/typing/typedecl.ml index 9d38ebe97e..3b847099d3 100644 --- a/upstream/ocaml_500/typing/typedecl.ml +++ b/upstream/ocaml_500/typing/typedecl.ml @@ -1003,7 +1003,9 @@ let transl_extension_constructor ~scope env type_path type_params 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 (args, cstr_res, _ex) = + Ctype.instance_constructor Keep_existentials_flexible cdescr + in let res, ret_type = if cdescr.cstr_generalized then let params = Ctype.instance_list type_params in diff --git a/upstream/ocaml_500/typing/typemod.ml b/upstream/ocaml_500/typing/typemod.ml index dab2a3552c..0ef1e13d89 100644 --- a/upstream/ocaml_500/typing/typemod.ml +++ b/upstream/ocaml_500/typing/typemod.ml @@ -2041,8 +2041,11 @@ and package_constraints env loc mty constrs = 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 mty = + package_constraints env loc (Mty_ident p) + (List.map (fun (n, t) -> (Longident.flatten n, t)) fl) + in + Subst.modtype Keep Subst.identity mty let package_subtype env p1 fl1 p2 fl2 = let mkmty p fl = @@ -2060,11 +2063,13 @@ let package_subtype env p1 fl1 p2 fl2 = let () = Ctype.package_subtype := package_subtype -let wrap_constraint env mark arg mty explicit = +let wrap_constraint_package env mark arg mty explicit = let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let mty1 = Subst.modtype Keep Subst.identity arg.mod_type in + let mty2 = Subst.modtype Keep Subst.identity mty in let coercion = try - Includemod.modtypes ~loc:arg.mod_loc env ~mark arg.mod_type mty + Includemod.modtypes ~loc:arg.mod_loc env ~mark mty1 mty2 with Includemod.Error msg -> raise(Error(arg.mod_loc, env, Not_included msg)) in { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); @@ -2946,7 +2951,7 @@ let type_package env m p fl = 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 + let modl = wrap_constraint_package env true modl mty Tmodtype_implicit in modl, fl' (* Fill in the forward declarations *) diff --git a/upstream/ocaml_500/typing/types.ml b/upstream/ocaml_500/typing/types.ml index 739c7f18af..81febbf3fb 100644 --- a/upstream/ocaml_500/typing/types.ml +++ b/upstream/ocaml_500/typing/types.ml @@ -720,6 +720,7 @@ let log_type ty = let link_type ty ty' = let ty = repr ty in let ty' = repr ty' in + if ty == ty' then () else begin log_type ty; let desc = ty.desc in Transient_expr.set_desc ty (Tlink ty'); @@ -736,6 +737,7 @@ let link_type ty ty' = | None, None -> () end | _ -> () + end (* ; assert (check_memorized_abbrevs ()) *) (* ; check_expans [] ty' *) (* TODO: consider eliminating set_type_desc, replacing it with link types *) diff --git a/upstream/ocaml_500/utils/Makefile b/upstream/ocaml_500/utils/Makefile deleted file mode 100644 index 7142afbd08..0000000000 --- a/upstream/ocaml_500/utils/Makefile +++ /dev/null @@ -1,118 +0,0 @@ -#************************************************************************** -#* * -#* 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,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) \ - $(call SUBST,FORCE_INSTRUMENTED_RUNTIME) \ - $< > $@ - -# 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_500/utils/ccomp.ml b/upstream/ocaml_500/utils/ccomp.ml index 955968d1cd..d23c3f2baa 100644 --- a/upstream/ocaml_500/utils/ccomp.ml +++ b/upstream/ocaml_500/utils/ccomp.ml @@ -140,12 +140,8 @@ let create_archive archive file_list = 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) + command(Printf.sprintf "%s rc %s %s" + Config.ar quoted_archive (quote_files file_list)) let expand_libname cclibs = cclibs |> List.map (fun cclib -> diff --git a/upstream/ocaml_500/utils/clflags.ml b/upstream/ocaml_500/utils/clflags.ml index 53319aedfd..fac4309b98 100644 --- a/upstream/ocaml_500/utils/clflags.ml +++ b/upstream/ocaml_500/utils/clflags.ml @@ -48,6 +48,7 @@ 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 no_cwd = ref false (* -nocwd *) and print_types = ref false (* -i *) and make_archive = ref false (* -a *) and debug = ref false (* -g *) diff --git a/upstream/ocaml_500/utils/clflags.mli b/upstream/ocaml_500/utils/clflags.mli index ec852553df..e5f8745268 100644 --- a/upstream/ocaml_500/utils/clflags.mli +++ b/upstream/ocaml_500/utils/clflags.mli @@ -76,6 +76,7 @@ val compile_only : bool ref val output_name : string option ref val include_dirs : string list ref val no_std_include : bool ref +val no_cwd : bool ref val print_types : bool ref val make_archive : bool ref val debug : bool ref diff --git a/upstream/ocaml_500/utils/config.common.ml b/upstream/ocaml_500/utils/config.common.ml new file mode 100644 index 0000000000..b54bf1941b --- /dev/null +++ b/upstream/ocaml_500/utils/config.common.ml @@ -0,0 +1,162 @@ +#2 "utils/config.common.ml" +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Portions of the Config module common to both the boot and main compiler. *) + +(* The main OCaml version string has moved to ../build-aux/ocaml_version.m4 *) +let version = Sys.ocaml_version + +let standard_library = + try + Sys.getenv "OCAMLLIB" + with Not_found -> + try + Sys.getenv "CAMLLIB" + with Not_found -> + standard_library_default + +let exec_magic_number = "Caml1999X032" + (* exec_magic_number is duplicated in runtime/caml/exec.h *) +and cmi_magic_number = "Caml1999I032" +and cmo_magic_number = "Caml1999O032" +and cma_magic_number = "Caml1999A032" +and cmx_magic_number = + if flambda then + "Caml1999y032" + else + "Caml1999Y032" +and cmxa_magic_number = + if flambda then + "Caml1999z032" + else + "Caml1999Z032" +and ast_impl_magic_number = "Caml1999M032" +and ast_intf_magic_number = "Caml1999N032" +and cmxs_magic_number = "Caml1999D032" +and cmt_magic_number = "Caml1999T032" +and linear_magic_number = "Caml1999L032" + +let safe_string = true +let default_safe_string = true +let naked_pointers = false + +let interface_suffix = ref ".mli" + +let max_tag = 243 +(* 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 = 32 (* see runtime/caml/config.h *) +let stack_safety_margin = 6 +let default_executable_name = + match Sys.os_type with + "Unix" -> "a.out" + | "Win32" | "Cygwin" -> "camlprog.exe" + | _ -> "camlprog" +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 "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_bool "naked_pointers" naked_pointers; + + 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_500/utils/config.fixed.ml b/upstream/ocaml_500/utils/config.fixed.ml new file mode 100644 index 0000000000..141fcea3d8 --- /dev/null +++ b/upstream/ocaml_500/utils/config.fixed.ml @@ -0,0 +1,70 @@ +#2 "utils/config.fixed.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* David Allsopp, Tarides UK. *) +(* *) +(* Copyright 2022 David Allsopp Ltd. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Configuration for the boot compiler. The compiler should refuse to bootstrap + if configured with values which would contradict the configuration below. + The values below are picked to trigger errors if accidentally used in the + compiler (e.g. for the C compiler). *) + +let boot_cannot_call s = "/ The boot compiler should not call " ^ s + +let bindir = "/tmp" +let standard_library_default = "/tmp" +let ccomp_type = "n/a" +let c_compiler = boot_cannot_call "the C compiler" +let c_output_obj = "" +let c_has_debug_prefix_map = false +let as_has_debug_prefix_map = false +let ocamlc_cflags = "" +let ocamlc_cppflags = "" +let ocamlopt_cflags = "" +let ocamlopt_cppflags = "" +let bytecomp_c_libraries = "" +let bytecomp_c_compiler = "" +let native_c_compiler = c_compiler +let native_c_libraries = "" +let native_pack_linker = boot_cannot_call "the linker" +let default_rpath = "" +let mksharedlibrpath = "" +let ar = boot_cannot_call "ar" +let supports_shared_libraries = false +let mkdll = native_pack_linker +let mkexe = native_pack_linker +let mkmaindll = native_pack_linker +let flambda = false +let with_flambda_invariants = false +let with_cmm_invariants = false +let windows_unicode = false +let force_instrumented_runtime = false +let flat_float_array = true +let function_sections = false +let afl_instrument = false +let architecture = "none" +let model = "default" +let system = "unknown" +let asm = boot_cannot_call "the assembler" +let asm_cfi_supported = false +let with_frame_pointers = false +let profinfo = false +let profinfo_width = 0 +let ext_exe = ".ex_The boot compiler should not be using Config.ext_exe" +let ext_obj = ".o_The boot compiler cannot process C objects" +let ext_asm = ".s_The boot compiler should not be using Config.ext_asm" +let ext_lib = ".a_The boot compiler cannot process C libraries" +let ext_dll = ".so_The boot compiler cannot load DLLs" +let host = "zinc-boot-ocaml" +let target = host +let systhread_supported = false +let flexdll_dirs = [] diff --git a/upstream/ocaml_500/utils/config.mli b/upstream/ocaml_500/utils/config.mli index 29f482d261..fa02a76745 100644 --- a/upstream/ocaml_500/utils/config.mli +++ b/upstream/ocaml_500/utils/config.mli @@ -82,9 +82,6 @@ val mkexe: string 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) *) diff --git a/upstream/ocaml_500/utils/config.mlp b/upstream/ocaml_500/utils/config.mlp index fc92ba77ec..556d5ec7ec 100644 --- a/upstream/ocaml_500/utils/config.mlp +++ b/upstream/ocaml_500/utils/config.mlp @@ -14,22 +14,10 @@ (* *) (**************************************************************************) -(* The main OCaml version string has moved to ../build-aux/ocaml_version.m4 *) -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%%" @@ -54,37 +42,33 @@ 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 = - 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%%" + Option.value ~default:"flexlink" (Sys.getenv_opt "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 + in + let flags = " -chain %%FLEXDLL_CHAIN%% %%FLEXLINK_FLAGS%%" in + flexlink ^ flags ^ "%%FLEXLINK_DLL_LDFLAGS%%", + flexlink ^ " -exe" ^ flags ^ "%%FLEXLINK_LDFLAGS%%", + flexlink ^ " -maindll" ^ flags ^ "%%FLEXLINK_DLL_LDFLAGS%%" else - "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%" + "%%MKDLL_EXP%%", "%%MKEXE_EXP%%", "%%MKMAINDLL%%" let flambda = %%FLAMBDA%% let with_flambda_invariants = %%WITH_FLAMBDA_INVARIANTS%% let with_cmm_invariants = %%WITH_CMM_INVARIANTS%% -let safe_string = true -let default_safe_string = true let windows_unicode = %%WINDOWS_UNICODE%% != 0 -let naked_pointers = false let force_instrumented_runtime = %%FORCE_INSTRUMENTED_RUNTIME%% let flat_float_array = %%FLAT_FLOAT_ARRAY%% @@ -92,39 +76,6 @@ let flat_float_array = %%FLAT_FLOAT_ARRAY%% let function_sections = %%FUNCTION_SECTIONS%% let afl_instrument = %%AFL_INSTRUMENT%% -let exec_magic_number = "Caml1999X031" - (* exec_magic_number is duplicated in runtime/caml/exec.h *) -and cmi_magic_number = "Caml1999I031" -and cmo_magic_number = "Caml1999O031" -and cma_magic_number = "Caml1999A031" -and cmx_magic_number = - if flambda then - "Caml1999y031" - else - "Caml1999Y031" -and cmxa_magic_number = - if flambda then - "Caml1999z031" - else - "Caml1999Z031" -and ast_impl_magic_number = "Caml1999M031" -and ast_intf_magic_number = "Caml1999N031" -and cmxs_magic_number = "Caml1999D031" -and cmt_magic_number = "Caml1999T031" -and linear_magic_number = "Caml1999L031" - -let interface_suffix = ref ".mli" - -let max_tag = 243 -(* 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 = 32 (* see runtime/caml/config.h *) -let stack_safety_margin = 6 - let architecture = "%%ARCH%%" let model = "%%MODEL%%" let system = "%%SYSTEM%%" @@ -144,105 +95,6 @@ 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_bool "naked_pointers" naked_pointers; - - 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_500/utils/diffing.mli b/upstream/ocaml_500/utils/diffing.mli index 1d4588ba77..80cfa5e279 100644 --- a/upstream/ocaml_500/utils/diffing.mli +++ b/upstream/ocaml_500/utils/diffing.mli @@ -1,4 +1,3 @@ - (**************************************************************************) (* *) (* OCaml *) @@ -14,7 +13,7 @@ (* *) (**************************************************************************) -(** {0 Parametric diffing} +(** Parametric diffing This module implements diffing over lists of arbitrary content. It is parameterized by diff --git a/upstream/ocaml_500/utils/load_path.ml b/upstream/ocaml_500/utils/load_path.ml index 2b1d02654b..42330d5623 100644 --- a/upstream/ocaml_500/utils/load_path.ml +++ b/upstream/ocaml_500/utils/load_path.ml @@ -31,6 +31,22 @@ module Dir = struct let path t = t.path let files t = t.files + let find t fn = + if List.mem fn t.files then + Some (Filename.concat t.path fn) + else + None + + let find_uncap t fn = + let fn = String.uncapitalize_ascii fn in + let search base = + if String.uncapitalize_ascii base = fn then + Some (Filename.concat t.path base) + else + None + in + List.find_map search 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. *) @@ -44,13 +60,19 @@ module Dir = struct { path; files = Array.to_list (readdir_compat path) } end +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string + let dirs = s_ref [] +let no_auto_include _ _ = raise Not_found +let auto_include_callback = ref no_auto_include let reset () = assert (not Config.merlin || Local_store.is_bound ()); STbl.clear !files; STbl.clear !files_uncap; - dirs := [] + dirs := []; + auto_include_callback := no_auto_include let get () = List.rev !dirs let get_paths () = List.rev_map Dir.path !dirs @@ -66,10 +88,11 @@ let prepend_add dir = STbl.replace !files_uncap (String.uncapitalize_ascii base) fn ) dir.Dir.files -let init l = +let init ~auto_include l = reset (); dirs := List.rev_map Dir.create l; - List.iter prepend_add !dirs + List.iter prepend_add !dirs; + auto_include_callback := auto_include let remove_dir dir = assert (not Config.merlin || Local_store.is_bound ()); @@ -109,16 +132,45 @@ let prepend_dir dir = let is_basename fn = Filename.basename fn = fn +let auto_include_libs libs alert find_in_dir fn = + let scan (lib, lazy dir) = + let file = find_in_dir dir fn in + let alert_and_add_dir _ = + alert lib; + append_dir dir + in + Option.iter alert_and_add_dir file; + file + in + match List.find_map scan libs with + | Some base -> base + | None -> raise Not_found + +let auto_include_otherlibs = + (* Ensure directories are only ever scanned once *) + let expand = Misc.expand_directory Config.standard_library in + let otherlibs = + let read_lib lib = lazy (Dir.create (expand ("+" ^ lib))) in + List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in + auto_include_libs otherlibs + 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 + try + if is_basename fn && not !Sys.interactive then + STbl.find !files fn + else + Misc.find_in_path (get_paths ()) fn + with Not_found -> + !auto_include_callback Dir.find 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 + try + 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 + with Not_found -> + let fn_uncap = String.uncapitalize_ascii fn in + !auto_include_callback Dir.find_uncap fn_uncap diff --git a/upstream/ocaml_500/utils/load_path.mli b/upstream/ocaml_500/utils/load_path.mli index 1f9aba28bf..fe3abaf95d 100644 --- a/upstream/ocaml_500/utils/load_path.mli +++ b/upstream/ocaml_500/utils/load_path.mli @@ -31,9 +31,43 @@ val remove_dir : string -> unit val reset : unit -> unit (** Remove all directories *) -val init : string list -> unit +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. *) + + val find : t -> string -> string option + (** [find dir fn] returns the full path to [fn] in [dir]. *) + + val find_uncap : t -> string -> string option + (** As {!find}, but search also for uncapitalized name, i.e. if name is + Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) +end + +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string +(** The type of callback functions on for [init ~auto_include] *) + +val no_auto_include : auto_include_callback +(** No automatic directory inclusion: misses in the load path raise [Not_found] + as normal. *) + +val init : auto_include:auto_include_callback -> string list -> unit (** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *) +val auto_include_otherlibs : + (string -> unit) -> auto_include_callback +(** [auto_include_otherlibs alert] is a callback function to be passed to + {!Load_path.init} and automatically adds [-I +lib] to the load path after + calling [alert lib]. *) + val get_paths : unit -> string list (** Return the list of directories passed to [add_dir] so far. *) @@ -47,19 +81,6 @@ 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} *) diff --git a/upstream/ocaml_500/utils/local_store.mli b/upstream/ocaml_500/utils/local_store.mli index f39cd12328..3ea05d5889 100644 --- a/upstream/ocaml_500/utils/local_store.mli +++ b/upstream/ocaml_500/utils/local_store.mli @@ -23,8 +23,8 @@ (** {1 Creators} *) val s_ref : 'a -> 'a ref -(** Similar to {!ref}, except the allocated reference is registered into the - store. *) +(** Similar to {!val:Stdlib.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 @@ -52,7 +52,7 @@ val fresh : unit -> store 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 +(** [with_store 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. *) @@ -62,5 +62,5 @@ val reset : unit -> unit 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. *) +(** Returns [true] when a store is active (i.e. when called from the callback + passed to {!with_store}), [false] otherwise. *) diff --git a/upstream/ocaml_500/utils/misc.mli b/upstream/ocaml_500/utils/misc.mli index 5fc95e61ad..7d76960f74 100644 --- a/upstream/ocaml_500/utils/misc.mli +++ b/upstream/ocaml_500/utils/misc.mli @@ -152,12 +152,10 @@ module Stdlib : sig 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. *) + (** Same as [Array.exists2] from the standard library. *) val for_alli : (int -> 'a -> bool) -> 'a array -> bool - (** Same as {!Array.for_all}, but the + (** Same as [Array.for_all] from the standard library, but the function is applied with the index of the element as first argument, and the element itself as second argument. *) diff --git a/upstream/ocaml_500/utils/misc.mli.orig b/upstream/ocaml_500/utils/misc.mli.orig deleted file mode 100644 index 6aea772091..0000000000 --- a/upstream/ocaml_500/utils/misc.mli.orig +++ /dev/null @@ -1,673 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 -*) - -val ordinal_suffix : int -> string -(** [ordinal_suffix n] is the appropriate suffix to append to the numeral [n] as - an ordinal number: [1] -> ["st"], [2] -> ["nd"], [3] -> ["rd"], - [4] -> ["th"], and so on. Handles larger numbers (e.g., [42] -> ["nd"]) and - the numbers 11--13 (which all get ["th"]) correctly. *) - -(* 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_500/utils/warnings.ml b/upstream/ocaml_500/utils/warnings.ml index 097bd3b920..23a64d509a 100644 --- a/upstream/ocaml_500/utils/warnings.ml +++ b/upstream/ocaml_500/utils/warnings.ml @@ -201,252 +201,330 @@ type description = (* 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. *) - description : string; } + description : string; + since : Sys.ocaml_release_info option; + (* The compiler version introducing this warning; only tagged for warnings + created after 3.12, which introduced the numbered syntax. *) + } + +let since major minor = Some { Sys.major; minor; patchlevel=0; extra=None } let descriptions = [ { number = 1; names = ["comment-start"]; - description = "Suspicious-looking start-of-comment mark." }; + description = "Suspicious-looking start-of-comment mark."; + since = None }; { number = 2; names = ["comment-not-end"]; - description = "Suspicious-looking end-of-comment mark." }; + description = "Suspicious-looking end-of-comment mark."; + since = None }; { number = 3; names = []; - description = "Deprecated synonym for the 'deprecated' alert." }; + description = "Deprecated synonym for the 'deprecated' alert."; + since = None }; { number = 4; names = ["fragile-match"]; description = "Fragile pattern matching: matching that will remain complete even\n\ \ if additional constructors are added to one of the variant types\n\ - \ matched." }; + \ matched."; + since = None }; { number = 5; names = ["ignored-partial-application"]; description = "Partially applied function: expression whose result has function\n\ - \ type and is ignored." }; + \ type and is ignored."; + since = None }; { number = 6; names = ["labels-omitted"]; - description = "Label omitted in function application." }; + description = "Label omitted in function application."; + since = None }; { number = 7; names = ["method-override"]; - description = "Method overridden." }; + description = "Method overridden."; + since = None }; { number = 8; names = ["partial-match"]; - description = "Partial match: missing cases in pattern-matching." }; + description = "Partial match: missing cases in pattern-matching."; + since = None }; { number = 9; names = ["missing-record-field-pattern"]; - description = "Missing fields in a record pattern." }; + description = "Missing fields in a record pattern."; + since = None }; { number = 10; names = ["non-unit-statement"]; description = "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)." }; + \ \"unit\" (and that is not a function, see warning number 5)."; + since = None }; { number = 11; names = ["redundant-case"]; description = - "Redundant case in a pattern matching (unused match case)." }; + "Redundant case in a pattern matching (unused match case)."; + since = None }; { number = 12; names = ["redundant-subpat"]; - description = "Redundant sub-pattern in a pattern-matching." }; + description = "Redundant sub-pattern in a pattern-matching." ; + since = None}; { number = 13; names = ["instance-variable-override"]; - description = "Instance variable overridden." }; + description = "Instance variable overridden."; + since = None }; { number = 14; names = ["illegal-backslash"]; - description = "Illegal backslash escape in a string constant." }; + description = "Illegal backslash escape in a string constant."; + since = None }; { number = 15; names = ["implicit-public-methods"]; - description = "Private method made public implicitly." }; + description = "Private method made public implicitly."; + since = None }; { number = 16; names = ["unerasable-optional-argument"]; - description = "Unerasable optional argument." }; + description = "Unerasable optional argument."; + since = None }; { number = 17; names = ["undeclared-virtual-method"]; - description = "Undeclared virtual method." }; + description = "Undeclared virtual method."; + since = None }; { number = 18; names = ["not-principal"]; - description = "Non-principal type." }; + description = "Non-principal type."; + since = None }; { number = 19; names = ["non-principal-labels"]; - description = "Type without principality." }; + description = "Type without principality."; + since = None }; { number = 20; names = ["ignored-extra-argument"]; - description = "Unused function argument." }; + description = "Unused function argument."; + since = None }; { number = 21; names = ["nonreturning-statement"]; - description = "Non-returning statement." }; + description = "Non-returning statement."; + since = None }; { number = 22; names = ["preprocessor"]; - description = "Preprocessor warning." }; + description = "Preprocessor warning."; + since = None }; { number = 23; names = ["useless-record-with"]; - description = "Useless record \"with\" clause." }; + description = "Useless record \"with\" clause."; + since = None }; { number = 24; names = ["bad-module-name"]; description = - "Bad module name: the source file name is not a valid OCaml module name."}; + "Bad module name: the source file name is not a valid OCaml module name."; + since = None }; { number = 25; names = []; - description = "Ignored: now part of warning 8." }; + description = "Ignored: now part of warning 8."; + since = None }; { number = 26; names = ["unused-var"]; description = "Suspicious unused variable: unused variable that is bound\n\ \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character." }; + \ character."; + since = None }; { number = 27; names = ["unused-var-strict"]; description = "Innocuous unused variable: unused variable that is not bound with\n\ \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character." }; + \ character."; + since = None }; { number = 28; names = ["wildcard-arg-to-constant-constr"]; description = - "Wildcard pattern given as argument to a constant constructor." }; + "Wildcard pattern given as argument to a constant constructor."; + since = None }; { number = 29; names = ["eol-in-string"]; description = - "Unescaped end-of-line in a string constant (non-portable code)." }; + "Unescaped end-of-line in a string constant (non-portable code)."; + since = None }; { number = 30; names = ["duplicate-definitions"]; description = "Two labels or constructors of the same name are defined in two\n\ - \ mutually recursive types." }; + \ mutually recursive types."; + since = None }; { number = 31; names = ["module-linked-twice"]; - description = "A module is linked twice in the same executable." }; + description = "A module is linked twice in the same executable."; + since = since 4 0 }; { number = 32; names = ["unused-value-declaration"]; - description = "Unused value declaration." }; + description = "Unused value declaration."; + since = since 4 0 }; { number = 33; names = ["unused-open"]; - description = "Unused open statement." }; + description = "Unused open statement."; + since = since 4 0 }; { number = 34; names = ["unused-type-declaration"]; - description = "Unused type declaration." }; + description = "Unused type declaration."; + since = since 4 0 }; { number = 35; names = ["unused-for-index"]; - description = "Unused for-loop index." }; + description = "Unused for-loop index."; + since = since 4 0 }; { number = 36; names = ["unused-ancestor"]; - description = "Unused ancestor variable." }; + description = "Unused ancestor variable."; + since = since 4 0 }; { number = 37; names = ["unused-constructor"]; - description = "Unused constructor." }; + description = "Unused constructor."; + since = since 4 0 }; { number = 38; names = ["unused-extension"]; - description = "Unused extension constructor." }; + description = "Unused extension constructor."; + since = since 4 0 }; { number = 39; names = ["unused-rec-flag"]; - description = "Unused rec flag." }; + description = "Unused rec flag."; + since = since 4 0 }; { number = 40; names = ["name-out-of-scope"]; - description = "Constructor or label name used out of scope." }; + description = "Constructor or label name used out of scope."; + since = since 4 1 }; { number = 41; names = ["ambiguous-name"]; - description = "Ambiguous constructor or label name." }; + description = "Ambiguous constructor or label name."; + since = since 4 1 }; { number = 42; names = ["disambiguated-name"]; description = - "Disambiguated constructor or label name (compatibility warning)." }; + "Disambiguated constructor or label name (compatibility warning)."; + since = since 4 1 }; { number = 43; names = ["nonoptional-label"]; - description = "Nonoptional label applied as optional." }; + description = "Nonoptional label applied as optional."; + since = since 4 1 }; { number = 44; names = ["open-shadow-identifier"]; - description = "Open statement shadows an already defined identifier." }; + description = "Open statement shadows an already defined identifier."; + since = since 4 1 }; { number = 45; names = ["open-shadow-label-constructor"]; description = - "Open statement shadows an already defined label or constructor." }; + "Open statement shadows an already defined label or constructor."; + since = since 4 1 }; { number = 46; names = ["bad-env-variable"]; - description = "Error in environment variable." }; + description = "Error in environment variable."; + since = since 4 1 }; { number = 47; names = ["attribute-payload"]; - description = "Illegal attribute payload." }; + description = "Illegal attribute payload."; + since = since 4 2 }; { number = 48; names = ["eliminated-optional-arguments"]; - description = "Implicit elimination of optional arguments." }; + description = "Implicit elimination of optional arguments."; + since = since 4 2 }; { number = 49; names = ["no-cmi-file"]; - description = "Absent cmi file when looking up module alias." }; + description = "Absent cmi file when looking up module alias."; + since = since 4 2 }; { number = 50; names = ["unexpected-docstring"]; - description = "Unexpected documentation comment." }; + description = "Unexpected documentation comment."; + since = since 4 3 }; { number = 51; names = ["wrong-tailcall-expectation"]; description = - "Function call annotated with an incorrect @tailcall attribute" }; + "Function call annotated with an incorrect @tailcall attribute."; + since = since 4 3 }; { number = 52; names = ["fragile-literal-pattern"]; - description = "Fragile constant pattern." }; + description = "Fragile constant pattern."; + since = since 4 3 }; { number = 53; names = ["misplaced-attribute"]; - description = "Attribute cannot appear in this context." }; + description = "Attribute cannot appear in this context."; + since = since 4 3 }; { number = 54; names = ["duplicated-attribute"]; - description = "Attribute used more than once on an expression." }; + description = "Attribute used more than once on an expression."; + since = since 4 3 }; { number = 55; names = ["inlining-impossible"]; - description = "Inlining impossible." }; + description = "Inlining impossible."; + since = since 4 3 }; { number = 56; names = ["unreachable-case"]; description = - "Unreachable case in a pattern-matching (based on type information)." }; + "Unreachable case in a pattern-matching (based on type information)."; + since = since 4 3 }; { number = 57; names = ["ambiguous-var-in-pattern-guard"]; - description = "Ambiguous or-pattern variables under guard." }; + description = "Ambiguous or-pattern variables under guard."; + since = since 4 3 }; { number = 58; names = ["no-cmx-file"]; - description = "Missing cmx file." }; + description = "Missing cmx file."; + since = since 4 3 }; { number = 59; names = ["flambda-assignment-to-non-mutable-value"]; - description = "Assignment to non-mutable value." }; + description = "Assignment to non-mutable value."; + since = since 4 3 }; { number = 60; names = ["unused-module"]; - description = "Unused module declaration." }; + description = "Unused module declaration."; + since = since 4 4 }; { number = 61; names = ["unboxable-type-in-prim-decl"]; - description = "Unboxable type in primitive declaration." }; + description = "Unboxable type in primitive declaration."; + since = since 4 4 }; { number = 62; names = ["constraint-on-gadt"]; - description = "Type constraint on GADT type declaration." }; + description = "Type constraint on GADT type declaration."; + since = since 4 6 }; { number = 63; names = ["erroneous-printed-signature"]; - description = "Erroneous printed signature." }; + description = "Erroneous printed signature."; + since = since 4 8 }; { number = 64; names = ["unsafe-array-syntax-without-parsing"]; description = - "-unsafe used with a preprocessor returning a syntax tree." }; + "-unsafe used with a preprocessor returning a syntax tree."; + since = since 4 8 }; { number = 65; names = ["redefining-unit"]; - description = "Type declaration defining a new '()' constructor." }; + description = "Type declaration defining a new '()' constructor."; + since = since 4 8 }; { number = 66; names = ["unused-open-bang"]; - description = "Unused open! statement." }; + description = "Unused open! statement."; + since = since 4 8 }; { number = 67; names = ["unused-functor-parameter"]; - description = "Unused functor parameter." }; + description = "Unused functor parameter."; + since = since 4 10 }; { number = 68; names = ["match-on-mutable-state-prevent-uncurry"]; description = "Pattern-matching depending on mutable state prevents the remaining \n\ - \ arguments from being uncurried." }; + \ arguments from being uncurried."; + since = since 4 12 }; { number = 69; names = ["unused-field"]; - description = "Unused record field." }; + description = "Unused record field."; + since = since 4 13 }; { number = 70; names = ["missing-mli"]; - description = "Missing interface file." }; + description = "Missing interface file."; + since = since 4 13 }; { number = 71; names = ["unused-tmc-attribute"]; - description = "Unused @tail_mod_cons attribute" }; + description = "Unused @tail_mod_cons attribute."; + since = since 4 14 }; { number = 72; names = ["tmc-breaks-tailcall"]; description = "A tail call is turned into a non-tail call \ - by the @tail_mod_cons transformation." }; + by the @tail_mod_cons transformation."; + since = since 4 14 }; ] let name_to_number = @@ -608,6 +686,10 @@ type token = | Letter of char * modifier option | Num of int * int * modifier +let ghost_loc_in_file name = + let pos = { Lexing.dummy_pos with pos_fname = name } in + { loc_start = pos; loc_end = pos; loc_ghost = true } + let letter_alert tokens = let print_warning_char ppf c = let lowercase = Char.lowercase_ascii c = c in @@ -646,8 +728,7 @@ let letter_alert tokens = 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 nowhere = ghost_loc_in_file "_none_" in let spelling_hint ppf = let max_seq_len = List.fold_left (fun l x -> Int.max l (List.length x)) @@ -963,17 +1044,24 @@ let message = function | 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 + let vars = List.sort String.compare vars in + let vars_explanation = + let in_different_places = + "in different places in different or-pattern alternatives" + in match vars with | [] -> assert false - | [x] -> "variable " ^ x + | [x] -> "variable " ^ x ^ " appears " ^ in_different_places | _::_ -> - "variables " ^ String.concat "," vars in + let vars = String.concat ", " vars in + "variables " ^ vars ^ " appear " ^ in_different_places + in Printf.sprintf "Ambiguous or-pattern variables under guard;\n\ - %s may match different arguments. %t" - msg ref_manual_explanation + %s.\n\ + Only the first match will be used to evaluate the guard expression.\n\ + %t" + vars_explanation ref_manual_explanation | No_cmx_file name -> Printf.sprintf "no cmx file was found in path for module %s, \ @@ -1025,16 +1113,17 @@ let message = function | Missing_mli -> "Cannot find interface file." | Unused_tmc_attribute -> - "This function is marked @tail_mod_cons but is never applied in \ - TMC position." + "This function is marked @tail_mod_cons\n\ + but is never applied in TMC position." | Tmc_breaks_tailcall -> - "This call is in tail-modulo-cons position in a TMC function,\n\ + "This call\n\ + is in tail-modulo-cons positionin a TMC function,\n\ but the function called is not itself specialized for TMC,\n\ so the call will not be transformed into a tail call.\n\ - Please either mark the called function with\n\ - the [@tail_mod_cons] attribute, or mark this call with\n\ - the [@tailcall false] attribute to make its non-tailness \ - explicit." + Please either mark the called function with the [@tail_mod_cons]\n\ + attribute, or mark this call with the [@tailcall false] attribute\n\ + to make its non-tailness explicit." +;; let nerrors = ref 0 @@ -1106,15 +1195,22 @@ let check_fatal () = raise Errors; end +let pp_since out release_info = + Printf.fprintf out " (since %d.%0*d)" + release_info.Sys.major + (if release_info.Sys.major >= 5 then 0 else 2) + release_info.Sys.minor + let help_warnings () = List.iter - (fun {number; description; names} -> + (fun {number; description; names; since} -> let name = match names with | s :: _ -> " [" ^ s ^ "]" | [] -> "" in - Printf.printf "%3i%s %s\n" number name description) + Printf.printf "%3i%s %s%a\n" + number name description (fun out -> Option.iter (pp_since out)) since) descriptions; print_endline " A all warnings"; for i = Char.code 'b' to Char.code 'z' do diff --git a/upstream/ocaml_500/utils/warnings.ml.orig b/upstream/ocaml_500/utils/warnings.ml.orig deleted file mode 100644 index 7f84a175b2..0000000000 --- a/upstream/ocaml_500/utils/warnings.ml.orig +++ /dev/null @@ -1,1137 +0,0 @@ -(**************************************************************************) -(* *) -(* 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 *) - | Unused_tmc_attribute (* 71 *) - | Tmc_breaks_tailcall (* 72 *) -;; - -(* 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 - | Unused_tmc_attribute -> 71 - | Tmc_breaks_tailcall -> 72 -;; - -let last_warning_number = 72 -;; - -type description = - { number : int; - names : string list; - (* 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. *) - description : string; } - -let descriptions = [ - { number = 1; - names = ["comment-start"]; - description = "Suspicious-looking start-of-comment mark." }; - { number = 2; - names = ["comment-not-end"]; - description = "Suspicious-looking end-of-comment mark." }; - { number = 3; - names = []; - description = "Deprecated synonym for the 'deprecated' alert." }; - { number = 4; - names = ["fragile-match"]; - description = - "Fragile pattern matching: matching that will remain complete even\n\ - \ if additional constructors are added to one of the variant types\n\ - \ matched." }; - { number = 5; - names = ["ignored-partial-application"]; - description = - "Partially applied function: expression whose result has function\n\ - \ type and is ignored." }; - { number = 6; - names = ["labels-omitted"]; - description = "Label omitted in function application." }; - { number = 7; - names = ["method-override"]; - description = "Method overridden." }; - { number = 8; - names = ["partial-match"]; - description = "Partial match: missing cases in pattern-matching." }; - { number = 9; - names = ["missing-record-field-pattern"]; - description = "Missing fields in a record pattern." }; - { number = 10; - names = ["non-unit-statement"]; - description = - "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)." }; - { number = 11; - names = ["redundant-case"]; - description = - "Redundant case in a pattern matching (unused match case)." }; - { number = 12; - names = ["redundant-subpat"]; - description = "Redundant sub-pattern in a pattern-matching." }; - { number = 13; - names = ["instance-variable-override"]; - description = "Instance variable overridden." }; - { number = 14; - names = ["illegal-backslash"]; - description = "Illegal backslash escape in a string constant." }; - { number = 15; - names = ["implicit-public-methods"]; - description = "Private method made public implicitly." }; - { number = 16; - names = ["unerasable-optional-argument"]; - description = "Unerasable optional argument." }; - { number = 17; - names = ["undeclared-virtual-method"]; - description = "Undeclared virtual method." }; - { number = 18; - names = ["not-principal"]; - description = "Non-principal type." }; - { number = 19; - names = ["non-principal-labels"]; - description = "Type without principality." }; - { number = 20; - names = ["ignored-extra-argument"]; - description = "Unused function argument." }; - { number = 21; - names = ["nonreturning-statement"]; - description = "Non-returning statement." }; - { number = 22; - names = ["preprocessor"]; - description = "Preprocessor warning." }; - { number = 23; - names = ["useless-record-with"]; - description = "Useless record \"with\" clause." }; - { number = 24; - names = ["bad-module-name"]; - description = - "Bad module name: the source file name is not a valid OCaml module name."}; - { number = 25; - names = []; - description = "Ignored: now part of warning 8." }; - { number = 26; - names = ["unused-var"]; - description = - "Suspicious unused variable: unused variable that is bound\n\ - \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character." }; - { number = 27; - names = ["unused-var-strict"]; - description = - "Innocuous unused variable: unused variable that is not bound with\n\ - \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character." }; - { number = 28; - names = ["wildcard-arg-to-constant-constr"]; - description = - "Wildcard pattern given as argument to a constant constructor." }; - { number = 29; - names = ["eol-in-string"]; - description = - "Unescaped end-of-line in a string constant (non-portable code)." }; - { number = 30; - names = ["duplicate-definitions"]; - description = - "Two labels or constructors of the same name are defined in two\n\ - \ mutually recursive types." }; - { number = 31; - names = ["module-linked-twice"]; - description = "A module is linked twice in the same executable." }; - { number = 32; - names = ["unused-value-declaration"]; - description = "Unused value declaration." }; - { number = 33; - names = ["unused-open"]; - description = "Unused open statement." }; - { number = 34; - names = ["unused-type-declaration"]; - description = "Unused type declaration." }; - { number = 35; - names = ["unused-for-index"]; - description = "Unused for-loop index." }; - { number = 36; - names = ["unused-ancestor"]; - description = "Unused ancestor variable." }; - { number = 37; - names = ["unused-constructor"]; - description = "Unused constructor." }; - { number = 38; - names = ["unused-extension"]; - description = "Unused extension constructor." }; - { number = 39; - names = ["unused-rec-flag"]; - description = "Unused rec flag." }; - { number = 40; - names = ["name-out-of-scope"]; - description = "Constructor or label name used out of scope." }; - { number = 41; - names = ["ambiguous-name"]; - description = "Ambiguous constructor or label name." }; - { number = 42; - names = ["disambiguated-name"]; - description = - "Disambiguated constructor or label name (compatibility warning)." }; - { number = 43; - names = ["nonoptional-label"]; - description = "Nonoptional label applied as optional." }; - { number = 44; - names = ["open-shadow-identifier"]; - description = "Open statement shadows an already defined identifier." }; - { number = 45; - names = ["open-shadow-label-constructor"]; - description = - "Open statement shadows an already defined label or constructor." }; - { number = 46; - names = ["bad-env-variable"]; - description = "Error in environment variable." }; - { number = 47; - names = ["attribute-payload"]; - description = "Illegal attribute payload." }; - { number = 48; - names = ["eliminated-optional-arguments"]; - description = "Implicit elimination of optional arguments." }; - { number = 49; - names = ["no-cmi-file"]; - description = "Absent cmi file when looking up module alias." }; - { number = 50; - names = ["unexpected-docstring"]; - description = "Unexpected documentation comment." }; - { number = 51; - names = ["wrong-tailcall-expectation"]; - description = - "Function call annotated with an incorrect @tailcall attribute" }; - { number = 52; - names = ["fragile-literal-pattern"]; - description = "Fragile constant pattern." }; - { number = 53; - names = ["misplaced-attribute"]; - description = "Attribute cannot appear in this context." }; - { number = 54; - names = ["duplicated-attribute"]; - description = "Attribute used more than once on an expression." }; - { number = 55; - names = ["inlining-impossible"]; - description = "Inlining impossible." }; - { number = 56; - names = ["unreachable-case"]; - description = - "Unreachable case in a pattern-matching (based on type information)." }; - { number = 57; - names = ["ambiguous-var-in-pattern-guard"]; - description = "Ambiguous or-pattern variables under guard." }; - { number = 58; - names = ["no-cmx-file"]; - description = "Missing cmx file." }; - { number = 59; - names = ["flambda-assignment-to-non-mutable-value"]; - description = "Assignment to non-mutable value." }; - { number = 60; - names = ["unused-module"]; - description = "Unused module declaration." }; - { number = 61; - names = ["unboxable-type-in-prim-decl"]; - description = "Unboxable type in primitive declaration." }; - { number = 62; - names = ["constraint-on-gadt"]; - description = "Type constraint on GADT type declaration." }; - { number = 63; - names = ["erroneous-printed-signature"]; - description = "Erroneous printed signature." }; - { number = 64; - names = ["unsafe-array-syntax-without-parsing"]; - description = - "-unsafe used with a preprocessor returning a syntax tree." }; - { number = 65; - names = ["redefining-unit"]; - description = "Type declaration defining a new '()' constructor." }; - { number = 66; - names = ["unused-open-bang"]; - description = "Unused open! statement." }; - { number = 67; - names = ["unused-functor-parameter"]; - description = "Unused functor parameter." }; - { number = 68; - names = ["match-on-mutable-state-prevent-uncurry"]; - description = - "Pattern-matching depending on mutable state prevents the remaining \n\ - \ arguments from being uncurried." }; - { number = 69; - names = ["unused-field"]; - description = "Unused record field." }; - { number = 70; - names = ["missing-mli"]; - description = "Missing interface file." }; - { number = 71; - names = ["unused-tmc-attribute"]; - description = "Unused @tail_mod_cons attribute" }; - { number = 72; - names = ["tmc-breaks-tailcall"]; - description = "A tail call is turned into a non-tail call \ - by the @tail_mod_cons transformation." }; -] -;; - -let name_to_number = - let h = Hashtbl.create last_warning_number in - List.iter (fun {number; names; _} -> - List.iter (fun name -> Hashtbl.add h name number) 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 with_state state f = - let prev = backup () in - restore state; - try - let r = f () in - restore prev; - r - with exn -> - restore prev; - raise exn - -let mk_lazy f = - let state = backup () in - lazy (with_state state f) - -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 - "@[@[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." - | Instance_variable_override (cname :: slist) -> - String.concat " " - ("the following instance variables are overridden by the class" - :: cname :: ":\n " :: slist) - | 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 ' -> .'" - | 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." - | Unused_tmc_attribute -> - "This function is marked @tail_mod_cons but is never applied in \ - TMC position." - | Tmc_breaks_tailcall -> - "This call is in tail-modulo-cons position in a TMC function,\n\ - but the function called is not itself specialized for TMC,\n\ - so the call will not be transformed into a tail call.\n\ - Please either mark the called function with\n\ - the [@tail_mod_cons] attribute, or mark this call with\n\ - the [@tailcall false] attribute to make its non-tailness \ - explicit." -;; - -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 {number; _} -> number = n) descriptions with - | Some {names = 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 {number; description; names} -> - let name = - match names with - | s :: _ -> " [" ^ s ^ "]" - | [] -> "" - in - Printf.printf "%3i%s %s\n" number name description) - 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_500/utils/warnings.mli b/upstream/ocaml_500/utils/warnings.mli index 6ec73928b0..57654747de 100644 --- a/upstream/ocaml_500/utils/warnings.mli +++ b/upstream/ocaml_500/utils/warnings.mli @@ -26,6 +26,9 @@ type loc = { loc_ghost: bool; } +val ghost_loc_in_file : string -> loc +(** Return an empty ghost range located in a given file *) + type field_usage_warning = | Unused | Not_read @@ -157,6 +160,7 @@ val mk_lazy: (unit -> 'a) -> 'a Lazy.t type description = { number : int; names : string list; - description : string; } + description : string; + since : Sys.ocaml_release_info option; } val descriptions : description list From aa8030579adfc4a51f9de62c90b6feb5332ae544 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 24 Jun 2022 11:05:28 +0200 Subject: [PATCH 010/130] Merge changes from upstream into Merlin --- src/ocaml/parsing/ast_mapper.ml | 12 +- src/ocaml/parsing/location.ml | 33 ++++- src/ocaml/parsing/location.mli | 14 ++ src/ocaml/parsing/pprintast.ml | 10 +- src/ocaml/typing/ident.ml | 13 ++ src/ocaml/typing/ident.mli | 31 +++- src/ocaml/typing/typecore.ml | 6 +- src/ocaml/typing/typemod.ml | 8 +- src/ocaml/utils/config.ml | 24 ++-- src/ocaml/utils/load_path.ml | 73 ++++++++-- src/ocaml/utils/load_path.mli | 49 +++++-- src/ocaml/utils/local_store.mli | 4 +- src/ocaml/utils/warnings.ml | 242 ++++++++++++++++++++++---------- src/ocaml/utils/warnings.mli | 6 +- 14 files changed, 388 insertions(+), 137 deletions(-) diff --git a/src/ocaml/parsing/ast_mapper.ml b/src/ocaml/parsing/ast_mapper.ml index 356126c56a..d7ad7d2d0d 100644 --- a/src/ocaml/parsing/ast_mapper.ml +++ b/src/ocaml/parsing/ast_mapper.ml @@ -903,7 +903,17 @@ module PpxContext = struct | "include_dirs" -> Clflags.include_dirs := get_list get_string payload | "load_path" -> - Load_path.init (get_list get_string payload) + (* Duplicates Compmisc.auto_include, since we can't reference Compmisc + from this module. *) + (* let auto_include find_in_dir fn = + if !Clflags.no_std_include then + raise Not_found + else + let alert = Location.auto_include_alert in + Load_path.auto_include_otherlibs alert find_in_dir fn + in *) + Load_path.(init + ~auto_include:no_auto_include (get_list get_string payload)) | "open_modules" -> Clflags.open_modules := get_list get_string payload | "for_package" -> diff --git a/src/ocaml/parsing/location.ml b/src/ocaml/parsing/location.ml index 92c467a648..4272a47be2 100644 --- a/src/ocaml/parsing/location.ml +++ b/src/ocaml/parsing/location.ml @@ -18,10 +18,7 @@ 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 in_file = Warnings.ghost_loc_in_file let none = in_file "_none_" let is_none l = (l = none) @@ -83,6 +80,7 @@ let mknoloc txt = mkloc txt none let input_name = ref "_none_" let input_lexbuf = ref (None : lexbuf option) +let input_phrase_buffer = ref (None : Buffer.t option) (******************************************************************************) (* Terminal info *) @@ -765,6 +763,33 @@ let alert ?(def = none) ?(use = none) ~kind loc message = let deprecated ?def ?use loc message = alert ?def ?use ~kind:"deprecated" loc message + +let auto_include_alert lib = + let message = Printf.sprintf "\ + OCaml's lib directory layout changed in 5.0. The %s subdirectory has been \ + automatically added to the search path, but you should add -I +%s to the \ + command-line to silence this alert (e.g. by adding %s to the list of \ + libraries in your dune file, or adding use_%s to your _tags file for \ + ocamlbuild, or using -package %s for ocamlfind)." lib lib lib lib lib in + let alert = + {Warnings.kind="ocaml_deprecated_auto_include"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + +let deprecated_script_alert program = + let message = Printf.sprintf "\ + Running %s where the first argument is an implicit basename with no \ + extension (e.g. %s script-file) is deprecated. Either rename the script \ + (%s script-file.ml) or qualify the basename (%s ./script-file)" + program program program program + in + let alert = + {Warnings.kind="ocaml_deprecated_cli"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + (******************************************************************************) (* Reporting errors on exceptions *) diff --git a/src/ocaml/parsing/location.mli b/src/ocaml/parsing/location.mli index 63038ca62c..c6aa29b167 100644 --- a/src/ocaml/parsing/location.mli +++ b/src/ocaml/parsing/location.mli @@ -39,6 +39,7 @@ 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. *) @@ -76,6 +77,12 @@ val mkloc : 'a -> t -> 'a loc 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} *) @@ -236,6 +243,13 @@ val deprecated: ?def:t -> ?use:t -> t -> string -> unit val alert: ?def:t -> ?use:t -> kind:string -> t -> string -> unit (** Prints an arbitrary alert. *) +val auto_include_alert: string -> unit +(** Prints an alert that -I +lib has been automatically added to the load + path *) + +val deprecated_script_alert: string -> unit +(** [deprecated_script_alert command] prints an alert that [command foo] has + been deprecated in favour of [command ./foo] *) (** {1 Reporting errors} *) diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml index b6557de4c8..7915fcbc5a 100644 --- a/src/ocaml/parsing/pprintast.ml +++ b/src/ocaml/parsing/pprintast.ml @@ -1079,19 +1079,17 @@ and module_type 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 + (type_params ctxt) 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_params ctxt) ls + longident_loc li (type_declaration ctxt) td | Pwith_modsubst (li, li2) -> pp f "module %a :=@ %a" longident_loc li longident_loc li2 diff --git a/src/ocaml/typing/ident.ml b/src/ocaml/typing/ident.ml index dbd8a038f9..e881294bb2 100644 --- a/src/ocaml/typing/ident.ml +++ b/src/ocaml/typing/ident.ml @@ -149,6 +149,19 @@ let print_with_scope ppf id = print ~with_scope:true ppf id let print ppf id = print ~with_scope:false ppf id +(* For the documentation of ['a Ident.tbl], see ident.mli. + + The implementation is a copy-paste specialization of + a balanced-tree implementation similar to Map. + ['a tbl] + is a slightly more compact version of + [(Ident.t * 'a) list Map.Make(String)] + + This implementation comes from Caml Light where duplication was + unavoidable in absence of functors. It works well enough, and so + far we have not had strong incentives to do the deduplication work + (implementation, tests, benchmarks, etc.). +*) type 'a tbl = Empty | Node of 'a tbl * 'a data * 'a tbl * int diff --git a/src/ocaml/typing/ident.mli b/src/ocaml/typing/ident.mli index 2c04072d44..d78aa4e020 100644 --- a/src/ocaml/typing/ident.mli +++ b/src/ocaml/typing/ident.mli @@ -64,7 +64,36 @@ val highest_scope: int val reinit: unit -> unit type 'a tbl - (* Association tables from identifiers to type 'a. *) +(** ['a tbl] represents association tables from identifiers to values + of type ['a]. + + ['a tbl] plays the role of map, but bindings can be looked up + from either the full Ident using [find_same], or just its + user-visible name using [find_name]. In general the two lookups may + not return the same result, as an identifier may have been shadowed + in the environment by a distinct identifier with the same name. + + [find_all] returns the bindings for all idents of a given name, + most recently introduced first. + + In other words, + ['a tbl] + corresponds to + [(Ident.t * 'a) list Map.Make(String)] + and the implementation is very close to that representation. + + Note in particular that searching among idents of the same name + takes linear time, and that [add] simply extends the list without + checking for duplicates. So it is not a good idea to implement + union by repeated [add] calls, which may result in many duplicated + identifiers and poor [find_same] performance. It is even possible + to build overly large same-name lists such that non-recursive + functions like [find_all] or [fold_all] blow the stack. + + You should probably use [Map.Make(Ident)] instead, unless you + really need to query bindings by user-visible name, not just by + unique identifiers. +*) val empty: 'a tbl val add: t -> 'a -> 'a tbl -> 'a tbl diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index 91f46fd009..3776333868 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -832,7 +832,7 @@ let solve_Ppat_construct ~refine env loc constr no_existentials generalize_structure ty_res; List.iter generalize_structure ty_args; if !Clflags.principal && refine = None then begin - (* Do not warn for couter examples *) + (* Do not warn for counter-examples *) let exception Warn_only_once in try TypePairs.iter @@ -2701,14 +2701,14 @@ let check_statement exp = If [exp] has a function type, we check that it is not syntactically the result of a function application, as this is often a bug in certain contexts (eg the rhs of a let-binding or in the argument of [ignore]). For example, - [ignore (List.map print_int)] written by mistake instad of [ignore (List.map + [ignore (List.map print_int)] written by mistake instead of [ignore (List.map print_int li)]. The check can be disabled by explicitly annotating the expression with a type constraint, eg [(e : _ -> _)]. If [statement] is [true] and the [ignored-partial-application] is {em not} - triggered, then the [non-unit-statement] check is performaed (see + triggered, then the [non-unit-statement] check is performed (see [check_statement]). If the type of [exp] is not known at the time this function is called, the diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml index 0acce8e415..5662b69ae8 100644 --- a/src/ocaml/typing/typemod.ml +++ b/src/ocaml/typing/typemod.ml @@ -2153,11 +2153,9 @@ and package_constraints env loc mty constrs = end let modtype_of_package env loc p fl = - (* We call Ctype.correct_levels to ensure that the types being added to the - module type are at generic_level. *) let mty = package_constraints env loc (Mty_ident p) - (List.map (fun (n, t) -> Longident.flatten n, Ctype.correct_levels t) fl) + (List.map (fun (n, t) -> (Longident.flatten n, t)) fl) in Subst.modtype Keep Subst.identity mty @@ -2177,7 +2175,7 @@ let package_subtype env p1 fl1 p2 fl2 = let () = Ctype.package_subtype := package_subtype -let wrap_constraint env mark arg mty explicit = +let wrap_constraint_package env mark arg mty explicit = let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in let mty1 = Subst.modtype Keep Subst.identity arg.mod_type in let mty2 = Subst.modtype Keep Subst.identity mty in @@ -3137,7 +3135,7 @@ let type_package env m p fl = 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 + let modl = wrap_constraint_package env true modl mty Tmodtype_implicit in modl, fl' (* Fill in the forward declarations *) diff --git a/src/ocaml/utils/config.ml b/src/ocaml/utils/config.ml index 7ed564ea6c..78fab735d8 100644 --- a/src/ocaml/utils/config.ml +++ b/src/ocaml/utils/config.ml @@ -28,25 +28,25 @@ let version = Sys.ocaml_version let flambda = false -let exec_magic_number = "Caml1999X031" +let exec_magic_number = "Caml1999X032" (* exec_magic_number is duplicated in runtime/caml/exec.h *) -and cmi_magic_number = "Caml1999I031" -and cmo_magic_number = "Caml1999O031" -and cma_magic_number = "Caml1999A031" +and cmi_magic_number = "Caml1999I032" +and cmo_magic_number = "Caml1999O032" +and cma_magic_number = "Caml1999A032" and cmx_magic_number = if flambda then - "Caml1999y031" + "Caml1999y032" else - "Caml1999Y031" + "Caml1999Y032" and cmxa_magic_number = if flambda then - "Caml1999z031" + "Caml1999z032" else - "Caml1999Z031" -and ast_impl_magic_number = "Caml1999M031" -and ast_intf_magic_number = "Caml1999N031" -and cmxs_magic_number = "Caml1999D031" -and cmt_magic_number = "Caml1999T031" + "Caml1999Z032" +and ast_impl_magic_number = "Caml1999M032" +and ast_intf_magic_number = "Caml1999N032" +and cmxs_magic_number = "Caml1999D032" +and cmt_magic_number = "Caml1999T032" let interface_suffix = ref ".mli" diff --git a/src/ocaml/utils/load_path.ml b/src/ocaml/utils/load_path.ml index 045af69a47..7094b064c2 100644 --- a/src/ocaml/utils/load_path.ml +++ b/src/ocaml/utils/load_path.ml @@ -31,6 +31,22 @@ module Dir = struct let path t = t.path let files t = t.files + let find t fn = + if List.mem fn t.files then + Some (Filename.concat t.path fn) + else + None + + let find_uncap t fn = + let fn = String.uncapitalize_ascii fn in + let search base = + if String.uncapitalize_ascii base = fn then + Some (Filename.concat t.path base) + else + None + in + List.find_map search t.files + let create path = { path; files = Array.to_list (Directory_content_cache.read path) } @@ -38,13 +54,18 @@ module Dir = struct end +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string let dirs = s_ref [] +let no_auto_include _ _ = raise Not_found +let auto_include_callback = ref no_auto_include let reset () = assert (not Config.merlin || Local_store.is_bound ()); STbl.clear !files; STbl.clear !files_uncap; - dirs := [] + dirs := []; + auto_include_callback := no_auto_include let get () = List.rev !dirs let get_paths () = List.rev_map Dir.path !dirs @@ -60,7 +81,7 @@ let prepend_add dir = STbl.replace !files_uncap (String.uncapitalize_ascii base) fn ) dir.Dir.files -let init l = +let init ~auto_include l = assert (not Config.merlin || Local_store.is_bound ()); let rec loop_changed acc = function | [] -> Some acc @@ -89,7 +110,8 @@ let init l = | Some new_dirs -> reset (); dirs := new_dirs; - List.iter prepend_add new_dirs + List.iter prepend_add new_dirs; + auto_include_callback := auto_include let remove_dir dir = assert (not Config.merlin || Local_store.is_bound ()); @@ -129,16 +151,45 @@ let prepend_dir dir = let is_basename fn = Filename.basename fn = fn +let auto_include_libs libs alert find_in_dir fn = + let scan (lib, lazy dir) = + let file = find_in_dir dir fn in + let alert_and_add_dir _ = + alert lib; + append_dir dir + in + Option.iter alert_and_add_dir file; + file + in + match List.find_map scan libs with + | Some base -> base + | None -> raise Not_found + +(* let auto_include_otherlibs = + (* Ensure directories are only ever scanned once *) + let expand = Misc.expand_directory Config.standard_library in + let otherlibs = + let read_lib lib = lazy (Dir.create (expand ("+" ^ lib))) in + List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in + auto_include_libs otherlibs *) + 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 + try + if is_basename fn && not !Sys.interactive then + STbl.find !files fn + else + Misc.find_in_path (get_paths ()) fn + with Not_found -> + !auto_include_callback Dir.find 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 + try + 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 + with Not_found -> + let fn_uncap = String.uncapitalize_ascii fn in + !auto_include_callback Dir.find_uncap fn_uncap diff --git a/src/ocaml/utils/load_path.mli b/src/ocaml/utils/load_path.mli index 1f9aba28bf..7d9abe0a0b 100644 --- a/src/ocaml/utils/load_path.mli +++ b/src/ocaml/utils/load_path.mli @@ -31,9 +31,43 @@ val remove_dir : string -> unit val reset : unit -> unit (** Remove all directories *) -val init : string list -> unit +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. *) + + val find : t -> string -> string option + (** [find dir fn] returns the full path to [fn] in [dir]. *) + + val find_uncap : t -> string -> string option + (** As {!find}, but search also for uncapitalized name, i.e. if name is + Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) +end + +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string +(** The type of callback functions on for [init ~auto_include] *) + +val no_auto_include : auto_include_callback +(** No automatic directory inclusion: misses in the load path raise [Not_found] + as normal. *) + +val init : auto_include:auto_include_callback -> string list -> unit (** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *) +(* val auto_include_otherlibs : + config:Mconfig.t -> (string -> unit) -> auto_include_callback *) +(** [auto_include_otherlibs alert] is a callback function to be passed to + {!Load_path.init} and automatically adds [-I +lib] to the load path after + calling [alert lib]. *) + val get_paths : unit -> string list (** Return the list of directories passed to [add_dir] so far. *) @@ -47,19 +81,6 @@ 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} *) diff --git a/src/ocaml/utils/local_store.mli b/src/ocaml/utils/local_store.mli index 94346b96d7..3ea05d5889 100644 --- a/src/ocaml/utils/local_store.mli +++ b/src/ocaml/utils/local_store.mli @@ -23,8 +23,8 @@ (** {1 Creators} *) val s_ref : 'a -> 'a ref -(** Similar to {!Stdlib.ref}, except the allocated reference is registered into - the store. *) +(** Similar to {!val:Stdlib.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 diff --git a/src/ocaml/utils/warnings.ml b/src/ocaml/utils/warnings.ml index 81657c5efb..333f627dcd 100644 --- a/src/ocaml/utils/warnings.ml +++ b/src/ocaml/utils/warnings.ml @@ -201,252 +201,330 @@ type description = (* 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. *) - description : string; } + description : string; + since : Sys.ocaml_release_info option; + (* The compiler version introducing this warning; only tagged for warnings + created after 3.12, which introduced the numbered syntax. *) + } + + let since major minor = Some { Sys.major; minor; patchlevel=0; extra=None } let descriptions = [ { number = 1; names = ["comment-start"]; - description = "Suspicious-looking start-of-comment mark." }; + description = "Suspicious-looking start-of-comment mark."; + since = None }; { number = 2; names = ["comment-not-end"]; - description = "Suspicious-looking end-of-comment mark." }; + description = "Suspicious-looking end-of-comment mark."; + since = None }; { number = 3; names = []; - description = "Deprecated synonym for the 'deprecated' alert." }; + description = "Deprecated synonym for the 'deprecated' alert."; + since = None }; { number = 4; names = ["fragile-match"]; description = "Fragile pattern matching: matching that will remain complete even\n\ \ if additional constructors are added to one of the variant types\n\ - \ matched." }; + \ matched."; + since = None }; { number = 5; names = ["ignored-partial-application"]; description = "Partially applied function: expression whose result has function\n\ - \ type and is ignored." }; + \ type and is ignored."; + since = None }; { number = 6; names = ["labels-omitted"]; - description = "Label omitted in function application." }; + description = "Label omitted in function application."; + since = None }; { number = 7; names = ["method-override"]; - description = "Method overridden." }; + description = "Method overridden."; + since = None }; { number = 8; names = ["partial-match"]; - description = "Partial match: missing cases in pattern-matching." }; + description = "Partial match: missing cases in pattern-matching."; + since = None }; { number = 9; names = ["missing-record-field-pattern"]; - description = "Missing fields in a record pattern." }; + description = "Missing fields in a record pattern."; + since = None }; { number = 10; names = ["non-unit-statement"]; description = "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)." }; + \ \"unit\" (and that is not a function, see warning number 5)."; + since = None }; { number = 11; names = ["redundant-case"]; description = - "Redundant case in a pattern matching (unused match case)." }; + "Redundant case in a pattern matching (unused match case)."; + since = None }; { number = 12; names = ["redundant-subpat"]; - description = "Redundant sub-pattern in a pattern-matching." }; + description = "Redundant sub-pattern in a pattern-matching." ; + since = None}; { number = 13; names = ["instance-variable-override"]; - description = "Instance variable overridden." }; + description = "Instance variable overridden."; + since = None }; { number = 14; names = ["illegal-backslash"]; - description = "Illegal backslash escape in a string constant." }; + description = "Illegal backslash escape in a string constant."; + since = None }; { number = 15; names = ["implicit-public-methods"]; - description = "Private method made public implicitly." }; + description = "Private method made public implicitly."; + since = None }; { number = 16; names = ["unerasable-optional-argument"]; - description = "Unerasable optional argument." }; + description = "Unerasable optional argument."; + since = None }; { number = 17; names = ["undeclared-virtual-method"]; - description = "Undeclared virtual method." }; + description = "Undeclared virtual method."; + since = None }; { number = 18; names = ["not-principal"]; - description = "Non-principal type." }; + description = "Non-principal type."; + since = None }; { number = 19; names = ["non-principal-labels"]; - description = "Type without principality." }; + description = "Type without principality."; + since = None }; { number = 20; names = ["ignored-extra-argument"]; - description = "Unused function argument." }; + description = "Unused function argument."; + since = None }; { number = 21; names = ["nonreturning-statement"]; - description = "Non-returning statement." }; + description = "Non-returning statement."; + since = None }; { number = 22; names = ["preprocessor"]; - description = "Preprocessor warning." }; + description = "Preprocessor warning."; + since = None }; { number = 23; names = ["useless-record-with"]; - description = "Useless record \"with\" clause." }; + description = "Useless record \"with\" clause."; + since = None }; { number = 24; names = ["bad-module-name"]; description = - "Bad module name: the source file name is not a valid OCaml module name."}; + "Bad module name: the source file name is not a valid OCaml module name."; + since = None }; { number = 25; names = []; - description = "Ignored: now part of warning 8." }; + description = "Ignored: now part of warning 8."; + since = None }; { number = 26; names = ["unused-var"]; description = "Suspicious unused variable: unused variable that is bound\n\ \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character." }; + \ character."; + since = None }; { number = 27; names = ["unused-var-strict"]; description = "Innocuous unused variable: unused variable that is not bound with\n\ \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character." }; + \ character."; + since = None }; { number = 28; names = ["wildcard-arg-to-constant-constr"]; description = - "Wildcard pattern given as argument to a constant constructor." }; + "Wildcard pattern given as argument to a constant constructor."; + since = None }; { number = 29; names = ["eol-in-string"]; description = - "Unescaped end-of-line in a string constant (non-portable code)." }; + "Unescaped end-of-line in a string constant (non-portable code)."; + since = None }; { number = 30; names = ["duplicate-definitions"]; description = "Two labels or constructors of the same name are defined in two\n\ - \ mutually recursive types." }; + \ mutually recursive types."; + since = None }; { number = 31; names = ["module-linked-twice"]; - description = "A module is linked twice in the same executable." }; + description = "A module is linked twice in the same executable."; + since = since 4 0 }; { number = 32; names = ["unused-value-declaration"]; - description = "Unused value declaration." }; + description = "Unused value declaration."; + since = since 4 0 }; { number = 33; names = ["unused-open"]; - description = "Unused open statement." }; + description = "Unused open statement."; + since = since 4 0 }; { number = 34; names = ["unused-type-declaration"]; - description = "Unused type declaration." }; + description = "Unused type declaration."; + since = since 4 0 }; { number = 35; names = ["unused-for-index"]; - description = "Unused for-loop index." }; + description = "Unused for-loop index."; + since = since 4 0 }; { number = 36; names = ["unused-ancestor"]; - description = "Unused ancestor variable." }; + description = "Unused ancestor variable."; + since = since 4 0 }; { number = 37; names = ["unused-constructor"]; - description = "Unused constructor." }; + description = "Unused constructor."; + since = since 4 0 }; { number = 38; names = ["unused-extension"]; - description = "Unused extension constructor." }; + description = "Unused extension constructor."; + since = since 4 0 }; { number = 39; names = ["unused-rec-flag"]; - description = "Unused rec flag." }; + description = "Unused rec flag."; + since = since 4 0 }; { number = 40; names = ["name-out-of-scope"]; - description = "Constructor or label name used out of scope." }; + description = "Constructor or label name used out of scope."; + since = since 4 1 }; { number = 41; names = ["ambiguous-name"]; - description = "Ambiguous constructor or label name." }; + description = "Ambiguous constructor or label name."; + since = since 4 1 }; { number = 42; names = ["disambiguated-name"]; description = - "Disambiguated constructor or label name (compatibility warning)." }; + "Disambiguated constructor or label name (compatibility warning)."; + since = since 4 1 }; { number = 43; names = ["nonoptional-label"]; - description = "Nonoptional label applied as optional." }; + description = "Nonoptional label applied as optional."; + since = since 4 1 }; { number = 44; names = ["open-shadow-identifier"]; - description = "Open statement shadows an already defined identifier." }; + description = "Open statement shadows an already defined identifier."; + since = since 4 1 }; { number = 45; names = ["open-shadow-label-constructor"]; description = - "Open statement shadows an already defined label or constructor." }; + "Open statement shadows an already defined label or constructor."; + since = since 4 1 }; { number = 46; names = ["bad-env-variable"]; - description = "Error in environment variable." }; + description = "Error in environment variable."; + since = since 4 1 }; { number = 47; names = ["attribute-payload"]; - description = "Illegal attribute payload." }; + description = "Illegal attribute payload."; + since = since 4 2 }; { number = 48; names = ["eliminated-optional-arguments"]; - description = "Implicit elimination of optional arguments." }; + description = "Implicit elimination of optional arguments."; + since = since 4 2 }; { number = 49; names = ["no-cmi-file"]; - description = "Absent cmi file when looking up module alias." }; + description = "Absent cmi file when looking up module alias."; + since = since 4 2 }; { number = 50; names = ["unexpected-docstring"]; - description = "Unexpected documentation comment." }; + description = "Unexpected documentation comment."; + since = since 4 3 }; { number = 51; names = ["wrong-tailcall-expectation"]; description = - "Function call annotated with an incorrect @tailcall attribute" }; + "Function call annotated with an incorrect @tailcall attribute."; + since = since 4 3 }; { number = 52; names = ["fragile-literal-pattern"]; - description = "Fragile constant pattern." }; + description = "Fragile constant pattern."; + since = since 4 3 }; { number = 53; names = ["misplaced-attribute"]; - description = "Attribute cannot appear in this context." }; + description = "Attribute cannot appear in this context."; + since = since 4 3 }; { number = 54; names = ["duplicated-attribute"]; - description = "Attribute used more than once on an expression." }; + description = "Attribute used more than once on an expression."; + since = since 4 3 }; { number = 55; names = ["inlining-impossible"]; - description = "Inlining impossible." }; + description = "Inlining impossible."; + since = since 4 3 }; { number = 56; names = ["unreachable-case"]; description = - "Unreachable case in a pattern-matching (based on type information)." }; + "Unreachable case in a pattern-matching (based on type information)."; + since = since 4 3 }; { number = 57; names = ["ambiguous-var-in-pattern-guard"]; - description = "Ambiguous or-pattern variables under guard." }; + description = "Ambiguous or-pattern variables under guard."; + since = since 4 3 }; { number = 58; names = ["no-cmx-file"]; - description = "Missing cmx file." }; + description = "Missing cmx file."; + since = since 4 3 }; { number = 59; names = ["flambda-assignment-to-non-mutable-value"]; - description = "Assignment to non-mutable value." }; + description = "Assignment to non-mutable value."; + since = since 4 3 }; { number = 60; names = ["unused-module"]; - description = "Unused module declaration." }; + description = "Unused module declaration."; + since = since 4 4 }; { number = 61; names = ["unboxable-type-in-prim-decl"]; - description = "Unboxable type in primitive declaration." }; + description = "Unboxable type in primitive declaration."; + since = since 4 4 }; { number = 62; names = ["constraint-on-gadt"]; - description = "Type constraint on GADT type declaration." }; + description = "Type constraint on GADT type declaration."; + since = since 4 6 }; { number = 63; names = ["erroneous-printed-signature"]; - description = "Erroneous printed signature." }; + description = "Erroneous printed signature."; + since = since 4 8 }; { number = 64; names = ["unsafe-array-syntax-without-parsing"]; description = - "-unsafe used with a preprocessor returning a syntax tree." }; + "-unsafe used with a preprocessor returning a syntax tree."; + since = since 4 8 }; { number = 65; names = ["redefining-unit"]; - description = "Type declaration defining a new '()' constructor." }; + description = "Type declaration defining a new '()' constructor."; + since = since 4 8 }; { number = 66; names = ["unused-open-bang"]; - description = "Unused open! statement." }; + description = "Unused open! statement."; + since = since 4 8 }; { number = 67; names = ["unused-functor-parameter"]; - description = "Unused functor parameter." }; + description = "Unused functor parameter."; + since = since 4 10 }; { number = 68; names = ["match-on-mutable-state-prevent-uncurry"]; description = "Pattern-matching depending on mutable state prevents the remaining \n\ - \ arguments from being uncurried." }; + \ arguments from being uncurried."; + since = since 4 12 }; { number = 69; names = ["unused-field"]; - description = "Unused record field." }; + description = "Unused record field."; + since = since 4 13 }; { number = 70; names = ["missing-mli"]; - description = "Missing interface file." }; + description = "Missing interface file."; + since = since 4 13 }; { number = 71; names = ["unused-tmc-attribute"]; - description = "Unused @tail_mod_cons attribute" }; + description = "Unused @tail_mod_cons attribute."; + since = since 4 14 }; { number = 72; names = ["tmc-breaks-tailcall"]; description = "A tail call is turned into a non-tail call \ - by the @tail_mod_cons transformation." }; + by the @tail_mod_cons transformation."; + since = since 4 14 }; ] let name_to_number = @@ -615,6 +693,10 @@ type token = | Letter of char * modifier option | Num of int * int * modifier +let ghost_loc_in_file name = + let pos = { Lexing.dummy_pos with pos_fname = name } in + { loc_start = pos; loc_end = pos; loc_ghost = true } + let letter_alert tokens = let print_warning_char ppf c = let lowercase = Char.lowercase_ascii c = c in @@ -653,8 +735,7 @@ let letter_alert tokens = 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 nowhere = ghost_loc_in_file "_none_" in let spelling_hint ppf = let max_seq_len = List.fold_left (fun l x -> Int.max l (List.length x)) @@ -1124,15 +1205,22 @@ let check_fatal () = raise Errors; end +let pp_since out release_info = + Printf.fprintf out " (since %d.%0*d)" + release_info.Sys.major + (if release_info.Sys.major >= 5 then 0 else 2) + release_info.Sys.minor + let help_warnings () = List.iter - (fun {number; description; names} -> + (fun {number; description; names; since} -> let name = match names with | s :: _ -> " [" ^ s ^ "]" | [] -> "" in - Printf.printf "%3i%s %s\n" number name description) + Printf.printf "%3i%s %s%a\n" + number name description (fun out -> Option.iter (pp_since out)) since) descriptions; print_endline " A all warnings"; for i = Char.code 'b' to Char.code 'z' do diff --git a/src/ocaml/utils/warnings.mli b/src/ocaml/utils/warnings.mli index 79f9f97372..7710356eed 100644 --- a/src/ocaml/utils/warnings.mli +++ b/src/ocaml/utils/warnings.mli @@ -26,6 +26,9 @@ type loc = { loc_ghost: bool; } +val ghost_loc_in_file : string -> loc +(** Return an empty ghost range located in a given file *) + type field_usage_warning = | Unused | Not_read @@ -157,7 +160,8 @@ val mk_lazy: (unit -> 'a) -> 'a Lazy.t type description = { number : int; names : string list; - description : string; } + description : string; + since : Sys.ocaml_release_info option; } val descriptions : description list From 7b350f217b067cbbc31b5e0685e5afe3013ebab1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 24 Jun 2022 11:09:17 +0200 Subject: [PATCH 011/130] fix load_path usages --- src/kernel/mocaml.ml | 2 +- src/kernel/mtyper.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/kernel/mocaml.ml b/src/kernel/mocaml.ml index 7291588ef5..de572d76f1 100644 --- a/src/kernel/mocaml.ml +++ b/src/kernel/mocaml.ml @@ -46,7 +46,7 @@ let setup_reader_config config = ( let setup_typer_config config = ( setup_reader_config config; - Load_path.init (Mconfig.build_path config); + Load_path.(init ~auto_include:no_auto_include (Mconfig.build_path config)); ) (** Switchable implementation of Oprint *) diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index 034cb10c7d..703c776b80 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -159,7 +159,7 @@ let run config parsetree = Mocaml.flush_caches (); Local_store.reset (); Load_path.reset (); - Load_path.init load_path; + Load_path.(init ~auto_include:no_auto_include load_path); ); let caught = ref [] in Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () -> From 60ed3216c375d4049e67bdafd3a095bd8d80f059 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 24 Jun 2022 11:09:27 +0200 Subject: [PATCH 012/130] Add str lib explicitely --- src/analysis/dune | 3 ++- src/frontend/dune | 3 ++- src/frontend/ocamlmerlin/dune | 2 +- src/kernel/dune | 5 +++-- 4 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/analysis/dune b/src/analysis/dune index 1521f351e9..6b4d2f6d09 100644 --- a/src/analysis/dune +++ b/src/analysis/dune @@ -21,4 +21,5 @@ ocaml_preprocess query_protocol ocaml_typing - ocaml_utils)) + ocaml_utils + str)) diff --git a/src/frontend/dune b/src/frontend/dune index 92776fa4f2..c5597f13f9 100644 --- a/src/frontend/dune +++ b/src/frontend/dune @@ -29,4 +29,5 @@ merlin_specific merlin_config merlin_analysis - query_protocol)) + query_protocol + str)) diff --git a/src/frontend/ocamlmerlin/dune b/src/frontend/ocamlmerlin/dune index e8ab3eccdd..629faa6e4b 100644 --- a/src/frontend/ocamlmerlin/dune +++ b/src/frontend/ocamlmerlin/dune @@ -17,7 +17,7 @@ (libraries merlin-lib.config yojson merlin-lib.analysis merlin-lib.kernel merlin-lib.utils merlin-lib.os_ipc merlin-lib.ocaml_parsing merlin-lib.query_protocol merlin-lib.query_commands - merlin-lib.ocaml_typing merlin-lib.ocaml_utils)) + merlin-lib.ocaml_typing merlin-lib.ocaml_utils unix str)) (executable (name gen_ccflags) diff --git a/src/kernel/dune b/src/kernel/dune index af69229174..7d12d85e73 100644 --- a/src/kernel/dune +++ b/src/kernel/dune @@ -13,8 +13,9 @@ -open Ocaml_typing -open Merlin_specific -open Merlin_extend) - (libraries merlin_config os_ipc ocaml_parsing ocaml_preprocess ocaml_typing ocaml_utils - merlin_extend merlin_specific merlin_utils merlin_dot_protocol)) + (libraries merlin_config os_ipc ocaml_parsing ocaml_preprocess ocaml_typing + ocaml_utils merlin_extend merlin_specific merlin_utils + merlin_dot_protocol unix str)) (rule (targets standard_library.ml) From a5297cc990710ceea3b19f49d9635fade4e1de72 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 24 Jun 2022 11:11:18 +0200 Subject: [PATCH 013/130] Fix tests using unix --- tests/test-dirs/refactor-open/qualify.t | 11 +++++------ tests/test-dirs/refactor-open/record_field.t | 16 ++++++++-------- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/tests/test-dirs/refactor-open/qualify.t b/tests/test-dirs/refactor-open/qualify.t index 0c87c3a70f..ff1f8eba96 100644 --- a/tests/test-dirs/refactor-open/qualify.t +++ b/tests/test-dirs/refactor-open/qualify.t @@ -56,8 +56,8 @@ Can qualify nested modules located in the same file Can qualify a module from an external library $ $MERLIN single refactor-open -action qualify -position 1:6 < open Unix - > let times = times () + > open Sys + > let enable_runtime_warnings = enable_runtime_warnings () > EOF { "class": "return", @@ -65,13 +65,13 @@ Can qualify a module from an external library { "start": { "line": 2, - "col": 12 + "col": 30 }, "end": { "line": 2, - "col": 17 + "col": 53 }, - "content": "Unix.times" + "content": "Sys.enable_runtime_warnings" } ], "notifications": [] @@ -120,4 +120,3 @@ does not return duplicate edits ], "notifications": [] } - diff --git a/tests/test-dirs/refactor-open/record_field.t b/tests/test-dirs/refactor-open/record_field.t index 5c9edab975..2d0062c93e 100644 --- a/tests/test-dirs/refactor-open/record_field.t +++ b/tests/test-dirs/refactor-open/record_field.t @@ -27,9 +27,9 @@ Refactor open for record fields Refactor open for record disambiguation - $ $MERLIN single refactor-open -action qualify -position 1:6 < open Unix - > let f x = x.tms_stime, x.tms_utime + $ $MERLIN single refactor-open -action qualify -I +unix -position 1:6 < open Sys + > let f x = x.patchlevel, x.major > EOF { "class": "return", @@ -41,20 +41,20 @@ Refactor open for record disambiguation }, "end": { "line": 2, - "col": 21 + "col": 22 }, - "content": "Unix.tms_stime" + "content": "Sys.patchlevel" }, { "start": { "line": 2, - "col": 25 + "col": 26 }, "end": { "line": 2, - "col": 34 + "col": 31 }, - "content": "Unix.tms_utime" + "content": "Sys.major" } ], "notifications": [] From c73c4d1c8112377e5f682904169068fd03b22249 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 24 Jun 2022 11:11:44 +0200 Subject: [PATCH 014/130] Promote mechanical changes in tests --- .../server-tests/typer-cache/stamps.t/run.t | 20 ++++++------- tests/test-dirs/typing-recovery.t | 30 +++++++++---------- 2 files changed, 25 insertions(+), 25 deletions(-) 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 index aa7741e20d..ce8a661416 100644 --- a/tests/test-dirs/server-tests/typer-cache/stamps.t/run.t +++ b/tests/test-dirs/server-tests/typer-cache/stamps.t/run.t @@ -8,31 +8,31 @@ 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/273\" - Tpat_var \"x/275\" + Tpat_var \"f/274\" + Tpat_var \"x/276\" $ 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/276\" - Tpat_var \"x/278\" + Tpat_var \"f/277\" + Tpat_var \"x/279\" $ 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/273\" - Tpat_var \"x/275\" + Tpat_var \"f/274\" + Tpat_var \"x/276\" $ 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/276\" - Tpat_var \"x/278\" + Tpat_var \"f/277\" + Tpat_var \"x/279\" $ echo "let f x = x" | \ > $MERLIN server dump -what browse -filename test.ml | \ > sed 's:\\n:\n:g' | grep Tpat_var - Tpat_var \"f/279\" - Tpat_var \"x/281\" + Tpat_var \"f/280\" + Tpat_var \"x/282\" $ $MERLIN server stop-server diff --git a/tests/test-dirs/typing-recovery.t b/tests/test-dirs/typing-recovery.t index 088abcc73e..7bff03f0a5 100644 --- a/tests/test-dirs/typing-recovery.t +++ b/tests/test-dirs/typing-recovery.t @@ -67,7 +67,7 @@ structure_item (test.ml[1,0+0]..test.ml[1,0+14]) Tstr_type Rec [ - type_declaration t/273 (test.ml[1,0+0]..test.ml[1,0+14]) + type_declaration t/274 (test.ml[1,0+0]..test.ml[1,0+14]) ptype_params = [] ptype_cstrs = @@ -76,11 +76,11 @@ Ttype_variant [ (test.ml[1,0+9]..test.ml[1,0+10]) - A/274 + A/275 [] None (test.ml[1,0+11]..test.ml[1,0+14]) - B/275 + B/276 [] None ] @@ -93,7 +93,7 @@ [ pattern (test.ml[2,15+4]..test.ml[2,15+5]) - Tpat_var \"f/276\" + Tpat_var \"f/277\" expression (test.ml[2,15+6]..test.ml[6,69+12]) ghost Texp_function Nolabel @@ -103,15 +103,15 @@ extra Tpat_extra_constraint core_type (test.ml[2,15+11]..test.ml[2,15+12]) - Ttyp_constr \"t/273\" + Ttyp_constr \"t/274\" [] - Tpat_alias \"x/278\" + Tpat_alias \"x/279\" 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/278\" + Texp_ident \"x/279\" [ pattern (test.ml[4,46+4]..test.ml[4,46+5]) @@ -144,7 +144,7 @@ ] attribute \"merlin.loc\" [] - Texp_ident \"*type-error*/279\" + Texp_ident \"*type-error*/280\" pattern (test.ml[6,69+4]..test.ml[6,69+5]) Tpat_value @@ -164,7 +164,7 @@ ] attribute \"merlin.loc\" [] - Texp_ident \"*type-error*/280\" + Texp_ident \"*type-error*/281\" ] ] ] @@ -224,7 +224,7 @@ structure_item (test2.ml[1,0+0]..test2.ml[1,0+14]) Tstr_type Rec [ - type_declaration t/273 (test2.ml[1,0+0]..test2.ml[1,0+14]) + type_declaration t/274 (test2.ml[1,0+0]..test2.ml[1,0+14]) ptype_params = [] ptype_cstrs = @@ -233,11 +233,11 @@ Ttype_variant [ (test2.ml[1,0+9]..test2.ml[1,0+10]) - A/274 + A/275 [] None (test2.ml[1,0+11]..test2.ml[1,0+14]) - B/275 + B/276 [] None ] @@ -250,7 +250,7 @@ [ pattern (test2.ml[2,15+4]..test2.ml[2,15+5]) - Tpat_var \"f/276\" + Tpat_var \"f/277\" expression (test2.ml[2,15+6]..test2.ml[2,15+24]) ghost Texp_function Nolabel @@ -262,7 +262,7 @@ extra Tpat_extra_constraint core_type (test2.ml[2,15+11]..test2.ml[2,15+12]) - Ttyp_constr \"t/273\" + Ttyp_constr \"t/274\" [] Tpat_any expression (test2.ml[2,15+22]..test2.ml[2,15+24]) @@ -280,7 +280,7 @@ core_type (test2.ml[2,15+16]..test2.ml[2,15+19]) Ttyp_constr \"int/1!\" [] - Texp_ident \"*type-error*/278\" + Texp_ident \"*type-error*/279\" ] ] ] From 7991af6f2b68445f5e2da1983314c04855c36576 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 24 Jun 2022 11:15:40 +0200 Subject: [PATCH 015/130] Try to enable CI --- .github/workflows/main.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 635a80b9f2..ef8c009e61 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -6,7 +6,7 @@ name: CI # events but only for the master branch on: push: - branches: [ master ] + branches: [ master; 500 ] paths-ignore: - '**.md' - '**.txt' @@ -40,7 +40,7 @@ jobs: - ubuntu-latest - windows-latest ocaml-compiler: - - ocaml-variants.5.0.0+trunk + - 5.0.x # The type of runner that the job will run on runs-on: ${{ matrix.os }} From a93dd8e39e1325414ad798ae952ed672d7e15b86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 28 Jun 2022 13:38:09 +0200 Subject: [PATCH 016/130] Remove warning desactivation --- src/utils/std.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/utils/std.ml b/src/utils/std.ml index 582a9cf070..5ba3803b6f 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -449,10 +449,6 @@ module String = struct 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_ascii let uncapitalize = uncapitalize_ascii From 4ed41f12114103ca4afffd3da407d893d8485547 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 28 Jun 2022 14:07:24 +0200 Subject: [PATCH 017/130] Update dot-merlin-reader ocaml lower bound --- dot-merlin-reader.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dot-merlin-reader.opam b/dot-merlin-reader.opam index 48ead45bf7..9574afe0b7 100644 --- a/dot-merlin-reader.opam +++ b/dot-merlin-reader.opam @@ -11,7 +11,7 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "ocaml" {>= "4.08" & < "5.0"} + "ocaml" {>= "5.0" & < "6.0" } "dune" {>= "2.9.0"} "merlin-lib" {>= "4.9"} "ocamlfind" {>= "1.6.0"} From 69ef23863cfad1365809a2e885ea9517f3fdc3eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 12 Jul 2022 15:42:03 +0200 Subject: [PATCH 018/130] Comment unused function in load_path --- src/ocaml/utils/load_path.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ocaml/utils/load_path.ml b/src/ocaml/utils/load_path.ml index 7094b064c2..70ce575599 100644 --- a/src/ocaml/utils/load_path.ml +++ b/src/ocaml/utils/load_path.ml @@ -151,7 +151,7 @@ let prepend_dir dir = let is_basename fn = Filename.basename fn = fn -let auto_include_libs libs alert find_in_dir fn = +(* let auto_include_libs libs alert find_in_dir fn = let scan (lib, lazy dir) = let file = find_in_dir dir fn in let alert_and_add_dir _ = @@ -163,7 +163,7 @@ let auto_include_libs libs alert find_in_dir fn = in match List.find_map scan libs with | Some base -> base - | None -> raise Not_found + | None -> raise Not_found *) (* let auto_include_otherlibs = (* Ensure directories are only ever scanned once *) From b3b6ac3614b87db96d3a1a508dc7734e83d7e593 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 12 Jul 2022 15:42:18 +0200 Subject: [PATCH 019/130] Test update --- tests/test-dirs/typing-recovery.t | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/tests/test-dirs/typing-recovery.t b/tests/test-dirs/typing-recovery.t index 7bff03f0a5..53ab9694d6 100644 --- a/tests/test-dirs/typing-recovery.t +++ b/tests/test-dirs/typing-recovery.t @@ -330,14 +330,14 @@ First a simple case: "value": "[ signature_item (test.mli[1,0+0]..test.mli[1,0+14]) Tsig_value - value_description foo1/273 (test.mli[1,0+0]..test.mli[1,0+14]) + value_description foo1/274 (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/274 (test.mli[3,16+0]..test.mli[3,16+21]) + value_description foo2/275 (test.mli[3,16+0]..test.mli[3,16+21]) core_type (test.mli[3,16+11]..test.mli[3,16+21]) Ttyp_tuple [ @@ -350,7 +350,7 @@ First a simple case: [] signature_item (test.mli[5,39+0]..test.mli[5,39+21]) Tsig_value - value_description foo3/275 (test.mli[5,39+0]..test.mli[5,39+21]) + value_description foo3/276 (test.mli[5,39+0]..test.mli[5,39+21]) core_type (test.mli[5,39+11]..test.mli[5,39+21]) Ttyp_tuple [ @@ -414,38 +414,38 @@ And now, with an error deep in a submodule: "value": "[ signature_item (test2.mli[1,0+0]..test2.mli[1,0+14]) Tsig_value - value_description foo1/273 (test2.mli[1,0+0]..test2.mli[1,0+14]) + value_description foo1/274 (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/279\" + Tsig_module \"M/280\" 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/274 (test2.mli[4,31+2]..test2.mli[4,31+17]) + value_description foo21/275 (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/278\" + Tsig_module \"N/279\" 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/275 (test2.mli[6,66+4]..test2.mli[6,66+20]) + value_description foo211/276 (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/276 (test2.mli[7,87+4]..test2.mli[7,87+27]) + value_description foo212/277 (test2.mli[7,87+4]..test2.mli[7,87+27]) core_type (test2.mli[7,87+17]..test2.mli[7,87+27]) Ttyp_tuple [ @@ -458,7 +458,7 @@ And now, with an error deep in a submodule: [] signature_item (test2.mli[8,115+4]..test2.mli[8,115+27]) Tsig_value - value_description foo213/277 (test2.mli[8,115+4]..test2.mli[8,115+27]) + value_description foo213/278 (test2.mli[8,115+4]..test2.mli[8,115+27]) core_type (test2.mli[8,115+17]..test2.mli[8,115+27]) Ttyp_tuple [ @@ -474,7 +474,7 @@ And now, with an error deep in a submodule: ] signature_item (test2.mli[12,154+0]..test2.mli[12,154+21]) Tsig_value - value_description foo3/280 (test2.mli[12,154+0]..test2.mli[12,154+21]) + value_description foo3/281 (test2.mli[12,154+0]..test2.mli[12,154+21]) core_type (test2.mli[12,154+11]..test2.mli[12,154+21]) Ttyp_tuple [ @@ -544,7 +544,7 @@ make sure we also handle that correctly in structures: core_type (test_ct.ml[1,0+11]..test_ct.ml[1,0+14]) Ttyp_constr \"int/1!\" [] - Tpat_var \"foo1/273\" + Tpat_var \"foo1/274\" expression (test_ct.ml[1,0+17]..test_ct.ml[1,0+18]) extra Texp_constraint @@ -571,7 +571,7 @@ make sure we also handle that correctly in structures: core_type (test_ct.ml[3,20+17]..test_ct.ml[3,20+21]) Ttyp_any ] - Tpat_var \"foo2/274\" + Tpat_var \"foo2/275\" expression (test_ct.ml[3,20+24]..test_ct.ml[3,20+28]) extra Texp_constraint @@ -611,7 +611,7 @@ make sure we also handle that correctly in structures: Ttyp_constr \"int/1!\" [] ] - Tpat_var \"foo3/275\" + Tpat_var \"foo3/276\" expression (test_ct.ml[5,50+23]..test_ct.ml[5,50+27]) extra Texp_constraint From 64faaa88ef5a7f9a1e10f5084ac8fe75898388d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 24 Nov 2022 17:50:27 +0100 Subject: [PATCH 020/130] Fetch latest upstream version of OCaml 5 1470e1e9b13341893e68f404c5c798d0259bb564 --- upstream/ocaml_500/base-rev.txt | 2 +- upstream/ocaml_500/parsing/parse.ml | 6 ++ upstream/ocaml_500/parsing/parser.mly | 7 +- upstream/ocaml_500/parsing/syntaxerr.ml | 4 +- upstream/ocaml_500/parsing/syntaxerr.mli | 1 + upstream/ocaml_500/typing/env.ml | 9 +- .../typing/includemod_errorprinter.ml | 11 ++- upstream/ocaml_500/typing/predef.ml | 7 -- upstream/ocaml_500/typing/printtyp.ml | 10 ++- upstream/ocaml_500/typing/printtyp.mli | 6 ++ upstream/ocaml_500/typing/tast_mapper.ml | 6 +- upstream/ocaml_500/typing/typeclass.ml | 15 +++- upstream/ocaml_500/typing/typecore.ml | 85 ++++++++++--------- upstream/ocaml_500/typing/typedecl.ml | 2 +- upstream/ocaml_500/typing/typemod.ml | 4 +- upstream/ocaml_500/utils/clflags.ml | 6 +- upstream/ocaml_500/utils/clflags.mli | 1 - upstream/ocaml_500/utils/config.fixed.ml | 1 - upstream/ocaml_500/utils/config.mli | 4 - upstream/ocaml_500/utils/config.mlp | 1 - upstream/ocaml_500/utils/warnings.ml | 2 +- 21 files changed, 117 insertions(+), 73 deletions(-) diff --git a/upstream/ocaml_500/base-rev.txt b/upstream/ocaml_500/base-rev.txt index f9a215ed0f..5dd01cf1c9 100644 --- a/upstream/ocaml_500/base-rev.txt +++ b/upstream/ocaml_500/base-rev.txt @@ -1 +1 @@ -2b2bd86c61c1f06b68c7db214bd88474ed28d3fc +1470e1e9b13341893e68f404c5c798d0259bb564 diff --git a/upstream/ocaml_500/parsing/parse.ml b/upstream/ocaml_500/parsing/parse.ml index cf703060f4..fa84872b6f 100644 --- a/upstream/ocaml_500/parsing/parse.ml +++ b/upstream/ocaml_500/parsing/parse.ml @@ -140,6 +140,12 @@ let prepare_error err = "broken invariant in parsetree: %s" s | Invalid_package_type (loc, s) -> Location.errorf ~loc "invalid package type: %s" s + | Removed_string_set loc -> + Location.errorf ~loc + "Syntax error: strings are immutable, there is no assignment \ + syntax for them.\n\ + Hint: Mutable sequences of bytes are available in the Bytes module.\n\ + Hint: Did you mean to use 'Bytes.set'?" let () = Location.register_error_of_exn diff --git a/upstream/ocaml_500/parsing/parser.mly b/upstream/ocaml_500/parsing/parser.mly index f0c4bc0498..4842845cd7 100644 --- a/upstream/ocaml_500/parsing/parser.mly +++ b/upstream/ocaml_500/parsing/parser.mly @@ -230,6 +230,9 @@ let unclosed opening_name opening_loc closing_name closing_loc = let expecting loc nonterm = raise Syntaxerr.(Error(Expecting(make_loc loc, nonterm))) +let removed_string_set loc = + raise(Syntaxerr.Error(Syntaxerr.Removed_string_set(make_loc loc))) + (* 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. *) @@ -304,7 +307,9 @@ let builtin_arraylike_name loc _ ~assign paren_kind n = let opname = if !Clflags.unsafe then "unsafe_" ^ opname else opname in let prefix = match paren_kind with | Paren -> Lident "Array" - | Bracket -> Lident "String" + | Bracket -> + if assign then removed_string_set loc + else Lident "String" | Brace -> let submodule_name = match n with | One -> "Array1" diff --git a/upstream/ocaml_500/parsing/syntaxerr.ml b/upstream/ocaml_500/parsing/syntaxerr.ml index 49372b9edf..df7b8a0548 100644 --- a/upstream/ocaml_500/parsing/syntaxerr.ml +++ b/upstream/ocaml_500/parsing/syntaxerr.ml @@ -24,6 +24,7 @@ type error = | Other of Location.t | Ill_formed_ast of Location.t * string | Invalid_package_type of Location.t * string + | Removed_string_set of Location.t exception Error of error exception Escape_error @@ -36,7 +37,8 @@ let location_of_error = function | Not_expecting (l, _) | Ill_formed_ast (l, _) | Invalid_package_type (l, _) - | Expecting (l, _) -> l + | Expecting (l, _) + | Removed_string_set l -> l let ill_formed_ast loc s = diff --git a/upstream/ocaml_500/parsing/syntaxerr.mli b/upstream/ocaml_500/parsing/syntaxerr.mli index 26ba712671..577d5360cd 100644 --- a/upstream/ocaml_500/parsing/syntaxerr.mli +++ b/upstream/ocaml_500/parsing/syntaxerr.mli @@ -29,6 +29,7 @@ type error = | Other of Location.t | Ill_formed_ast of Location.t * string | Invalid_package_type of Location.t * string + | Removed_string_set of Location.t exception Error of error exception Escape_error diff --git a/upstream/ocaml_500/typing/env.ml b/upstream/ocaml_500/typing/env.ml index 88d0861fa0..fd2353eed2 100644 --- a/upstream/ocaml_500/typing/env.ml +++ b/upstream/ocaml_500/typing/env.ml @@ -104,6 +104,10 @@ let add_label_usage lu usage = lu.lu_mutation <- true; lu.lu_construct <- true +let is_mutating_label_usage = function + | Mutation -> true + | (Projection | Construct | Exported_private | Exported) -> false + let label_usages () = {lu_projection = false; lu_mutation = false; lu_construct = false} @@ -2723,7 +2727,10 @@ let use_cltype ~use ~loc path desc = 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 + Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name; + if is_mutating_label_usage usage then + Builtin_attributes.check_deprecated_mutable loc lbl.lbl_attributes + lbl.lbl_name end let use_constructor_desc ~use ~loc usage env cstr = diff --git a/upstream/ocaml_500/typing/includemod_errorprinter.ml b/upstream/ocaml_500/typing/includemod_errorprinter.ml index 24d452fddc..b719e1627d 100644 --- a/upstream/ocaml_500/typing/includemod_errorprinter.ml +++ b/upstream/ocaml_500/typing/includemod_errorprinter.ml @@ -709,7 +709,16 @@ let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx diff = 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 next = + match diff.symptom with + | Mt_core _ -> + (* In those cases, the refined error messages for the current error + will at most add some minor comments on the current error. + It is thus better to avoid eliding the current error message. + *) + dwith_context ctx (inner diff) + | _ -> dwith_context_and_elision ctx inner diff + in let before = next :: before in module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx diff.symptom diff --git a/upstream/ocaml_500/typing/predef.ml b/upstream/ocaml_500/typing/predef.ml index af932a53fd..185825c330 100644 --- a/upstream/ocaml_500/typing/predef.ml +++ b/upstream/ocaml_500/typing/predef.ml @@ -96,9 +96,6 @@ 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" -and ident_continuation_already_taken = - ident_create "Continuation_already_taken" -and ident_unhandled = ident_create "Unhandled" let all_predef_exns = [ ident_match_failure; @@ -113,8 +110,6 @@ let all_predef_exns = [ ident_sys_blocked_io; ident_assert_failure; ident_undefined_recursive_module; - ident_continuation_already_taken; - ident_unhandled; ] let path_match_failure = Pident ident_match_failure @@ -237,7 +232,6 @@ let build_initial_env add_type add_extension empty_env = (* Predefined exceptions - alphabetical order *) |> add_extension ident_assert_failure [newgenty (Ttuple[type_string; type_int; type_int])] - |> add_extension ident_continuation_already_taken [] |> add_extension ident_division_by_zero [] |> add_extension ident_end_of_file [] |> add_extension ident_failure [type_string] @@ -251,7 +245,6 @@ let build_initial_env add_type add_extension empty_env = |> add_extension ident_sys_error [type_string] |> add_extension ident_undefined_recursive_module [newgenty (Ttuple[type_string; type_int; type_int])] - |> add_extension ident_unhandled [] let builtin_values = List.map (fun id -> (Ident.name id, id)) all_predef_exns diff --git a/upstream/ocaml_500/typing/printtyp.ml b/upstream/ocaml_500/typing/printtyp.ml index b0bf36cebd..88d67013c5 100644 --- a/upstream/ocaml_500/typing/printtyp.ml +++ b/upstream/ocaml_500/typing/printtyp.ml @@ -1058,7 +1058,10 @@ let reset () = reset_except_context () let prepare_for_printing tyl = - reset_except_context (); List.iter prepare_type tyl + reset_except_context (); + List.iter prepare_type tyl + +let add_type_to_preparation = prepare_type (* Disabled in classic mode when printing an unification error *) let print_labels = ref true @@ -1463,10 +1466,13 @@ and tree_of_label l = let constructor ppf c = reset_except_context (); + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res; !Oprint.out_constr ppf (tree_of_constructor c) let label ppf l = reset_except_context (); + prepare_type l.ld_type; !Oprint.out_label ppf (tree_of_label l) let tree_of_type_declaration id decl rs = @@ -1534,6 +1540,8 @@ let extension_constructor id ppf ext = let extension_only_constructor id ppf ext = reset_except_context (); + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type; let name = Ident.name id in let args, ret = extension_constructor_args_and_ret_type_subtree diff --git a/upstream/ocaml_500/typing/printtyp.mli b/upstream/ocaml_500/typing/printtyp.mli index 13b2ed95e8..09571f4046 100644 --- a/upstream/ocaml_500/typing/printtyp.mli +++ b/upstream/ocaml_500/typing/printtyp.mli @@ -107,6 +107,12 @@ val type_expr: formatter -> type_expr -> unit Any type variables that are shared between multiple types in the input list will be given the same name when printed with [prepared_type_expr]. *) val prepare_for_printing: type_expr list -> unit + +(** [add_type_to_preparation ty] extend a previous type expression preparation + to the type expression [ty] +*) +val add_type_to_preparation: type_expr -> unit + val prepared_type_expr: formatter -> type_expr -> unit (** The function [prepared_type_expr] is a less-safe but more-flexible version of [type_expr] that should only be called on [type_expr]s that have been diff --git a/upstream/ocaml_500/typing/tast_mapper.ml b/upstream/ocaml_500/typing/tast_mapper.ml index 87079db4fc..9016e891f3 100644 --- a/upstream/ocaml_500/typing/tast_mapper.ml +++ b/upstream/ocaml_500/typing/tast_mapper.ml @@ -458,10 +458,10 @@ let module_type sub x = 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_modtype mty -> Twith_modtype (sub.module_type sub mty) + | Twith_modtypesubst mty -> Twith_modtypesubst (sub.module_type sub mty) | Twith_module _ - | Twith_modsubst _ - | Twith_modtype _ - | Twith_modtypesubst _ as d -> d + | Twith_modsubst _ as d -> d let open_description sub od = {od with open_env = sub.env sub od.open_env} diff --git a/upstream/ocaml_500/typing/typeclass.ml b/upstream/ocaml_500/typing/typeclass.ml index fedbc0e025..79d464fa7d 100644 --- a/upstream/ocaml_500/typing/typeclass.ml +++ b/upstream/ocaml_500/typing/typeclass.ml @@ -177,6 +177,13 @@ let check_virtual loc env virt kind sign = | meths, vars -> raise(Error(loc, env, Virtual_class(kind, meths, vars))) +let rec check_virtual_clty loc env virt kind clty = + match clty with + | Cty_constr(_, _, clty) | Cty_arrow(_, _, clty) -> + check_virtual_clty loc env virt kind clty + | Cty_signature sign -> + check_virtual loc env virt kind sign + (* Return the constructor type associated to a class type *) let rec constructor_type constr cty = match cty with @@ -398,6 +405,8 @@ and class_type_aux env virt self_scope scty = ) styl params in let typ = Cty_constr (path, params, clty) in + (* Check for unexpected virtual methods *) + check_virtual_clty scty.pcty_loc env virt Class_type typ; cltyp (Tcty_constr ( path, lid , ctys)) typ | Pcty_signature pcsig -> @@ -1077,6 +1086,8 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = try Ctype.unify val_env ty' ty with Ctype.Unify err -> raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch err))) tyl params; + (* Check for unexpected virtual methods *) + check_virtual_clty scl.pcl_loc val_env virt Class clty'; let cl = rc {cl_desc = Tcl_ident (path, lid, tyl); cl_loc = scl.pcl_loc; @@ -1962,7 +1973,6 @@ let report_error env ppf = function (function ppf -> fprintf ppf "but is expected to have type") | Unexpected_field (ty, lab) -> - Printtyp.prepare_for_printing [ty]; fprintf ppf "@[@[<2>This object is expected to have type :@ %a@]\ @ This type does not have a method %s." @@ -2051,7 +2061,8 @@ let report_error env ppf = function let print_reason ppf (ty0, real, lab, ty) = let ty1 = if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in - Printtyp.prepare_for_printing [ty; ty1]; + Printtyp.add_type_to_preparation ty; + Printtyp.add_type_to_preparation ty1; fprintf ppf "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound" lab diff --git a/upstream/ocaml_500/typing/typecore.ml b/upstream/ocaml_500/typing/typecore.ml index 72287808b2..e9947d3276 100644 --- a/upstream/ocaml_500/typing/typecore.ml +++ b/upstream/ocaml_500/typing/typecore.ml @@ -300,13 +300,19 @@ let extract_option_type env ty = Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty | _ -> assert false +let protect_expansion env ty = + if Env.has_local_constraints env then generic_instance ty else ty + type record_extraction_result = | Record_type of Path.t * Path.t * Types.label_declaration list | Not_a_record_type | Maybe_a_record_type +let extract_concrete_typedecl_protected env ty = + extract_concrete_typedecl env (protect_expansion env ty) + let extract_concrete_record env ty = - match extract_concrete_typedecl env ty with + match extract_concrete_typedecl_protected env ty with | Typedecl(p0, p, {type_kind=Type_record (fields, _)}) -> Record_type (p0, p, fields) | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_record_type @@ -318,7 +324,7 @@ type variant_extraction_result = | Maybe_a_variant_type let extract_concrete_variant env ty = - match extract_concrete_typedecl env ty with + match extract_concrete_typedecl_protected env ty with | Typedecl(p0, p, {type_kind=Type_variant (cstrs, _)}) -> Variant_type (p0, p, cstrs) | Typedecl(p0, p, {type_kind=Type_open}) -> @@ -2893,7 +2899,7 @@ and type_expect_ | 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 ty_exp = expand_head env (protect_expansion env ty_expected) in let fmt6_path = Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"), "format6")) @@ -3099,9 +3105,10 @@ and type_expect_ type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes | Pexp_variant(l, sarg) -> (* Keep sharing *) + let ty_expected1 = protect_expansion env ty_expected in let ty_expected0 = instance ty_expected in begin try match - sarg, get_desc (expand_head env ty_expected), + sarg, get_desc (expand_head env ty_expected1), get_desc (expand_head env ty_expected0) with | Some sarg, Tvariant row, Tvariant row0 -> @@ -3768,7 +3775,7 @@ and type_expect_ | Pexp_poly(sbody, sty) -> if !Clflags.principal then begin_def (); let ty, cty = - match sty with None -> ty_expected, None + match sty with None -> protect_expansion env ty_expected, None | Some sty -> let sty = Ast_helper.Typ.force_poly sty in let cty = Typetexp.transl_simple_type env false sty in @@ -3852,7 +3859,8 @@ and type_expect_ match get_desc (Ctype.expand_head env (instance ty_expected)) with Tpackage (p, fl) -> if !Clflags.principal && - get_level (Ctype.expand_head env ty_expected) + get_level (Ctype.expand_head env + (protect_expansion env ty_expected)) < Btype.generic_level then Location.prerr_warning loc @@ -4461,7 +4469,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = (lv <> generic_level || get_level ty_fun' <> generic_level) and ty_fun = instance ty_fun' in let ty_arg, ty_res = - match get_desc (expand_head env ty_expected') with + match get_desc (expand_head env ty_expected) with Tarrow(Nolabel,ty_arg,ty_res,_) -> ty_arg, ty_res | _ -> assert false in @@ -4593,10 +4601,30 @@ and type_application env funct sargs = in let warned = ref false in let rec type_args args ty_fun ty_fun0 sargs = + let type_unknown_args () = + (* 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 + if sargs = [] then type_unknown_args () else let ty_fun' = expand_head env ty_fun in match get_desc ty_fun', get_desc (expand_head env ty_fun0) with | Tarrow (l, ty, ty_fun, com), Tarrow (_, ty0, ty_fun0, _) - when sargs <> [] && is_commu_ok com -> + when is_commu_ok com -> let lv = get_level ty_fun' in let may_warn loc w = if not !warned && !Clflags.principal && lv <> generic_level @@ -4674,23 +4702,7 @@ and type_application env funct sargs = 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 + type_unknown_args () in let is_ignore funct = is_prim ~name:"%ignore" funct && @@ -4983,6 +4995,8 @@ and type_cases ) half_typed_cases; (* type bodies *) let in_function = if List.length caselist = 1 then in_function else None in + let ty_res' = instance ty_res in + if !Clflags.principal then begin_def (); let cases = List.map (fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks; @@ -5005,14 +5019,8 @@ and type_cases 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 + let ty_expected = + if contains_gadt && not !Clflags.principal then (* allow propagation from preceding branches *) correct_levels ty_res else ty_res in @@ -5026,20 +5034,17 @@ and type_cases in let exp = type_unpacks ?in_function ext_env - unpacks pc_rhs (mk_expected ?explanation ty_res') + unpacks pc_rhs (mk_expected ?explanation ty_expected) in { c_lhs = pat; c_guard = guard; - c_rhs = {exp with exp_type = instance ty_res'} + c_rhs = {exp with exp_type = 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; + if !Clflags.principal then end_def (); let do_init = may_contain_gadts || needs_exhaust_check in let ty_arg_check = if do_init then @@ -5078,7 +5083,7 @@ and type_cases if may_contain_gadts then begin end_def (); (* Ensure that existential types do not escape *) - unify_exp_types loc env (instance ty_res) (newvar ()) ; + unify_exp_types loc env ty_res' (newvar ()) ; end; cases, partial diff --git a/upstream/ocaml_500/typing/typedecl.ml b/upstream/ocaml_500/typing/typedecl.ml index 3b847099d3..3515a36a3f 100644 --- a/upstream/ocaml_500/typing/typedecl.ml +++ b/upstream/ocaml_500/typing/typedecl.ml @@ -1336,7 +1336,7 @@ let rec parse_native_repr_attributes env core_type ty ~global_repr = parse_native_repr_attributes env ct2 t2 ~global_repr in (repr_arg :: repr_args, repr_res) - | Ptyp_poly (_, t), _, _ -> + | (Ptyp_poly (_, t) | Ptyp_alias (t, _)), _, _ -> parse_native_repr_attributes env t ty ~global_repr | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false | _ -> ([], make_native_repr env core_type ty ~global_repr) diff --git a/upstream/ocaml_500/typing/typemod.ml b/upstream/ocaml_500/typing/typemod.ml index 0ef1e13d89..32352ca11c 100644 --- a/upstream/ocaml_500/typing/typemod.ml +++ b/upstream/ocaml_500/typing/typemod.ml @@ -2041,9 +2041,11 @@ and package_constraints env loc mty constrs = end let modtype_of_package env loc p fl = + (* We call Ctype.correct_levels to ensure that the types being added to the + module type are at generic_level. *) let mty = package_constraints env loc (Mty_ident p) - (List.map (fun (n, t) -> (Longident.flatten n, t)) fl) + (List.map (fun (n, t) -> Longident.flatten n, Ctype.correct_levels t) fl) in Subst.modtype Keep Subst.identity mty diff --git a/upstream/ocaml_500/utils/clflags.ml b/upstream/ocaml_500/utils/clflags.ml index fac4309b98..5b8bbf33f9 100644 --- a/upstream/ocaml_500/utils/clflags.ml +++ b/upstream/ocaml_500/utils/clflags.ml @@ -138,7 +138,6 @@ let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *) let native_code = ref false (* set to true under ocamlopt *) -let force_tmc = ref false (* -force-tmc *) let force_slash = ref false (* for ocamldep *) let clambda_checks = ref false (* -clambda-checks *) let cmm_invariants = @@ -166,10 +165,7 @@ let pic_code = ref (match Config.architecture with (* -fPIC *) | "amd64" -> true | _ -> false) -let runtime_variant = - ref (match Config.force_instrumented_runtime with (* -runtime-variant *) - | true -> "i" - | false -> "") +let runtime_variant = ref "" let with_runtime = ref true (* -with-runtime *) diff --git a/upstream/ocaml_500/utils/clflags.mli b/upstream/ocaml_500/utils/clflags.mli index e5f8745268..72fcdbd981 100644 --- a/upstream/ocaml_500/utils/clflags.mli +++ b/upstream/ocaml_500/utils/clflags.mli @@ -191,7 +191,6 @@ val dlcode : bool ref val pic_code : bool ref val runtime_variant : string ref val with_runtime : bool ref -val force_tmc : bool ref val force_slash : bool ref val keep_docs : bool ref val keep_locs : bool ref diff --git a/upstream/ocaml_500/utils/config.fixed.ml b/upstream/ocaml_500/utils/config.fixed.ml index 141fcea3d8..e29c94cfe1 100644 --- a/upstream/ocaml_500/utils/config.fixed.ml +++ b/upstream/ocaml_500/utils/config.fixed.ml @@ -47,7 +47,6 @@ let flambda = false let with_flambda_invariants = false let with_cmm_invariants = false let windows_unicode = false -let force_instrumented_runtime = false let flat_float_array = true let function_sections = false let afl_instrument = false diff --git a/upstream/ocaml_500/utils/config.mli b/upstream/ocaml_500/utils/config.mli index fa02a76745..54fda00f58 100644 --- a/upstream/ocaml_500/utils/config.mli +++ b/upstream/ocaml_500/utils/config.mli @@ -239,10 +239,6 @@ val supports_shared_libraries: bool @since 4.08.0 *) -val force_instrumented_runtime: bool -(** Force runtime-variant to be "i" at configure time - when ocamlc or ocamlopt link executables. *) - val afl_instrument : bool (** Whether afl-fuzz instrumentation is generated by default *) diff --git a/upstream/ocaml_500/utils/config.mlp b/upstream/ocaml_500/utils/config.mlp index 556d5ec7ec..7e1848f433 100644 --- a/upstream/ocaml_500/utils/config.mlp +++ b/upstream/ocaml_500/utils/config.mlp @@ -69,7 +69,6 @@ let flambda = %%FLAMBDA%% let with_flambda_invariants = %%WITH_FLAMBDA_INVARIANTS%% let with_cmm_invariants = %%WITH_CMM_INVARIANTS%% let windows_unicode = %%WINDOWS_UNICODE%% != 0 -let force_instrumented_runtime = %%FORCE_INSTRUMENTED_RUNTIME%% let flat_float_array = %%FLAT_FLOAT_ARRAY%% diff --git a/upstream/ocaml_500/utils/warnings.ml b/upstream/ocaml_500/utils/warnings.ml index 23a64d509a..65044fc965 100644 --- a/upstream/ocaml_500/utils/warnings.ml +++ b/upstream/ocaml_500/utils/warnings.ml @@ -863,7 +863,7 @@ 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 + let[@manual.ref "s:comp-warnings"] chapter, section = 13, 5 in Printf.sprintf "(See manual section %d.%d)" chapter section let message = function From 646d3fbb7b274fc6eae1df2461c8bef119489fe0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 24 Nov 2022 17:50:45 +0100 Subject: [PATCH 021/130] Upgrade Merlin's vendored compiler --- src/ocaml/parsing/pprintast.ml | 6 ++ src/ocaml/parsing/syntaxerr.ml | 4 +- src/ocaml/parsing/syntaxerr.mli | 1 + src/ocaml/preprocess/parser_raw.mly | 6 +- src/ocaml/typing/env.ml | 4 +- src/ocaml/typing/predef.ml | 7 --- src/ocaml/typing/typeclass.ml | 13 +++-- src/ocaml/typing/typecore.ml | 87 +++++++++++++++-------------- src/ocaml/typing/typemod.ml | 4 +- src/ocaml/utils/warnings.ml | 2 +- 10 files changed, 74 insertions(+), 60 deletions(-) diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml index 7915fcbc5a..7e2d5095f4 100644 --- a/src/ocaml/parsing/pprintast.ml +++ b/src/ocaml/parsing/pprintast.ml @@ -1761,6 +1761,12 @@ let prepare_error err = "broken invariant in parsetree: %s" s | Invalid_package_type (loc, s) -> Location.errorf ~source ~loc "invalid package type: %s" s + | Removed_string_set loc -> + Location.errorf ~loc + "Syntax error: strings are immutable, there is no assignment \ + syntax for them.\n\ + Hint: Mutable sequences of bytes are available in the Bytes module.\n\ + Hint: Did you mean to use 'Bytes.set'?" let () = Location.register_error_of_exn diff --git a/src/ocaml/parsing/syntaxerr.ml b/src/ocaml/parsing/syntaxerr.ml index 49372b9edf..df7b8a0548 100644 --- a/src/ocaml/parsing/syntaxerr.ml +++ b/src/ocaml/parsing/syntaxerr.ml @@ -24,6 +24,7 @@ type error = | Other of Location.t | Ill_formed_ast of Location.t * string | Invalid_package_type of Location.t * string + | Removed_string_set of Location.t exception Error of error exception Escape_error @@ -36,7 +37,8 @@ let location_of_error = function | Not_expecting (l, _) | Ill_formed_ast (l, _) | Invalid_package_type (l, _) - | Expecting (l, _) -> l + | Expecting (l, _) + | Removed_string_set l -> l let ill_formed_ast loc s = diff --git a/src/ocaml/parsing/syntaxerr.mli b/src/ocaml/parsing/syntaxerr.mli index 26ba712671..577d5360cd 100644 --- a/src/ocaml/parsing/syntaxerr.mli +++ b/src/ocaml/parsing/syntaxerr.mli @@ -29,6 +29,7 @@ type error = | Other of Location.t | Ill_formed_ast of Location.t * string | Invalid_package_type of Location.t * string + | Removed_string_set of Location.t exception Error of error exception Escape_error diff --git a/src/ocaml/preprocess/parser_raw.mly b/src/ocaml/preprocess/parser_raw.mly index 1196412f78..adfeddfa22 100644 --- a/src/ocaml/preprocess/parser_raw.mly +++ b/src/ocaml/preprocess/parser_raw.mly @@ -227,6 +227,8 @@ let mkpat_opt_constraint ~loc p = function (*let syntax_error () = raise Syntaxerr.Escape_error*) +let removed_string_set loc = + raise_error Syntaxerr.(Error(Syntaxerr.Removed_string_set(make_loc loc))) (* 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 @@ -312,7 +314,9 @@ let builtin_arraylike_name loc _ ~assign paren_kind n = let opname = if !Clflags.fast then "unsafe_" ^ opname else opname in let prefix = match paren_kind with | Paren -> Lident "Array" - | Bracket -> Lident "String" + | Bracket -> + if assign then removed_string_set loc; + Lident "String" | Brace -> let submodule_name = match n with | One -> "Array1" diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml index f01e7c0703..cb191003a1 100644 --- a/src/ocaml/typing/env.ml +++ b/src/ocaml/typing/env.ml @@ -105,8 +105,8 @@ let add_label_usage lu usage = lu.lu_construct <- true let is_mutating_label_usage = function -| Mutation -> true -| (Projection | Construct | Exported_private | Exported) -> false + | Mutation -> true + | (Projection | Construct | Exported_private | Exported) -> false let label_usages () = {lu_projection = false; lu_mutation = false; lu_construct = false} diff --git a/src/ocaml/typing/predef.ml b/src/ocaml/typing/predef.ml index af932a53fd..185825c330 100644 --- a/src/ocaml/typing/predef.ml +++ b/src/ocaml/typing/predef.ml @@ -96,9 +96,6 @@ 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" -and ident_continuation_already_taken = - ident_create "Continuation_already_taken" -and ident_unhandled = ident_create "Unhandled" let all_predef_exns = [ ident_match_failure; @@ -113,8 +110,6 @@ let all_predef_exns = [ ident_sys_blocked_io; ident_assert_failure; ident_undefined_recursive_module; - ident_continuation_already_taken; - ident_unhandled; ] let path_match_failure = Pident ident_match_failure @@ -237,7 +232,6 @@ let build_initial_env add_type add_extension empty_env = (* Predefined exceptions - alphabetical order *) |> add_extension ident_assert_failure [newgenty (Ttuple[type_string; type_int; type_int])] - |> add_extension ident_continuation_already_taken [] |> add_extension ident_division_by_zero [] |> add_extension ident_end_of_file [] |> add_extension ident_failure [type_string] @@ -251,7 +245,6 @@ let build_initial_env add_type add_extension empty_env = |> add_extension ident_sys_error [type_string] |> add_extension ident_undefined_recursive_module [newgenty (Ttuple[type_string; type_int; type_int])] - |> add_extension ident_unhandled [] let builtin_values = List.map (fun id -> (Ident.name id, id)) all_predef_exns diff --git a/src/ocaml/typing/typeclass.ml b/src/ocaml/typing/typeclass.ml index 28f0645780..c9841a2618 100644 --- a/src/ocaml/typing/typeclass.ml +++ b/src/ocaml/typing/typeclass.ml @@ -2057,12 +2057,13 @@ let report_error env ppf = function Includeclass.report_error Type ppf error | Unbound_val lab -> fprintf ppf "Unbound instance variable %s" lab - | Unbound_type_var (printer, reason) -> - let print_reason ppf (ty0, real, lab, ty) = - let ty1 = - if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in - Printtyp.add_type_to_preparation ty; - Printtyp.add_type_to_preparation ty1; + | Unbound_type_var (printer, (ty0, real, lab, ty)) -> + let ty1 = + if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) + in + Printtyp.add_type_to_preparation ty; + Printtyp.add_type_to_preparation ty1; + let print_reason ppf (ty0, lab, ty) = fprintf ppf "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound" lab diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index 3776333868..d5884cf7a9 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -399,13 +399,19 @@ let extract_option_type env ty = Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty | _ -> assert false +let protect_expansion env ty = + if Env.has_local_constraints env then generic_instance ty else ty + type record_extraction_result = | Record_type of Path.t * Path.t * Types.label_declaration list | Not_a_record_type | Maybe_a_record_type +let extract_concrete_typedecl_protected env ty = + extract_concrete_typedecl env (protect_expansion env ty) + let extract_concrete_record env ty = - match extract_concrete_typedecl env ty with + match extract_concrete_typedecl_protected env ty with | Typedecl(p0, p, {type_kind=Type_record (fields, _)}) -> Record_type (p0, p, fields) | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_record_type @@ -417,7 +423,7 @@ type variant_extraction_result = | Maybe_a_variant_type let extract_concrete_variant env ty = - match extract_concrete_typedecl env ty with + match extract_concrete_typedecl_protected env ty with | Typedecl(p0, p, {type_kind=Type_variant (cstrs, _)}) -> Variant_type (p0, p, cstrs) | Typedecl(p0, p, {type_kind=Type_open}) -> @@ -3041,7 +3047,7 @@ and type_expect_ | 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 ty_exp = expand_head env (protect_expansion env ty_expected) in let fmt6_path = Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"), "format6")) @@ -3247,9 +3253,10 @@ and type_expect_ type_construct env loc lid sarg ty_expected_explained sexp.pexp_attributes | Pexp_variant(l, sarg) -> (* Keep sharing *) + let ty_expected1 = protect_expansion env ty_expected in let ty_expected0 = instance ty_expected in begin try match - sarg, get_desc (expand_head env ty_expected), + sarg, get_desc (expand_head env ty_expected1), get_desc (expand_head env ty_expected0) with | Some sarg, Tvariant row, Tvariant row0 -> @@ -3962,8 +3969,8 @@ and type_expect_ | Pexp_poly(sbody, sty) -> if !Clflags.principal then begin_def (); let ty, cty = - match sty with None -> ty_expected, None - | Some sty -> + match sty with None -> protect_expansion env ty_expected, None + | Some sty -> let sty = Ast_helper.Typ.force_poly sty in let cty = Typetexp.transl_simple_type env false sty in cty.ctyp_type, Some cty @@ -4046,7 +4053,8 @@ and type_expect_ match get_desc (Ctype.expand_head env (instance ty_expected)) with Tpackage (p, fl) -> if !Clflags.principal && - get_level (Ctype.expand_head env ty_expected) + get_level (Ctype.expand_head env + (protect_expansion env ty_expected)) < Btype.generic_level then Location.prerr_warning loc @@ -4693,7 +4701,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = (lv <> generic_level || get_level ty_fun' <> generic_level) and ty_fun = instance ty_fun' in let ty_arg, ty_res = - match get_desc (expand_head env ty_expected') with + match get_desc (expand_head env ty_expected) with Tarrow(Nolabel,ty_arg,ty_res,_) -> ty_arg, ty_res | _ -> assert false in @@ -4832,10 +4840,30 @@ and type_application env funct sargs = in let warned = ref false in let rec type_args args ty_fun ty_fun0 sargs = + let type_unknown_args () = + (* 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 + if sargs = [] then type_unknown_args () else let ty_fun' = expand_head env ty_fun in match get_desc ty_fun', get_desc (expand_head env ty_fun0) with | Tarrow (l, ty, ty_fun, com), Tarrow (_, ty0, ty_fun0, _) - when sargs <> [] && is_commu_ok com -> + when is_commu_ok com -> let lv = get_level ty_fun' in let may_warn loc w = if not !warned && !Clflags.principal && lv <> generic_level @@ -4913,23 +4941,7 @@ and type_application env funct sargs = 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 + type_unknown_args () in let is_ignore funct = is_prim ~name:"%ignore" funct && @@ -5226,6 +5238,8 @@ and type_cases ) half_typed_cases; (* type bodies *) let in_function = if List.length caselist = 1 then in_function else None in + let ty_res' = instance ty_res in + if !Clflags.principal then begin_def (); let cases = List.map (fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks; @@ -5248,14 +5262,8 @@ and type_cases 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 + let ty_expected = + if contains_gadt && not !Clflags.principal then (* allow propagation from preceding branches *) correct_levels ty_res else ty_res in @@ -5269,20 +5277,17 @@ and type_cases in let exp = type_unpacks ?in_function ext_env - unpacks pc_rhs (mk_expected ?explanation ty_res') + unpacks pc_rhs (mk_expected ?explanation ty_expected) in { c_lhs = pat; c_guard = guard; - c_rhs = {exp with exp_type = instance ty_res'} + c_rhs = {exp with exp_type = 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; + if !Clflags.principal then end_def (); let do_init = may_contain_gadts || needs_exhaust_check in let ty_arg_check = if do_init then @@ -5323,7 +5328,7 @@ and type_cases if may_contain_gadts then begin end_def (); (* Ensure that existential types do not escape *) - unify_exp_types loc env (instance ty_res) (newvar ()) ; + unify_exp_types loc env ty_res' (newvar ()) ; end; cases, partial diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml index 5662b69ae8..d8a180482c 100644 --- a/src/ocaml/typing/typemod.ml +++ b/src/ocaml/typing/typemod.ml @@ -2153,9 +2153,11 @@ and package_constraints env loc mty constrs = end let modtype_of_package env loc p fl = + (* We call Ctype.correct_levels to ensure that the types being added to the + module type are at generic_level. *) let mty = package_constraints env loc (Mty_ident p) - (List.map (fun (n, t) -> (Longident.flatten n, t)) fl) + (List.map (fun (n, t) -> Longident.flatten n, Ctype.correct_levels t) fl) in Subst.modtype Keep Subst.identity mty diff --git a/src/ocaml/utils/warnings.ml b/src/ocaml/utils/warnings.ml index 333f627dcd..bca751c3df 100644 --- a/src/ocaml/utils/warnings.ml +++ b/src/ocaml/utils/warnings.ml @@ -870,7 +870,7 @@ 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 + let[@manual.ref "s:comp-warnings"] chapter, section = 13, 5 in Printf.sprintf "(See manual section %d.%d)" chapter section let message = function From 06b901f2963da5a5bcb9b2e6bb2d68291700857c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 24 Nov 2022 17:50:54 +0100 Subject: [PATCH 022/130] Parser update --- src/ocaml/preprocess/parser_raw.ml | 9472 ++++++++++++++-------------- 1 file changed, 4738 insertions(+), 4734 deletions(-) diff --git a/src/ocaml/preprocess/parser_raw.ml b/src/ocaml/preprocess/parser_raw.ml index f1065c4a5e..1ff0eace23 100644 --- a/src/ocaml/preprocess/parser_raw.ml +++ b/src/ocaml/preprocess/parser_raw.ml @@ -17,7 +17,7 @@ module MenhirBasics = struct | VAL | UNDERSCORE | UIDENT of ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) # 23 "src/ocaml/preprocess/parser_raw.ml" ) @@ -30,7 +30,7 @@ module MenhirBasics = struct | THEN | STRUCT | STRING of ( -# 831 "src/ocaml/preprocess/parser_raw.mly" +# 835 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) # 36 "src/ocaml/preprocess/parser_raw.ml" ) @@ -43,12 +43,12 @@ module MenhirBasics = struct | RBRACKET | RBRACE | QUOTED_STRING_ITEM of ( -# 836 "src/ocaml/preprocess/parser_raw.mly" +# 840 "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 ( -# 833 "src/ocaml/preprocess/parser_raw.mly" +# 837 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) # 54 "src/ocaml/preprocess/parser_raw.ml" ) @@ -56,7 +56,7 @@ module MenhirBasics = struct | QUESTION | PRIVATE | PREFIXOP of ( -# 817 "src/ocaml/preprocess/parser_raw.mly" +# 821 "src/ocaml/preprocess/parser_raw.mly" (string) # 62 "src/ocaml/preprocess/parser_raw.ml" ) @@ -66,7 +66,7 @@ module MenhirBasics = struct | PERCENT | OR | OPTLABEL of ( -# 810 "src/ocaml/preprocess/parser_raw.mly" +# 814 "src/ocaml/preprocess/parser_raw.mly" (string) # 72 "src/ocaml/preprocess/parser_raw.ml" ) @@ -85,13 +85,13 @@ module MenhirBasics = struct | MATCH | LPAREN | LIDENT of ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) # 91 "src/ocaml/preprocess/parser_raw.ml" ) | LET_LWT | LETOP of ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 779 "src/ocaml/preprocess/parser_raw.mly" (string) # 97 "src/ocaml/preprocess/parser_raw.ml" ) @@ -111,39 +111,39 @@ module MenhirBasics = struct | LBRACE | LAZY | LABEL of ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 784 "src/ocaml/preprocess/parser_raw.mly" (string) # 117 "src/ocaml/preprocess/parser_raw.ml" ) | INT of ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 783 "src/ocaml/preprocess/parser_raw.mly" (string * char option) # 122 "src/ocaml/preprocess/parser_raw.ml" ) | INITIALIZER | INHERIT | INFIXOP4 of ( -# 773 "src/ocaml/preprocess/parser_raw.mly" +# 777 "src/ocaml/preprocess/parser_raw.mly" (string) # 129 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP3 of ( -# 772 "src/ocaml/preprocess/parser_raw.mly" +# 776 "src/ocaml/preprocess/parser_raw.mly" (string) # 134 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP2 of ( -# 771 "src/ocaml/preprocess/parser_raw.mly" +# 775 "src/ocaml/preprocess/parser_raw.mly" (string) # 139 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP1 of ( -# 770 "src/ocaml/preprocess/parser_raw.mly" +# 774 "src/ocaml/preprocess/parser_raw.mly" (string) # 144 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP0 of ( -# 769 "src/ocaml/preprocess/parser_raw.mly" +# 773 "src/ocaml/preprocess/parser_raw.mly" (string) # 149 "src/ocaml/preprocess/parser_raw.ml" ) @@ -151,7 +151,7 @@ module MenhirBasics = struct | IN | IF | HASHOP of ( -# 828 "src/ocaml/preprocess/parser_raw.mly" +# 832 "src/ocaml/preprocess/parser_raw.mly" (string) # 157 "src/ocaml/preprocess/parser_raw.ml" ) @@ -166,7 +166,7 @@ module MenhirBasics = struct | FOR_LWT | FOR | FLOAT of ( -# 758 "src/ocaml/preprocess/parser_raw.mly" +# 762 "src/ocaml/preprocess/parser_raw.mly" (string * char option) # 172 "src/ocaml/preprocess/parser_raw.ml" ) @@ -182,7 +182,7 @@ module MenhirBasics = struct | DOWNTO | DOTTILDE | DOTOP of ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) # 188 "src/ocaml/preprocess/parser_raw.ml" ) @@ -191,14 +191,14 @@ module MenhirBasics = struct | DOT | DONE | DOCSTRING of ( -# 853 "src/ocaml/preprocess/parser_raw.mly" +# 857 "src/ocaml/preprocess/parser_raw.mly" (Docstrings.docstring) # 197 "src/ocaml/preprocess/parser_raw.ml" ) | DO | CONSTRAINT | COMMENT of ( -# 852 "src/ocaml/preprocess/parser_raw.mly" +# 856 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t) # 204 "src/ocaml/preprocess/parser_raw.ml" ) @@ -209,7 +209,7 @@ module MenhirBasics = struct | COLON | CLASS | CHAR of ( -# 738 "src/ocaml/preprocess/parser_raw.mly" +# 742 "src/ocaml/preprocess/parser_raw.mly" (char) # 215 "src/ocaml/preprocess/parser_raw.ml" ) @@ -222,7 +222,7 @@ module MenhirBasics = struct | ASSERT | AS | ANDOP of ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) # 228 "src/ocaml/preprocess/parser_raw.ml" ) @@ -443,6 +443,8 @@ let mkpat_opt_constraint ~loc p = function (*let syntax_error () = raise Syntaxerr.Escape_error*) +let removed_string_set loc = + raise_error Syntaxerr.(Error(Syntaxerr.Removed_string_set(make_loc loc))) (* 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 @@ -528,7 +530,9 @@ let builtin_arraylike_name loc _ ~assign paren_kind n = let opname = if !Clflags.fast then "unsafe_" ^ opname else opname in let prefix = match paren_kind with | Paren -> Lident "Array" - | Bracket -> Lident "String" + | Bracket -> + if assign then removed_string_set loc; + Lident "String" | Brace -> let submodule_name = match n with | One -> "Array1" @@ -894,7 +898,7 @@ let expr_of_lwt_bindings ~loc lbs body = (lbs.lbs_extension, [])) -# 898 "src/ocaml/preprocess/parser_raw.ml" +# 902 "src/ocaml/preprocess/parser_raw.ml" module Tables = struct @@ -1473,9 +1477,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3941 "src/ocaml/preprocess/parser_raw.mly" +# 3945 "src/ocaml/preprocess/parser_raw.mly" ( "+" ) -# 1479 "src/ocaml/preprocess/parser_raw.ml" +# 1483 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1498,9 +1502,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3942 "src/ocaml/preprocess/parser_raw.mly" +# 3946 "src/ocaml/preprocess/parser_raw.mly" ( "+." ) -# 1504 "src/ocaml/preprocess/parser_raw.ml" +# 1508 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1523,9 +1527,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3490 "src/ocaml/preprocess/parser_raw.mly" +# 3494 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1529 "src/ocaml/preprocess/parser_raw.ml" +# 1533 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1570,24 +1574,24 @@ module Tables = struct let _endpos = _endpos_tyvar_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3493 "src/ocaml/preprocess/parser_raw.mly" +# 3497 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_alias(ty, tyvar) ) -# 1576 "src/ocaml/preprocess/parser_raw.ml" +# 1580 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1585 "src/ocaml/preprocess/parser_raw.ml" +# 1589 "src/ocaml/preprocess/parser_raw.ml" in -# 3495 "src/ocaml/preprocess/parser_raw.mly" +# 3499 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1591 "src/ocaml/preprocess/parser_raw.ml" +# 1595 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1633,30 +1637,30 @@ module Tables = struct let _v : (Ast_helper.let_binding) = let attrs2 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1639 "src/ocaml/preprocess/parser_raw.ml" +# 1643 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1648 "src/ocaml/preprocess/parser_raw.ml" +# 1652 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2734 "src/ocaml/preprocess/parser_raw.mly" +# 2738 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklb ~loc:_sloc false body attrs ) -# 1660 "src/ocaml/preprocess/parser_raw.ml" +# 1664 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1679,9 +1683,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3825 "src/ocaml/preprocess/parser_raw.mly" +# 3829 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1685 "src/ocaml/preprocess/parser_raw.ml" +# 1689 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1704,9 +1708,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3826 "src/ocaml/preprocess/parser_raw.mly" +# 3830 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 1710 "src/ocaml/preprocess/parser_raw.ml" +# 1714 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1743,9 +1747,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = -# 3551 "src/ocaml/preprocess/parser_raw.mly" +# 3555 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 1749 "src/ocaml/preprocess/parser_raw.ml" +# 1753 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1808,11 +1812,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3611 "src/ocaml/preprocess/parser_raw.mly" +# 3615 "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 ) -# 1816 "src/ocaml/preprocess/parser_raw.ml" +# 1820 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -1820,24 +1824,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1826 "src/ocaml/preprocess/parser_raw.ml" +# 1830 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 1832 "src/ocaml/preprocess/parser_raw.ml" +# 1836 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3553 "src/ocaml/preprocess/parser_raw.mly" +# 3557 "src/ocaml/preprocess/parser_raw.mly" ( wrap_typ_attrs ~loc:_sloc (reloc_typ ~loc:_sloc _4) _3 ) -# 1841 "src/ocaml/preprocess/parser_raw.ml" +# 1845 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1868,24 +1872,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3556 "src/ocaml/preprocess/parser_raw.mly" +# 3560 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_var _2 ) -# 1874 "src/ocaml/preprocess/parser_raw.ml" +# 1878 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1883 "src/ocaml/preprocess/parser_raw.ml" +# 1887 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1889 "src/ocaml/preprocess/parser_raw.ml" +# 1893 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1909,23 +1913,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3558 "src/ocaml/preprocess/parser_raw.mly" +# 3562 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 1915 "src/ocaml/preprocess/parser_raw.ml" +# 1919 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1923 "src/ocaml/preprocess/parser_raw.ml" +# 1927 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1929 "src/ocaml/preprocess/parser_raw.ml" +# 1933 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1954,35 +1958,35 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 1960 "src/ocaml/preprocess/parser_raw.ml" +# 1964 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3603 "src/ocaml/preprocess/parser_raw.mly" +# 3607 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 1966 "src/ocaml/preprocess/parser_raw.ml" +# 1970 "src/ocaml/preprocess/parser_raw.ml" in -# 3561 "src/ocaml/preprocess/parser_raw.mly" +# 3565 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr(tid, tys) ) -# 1971 "src/ocaml/preprocess/parser_raw.ml" +# 1975 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1980 "src/ocaml/preprocess/parser_raw.ml" +# 1984 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1986 "src/ocaml/preprocess/parser_raw.ml" +# 1990 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2018,20 +2022,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2024 "src/ocaml/preprocess/parser_raw.ml" +# 2028 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3605 "src/ocaml/preprocess/parser_raw.mly" +# 3609 "src/ocaml/preprocess/parser_raw.mly" ( [ty] ) -# 2030 "src/ocaml/preprocess/parser_raw.ml" +# 2034 "src/ocaml/preprocess/parser_raw.ml" in -# 3561 "src/ocaml/preprocess/parser_raw.mly" +# 3565 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr(tid, tys) ) -# 2035 "src/ocaml/preprocess/parser_raw.ml" +# 2039 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_ty_ in @@ -2039,15 +2043,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2045 "src/ocaml/preprocess/parser_raw.ml" +# 2049 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2051 "src/ocaml/preprocess/parser_raw.ml" +# 2055 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2098,9 +2102,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2104 "src/ocaml/preprocess/parser_raw.ml" +# 2108 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -2108,24 +2112,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2112 "src/ocaml/preprocess/parser_raw.ml" +# 2116 "src/ocaml/preprocess/parser_raw.ml" in -# 1152 "src/ocaml/preprocess/parser_raw.mly" +# 1156 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2117 "src/ocaml/preprocess/parser_raw.ml" +# 2121 "src/ocaml/preprocess/parser_raw.ml" in -# 3607 "src/ocaml/preprocess/parser_raw.mly" +# 3611 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 2123 "src/ocaml/preprocess/parser_raw.ml" +# 2127 "src/ocaml/preprocess/parser_raw.ml" in -# 3561 "src/ocaml/preprocess/parser_raw.mly" +# 3565 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr(tid, tys) ) -# 2129 "src/ocaml/preprocess/parser_raw.ml" +# 2133 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -2133,15 +2137,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2139 "src/ocaml/preprocess/parser_raw.ml" +# 2143 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2145 "src/ocaml/preprocess/parser_raw.ml" +# 2149 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2179,24 +2183,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3563 "src/ocaml/preprocess/parser_raw.mly" +# 3567 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = _2 in Ptyp_object (f, c) ) -# 2185 "src/ocaml/preprocess/parser_raw.ml" +# 2189 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2194 "src/ocaml/preprocess/parser_raw.ml" +# 2198 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2200 "src/ocaml/preprocess/parser_raw.ml" +# 2204 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2227,24 +2231,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3565 "src/ocaml/preprocess/parser_raw.mly" +# 3569 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_object ([], Closed) ) -# 2233 "src/ocaml/preprocess/parser_raw.ml" +# 2237 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2242 "src/ocaml/preprocess/parser_raw.ml" +# 2246 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2248 "src/ocaml/preprocess/parser_raw.ml" +# 2252 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2280,20 +2284,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2286 "src/ocaml/preprocess/parser_raw.ml" +# 2290 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3603 "src/ocaml/preprocess/parser_raw.mly" +# 3607 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 2292 "src/ocaml/preprocess/parser_raw.ml" +# 2296 "src/ocaml/preprocess/parser_raw.ml" in -# 3569 "src/ocaml/preprocess/parser_raw.mly" +# 3573 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_class(cid, tys) ) -# 2297 "src/ocaml/preprocess/parser_raw.ml" +# 2301 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos__2_ in @@ -2301,15 +2305,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2307 "src/ocaml/preprocess/parser_raw.ml" +# 2311 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2313 "src/ocaml/preprocess/parser_raw.ml" +# 2317 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2352,20 +2356,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2358 "src/ocaml/preprocess/parser_raw.ml" +# 2362 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3605 "src/ocaml/preprocess/parser_raw.mly" +# 3609 "src/ocaml/preprocess/parser_raw.mly" ( [ty] ) -# 2364 "src/ocaml/preprocess/parser_raw.ml" +# 2368 "src/ocaml/preprocess/parser_raw.ml" in -# 3569 "src/ocaml/preprocess/parser_raw.mly" +# 3573 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_class(cid, tys) ) -# 2369 "src/ocaml/preprocess/parser_raw.ml" +# 2373 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_ty_ in @@ -2373,15 +2377,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2379 "src/ocaml/preprocess/parser_raw.ml" +# 2383 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2385 "src/ocaml/preprocess/parser_raw.ml" +# 2389 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2439,9 +2443,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2445 "src/ocaml/preprocess/parser_raw.ml" +# 2449 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -2449,24 +2453,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2453 "src/ocaml/preprocess/parser_raw.ml" +# 2457 "src/ocaml/preprocess/parser_raw.ml" in -# 1152 "src/ocaml/preprocess/parser_raw.mly" +# 1156 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2458 "src/ocaml/preprocess/parser_raw.ml" +# 2462 "src/ocaml/preprocess/parser_raw.ml" in -# 3607 "src/ocaml/preprocess/parser_raw.mly" +# 3611 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 2464 "src/ocaml/preprocess/parser_raw.ml" +# 2468 "src/ocaml/preprocess/parser_raw.ml" in -# 3569 "src/ocaml/preprocess/parser_raw.mly" +# 3573 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_class(cid, tys) ) -# 2470 "src/ocaml/preprocess/parser_raw.ml" +# 2474 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -2474,15 +2478,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2480 "src/ocaml/preprocess/parser_raw.ml" +# 2484 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2486 "src/ocaml/preprocess/parser_raw.ml" +# 2490 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2520,24 +2524,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3572 "src/ocaml/preprocess/parser_raw.mly" +# 3576 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant([_2], Closed, None) ) -# 2526 "src/ocaml/preprocess/parser_raw.ml" +# 2530 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2535 "src/ocaml/preprocess/parser_raw.ml" +# 2539 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2541 "src/ocaml/preprocess/parser_raw.ml" +# 2545 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2587,24 +2591,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2591 "src/ocaml/preprocess/parser_raw.ml" +# 2595 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2596 "src/ocaml/preprocess/parser_raw.ml" +# 2600 "src/ocaml/preprocess/parser_raw.ml" in -# 3617 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2602 "src/ocaml/preprocess/parser_raw.ml" +# 2606 "src/ocaml/preprocess/parser_raw.ml" in -# 3574 "src/ocaml/preprocess/parser_raw.mly" +# 3578 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Closed, None) ) -# 2608 "src/ocaml/preprocess/parser_raw.ml" +# 2612 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -2612,15 +2616,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2618 "src/ocaml/preprocess/parser_raw.ml" +# 2622 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2624 "src/ocaml/preprocess/parser_raw.ml" +# 2628 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2677,24 +2681,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2681 "src/ocaml/preprocess/parser_raw.ml" +# 2685 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2686 "src/ocaml/preprocess/parser_raw.ml" +# 2690 "src/ocaml/preprocess/parser_raw.ml" in -# 3617 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2692 "src/ocaml/preprocess/parser_raw.ml" +# 2696 "src/ocaml/preprocess/parser_raw.ml" in -# 3576 "src/ocaml/preprocess/parser_raw.mly" +# 3580 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_2 :: _4, Closed, None) ) -# 2698 "src/ocaml/preprocess/parser_raw.ml" +# 2702 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -2702,15 +2706,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2708 "src/ocaml/preprocess/parser_raw.ml" +# 2712 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2714 "src/ocaml/preprocess/parser_raw.ml" +# 2718 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2760,24 +2764,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2764 "src/ocaml/preprocess/parser_raw.ml" +# 2768 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2769 "src/ocaml/preprocess/parser_raw.ml" +# 2773 "src/ocaml/preprocess/parser_raw.ml" in -# 3617 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2775 "src/ocaml/preprocess/parser_raw.ml" +# 2779 "src/ocaml/preprocess/parser_raw.ml" in -# 3578 "src/ocaml/preprocess/parser_raw.mly" +# 3582 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Open, None) ) -# 2781 "src/ocaml/preprocess/parser_raw.ml" +# 2785 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -2785,15 +2789,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2791 "src/ocaml/preprocess/parser_raw.ml" +# 2795 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2797 "src/ocaml/preprocess/parser_raw.ml" +# 2801 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2824,24 +2828,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3580 "src/ocaml/preprocess/parser_raw.mly" +# 3584 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant([], Open, None) ) -# 2830 "src/ocaml/preprocess/parser_raw.ml" +# 2834 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2839 "src/ocaml/preprocess/parser_raw.ml" +# 2843 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2845 "src/ocaml/preprocess/parser_raw.ml" +# 2849 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2891,24 +2895,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2895 "src/ocaml/preprocess/parser_raw.ml" +# 2899 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2900 "src/ocaml/preprocess/parser_raw.ml" +# 2904 "src/ocaml/preprocess/parser_raw.ml" in -# 3617 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2906 "src/ocaml/preprocess/parser_raw.ml" +# 2910 "src/ocaml/preprocess/parser_raw.ml" in -# 3582 "src/ocaml/preprocess/parser_raw.mly" +# 3586 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Closed, Some []) ) -# 2912 "src/ocaml/preprocess/parser_raw.ml" +# 2916 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -2916,15 +2920,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2922 "src/ocaml/preprocess/parser_raw.ml" +# 2926 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2928 "src/ocaml/preprocess/parser_raw.ml" +# 2932 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2989,18 +2993,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2993 "src/ocaml/preprocess/parser_raw.ml" +# 2997 "src/ocaml/preprocess/parser_raw.ml" in -# 1092 "src/ocaml/preprocess/parser_raw.mly" +# 1096 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2998 "src/ocaml/preprocess/parser_raw.ml" +# 3002 "src/ocaml/preprocess/parser_raw.ml" in -# 3645 "src/ocaml/preprocess/parser_raw.mly" +# 3649 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3004 "src/ocaml/preprocess/parser_raw.ml" +# 3008 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -3008,24 +3012,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 3012 "src/ocaml/preprocess/parser_raw.ml" +# 3016 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 3017 "src/ocaml/preprocess/parser_raw.ml" +# 3021 "src/ocaml/preprocess/parser_raw.ml" in -# 3617 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3023 "src/ocaml/preprocess/parser_raw.ml" +# 3027 "src/ocaml/preprocess/parser_raw.ml" in -# 3584 "src/ocaml/preprocess/parser_raw.mly" +# 3588 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Closed, Some _5) ) -# 3029 "src/ocaml/preprocess/parser_raw.ml" +# 3033 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -3033,15 +3037,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 3039 "src/ocaml/preprocess/parser_raw.ml" +# 3043 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3045 "src/ocaml/preprocess/parser_raw.ml" +# 3049 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3065,23 +3069,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3586 "src/ocaml/preprocess/parser_raw.mly" +# 3590 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_extension _1 ) -# 3071 "src/ocaml/preprocess/parser_raw.ml" +# 3075 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 3079 "src/ocaml/preprocess/parser_raw.ml" +# 3083 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3085 "src/ocaml/preprocess/parser_raw.ml" +# 3089 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3105,23 +3109,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (string Location.loc) = let _1 = let _1 = -# 4008 "src/ocaml/preprocess/parser_raw.mly" +# 4012 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3111 "src/ocaml/preprocess/parser_raw.ml" +# 3115 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1020 "src/ocaml/preprocess/parser_raw.mly" +# 1024 "src/ocaml/preprocess/parser_raw.mly" ( mkloc _1 (make_loc _sloc) ) -# 3119 "src/ocaml/preprocess/parser_raw.ml" +# 3123 "src/ocaml/preprocess/parser_raw.ml" in -# 4010 "src/ocaml/preprocess/parser_raw.mly" +# 4014 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3125 "src/ocaml/preprocess/parser_raw.ml" +# 3129 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3159,24 +3163,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (string Location.loc) = let _1 = let _1 = -# 4009 "src/ocaml/preprocess/parser_raw.mly" +# 4013 "src/ocaml/preprocess/parser_raw.mly" ( _1 ^ "." ^ _3.txt ) -# 3165 "src/ocaml/preprocess/parser_raw.ml" +# 3169 "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 -# 1020 "src/ocaml/preprocess/parser_raw.mly" +# 1024 "src/ocaml/preprocess/parser_raw.mly" ( mkloc _1 (make_loc _sloc) ) -# 3174 "src/ocaml/preprocess/parser_raw.ml" +# 3178 "src/ocaml/preprocess/parser_raw.ml" in -# 4010 "src/ocaml/preprocess/parser_raw.mly" +# 4014 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3180 "src/ocaml/preprocess/parser_raw.ml" +# 3184 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3223,9 +3227,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4014 "src/ocaml/preprocess/parser_raw.mly" +# 4018 "src/ocaml/preprocess/parser_raw.mly" ( Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 3229 "src/ocaml/preprocess/parser_raw.ml" +# 3233 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3248,9 +3252,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.class_expr) = -# 1994 "src/ocaml/preprocess/parser_raw.mly" +# 1998 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3254 "src/ocaml/preprocess/parser_raw.ml" +# 3258 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3289,18 +3293,18 @@ module Tables = struct let _v : (Parsetree.class_expr) = let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3295 "src/ocaml/preprocess/parser_raw.ml" +# 3299 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1996 "src/ocaml/preprocess/parser_raw.mly" +# 2000 "src/ocaml/preprocess/parser_raw.mly" ( wrap_class_attrs ~loc:_sloc _3 _2 ) -# 3304 "src/ocaml/preprocess/parser_raw.ml" +# 3308 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3340,9 +3344,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1998 "src/ocaml/preprocess/parser_raw.mly" +# 2002 "src/ocaml/preprocess/parser_raw.mly" ( class_of_let_bindings ~loc:_sloc _1 _3 ) -# 3346 "src/ocaml/preprocess/parser_raw.ml" +# 3350 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3405,34 +3409,34 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 3411 "src/ocaml/preprocess/parser_raw.ml" +# 3415 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in let _4 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3420 "src/ocaml/preprocess/parser_raw.ml" +# 3424 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 3426 "src/ocaml/preprocess/parser_raw.ml" +# 3430 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2000 "src/ocaml/preprocess/parser_raw.mly" +# 2004 "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)) ) -# 3436 "src/ocaml/preprocess/parser_raw.ml" +# 3440 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3502,37 +3506,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 3508 "src/ocaml/preprocess/parser_raw.ml" +# 3512 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3517 "src/ocaml/preprocess/parser_raw.ml" +# 3521 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 3525 "src/ocaml/preprocess/parser_raw.ml" +# 3529 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2000 "src/ocaml/preprocess/parser_raw.mly" +# 2004 "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)) ) -# 3536 "src/ocaml/preprocess/parser_raw.ml" +# 3540 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3562,9 +3566,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = -# 2004 "src/ocaml/preprocess/parser_raw.mly" +# 2008 "src/ocaml/preprocess/parser_raw.mly" ( Cl.attr _1 _2 ) -# 3568 "src/ocaml/preprocess/parser_raw.ml" +# 3572 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3599,18 +3603,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 3603 "src/ocaml/preprocess/parser_raw.ml" +# 3607 "src/ocaml/preprocess/parser_raw.ml" in -# 1092 "src/ocaml/preprocess/parser_raw.mly" +# 1096 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 3608 "src/ocaml/preprocess/parser_raw.ml" +# 3612 "src/ocaml/preprocess/parser_raw.ml" in -# 2007 "src/ocaml/preprocess/parser_raw.mly" +# 2011 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_apply(_1, _2) ) -# 3614 "src/ocaml/preprocess/parser_raw.ml" +# 3618 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -3618,15 +3622,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1047 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3624 "src/ocaml/preprocess/parser_raw.ml" +# 3628 "src/ocaml/preprocess/parser_raw.ml" in -# 2010 "src/ocaml/preprocess/parser_raw.mly" +# 2014 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3630 "src/ocaml/preprocess/parser_raw.ml" +# 3634 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3650,23 +3654,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2009 "src/ocaml/preprocess/parser_raw.mly" +# 2013 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_extension _1 ) -# 3656 "src/ocaml/preprocess/parser_raw.ml" +# 3660 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1047 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3664 "src/ocaml/preprocess/parser_raw.ml" +# 3668 "src/ocaml/preprocess/parser_raw.ml" in -# 2010 "src/ocaml/preprocess/parser_raw.mly" +# 2014 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3670 "src/ocaml/preprocess/parser_raw.ml" +# 3674 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3719,33 +3723,33 @@ module Tables = struct let _v : (Parsetree.class_field) = let _6 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3725 "src/ocaml/preprocess/parser_raw.ml" +# 3729 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3734 "src/ocaml/preprocess/parser_raw.ml" +# 3738 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 3740 "src/ocaml/preprocess/parser_raw.ml" +# 3744 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2065 "src/ocaml/preprocess/parser_raw.mly" +# 2069 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3749 "src/ocaml/preprocess/parser_raw.ml" +# 3753 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3805,36 +3809,36 @@ module Tables = struct let _v : (Parsetree.class_field) = let _6 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3811 "src/ocaml/preprocess/parser_raw.ml" +# 3815 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _3 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3820 "src/ocaml/preprocess/parser_raw.ml" +# 3824 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 3828 "src/ocaml/preprocess/parser_raw.ml" +# 3832 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2065 "src/ocaml/preprocess/parser_raw.mly" +# 2069 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3838 "src/ocaml/preprocess/parser_raw.ml" +# 3842 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3874,9 +3878,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _3 = let _1 = _1_inlined1 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3880 "src/ocaml/preprocess/parser_raw.ml" +# 3884 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3884,11 +3888,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2068 "src/ocaml/preprocess/parser_raw.mly" +# 2072 "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 ) -# 3892 "src/ocaml/preprocess/parser_raw.ml" +# 3896 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3928,9 +3932,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _3 = let _1 = _1_inlined1 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3934 "src/ocaml/preprocess/parser_raw.ml" +# 3938 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3938,11 +3942,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2072 "src/ocaml/preprocess/parser_raw.mly" +# 2076 "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 ) -# 3946 "src/ocaml/preprocess/parser_raw.ml" +# 3950 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3988,28 +3992,28 @@ module Tables = struct let _v : (Parsetree.class_field) = let _4 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3994 "src/ocaml/preprocess/parser_raw.ml" +# 3998 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4003 "src/ocaml/preprocess/parser_raw.ml" +# 4007 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2076 "src/ocaml/preprocess/parser_raw.mly" +# 2080 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 4013 "src/ocaml/preprocess/parser_raw.ml" +# 4017 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4055,28 +4059,28 @@ module Tables = struct let _v : (Parsetree.class_field) = let _4 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4061 "src/ocaml/preprocess/parser_raw.ml" +# 4065 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4070 "src/ocaml/preprocess/parser_raw.ml" +# 4074 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2079 "src/ocaml/preprocess/parser_raw.mly" +# 2083 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_initializer _3) ~attrs:(_2@_4) ~docs ) -# 4080 "src/ocaml/preprocess/parser_raw.ml" +# 4084 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4108,9 +4112,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _2 = let _1 = _1_inlined1 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4114 "src/ocaml/preprocess/parser_raw.ml" +# 4118 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -4118,10 +4122,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2082 "src/ocaml/preprocess/parser_raw.mly" +# 2086 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_extension _1) ~attrs:_2 ~docs ) -# 4125 "src/ocaml/preprocess/parser_raw.ml" +# 4129 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4145,23 +4149,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_field) = let _1 = let _1 = -# 2085 "src/ocaml/preprocess/parser_raw.mly" +# 2089 "src/ocaml/preprocess/parser_raw.mly" ( Pcf_attribute _1 ) -# 4151 "src/ocaml/preprocess/parser_raw.ml" +# 4155 "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" +# 1045 "src/ocaml/preprocess/parser_raw.mly" ( mkcf ~loc:_sloc _1 ) -# 4159 "src/ocaml/preprocess/parser_raw.ml" +# 4163 "src/ocaml/preprocess/parser_raw.ml" in -# 2086 "src/ocaml/preprocess/parser_raw.mly" +# 2090 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4165 "src/ocaml/preprocess/parser_raw.ml" +# 4169 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4191,9 +4195,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = -# 1974 "src/ocaml/preprocess/parser_raw.mly" +# 1978 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 4197 "src/ocaml/preprocess/parser_raw.ml" +# 4201 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4238,24 +4242,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 1977 "src/ocaml/preprocess/parser_raw.mly" +# 1981 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constraint(_4, _2) ) -# 4244 "src/ocaml/preprocess/parser_raw.ml" +# 4248 "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 -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1047 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4253 "src/ocaml/preprocess/parser_raw.ml" +# 4257 "src/ocaml/preprocess/parser_raw.ml" in -# 1980 "src/ocaml/preprocess/parser_raw.mly" +# 1984 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4259 "src/ocaml/preprocess/parser_raw.ml" +# 4263 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4286,24 +4290,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 1979 "src/ocaml/preprocess/parser_raw.mly" +# 1983 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, _2) ) -# 4292 "src/ocaml/preprocess/parser_raw.ml" +# 4296 "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 -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1047 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4301 "src/ocaml/preprocess/parser_raw.ml" +# 4305 "src/ocaml/preprocess/parser_raw.ml" in -# 1980 "src/ocaml/preprocess/parser_raw.mly" +# 1984 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4307 "src/ocaml/preprocess/parser_raw.ml" +# 4311 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4341,24 +4345,24 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2041 "src/ocaml/preprocess/parser_raw.mly" +# 2045 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 4347 "src/ocaml/preprocess/parser_raw.ml" +# 4351 "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 -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1047 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4356 "src/ocaml/preprocess/parser_raw.ml" +# 4360 "src/ocaml/preprocess/parser_raw.ml" in -# 2042 "src/ocaml/preprocess/parser_raw.mly" +# 2046 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4362 "src/ocaml/preprocess/parser_raw.ml" +# 4366 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4389,24 +4393,24 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2041 "src/ocaml/preprocess/parser_raw.mly" +# 2045 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 4395 "src/ocaml/preprocess/parser_raw.ml" +# 4399 "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 -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1047 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4404 "src/ocaml/preprocess/parser_raw.ml" +# 4408 "src/ocaml/preprocess/parser_raw.ml" in -# 2042 "src/ocaml/preprocess/parser_raw.mly" +# 2046 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4410 "src/ocaml/preprocess/parser_raw.ml" +# 4414 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4429,9 +4433,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3815 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4435 "src/ocaml/preprocess/parser_raw.ml" +# 4439 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4471,9 +4475,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2050 "src/ocaml/preprocess/parser_raw.mly" +# 2054 "src/ocaml/preprocess/parser_raw.mly" ( reloc_pat ~loc:_sloc _2 ) -# 4477 "src/ocaml/preprocess/parser_raw.ml" +# 4481 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4525,24 +4529,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2052 "src/ocaml/preprocess/parser_raw.mly" +# 2056 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_2, _4) ) -# 4531 "src/ocaml/preprocess/parser_raw.ml" +# 4535 "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 -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 4540 "src/ocaml/preprocess/parser_raw.ml" +# 4544 "src/ocaml/preprocess/parser_raw.ml" in -# 2053 "src/ocaml/preprocess/parser_raw.mly" +# 2057 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4546 "src/ocaml/preprocess/parser_raw.ml" +# 4550 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4561,9 +4565,9 @@ module Tables = struct let _symbolstartpos = _endpos in let _sloc = (_symbolstartpos, _endpos) in -# 2055 "src/ocaml/preprocess/parser_raw.mly" +# 2059 "src/ocaml/preprocess/parser_raw.mly" ( ghpat ~loc:_sloc Ppat_any ) -# 4567 "src/ocaml/preprocess/parser_raw.ml" +# 4571 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4600,9 +4604,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = -# 2182 "src/ocaml/preprocess/parser_raw.mly" +# 2186 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 4606 "src/ocaml/preprocess/parser_raw.ml" +# 4610 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4619,24 +4623,24 @@ module Tables = struct let _endpos = _startpos in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 2183 "src/ocaml/preprocess/parser_raw.mly" +# 2187 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 4625 "src/ocaml/preprocess/parser_raw.ml" +# 4629 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 4634 "src/ocaml/preprocess/parser_raw.ml" +# 4638 "src/ocaml/preprocess/parser_raw.ml" in -# 2184 "src/ocaml/preprocess/parser_raw.mly" +# 2188 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4640 "src/ocaml/preprocess/parser_raw.ml" +# 4644 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4682,28 +4686,28 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4688 "src/ocaml/preprocess/parser_raw.ml" +# 4692 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4697 "src/ocaml/preprocess/parser_raw.ml" +# 4701 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2192 "src/ocaml/preprocess/parser_raw.mly" +# 2196 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_inherit _3) ~attrs:(_2@_4) ~docs ) -# 4707 "src/ocaml/preprocess/parser_raw.ml" +# 4711 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4761,9 +4765,9 @@ module Tables = struct let ty : (Parsetree.core_type) = Obj.magic ty in let _3 : unit = Obj.magic _3 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 4767 "src/ocaml/preprocess/parser_raw.ml" +# 4771 "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 @@ -4774,9 +4778,9 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4780 "src/ocaml/preprocess/parser_raw.ml" +# 4784 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined3_ in @@ -4784,44 +4788,44 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let label = let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4790 "src/ocaml/preprocess/parser_raw.ml" +# 4794 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4798 "src/ocaml/preprocess/parser_raw.ml" +# 4802 "src/ocaml/preprocess/parser_raw.ml" in -# 2217 "src/ocaml/preprocess/parser_raw.mly" +# 2221 "src/ocaml/preprocess/parser_raw.mly" ( let mut, virt = flags in label, mut, virt, ty ) -# 4807 "src/ocaml/preprocess/parser_raw.ml" +# 4811 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4815 "src/ocaml/preprocess/parser_raw.ml" +# 4819 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2195 "src/ocaml/preprocess/parser_raw.mly" +# 2199 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_val _3) ~attrs:(_2@_4) ~docs ) -# 4825 "src/ocaml/preprocess/parser_raw.ml" +# 4829 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4879,9 +4883,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 4885 "src/ocaml/preprocess/parser_raw.ml" +# 4889 "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 @@ -4892,53 +4896,53 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _7 = let _1 = _1_inlined4 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4898 "src/ocaml/preprocess/parser_raw.ml" +# 4902 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__7_ = _endpos__1_inlined4_ in let _6 = let _1 = _1_inlined3 in -# 3456 "src/ocaml/preprocess/parser_raw.mly" +# 3460 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4907 "src/ocaml/preprocess/parser_raw.ml" +# 4911 "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 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4915 "src/ocaml/preprocess/parser_raw.ml" +# 4919 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4923 "src/ocaml/preprocess/parser_raw.ml" +# 4927 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4931 "src/ocaml/preprocess/parser_raw.ml" +# 4935 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2199 "src/ocaml/preprocess/parser_raw.mly" +# 2203 "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 ) -# 4942 "src/ocaml/preprocess/parser_raw.ml" +# 4946 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4984,28 +4988,28 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4990 "src/ocaml/preprocess/parser_raw.ml" +# 4994 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4999 "src/ocaml/preprocess/parser_raw.ml" +# 5003 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2203 "src/ocaml/preprocess/parser_raw.mly" +# 2207 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 5009 "src/ocaml/preprocess/parser_raw.ml" +# 5013 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5037,9 +5041,9 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _2 = let _1 = _1_inlined1 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5043 "src/ocaml/preprocess/parser_raw.ml" +# 5047 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -5047,10 +5051,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2206 "src/ocaml/preprocess/parser_raw.mly" +# 2210 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_extension _1) ~attrs:_2 ~docs ) -# 5054 "src/ocaml/preprocess/parser_raw.ml" +# 5058 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5074,23 +5078,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_type_field) = let _1 = let _1 = -# 2209 "src/ocaml/preprocess/parser_raw.mly" +# 2213 "src/ocaml/preprocess/parser_raw.mly" ( Pctf_attribute _1 ) -# 5080 "src/ocaml/preprocess/parser_raw.ml" +# 5084 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1043 "src/ocaml/preprocess/parser_raw.mly" ( mkctf ~loc:_sloc _1 ) -# 5088 "src/ocaml/preprocess/parser_raw.ml" +# 5092 "src/ocaml/preprocess/parser_raw.ml" in -# 2210 "src/ocaml/preprocess/parser_raw.mly" +# 2214 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5094 "src/ocaml/preprocess/parser_raw.ml" +# 5098 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5119,42 +5123,42 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5125 "src/ocaml/preprocess/parser_raw.ml" +# 5129 "src/ocaml/preprocess/parser_raw.ml" in let tys = let tys = -# 2168 "src/ocaml/preprocess/parser_raw.mly" +# 2172 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 5132 "src/ocaml/preprocess/parser_raw.ml" +# 5136 "src/ocaml/preprocess/parser_raw.ml" in -# 2174 "src/ocaml/preprocess/parser_raw.mly" +# 2178 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5137 "src/ocaml/preprocess/parser_raw.ml" +# 5141 "src/ocaml/preprocess/parser_raw.ml" in -# 2149 "src/ocaml/preprocess/parser_raw.mly" +# 2153 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_constr (cid, tys) ) -# 5143 "src/ocaml/preprocess/parser_raw.ml" +# 5147 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5152 "src/ocaml/preprocess/parser_raw.ml" +# 5156 "src/ocaml/preprocess/parser_raw.ml" in -# 2152 "src/ocaml/preprocess/parser_raw.mly" +# 2156 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5158 "src/ocaml/preprocess/parser_raw.ml" +# 5162 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5205,9 +5209,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5211 "src/ocaml/preprocess/parser_raw.ml" +# 5215 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -5216,30 +5220,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5220 "src/ocaml/preprocess/parser_raw.ml" +# 5224 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 5225 "src/ocaml/preprocess/parser_raw.ml" +# 5229 "src/ocaml/preprocess/parser_raw.ml" in -# 2170 "src/ocaml/preprocess/parser_raw.mly" +# 2174 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 5231 "src/ocaml/preprocess/parser_raw.ml" +# 5235 "src/ocaml/preprocess/parser_raw.ml" in -# 2174 "src/ocaml/preprocess/parser_raw.mly" +# 2178 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5237 "src/ocaml/preprocess/parser_raw.ml" +# 5241 "src/ocaml/preprocess/parser_raw.ml" in -# 2149 "src/ocaml/preprocess/parser_raw.mly" +# 2153 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_constr (cid, tys) ) -# 5243 "src/ocaml/preprocess/parser_raw.ml" +# 5247 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5247,15 +5251,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5253 "src/ocaml/preprocess/parser_raw.ml" +# 5257 "src/ocaml/preprocess/parser_raw.ml" in -# 2152 "src/ocaml/preprocess/parser_raw.mly" +# 2156 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5259 "src/ocaml/preprocess/parser_raw.ml" +# 5263 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5279,23 +5283,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_type) = let _1 = let _1 = -# 2151 "src/ocaml/preprocess/parser_raw.mly" +# 2155 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_extension _1 ) -# 5285 "src/ocaml/preprocess/parser_raw.ml" +# 5289 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5293 "src/ocaml/preprocess/parser_raw.ml" +# 5297 "src/ocaml/preprocess/parser_raw.ml" in -# 2152 "src/ocaml/preprocess/parser_raw.mly" +# 2156 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5299 "src/ocaml/preprocess/parser_raw.ml" +# 5303 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5352,44 +5356,44 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5356 "src/ocaml/preprocess/parser_raw.ml" +# 5360 "src/ocaml/preprocess/parser_raw.ml" in -# 2188 "src/ocaml/preprocess/parser_raw.mly" +# 2192 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5361 "src/ocaml/preprocess/parser_raw.ml" +# 5365 "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 -# 985 "src/ocaml/preprocess/parser_raw.mly" +# 989 "src/ocaml/preprocess/parser_raw.mly" ( extra_csig _startpos _endpos _1 ) -# 5370 "src/ocaml/preprocess/parser_raw.ml" +# 5374 "src/ocaml/preprocess/parser_raw.ml" in -# 2178 "src/ocaml/preprocess/parser_raw.mly" +# 2182 "src/ocaml/preprocess/parser_raw.mly" ( Csig.mk _1 _2 ) -# 5376 "src/ocaml/preprocess/parser_raw.ml" +# 5380 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5384 "src/ocaml/preprocess/parser_raw.ml" +# 5388 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2154 "src/ocaml/preprocess/parser_raw.mly" +# 2158 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc ~attrs:_2 (Pcty_signature _3) ) -# 5393 "src/ocaml/preprocess/parser_raw.ml" +# 5397 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5419,9 +5423,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_type) = -# 2160 "src/ocaml/preprocess/parser_raw.mly" +# 2164 "src/ocaml/preprocess/parser_raw.mly" ( Cty.attr _1 _2 ) -# 5425 "src/ocaml/preprocess/parser_raw.ml" +# 5429 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5484,34 +5488,34 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5490 "src/ocaml/preprocess/parser_raw.ml" +# 5494 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in let _4 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5499 "src/ocaml/preprocess/parser_raw.ml" +# 5503 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 5505 "src/ocaml/preprocess/parser_raw.ml" +# 5509 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2162 "src/ocaml/preprocess/parser_raw.mly" +# 2166 "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)) ) -# 5515 "src/ocaml/preprocess/parser_raw.ml" +# 5519 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5581,37 +5585,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5587 "src/ocaml/preprocess/parser_raw.ml" +# 5591 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5596 "src/ocaml/preprocess/parser_raw.ml" +# 5600 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 5604 "src/ocaml/preprocess/parser_raw.ml" +# 5608 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2162 "src/ocaml/preprocess/parser_raw.mly" +# 2166 "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)) ) -# 5615 "src/ocaml/preprocess/parser_raw.ml" +# 5619 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5648,9 +5652,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.class_expr) = -# 2014 "src/ocaml/preprocess/parser_raw.mly" +# 2018 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 5654 "src/ocaml/preprocess/parser_raw.ml" +# 5658 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5679,42 +5683,42 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5685 "src/ocaml/preprocess/parser_raw.ml" +# 5689 "src/ocaml/preprocess/parser_raw.ml" in let tys = let tys = -# 2168 "src/ocaml/preprocess/parser_raw.mly" +# 2172 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 5692 "src/ocaml/preprocess/parser_raw.ml" +# 5696 "src/ocaml/preprocess/parser_raw.ml" in -# 2174 "src/ocaml/preprocess/parser_raw.mly" +# 2178 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5697 "src/ocaml/preprocess/parser_raw.ml" +# 5701 "src/ocaml/preprocess/parser_raw.ml" in -# 2021 "src/ocaml/preprocess/parser_raw.mly" +# 2025 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constr(cid, tys) ) -# 5703 "src/ocaml/preprocess/parser_raw.ml" +# 5707 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1047 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5712 "src/ocaml/preprocess/parser_raw.ml" +# 5716 "src/ocaml/preprocess/parser_raw.ml" in -# 2032 "src/ocaml/preprocess/parser_raw.mly" +# 2036 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5718 "src/ocaml/preprocess/parser_raw.ml" +# 5722 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5765,9 +5769,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5771 "src/ocaml/preprocess/parser_raw.ml" +# 5775 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -5776,30 +5780,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5780 "src/ocaml/preprocess/parser_raw.ml" +# 5784 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 5785 "src/ocaml/preprocess/parser_raw.ml" +# 5789 "src/ocaml/preprocess/parser_raw.ml" in -# 2170 "src/ocaml/preprocess/parser_raw.mly" +# 2174 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 5791 "src/ocaml/preprocess/parser_raw.ml" +# 5795 "src/ocaml/preprocess/parser_raw.ml" in -# 2174 "src/ocaml/preprocess/parser_raw.mly" +# 2178 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5797 "src/ocaml/preprocess/parser_raw.ml" +# 5801 "src/ocaml/preprocess/parser_raw.ml" in -# 2021 "src/ocaml/preprocess/parser_raw.mly" +# 2025 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constr(cid, tys) ) -# 5803 "src/ocaml/preprocess/parser_raw.ml" +# 5807 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5807,15 +5811,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1047 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5813 "src/ocaml/preprocess/parser_raw.ml" +# 5817 "src/ocaml/preprocess/parser_raw.ml" in -# 2032 "src/ocaml/preprocess/parser_raw.mly" +# 2036 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5819 "src/ocaml/preprocess/parser_raw.ml" +# 5823 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5867,24 +5871,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2027 "src/ocaml/preprocess/parser_raw.mly" +# 2031 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constraint(_2, _4) ) -# 5873 "src/ocaml/preprocess/parser_raw.ml" +# 5877 "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 -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1047 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5882 "src/ocaml/preprocess/parser_raw.ml" +# 5886 "src/ocaml/preprocess/parser_raw.ml" in -# 2032 "src/ocaml/preprocess/parser_raw.mly" +# 2036 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5888 "src/ocaml/preprocess/parser_raw.ml" +# 5892 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5941,44 +5945,44 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5945 "src/ocaml/preprocess/parser_raw.ml" +# 5949 "src/ocaml/preprocess/parser_raw.ml" in -# 2059 "src/ocaml/preprocess/parser_raw.mly" +# 2063 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5950 "src/ocaml/preprocess/parser_raw.ml" +# 5954 "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 -# 984 "src/ocaml/preprocess/parser_raw.mly" +# 988 "src/ocaml/preprocess/parser_raw.mly" ( extra_cstr _startpos _endpos _1 ) -# 5959 "src/ocaml/preprocess/parser_raw.ml" +# 5963 "src/ocaml/preprocess/parser_raw.ml" in -# 2046 "src/ocaml/preprocess/parser_raw.mly" +# 2050 "src/ocaml/preprocess/parser_raw.mly" ( Cstr.mk _1 _2 ) -# 5965 "src/ocaml/preprocess/parser_raw.ml" +# 5969 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5973 "src/ocaml/preprocess/parser_raw.ml" +# 5977 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2034 "src/ocaml/preprocess/parser_raw.mly" +# 2038 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc ~attrs:_2 (Pcl_structure _3) ) -# 5982 "src/ocaml/preprocess/parser_raw.ml" +# 5986 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6001,9 +6005,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.class_type) = -# 2137 "src/ocaml/preprocess/parser_raw.mly" +# 2141 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6007 "src/ocaml/preprocess/parser_raw.ml" +# 6011 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6049,14 +6053,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3519 "src/ocaml/preprocess/parser_raw.mly" +# 3523 "src/ocaml/preprocess/parser_raw.mly" ( Optional label ) -# 6055 "src/ocaml/preprocess/parser_raw.ml" +# 6059 "src/ocaml/preprocess/parser_raw.ml" in -# 2143 "src/ocaml/preprocess/parser_raw.mly" +# 2147 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6060 "src/ocaml/preprocess/parser_raw.ml" +# 6064 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -6064,15 +6068,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6070 "src/ocaml/preprocess/parser_raw.ml" +# 6074 "src/ocaml/preprocess/parser_raw.ml" in -# 2144 "src/ocaml/preprocess/parser_raw.mly" +# 2148 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6076 "src/ocaml/preprocess/parser_raw.ml" +# 6080 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6119,9 +6123,9 @@ module Tables = struct let domain : (Parsetree.core_type) = Obj.magic domain in let _2 : unit = Obj.magic _2 in let label : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 6125 "src/ocaml/preprocess/parser_raw.ml" +# 6129 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -6129,14 +6133,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3521 "src/ocaml/preprocess/parser_raw.mly" +# 3525 "src/ocaml/preprocess/parser_raw.mly" ( Labelled label ) -# 6135 "src/ocaml/preprocess/parser_raw.ml" +# 6139 "src/ocaml/preprocess/parser_raw.ml" in -# 2143 "src/ocaml/preprocess/parser_raw.mly" +# 2147 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6140 "src/ocaml/preprocess/parser_raw.ml" +# 6144 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -6144,15 +6148,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6150 "src/ocaml/preprocess/parser_raw.ml" +# 6154 "src/ocaml/preprocess/parser_raw.ml" in -# 2144 "src/ocaml/preprocess/parser_raw.mly" +# 2148 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6156 "src/ocaml/preprocess/parser_raw.ml" +# 6160 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6191,14 +6195,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3523 "src/ocaml/preprocess/parser_raw.mly" +# 3527 "src/ocaml/preprocess/parser_raw.mly" ( Nolabel ) -# 6197 "src/ocaml/preprocess/parser_raw.ml" +# 6201 "src/ocaml/preprocess/parser_raw.ml" in -# 2143 "src/ocaml/preprocess/parser_raw.mly" +# 2147 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6202 "src/ocaml/preprocess/parser_raw.ml" +# 6206 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_domain_) in @@ -6206,15 +6210,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6212 "src/ocaml/preprocess/parser_raw.ml" +# 6216 "src/ocaml/preprocess/parser_raw.ml" in -# 2144 "src/ocaml/preprocess/parser_raw.mly" +# 2148 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6218 "src/ocaml/preprocess/parser_raw.ml" +# 6222 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6297,9 +6301,9 @@ module Tables = struct let csig : (Parsetree.class_type) = Obj.magic csig in let _8 : unit = Obj.magic _8 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 6303 "src/ocaml/preprocess/parser_raw.ml" +# 6307 "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 @@ -6315,9 +6319,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6321 "src/ocaml/preprocess/parser_raw.ml" +# 6325 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -6327,24 +6331,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 6333 "src/ocaml/preprocess/parser_raw.ml" +# 6337 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6341 "src/ocaml/preprocess/parser_raw.ml" +# 6345 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2284 "src/ocaml/preprocess/parser_raw.mly" +# 2288 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -6352,19 +6356,19 @@ module Tables = struct ext, Ci.mk id csig ~virt ~params ~attrs ~loc ~docs ) -# 6356 "src/ocaml/preprocess/parser_raw.ml" +# 6360 "src/ocaml/preprocess/parser_raw.ml" in -# 1221 "src/ocaml/preprocess/parser_raw.mly" +# 1225 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 6362 "src/ocaml/preprocess/parser_raw.ml" +# 6366 "src/ocaml/preprocess/parser_raw.ml" in -# 2272 "src/ocaml/preprocess/parser_raw.mly" +# 2276 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6368 "src/ocaml/preprocess/parser_raw.ml" +# 6372 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6387,9 +6391,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3812 "src/ocaml/preprocess/parser_raw.mly" +# 3816 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6393 "src/ocaml/preprocess/parser_raw.ml" +# 6397 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6408,17 +6412,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 783 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 6414 "src/ocaml/preprocess/parser_raw.ml" +# 6418 "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) = -# 3691 "src/ocaml/preprocess/parser_raw.mly" +# 3695 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _1 in Pconst_integer (n, m) ) -# 6422 "src/ocaml/preprocess/parser_raw.ml" +# 6426 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6437,17 +6441,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 738 "src/ocaml/preprocess/parser_raw.mly" +# 742 "src/ocaml/preprocess/parser_raw.mly" (char) -# 6443 "src/ocaml/preprocess/parser_raw.ml" +# 6447 "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) = -# 3692 "src/ocaml/preprocess/parser_raw.mly" +# 3696 "src/ocaml/preprocess/parser_raw.mly" ( Pconst_char _1 ) -# 6451 "src/ocaml/preprocess/parser_raw.ml" +# 6455 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6466,17 +6470,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 831 "src/ocaml/preprocess/parser_raw.mly" +# 835 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 6472 "src/ocaml/preprocess/parser_raw.ml" +# 6476 "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) = -# 3693 "src/ocaml/preprocess/parser_raw.mly" +# 3697 "src/ocaml/preprocess/parser_raw.mly" ( let (s, strloc, d) = _1 in Pconst_string (s, strloc, d) ) -# 6480 "src/ocaml/preprocess/parser_raw.ml" +# 6484 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6495,17 +6499,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 758 "src/ocaml/preprocess/parser_raw.mly" +# 762 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 6501 "src/ocaml/preprocess/parser_raw.ml" +# 6505 "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) = -# 3694 "src/ocaml/preprocess/parser_raw.mly" +# 3698 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _1 in Pconst_float (f, m) ) -# 6509 "src/ocaml/preprocess/parser_raw.ml" +# 6513 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6535,9 +6539,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3767 "src/ocaml/preprocess/parser_raw.mly" +# 3771 "src/ocaml/preprocess/parser_raw.mly" ( "[]" ) -# 6541 "src/ocaml/preprocess/parser_raw.ml" +# 6545 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6567,9 +6571,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3768 "src/ocaml/preprocess/parser_raw.mly" +# 3772 "src/ocaml/preprocess/parser_raw.mly" ( "()" ) -# 6573 "src/ocaml/preprocess/parser_raw.ml" +# 6577 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6592,9 +6596,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3769 "src/ocaml/preprocess/parser_raw.mly" +# 3773 "src/ocaml/preprocess/parser_raw.mly" ( "false" ) -# 6598 "src/ocaml/preprocess/parser_raw.ml" +# 6602 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6617,9 +6621,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3770 "src/ocaml/preprocess/parser_raw.mly" +# 3774 "src/ocaml/preprocess/parser_raw.mly" ( "true" ) -# 6623 "src/ocaml/preprocess/parser_raw.ml" +# 6627 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6638,17 +6642,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) -# 6644 "src/ocaml/preprocess/parser_raw.ml" +# 6648 "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) = -# 3773 "src/ocaml/preprocess/parser_raw.mly" +# 3777 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6652 "src/ocaml/preprocess/parser_raw.ml" +# 6656 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6685,14 +6689,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = let _1 = -# 3764 "src/ocaml/preprocess/parser_raw.mly" +# 3768 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6691 "src/ocaml/preprocess/parser_raw.ml" +# 6695 "src/ocaml/preprocess/parser_raw.ml" in -# 3774 "src/ocaml/preprocess/parser_raw.mly" +# 3778 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6696 "src/ocaml/preprocess/parser_raw.ml" +# 6700 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6715,9 +6719,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3775 "src/ocaml/preprocess/parser_raw.mly" +# 3779 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6721 "src/ocaml/preprocess/parser_raw.ml" +# 6725 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6740,9 +6744,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3778 "src/ocaml/preprocess/parser_raw.mly" +# 3782 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6746 "src/ocaml/preprocess/parser_raw.ml" +# 6750 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6795,15 +6799,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let (_2, _1) = (_2_inlined1, _1_inlined1) in -# 3764 "src/ocaml/preprocess/parser_raw.mly" +# 3768 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6801 "src/ocaml/preprocess/parser_raw.ml" +# 6805 "src/ocaml/preprocess/parser_raw.ml" in -# 3779 "src/ocaml/preprocess/parser_raw.mly" +# 3783 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 6807 "src/ocaml/preprocess/parser_raw.ml" +# 6811 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6840,14 +6844,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = let _1 = -# 3764 "src/ocaml/preprocess/parser_raw.mly" +# 3768 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6846 "src/ocaml/preprocess/parser_raw.ml" +# 6850 "src/ocaml/preprocess/parser_raw.ml" in -# 3780 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 6851 "src/ocaml/preprocess/parser_raw.ml" +# 6855 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6870,9 +6874,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3781 "src/ocaml/preprocess/parser_raw.mly" +# 3785 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 6876 "src/ocaml/preprocess/parser_raw.ml" +# 6880 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6909,9 +6913,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type * Parsetree.core_type) = -# 2228 "src/ocaml/preprocess/parser_raw.mly" +# 2232 "src/ocaml/preprocess/parser_raw.mly" ( _1, _3 ) -# 6915 "src/ocaml/preprocess/parser_raw.ml" +# 6919 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6936,26 +6940,26 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = let tys = let xs = let xs = -# 1108 "src/ocaml/preprocess/parser_raw.mly" +# 1112 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 6942 "src/ocaml/preprocess/parser_raw.ml" +# 6946 "src/ocaml/preprocess/parser_raw.ml" in # 253 "" ( List.rev xs ) -# 6947 "src/ocaml/preprocess/parser_raw.ml" +# 6951 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1132 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 6953 "src/ocaml/preprocess/parser_raw.ml" +# 6957 "src/ocaml/preprocess/parser_raw.ml" in -# 3322 "src/ocaml/preprocess/parser_raw.mly" +# 3326 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_tuple tys ) -# 6959 "src/ocaml/preprocess/parser_raw.ml" +# 6963 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6994,26 +6998,26 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = let tys = let xs = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1116 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 7000 "src/ocaml/preprocess/parser_raw.ml" +# 7004 "src/ocaml/preprocess/parser_raw.ml" in # 253 "" ( List.rev xs ) -# 7005 "src/ocaml/preprocess/parser_raw.ml" +# 7009 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1132 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7011 "src/ocaml/preprocess/parser_raw.ml" +# 7015 "src/ocaml/preprocess/parser_raw.ml" in -# 3322 "src/ocaml/preprocess/parser_raw.mly" +# 3326 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_tuple tys ) -# 7017 "src/ocaml/preprocess/parser_raw.ml" +# 7021 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7050,9 +7054,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.constructor_arguments) = -# 3324 "src/ocaml/preprocess/parser_raw.mly" +# 3328 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_record _2 ) -# 7056 "src/ocaml/preprocess/parser_raw.ml" +# 7060 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7075,9 +7079,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constructor_declaration list) = -# 3238 "src/ocaml/preprocess/parser_raw.mly" +# 3242 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 7081 "src/ocaml/preprocess/parser_raw.ml" +# 7085 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7100,14 +7104,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.constructor_declaration list) = let cs = -# 1213 "src/ocaml/preprocess/parser_raw.mly" +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 7106 "src/ocaml/preprocess/parser_raw.ml" +# 7110 "src/ocaml/preprocess/parser_raw.ml" in -# 3240 "src/ocaml/preprocess/parser_raw.mly" +# 3244 "src/ocaml/preprocess/parser_raw.mly" ( cs ) -# 7111 "src/ocaml/preprocess/parser_raw.ml" +# 7115 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7130,14 +7134,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = -# 3481 "src/ocaml/preprocess/parser_raw.mly" +# 3485 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7136 "src/ocaml/preprocess/parser_raw.ml" +# 7140 "src/ocaml/preprocess/parser_raw.ml" in -# 3471 "src/ocaml/preprocess/parser_raw.mly" +# 3475 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7141 "src/ocaml/preprocess/parser_raw.ml" +# 7145 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7167,9 +7171,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = -# 3473 "src/ocaml/preprocess/parser_raw.mly" +# 3477 "src/ocaml/preprocess/parser_raw.mly" ( Typ.attr _1 _2 ) -# 7173 "src/ocaml/preprocess/parser_raw.ml" +# 7177 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7192,9 +7196,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.direction_flag) = -# 3878 "src/ocaml/preprocess/parser_raw.mly" +# 3882 "src/ocaml/preprocess/parser_raw.mly" ( Upto ) -# 7198 "src/ocaml/preprocess/parser_raw.ml" +# 7202 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7217,9 +7221,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.direction_flag) = -# 3879 "src/ocaml/preprocess/parser_raw.mly" +# 3883 "src/ocaml/preprocess/parser_raw.mly" ( Downto ) -# 7223 "src/ocaml/preprocess/parser_raw.ml" +# 7227 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7259,9 +7263,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4088 "src/ocaml/preprocess/parser_raw.mly" +# 4092 "src/ocaml/preprocess/parser_raw.mly" ( expr_of_lwt_bindings ~loc:_loc _1 (merloc _endpos__2_ _3) ) -# 7265 "src/ocaml/preprocess/parser_raw.ml" +# 7269 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7323,18 +7327,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7327 "src/ocaml/preprocess/parser_raw.ml" +# 7331 "src/ocaml/preprocess/parser_raw.ml" in -# 1185 "src/ocaml/preprocess/parser_raw.mly" +# 1189 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7332 "src/ocaml/preprocess/parser_raw.ml" +# 7336 "src/ocaml/preprocess/parser_raw.ml" in -# 2778 "src/ocaml/preprocess/parser_raw.mly" +# 2782 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7338 "src/ocaml/preprocess/parser_raw.ml" +# 7342 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos_xs_ in @@ -7343,26 +7347,26 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7349 "src/ocaml/preprocess/parser_raw.ml" +# 7353 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7355 "src/ocaml/preprocess/parser_raw.ml" +# 7359 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4090 "src/ocaml/preprocess/parser_raw.mly" +# 4094 "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 ) -# 7366 "src/ocaml/preprocess/parser_raw.ml" +# 7370 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7410,24 +7414,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7416 "src/ocaml/preprocess/parser_raw.ml" +# 7420 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7422 "src/ocaml/preprocess/parser_raw.ml" +# 7426 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4094 "src/ocaml/preprocess/parser_raw.mly" +# 4098 "src/ocaml/preprocess/parser_raw.mly" ( reloc_exp ~loc:_loc (Fake.app Fake.Lwt.in_lwt _3) ) -# 7431 "src/ocaml/preprocess/parser_raw.ml" +# 7435 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7489,18 +7493,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7493 "src/ocaml/preprocess/parser_raw.ml" +# 7497 "src/ocaml/preprocess/parser_raw.ml" in -# 1185 "src/ocaml/preprocess/parser_raw.mly" +# 1189 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7498 "src/ocaml/preprocess/parser_raw.ml" +# 7502 "src/ocaml/preprocess/parser_raw.ml" in -# 2778 "src/ocaml/preprocess/parser_raw.mly" +# 2782 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7504 "src/ocaml/preprocess/parser_raw.ml" +# 7508 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos_xs_ in @@ -7509,25 +7513,25 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7515 "src/ocaml/preprocess/parser_raw.ml" +# 7519 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7521 "src/ocaml/preprocess/parser_raw.ml" +# 7525 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4096 "src/ocaml/preprocess/parser_raw.mly" +# 4100 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_attrs ~loc:_loc (Pexp_try(Fake.app Fake.Lwt.in_lwt _3, List.rev _5)) _2 ) -# 7531 "src/ocaml/preprocess/parser_raw.ml" +# 7535 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7589,21 +7593,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7595 "src/ocaml/preprocess/parser_raw.ml" +# 7599 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7601 "src/ocaml/preprocess/parser_raw.ml" +# 7605 "src/ocaml/preprocess/parser_raw.ml" in -# 4099 "src/ocaml/preprocess/parser_raw.mly" +# 4103 "src/ocaml/preprocess/parser_raw.mly" ( Fake.app (Fake.app Fake.Lwt.finally_ _3) _5 ) -# 7607 "src/ocaml/preprocess/parser_raw.ml" +# 7611 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7679,18 +7683,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7683 "src/ocaml/preprocess/parser_raw.ml" +# 7687 "src/ocaml/preprocess/parser_raw.ml" in -# 1185 "src/ocaml/preprocess/parser_raw.mly" +# 1189 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7688 "src/ocaml/preprocess/parser_raw.ml" +# 7692 "src/ocaml/preprocess/parser_raw.ml" in -# 2778 "src/ocaml/preprocess/parser_raw.mly" +# 2782 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7694 "src/ocaml/preprocess/parser_raw.ml" +# 7698 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -7698,26 +7702,26 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7704 "src/ocaml/preprocess/parser_raw.ml" +# 7708 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7710 "src/ocaml/preprocess/parser_raw.ml" +# 7714 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4101 "src/ocaml/preprocess/parser_raw.mly" +# 4105 "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 ) -# 7721 "src/ocaml/preprocess/parser_raw.ml" +# 7725 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7786,25 +7790,25 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7792 "src/ocaml/preprocess/parser_raw.ml" +# 7796 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7798 "src/ocaml/preprocess/parser_raw.ml" +# 7802 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4105 "src/ocaml/preprocess/parser_raw.mly" +# 4109 "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)) ) -# 7808 "src/ocaml/preprocess/parser_raw.ml" +# 7812 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7901,25 +7905,25 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7907 "src/ocaml/preprocess/parser_raw.ml" +# 7911 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7913 "src/ocaml/preprocess/parser_raw.ml" +# 7917 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__10_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4108 "src/ocaml/preprocess/parser_raw.mly" +# 4112 "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)) ) -# 7923 "src/ocaml/preprocess/parser_raw.ml" +# 7927 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8002,28 +8006,28 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8008 "src/ocaml/preprocess/parser_raw.ml" +# 8012 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8014 "src/ocaml/preprocess/parser_raw.ml" +# 8018 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__8_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4111 "src/ocaml/preprocess/parser_raw.mly" +# 4115 "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 ) -# 8027 "src/ocaml/preprocess/parser_raw.ml" +# 8031 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8046,9 +8050,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2399 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8052 "src/ocaml/preprocess/parser_raw.ml" +# 8056 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8126,9 +8130,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 8132 "src/ocaml/preprocess/parser_raw.ml" +# 8136 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -8136,21 +8140,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8142 "src/ocaml/preprocess/parser_raw.ml" +# 8146 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8148 "src/ocaml/preprocess/parser_raw.ml" +# 8152 "src/ocaml/preprocess/parser_raw.ml" in -# 2430 "src/ocaml/preprocess/parser_raw.mly" +# 2434 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_letmodule(_4, _5, (merloc _endpos__6_ _7)), _3 ) -# 8154 "src/ocaml/preprocess/parser_raw.ml" +# 8158 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8158,10 +8162,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8165 "src/ocaml/preprocess/parser_raw.ml" +# 8169 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8246,9 +8250,9 @@ module Tables = struct let _3 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8252 "src/ocaml/preprocess/parser_raw.ml" +# 8256 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -8257,19 +8261,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 8263 "src/ocaml/preprocess/parser_raw.ml" +# 8267 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3302 "src/ocaml/preprocess/parser_raw.mly" +# 3306 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = _2 in Te.decl _1 ~vars ~args ?res ~attrs:_3 ~loc:(make_loc _sloc) ) -# 8273 "src/ocaml/preprocess/parser_raw.ml" +# 8277 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -8277,21 +8281,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8283 "src/ocaml/preprocess/parser_raw.ml" +# 8287 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8289 "src/ocaml/preprocess/parser_raw.ml" +# 8293 "src/ocaml/preprocess/parser_raw.ml" in -# 2432 "src/ocaml/preprocess/parser_raw.mly" +# 2436 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_letexception(_4, _6), _3 ) -# 8295 "src/ocaml/preprocess/parser_raw.ml" +# 8299 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -8299,10 +8303,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8306 "src/ocaml/preprocess/parser_raw.ml" +# 8310 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8372,28 +8376,28 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8378 "src/ocaml/preprocess/parser_raw.ml" +# 8382 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8384 "src/ocaml/preprocess/parser_raw.ml" +# 8388 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 8390 "src/ocaml/preprocess/parser_raw.ml" +# 8394 "src/ocaml/preprocess/parser_raw.ml" in -# 2434 "src/ocaml/preprocess/parser_raw.mly" +# 2438 "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 ) -# 8397 "src/ocaml/preprocess/parser_raw.ml" +# 8401 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8401,10 +8405,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8408 "src/ocaml/preprocess/parser_raw.ml" +# 8412 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8481,31 +8485,31 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8487 "src/ocaml/preprocess/parser_raw.ml" +# 8491 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8493 "src/ocaml/preprocess/parser_raw.ml" +# 8497 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 8501 "src/ocaml/preprocess/parser_raw.ml" +# 8505 "src/ocaml/preprocess/parser_raw.ml" in -# 2434 "src/ocaml/preprocess/parser_raw.mly" +# 2438 "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 ) -# 8509 "src/ocaml/preprocess/parser_raw.ml" +# 8513 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8513,10 +8517,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8520 "src/ocaml/preprocess/parser_raw.ml" +# 8524 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8565,18 +8569,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8569 "src/ocaml/preprocess/parser_raw.ml" +# 8573 "src/ocaml/preprocess/parser_raw.ml" in -# 1185 "src/ocaml/preprocess/parser_raw.mly" +# 1189 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8574 "src/ocaml/preprocess/parser_raw.ml" +# 8578 "src/ocaml/preprocess/parser_raw.ml" in -# 2778 "src/ocaml/preprocess/parser_raw.mly" +# 2782 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8580 "src/ocaml/preprocess/parser_raw.ml" +# 8584 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -8584,21 +8588,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8590 "src/ocaml/preprocess/parser_raw.ml" +# 8594 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8596 "src/ocaml/preprocess/parser_raw.ml" +# 8600 "src/ocaml/preprocess/parser_raw.ml" in -# 2438 "src/ocaml/preprocess/parser_raw.mly" +# 2442 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_function _3, _2 ) -# 8602 "src/ocaml/preprocess/parser_raw.ml" +# 8606 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -8606,10 +8610,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8613 "src/ocaml/preprocess/parser_raw.ml" +# 8617 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8665,22 +8669,22 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8671 "src/ocaml/preprocess/parser_raw.ml" +# 8675 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8677 "src/ocaml/preprocess/parser_raw.ml" +# 8681 "src/ocaml/preprocess/parser_raw.ml" in -# 2440 "src/ocaml/preprocess/parser_raw.mly" +# 2444 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _3 in Pexp_fun(l, o, p, _4), _2 ) -# 8684 "src/ocaml/preprocess/parser_raw.ml" +# 8688 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -8688,10 +8692,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8695 "src/ocaml/preprocess/parser_raw.ml" +# 8699 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8764,33 +8768,33 @@ module Tables = struct let _endpos = _endpos__7_ in let _v : (Parsetree.expression) = let _1 = let _5 = -# 2662 "src/ocaml/preprocess/parser_raw.mly" +# 2666 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8770 "src/ocaml/preprocess/parser_raw.ml" +# 8774 "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 -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8779 "src/ocaml/preprocess/parser_raw.ml" +# 8783 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8785 "src/ocaml/preprocess/parser_raw.ml" +# 8789 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2443 "src/ocaml/preprocess/parser_raw.mly" +# 2447 "src/ocaml/preprocess/parser_raw.mly" ( (mk_newtypes ~loc:_sloc _5 _7).pexp_desc, _2 ) -# 8794 "src/ocaml/preprocess/parser_raw.ml" +# 8798 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8798,10 +8802,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8805 "src/ocaml/preprocess/parser_raw.ml" +# 8809 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8864,18 +8868,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8868 "src/ocaml/preprocess/parser_raw.ml" +# 8872 "src/ocaml/preprocess/parser_raw.ml" in -# 1185 "src/ocaml/preprocess/parser_raw.mly" +# 1189 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8873 "src/ocaml/preprocess/parser_raw.ml" +# 8877 "src/ocaml/preprocess/parser_raw.ml" in -# 2778 "src/ocaml/preprocess/parser_raw.mly" +# 2782 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8879 "src/ocaml/preprocess/parser_raw.ml" +# 8883 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -8883,21 +8887,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8889 "src/ocaml/preprocess/parser_raw.ml" +# 8893 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8895 "src/ocaml/preprocess/parser_raw.ml" +# 8899 "src/ocaml/preprocess/parser_raw.ml" in -# 2445 "src/ocaml/preprocess/parser_raw.mly" +# 2449 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_match(_3, _5), _2 ) -# 8901 "src/ocaml/preprocess/parser_raw.ml" +# 8905 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -8905,10 +8909,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8912 "src/ocaml/preprocess/parser_raw.ml" +# 8916 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8971,18 +8975,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8975 "src/ocaml/preprocess/parser_raw.ml" +# 8979 "src/ocaml/preprocess/parser_raw.ml" in -# 1185 "src/ocaml/preprocess/parser_raw.mly" +# 1189 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8980 "src/ocaml/preprocess/parser_raw.ml" +# 8984 "src/ocaml/preprocess/parser_raw.ml" in -# 2778 "src/ocaml/preprocess/parser_raw.mly" +# 2782 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8986 "src/ocaml/preprocess/parser_raw.ml" +# 8990 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -8990,21 +8994,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8996 "src/ocaml/preprocess/parser_raw.ml" +# 9000 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9002 "src/ocaml/preprocess/parser_raw.ml" +# 9006 "src/ocaml/preprocess/parser_raw.ml" in -# 2447 "src/ocaml/preprocess/parser_raw.mly" +# 2451 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_try(_3, _5), _2 ) -# 9008 "src/ocaml/preprocess/parser_raw.ml" +# 9012 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -9012,10 +9016,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9019 "src/ocaml/preprocess/parser_raw.ml" +# 9023 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9092,21 +9096,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9098 "src/ocaml/preprocess/parser_raw.ml" +# 9102 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9104 "src/ocaml/preprocess/parser_raw.ml" +# 9108 "src/ocaml/preprocess/parser_raw.ml" in -# 2453 "src/ocaml/preprocess/parser_raw.mly" +# 2457 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), Some (merloc _endpos__6_ _7)), _2 ) -# 9110 "src/ocaml/preprocess/parser_raw.ml" +# 9114 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -9114,10 +9118,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9121 "src/ocaml/preprocess/parser_raw.ml" +# 9125 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9180,21 +9184,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9186 "src/ocaml/preprocess/parser_raw.ml" +# 9190 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9192 "src/ocaml/preprocess/parser_raw.ml" +# 9196 "src/ocaml/preprocess/parser_raw.ml" in -# 2455 "src/ocaml/preprocess/parser_raw.mly" +# 2459 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), None), _2 ) -# 9198 "src/ocaml/preprocess/parser_raw.ml" +# 9202 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -9202,10 +9206,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9209 "src/ocaml/preprocess/parser_raw.ml" +# 9213 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9275,21 +9279,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9281 "src/ocaml/preprocess/parser_raw.ml" +# 9285 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9287 "src/ocaml/preprocess/parser_raw.ml" +# 9291 "src/ocaml/preprocess/parser_raw.ml" in -# 2457 "src/ocaml/preprocess/parser_raw.mly" +# 2461 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_while(_3, (merloc _endpos__4_ _5)), _2 ) -# 9293 "src/ocaml/preprocess/parser_raw.ml" +# 9297 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -9297,10 +9301,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9304 "src/ocaml/preprocess/parser_raw.ml" +# 9308 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9398,21 +9402,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9404 "src/ocaml/preprocess/parser_raw.ml" +# 9408 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9410 "src/ocaml/preprocess/parser_raw.ml" +# 9414 "src/ocaml/preprocess/parser_raw.ml" in -# 2460 "src/ocaml/preprocess/parser_raw.mly" +# 2464 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_for(_3, (merloc _endpos__4_ _5), (merloc _endpos__6_ _7), _6, (merloc _endpos__8_ _9)), _2 ) -# 9416 "src/ocaml/preprocess/parser_raw.ml" +# 9420 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__10_ in @@ -9420,10 +9424,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9427 "src/ocaml/preprocess/parser_raw.ml" +# 9431 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9472,21 +9476,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9478 "src/ocaml/preprocess/parser_raw.ml" +# 9482 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9484 "src/ocaml/preprocess/parser_raw.ml" +# 9488 "src/ocaml/preprocess/parser_raw.ml" in -# 2462 "src/ocaml/preprocess/parser_raw.mly" +# 2466 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_assert _3, _2 ) -# 9490 "src/ocaml/preprocess/parser_raw.ml" +# 9494 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -9494,10 +9498,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9501 "src/ocaml/preprocess/parser_raw.ml" +# 9505 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9546,21 +9550,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9552 "src/ocaml/preprocess/parser_raw.ml" +# 9556 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9558 "src/ocaml/preprocess/parser_raw.ml" +# 9562 "src/ocaml/preprocess/parser_raw.ml" in -# 2464 "src/ocaml/preprocess/parser_raw.mly" +# 2468 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_lazy _3, _2 ) -# 9564 "src/ocaml/preprocess/parser_raw.ml" +# 9568 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -9568,10 +9572,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2397 "src/ocaml/preprocess/parser_raw.mly" +# 2401 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9575 "src/ocaml/preprocess/parser_raw.ml" +# 9579 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9606,18 +9610,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9610 "src/ocaml/preprocess/parser_raw.ml" +# 9614 "src/ocaml/preprocess/parser_raw.ml" in -# 1092 "src/ocaml/preprocess/parser_raw.mly" +# 1096 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 9615 "src/ocaml/preprocess/parser_raw.ml" +# 9619 "src/ocaml/preprocess/parser_raw.ml" in -# 2468 "src/ocaml/preprocess/parser_raw.mly" +# 2472 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, _2) ) -# 9621 "src/ocaml/preprocess/parser_raw.ml" +# 9625 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -9625,15 +9629,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9631 "src/ocaml/preprocess/parser_raw.ml" +# 9635 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9637 "src/ocaml/preprocess/parser_raw.ml" +# 9641 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9662,24 +9666,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9666 "src/ocaml/preprocess/parser_raw.ml" +# 9670 "src/ocaml/preprocess/parser_raw.ml" in -# 1152 "src/ocaml/preprocess/parser_raw.mly" +# 1156 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 9671 "src/ocaml/preprocess/parser_raw.ml" +# 9675 "src/ocaml/preprocess/parser_raw.ml" in -# 2806 "src/ocaml/preprocess/parser_raw.mly" +# 2810 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 9677 "src/ocaml/preprocess/parser_raw.ml" +# 9681 "src/ocaml/preprocess/parser_raw.ml" in -# 2470 "src/ocaml/preprocess/parser_raw.mly" +# 2474 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_tuple(_1) ) -# 9683 "src/ocaml/preprocess/parser_raw.ml" +# 9687 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -9687,15 +9691,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9693 "src/ocaml/preprocess/parser_raw.ml" +# 9697 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9699 "src/ocaml/preprocess/parser_raw.ml" +# 9703 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9731,15 +9735,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 9737 "src/ocaml/preprocess/parser_raw.ml" +# 9741 "src/ocaml/preprocess/parser_raw.ml" in -# 2472 "src/ocaml/preprocess/parser_raw.mly" +# 2476 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct(_1, Some _2) ) -# 9743 "src/ocaml/preprocess/parser_raw.ml" +# 9747 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -9747,15 +9751,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9753 "src/ocaml/preprocess/parser_raw.ml" +# 9757 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9759 "src/ocaml/preprocess/parser_raw.ml" +# 9763 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9786,24 +9790,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2474 "src/ocaml/preprocess/parser_raw.mly" +# 2478 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_variant(_1, Some _2) ) -# 9792 "src/ocaml/preprocess/parser_raw.ml" +# 9796 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9801 "src/ocaml/preprocess/parser_raw.ml" +# 9805 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9807 "src/ocaml/preprocess/parser_raw.ml" +# 9811 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9835,9 +9839,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 769 "src/ocaml/preprocess/parser_raw.mly" +# 773 "src/ocaml/preprocess/parser_raw.mly" (string) -# 9841 "src/ocaml/preprocess/parser_raw.ml" +# 9845 "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 @@ -9847,24 +9851,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3737 "src/ocaml/preprocess/parser_raw.mly" +# 3741 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 9853 "src/ocaml/preprocess/parser_raw.ml" +# 9857 "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 -# 1017 "src/ocaml/preprocess/parser_raw.mly" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 9862 "src/ocaml/preprocess/parser_raw.ml" +# 9866 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 9868 "src/ocaml/preprocess/parser_raw.ml" +# 9872 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9872,15 +9876,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9878 "src/ocaml/preprocess/parser_raw.ml" +# 9882 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9884 "src/ocaml/preprocess/parser_raw.ml" +# 9888 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9912,9 +9916,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 770 "src/ocaml/preprocess/parser_raw.mly" +# 774 "src/ocaml/preprocess/parser_raw.mly" (string) -# 9918 "src/ocaml/preprocess/parser_raw.ml" +# 9922 "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 @@ -9924,24 +9928,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3742 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 9930 "src/ocaml/preprocess/parser_raw.ml" +# 9934 "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 -# 1017 "src/ocaml/preprocess/parser_raw.mly" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 9939 "src/ocaml/preprocess/parser_raw.ml" +# 9943 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 9945 "src/ocaml/preprocess/parser_raw.ml" +# 9949 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9949,15 +9953,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9955 "src/ocaml/preprocess/parser_raw.ml" +# 9959 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9961 "src/ocaml/preprocess/parser_raw.ml" +# 9965 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9989,9 +9993,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 771 "src/ocaml/preprocess/parser_raw.mly" +# 775 "src/ocaml/preprocess/parser_raw.mly" (string) -# 9995 "src/ocaml/preprocess/parser_raw.ml" +# 9999 "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 @@ -10001,24 +10005,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3739 "src/ocaml/preprocess/parser_raw.mly" +# 3743 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10007 "src/ocaml/preprocess/parser_raw.ml" +# 10011 "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 -# 1017 "src/ocaml/preprocess/parser_raw.mly" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10016 "src/ocaml/preprocess/parser_raw.ml" +# 10020 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10022 "src/ocaml/preprocess/parser_raw.ml" +# 10026 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10026,15 +10030,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10032 "src/ocaml/preprocess/parser_raw.ml" +# 10036 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10038 "src/ocaml/preprocess/parser_raw.ml" +# 10042 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10066,9 +10070,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 772 "src/ocaml/preprocess/parser_raw.mly" +# 776 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10072 "src/ocaml/preprocess/parser_raw.ml" +# 10076 "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 @@ -10078,24 +10082,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3740 "src/ocaml/preprocess/parser_raw.mly" +# 3744 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10084 "src/ocaml/preprocess/parser_raw.ml" +# 10088 "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 -# 1017 "src/ocaml/preprocess/parser_raw.mly" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10093 "src/ocaml/preprocess/parser_raw.ml" +# 10097 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10099 "src/ocaml/preprocess/parser_raw.ml" +# 10103 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10103,15 +10107,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10109 "src/ocaml/preprocess/parser_raw.ml" +# 10113 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10115 "src/ocaml/preprocess/parser_raw.ml" +# 10119 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10143,9 +10147,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 773 "src/ocaml/preprocess/parser_raw.mly" +# 777 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10149 "src/ocaml/preprocess/parser_raw.ml" +# 10153 "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 @@ -10155,24 +10159,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3741 "src/ocaml/preprocess/parser_raw.mly" +# 3745 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10161 "src/ocaml/preprocess/parser_raw.ml" +# 10165 "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 -# 1017 "src/ocaml/preprocess/parser_raw.mly" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10170 "src/ocaml/preprocess/parser_raw.ml" +# 10174 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10176 "src/ocaml/preprocess/parser_raw.ml" +# 10180 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10180,15 +10184,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10186 "src/ocaml/preprocess/parser_raw.ml" +# 10190 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10192 "src/ocaml/preprocess/parser_raw.ml" +# 10196 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10228,23 +10232,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3742 "src/ocaml/preprocess/parser_raw.mly" +# 3746 "src/ocaml/preprocess/parser_raw.mly" ("+") -# 10234 "src/ocaml/preprocess/parser_raw.ml" +# 10238 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10242 "src/ocaml/preprocess/parser_raw.ml" +# 10246 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10248 "src/ocaml/preprocess/parser_raw.ml" +# 10252 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10252,15 +10256,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10258 "src/ocaml/preprocess/parser_raw.ml" +# 10262 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10264 "src/ocaml/preprocess/parser_raw.ml" +# 10268 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10300,23 +10304,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3743 "src/ocaml/preprocess/parser_raw.mly" +# 3747 "src/ocaml/preprocess/parser_raw.mly" ("+.") -# 10306 "src/ocaml/preprocess/parser_raw.ml" +# 10310 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10314 "src/ocaml/preprocess/parser_raw.ml" +# 10318 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10320 "src/ocaml/preprocess/parser_raw.ml" +# 10324 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10324,15 +10328,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10330 "src/ocaml/preprocess/parser_raw.ml" +# 10334 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10336 "src/ocaml/preprocess/parser_raw.ml" +# 10340 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10372,23 +10376,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3744 "src/ocaml/preprocess/parser_raw.mly" +# 3748 "src/ocaml/preprocess/parser_raw.mly" ("+=") -# 10378 "src/ocaml/preprocess/parser_raw.ml" +# 10382 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10386 "src/ocaml/preprocess/parser_raw.ml" +# 10390 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10392 "src/ocaml/preprocess/parser_raw.ml" +# 10396 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10396,15 +10400,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10402 "src/ocaml/preprocess/parser_raw.ml" +# 10406 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10408 "src/ocaml/preprocess/parser_raw.ml" +# 10412 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10444,23 +10448,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3745 "src/ocaml/preprocess/parser_raw.mly" +# 3749 "src/ocaml/preprocess/parser_raw.mly" ("-") -# 10450 "src/ocaml/preprocess/parser_raw.ml" +# 10454 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10458 "src/ocaml/preprocess/parser_raw.ml" +# 10462 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10464 "src/ocaml/preprocess/parser_raw.ml" +# 10468 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10468,15 +10472,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10474 "src/ocaml/preprocess/parser_raw.ml" +# 10478 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10480 "src/ocaml/preprocess/parser_raw.ml" +# 10484 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10516,23 +10520,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3746 "src/ocaml/preprocess/parser_raw.mly" +# 3750 "src/ocaml/preprocess/parser_raw.mly" ("-.") -# 10522 "src/ocaml/preprocess/parser_raw.ml" +# 10526 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10530 "src/ocaml/preprocess/parser_raw.ml" +# 10534 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10536 "src/ocaml/preprocess/parser_raw.ml" +# 10540 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10540,15 +10544,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10546 "src/ocaml/preprocess/parser_raw.ml" +# 10550 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10552 "src/ocaml/preprocess/parser_raw.ml" +# 10556 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10588,23 +10592,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3747 "src/ocaml/preprocess/parser_raw.mly" +# 3751 "src/ocaml/preprocess/parser_raw.mly" ("*") -# 10594 "src/ocaml/preprocess/parser_raw.ml" +# 10598 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10602 "src/ocaml/preprocess/parser_raw.ml" +# 10606 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10608 "src/ocaml/preprocess/parser_raw.ml" +# 10612 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10612,15 +10616,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10618 "src/ocaml/preprocess/parser_raw.ml" +# 10622 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10624 "src/ocaml/preprocess/parser_raw.ml" +# 10628 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10660,23 +10664,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3748 "src/ocaml/preprocess/parser_raw.mly" +# 3752 "src/ocaml/preprocess/parser_raw.mly" ("%") -# 10666 "src/ocaml/preprocess/parser_raw.ml" +# 10670 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10674 "src/ocaml/preprocess/parser_raw.ml" +# 10678 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10680 "src/ocaml/preprocess/parser_raw.ml" +# 10684 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10684,15 +10688,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10690 "src/ocaml/preprocess/parser_raw.ml" +# 10694 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10696 "src/ocaml/preprocess/parser_raw.ml" +# 10700 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10732,23 +10736,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3749 "src/ocaml/preprocess/parser_raw.mly" +# 3753 "src/ocaml/preprocess/parser_raw.mly" ("=") -# 10738 "src/ocaml/preprocess/parser_raw.ml" +# 10742 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10746 "src/ocaml/preprocess/parser_raw.ml" +# 10750 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10752 "src/ocaml/preprocess/parser_raw.ml" +# 10756 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10756,15 +10760,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10762 "src/ocaml/preprocess/parser_raw.ml" +# 10766 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10768 "src/ocaml/preprocess/parser_raw.ml" +# 10772 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10804,23 +10808,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3750 "src/ocaml/preprocess/parser_raw.mly" +# 3754 "src/ocaml/preprocess/parser_raw.mly" ("<") -# 10810 "src/ocaml/preprocess/parser_raw.ml" +# 10814 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10818 "src/ocaml/preprocess/parser_raw.ml" +# 10822 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10824 "src/ocaml/preprocess/parser_raw.ml" +# 10828 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10828,15 +10832,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10834 "src/ocaml/preprocess/parser_raw.ml" +# 10838 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10840 "src/ocaml/preprocess/parser_raw.ml" +# 10844 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10876,23 +10880,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3751 "src/ocaml/preprocess/parser_raw.mly" +# 3755 "src/ocaml/preprocess/parser_raw.mly" (">") -# 10882 "src/ocaml/preprocess/parser_raw.ml" +# 10886 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10890 "src/ocaml/preprocess/parser_raw.ml" +# 10894 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10896 "src/ocaml/preprocess/parser_raw.ml" +# 10900 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10900,15 +10904,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10906 "src/ocaml/preprocess/parser_raw.ml" +# 10910 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10912 "src/ocaml/preprocess/parser_raw.ml" +# 10916 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10948,23 +10952,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3752 "src/ocaml/preprocess/parser_raw.mly" +# 3756 "src/ocaml/preprocess/parser_raw.mly" ("or") -# 10954 "src/ocaml/preprocess/parser_raw.ml" +# 10958 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10962 "src/ocaml/preprocess/parser_raw.ml" +# 10966 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10968 "src/ocaml/preprocess/parser_raw.ml" +# 10972 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10972,15 +10976,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10978 "src/ocaml/preprocess/parser_raw.ml" +# 10982 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10984 "src/ocaml/preprocess/parser_raw.ml" +# 10988 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11020,23 +11024,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3753 "src/ocaml/preprocess/parser_raw.mly" +# 3757 "src/ocaml/preprocess/parser_raw.mly" ("||") -# 11026 "src/ocaml/preprocess/parser_raw.ml" +# 11030 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11034 "src/ocaml/preprocess/parser_raw.ml" +# 11038 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11040 "src/ocaml/preprocess/parser_raw.ml" +# 11044 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11044,15 +11048,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11050 "src/ocaml/preprocess/parser_raw.ml" +# 11054 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11056 "src/ocaml/preprocess/parser_raw.ml" +# 11060 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11092,23 +11096,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3754 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ("&") -# 11098 "src/ocaml/preprocess/parser_raw.ml" +# 11102 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11106 "src/ocaml/preprocess/parser_raw.ml" +# 11110 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11112 "src/ocaml/preprocess/parser_raw.ml" +# 11116 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11116,15 +11120,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11122 "src/ocaml/preprocess/parser_raw.ml" +# 11126 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11128 "src/ocaml/preprocess/parser_raw.ml" +# 11132 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11164,23 +11168,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3755 "src/ocaml/preprocess/parser_raw.mly" +# 3759 "src/ocaml/preprocess/parser_raw.mly" ("&&") -# 11170 "src/ocaml/preprocess/parser_raw.ml" +# 11174 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11178 "src/ocaml/preprocess/parser_raw.ml" +# 11182 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11184 "src/ocaml/preprocess/parser_raw.ml" +# 11188 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11188,15 +11192,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11194 "src/ocaml/preprocess/parser_raw.ml" +# 11198 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11200 "src/ocaml/preprocess/parser_raw.ml" +# 11204 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11236,23 +11240,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3756 "src/ocaml/preprocess/parser_raw.mly" +# 3760 "src/ocaml/preprocess/parser_raw.mly" (":=") -# 11242 "src/ocaml/preprocess/parser_raw.ml" +# 11246 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11250 "src/ocaml/preprocess/parser_raw.ml" +# 11254 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11256 "src/ocaml/preprocess/parser_raw.ml" +# 11260 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11260,15 +11264,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11266 "src/ocaml/preprocess/parser_raw.ml" +# 11270 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11272 "src/ocaml/preprocess/parser_raw.ml" +# 11276 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11301,9 +11305,9 @@ module Tables = struct let _1 = let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 2478 "src/ocaml/preprocess/parser_raw.mly" +# 2482 "src/ocaml/preprocess/parser_raw.mly" ( mkuminus ~oploc:_loc__1_ _1 _2 ) -# 11307 "src/ocaml/preprocess/parser_raw.ml" +# 11311 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -11311,15 +11315,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11317 "src/ocaml/preprocess/parser_raw.ml" +# 11321 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11323 "src/ocaml/preprocess/parser_raw.ml" +# 11327 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11352,9 +11356,9 @@ module Tables = struct let _1 = let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2484 "src/ocaml/preprocess/parser_raw.mly" ( mkuplus ~oploc:_loc__1_ _1 _2 ) -# 11358 "src/ocaml/preprocess/parser_raw.ml" +# 11362 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -11362,15 +11366,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11368 "src/ocaml/preprocess/parser_raw.ml" +# 11372 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2404 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11374 "src/ocaml/preprocess/parser_raw.ml" +# 11378 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11410,9 +11414,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2402 "src/ocaml/preprocess/parser_raw.mly" +# 2406 "src/ocaml/preprocess/parser_raw.mly" ( expr_of_let_bindings ~loc:_sloc _1 (merloc _endpos__2_ _3) ) -# 11416 "src/ocaml/preprocess/parser_raw.ml" +# 11420 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11452,9 +11456,9 @@ module Tables = struct let _3 : unit = Obj.magic _3 in let bindings : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = Obj.magic bindings in let _1 : ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 779 "src/ocaml/preprocess/parser_raw.mly" (string) -# 11458 "src/ocaml/preprocess/parser_raw.ml" +# 11462 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -11464,9 +11468,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11470 "src/ocaml/preprocess/parser_raw.ml" +# 11474 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_pbop_op_ = _startpos__1_ in @@ -11474,13 +11478,13 @@ module Tables = struct let _symbolstartpos = _startpos_pbop_op_ in let _sloc = (_symbolstartpos, _endpos) in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2408 "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}) ) -# 11484 "src/ocaml/preprocess/parser_raw.ml" +# 11488 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11521,9 +11525,9 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2410 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_cons ~loc:_sloc _loc__2_ (ghexp ~loc:_sloc (Pexp_tuple[_1;(merloc _endpos__2_ _3)])) ) -# 11527 "src/ocaml/preprocess/parser_raw.ml" +# 11531 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11556,35 +11560,35 @@ module Tables = struct let _3 : (Parsetree.expression) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 11562 "src/ocaml/preprocess/parser_raw.ml" +# 11566 "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 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11571 "src/ocaml/preprocess/parser_raw.ml" +# 11575 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11579 "src/ocaml/preprocess/parser_raw.ml" +# 11583 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2412 "src/ocaml/preprocess/parser_raw.mly" +# 2416 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc (Pexp_setinstvar(_1, _3)) ) -# 11588 "src/ocaml/preprocess/parser_raw.ml" +# 11592 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11640,18 +11644,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11646 "src/ocaml/preprocess/parser_raw.ml" +# 11650 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2418 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc (Pexp_setfield(_1, _3, _5)) ) -# 11655 "src/ocaml/preprocess/parser_raw.ml" +# 11659 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11717,14 +11721,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2415 "src/ocaml/preprocess/parser_raw.mly" +# 2419 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11723 "src/ocaml/preprocess/parser_raw.ml" +# 11727 "src/ocaml/preprocess/parser_raw.ml" in -# 2375 "src/ocaml/preprocess/parser_raw.mly" +# 2379 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 11728 "src/ocaml/preprocess/parser_raw.ml" +# 11732 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11732,9 +11736,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2416 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11738 "src/ocaml/preprocess/parser_raw.ml" +# 11742 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11800,14 +11804,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2415 "src/ocaml/preprocess/parser_raw.mly" +# 2419 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11806 "src/ocaml/preprocess/parser_raw.ml" +# 11810 "src/ocaml/preprocess/parser_raw.ml" in -# 2377 "src/ocaml/preprocess/parser_raw.mly" +# 2381 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 11811 "src/ocaml/preprocess/parser_raw.ml" +# 11815 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11815,9 +11819,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2416 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11821 "src/ocaml/preprocess/parser_raw.ml" +# 11825 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11883,14 +11887,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2415 "src/ocaml/preprocess/parser_raw.mly" +# 2419 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11889 "src/ocaml/preprocess/parser_raw.ml" +# 11893 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2383 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 11894 "src/ocaml/preprocess/parser_raw.ml" +# 11898 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11898,9 +11902,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2416 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11904 "src/ocaml/preprocess/parser_raw.ml" +# 11908 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11960,9 +11964,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 11966 "src/ocaml/preprocess/parser_raw.ml" +# 11970 "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 @@ -11970,31 +11974,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2417 "src/ocaml/preprocess/parser_raw.mly" +# 2421 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11976 "src/ocaml/preprocess/parser_raw.ml" +# 11980 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 11981 "src/ocaml/preprocess/parser_raw.ml" +# 11985 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 11987 "src/ocaml/preprocess/parser_raw.ml" +# 11991 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 11992 "src/ocaml/preprocess/parser_raw.ml" +# 11996 "src/ocaml/preprocess/parser_raw.ml" in -# 2375 "src/ocaml/preprocess/parser_raw.mly" +# 2379 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 11998 "src/ocaml/preprocess/parser_raw.ml" +# 12002 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12002,9 +12006,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2418 "src/ocaml/preprocess/parser_raw.mly" +# 2422 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12008 "src/ocaml/preprocess/parser_raw.ml" +# 12012 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12076,9 +12080,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12082 "src/ocaml/preprocess/parser_raw.ml" +# 12086 "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 @@ -12090,40 +12094,40 @@ module Tables = struct let r = let _1 = _1_inlined1 in -# 2417 "src/ocaml/preprocess/parser_raw.mly" +# 2421 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12096 "src/ocaml/preprocess/parser_raw.ml" +# 12100 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12102 "src/ocaml/preprocess/parser_raw.ml" +# 12106 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 12110 "src/ocaml/preprocess/parser_raw.ml" +# 12114 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12115 "src/ocaml/preprocess/parser_raw.ml" +# 12119 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12121 "src/ocaml/preprocess/parser_raw.ml" +# 12125 "src/ocaml/preprocess/parser_raw.ml" in -# 2375 "src/ocaml/preprocess/parser_raw.mly" +# 2379 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 12127 "src/ocaml/preprocess/parser_raw.ml" +# 12131 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12131,9 +12135,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2418 "src/ocaml/preprocess/parser_raw.mly" +# 2422 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12137 "src/ocaml/preprocess/parser_raw.ml" +# 12141 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12193,9 +12197,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12199 "src/ocaml/preprocess/parser_raw.ml" +# 12203 "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 @@ -12203,31 +12207,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2417 "src/ocaml/preprocess/parser_raw.mly" +# 2421 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12209 "src/ocaml/preprocess/parser_raw.ml" +# 12213 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12214 "src/ocaml/preprocess/parser_raw.ml" +# 12218 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12220 "src/ocaml/preprocess/parser_raw.ml" +# 12224 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12225 "src/ocaml/preprocess/parser_raw.ml" +# 12229 "src/ocaml/preprocess/parser_raw.ml" in -# 2377 "src/ocaml/preprocess/parser_raw.mly" +# 2381 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 12231 "src/ocaml/preprocess/parser_raw.ml" +# 12235 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12235,9 +12239,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2418 "src/ocaml/preprocess/parser_raw.mly" +# 2422 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12241 "src/ocaml/preprocess/parser_raw.ml" +# 12245 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12309,9 +12313,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12315 "src/ocaml/preprocess/parser_raw.ml" +# 12319 "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 @@ -12323,40 +12327,40 @@ module Tables = struct let r = let _1 = _1_inlined1 in -# 2417 "src/ocaml/preprocess/parser_raw.mly" +# 2421 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12329 "src/ocaml/preprocess/parser_raw.ml" +# 12333 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12335 "src/ocaml/preprocess/parser_raw.ml" +# 12339 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 12343 "src/ocaml/preprocess/parser_raw.ml" +# 12347 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12348 "src/ocaml/preprocess/parser_raw.ml" +# 12352 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12354 "src/ocaml/preprocess/parser_raw.ml" +# 12358 "src/ocaml/preprocess/parser_raw.ml" in -# 2377 "src/ocaml/preprocess/parser_raw.mly" +# 2381 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 12360 "src/ocaml/preprocess/parser_raw.ml" +# 12364 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12364,9 +12368,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2418 "src/ocaml/preprocess/parser_raw.mly" +# 2422 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12370 "src/ocaml/preprocess/parser_raw.ml" +# 12374 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12426,9 +12430,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12432 "src/ocaml/preprocess/parser_raw.ml" +# 12436 "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 @@ -12436,31 +12440,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2417 "src/ocaml/preprocess/parser_raw.mly" +# 2421 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12442 "src/ocaml/preprocess/parser_raw.ml" +# 12446 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12447 "src/ocaml/preprocess/parser_raw.ml" +# 12451 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12453 "src/ocaml/preprocess/parser_raw.ml" +# 12457 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12458 "src/ocaml/preprocess/parser_raw.ml" +# 12462 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2383 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 12464 "src/ocaml/preprocess/parser_raw.ml" +# 12468 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12468,9 +12472,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2418 "src/ocaml/preprocess/parser_raw.mly" +# 2422 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12474 "src/ocaml/preprocess/parser_raw.ml" +# 12478 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12542,9 +12546,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12548 "src/ocaml/preprocess/parser_raw.ml" +# 12552 "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 @@ -12556,40 +12560,40 @@ module Tables = struct let r = let _1 = _1_inlined1 in -# 2417 "src/ocaml/preprocess/parser_raw.mly" +# 2421 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12562 "src/ocaml/preprocess/parser_raw.ml" +# 12566 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12568 "src/ocaml/preprocess/parser_raw.ml" +# 12572 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 12576 "src/ocaml/preprocess/parser_raw.ml" +# 12580 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12581 "src/ocaml/preprocess/parser_raw.ml" +# 12585 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12587 "src/ocaml/preprocess/parser_raw.ml" +# 12591 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2383 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 12593 "src/ocaml/preprocess/parser_raw.ml" +# 12597 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12597,9 +12601,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2418 "src/ocaml/preprocess/parser_raw.mly" +# 2422 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12603 "src/ocaml/preprocess/parser_raw.ml" +# 12607 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12629,9 +12633,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2424 "src/ocaml/preprocess/parser_raw.mly" ( Exp.attr _1 _2 ) -# 12635 "src/ocaml/preprocess/parser_raw.ml" +# 12639 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12647,9 +12651,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (string Location.loc option) = -# 4034 "src/ocaml/preprocess/parser_raw.mly" +# 4038 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 12653 "src/ocaml/preprocess/parser_raw.ml" +# 12657 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12679,9 +12683,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string Location.loc option) = -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4039 "src/ocaml/preprocess/parser_raw.mly" ( Some _2 ) -# 12685 "src/ocaml/preprocess/parser_raw.ml" +# 12689 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12725,9 +12729,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.extension) = -# 4047 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( (_2, _3) ) -# 12731 "src/ocaml/preprocess/parser_raw.ml" +# 12735 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12746,9 +12750,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 833 "src/ocaml/preprocess/parser_raw.mly" +# 837 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 12752 "src/ocaml/preprocess/parser_raw.ml" +# 12756 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -12757,9 +12761,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4049 "src/ocaml/preprocess/parser_raw.mly" +# 4053 "src/ocaml/preprocess/parser_raw.mly" ( mk_quotedext ~loc:_sloc _1 ) -# 12763 "src/ocaml/preprocess/parser_raw.ml" +# 12767 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12812,9 +12816,9 @@ module Tables = struct let _v : (Parsetree.extension_constructor) = let attrs = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 12818 "src/ocaml/preprocess/parser_raw.ml" +# 12822 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined3_ in @@ -12824,9 +12828,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12830 "src/ocaml/preprocess/parser_raw.ml" +# 12834 "src/ocaml/preprocess/parser_raw.ml" in let cid = @@ -12835,19 +12839,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12841 "src/ocaml/preprocess/parser_raw.ml" +# 12845 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3391 "src/ocaml/preprocess/parser_raw.mly" +# 3395 "src/ocaml/preprocess/parser_raw.mly" ( let info = symbol_info _endpos in Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 12851 "src/ocaml/preprocess/parser_raw.ml" +# 12855 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12893,9 +12897,9 @@ module Tables = struct let _v : (Parsetree.extension_constructor) = let attrs = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 12899 "src/ocaml/preprocess/parser_raw.ml" +# 12903 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined2_ in @@ -12905,9 +12909,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12911 "src/ocaml/preprocess/parser_raw.ml" +# 12915 "src/ocaml/preprocess/parser_raw.ml" in let cid = @@ -12915,25 +12919,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12921 "src/ocaml/preprocess/parser_raw.ml" +# 12925 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_cid_ = _startpos__1_ in let _1 = -# 3852 "src/ocaml/preprocess/parser_raw.mly" +# 3856 "src/ocaml/preprocess/parser_raw.mly" ( () ) -# 12928 "src/ocaml/preprocess/parser_raw.ml" +# 12932 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos_cid_ in let _sloc = (_symbolstartpos, _endpos) in -# 3391 "src/ocaml/preprocess/parser_raw.mly" +# 3395 "src/ocaml/preprocess/parser_raw.mly" ( let info = symbol_info _endpos in Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 12937 "src/ocaml/preprocess/parser_raw.ml" +# 12941 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12980,10 +12984,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4022 "src/ocaml/preprocess/parser_raw.mly" +# 4026 "src/ocaml/preprocess/parser_raw.mly" ( mark_symbol_docs _sloc; Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 12987 "src/ocaml/preprocess/parser_raw.ml" +# 12991 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12999,14 +13003,14 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let params = -# 2168 "src/ocaml/preprocess/parser_raw.mly" +# 2172 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 13005 "src/ocaml/preprocess/parser_raw.ml" +# 13009 "src/ocaml/preprocess/parser_raw.ml" in -# 1985 "src/ocaml/preprocess/parser_raw.mly" +# 1989 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 13010 "src/ocaml/preprocess/parser_raw.ml" +# 13014 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13047,24 +13051,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 13051 "src/ocaml/preprocess/parser_raw.ml" +# 13055 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13056 "src/ocaml/preprocess/parser_raw.ml" +# 13060 "src/ocaml/preprocess/parser_raw.ml" in -# 2170 "src/ocaml/preprocess/parser_raw.mly" +# 2174 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 13062 "src/ocaml/preprocess/parser_raw.ml" +# 13066 "src/ocaml/preprocess/parser_raw.ml" in -# 1985 "src/ocaml/preprocess/parser_raw.mly" +# 1989 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 13068 "src/ocaml/preprocess/parser_raw.ml" +# 13072 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13087,9 +13091,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2764 "src/ocaml/preprocess/parser_raw.mly" +# 2768 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13093 "src/ocaml/preprocess/parser_raw.ml" +# 13097 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13129,9 +13133,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2766 "src/ocaml/preprocess/parser_raw.mly" +# 2770 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_constraint ~loc:_sloc _3 _1 ) -# 13135 "src/ocaml/preprocess/parser_raw.ml" +# 13139 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13161,9 +13165,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2791 "src/ocaml/preprocess/parser_raw.mly" +# 2795 "src/ocaml/preprocess/parser_raw.mly" ( (merloc _endpos__1_ _2) ) -# 13167 "src/ocaml/preprocess/parser_raw.ml" +# 13171 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13208,24 +13212,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2793 "src/ocaml/preprocess/parser_raw.mly" +# 2797 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_constraint ((merloc _endpos__3_ _4), _2) ) -# 13214 "src/ocaml/preprocess/parser_raw.ml" +# 13218 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 13223 "src/ocaml/preprocess/parser_raw.ml" +# 13227 "src/ocaml/preprocess/parser_raw.ml" in -# 2794 "src/ocaml/preprocess/parser_raw.mly" +# 2798 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13229 "src/ocaml/preprocess/parser_raw.ml" +# 13233 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13258,12 +13262,12 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2797 "src/ocaml/preprocess/parser_raw.mly" +# 2801 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) ) -# 13267 "src/ocaml/preprocess/parser_raw.ml" +# 13271 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13314,17 +13318,17 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _3 = -# 2662 "src/ocaml/preprocess/parser_raw.mly" +# 2666 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13320 "src/ocaml/preprocess/parser_raw.ml" +# 13324 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2802 "src/ocaml/preprocess/parser_raw.mly" +# 2806 "src/ocaml/preprocess/parser_raw.mly" ( mk_newtypes ~loc:_sloc _3 _5 ) -# 13328 "src/ocaml/preprocess/parser_raw.ml" +# 13332 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13347,9 +13351,9 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.core_type) = -# 3507 "src/ocaml/preprocess/parser_raw.mly" +# 3511 "src/ocaml/preprocess/parser_raw.mly" ( ty ) -# 13353 "src/ocaml/preprocess/parser_raw.ml" +# 13357 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13395,19 +13399,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 988 "src/ocaml/preprocess/parser_raw.mly" +# 992 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13401 "src/ocaml/preprocess/parser_raw.ml" +# 13405 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3519 "src/ocaml/preprocess/parser_raw.mly" +# 3523 "src/ocaml/preprocess/parser_raw.mly" ( Optional label ) -# 13406 "src/ocaml/preprocess/parser_raw.ml" +# 13410 "src/ocaml/preprocess/parser_raw.ml" in -# 3513 "src/ocaml/preprocess/parser_raw.mly" +# 3517 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13411 "src/ocaml/preprocess/parser_raw.ml" +# 13415 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13415,15 +13419,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13421 "src/ocaml/preprocess/parser_raw.ml" +# 13425 "src/ocaml/preprocess/parser_raw.ml" in -# 3515 "src/ocaml/preprocess/parser_raw.mly" +# 3519 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13427 "src/ocaml/preprocess/parser_raw.ml" +# 13431 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13470,9 +13474,9 @@ module Tables = struct let _1 : (Parsetree.core_type) = Obj.magic _1 in let _2 : unit = Obj.magic _2 in let label : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 13476 "src/ocaml/preprocess/parser_raw.ml" +# 13480 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -13480,19 +13484,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 988 "src/ocaml/preprocess/parser_raw.mly" +# 992 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13486 "src/ocaml/preprocess/parser_raw.ml" +# 13490 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3521 "src/ocaml/preprocess/parser_raw.mly" +# 3525 "src/ocaml/preprocess/parser_raw.mly" ( Labelled label ) -# 13491 "src/ocaml/preprocess/parser_raw.ml" +# 13495 "src/ocaml/preprocess/parser_raw.ml" in -# 3513 "src/ocaml/preprocess/parser_raw.mly" +# 3517 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13496 "src/ocaml/preprocess/parser_raw.ml" +# 13500 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13500,15 +13504,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13506 "src/ocaml/preprocess/parser_raw.ml" +# 13510 "src/ocaml/preprocess/parser_raw.ml" in -# 3515 "src/ocaml/preprocess/parser_raw.mly" +# 3519 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13512 "src/ocaml/preprocess/parser_raw.ml" +# 13516 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13547,19 +13551,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 988 "src/ocaml/preprocess/parser_raw.mly" +# 992 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13553 "src/ocaml/preprocess/parser_raw.ml" +# 13557 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3523 "src/ocaml/preprocess/parser_raw.mly" +# 3527 "src/ocaml/preprocess/parser_raw.mly" ( Nolabel ) -# 13558 "src/ocaml/preprocess/parser_raw.ml" +# 13562 "src/ocaml/preprocess/parser_raw.ml" in -# 3513 "src/ocaml/preprocess/parser_raw.mly" +# 3517 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13563 "src/ocaml/preprocess/parser_raw.ml" +# 13567 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_codomain_ in @@ -13567,15 +13571,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13573 "src/ocaml/preprocess/parser_raw.ml" +# 13577 "src/ocaml/preprocess/parser_raw.ml" in -# 3515 "src/ocaml/preprocess/parser_raw.mly" +# 3519 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13579 "src/ocaml/preprocess/parser_raw.ml" +# 13583 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13606,9 +13610,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Lexing.position * Parsetree.functor_parameter) = let _startpos = _startpos__1_ in -# 1379 "src/ocaml/preprocess/parser_raw.mly" +# 1383 "src/ocaml/preprocess/parser_raw.mly" ( _startpos, Unit ) -# 13612 "src/ocaml/preprocess/parser_raw.ml" +# 13616 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13664,16 +13668,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 13670 "src/ocaml/preprocess/parser_raw.ml" +# 13674 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1382 "src/ocaml/preprocess/parser_raw.mly" +# 1386 "src/ocaml/preprocess/parser_raw.mly" ( _startpos, Named (x, mty) ) -# 13677 "src/ocaml/preprocess/parser_raw.ml" +# 13681 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13696,9 +13700,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1371 "src/ocaml/preprocess/parser_raw.mly" +# 1375 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13702 "src/ocaml/preprocess/parser_raw.ml" +# 13706 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13715,9 +13719,9 @@ module Tables = struct let _endpos = _startpos in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3306 "src/ocaml/preprocess/parser_raw.mly" +# 3310 "src/ocaml/preprocess/parser_raw.mly" ( ([],Pcstr_tuple [],None) ) -# 13721 "src/ocaml/preprocess/parser_raw.ml" +# 13725 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13748,9 +13752,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3307 "src/ocaml/preprocess/parser_raw.mly" +# 3311 "src/ocaml/preprocess/parser_raw.mly" ( ([],_2,None) ) -# 13754 "src/ocaml/preprocess/parser_raw.ml" +# 13758 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13795,9 +13799,9 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3309 "src/ocaml/preprocess/parser_raw.mly" +# 3313 "src/ocaml/preprocess/parser_raw.mly" ( ([],_2,Some _4) ) -# 13801 "src/ocaml/preprocess/parser_raw.ml" +# 13805 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13860,24 +13864,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 13864 "src/ocaml/preprocess/parser_raw.ml" +# 13868 "src/ocaml/preprocess/parser_raw.ml" in -# 1092 "src/ocaml/preprocess/parser_raw.mly" +# 1096 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13869 "src/ocaml/preprocess/parser_raw.ml" +# 13873 "src/ocaml/preprocess/parser_raw.ml" in -# 3442 "src/ocaml/preprocess/parser_raw.mly" +# 3446 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13875 "src/ocaml/preprocess/parser_raw.ml" +# 13879 "src/ocaml/preprocess/parser_raw.ml" in -# 3312 "src/ocaml/preprocess/parser_raw.mly" +# 3316 "src/ocaml/preprocess/parser_raw.mly" ( (_2,_4,Some _6) ) -# 13881 "src/ocaml/preprocess/parser_raw.ml" +# 13885 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13908,9 +13912,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3314 "src/ocaml/preprocess/parser_raw.mly" +# 3318 "src/ocaml/preprocess/parser_raw.mly" ( ([],Pcstr_tuple [],Some _2) ) -# 13914 "src/ocaml/preprocess/parser_raw.ml" +# 13918 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13959,24 +13963,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 13963 "src/ocaml/preprocess/parser_raw.ml" +# 13967 "src/ocaml/preprocess/parser_raw.ml" in -# 1092 "src/ocaml/preprocess/parser_raw.mly" +# 1096 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13968 "src/ocaml/preprocess/parser_raw.ml" +# 13972 "src/ocaml/preprocess/parser_raw.ml" in -# 3442 "src/ocaml/preprocess/parser_raw.mly" +# 3446 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13974 "src/ocaml/preprocess/parser_raw.ml" +# 13978 "src/ocaml/preprocess/parser_raw.ml" in -# 3316 "src/ocaml/preprocess/parser_raw.mly" +# 3320 "src/ocaml/preprocess/parser_raw.mly" ( (_2,Pcstr_tuple [],Some _4) ) -# 13980 "src/ocaml/preprocess/parser_raw.ml" +# 13984 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14025,9 +14029,9 @@ module Tables = struct Parsetree.attributes * Location.t * Ocaml_parsing.Docstrings.info) = let attrs = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14031 "src/ocaml/preprocess/parser_raw.ml" +# 14035 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined2_ in @@ -14037,23 +14041,23 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14043 "src/ocaml/preprocess/parser_raw.ml" +# 14047 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3254 "src/ocaml/preprocess/parser_raw.mly" +# 3258 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let info = symbol_info _endpos in let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 14057 "src/ocaml/preprocess/parser_raw.ml" +# 14061 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14095,9 +14099,9 @@ module Tables = struct Parsetree.attributes * Location.t * Ocaml_parsing.Docstrings.info) = let attrs = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14101 "src/ocaml/preprocess/parser_raw.ml" +# 14105 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined1_ in @@ -14106,29 +14110,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14112 "src/ocaml/preprocess/parser_raw.ml" +# 14116 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_cid_ = _startpos__1_ in let _1 = -# 3852 "src/ocaml/preprocess/parser_raw.mly" +# 3856 "src/ocaml/preprocess/parser_raw.mly" ( () ) -# 14119 "src/ocaml/preprocess/parser_raw.ml" +# 14123 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos_cid_ in let _sloc = (_symbolstartpos, _endpos) in -# 3254 "src/ocaml/preprocess/parser_raw.mly" +# 3258 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let info = symbol_info _endpos in let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 14132 "src/ocaml/preprocess/parser_raw.ml" +# 14136 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14199,9 +14203,9 @@ module Tables = struct 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 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14205 "src/ocaml/preprocess/parser_raw.ml" +# 14209 "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 @@ -14214,9 +14218,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined4 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14220 "src/ocaml/preprocess/parser_raw.ml" +# 14224 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14225,26 +14229,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14229 "src/ocaml/preprocess/parser_raw.ml" +# 14233 "src/ocaml/preprocess/parser_raw.ml" in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1078 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14234 "src/ocaml/preprocess/parser_raw.ml" +# 14238 "src/ocaml/preprocess/parser_raw.ml" in -# 3157 "src/ocaml/preprocess/parser_raw.mly" +# 3161 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14240 "src/ocaml/preprocess/parser_raw.ml" +# 14244 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined3 in -# 3192 "src/ocaml/preprocess/parser_raw.mly" +# 3196 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 14248 "src/ocaml/preprocess/parser_raw.ml" +# 14252 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14253,29 +14257,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14259 "src/ocaml/preprocess/parser_raw.ml" +# 14263 "src/ocaml/preprocess/parser_raw.ml" in let flag = -# 3872 "src/ocaml/preprocess/parser_raw.mly" +# 3876 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 14265 "src/ocaml/preprocess/parser_raw.ml" +# 14269 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14272 "src/ocaml/preprocess/parser_raw.ml" +# 14276 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3129 "src/ocaml/preprocess/parser_raw.mly" +# 3133 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14284,7 +14288,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14288 "src/ocaml/preprocess/parser_raw.ml" +# 14292 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14361,9 +14365,9 @@ module Tables = struct 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 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14367 "src/ocaml/preprocess/parser_raw.ml" +# 14371 "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 @@ -14377,9 +14381,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined5 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14383 "src/ocaml/preprocess/parser_raw.ml" +# 14387 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined5_ in @@ -14388,26 +14392,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14392 "src/ocaml/preprocess/parser_raw.ml" +# 14396 "src/ocaml/preprocess/parser_raw.ml" in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1078 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14397 "src/ocaml/preprocess/parser_raw.ml" +# 14401 "src/ocaml/preprocess/parser_raw.ml" in -# 3157 "src/ocaml/preprocess/parser_raw.mly" +# 3161 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14403 "src/ocaml/preprocess/parser_raw.ml" +# 14407 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined4 in -# 3192 "src/ocaml/preprocess/parser_raw.mly" +# 3196 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 14411 "src/ocaml/preprocess/parser_raw.ml" +# 14415 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14416,9 +14420,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14422 "src/ocaml/preprocess/parser_raw.ml" +# 14426 "src/ocaml/preprocess/parser_raw.ml" in let flag = @@ -14427,24 +14431,24 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3874 "src/ocaml/preprocess/parser_raw.mly" +# 3878 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 14433 "src/ocaml/preprocess/parser_raw.ml" +# 14437 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14441 "src/ocaml/preprocess/parser_raw.ml" +# 14445 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3129 "src/ocaml/preprocess/parser_raw.mly" +# 3133 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14453,7 +14457,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14457 "src/ocaml/preprocess/parser_raw.ml" +# 14461 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14517,9 +14521,9 @@ module Tables = struct 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 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14523 "src/ocaml/preprocess/parser_raw.ml" +# 14527 "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 @@ -14532,9 +14536,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14538 "src/ocaml/preprocess/parser_raw.ml" +# 14542 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -14543,18 +14547,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14547 "src/ocaml/preprocess/parser_raw.ml" +# 14551 "src/ocaml/preprocess/parser_raw.ml" in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1078 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14552 "src/ocaml/preprocess/parser_raw.ml" +# 14556 "src/ocaml/preprocess/parser_raw.ml" in -# 3157 "src/ocaml/preprocess/parser_raw.mly" +# 3161 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14558 "src/ocaml/preprocess/parser_raw.ml" +# 14562 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14563,29 +14567,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14569 "src/ocaml/preprocess/parser_raw.ml" +# 14573 "src/ocaml/preprocess/parser_raw.ml" in let flag = -# 3868 "src/ocaml/preprocess/parser_raw.mly" +# 3872 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 14575 "src/ocaml/preprocess/parser_raw.ml" +# 14579 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14582 "src/ocaml/preprocess/parser_raw.ml" +# 14586 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3129 "src/ocaml/preprocess/parser_raw.mly" +# 3133 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14594,7 +14598,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14598 "src/ocaml/preprocess/parser_raw.ml" +# 14602 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14664,9 +14668,9 @@ module Tables = struct 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 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14670 "src/ocaml/preprocess/parser_raw.ml" +# 14674 "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 @@ -14680,9 +14684,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined4 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14686 "src/ocaml/preprocess/parser_raw.ml" +# 14690 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14691,18 +14695,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14695 "src/ocaml/preprocess/parser_raw.ml" +# 14699 "src/ocaml/preprocess/parser_raw.ml" in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1078 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14700 "src/ocaml/preprocess/parser_raw.ml" +# 14704 "src/ocaml/preprocess/parser_raw.ml" in -# 3157 "src/ocaml/preprocess/parser_raw.mly" +# 3161 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14706 "src/ocaml/preprocess/parser_raw.ml" +# 14710 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14711,32 +14715,32 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14717 "src/ocaml/preprocess/parser_raw.ml" +# 14721 "src/ocaml/preprocess/parser_raw.ml" in let flag = let _1 = _1_inlined2 in -# 3869 "src/ocaml/preprocess/parser_raw.mly" +# 3873 "src/ocaml/preprocess/parser_raw.mly" ( Nonrecursive ) -# 14725 "src/ocaml/preprocess/parser_raw.ml" +# 14729 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14733 "src/ocaml/preprocess/parser_raw.ml" +# 14737 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3129 "src/ocaml/preprocess/parser_raw.mly" +# 3133 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14745,7 +14749,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14749 "src/ocaml/preprocess/parser_raw.ml" +# 14753 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14764,17 +14768,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14770 "src/ocaml/preprocess/parser_raw.ml" +# 14774 "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) = -# 3707 "src/ocaml/preprocess/parser_raw.mly" +# 3711 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14778 "src/ocaml/preprocess/parser_raw.ml" +# 14782 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14793,17 +14797,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14799 "src/ocaml/preprocess/parser_raw.ml" +# 14803 "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" +# 3712 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14807 "src/ocaml/preprocess/parser_raw.ml" +# 14811 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14833,9 +14837,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.structure) = -# 1245 "src/ocaml/preprocess/parser_raw.mly" +# 1249 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14839 "src/ocaml/preprocess/parser_raw.ml" +# 14843 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14851,9 +14855,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (string) = -# 3759 "src/ocaml/preprocess/parser_raw.mly" +# 3763 "src/ocaml/preprocess/parser_raw.mly" ( "" ) -# 14857 "src/ocaml/preprocess/parser_raw.ml" +# 14861 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14883,9 +14887,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3760 "src/ocaml/preprocess/parser_raw.mly" +# 3764 "src/ocaml/preprocess/parser_raw.mly" ( ";.." ) -# 14889 "src/ocaml/preprocess/parser_raw.ml" +# 14893 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14915,9 +14919,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.signature) = -# 1252 "src/ocaml/preprocess/parser_raw.mly" +# 1256 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14921 "src/ocaml/preprocess/parser_raw.ml" +# 14925 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14961,9 +14965,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.extension) = -# 4052 "src/ocaml/preprocess/parser_raw.mly" +# 4056 "src/ocaml/preprocess/parser_raw.mly" ( (_2, _3) ) -# 14967 "src/ocaml/preprocess/parser_raw.ml" +# 14971 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14982,9 +14986,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 836 "src/ocaml/preprocess/parser_raw.mly" +# 840 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 14988 "src/ocaml/preprocess/parser_raw.ml" +# 14992 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -14993,9 +14997,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4054 "src/ocaml/preprocess/parser_raw.mly" +# 4058 "src/ocaml/preprocess/parser_raw.mly" ( mk_quotedext ~loc:_sloc _1 ) -# 14999 "src/ocaml/preprocess/parser_raw.ml" +# 15003 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15041,9 +15045,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _3 : unit = Obj.magic _3 in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15047 "src/ocaml/preprocess/parser_raw.ml" +# 15051 "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 @@ -15052,34 +15056,34 @@ module Tables = struct let _v : (Parsetree.label_declaration) = let _5 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15058 "src/ocaml/preprocess/parser_raw.ml" +# 15062 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 3460 "src/ocaml/preprocess/parser_raw.mly" +# 3464 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15067 "src/ocaml/preprocess/parser_raw.ml" +# 15071 "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 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15075 "src/ocaml/preprocess/parser_raw.ml" +# 15079 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15083 "src/ocaml/preprocess/parser_raw.ml" +# 15087 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15090,10 +15094,10 @@ module Tables = struct _startpos__2_ in let _sloc = (_symbolstartpos, _endpos) in -# 3333 "src/ocaml/preprocess/parser_raw.mly" +# 3337 "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 ) -# 15097 "src/ocaml/preprocess/parser_raw.ml" +# 15101 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15153,9 +15157,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _3 : unit = Obj.magic _3 in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15159 "src/ocaml/preprocess/parser_raw.ml" +# 15163 "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 @@ -15164,43 +15168,43 @@ module Tables = struct let _v : (Parsetree.label_declaration) = let _7 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15170 "src/ocaml/preprocess/parser_raw.ml" +# 15174 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__7_ = _endpos__1_inlined4_ in let _5 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15179 "src/ocaml/preprocess/parser_raw.ml" +# 15183 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 3460 "src/ocaml/preprocess/parser_raw.mly" +# 3464 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15188 "src/ocaml/preprocess/parser_raw.ml" +# 15192 "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 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15196 "src/ocaml/preprocess/parser_raw.ml" +# 15200 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15204 "src/ocaml/preprocess/parser_raw.ml" +# 15208 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15211,14 +15215,14 @@ module Tables = struct _startpos__2_ in let _sloc = (_symbolstartpos, _endpos) in -# 3338 "src/ocaml/preprocess/parser_raw.mly" +# 3342 "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 ) -# 15222 "src/ocaml/preprocess/parser_raw.ml" +# 15226 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15241,9 +15245,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.label_declaration list) = -# 3327 "src/ocaml/preprocess/parser_raw.mly" +# 3331 "src/ocaml/preprocess/parser_raw.mly" ( [_1] ) -# 15247 "src/ocaml/preprocess/parser_raw.ml" +# 15251 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15266,9 +15270,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.label_declaration list) = -# 3328 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( [_1] ) -# 15272 "src/ocaml/preprocess/parser_raw.ml" +# 15276 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15298,9 +15302,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.label_declaration list) = -# 3329 "src/ocaml/preprocess/parser_raw.mly" +# 3333 "src/ocaml/preprocess/parser_raw.mly" ( _1 :: _2 ) -# 15304 "src/ocaml/preprocess/parser_raw.ml" +# 15308 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15319,9 +15323,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15325 "src/ocaml/preprocess/parser_raw.ml" +# 15329 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15332,24 +15336,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15338 "src/ocaml/preprocess/parser_raw.ml" +# 15342 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2363 "src/ocaml/preprocess/parser_raw.mly" +# 2367 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15347 "src/ocaml/preprocess/parser_raw.ml" +# 15351 "src/ocaml/preprocess/parser_raw.ml" in -# 2355 "src/ocaml/preprocess/parser_raw.mly" +# 2359 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 15353 "src/ocaml/preprocess/parser_raw.ml" +# 15357 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15382,9 +15386,9 @@ module Tables = struct let cty : (Parsetree.core_type) = Obj.magic cty in let _2 : unit = Obj.magic _2 in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15388 "src/ocaml/preprocess/parser_raw.ml" +# 15392 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15395,18 +15399,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15401 "src/ocaml/preprocess/parser_raw.ml" +# 15405 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2363 "src/ocaml/preprocess/parser_raw.mly" +# 2367 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15410 "src/ocaml/preprocess/parser_raw.ml" +# 15414 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_x_ = _startpos__1_ in @@ -15414,11 +15418,11 @@ module Tables = struct let _symbolstartpos = _startpos_x_ in let _sloc = (_symbolstartpos, _endpos) in -# 2357 "src/ocaml/preprocess/parser_raw.mly" +# 2361 "src/ocaml/preprocess/parser_raw.mly" ( let lab, pat = x in lab, mkpat ~loc:_sloc (Ppat_constraint (pat, cty)) ) -# 15422 "src/ocaml/preprocess/parser_raw.ml" +# 15426 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15441,9 +15445,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3791 "src/ocaml/preprocess/parser_raw.mly" +# 3795 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15447 "src/ocaml/preprocess/parser_raw.ml" +# 15451 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15466,9 +15470,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.arg_label * Parsetree.expression) = -# 2645 "src/ocaml/preprocess/parser_raw.mly" +# 2649 "src/ocaml/preprocess/parser_raw.mly" ( (Nolabel, _1) ) -# 15472 "src/ocaml/preprocess/parser_raw.ml" +# 15476 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15494,17 +15498,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 784 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15500 "src/ocaml/preprocess/parser_raw.ml" +# 15504 "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) = -# 2647 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled _1, _2) ) -# 15508 "src/ocaml/preprocess/parser_raw.ml" +# 15512 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15529,9 +15533,9 @@ module Tables = struct }; } = _menhir_stack in let label : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15535 "src/ocaml/preprocess/parser_raw.ml" +# 15539 "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 @@ -15539,10 +15543,10 @@ module Tables = struct let _endpos = _endpos_label_ in let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2649 "src/ocaml/preprocess/parser_raw.mly" +# 2653 "src/ocaml/preprocess/parser_raw.mly" ( let loc = _loc_label_ in (Labelled label, mkexpvar ~loc label) ) -# 15546 "src/ocaml/preprocess/parser_raw.ml" +# 15550 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15587,9 +15591,9 @@ module Tables = struct let _5 : unit = Obj.magic _5 in let ty : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic ty in let label : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15593 "src/ocaml/preprocess/parser_raw.ml" +# 15597 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _2 : unit = Obj.magic _2 in let _1 : unit = Obj.magic _1 in @@ -15599,10 +15603,10 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression) = let _endpos = _endpos__5_ in let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2652 "src/ocaml/preprocess/parser_raw.mly" +# 2656 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled label, mkexp_constraint ~loc:(_startpos__2_, _endpos) (mkexpvar ~loc:_loc_label_ label) ty) ) -# 15606 "src/ocaml/preprocess/parser_raw.ml" +# 15610 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15627,9 +15631,9 @@ module Tables = struct }; } = _menhir_stack in let label : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15633 "src/ocaml/preprocess/parser_raw.ml" +# 15637 "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 @@ -15637,10 +15641,10 @@ module Tables = struct let _endpos = _endpos_label_ in let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2655 "src/ocaml/preprocess/parser_raw.mly" +# 2659 "src/ocaml/preprocess/parser_raw.mly" ( let loc = _loc_label_ in (Optional label, mkexpvar ~loc label) ) -# 15644 "src/ocaml/preprocess/parser_raw.ml" +# 15648 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15666,17 +15670,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 810 "src/ocaml/preprocess/parser_raw.mly" +# 814 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15672 "src/ocaml/preprocess/parser_raw.ml" +# 15676 "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) = -# 2658 "src/ocaml/preprocess/parser_raw.mly" +# 2662 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, _2) ) -# 15680 "src/ocaml/preprocess/parser_raw.ml" +# 15684 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15729,15 +15733,15 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 = let _1 = _1_inlined1 in -# 2351 "src/ocaml/preprocess/parser_raw.mly" +# 2355 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15735 "src/ocaml/preprocess/parser_raw.ml" +# 15739 "src/ocaml/preprocess/parser_raw.ml" in -# 2325 "src/ocaml/preprocess/parser_raw.mly" +# 2329 "src/ocaml/preprocess/parser_raw.mly" ( (Optional (fst _3), _4, snd _3) ) -# 15741 "src/ocaml/preprocess/parser_raw.ml" +# 15745 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15762,9 +15766,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15768 "src/ocaml/preprocess/parser_raw.ml" +# 15772 "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 @@ -15777,24 +15781,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15783 "src/ocaml/preprocess/parser_raw.ml" +# 15787 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2363 "src/ocaml/preprocess/parser_raw.mly" +# 2367 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15792 "src/ocaml/preprocess/parser_raw.ml" +# 15796 "src/ocaml/preprocess/parser_raw.ml" in -# 2327 "src/ocaml/preprocess/parser_raw.mly" +# 2331 "src/ocaml/preprocess/parser_raw.mly" ( (Optional (fst _2), None, snd _2) ) -# 15798 "src/ocaml/preprocess/parser_raw.ml" +# 15802 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15841,9 +15845,9 @@ module Tables = struct let _3 : (Parsetree.pattern) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 810 "src/ocaml/preprocess/parser_raw.mly" +# 814 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15847 "src/ocaml/preprocess/parser_raw.ml" +# 15851 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15851,15 +15855,15 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 = let _1 = _1_inlined1 in -# 2351 "src/ocaml/preprocess/parser_raw.mly" +# 2355 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15857 "src/ocaml/preprocess/parser_raw.ml" +# 15861 "src/ocaml/preprocess/parser_raw.ml" in -# 2329 "src/ocaml/preprocess/parser_raw.mly" +# 2333 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, _4, _3) ) -# 15863 "src/ocaml/preprocess/parser_raw.ml" +# 15867 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15885,17 +15889,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.pattern) = Obj.magic _2 in let _1 : ( -# 810 "src/ocaml/preprocess/parser_raw.mly" +# 814 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15891 "src/ocaml/preprocess/parser_raw.ml" +# 15895 "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) = -# 2331 "src/ocaml/preprocess/parser_raw.mly" +# 2335 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, None, _2) ) -# 15899 "src/ocaml/preprocess/parser_raw.ml" +# 15903 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15939,9 +15943,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2333 "src/ocaml/preprocess/parser_raw.mly" +# 2337 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled (fst _3), None, snd _3) ) -# 15945 "src/ocaml/preprocess/parser_raw.ml" +# 15949 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15966,9 +15970,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15972 "src/ocaml/preprocess/parser_raw.ml" +# 15976 "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 @@ -15981,24 +15985,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15987 "src/ocaml/preprocess/parser_raw.ml" +# 15991 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2363 "src/ocaml/preprocess/parser_raw.mly" +# 2367 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15996 "src/ocaml/preprocess/parser_raw.ml" +# 16000 "src/ocaml/preprocess/parser_raw.ml" in -# 2335 "src/ocaml/preprocess/parser_raw.mly" +# 2339 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled (fst _2), None, snd _2) ) -# 16002 "src/ocaml/preprocess/parser_raw.ml" +# 16006 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16024,17 +16028,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.pattern) = Obj.magic _2 in let _1 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 784 "src/ocaml/preprocess/parser_raw.mly" (string) -# 16030 "src/ocaml/preprocess/parser_raw.ml" +# 16034 "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) = -# 2337 "src/ocaml/preprocess/parser_raw.mly" +# 2341 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled _1, None, _2) ) -# 16038 "src/ocaml/preprocess/parser_raw.ml" +# 16042 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16057,9 +16061,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2339 "src/ocaml/preprocess/parser_raw.mly" +# 2343 "src/ocaml/preprocess/parser_raw.mly" ( (Nolabel, None, _1) ) -# 16063 "src/ocaml/preprocess/parser_raw.ml" +# 16067 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16082,9 +16086,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern * Parsetree.expression * bool) = -# 2701 "src/ocaml/preprocess/parser_raw.mly" +# 2705 "src/ocaml/preprocess/parser_raw.mly" ( let p,e = _1 in (p,e,false) ) -# 16088 "src/ocaml/preprocess/parser_raw.ml" +# 16092 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16110,9 +16114,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2704 "src/ocaml/preprocess/parser_raw.mly" +# 2708 "src/ocaml/preprocess/parser_raw.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1, true) ) -# 16116 "src/ocaml/preprocess/parser_raw.ml" +# 16120 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16146,15 +16150,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2665 "src/ocaml/preprocess/parser_raw.mly" +# 2669 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16152 "src/ocaml/preprocess/parser_raw.ml" +# 16156 "src/ocaml/preprocess/parser_raw.ml" in -# 2669 "src/ocaml/preprocess/parser_raw.mly" +# 2673 "src/ocaml/preprocess/parser_raw.mly" ( (_1, _2) ) -# 16158 "src/ocaml/preprocess/parser_raw.ml" +# 16162 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16202,16 +16206,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2665 "src/ocaml/preprocess/parser_raw.mly" +# 2669 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16208 "src/ocaml/preprocess/parser_raw.ml" +# 16212 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2671 "src/ocaml/preprocess/parser_raw.mly" +# 2675 "src/ocaml/preprocess/parser_raw.mly" ( let v = _1 in (* PR#7344 *) let t = match _2 with @@ -16224,7 +16228,7 @@ module Tables = struct let patloc = (_startpos__1_, _endpos__2_) in (ghpat ~loc:patloc (Ppat_constraint(v, typ)), mkexp_constraint ~loc:_sloc _4 _2) ) -# 16228 "src/ocaml/preprocess/parser_raw.ml" +# 16232 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16295,24 +16299,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 16299 "src/ocaml/preprocess/parser_raw.ml" +# 16303 "src/ocaml/preprocess/parser_raw.ml" in -# 1092 "src/ocaml/preprocess/parser_raw.mly" +# 1096 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 16304 "src/ocaml/preprocess/parser_raw.ml" +# 16308 "src/ocaml/preprocess/parser_raw.ml" in -# 3442 "src/ocaml/preprocess/parser_raw.mly" +# 3446 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16310 "src/ocaml/preprocess/parser_raw.ml" +# 16314 "src/ocaml/preprocess/parser_raw.ml" in -# 3446 "src/ocaml/preprocess/parser_raw.mly" +# 3450 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 16316 "src/ocaml/preprocess/parser_raw.ml" +# 16320 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__3_ = _startpos_xs_ in @@ -16321,19 +16325,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2665 "src/ocaml/preprocess/parser_raw.mly" +# 2669 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16327 "src/ocaml/preprocess/parser_raw.ml" +# 16331 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2684 "src/ocaml/preprocess/parser_raw.mly" +# 2688 "src/ocaml/preprocess/parser_raw.mly" ( let patloc = (_startpos__1_, _endpos__3_) in (ghpat ~loc:patloc (Ppat_constraint(_1, ghtyp ~loc:(_loc__3_) _3)), _5) ) -# 16337 "src/ocaml/preprocess/parser_raw.ml" +# 16341 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16405,30 +16409,30 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__8_ in let _v : (Parsetree.pattern * Parsetree.expression) = let _4 = -# 2662 "src/ocaml/preprocess/parser_raw.mly" +# 2666 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 16411 "src/ocaml/preprocess/parser_raw.ml" +# 16415 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2665 "src/ocaml/preprocess/parser_raw.mly" +# 2669 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16420 "src/ocaml/preprocess/parser_raw.ml" +# 16424 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__8_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2689 "src/ocaml/preprocess/parser_raw.mly" +# 2693 "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) ) -# 16432 "src/ocaml/preprocess/parser_raw.ml" +# 16436 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16465,9 +16469,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2694 "src/ocaml/preprocess/parser_raw.mly" +# 2698 "src/ocaml/preprocess/parser_raw.mly" ( (_1, _3) ) -# 16471 "src/ocaml/preprocess/parser_raw.ml" +# 16475 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16518,10 +16522,10 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2696 "src/ocaml/preprocess/parser_raw.mly" +# 2700 "src/ocaml/preprocess/parser_raw.mly" ( let loc = (_startpos__1_, _endpos__3_) in (ghpat ~loc (Ppat_constraint(_1, _3)), _5) ) -# 16525 "src/ocaml/preprocess/parser_raw.ml" +# 16529 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16582,36 +16586,36 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16588 "src/ocaml/preprocess/parser_raw.ml" +# 16592 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16597 "src/ocaml/preprocess/parser_raw.ml" +# 16601 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2724 "src/ocaml/preprocess/parser_raw.mly" +# 2728 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 16609 "src/ocaml/preprocess/parser_raw.ml" +# 16613 "src/ocaml/preprocess/parser_raw.ml" in -# 2714 "src/ocaml/preprocess/parser_raw.mly" +# 2718 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16615 "src/ocaml/preprocess/parser_raw.ml" +# 16619 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16641,9 +16645,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 2715 "src/ocaml/preprocess/parser_raw.mly" +# 2719 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 16647 "src/ocaml/preprocess/parser_raw.ml" +# 16651 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16697,41 +16701,41 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16703 "src/ocaml/preprocess/parser_raw.ml" +# 16707 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16712 "src/ocaml/preprocess/parser_raw.ml" +# 16716 "src/ocaml/preprocess/parser_raw.ml" in let ext = -# 4038 "src/ocaml/preprocess/parser_raw.mly" +# 4042 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 16718 "src/ocaml/preprocess/parser_raw.ml" +# 16722 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2724 "src/ocaml/preprocess/parser_raw.mly" +# 2728 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 16729 "src/ocaml/preprocess/parser_raw.ml" +# 16733 "src/ocaml/preprocess/parser_raw.ml" in -# 2714 "src/ocaml/preprocess/parser_raw.mly" +# 2718 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16735 "src/ocaml/preprocess/parser_raw.ml" +# 16739 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16799,18 +16803,18 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16805 "src/ocaml/preprocess/parser_raw.ml" +# 16809 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let attrs1 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16814 "src/ocaml/preprocess/parser_raw.ml" +# 16818 "src/ocaml/preprocess/parser_raw.ml" in let ext = @@ -16819,27 +16823,27 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4040 "src/ocaml/preprocess/parser_raw.mly" +# 4044 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "extension"; None ) -# 16825 "src/ocaml/preprocess/parser_raw.ml" +# 16829 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2724 "src/ocaml/preprocess/parser_raw.mly" +# 2728 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 16837 "src/ocaml/preprocess/parser_raw.ml" +# 16841 "src/ocaml/preprocess/parser_raw.ml" in -# 2714 "src/ocaml/preprocess/parser_raw.mly" +# 2718 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16843 "src/ocaml/preprocess/parser_raw.ml" +# 16847 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16869,9 +16873,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 2715 "src/ocaml/preprocess/parser_raw.mly" +# 2719 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 16875 "src/ocaml/preprocess/parser_raw.ml" +# 16879 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16894,9 +16898,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2367 "src/ocaml/preprocess/parser_raw.mly" +# 2371 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16900 "src/ocaml/preprocess/parser_raw.ml" +# 16904 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16934,24 +16938,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2369 "src/ocaml/preprocess/parser_raw.mly" +# 2373 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_1, _3) ) -# 16940 "src/ocaml/preprocess/parser_raw.ml" +# 16944 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 16949 "src/ocaml/preprocess/parser_raw.ml" +# 16953 "src/ocaml/preprocess/parser_raw.ml" in -# 2370 "src/ocaml/preprocess/parser_raw.mly" +# 2374 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16955 "src/ocaml/preprocess/parser_raw.ml" +# 16959 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16985,15 +16989,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2665 "src/ocaml/preprocess/parser_raw.mly" +# 2669 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16991 "src/ocaml/preprocess/parser_raw.ml" +# 16995 "src/ocaml/preprocess/parser_raw.ml" in -# 2741 "src/ocaml/preprocess/parser_raw.mly" +# 2745 "src/ocaml/preprocess/parser_raw.mly" ( (pat, exp) ) -# 16997 "src/ocaml/preprocess/parser_raw.ml" +# 17001 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17019,9 +17023,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2744 "src/ocaml/preprocess/parser_raw.mly" +# 2748 "src/ocaml/preprocess/parser_raw.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1) ) -# 17025 "src/ocaml/preprocess/parser_raw.ml" +# 17029 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17072,10 +17076,10 @@ module Tables = struct let _startpos = _startpos_pat_ in let _endpos = _endpos_exp_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2746 "src/ocaml/preprocess/parser_raw.mly" +# 2750 "src/ocaml/preprocess/parser_raw.mly" ( let loc = (_startpos_pat_, _endpos_typ_) in (ghpat ~loc (Ppat_constraint(pat, typ)), exp) ) -# 17079 "src/ocaml/preprocess/parser_raw.ml" +# 17083 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17112,9 +17116,9 @@ module Tables = struct let _startpos = _startpos_pat_ in let _endpos = _endpos_exp_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2749 "src/ocaml/preprocess/parser_raw.mly" +# 2753 "src/ocaml/preprocess/parser_raw.mly" ( (pat, exp) ) -# 17118 "src/ocaml/preprocess/parser_raw.ml" +# 17122 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17137,10 +17141,10 @@ module Tables = struct let _startpos = _startpos_body_ in let _endpos = _endpos_body_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = -# 2753 "src/ocaml/preprocess/parser_raw.mly" +# 2757 "src/ocaml/preprocess/parser_raw.mly" ( let let_pat, let_exp = body in let_pat, let_exp, [] ) -# 17144 "src/ocaml/preprocess/parser_raw.ml" +# 17148 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17172,9 +17176,9 @@ module Tables = struct } = _menhir_stack in let body : (Parsetree.pattern * Parsetree.expression) = Obj.magic body in let _1 : ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17178 "src/ocaml/preprocess/parser_raw.ml" +# 17182 "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 @@ -17185,22 +17189,22 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17191 "src/ocaml/preprocess/parser_raw.ml" +# 17195 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_body_ in let _symbolstartpos = _startpos_bindings_ in let _sloc = (_symbolstartpos, _endpos) in -# 2756 "src/ocaml/preprocess/parser_raw.mly" +# 2760 "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 ) -# 17204 "src/ocaml/preprocess/parser_raw.ml" +# 17208 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17218,7 +17222,7 @@ module Tables = struct let _v : (Parsetree.class_expr Parsetree.class_infos list) = # 211 "" ( [] ) -# 17222 "src/ocaml/preprocess/parser_raw.ml" +# 17226 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17282,9 +17286,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17288 "src/ocaml/preprocess/parser_raw.ml" +# 17292 "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 @@ -17297,9 +17301,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17303 "src/ocaml/preprocess/parser_raw.ml" +# 17307 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17309,24 +17313,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17315 "src/ocaml/preprocess/parser_raw.ml" +# 17319 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17323 "src/ocaml/preprocess/parser_raw.ml" +# 17327 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1963 "src/ocaml/preprocess/parser_raw.mly" +# 1967 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17334,13 +17338,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs ) -# 17338 "src/ocaml/preprocess/parser_raw.ml" +# 17342 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17344 "src/ocaml/preprocess/parser_raw.ml" +# 17348 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17358,7 +17362,7 @@ module Tables = struct let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 17362 "src/ocaml/preprocess/parser_raw.ml" +# 17366 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17429,9 +17433,9 @@ module Tables = struct let cty : (Parsetree.class_type) = Obj.magic cty in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17435 "src/ocaml/preprocess/parser_raw.ml" +# 17439 "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 @@ -17444,9 +17448,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17450 "src/ocaml/preprocess/parser_raw.ml" +# 17454 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17456,24 +17460,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17462 "src/ocaml/preprocess/parser_raw.ml" +# 17466 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17470 "src/ocaml/preprocess/parser_raw.ml" +# 17474 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2262 "src/ocaml/preprocess/parser_raw.mly" +# 2266 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17481,13 +17485,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs ) -# 17485 "src/ocaml/preprocess/parser_raw.ml" +# 17489 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17491 "src/ocaml/preprocess/parser_raw.ml" +# 17495 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17505,7 +17509,7 @@ module Tables = struct let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 17509 "src/ocaml/preprocess/parser_raw.ml" +# 17513 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17576,9 +17580,9 @@ module Tables = struct let csig : (Parsetree.class_type) = Obj.magic csig in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17582 "src/ocaml/preprocess/parser_raw.ml" +# 17586 "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 @@ -17591,9 +17595,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17597 "src/ocaml/preprocess/parser_raw.ml" +# 17601 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17603,24 +17607,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17609 "src/ocaml/preprocess/parser_raw.ml" +# 17613 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17617 "src/ocaml/preprocess/parser_raw.ml" +# 17621 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2301 "src/ocaml/preprocess/parser_raw.mly" +# 2305 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17628,13 +17632,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs ) -# 17632 "src/ocaml/preprocess/parser_raw.ml" +# 17636 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17638 "src/ocaml/preprocess/parser_raw.ml" +# 17642 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17652,7 +17656,7 @@ module Tables = struct let _v : (Parsetree.module_binding list) = # 211 "" ( [] ) -# 17656 "src/ocaml/preprocess/parser_raw.ml" +# 17660 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17713,9 +17717,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17719 "src/ocaml/preprocess/parser_raw.ml" +# 17723 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17725,24 +17729,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17731 "src/ocaml/preprocess/parser_raw.ml" +# 17735 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17739 "src/ocaml/preprocess/parser_raw.ml" +# 17743 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1619 "src/ocaml/preprocess/parser_raw.mly" +# 1623 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in @@ -17750,13 +17754,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Mb.mk name body ~attrs ~loc ~text ~docs ) -# 17754 "src/ocaml/preprocess/parser_raw.ml" +# 17758 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17760 "src/ocaml/preprocess/parser_raw.ml" +# 17764 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17774,7 +17778,7 @@ module Tables = struct let _v : (Parsetree.module_declaration list) = # 211 "" ( [] ) -# 17778 "src/ocaml/preprocess/parser_raw.ml" +# 17782 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17842,9 +17846,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17848 "src/ocaml/preprocess/parser_raw.ml" +# 17852 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17854,24 +17858,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17860 "src/ocaml/preprocess/parser_raw.ml" +# 17864 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17868 "src/ocaml/preprocess/parser_raw.ml" +# 17872 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1904 "src/ocaml/preprocess/parser_raw.mly" +# 1908 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let docs = symbol_docs _sloc in @@ -17879,13 +17883,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Md.mk name mty ~attrs ~loc ~text ~docs ) -# 17883 "src/ocaml/preprocess/parser_raw.ml" +# 17887 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17889 "src/ocaml/preprocess/parser_raw.ml" +# 17893 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17903,7 +17907,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 17907 "src/ocaml/preprocess/parser_raw.ml" +# 17911 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17935,7 +17939,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 17939 "src/ocaml/preprocess/parser_raw.ml" +# 17943 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17953,7 +17957,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 17957 "src/ocaml/preprocess/parser_raw.ml" +# 17961 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18018,9 +18022,9 @@ module Tables = struct 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 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 18024 "src/ocaml/preprocess/parser_raw.ml" +# 18028 "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 @@ -18033,9 +18037,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18039 "src/ocaml/preprocess/parser_raw.ml" +# 18043 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18044,18 +18048,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18048 "src/ocaml/preprocess/parser_raw.ml" +# 18052 "src/ocaml/preprocess/parser_raw.ml" in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1078 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 18053 "src/ocaml/preprocess/parser_raw.ml" +# 18057 "src/ocaml/preprocess/parser_raw.ml" in -# 3157 "src/ocaml/preprocess/parser_raw.mly" +# 3161 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18059 "src/ocaml/preprocess/parser_raw.ml" +# 18063 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -18064,24 +18068,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18070 "src/ocaml/preprocess/parser_raw.ml" +# 18074 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18078 "src/ocaml/preprocess/parser_raw.ml" +# 18082 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3146 "src/ocaml/preprocess/parser_raw.mly" +# 3150 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -18090,13 +18094,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18094 "src/ocaml/preprocess/parser_raw.ml" +# 18098 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18100 "src/ocaml/preprocess/parser_raw.ml" +# 18104 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18114,7 +18118,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 18118 "src/ocaml/preprocess/parser_raw.ml" +# 18122 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18186,9 +18190,9 @@ module Tables = struct 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 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 18192 "src/ocaml/preprocess/parser_raw.ml" +# 18196 "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 @@ -18201,9 +18205,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18207 "src/ocaml/preprocess/parser_raw.ml" +# 18211 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -18212,26 +18216,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18216 "src/ocaml/preprocess/parser_raw.ml" +# 18220 "src/ocaml/preprocess/parser_raw.ml" in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1078 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 18221 "src/ocaml/preprocess/parser_raw.ml" +# 18225 "src/ocaml/preprocess/parser_raw.ml" in -# 3157 "src/ocaml/preprocess/parser_raw.mly" +# 3161 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18227 "src/ocaml/preprocess/parser_raw.ml" +# 18231 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined3 in -# 3192 "src/ocaml/preprocess/parser_raw.mly" +# 3196 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 18235 "src/ocaml/preprocess/parser_raw.ml" +# 18239 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -18240,24 +18244,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18246 "src/ocaml/preprocess/parser_raw.ml" +# 18250 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18254 "src/ocaml/preprocess/parser_raw.ml" +# 18258 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3146 "src/ocaml/preprocess/parser_raw.mly" +# 3150 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -18266,13 +18270,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18270 "src/ocaml/preprocess/parser_raw.ml" +# 18274 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18276 "src/ocaml/preprocess/parser_raw.ml" +# 18280 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18290,7 +18294,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 18294 "src/ocaml/preprocess/parser_raw.ml" +# 18298 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18322,7 +18326,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 18326 "src/ocaml/preprocess/parser_raw.ml" +# 18330 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18340,7 +18344,7 @@ module Tables = struct let _v : (Parsetree.signature_item list list) = # 211 "" ( [] ) -# 18344 "src/ocaml/preprocess/parser_raw.ml" +# 18348 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18373,21 +18377,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1000 "src/ocaml/preprocess/parser_raw.mly" +# 1004 "src/ocaml/preprocess/parser_raw.mly" ( text_sig _startpos ) -# 18379 "src/ocaml/preprocess/parser_raw.ml" +# 18383 "src/ocaml/preprocess/parser_raw.ml" in -# 1761 "src/ocaml/preprocess/parser_raw.mly" +# 1765 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18385 "src/ocaml/preprocess/parser_raw.ml" +# 18389 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18391 "src/ocaml/preprocess/parser_raw.ml" +# 18395 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18420,21 +18424,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 998 "src/ocaml/preprocess/parser_raw.mly" +# 1002 "src/ocaml/preprocess/parser_raw.mly" ( text_sig _startpos @ [_1] ) -# 18426 "src/ocaml/preprocess/parser_raw.ml" +# 18430 "src/ocaml/preprocess/parser_raw.ml" in -# 1761 "src/ocaml/preprocess/parser_raw.mly" +# 1765 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18432 "src/ocaml/preprocess/parser_raw.ml" +# 18436 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18438 "src/ocaml/preprocess/parser_raw.ml" +# 18442 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18452,7 +18456,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 18456 "src/ocaml/preprocess/parser_raw.ml" +# 18460 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18485,40 +18489,40 @@ module Tables = struct let _1 = let ys = let items = -# 1060 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 18491 "src/ocaml/preprocess/parser_raw.ml" +# 18495 "src/ocaml/preprocess/parser_raw.ml" in -# 1502 "src/ocaml/preprocess/parser_raw.mly" +# 1506 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 18496 "src/ocaml/preprocess/parser_raw.ml" +# 18500 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _startpos = _startpos__1_ in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1000 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos ) -# 18504 "src/ocaml/preprocess/parser_raw.ml" +# 18508 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 18510 "src/ocaml/preprocess/parser_raw.ml" +# 18514 "src/ocaml/preprocess/parser_raw.ml" in -# 1518 "src/ocaml/preprocess/parser_raw.mly" +# 1522 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18516 "src/ocaml/preprocess/parser_raw.ml" +# 18520 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18522 "src/ocaml/preprocess/parser_raw.ml" +# 18526 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18570,70 +18574,70 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18576 "src/ocaml/preprocess/parser_raw.ml" +# 18580 "src/ocaml/preprocess/parser_raw.ml" in -# 1509 "src/ocaml/preprocess/parser_raw.mly" +# 1513 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 18581 "src/ocaml/preprocess/parser_raw.ml" +# 18585 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 998 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18589 "src/ocaml/preprocess/parser_raw.ml" +# 18593 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1013 "src/ocaml/preprocess/parser_raw.mly" +# 1017 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 18599 "src/ocaml/preprocess/parser_raw.ml" +# 18603 "src/ocaml/preprocess/parser_raw.ml" in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 18605 "src/ocaml/preprocess/parser_raw.ml" +# 18609 "src/ocaml/preprocess/parser_raw.ml" in -# 1502 "src/ocaml/preprocess/parser_raw.mly" +# 1506 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 18611 "src/ocaml/preprocess/parser_raw.ml" +# 18615 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _startpos = _startpos__1_ in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1000 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos ) -# 18619 "src/ocaml/preprocess/parser_raw.ml" +# 18623 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 18625 "src/ocaml/preprocess/parser_raw.ml" +# 18629 "src/ocaml/preprocess/parser_raw.ml" in -# 1518 "src/ocaml/preprocess/parser_raw.mly" +# 1522 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18631 "src/ocaml/preprocess/parser_raw.ml" +# 18635 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18637 "src/ocaml/preprocess/parser_raw.ml" +# 18641 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18666,21 +18670,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 998 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18672 "src/ocaml/preprocess/parser_raw.ml" +# 18676 "src/ocaml/preprocess/parser_raw.ml" in -# 1518 "src/ocaml/preprocess/parser_raw.mly" +# 1522 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18678 "src/ocaml/preprocess/parser_raw.ml" +# 18682 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18684 "src/ocaml/preprocess/parser_raw.ml" +# 18688 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18698,7 +18702,7 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = # 211 "" ( [] ) -# 18702 "src/ocaml/preprocess/parser_raw.ml" +# 18706 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18730,15 +18734,15 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = let x = let _startpos = _startpos__1_ in -# 1008 "src/ocaml/preprocess/parser_raw.mly" +# 1012 "src/ocaml/preprocess/parser_raw.mly" ( text_csig _startpos @ [_1] ) -# 18736 "src/ocaml/preprocess/parser_raw.ml" +# 18740 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18742 "src/ocaml/preprocess/parser_raw.ml" +# 18746 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18756,7 +18760,7 @@ module Tables = struct let _v : (Parsetree.class_field list list) = # 211 "" ( [] ) -# 18760 "src/ocaml/preprocess/parser_raw.ml" +# 18764 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18788,15 +18792,15 @@ module Tables = struct let _v : (Parsetree.class_field list list) = let x = let _startpos = _startpos__1_ in -# 1006 "src/ocaml/preprocess/parser_raw.mly" +# 1010 "src/ocaml/preprocess/parser_raw.mly" ( text_cstr _startpos @ [_1] ) -# 18794 "src/ocaml/preprocess/parser_raw.ml" +# 18798 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18800 "src/ocaml/preprocess/parser_raw.ml" +# 18804 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18814,7 +18818,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 18818 "src/ocaml/preprocess/parser_raw.ml" +# 18822 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18846,15 +18850,15 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = let x = let _startpos = _startpos__1_ in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 998 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18852 "src/ocaml/preprocess/parser_raw.ml" +# 18856 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18858 "src/ocaml/preprocess/parser_raw.ml" +# 18862 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18872,7 +18876,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = # 211 "" ( [] ) -# 18876 "src/ocaml/preprocess/parser_raw.ml" +# 18880 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18905,32 +18909,32 @@ module Tables = struct let _1 = let x = let _1 = -# 1060 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 18911 "src/ocaml/preprocess/parser_raw.ml" +# 18915 "src/ocaml/preprocess/parser_raw.ml" in -# 1292 "src/ocaml/preprocess/parser_raw.mly" +# 1296 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18916 "src/ocaml/preprocess/parser_raw.ml" +# 18920 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 18922 "src/ocaml/preprocess/parser_raw.ml" +# 18926 "src/ocaml/preprocess/parser_raw.ml" in -# 1304 "src/ocaml/preprocess/parser_raw.mly" +# 1308 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18928 "src/ocaml/preprocess/parser_raw.ml" +# 18932 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18934 "src/ocaml/preprocess/parser_raw.ml" +# 18938 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18982,58 +18986,58 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18988 "src/ocaml/preprocess/parser_raw.ml" +# 18992 "src/ocaml/preprocess/parser_raw.ml" in -# 1509 "src/ocaml/preprocess/parser_raw.mly" +# 1513 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 18993 "src/ocaml/preprocess/parser_raw.ml" +# 18997 "src/ocaml/preprocess/parser_raw.ml" in -# 1004 "src/ocaml/preprocess/parser_raw.mly" +# 1008 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 18999 "src/ocaml/preprocess/parser_raw.ml" +# 19003 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1002 "src/ocaml/preprocess/parser_raw.mly" +# 1006 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19007 "src/ocaml/preprocess/parser_raw.ml" +# 19011 "src/ocaml/preprocess/parser_raw.ml" in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 19013 "src/ocaml/preprocess/parser_raw.ml" +# 19017 "src/ocaml/preprocess/parser_raw.ml" in -# 1292 "src/ocaml/preprocess/parser_raw.mly" +# 1296 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19019 "src/ocaml/preprocess/parser_raw.ml" +# 19023 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 19025 "src/ocaml/preprocess/parser_raw.ml" +# 19029 "src/ocaml/preprocess/parser_raw.ml" in -# 1304 "src/ocaml/preprocess/parser_raw.mly" +# 1308 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19031 "src/ocaml/preprocess/parser_raw.ml" +# 19035 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19037 "src/ocaml/preprocess/parser_raw.ml" +# 19041 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19065,27 +19069,27 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = let x = let _1 = let _1 = -# 1004 "src/ocaml/preprocess/parser_raw.mly" +# 1008 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 19071 "src/ocaml/preprocess/parser_raw.ml" +# 19075 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1002 "src/ocaml/preprocess/parser_raw.mly" +# 1006 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19077 "src/ocaml/preprocess/parser_raw.ml" +# 19081 "src/ocaml/preprocess/parser_raw.ml" in -# 1304 "src/ocaml/preprocess/parser_raw.mly" +# 1308 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19083 "src/ocaml/preprocess/parser_raw.ml" +# 19087 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19089 "src/ocaml/preprocess/parser_raw.ml" +# 19093 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19120,29 +19124,29 @@ module Tables = struct let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1013 "src/ocaml/preprocess/parser_raw.mly" +# 1017 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 19127 "src/ocaml/preprocess/parser_raw.ml" +# 19131 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1002 "src/ocaml/preprocess/parser_raw.mly" +# 1006 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19134 "src/ocaml/preprocess/parser_raw.ml" +# 19138 "src/ocaml/preprocess/parser_raw.ml" in -# 1304 "src/ocaml/preprocess/parser_raw.mly" +# 1308 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19140 "src/ocaml/preprocess/parser_raw.ml" +# 19144 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19146 "src/ocaml/preprocess/parser_raw.ml" +# 19150 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19181,7 +19185,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 124 "" ( None ) -# 19185 "src/ocaml/preprocess/parser_raw.ml" +# 19189 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -19189,9 +19193,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19195 "src/ocaml/preprocess/parser_raw.ml" +# 19199 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19199,7 +19203,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3032 "src/ocaml/preprocess/parser_raw.mly" +# 3036 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19213,13 +19217,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19217 "src/ocaml/preprocess/parser_raw.ml" +# 19221 "src/ocaml/preprocess/parser_raw.ml" in -# 1229 "src/ocaml/preprocess/parser_raw.mly" +# 1233 "src/ocaml/preprocess/parser_raw.mly" ( [x], None ) -# 19223 "src/ocaml/preprocess/parser_raw.ml" +# 19227 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19265,7 +19269,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 126 "" ( Some x ) -# 19269 "src/ocaml/preprocess/parser_raw.ml" +# 19273 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -19273,9 +19277,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19279 "src/ocaml/preprocess/parser_raw.ml" +# 19283 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19283,7 +19287,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3032 "src/ocaml/preprocess/parser_raw.mly" +# 3036 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19297,13 +19301,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19301 "src/ocaml/preprocess/parser_raw.ml" +# 19305 "src/ocaml/preprocess/parser_raw.ml" in -# 1229 "src/ocaml/preprocess/parser_raw.mly" +# 1233 "src/ocaml/preprocess/parser_raw.mly" ( [x], None ) -# 19307 "src/ocaml/preprocess/parser_raw.ml" +# 19311 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19366,9 +19370,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19372 "src/ocaml/preprocess/parser_raw.ml" +# 19376 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19376,7 +19380,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3032 "src/ocaml/preprocess/parser_raw.mly" +# 3036 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19390,13 +19394,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19394 "src/ocaml/preprocess/parser_raw.ml" +# 19398 "src/ocaml/preprocess/parser_raw.ml" in -# 1231 "src/ocaml/preprocess/parser_raw.mly" +# 1235 "src/ocaml/preprocess/parser_raw.mly" ( [x], Some y ) -# 19400 "src/ocaml/preprocess/parser_raw.ml" +# 19404 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19452,9 +19456,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19458 "src/ocaml/preprocess/parser_raw.ml" +# 19462 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19462,7 +19466,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3032 "src/ocaml/preprocess/parser_raw.mly" +# 3036 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19476,14 +19480,14 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19480 "src/ocaml/preprocess/parser_raw.ml" +# 19484 "src/ocaml/preprocess/parser_raw.ml" in -# 1235 "src/ocaml/preprocess/parser_raw.mly" +# 1239 "src/ocaml/preprocess/parser_raw.mly" ( let xs, y = tail in x :: xs, y ) -# 19487 "src/ocaml/preprocess/parser_raw.ml" +# 19491 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19543,9 +19547,9 @@ module Tables = struct let _v : (Ast_helper.let_bindings) = let _5 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19549 "src/ocaml/preprocess/parser_raw.ml" +# 19553 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -19553,23 +19557,23 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19559 "src/ocaml/preprocess/parser_raw.ml" +# 19563 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 19565 "src/ocaml/preprocess/parser_raw.ml" +# 19569 "src/ocaml/preprocess/parser_raw.ml" in let _loc__4_ = (_startpos__4_, _endpos__4_) in -# 4078 "src/ocaml/preprocess/parser_raw.mly" +# 4082 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, attr) = _2 in mklbs ext _3 (mklb ~loc:_loc__4_ true _4 (attr@_5)) ) -# 19573 "src/ocaml/preprocess/parser_raw.ml" +# 19577 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19592,9 +19596,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Ast_helper.let_bindings) = -# 4082 "src/ocaml/preprocess/parser_raw.mly" +# 4086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19598 "src/ocaml/preprocess/parser_raw.ml" +# 19602 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19624,9 +19628,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 4083 "src/ocaml/preprocess/parser_raw.mly" +# 4087 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 19630 "src/ocaml/preprocess/parser_raw.ml" +# 19634 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19663,9 +19667,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.case) = -# 2782 "src/ocaml/preprocess/parser_raw.mly" +# 2786 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 (merloc _endpos__2_ _3) ) -# 19669 "src/ocaml/preprocess/parser_raw.ml" +# 19673 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19716,9 +19720,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.case) = -# 2784 "src/ocaml/preprocess/parser_raw.mly" +# 2788 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 ~guard:(merloc _endpos__2_ _3) (merloc _endpos__4_ _5) ) -# 19722 "src/ocaml/preprocess/parser_raw.ml" +# 19726 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19756,10 +19760,10 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.case) = let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2786 "src/ocaml/preprocess/parser_raw.mly" +# 2790 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 (merloc _endpos__2_ (Exp.unreachable ~loc:(make_loc _loc__3_) ())) ) -# 19763 "src/ocaml/preprocess/parser_raw.ml" +# 19767 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19820,9 +19824,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 19826 "src/ocaml/preprocess/parser_raw.ml" +# 19830 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -19831,49 +19835,49 @@ module Tables = struct let _6 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19837 "src/ocaml/preprocess/parser_raw.ml" +# 19841 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19846 "src/ocaml/preprocess/parser_raw.ml" +# 19850 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3460 "src/ocaml/preprocess/parser_raw.mly" +# 3464 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19855 "src/ocaml/preprocess/parser_raw.ml" +# 19859 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19862 "src/ocaml/preprocess/parser_raw.ml" +# 19866 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19870 "src/ocaml/preprocess/parser_raw.ml" +# 19874 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3670 "src/ocaml/preprocess/parser_raw.mly" +# 3674 "src/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__4_ with | Some _ as info_before_semi -> info_before_semi @@ -19881,13 +19885,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 19885 "src/ocaml/preprocess/parser_raw.ml" +# 19889 "src/ocaml/preprocess/parser_raw.ml" in -# 3651 "src/ocaml/preprocess/parser_raw.mly" +# 3655 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = tail in (head :: f, c) ) -# 19891 "src/ocaml/preprocess/parser_raw.ml" +# 19895 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19928,15 +19932,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3681 "src/ocaml/preprocess/parser_raw.mly" +# 3685 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 19934 "src/ocaml/preprocess/parser_raw.ml" +# 19938 "src/ocaml/preprocess/parser_raw.ml" in -# 3651 "src/ocaml/preprocess/parser_raw.mly" +# 3655 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = tail in (head :: f, c) ) -# 19940 "src/ocaml/preprocess/parser_raw.ml" +# 19944 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19990,9 +19994,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 19996 "src/ocaml/preprocess/parser_raw.ml" +# 20000 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20001,49 +20005,49 @@ module Tables = struct let _6 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20007 "src/ocaml/preprocess/parser_raw.ml" +# 20011 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20016 "src/ocaml/preprocess/parser_raw.ml" +# 20020 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3460 "src/ocaml/preprocess/parser_raw.mly" +# 3464 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20025 "src/ocaml/preprocess/parser_raw.ml" +# 20029 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20032 "src/ocaml/preprocess/parser_raw.ml" +# 20036 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20040 "src/ocaml/preprocess/parser_raw.ml" +# 20044 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3670 "src/ocaml/preprocess/parser_raw.mly" +# 3674 "src/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__4_ with | Some _ as info_before_semi -> info_before_semi @@ -20051,13 +20055,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20055 "src/ocaml/preprocess/parser_raw.ml" +# 20059 "src/ocaml/preprocess/parser_raw.ml" in -# 3654 "src/ocaml/preprocess/parser_raw.mly" +# 3658 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20061 "src/ocaml/preprocess/parser_raw.ml" +# 20065 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20091,15 +20095,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3681 "src/ocaml/preprocess/parser_raw.mly" +# 3685 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20097 "src/ocaml/preprocess/parser_raw.ml" +# 20101 "src/ocaml/preprocess/parser_raw.ml" in -# 3654 "src/ocaml/preprocess/parser_raw.mly" +# 3658 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20103 "src/ocaml/preprocess/parser_raw.ml" +# 20107 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20139,9 +20143,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20145 "src/ocaml/preprocess/parser_raw.ml" +# 20149 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20150,50 +20154,50 @@ module Tables = struct let _4 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20156 "src/ocaml/preprocess/parser_raw.ml" +# 20160 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3460 "src/ocaml/preprocess/parser_raw.mly" +# 3464 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20165 "src/ocaml/preprocess/parser_raw.ml" +# 20169 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20172 "src/ocaml/preprocess/parser_raw.ml" +# 20176 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20180 "src/ocaml/preprocess/parser_raw.ml" +# 20184 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3663 "src/ocaml/preprocess/parser_raw.mly" +# 3667 "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 ) -# 20191 "src/ocaml/preprocess/parser_raw.ml" +# 20195 "src/ocaml/preprocess/parser_raw.ml" in -# 3657 "src/ocaml/preprocess/parser_raw.mly" +# 3661 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20197 "src/ocaml/preprocess/parser_raw.ml" +# 20201 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20220,15 +20224,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3681 "src/ocaml/preprocess/parser_raw.mly" +# 3685 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20226 "src/ocaml/preprocess/parser_raw.ml" +# 20230 "src/ocaml/preprocess/parser_raw.ml" in -# 3657 "src/ocaml/preprocess/parser_raw.mly" +# 3661 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20232 "src/ocaml/preprocess/parser_raw.ml" +# 20236 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20251,9 +20255,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.object_field list * Asttypes.closed_flag) = -# 3659 "src/ocaml/preprocess/parser_raw.mly" +# 3663 "src/ocaml/preprocess/parser_raw.mly" ( [], Open ) -# 20257 "src/ocaml/preprocess/parser_raw.ml" +# 20261 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20298,9 +20302,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20304 "src/ocaml/preprocess/parser_raw.ml" +# 20308 "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 @@ -20311,41 +20315,41 @@ module Tables = struct Parsetree.attributes) = let ty = let _1 = _1_inlined2 in -# 3456 "src/ocaml/preprocess/parser_raw.mly" +# 3460 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20317 "src/ocaml/preprocess/parser_raw.ml" +# 20321 "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 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20325 "src/ocaml/preprocess/parser_raw.ml" +# 20329 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20333 "src/ocaml/preprocess/parser_raw.ml" +# 20337 "src/ocaml/preprocess/parser_raw.ml" in let attrs = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20339 "src/ocaml/preprocess/parser_raw.ml" +# 20343 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3930 "src/ocaml/preprocess/parser_raw.mly" +# 3934 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20344 "src/ocaml/preprocess/parser_raw.ml" +# 20348 "src/ocaml/preprocess/parser_raw.ml" in -# 2107 "src/ocaml/preprocess/parser_raw.mly" +# 2111 "src/ocaml/preprocess/parser_raw.mly" ( (label, private_, Cfk_virtual ty), attrs ) -# 20349 "src/ocaml/preprocess/parser_raw.ml" +# 20353 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20383,9 +20387,9 @@ module Tables = struct } = _menhir_stack in let _5 : (Parsetree.expression) = Obj.magic _5 in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20389 "src/ocaml/preprocess/parser_raw.ml" +# 20393 "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 @@ -20396,36 +20400,36 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20402 "src/ocaml/preprocess/parser_raw.ml" +# 20406 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20410 "src/ocaml/preprocess/parser_raw.ml" +# 20414 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20416 "src/ocaml/preprocess/parser_raw.ml" +# 20420 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20421 "src/ocaml/preprocess/parser_raw.ml" +# 20425 "src/ocaml/preprocess/parser_raw.ml" in -# 2109 "src/ocaml/preprocess/parser_raw.mly" +# 2113 "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 ) -# 20429 "src/ocaml/preprocess/parser_raw.ml" +# 20433 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20469,9 +20473,9 @@ module Tables = struct } = _menhir_stack in let _5 : (Parsetree.expression) = Obj.magic _5 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20475 "src/ocaml/preprocess/parser_raw.ml" +# 20479 "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 @@ -20483,39 +20487,39 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20489 "src/ocaml/preprocess/parser_raw.ml" +# 20493 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20497 "src/ocaml/preprocess/parser_raw.ml" +# 20501 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20505 "src/ocaml/preprocess/parser_raw.ml" +# 20509 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 20511 "src/ocaml/preprocess/parser_raw.ml" +# 20515 "src/ocaml/preprocess/parser_raw.ml" in -# 2109 "src/ocaml/preprocess/parser_raw.mly" +# 2113 "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 ) -# 20519 "src/ocaml/preprocess/parser_raw.ml" +# 20523 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20574,9 +20578,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20580 "src/ocaml/preprocess/parser_raw.ml" +# 20584 "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 @@ -20587,45 +20591,45 @@ module Tables = struct Parsetree.attributes) = let _6 = let _1 = _1_inlined2 in -# 3456 "src/ocaml/preprocess/parser_raw.mly" +# 3460 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20593 "src/ocaml/preprocess/parser_raw.ml" +# 20597 "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 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20602 "src/ocaml/preprocess/parser_raw.ml" +# 20606 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20610 "src/ocaml/preprocess/parser_raw.ml" +# 20614 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20616 "src/ocaml/preprocess/parser_raw.ml" +# 20620 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20621 "src/ocaml/preprocess/parser_raw.ml" +# 20625 "src/ocaml/preprocess/parser_raw.ml" in -# 2115 "src/ocaml/preprocess/parser_raw.mly" +# 2119 "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 ) -# 20629 "src/ocaml/preprocess/parser_raw.ml" +# 20633 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20690,9 +20694,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20696 "src/ocaml/preprocess/parser_raw.ml" +# 20700 "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 @@ -20704,48 +20708,48 @@ module Tables = struct Parsetree.attributes) = let _6 = let _1 = _1_inlined3 in -# 3456 "src/ocaml/preprocess/parser_raw.mly" +# 3460 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20710 "src/ocaml/preprocess/parser_raw.ml" +# 20714 "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 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20719 "src/ocaml/preprocess/parser_raw.ml" +# 20723 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20727 "src/ocaml/preprocess/parser_raw.ml" +# 20731 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20735 "src/ocaml/preprocess/parser_raw.ml" +# 20739 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 20741 "src/ocaml/preprocess/parser_raw.ml" +# 20745 "src/ocaml/preprocess/parser_raw.ml" in -# 2115 "src/ocaml/preprocess/parser_raw.mly" +# 2119 "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 ) -# 20749 "src/ocaml/preprocess/parser_raw.ml" +# 20753 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20825,9 +20829,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20831 "src/ocaml/preprocess/parser_raw.ml" +# 20835 "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 @@ -20836,38 +20840,38 @@ module Tables = struct let _endpos = _endpos__11_ in let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) * Parsetree.attributes) = let _7 = -# 2662 "src/ocaml/preprocess/parser_raw.mly" +# 2666 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 20842 "src/ocaml/preprocess/parser_raw.ml" +# 20846 "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 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20850 "src/ocaml/preprocess/parser_raw.ml" +# 20854 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20858 "src/ocaml/preprocess/parser_raw.ml" +# 20862 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20865 "src/ocaml/preprocess/parser_raw.ml" +# 20869 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20871 "src/ocaml/preprocess/parser_raw.ml" +# 20875 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__11_ in @@ -20883,7 +20887,7 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2121 "src/ocaml/preprocess/parser_raw.mly" +# 2125 "src/ocaml/preprocess/parser_raw.mly" ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in let poly_exp = let exp, poly = @@ -20894,7 +20898,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 20898 "src/ocaml/preprocess/parser_raw.ml" +# 20902 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20980,9 +20984,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20986 "src/ocaml/preprocess/parser_raw.ml" +# 20990 "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 @@ -20992,41 +20996,41 @@ module Tables = struct let _endpos = _endpos__11_ in let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) * Parsetree.attributes) = let _7 = -# 2662 "src/ocaml/preprocess/parser_raw.mly" +# 2666 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 20998 "src/ocaml/preprocess/parser_raw.ml" +# 21002 "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 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21006 "src/ocaml/preprocess/parser_raw.ml" +# 21010 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21014 "src/ocaml/preprocess/parser_raw.ml" +# 21018 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21023 "src/ocaml/preprocess/parser_raw.ml" +# 21027 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 21030 "src/ocaml/preprocess/parser_raw.ml" +# 21034 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__11_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -21041,7 +21045,7 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2121 "src/ocaml/preprocess/parser_raw.mly" +# 2125 "src/ocaml/preprocess/parser_raw.mly" ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in let poly_exp = let exp, poly = @@ -21052,7 +21056,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21056 "src/ocaml/preprocess/parser_raw.ml" +# 21060 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21071,17 +21075,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21077 "src/ocaml/preprocess/parser_raw.ml" +# 21081 "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) = -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21085 "src/ocaml/preprocess/parser_raw.ml" +# 21089 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21112,9 +21116,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21118 "src/ocaml/preprocess/parser_raw.ml" +# 21122 "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 @@ -21122,9 +21126,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3785 "src/ocaml/preprocess/parser_raw.mly" +# 3789 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21128 "src/ocaml/preprocess/parser_raw.ml" +# 21132 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21143,17 +21147,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21149 "src/ocaml/preprocess/parser_raw.ml" +# 21153 "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) = -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21157 "src/ocaml/preprocess/parser_raw.ml" +# 21161 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21184,9 +21188,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21190 "src/ocaml/preprocess/parser_raw.ml" +# 21194 "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 @@ -21194,9 +21198,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3785 "src/ocaml/preprocess/parser_raw.mly" +# 3789 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21200 "src/ocaml/preprocess/parser_raw.ml" +# 21204 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21219,14 +21223,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = let _1 = -# 3824 "src/ocaml/preprocess/parser_raw.mly" +# 3828 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21225 "src/ocaml/preprocess/parser_raw.ml" +# 21229 "src/ocaml/preprocess/parser_raw.ml" in -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21230 "src/ocaml/preprocess/parser_raw.ml" +# 21234 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21264,20 +21268,20 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Longident.t) = let _1 = let _1 = -# 3764 "src/ocaml/preprocess/parser_raw.mly" +# 3768 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 21270 "src/ocaml/preprocess/parser_raw.ml" +# 21274 "src/ocaml/preprocess/parser_raw.ml" in -# 3824 "src/ocaml/preprocess/parser_raw.mly" +# 3828 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21275 "src/ocaml/preprocess/parser_raw.ml" +# 21279 "src/ocaml/preprocess/parser_raw.ml" in -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21281 "src/ocaml/preprocess/parser_raw.ml" +# 21285 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21300,14 +21304,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = let _1 = -# 3824 "src/ocaml/preprocess/parser_raw.mly" +# 3828 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21306 "src/ocaml/preprocess/parser_raw.ml" +# 21310 "src/ocaml/preprocess/parser_raw.ml" in -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21311 "src/ocaml/preprocess/parser_raw.ml" +# 21315 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21346,15 +21350,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let _1 = _1_inlined1 in -# 3824 "src/ocaml/preprocess/parser_raw.mly" +# 3828 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21352 "src/ocaml/preprocess/parser_raw.ml" +# 21356 "src/ocaml/preprocess/parser_raw.ml" in -# 3785 "src/ocaml/preprocess/parser_raw.mly" +# 3789 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21358 "src/ocaml/preprocess/parser_raw.ml" +# 21362 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21407,20 +21411,20 @@ module Tables = struct let _v : (Longident.t) = let _3 = let (_2, _1) = (_2_inlined1, _1_inlined1) in let _1 = -# 3764 "src/ocaml/preprocess/parser_raw.mly" +# 3768 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 21413 "src/ocaml/preprocess/parser_raw.ml" +# 21417 "src/ocaml/preprocess/parser_raw.ml" in -# 3824 "src/ocaml/preprocess/parser_raw.mly" +# 3828 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21418 "src/ocaml/preprocess/parser_raw.ml" +# 21422 "src/ocaml/preprocess/parser_raw.ml" in -# 3785 "src/ocaml/preprocess/parser_raw.mly" +# 3789 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21424 "src/ocaml/preprocess/parser_raw.ml" +# 21428 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21459,15 +21463,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let _1 = _1_inlined1 in -# 3824 "src/ocaml/preprocess/parser_raw.mly" +# 3828 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21465 "src/ocaml/preprocess/parser_raw.ml" +# 21469 "src/ocaml/preprocess/parser_raw.ml" in -# 3785 "src/ocaml/preprocess/parser_raw.mly" +# 3789 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21471 "src/ocaml/preprocess/parser_raw.ml" +# 21475 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21490,9 +21494,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21496 "src/ocaml/preprocess/parser_raw.ml" +# 21500 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21529,9 +21533,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3785 "src/ocaml/preprocess/parser_raw.mly" +# 3789 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21535 "src/ocaml/preprocess/parser_raw.ml" +# 21539 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21550,17 +21554,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21556 "src/ocaml/preprocess/parser_raw.ml" +# 21560 "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) = -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21564 "src/ocaml/preprocess/parser_raw.ml" +# 21568 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21591,9 +21595,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21597 "src/ocaml/preprocess/parser_raw.ml" +# 21601 "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 @@ -21601,9 +21605,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3785 "src/ocaml/preprocess/parser_raw.mly" +# 3789 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21607 "src/ocaml/preprocess/parser_raw.ml" +# 21611 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21622,17 +21626,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21628 "src/ocaml/preprocess/parser_raw.ml" +# 21632 "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) = -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21636 "src/ocaml/preprocess/parser_raw.ml" +# 21640 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21663,9 +21667,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21669 "src/ocaml/preprocess/parser_raw.ml" +# 21673 "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 @@ -21673,9 +21677,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3785 "src/ocaml/preprocess/parser_raw.mly" +# 3789 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21679 "src/ocaml/preprocess/parser_raw.ml" +# 21683 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21698,9 +21702,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21704 "src/ocaml/preprocess/parser_raw.ml" +# 21708 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21737,9 +21741,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3785 "src/ocaml/preprocess/parser_raw.mly" +# 3789 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21743 "src/ocaml/preprocess/parser_raw.ml" +# 21747 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21762,9 +21766,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3800 "src/ocaml/preprocess/parser_raw.mly" +# 3804 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21768 "src/ocaml/preprocess/parser_raw.ml" +# 21772 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21811,9 +21815,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3802 "src/ocaml/preprocess/parser_raw.mly" +# 3806 "src/ocaml/preprocess/parser_raw.mly" ( lapply ~loc:_sloc _1 _3 ) -# 21817 "src/ocaml/preprocess/parser_raw.ml" +# 21821 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21836,9 +21840,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3797 "src/ocaml/preprocess/parser_raw.mly" +# 3801 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21842 "src/ocaml/preprocess/parser_raw.ml" +# 21846 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21868,9 +21872,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = -# 1578 "src/ocaml/preprocess/parser_raw.mly" +# 1582 "src/ocaml/preprocess/parser_raw.mly" ( me ) -# 21874 "src/ocaml/preprocess/parser_raw.ml" +# 21878 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21915,24 +21919,24 @@ module Tables = struct let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1581 "src/ocaml/preprocess/parser_raw.mly" +# 1585 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_constraint(me, mty) ) -# 21921 "src/ocaml/preprocess/parser_raw.ml" +# 21925 "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 -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1037 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 21930 "src/ocaml/preprocess/parser_raw.ml" +# 21934 "src/ocaml/preprocess/parser_raw.ml" in -# 1585 "src/ocaml/preprocess/parser_raw.mly" +# 1589 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21936 "src/ocaml/preprocess/parser_raw.ml" +# 21940 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21963,25 +21967,25 @@ module Tables = struct let _endpos = _endpos_body_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1583 "src/ocaml/preprocess/parser_raw.mly" +# 1587 "src/ocaml/preprocess/parser_raw.mly" ( let (_, arg) = arg_and_pos in Pmod_functor(arg, body) ) -# 21970 "src/ocaml/preprocess/parser_raw.ml" +# 21974 "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 -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1037 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 21979 "src/ocaml/preprocess/parser_raw.ml" +# 21983 "src/ocaml/preprocess/parser_raw.ml" in -# 1585 "src/ocaml/preprocess/parser_raw.mly" +# 1589 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21985 "src/ocaml/preprocess/parser_raw.ml" +# 21989 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22011,9 +22015,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_mty_ in let _v : (Parsetree.module_type) = -# 1828 "src/ocaml/preprocess/parser_raw.mly" +# 1832 "src/ocaml/preprocess/parser_raw.mly" ( mty ) -# 22017 "src/ocaml/preprocess/parser_raw.ml" +# 22021 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22044,25 +22048,25 @@ module Tables = struct let _endpos = _endpos_body_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1831 "src/ocaml/preprocess/parser_raw.mly" +# 1835 "src/ocaml/preprocess/parser_raw.mly" ( let (_, arg) = arg_and_pos in Pmty_functor(arg, body) ) -# 22051 "src/ocaml/preprocess/parser_raw.ml" +# 22055 "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 -# 1035 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 22060 "src/ocaml/preprocess/parser_raw.ml" +# 22064 "src/ocaml/preprocess/parser_raw.ml" in -# 1834 "src/ocaml/preprocess/parser_raw.mly" +# 1838 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22066 "src/ocaml/preprocess/parser_raw.ml" +# 22070 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22108,18 +22112,18 @@ module Tables = struct let _v : (Parsetree.module_expr) = let attrs = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22114 "src/ocaml/preprocess/parser_raw.ml" +# 22118 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1405 "src/ocaml/preprocess/parser_raw.mly" +# 1409 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_structure s) ) -# 22123 "src/ocaml/preprocess/parser_raw.ml" +# 22127 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22172,22 +22176,22 @@ module Tables = struct let _v : (Parsetree.module_expr) = let attrs = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22178 "src/ocaml/preprocess/parser_raw.ml" +# 22182 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_me_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1411 "src/ocaml/preprocess/parser_raw.mly" +# 1415 "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 ) ) -# 22191 "src/ocaml/preprocess/parser_raw.ml" +# 22195 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22210,9 +22214,9 @@ module Tables = struct let _startpos = _startpos_me_ in let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = -# 1417 "src/ocaml/preprocess/parser_raw.mly" +# 1421 "src/ocaml/preprocess/parser_raw.mly" ( me ) -# 22216 "src/ocaml/preprocess/parser_raw.ml" +# 22220 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22242,9 +22246,9 @@ module Tables = struct let _startpos = _startpos_me_ in let _endpos = _endpos_attr_ in let _v : (Parsetree.module_expr) = -# 1419 "src/ocaml/preprocess/parser_raw.mly" +# 1423 "src/ocaml/preprocess/parser_raw.mly" ( Mod.attr me attr ) -# 22248 "src/ocaml/preprocess/parser_raw.ml" +# 22252 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22273,30 +22277,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22279 "src/ocaml/preprocess/parser_raw.ml" +# 22283 "src/ocaml/preprocess/parser_raw.ml" in -# 1423 "src/ocaml/preprocess/parser_raw.mly" +# 1427 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_ident x ) -# 22285 "src/ocaml/preprocess/parser_raw.ml" +# 22289 "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" +# 1037 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22294 "src/ocaml/preprocess/parser_raw.ml" +# 22298 "src/ocaml/preprocess/parser_raw.ml" in -# 1439 "src/ocaml/preprocess/parser_raw.mly" +# 1443 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22300 "src/ocaml/preprocess/parser_raw.ml" +# 22304 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22327,24 +22331,24 @@ module Tables = struct let _endpos = _endpos_me2_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1426 "src/ocaml/preprocess/parser_raw.mly" +# 1430 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_apply(me1, me2) ) -# 22333 "src/ocaml/preprocess/parser_raw.ml" +# 22337 "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 -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1037 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22342 "src/ocaml/preprocess/parser_raw.ml" +# 22346 "src/ocaml/preprocess/parser_raw.ml" in -# 1439 "src/ocaml/preprocess/parser_raw.mly" +# 1443 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22348 "src/ocaml/preprocess/parser_raw.ml" +# 22352 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22386,10 +22390,10 @@ module Tables = struct let _symbolstartpos = _startpos_me1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1429 "src/ocaml/preprocess/parser_raw.mly" +# 1433 "src/ocaml/preprocess/parser_raw.mly" ( (* TODO review mkmod location *) Pmod_apply(me1, mkmod ~loc:_sloc (Pmod_structure [])) ) -# 22393 "src/ocaml/preprocess/parser_raw.ml" +# 22397 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_me1_) in @@ -22397,15 +22401,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1037 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22403 "src/ocaml/preprocess/parser_raw.ml" +# 22407 "src/ocaml/preprocess/parser_raw.ml" in -# 1439 "src/ocaml/preprocess/parser_raw.mly" +# 1443 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22409 "src/ocaml/preprocess/parser_raw.ml" +# 22413 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22429,24 +22433,24 @@ module Tables = struct let _endpos = _endpos_ex_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1433 "src/ocaml/preprocess/parser_raw.mly" +# 1437 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_extension ex ) -# 22435 "src/ocaml/preprocess/parser_raw.ml" +# 22439 "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 -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1037 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22444 "src/ocaml/preprocess/parser_raw.ml" +# 22448 "src/ocaml/preprocess/parser_raw.ml" in -# 1439 "src/ocaml/preprocess/parser_raw.mly" +# 1443 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22450 "src/ocaml/preprocess/parser_raw.ml" +# 22454 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22474,25 +22478,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 1436 "src/ocaml/preprocess/parser_raw.mly" +# 1440 "src/ocaml/preprocess/parser_raw.mly" ( let id = mkrhs Ast_helper.hole_txt _loc in Pmod_extension (id, PStr []) ) -# 22481 "src/ocaml/preprocess/parser_raw.ml" +# 22485 "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" +# 1037 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22490 "src/ocaml/preprocess/parser_raw.ml" +# 22494 "src/ocaml/preprocess/parser_raw.ml" in -# 1439 "src/ocaml/preprocess/parser_raw.mly" +# 1443 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22496 "src/ocaml/preprocess/parser_raw.ml" +# 22500 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22511,17 +22515,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let x : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) -# 22517 "src/ocaml/preprocess/parser_raw.ml" +# 22521 "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) = -# 1388 "src/ocaml/preprocess/parser_raw.mly" +# 1392 "src/ocaml/preprocess/parser_raw.mly" ( Some x ) -# 22525 "src/ocaml/preprocess/parser_raw.ml" +# 22529 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22544,9 +22548,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string option) = -# 1391 "src/ocaml/preprocess/parser_raw.mly" +# 1395 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 22550 "src/ocaml/preprocess/parser_raw.ml" +# 22554 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22604,9 +22608,9 @@ module Tables = struct let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) -# 22610 "src/ocaml/preprocess/parser_raw.ml" +# 22614 "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 @@ -22617,9 +22621,9 @@ module Tables = struct let _v : (Parsetree.module_substitution * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22623 "src/ocaml/preprocess/parser_raw.ml" +# 22627 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -22629,9 +22633,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22635 "src/ocaml/preprocess/parser_raw.ml" +# 22639 "src/ocaml/preprocess/parser_raw.ml" in let uid = @@ -22640,31 +22644,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22646 "src/ocaml/preprocess/parser_raw.ml" +# 22650 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22654 "src/ocaml/preprocess/parser_raw.ml" +# 22658 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1864 "src/ocaml/preprocess/parser_raw.mly" +# 1868 "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 ) -# 22668 "src/ocaml/preprocess/parser_raw.ml" +# 22672 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22710,18 +22714,18 @@ module Tables = struct let _v : (Parsetree.module_type) = let attrs = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22716 "src/ocaml/preprocess/parser_raw.ml" +# 22720 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1710 "src/ocaml/preprocess/parser_raw.mly" +# 1714 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc ~attrs (Pmty_signature s) ) -# 22725 "src/ocaml/preprocess/parser_raw.ml" +# 22729 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22774,22 +22778,22 @@ module Tables = struct let _v : (Parsetree.module_type) = let attrs = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22780 "src/ocaml/preprocess/parser_raw.ml" +# 22784 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_mty_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1718 "src/ocaml/preprocess/parser_raw.mly" +# 1722 "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 ) ) -# 22793 "src/ocaml/preprocess/parser_raw.ml" +# 22797 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22842,18 +22846,18 @@ module Tables = struct let _v : (Parsetree.module_type) = let _4 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22848 "src/ocaml/preprocess/parser_raw.ml" +# 22852 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1724 "src/ocaml/preprocess/parser_raw.mly" +# 1728 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc ~attrs:_4 (Pmty_typeof _5) ) -# 22857 "src/ocaml/preprocess/parser_raw.ml" +# 22861 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22890,9 +22894,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.module_type) = -# 1726 "src/ocaml/preprocess/parser_raw.mly" +# 1730 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 22896 "src/ocaml/preprocess/parser_raw.ml" +# 22900 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22922,9 +22926,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_type) = -# 1732 "src/ocaml/preprocess/parser_raw.mly" +# 1736 "src/ocaml/preprocess/parser_raw.mly" ( Mty.attr _1 _2 ) -# 22928 "src/ocaml/preprocess/parser_raw.ml" +# 22932 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22953,30 +22957,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22959 "src/ocaml/preprocess/parser_raw.ml" +# 22963 "src/ocaml/preprocess/parser_raw.ml" in -# 1735 "src/ocaml/preprocess/parser_raw.mly" +# 1739 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_ident _1 ) -# 22965 "src/ocaml/preprocess/parser_raw.ml" +# 22969 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1035 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 22974 "src/ocaml/preprocess/parser_raw.ml" +# 22978 "src/ocaml/preprocess/parser_raw.ml" in -# 1746 "src/ocaml/preprocess/parser_raw.mly" +# 1750 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22980 "src/ocaml/preprocess/parser_raw.ml" +# 22984 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23014,24 +23018,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1738 "src/ocaml/preprocess/parser_raw.mly" +# 1742 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_functor(Named (mknoloc None, _1), _3) ) -# 23020 "src/ocaml/preprocess/parser_raw.ml" +# 23024 "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 -# 1035 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23029 "src/ocaml/preprocess/parser_raw.ml" +# 23033 "src/ocaml/preprocess/parser_raw.ml" in -# 1746 "src/ocaml/preprocess/parser_raw.mly" +# 1750 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23035 "src/ocaml/preprocess/parser_raw.ml" +# 23039 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23073,18 +23077,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 23077 "src/ocaml/preprocess/parser_raw.ml" +# 23081 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 23082 "src/ocaml/preprocess/parser_raw.ml" +# 23086 "src/ocaml/preprocess/parser_raw.ml" in -# 1740 "src/ocaml/preprocess/parser_raw.mly" +# 1744 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_with(_1, _3) ) -# 23088 "src/ocaml/preprocess/parser_raw.ml" +# 23092 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -23092,15 +23096,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1035 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23098 "src/ocaml/preprocess/parser_raw.ml" +# 23102 "src/ocaml/preprocess/parser_raw.ml" in -# 1746 "src/ocaml/preprocess/parser_raw.mly" +# 1750 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23104 "src/ocaml/preprocess/parser_raw.ml" +# 23108 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23124,23 +23128,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1744 "src/ocaml/preprocess/parser_raw.mly" +# 1748 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_extension _1 ) -# 23130 "src/ocaml/preprocess/parser_raw.ml" +# 23134 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1035 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23138 "src/ocaml/preprocess/parser_raw.ml" +# 23142 "src/ocaml/preprocess/parser_raw.ml" in -# 1746 "src/ocaml/preprocess/parser_raw.mly" +# 1750 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23144 "src/ocaml/preprocess/parser_raw.ml" +# 23148 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23207,9 +23211,9 @@ module Tables = struct let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23213 "src/ocaml/preprocess/parser_raw.ml" +# 23217 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -23219,31 +23223,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23225 "src/ocaml/preprocess/parser_raw.ml" +# 23229 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23233 "src/ocaml/preprocess/parser_raw.ml" +# 23237 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1656 "src/ocaml/preprocess/parser_raw.mly" +# 1660 "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 ) -# 23247 "src/ocaml/preprocess/parser_raw.ml" +# 23251 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23317,9 +23321,9 @@ module Tables = struct let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23323 "src/ocaml/preprocess/parser_raw.ml" +# 23327 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -23329,31 +23333,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23335 "src/ocaml/preprocess/parser_raw.ml" +# 23339 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23343 "src/ocaml/preprocess/parser_raw.ml" +# 23347 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1922 "src/ocaml/preprocess/parser_raw.mly" +# 1926 "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 ) -# 23357 "src/ocaml/preprocess/parser_raw.ml" +# 23361 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23376,9 +23380,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 3813 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23382 "src/ocaml/preprocess/parser_raw.ml" +# 23386 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23394,9 +23398,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.mutable_flag) = -# 3890 "src/ocaml/preprocess/parser_raw.mly" +# 3894 "src/ocaml/preprocess/parser_raw.mly" ( Immutable ) -# 23400 "src/ocaml/preprocess/parser_raw.ml" +# 23404 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23419,9 +23423,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag) = -# 3891 "src/ocaml/preprocess/parser_raw.mly" +# 3895 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 23425 "src/ocaml/preprocess/parser_raw.ml" +# 23429 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23437,9 +23441,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3899 "src/ocaml/preprocess/parser_raw.mly" +# 3903 "src/ocaml/preprocess/parser_raw.mly" ( Immutable, Concrete ) -# 23443 "src/ocaml/preprocess/parser_raw.ml" +# 23447 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23462,9 +23466,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3901 "src/ocaml/preprocess/parser_raw.mly" +# 3905 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Concrete ) -# 23468 "src/ocaml/preprocess/parser_raw.ml" +# 23472 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23487,9 +23491,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3903 "src/ocaml/preprocess/parser_raw.mly" +# 3907 "src/ocaml/preprocess/parser_raw.mly" ( Immutable, Virtual ) -# 23493 "src/ocaml/preprocess/parser_raw.ml" +# 23497 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23519,9 +23523,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3906 "src/ocaml/preprocess/parser_raw.mly" +# 3910 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Virtual ) -# 23525 "src/ocaml/preprocess/parser_raw.ml" +# 23529 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23551,9 +23555,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3906 "src/ocaml/preprocess/parser_raw.mly" +# 3910 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Virtual ) -# 23557 "src/ocaml/preprocess/parser_raw.ml" +# 23561 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23583,9 +23587,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3861 "src/ocaml/preprocess/parser_raw.mly" +# 3865 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 23589 "src/ocaml/preprocess/parser_raw.ml" +# 23593 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23604,9 +23608,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 23610 "src/ocaml/preprocess/parser_raw.ml" +# 23614 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -23616,15 +23620,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23622 "src/ocaml/preprocess/parser_raw.ml" +# 23626 "src/ocaml/preprocess/parser_raw.ml" in # 221 "" ( [ x ] ) -# 23628 "src/ocaml/preprocess/parser_raw.ml" +# 23632 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23650,9 +23654,9 @@ module Tables = struct } = _menhir_stack in let xs : (string Location.loc list) = Obj.magic xs in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 23656 "src/ocaml/preprocess/parser_raw.ml" +# 23660 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -23662,15 +23666,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23668 "src/ocaml/preprocess/parser_raw.ml" +# 23672 "src/ocaml/preprocess/parser_raw.ml" in # 223 "" ( x :: xs ) -# 23674 "src/ocaml/preprocess/parser_raw.ml" +# 23678 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23689,22 +23693,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let s : ( -# 831 "src/ocaml/preprocess/parser_raw.mly" +# 835 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 23695 "src/ocaml/preprocess/parser_raw.ml" +# 23699 "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 = -# 3857 "src/ocaml/preprocess/parser_raw.mly" +# 3861 "src/ocaml/preprocess/parser_raw.mly" ( let body, _, _ = s in body ) -# 23703 "src/ocaml/preprocess/parser_raw.ml" +# 23707 "src/ocaml/preprocess/parser_raw.ml" in # 221 "" ( [ x ] ) -# 23708 "src/ocaml/preprocess/parser_raw.ml" +# 23712 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23730,22 +23734,22 @@ module Tables = struct } = _menhir_stack in let xs : (string list) = Obj.magic xs in let s : ( -# 831 "src/ocaml/preprocess/parser_raw.mly" +# 835 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 23736 "src/ocaml/preprocess/parser_raw.ml" +# 23740 "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 = -# 3857 "src/ocaml/preprocess/parser_raw.mly" +# 3861 "src/ocaml/preprocess/parser_raw.mly" ( let body, _, _ = s in body ) -# 23744 "src/ocaml/preprocess/parser_raw.ml" +# 23748 "src/ocaml/preprocess/parser_raw.ml" in # 223 "" ( x :: xs ) -# 23749 "src/ocaml/preprocess/parser_raw.ml" +# 23753 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23768,14 +23772,14 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3886 "src/ocaml/preprocess/parser_raw.mly" +# 3890 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 23774 "src/ocaml/preprocess/parser_raw.ml" +# 23778 "src/ocaml/preprocess/parser_raw.ml" in -# 3166 "src/ocaml/preprocess/parser_raw.mly" +# 3170 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, priv, Some ty) ) -# 23779 "src/ocaml/preprocess/parser_raw.ml" +# 23783 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23805,14 +23809,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3887 "src/ocaml/preprocess/parser_raw.mly" +# 3891 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 23811 "src/ocaml/preprocess/parser_raw.ml" +# 23815 "src/ocaml/preprocess/parser_raw.ml" in -# 3166 "src/ocaml/preprocess/parser_raw.mly" +# 3170 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, priv, Some ty) ) -# 23816 "src/ocaml/preprocess/parser_raw.ml" +# 23820 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23835,26 +23839,26 @@ module Tables = struct let _startpos = _startpos_cs_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3886 "src/ocaml/preprocess/parser_raw.mly" +# 3890 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 23841 "src/ocaml/preprocess/parser_raw.ml" +# 23845 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 23847 "src/ocaml/preprocess/parser_raw.ml" +# 23851 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23852 "src/ocaml/preprocess/parser_raw.ml" +# 23856 "src/ocaml/preprocess/parser_raw.ml" in -# 3170 "src/ocaml/preprocess/parser_raw.mly" +# 3174 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 23858 "src/ocaml/preprocess/parser_raw.ml" +# 23862 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23884,26 +23888,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3887 "src/ocaml/preprocess/parser_raw.mly" +# 3891 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 23890 "src/ocaml/preprocess/parser_raw.ml" +# 23894 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 23896 "src/ocaml/preprocess/parser_raw.ml" +# 23900 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23901 "src/ocaml/preprocess/parser_raw.ml" +# 23905 "src/ocaml/preprocess/parser_raw.ml" in -# 3170 "src/ocaml/preprocess/parser_raw.mly" +# 3174 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 23907 "src/ocaml/preprocess/parser_raw.ml" +# 23911 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23940,33 +23944,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3886 "src/ocaml/preprocess/parser_raw.mly" +# 3890 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 23946 "src/ocaml/preprocess/parser_raw.ml" +# 23950 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 23953 "src/ocaml/preprocess/parser_raw.ml" +# 23957 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 23958 "src/ocaml/preprocess/parser_raw.ml" +# 23962 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23964 "src/ocaml/preprocess/parser_raw.ml" +# 23968 "src/ocaml/preprocess/parser_raw.ml" in -# 3170 "src/ocaml/preprocess/parser_raw.mly" +# 3174 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 23970 "src/ocaml/preprocess/parser_raw.ml" +# 23974 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24010,33 +24014,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3887 "src/ocaml/preprocess/parser_raw.mly" +# 3891 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24016 "src/ocaml/preprocess/parser_raw.ml" +# 24020 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24023 "src/ocaml/preprocess/parser_raw.ml" +# 24027 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24028 "src/ocaml/preprocess/parser_raw.ml" +# 24032 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24034 "src/ocaml/preprocess/parser_raw.ml" +# 24038 "src/ocaml/preprocess/parser_raw.ml" in -# 3170 "src/ocaml/preprocess/parser_raw.mly" +# 3174 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24040 "src/ocaml/preprocess/parser_raw.ml" +# 24044 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24059,26 +24063,26 @@ module Tables = struct let _startpos = _startpos__3_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3886 "src/ocaml/preprocess/parser_raw.mly" +# 3890 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24065 "src/ocaml/preprocess/parser_raw.ml" +# 24069 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24071 "src/ocaml/preprocess/parser_raw.ml" +# 24075 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24076 "src/ocaml/preprocess/parser_raw.ml" +# 24080 "src/ocaml/preprocess/parser_raw.ml" in -# 3174 "src/ocaml/preprocess/parser_raw.mly" +# 3178 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24082 "src/ocaml/preprocess/parser_raw.ml" +# 24086 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24108,26 +24112,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3887 "src/ocaml/preprocess/parser_raw.mly" +# 3891 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24114 "src/ocaml/preprocess/parser_raw.ml" +# 24118 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24120 "src/ocaml/preprocess/parser_raw.ml" +# 24124 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24125 "src/ocaml/preprocess/parser_raw.ml" +# 24129 "src/ocaml/preprocess/parser_raw.ml" in -# 3174 "src/ocaml/preprocess/parser_raw.mly" +# 3178 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24131 "src/ocaml/preprocess/parser_raw.ml" +# 24135 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24164,33 +24168,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3886 "src/ocaml/preprocess/parser_raw.mly" +# 3890 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24170 "src/ocaml/preprocess/parser_raw.ml" +# 24174 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24177 "src/ocaml/preprocess/parser_raw.ml" +# 24181 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24182 "src/ocaml/preprocess/parser_raw.ml" +# 24186 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24188 "src/ocaml/preprocess/parser_raw.ml" +# 24192 "src/ocaml/preprocess/parser_raw.ml" in -# 3174 "src/ocaml/preprocess/parser_raw.mly" +# 3178 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24194 "src/ocaml/preprocess/parser_raw.ml" +# 24198 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24234,33 +24238,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3887 "src/ocaml/preprocess/parser_raw.mly" +# 3891 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24240 "src/ocaml/preprocess/parser_raw.ml" +# 24244 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24247 "src/ocaml/preprocess/parser_raw.ml" +# 24251 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24252 "src/ocaml/preprocess/parser_raw.ml" +# 24256 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24258 "src/ocaml/preprocess/parser_raw.ml" +# 24262 "src/ocaml/preprocess/parser_raw.ml" in -# 3174 "src/ocaml/preprocess/parser_raw.mly" +# 3178 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24264 "src/ocaml/preprocess/parser_raw.ml" +# 24268 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24297,26 +24301,26 @@ module Tables = struct let _startpos = _startpos__3_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3886 "src/ocaml/preprocess/parser_raw.mly" +# 3890 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24303 "src/ocaml/preprocess/parser_raw.ml" +# 24307 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24309 "src/ocaml/preprocess/parser_raw.ml" +# 24313 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24314 "src/ocaml/preprocess/parser_raw.ml" +# 24318 "src/ocaml/preprocess/parser_raw.ml" in -# 3178 "src/ocaml/preprocess/parser_raw.mly" +# 3182 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24320 "src/ocaml/preprocess/parser_raw.ml" +# 24324 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24360,26 +24364,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3887 "src/ocaml/preprocess/parser_raw.mly" +# 3891 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24366 "src/ocaml/preprocess/parser_raw.ml" +# 24370 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24372 "src/ocaml/preprocess/parser_raw.ml" +# 24376 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24377 "src/ocaml/preprocess/parser_raw.ml" +# 24381 "src/ocaml/preprocess/parser_raw.ml" in -# 3178 "src/ocaml/preprocess/parser_raw.mly" +# 3182 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24383 "src/ocaml/preprocess/parser_raw.ml" +# 24387 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24430,33 +24434,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3886 "src/ocaml/preprocess/parser_raw.mly" +# 3890 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24436 "src/ocaml/preprocess/parser_raw.ml" +# 24440 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24443 "src/ocaml/preprocess/parser_raw.ml" +# 24447 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24448 "src/ocaml/preprocess/parser_raw.ml" +# 24452 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24454 "src/ocaml/preprocess/parser_raw.ml" +# 24458 "src/ocaml/preprocess/parser_raw.ml" in -# 3178 "src/ocaml/preprocess/parser_raw.mly" +# 3182 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24460 "src/ocaml/preprocess/parser_raw.ml" +# 24464 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24514,33 +24518,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3887 "src/ocaml/preprocess/parser_raw.mly" +# 3891 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24520 "src/ocaml/preprocess/parser_raw.ml" +# 24524 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24527 "src/ocaml/preprocess/parser_raw.ml" +# 24531 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24532 "src/ocaml/preprocess/parser_raw.ml" +# 24536 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3186 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24538 "src/ocaml/preprocess/parser_raw.ml" +# 24542 "src/ocaml/preprocess/parser_raw.ml" in -# 3178 "src/ocaml/preprocess/parser_raw.mly" +# 3182 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24544 "src/ocaml/preprocess/parser_raw.ml" +# 24548 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24593,37 +24597,37 @@ module Tables = struct let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24599 "src/ocaml/preprocess/parser_raw.ml" +# 24603 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24608 "src/ocaml/preprocess/parser_raw.ml" +# 24612 "src/ocaml/preprocess/parser_raw.ml" in let override = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 24614 "src/ocaml/preprocess/parser_raw.ml" +# 24618 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1675 "src/ocaml/preprocess/parser_raw.mly" +# 1679 "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 ) -# 24627 "src/ocaml/preprocess/parser_raw.ml" +# 24631 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24683,40 +24687,40 @@ module Tables = struct let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24689 "src/ocaml/preprocess/parser_raw.ml" +# 24693 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let attrs1 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24698 "src/ocaml/preprocess/parser_raw.ml" +# 24702 "src/ocaml/preprocess/parser_raw.ml" in let override = let _1 = _1_inlined1 in -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 24706 "src/ocaml/preprocess/parser_raw.ml" +# 24710 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1675 "src/ocaml/preprocess/parser_raw.mly" +# 1679 "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 ) -# 24720 "src/ocaml/preprocess/parser_raw.ml" +# 24724 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24769,9 +24773,9 @@ module Tables = struct let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24775 "src/ocaml/preprocess/parser_raw.ml" +# 24779 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -24781,36 +24785,36 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 24787 "src/ocaml/preprocess/parser_raw.ml" +# 24791 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24795 "src/ocaml/preprocess/parser_raw.ml" +# 24799 "src/ocaml/preprocess/parser_raw.ml" in let override = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 24801 "src/ocaml/preprocess/parser_raw.ml" +# 24805 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1690 "src/ocaml/preprocess/parser_raw.mly" +# 1694 "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 ) -# 24814 "src/ocaml/preprocess/parser_raw.ml" +# 24818 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24870,9 +24874,9 @@ module Tables = struct let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24876 "src/ocaml/preprocess/parser_raw.ml" +# 24880 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -24882,39 +24886,39 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 24888 "src/ocaml/preprocess/parser_raw.ml" +# 24892 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24896 "src/ocaml/preprocess/parser_raw.ml" +# 24900 "src/ocaml/preprocess/parser_raw.ml" in let override = let _1 = _1_inlined1 in -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 24904 "src/ocaml/preprocess/parser_raw.ml" +# 24908 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1690 "src/ocaml/preprocess/parser_raw.mly" +# 1694 "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 ) -# 24918 "src/ocaml/preprocess/parser_raw.ml" +# 24922 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24933,17 +24937,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 817 "src/ocaml/preprocess/parser_raw.mly" +# 821 "src/ocaml/preprocess/parser_raw.mly" (string) -# 24939 "src/ocaml/preprocess/parser_raw.ml" +# 24943 "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) = -# 3723 "src/ocaml/preprocess/parser_raw.mly" +# 3727 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24947 "src/ocaml/preprocess/parser_raw.ml" +# 24951 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24962,17 +24966,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 779 "src/ocaml/preprocess/parser_raw.mly" (string) -# 24968 "src/ocaml/preprocess/parser_raw.ml" +# 24972 "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) = -# 3724 "src/ocaml/preprocess/parser_raw.mly" +# 3728 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24976 "src/ocaml/preprocess/parser_raw.ml" +# 24980 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24991,17 +24995,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 24997 "src/ocaml/preprocess/parser_raw.ml" +# 25001 "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) = -# 3725 "src/ocaml/preprocess/parser_raw.mly" +# 3729 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25005 "src/ocaml/preprocess/parser_raw.ml" +# 25009 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25041,17 +25045,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25047 "src/ocaml/preprocess/parser_raw.ml" +# 25051 "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) = -# 3726 "src/ocaml/preprocess/parser_raw.mly" +# 3730 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"(" ^ _3 ^ ")" ) -# 25055 "src/ocaml/preprocess/parser_raw.ml" +# 25059 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25098,17 +25102,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25104 "src/ocaml/preprocess/parser_raw.ml" +# 25108 "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) = -# 3727 "src/ocaml/preprocess/parser_raw.mly" +# 3731 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "(" ^ _3 ^ ")<-" ) -# 25112 "src/ocaml/preprocess/parser_raw.ml" +# 25116 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25148,17 +25152,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25154 "src/ocaml/preprocess/parser_raw.ml" +# 25158 "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) = -# 3728 "src/ocaml/preprocess/parser_raw.mly" +# 3732 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"[" ^ _3 ^ "]" ) -# 25162 "src/ocaml/preprocess/parser_raw.ml" +# 25166 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25205,17 +25209,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25211 "src/ocaml/preprocess/parser_raw.ml" +# 25215 "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) = -# 3729 "src/ocaml/preprocess/parser_raw.mly" +# 3733 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "[" ^ _3 ^ "]<-" ) -# 25219 "src/ocaml/preprocess/parser_raw.ml" +# 25223 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25255,17 +25259,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25261 "src/ocaml/preprocess/parser_raw.ml" +# 25265 "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) = -# 3730 "src/ocaml/preprocess/parser_raw.mly" +# 3734 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"{" ^ _3 ^ "}" ) -# 25269 "src/ocaml/preprocess/parser_raw.ml" +# 25273 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25312,17 +25316,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25318 "src/ocaml/preprocess/parser_raw.ml" +# 25322 "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) = -# 3731 "src/ocaml/preprocess/parser_raw.mly" +# 3735 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "{" ^ _3 ^ "}<-" ) -# 25326 "src/ocaml/preprocess/parser_raw.ml" +# 25330 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25341,17 +25345,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 828 "src/ocaml/preprocess/parser_raw.mly" +# 832 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25347 "src/ocaml/preprocess/parser_raw.ml" +# 25351 "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) = -# 3732 "src/ocaml/preprocess/parser_raw.mly" +# 3736 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25355 "src/ocaml/preprocess/parser_raw.ml" +# 25359 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25374,9 +25378,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3733 "src/ocaml/preprocess/parser_raw.mly" +# 3737 "src/ocaml/preprocess/parser_raw.mly" ( "!" ) -# 25380 "src/ocaml/preprocess/parser_raw.ml" +# 25384 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25395,22 +25399,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 769 "src/ocaml/preprocess/parser_raw.mly" +# 773 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25401 "src/ocaml/preprocess/parser_raw.ml" +# 25405 "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 = -# 3737 "src/ocaml/preprocess/parser_raw.mly" +# 3741 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25409 "src/ocaml/preprocess/parser_raw.ml" +# 25413 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25414 "src/ocaml/preprocess/parser_raw.ml" +# 25418 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25429,22 +25433,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 770 "src/ocaml/preprocess/parser_raw.mly" +# 774 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25435 "src/ocaml/preprocess/parser_raw.ml" +# 25439 "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 = -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3742 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25443 "src/ocaml/preprocess/parser_raw.ml" +# 25447 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25448 "src/ocaml/preprocess/parser_raw.ml" +# 25452 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25463,22 +25467,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 771 "src/ocaml/preprocess/parser_raw.mly" +# 775 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25469 "src/ocaml/preprocess/parser_raw.ml" +# 25473 "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 = -# 3739 "src/ocaml/preprocess/parser_raw.mly" +# 3743 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25477 "src/ocaml/preprocess/parser_raw.ml" +# 25481 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25482 "src/ocaml/preprocess/parser_raw.ml" +# 25486 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25497,22 +25501,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 772 "src/ocaml/preprocess/parser_raw.mly" +# 776 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25503 "src/ocaml/preprocess/parser_raw.ml" +# 25507 "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 = -# 3740 "src/ocaml/preprocess/parser_raw.mly" +# 3744 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25511 "src/ocaml/preprocess/parser_raw.ml" +# 25515 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25516 "src/ocaml/preprocess/parser_raw.ml" +# 25520 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25531,22 +25535,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 773 "src/ocaml/preprocess/parser_raw.mly" +# 777 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25537 "src/ocaml/preprocess/parser_raw.ml" +# 25541 "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 = -# 3741 "src/ocaml/preprocess/parser_raw.mly" +# 3745 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25545 "src/ocaml/preprocess/parser_raw.ml" +# 25549 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25550 "src/ocaml/preprocess/parser_raw.ml" +# 25554 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25569,14 +25573,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3742 "src/ocaml/preprocess/parser_raw.mly" +# 3746 "src/ocaml/preprocess/parser_raw.mly" ("+") -# 25575 "src/ocaml/preprocess/parser_raw.ml" +# 25579 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25580 "src/ocaml/preprocess/parser_raw.ml" +# 25584 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25599,14 +25603,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3743 "src/ocaml/preprocess/parser_raw.mly" +# 3747 "src/ocaml/preprocess/parser_raw.mly" ("+.") -# 25605 "src/ocaml/preprocess/parser_raw.ml" +# 25609 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25610 "src/ocaml/preprocess/parser_raw.ml" +# 25614 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25629,14 +25633,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3744 "src/ocaml/preprocess/parser_raw.mly" +# 3748 "src/ocaml/preprocess/parser_raw.mly" ("+=") -# 25635 "src/ocaml/preprocess/parser_raw.ml" +# 25639 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25640 "src/ocaml/preprocess/parser_raw.ml" +# 25644 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25659,14 +25663,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3745 "src/ocaml/preprocess/parser_raw.mly" +# 3749 "src/ocaml/preprocess/parser_raw.mly" ("-") -# 25665 "src/ocaml/preprocess/parser_raw.ml" +# 25669 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25670 "src/ocaml/preprocess/parser_raw.ml" +# 25674 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25689,14 +25693,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3746 "src/ocaml/preprocess/parser_raw.mly" +# 3750 "src/ocaml/preprocess/parser_raw.mly" ("-.") -# 25695 "src/ocaml/preprocess/parser_raw.ml" +# 25699 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25700 "src/ocaml/preprocess/parser_raw.ml" +# 25704 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25719,14 +25723,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3747 "src/ocaml/preprocess/parser_raw.mly" +# 3751 "src/ocaml/preprocess/parser_raw.mly" ("*") -# 25725 "src/ocaml/preprocess/parser_raw.ml" +# 25729 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25730 "src/ocaml/preprocess/parser_raw.ml" +# 25734 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25749,14 +25753,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3748 "src/ocaml/preprocess/parser_raw.mly" +# 3752 "src/ocaml/preprocess/parser_raw.mly" ("%") -# 25755 "src/ocaml/preprocess/parser_raw.ml" +# 25759 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25760 "src/ocaml/preprocess/parser_raw.ml" +# 25764 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25779,14 +25783,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3749 "src/ocaml/preprocess/parser_raw.mly" +# 3753 "src/ocaml/preprocess/parser_raw.mly" ("=") -# 25785 "src/ocaml/preprocess/parser_raw.ml" +# 25789 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25790 "src/ocaml/preprocess/parser_raw.ml" +# 25794 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25809,14 +25813,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3750 "src/ocaml/preprocess/parser_raw.mly" +# 3754 "src/ocaml/preprocess/parser_raw.mly" ("<") -# 25815 "src/ocaml/preprocess/parser_raw.ml" +# 25819 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25820 "src/ocaml/preprocess/parser_raw.ml" +# 25824 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25839,14 +25843,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3751 "src/ocaml/preprocess/parser_raw.mly" +# 3755 "src/ocaml/preprocess/parser_raw.mly" (">") -# 25845 "src/ocaml/preprocess/parser_raw.ml" +# 25849 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25850 "src/ocaml/preprocess/parser_raw.ml" +# 25854 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25869,14 +25873,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3752 "src/ocaml/preprocess/parser_raw.mly" +# 3756 "src/ocaml/preprocess/parser_raw.mly" ("or") -# 25875 "src/ocaml/preprocess/parser_raw.ml" +# 25879 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25880 "src/ocaml/preprocess/parser_raw.ml" +# 25884 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25899,14 +25903,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3753 "src/ocaml/preprocess/parser_raw.mly" +# 3757 "src/ocaml/preprocess/parser_raw.mly" ("||") -# 25905 "src/ocaml/preprocess/parser_raw.ml" +# 25909 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25910 "src/ocaml/preprocess/parser_raw.ml" +# 25914 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25929,14 +25933,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3754 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ("&") -# 25935 "src/ocaml/preprocess/parser_raw.ml" +# 25939 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25940 "src/ocaml/preprocess/parser_raw.ml" +# 25944 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25959,14 +25963,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3755 "src/ocaml/preprocess/parser_raw.mly" +# 3759 "src/ocaml/preprocess/parser_raw.mly" ("&&") -# 25965 "src/ocaml/preprocess/parser_raw.ml" +# 25969 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25970 "src/ocaml/preprocess/parser_raw.ml" +# 25974 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25989,14 +25993,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3756 "src/ocaml/preprocess/parser_raw.mly" +# 3760 "src/ocaml/preprocess/parser_raw.mly" (":=") -# 25995 "src/ocaml/preprocess/parser_raw.ml" +# 25999 "src/ocaml/preprocess/parser_raw.ml" in -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26000 "src/ocaml/preprocess/parser_raw.ml" +# 26004 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26019,9 +26023,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (bool) = -# 3636 "src/ocaml/preprocess/parser_raw.mly" +# 3640 "src/ocaml/preprocess/parser_raw.mly" ( true ) -# 26025 "src/ocaml/preprocess/parser_raw.ml" +# 26029 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26037,9 +26041,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (bool) = -# 3637 "src/ocaml/preprocess/parser_raw.mly" +# 3641 "src/ocaml/preprocess/parser_raw.mly" ( false ) -# 26043 "src/ocaml/preprocess/parser_raw.ml" +# 26047 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26057,7 +26061,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26061 "src/ocaml/preprocess/parser_raw.ml" +# 26065 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26082,7 +26086,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26086 "src/ocaml/preprocess/parser_raw.ml" +# 26090 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26100,7 +26104,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26104 "src/ocaml/preprocess/parser_raw.ml" +# 26108 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26125,7 +26129,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26129 "src/ocaml/preprocess/parser_raw.ml" +# 26133 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26143,7 +26147,7 @@ module Tables = struct let _v : (string Location.loc option) = # 114 "" ( None ) -# 26147 "src/ocaml/preprocess/parser_raw.ml" +# 26151 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26168,9 +26172,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 26174 "src/ocaml/preprocess/parser_raw.ml" +# 26178 "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 @@ -26183,21 +26187,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 26189 "src/ocaml/preprocess/parser_raw.ml" +# 26193 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 26195 "src/ocaml/preprocess/parser_raw.ml" +# 26199 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26201 "src/ocaml/preprocess/parser_raw.ml" +# 26205 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26215,7 +26219,7 @@ module Tables = struct let _v : (Parsetree.core_type option) = # 114 "" ( None ) -# 26219 "src/ocaml/preprocess/parser_raw.ml" +# 26223 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26247,12 +26251,12 @@ module Tables = struct let _v : (Parsetree.core_type option) = let x = # 183 "" ( x ) -# 26251 "src/ocaml/preprocess/parser_raw.ml" +# 26255 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26256 "src/ocaml/preprocess/parser_raw.ml" +# 26260 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26270,7 +26274,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 26274 "src/ocaml/preprocess/parser_raw.ml" +# 26278 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26302,12 +26306,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 26306 "src/ocaml/preprocess/parser_raw.ml" +# 26310 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26311 "src/ocaml/preprocess/parser_raw.ml" +# 26315 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26325,7 +26329,7 @@ module Tables = struct let _v : (Parsetree.module_type option) = # 114 "" ( None ) -# 26329 "src/ocaml/preprocess/parser_raw.ml" +# 26333 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26357,12 +26361,12 @@ module Tables = struct let _v : (Parsetree.module_type option) = let x = # 183 "" ( x ) -# 26361 "src/ocaml/preprocess/parser_raw.ml" +# 26365 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26366 "src/ocaml/preprocess/parser_raw.ml" +# 26370 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26380,7 +26384,7 @@ module Tables = struct let _v : (Parsetree.pattern option) = # 114 "" ( None ) -# 26384 "src/ocaml/preprocess/parser_raw.ml" +# 26388 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26412,12 +26416,12 @@ module Tables = struct let _v : (Parsetree.pattern option) = let x = # 183 "" ( x ) -# 26416 "src/ocaml/preprocess/parser_raw.ml" +# 26420 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26421 "src/ocaml/preprocess/parser_raw.ml" +# 26425 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26435,7 +26439,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 26439 "src/ocaml/preprocess/parser_raw.ml" +# 26443 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26467,12 +26471,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 26471 "src/ocaml/preprocess/parser_raw.ml" +# 26475 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26476 "src/ocaml/preprocess/parser_raw.ml" +# 26480 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26490,7 +26494,7 @@ module Tables = struct let _v : ((Parsetree.core_type option * Parsetree.core_type option) option) = # 114 "" ( None ) -# 26494 "src/ocaml/preprocess/parser_raw.ml" +# 26498 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26515,7 +26519,7 @@ module Tables = struct let _v : ((Parsetree.core_type option * Parsetree.core_type option) option) = # 116 "" ( Some x ) -# 26519 "src/ocaml/preprocess/parser_raw.ml" +# 26523 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26534,17 +26538,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 810 "src/ocaml/preprocess/parser_raw.mly" +# 814 "src/ocaml/preprocess/parser_raw.mly" (string) -# 26540 "src/ocaml/preprocess/parser_raw.ml" +# 26544 "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) = -# 3945 "src/ocaml/preprocess/parser_raw.mly" +# 3949 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26548 "src/ocaml/preprocess/parser_raw.ml" +# 26552 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26576,18 +26580,18 @@ module Tables = struct } = _menhir_stack in let _3 : unit = Obj.magic _3 in let _2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 26582 "src/ocaml/preprocess/parser_raw.ml" +# 26586 "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) = -# 3946 "src/ocaml/preprocess/parser_raw.mly" +# 3950 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 26591 "src/ocaml/preprocess/parser_raw.ml" +# 26595 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26641,9 +26645,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1448 "src/ocaml/preprocess/parser_raw.mly" +# 1452 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc (Pmod_constraint(me, mty)) ) -# 26647 "src/ocaml/preprocess/parser_raw.ml" +# 26651 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26680,9 +26684,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.module_expr) = -# 1455 "src/ocaml/preprocess/parser_raw.mly" +# 1459 "src/ocaml/preprocess/parser_raw.mly" ( me (* TODO consider reloc *) ) -# 26686 "src/ocaml/preprocess/parser_raw.ml" +# 26690 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26733,25 +26737,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.module_expr) = let e = -# 1478 "src/ocaml/preprocess/parser_raw.mly" +# 1482 "src/ocaml/preprocess/parser_raw.mly" ( e ) -# 26739 "src/ocaml/preprocess/parser_raw.ml" +# 26743 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26746 "src/ocaml/preprocess/parser_raw.ml" +# 26750 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1463 "src/ocaml/preprocess/parser_raw.mly" +# 1467 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 26755 "src/ocaml/preprocess/parser_raw.ml" +# 26759 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26822,11 +26826,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3611 "src/ocaml/preprocess/parser_raw.mly" +# 3615 "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 ) -# 26830 "src/ocaml/preprocess/parser_raw.ml" +# 26834 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_ty_ = _endpos__1_ in @@ -26834,26 +26838,26 @@ module Tables = struct let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1480 "src/ocaml/preprocess/parser_raw.mly" +# 1484 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_constraint (e, ty)) ) -# 26840 "src/ocaml/preprocess/parser_raw.ml" +# 26844 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26848 "src/ocaml/preprocess/parser_raw.ml" +# 26852 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1463 "src/ocaml/preprocess/parser_raw.mly" +# 1467 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 26857 "src/ocaml/preprocess/parser_raw.ml" +# 26861 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26939,11 +26943,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3611 "src/ocaml/preprocess/parser_raw.mly" +# 3615 "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 ) -# 26947 "src/ocaml/preprocess/parser_raw.ml" +# 26951 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_ty2_ = _endpos__1_inlined1_ in @@ -26952,37 +26956,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3611 "src/ocaml/preprocess/parser_raw.mly" +# 3615 "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 ) -# 26960 "src/ocaml/preprocess/parser_raw.ml" +# 26964 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_ty2_ in let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1482 "src/ocaml/preprocess/parser_raw.mly" +# 1486 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, Some ty1, ty2)) ) -# 26969 "src/ocaml/preprocess/parser_raw.ml" +# 26973 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26977 "src/ocaml/preprocess/parser_raw.ml" +# 26981 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1463 "src/ocaml/preprocess/parser_raw.mly" +# 1467 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 26986 "src/ocaml/preprocess/parser_raw.ml" +# 26990 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27053,11 +27057,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3611 "src/ocaml/preprocess/parser_raw.mly" +# 3615 "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 ) -# 27061 "src/ocaml/preprocess/parser_raw.ml" +# 27065 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_ty2_ = _endpos__1_ in @@ -27065,26 +27069,26 @@ module Tables = struct let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1484 "src/ocaml/preprocess/parser_raw.mly" +# 1488 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, None, ty2)) ) -# 27071 "src/ocaml/preprocess/parser_raw.ml" +# 27075 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27079 "src/ocaml/preprocess/parser_raw.ml" +# 27083 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1463 "src/ocaml/preprocess/parser_raw.mly" +# 1467 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27088 "src/ocaml/preprocess/parser_raw.ml" +# 27092 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27114,9 +27118,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1360 "src/ocaml/preprocess/parser_raw.mly" +# 1364 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27120 "src/ocaml/preprocess/parser_raw.ml" +# 27124 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27146,9 +27150,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1345 "src/ocaml/preprocess/parser_raw.mly" +# 1349 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27152 "src/ocaml/preprocess/parser_raw.ml" +# 27156 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27178,9 +27182,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = -# 1320 "src/ocaml/preprocess/parser_raw.mly" +# 1324 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27184 "src/ocaml/preprocess/parser_raw.ml" +# 27188 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27210,9 +27214,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 1325 "src/ocaml/preprocess/parser_raw.mly" +# 1329 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27216 "src/ocaml/preprocess/parser_raw.ml" +# 27220 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27242,9 +27246,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1350 "src/ocaml/preprocess/parser_raw.mly" +# 1354 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27248 "src/ocaml/preprocess/parser_raw.ml" +# 27252 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27274,9 +27278,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1355 "src/ocaml/preprocess/parser_raw.mly" +# 1359 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27280 "src/ocaml/preprocess/parser_raw.ml" +# 27284 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27306,9 +27310,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_expr) = -# 1315 "src/ocaml/preprocess/parser_raw.mly" +# 1319 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27312 "src/ocaml/preprocess/parser_raw.ml" +# 27316 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27338,9 +27342,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_type) = -# 1310 "src/ocaml/preprocess/parser_raw.mly" +# 1314 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27344 "src/ocaml/preprocess/parser_raw.ml" +# 27348 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27370,9 +27374,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1335 "src/ocaml/preprocess/parser_raw.mly" +# 1339 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27376 "src/ocaml/preprocess/parser_raw.ml" +# 27380 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27402,9 +27406,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = -# 1330 "src/ocaml/preprocess/parser_raw.mly" +# 1334 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27408 "src/ocaml/preprocess/parser_raw.ml" +# 27412 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27434,9 +27438,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1340 "src/ocaml/preprocess/parser_raw.mly" +# 1344 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27440 "src/ocaml/preprocess/parser_raw.ml" +# 27444 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27478,15 +27482,15 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2891 "src/ocaml/preprocess/parser_raw.mly" +# 2895 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 27484 "src/ocaml/preprocess/parser_raw.ml" +# 27488 "src/ocaml/preprocess/parser_raw.ml" in -# 2879 "src/ocaml/preprocess/parser_raw.mly" +# 2883 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27490 "src/ocaml/preprocess/parser_raw.ml" +# 27494 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27516,14 +27520,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = -# 2893 "src/ocaml/preprocess/parser_raw.mly" +# 2897 "src/ocaml/preprocess/parser_raw.mly" ( Pat.attr _1 _2 ) -# 27522 "src/ocaml/preprocess/parser_raw.ml" +# 27526 "src/ocaml/preprocess/parser_raw.ml" in -# 2879 "src/ocaml/preprocess/parser_raw.mly" +# 2883 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27527 "src/ocaml/preprocess/parser_raw.ml" +# 27531 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27546,14 +27550,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = -# 2895 "src/ocaml/preprocess/parser_raw.mly" +# 2899 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27552 "src/ocaml/preprocess/parser_raw.ml" +# 27556 "src/ocaml/preprocess/parser_raw.ml" in -# 2879 "src/ocaml/preprocess/parser_raw.mly" +# 2883 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27557 "src/ocaml/preprocess/parser_raw.ml" +# 27561 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27598,15 +27602,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 27604 "src/ocaml/preprocess/parser_raw.ml" +# 27608 "src/ocaml/preprocess/parser_raw.ml" in -# 2898 "src/ocaml/preprocess/parser_raw.mly" +# 2902 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_alias(_1, _3) ) -# 27610 "src/ocaml/preprocess/parser_raw.ml" +# 27614 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -27614,21 +27618,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 27620 "src/ocaml/preprocess/parser_raw.ml" +# 27624 "src/ocaml/preprocess/parser_raw.ml" in -# 2909 "src/ocaml/preprocess/parser_raw.mly" +# 2913 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27626 "src/ocaml/preprocess/parser_raw.ml" +# 27630 "src/ocaml/preprocess/parser_raw.ml" in -# 2879 "src/ocaml/preprocess/parser_raw.mly" +# 2883 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27632 "src/ocaml/preprocess/parser_raw.ml" +# 27636 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27653,29 +27657,29 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2902 "src/ocaml/preprocess/parser_raw.mly" +# 2906 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_tuple(List.rev _1) ) -# 27659 "src/ocaml/preprocess/parser_raw.ml" +# 27663 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 27667 "src/ocaml/preprocess/parser_raw.ml" +# 27671 "src/ocaml/preprocess/parser_raw.ml" in -# 2909 "src/ocaml/preprocess/parser_raw.mly" +# 2913 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27673 "src/ocaml/preprocess/parser_raw.ml" +# 27677 "src/ocaml/preprocess/parser_raw.ml" in -# 2879 "src/ocaml/preprocess/parser_raw.mly" +# 2883 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27679 "src/ocaml/preprocess/parser_raw.ml" +# 27683 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27714,30 +27718,30 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2906 "src/ocaml/preprocess/parser_raw.mly" +# 2910 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_or(_1, _3) ) -# 27720 "src/ocaml/preprocess/parser_raw.ml" +# 27724 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 27729 "src/ocaml/preprocess/parser_raw.ml" +# 27733 "src/ocaml/preprocess/parser_raw.ml" in -# 2909 "src/ocaml/preprocess/parser_raw.mly" +# 2913 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27735 "src/ocaml/preprocess/parser_raw.ml" +# 27739 "src/ocaml/preprocess/parser_raw.ml" in -# 2879 "src/ocaml/preprocess/parser_raw.mly" +# 2883 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27741 "src/ocaml/preprocess/parser_raw.ml" +# 27745 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27785,24 +27789,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27791 "src/ocaml/preprocess/parser_raw.ml" +# 27795 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 27797 "src/ocaml/preprocess/parser_raw.ml" +# 27801 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2881 "src/ocaml/preprocess/parser_raw.mly" +# 2885 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_exception _3) _2) -# 27806 "src/ocaml/preprocess/parser_raw.ml" +# 27810 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27839,9 +27843,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3012 "src/ocaml/preprocess/parser_raw.mly" +# 3016 "src/ocaml/preprocess/parser_raw.mly" ( _3 :: _1 ) -# 27845 "src/ocaml/preprocess/parser_raw.ml" +# 27849 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27878,9 +27882,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3013 "src/ocaml/preprocess/parser_raw.mly" +# 3017 "src/ocaml/preprocess/parser_raw.mly" ( [_3; _1] ) -# 27884 "src/ocaml/preprocess/parser_raw.ml" +# 27888 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27917,9 +27921,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3012 "src/ocaml/preprocess/parser_raw.mly" +# 3016 "src/ocaml/preprocess/parser_raw.mly" ( _3 :: _1 ) -# 27923 "src/ocaml/preprocess/parser_raw.ml" +# 27927 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27956,9 +27960,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3013 "src/ocaml/preprocess/parser_raw.mly" +# 3017 "src/ocaml/preprocess/parser_raw.mly" ( [_3; _1] ) -# 27962 "src/ocaml/preprocess/parser_raw.ml" +# 27966 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27981,9 +27985,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2914 "src/ocaml/preprocess/parser_raw.mly" +# 2918 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27987 "src/ocaml/preprocess/parser_raw.ml" +# 27991 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28019,15 +28023,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28025 "src/ocaml/preprocess/parser_raw.ml" +# 28029 "src/ocaml/preprocess/parser_raw.ml" in -# 2917 "src/ocaml/preprocess/parser_raw.mly" +# 2921 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(_1, Some ([], _2)) ) -# 28031 "src/ocaml/preprocess/parser_raw.ml" +# 28035 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -28035,15 +28039,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28041 "src/ocaml/preprocess/parser_raw.ml" +# 28045 "src/ocaml/preprocess/parser_raw.ml" in -# 2923 "src/ocaml/preprocess/parser_raw.mly" +# 2927 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28047 "src/ocaml/preprocess/parser_raw.ml" +# 28051 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28103,24 +28107,24 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let newtypes = -# 2662 "src/ocaml/preprocess/parser_raw.mly" +# 2666 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 28109 "src/ocaml/preprocess/parser_raw.ml" +# 28113 "src/ocaml/preprocess/parser_raw.ml" in let constr = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28118 "src/ocaml/preprocess/parser_raw.ml" +# 28122 "src/ocaml/preprocess/parser_raw.ml" in -# 2920 "src/ocaml/preprocess/parser_raw.mly" +# 2924 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(constr, Some (newtypes, pat)) ) -# 28124 "src/ocaml/preprocess/parser_raw.ml" +# 28128 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_pat_ in @@ -28128,15 +28132,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28134 "src/ocaml/preprocess/parser_raw.ml" +# 28138 "src/ocaml/preprocess/parser_raw.ml" in -# 2923 "src/ocaml/preprocess/parser_raw.mly" +# 2927 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28140 "src/ocaml/preprocess/parser_raw.ml" +# 28144 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28167,24 +28171,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2922 "src/ocaml/preprocess/parser_raw.mly" +# 2926 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_variant(_1, Some _2) ) -# 28173 "src/ocaml/preprocess/parser_raw.ml" +# 28177 "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 -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28182 "src/ocaml/preprocess/parser_raw.ml" +# 28186 "src/ocaml/preprocess/parser_raw.ml" in -# 2923 "src/ocaml/preprocess/parser_raw.mly" +# 2927 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28188 "src/ocaml/preprocess/parser_raw.ml" +# 28192 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28232,24 +28236,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28238 "src/ocaml/preprocess/parser_raw.ml" +# 28242 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 28244 "src/ocaml/preprocess/parser_raw.ml" +# 28248 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2925 "src/ocaml/preprocess/parser_raw.mly" +# 2929 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_lazy _3) _2) -# 28253 "src/ocaml/preprocess/parser_raw.ml" +# 28257 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28291,15 +28295,15 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2891 "src/ocaml/preprocess/parser_raw.mly" +# 2895 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 28297 "src/ocaml/preprocess/parser_raw.ml" +# 28301 "src/ocaml/preprocess/parser_raw.ml" in -# 2886 "src/ocaml/preprocess/parser_raw.mly" +# 2890 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28303 "src/ocaml/preprocess/parser_raw.ml" +# 28307 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28329,14 +28333,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = -# 2893 "src/ocaml/preprocess/parser_raw.mly" +# 2897 "src/ocaml/preprocess/parser_raw.mly" ( Pat.attr _1 _2 ) -# 28335 "src/ocaml/preprocess/parser_raw.ml" +# 28339 "src/ocaml/preprocess/parser_raw.ml" in -# 2886 "src/ocaml/preprocess/parser_raw.mly" +# 2890 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28340 "src/ocaml/preprocess/parser_raw.ml" +# 28344 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28359,14 +28363,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = -# 2895 "src/ocaml/preprocess/parser_raw.mly" +# 2899 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28365 "src/ocaml/preprocess/parser_raw.ml" +# 28369 "src/ocaml/preprocess/parser_raw.ml" in -# 2886 "src/ocaml/preprocess/parser_raw.mly" +# 2890 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28370 "src/ocaml/preprocess/parser_raw.ml" +# 28374 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28411,15 +28415,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28417 "src/ocaml/preprocess/parser_raw.ml" +# 28421 "src/ocaml/preprocess/parser_raw.ml" in -# 2898 "src/ocaml/preprocess/parser_raw.mly" +# 2902 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_alias(_1, _3) ) -# 28423 "src/ocaml/preprocess/parser_raw.ml" +# 28427 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -28427,21 +28431,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28433 "src/ocaml/preprocess/parser_raw.ml" +# 28437 "src/ocaml/preprocess/parser_raw.ml" in -# 2909 "src/ocaml/preprocess/parser_raw.mly" +# 2913 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28439 "src/ocaml/preprocess/parser_raw.ml" +# 28443 "src/ocaml/preprocess/parser_raw.ml" in -# 2886 "src/ocaml/preprocess/parser_raw.mly" +# 2890 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28445 "src/ocaml/preprocess/parser_raw.ml" +# 28449 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28466,29 +28470,29 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2902 "src/ocaml/preprocess/parser_raw.mly" +# 2906 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_tuple(List.rev _1) ) -# 28472 "src/ocaml/preprocess/parser_raw.ml" +# 28476 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28480 "src/ocaml/preprocess/parser_raw.ml" +# 28484 "src/ocaml/preprocess/parser_raw.ml" in -# 2909 "src/ocaml/preprocess/parser_raw.mly" +# 2913 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28486 "src/ocaml/preprocess/parser_raw.ml" +# 28490 "src/ocaml/preprocess/parser_raw.ml" in -# 2886 "src/ocaml/preprocess/parser_raw.mly" +# 2890 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28492 "src/ocaml/preprocess/parser_raw.ml" +# 28496 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28527,30 +28531,30 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2906 "src/ocaml/preprocess/parser_raw.mly" +# 2910 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_or(_1, _3) ) -# 28533 "src/ocaml/preprocess/parser_raw.ml" +# 28537 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28542 "src/ocaml/preprocess/parser_raw.ml" +# 28546 "src/ocaml/preprocess/parser_raw.ml" in -# 2909 "src/ocaml/preprocess/parser_raw.mly" +# 2913 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28548 "src/ocaml/preprocess/parser_raw.ml" +# 28552 "src/ocaml/preprocess/parser_raw.ml" in -# 2886 "src/ocaml/preprocess/parser_raw.mly" +# 2890 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28554 "src/ocaml/preprocess/parser_raw.ml" +# 28558 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28569,9 +28573,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 28575 "src/ocaml/preprocess/parser_raw.ml" +# 28579 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -28583,30 +28587,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28589 "src/ocaml/preprocess/parser_raw.ml" +# 28593 "src/ocaml/preprocess/parser_raw.ml" in -# 2344 "src/ocaml/preprocess/parser_raw.mly" +# 2348 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_var _1 ) -# 28595 "src/ocaml/preprocess/parser_raw.ml" +# 28599 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28604 "src/ocaml/preprocess/parser_raw.ml" +# 28608 "src/ocaml/preprocess/parser_raw.ml" in -# 2346 "src/ocaml/preprocess/parser_raw.mly" +# 2350 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28610 "src/ocaml/preprocess/parser_raw.ml" +# 28614 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28630,23 +28634,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2345 "src/ocaml/preprocess/parser_raw.mly" +# 2349 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_any ) -# 28636 "src/ocaml/preprocess/parser_raw.ml" +# 28640 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28644 "src/ocaml/preprocess/parser_raw.ml" +# 28648 "src/ocaml/preprocess/parser_raw.ml" in -# 2346 "src/ocaml/preprocess/parser_raw.mly" +# 2350 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28650 "src/ocaml/preprocess/parser_raw.ml" +# 28654 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28669,9 +28673,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.payload) = -# 4057 "src/ocaml/preprocess/parser_raw.mly" +# 4061 "src/ocaml/preprocess/parser_raw.mly" ( PStr _1 ) -# 28675 "src/ocaml/preprocess/parser_raw.ml" +# 28679 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28701,9 +28705,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4058 "src/ocaml/preprocess/parser_raw.mly" +# 4062 "src/ocaml/preprocess/parser_raw.mly" ( PSig _2 ) -# 28707 "src/ocaml/preprocess/parser_raw.ml" +# 28711 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28733,9 +28737,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4059 "src/ocaml/preprocess/parser_raw.mly" +# 4063 "src/ocaml/preprocess/parser_raw.mly" ( PTyp _2 ) -# 28739 "src/ocaml/preprocess/parser_raw.ml" +# 28743 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28765,9 +28769,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4060 "src/ocaml/preprocess/parser_raw.mly" +# 4064 "src/ocaml/preprocess/parser_raw.mly" ( PPat (_2, None) ) -# 28771 "src/ocaml/preprocess/parser_raw.ml" +# 28775 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28811,9 +28815,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.payload) = -# 4061 "src/ocaml/preprocess/parser_raw.mly" +# 4065 "src/ocaml/preprocess/parser_raw.mly" ( PPat (_2, Some _4) ) -# 28817 "src/ocaml/preprocess/parser_raw.ml" +# 28821 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28836,9 +28840,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3450 "src/ocaml/preprocess/parser_raw.mly" +# 3454 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28842 "src/ocaml/preprocess/parser_raw.ml" +# 28846 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28881,24 +28885,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 28885 "src/ocaml/preprocess/parser_raw.ml" +# 28889 "src/ocaml/preprocess/parser_raw.ml" in -# 1092 "src/ocaml/preprocess/parser_raw.mly" +# 1096 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 28890 "src/ocaml/preprocess/parser_raw.ml" +# 28894 "src/ocaml/preprocess/parser_raw.ml" in -# 3442 "src/ocaml/preprocess/parser_raw.mly" +# 3446 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28896 "src/ocaml/preprocess/parser_raw.ml" +# 28900 "src/ocaml/preprocess/parser_raw.ml" in -# 3446 "src/ocaml/preprocess/parser_raw.mly" +# 3450 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 28902 "src/ocaml/preprocess/parser_raw.ml" +# 28906 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_xs_) in @@ -28906,15 +28910,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 28912 "src/ocaml/preprocess/parser_raw.ml" +# 28916 "src/ocaml/preprocess/parser_raw.ml" in -# 3452 "src/ocaml/preprocess/parser_raw.mly" +# 3456 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28918 "src/ocaml/preprocess/parser_raw.ml" +# 28922 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28937,14 +28941,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = -# 3481 "src/ocaml/preprocess/parser_raw.mly" +# 3485 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28943 "src/ocaml/preprocess/parser_raw.ml" +# 28947 "src/ocaml/preprocess/parser_raw.ml" in -# 3450 "src/ocaml/preprocess/parser_raw.mly" +# 3454 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28948 "src/ocaml/preprocess/parser_raw.ml" +# 28952 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28983,33 +28987,33 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let _3 = -# 3481 "src/ocaml/preprocess/parser_raw.mly" +# 3485 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28989 "src/ocaml/preprocess/parser_raw.ml" +# 28993 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 28996 "src/ocaml/preprocess/parser_raw.ml" +# 29000 "src/ocaml/preprocess/parser_raw.ml" in -# 1092 "src/ocaml/preprocess/parser_raw.mly" +# 1096 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 29001 "src/ocaml/preprocess/parser_raw.ml" +# 29005 "src/ocaml/preprocess/parser_raw.ml" in -# 3442 "src/ocaml/preprocess/parser_raw.mly" +# 3446 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29007 "src/ocaml/preprocess/parser_raw.ml" +# 29011 "src/ocaml/preprocess/parser_raw.ml" in -# 3446 "src/ocaml/preprocess/parser_raw.mly" +# 3450 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 29013 "src/ocaml/preprocess/parser_raw.ml" +# 29017 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_xs_ in @@ -29017,15 +29021,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 29023 "src/ocaml/preprocess/parser_raw.ml" +# 29027 "src/ocaml/preprocess/parser_raw.ml" in -# 3452 "src/ocaml/preprocess/parser_raw.mly" +# 3456 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29029 "src/ocaml/preprocess/parser_raw.ml" +# 29033 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29072,9 +29076,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4018 "src/ocaml/preprocess/parser_raw.mly" +# 4022 "src/ocaml/preprocess/parser_raw.mly" ( Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 29078 "src/ocaml/preprocess/parser_raw.ml" +# 29082 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29155,9 +29159,9 @@ module Tables = struct let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29161 "src/ocaml/preprocess/parser_raw.ml" +# 29165 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -29167,30 +29171,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 29173 "src/ocaml/preprocess/parser_raw.ml" +# 29177 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29181 "src/ocaml/preprocess/parser_raw.ml" +# 29185 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3076 "src/ocaml/preprocess/parser_raw.mly" +# 3080 "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 ) -# 29194 "src/ocaml/preprocess/parser_raw.ml" +# 29198 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29206,14 +29210,14 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.private_flag) = let _1 = -# 3886 "src/ocaml/preprocess/parser_raw.mly" +# 3890 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 29212 "src/ocaml/preprocess/parser_raw.ml" +# 29216 "src/ocaml/preprocess/parser_raw.ml" in -# 3883 "src/ocaml/preprocess/parser_raw.mly" +# 3887 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29217 "src/ocaml/preprocess/parser_raw.ml" +# 29221 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29236,14 +29240,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = let _1 = -# 3887 "src/ocaml/preprocess/parser_raw.mly" +# 3891 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 29242 "src/ocaml/preprocess/parser_raw.ml" +# 29246 "src/ocaml/preprocess/parser_raw.ml" in -# 3883 "src/ocaml/preprocess/parser_raw.mly" +# 3887 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29247 "src/ocaml/preprocess/parser_raw.ml" +# 29251 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29259,9 +29263,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3909 "src/ocaml/preprocess/parser_raw.mly" +# 3913 "src/ocaml/preprocess/parser_raw.mly" ( Public, Concrete ) -# 29265 "src/ocaml/preprocess/parser_raw.ml" +# 29269 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29284,9 +29288,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 3914 "src/ocaml/preprocess/parser_raw.mly" ( Private, Concrete ) -# 29290 "src/ocaml/preprocess/parser_raw.ml" +# 29294 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29309,9 +29313,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3911 "src/ocaml/preprocess/parser_raw.mly" +# 3915 "src/ocaml/preprocess/parser_raw.mly" ( Public, Virtual ) -# 29315 "src/ocaml/preprocess/parser_raw.ml" +# 29319 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29341,9 +29345,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3912 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( Private, Virtual ) -# 29347 "src/ocaml/preprocess/parser_raw.ml" +# 29351 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29373,9 +29377,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3913 "src/ocaml/preprocess/parser_raw.mly" +# 3917 "src/ocaml/preprocess/parser_raw.mly" ( Private, Virtual ) -# 29379 "src/ocaml/preprocess/parser_raw.ml" +# 29383 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29391,9 +29395,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.rec_flag) = -# 3864 "src/ocaml/preprocess/parser_raw.mly" +# 3868 "src/ocaml/preprocess/parser_raw.mly" ( Nonrecursive ) -# 29397 "src/ocaml/preprocess/parser_raw.ml" +# 29401 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29416,9 +29420,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.rec_flag) = -# 3865 "src/ocaml/preprocess/parser_raw.mly" +# 3869 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 29422 "src/ocaml/preprocess/parser_raw.ml" +# 29426 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29444,12 +29448,12 @@ module Tables = struct (Longident.t Location.loc * Parsetree.expression) list) = let eo = # 124 "" ( None ) -# 29448 "src/ocaml/preprocess/parser_raw.ml" +# 29452 "src/ocaml/preprocess/parser_raw.ml" in -# 2811 "src/ocaml/preprocess/parser_raw.mly" +# 2815 "src/ocaml/preprocess/parser_raw.mly" ( eo, fields ) -# 29453 "src/ocaml/preprocess/parser_raw.ml" +# 29457 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29490,18 +29494,18 @@ module Tables = struct let x = # 191 "" ( x ) -# 29494 "src/ocaml/preprocess/parser_raw.ml" +# 29498 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 29499 "src/ocaml/preprocess/parser_raw.ml" +# 29503 "src/ocaml/preprocess/parser_raw.ml" in -# 2811 "src/ocaml/preprocess/parser_raw.mly" +# 2815 "src/ocaml/preprocess/parser_raw.mly" ( eo, fields ) -# 29505 "src/ocaml/preprocess/parser_raw.ml" +# 29509 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29526,17 +29530,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3263 "src/ocaml/preprocess/parser_raw.mly" +# 3267 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29535 "src/ocaml/preprocess/parser_raw.ml" +# 29539 "src/ocaml/preprocess/parser_raw.ml" in -# 1202 "src/ocaml/preprocess/parser_raw.mly" +# 1206 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29540 "src/ocaml/preprocess/parser_raw.ml" +# 29544 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29561,17 +29565,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3263 "src/ocaml/preprocess/parser_raw.mly" +# 3267 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29570 "src/ocaml/preprocess/parser_raw.ml" +# 29574 "src/ocaml/preprocess/parser_raw.ml" in -# 1205 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29575 "src/ocaml/preprocess/parser_raw.ml" +# 29579 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29603,17 +29607,17 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3263 "src/ocaml/preprocess/parser_raw.mly" +# 3267 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29612 "src/ocaml/preprocess/parser_raw.ml" +# 29616 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1213 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29617 "src/ocaml/preprocess/parser_raw.ml" +# 29621 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29639,23 +29643,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3380 "src/ocaml/preprocess/parser_raw.mly" +# 3384 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29648 "src/ocaml/preprocess/parser_raw.ml" +# 29652 "src/ocaml/preprocess/parser_raw.ml" in -# 3374 "src/ocaml/preprocess/parser_raw.mly" +# 3378 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29653 "src/ocaml/preprocess/parser_raw.ml" +# 29657 "src/ocaml/preprocess/parser_raw.ml" in -# 1202 "src/ocaml/preprocess/parser_raw.mly" +# 1206 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29659 "src/ocaml/preprocess/parser_raw.ml" +# 29663 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29678,14 +29682,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3376 "src/ocaml/preprocess/parser_raw.mly" +# 3380 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29684 "src/ocaml/preprocess/parser_raw.ml" +# 29688 "src/ocaml/preprocess/parser_raw.ml" in -# 1202 "src/ocaml/preprocess/parser_raw.mly" +# 1206 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29689 "src/ocaml/preprocess/parser_raw.ml" +# 29693 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29711,23 +29715,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3380 "src/ocaml/preprocess/parser_raw.mly" +# 3384 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29720 "src/ocaml/preprocess/parser_raw.ml" +# 29724 "src/ocaml/preprocess/parser_raw.ml" in -# 3374 "src/ocaml/preprocess/parser_raw.mly" +# 3378 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29725 "src/ocaml/preprocess/parser_raw.ml" +# 29729 "src/ocaml/preprocess/parser_raw.ml" in -# 1205 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29731 "src/ocaml/preprocess/parser_raw.ml" +# 29735 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29750,14 +29754,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3376 "src/ocaml/preprocess/parser_raw.mly" +# 3380 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29756 "src/ocaml/preprocess/parser_raw.ml" +# 29760 "src/ocaml/preprocess/parser_raw.ml" in -# 1205 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29761 "src/ocaml/preprocess/parser_raw.ml" +# 29765 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29790,23 +29794,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3380 "src/ocaml/preprocess/parser_raw.mly" +# 3384 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29799 "src/ocaml/preprocess/parser_raw.ml" +# 29803 "src/ocaml/preprocess/parser_raw.ml" in -# 3374 "src/ocaml/preprocess/parser_raw.mly" +# 3378 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29804 "src/ocaml/preprocess/parser_raw.ml" +# 29808 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1213 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29810 "src/ocaml/preprocess/parser_raw.ml" +# 29814 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29836,14 +29840,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3376 "src/ocaml/preprocess/parser_raw.mly" +# 3380 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29842 "src/ocaml/preprocess/parser_raw.ml" +# 29846 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1213 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29847 "src/ocaml/preprocess/parser_raw.ml" +# 29851 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29868,17 +29872,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3380 "src/ocaml/preprocess/parser_raw.mly" +# 3384 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29877 "src/ocaml/preprocess/parser_raw.ml" +# 29881 "src/ocaml/preprocess/parser_raw.ml" in -# 1202 "src/ocaml/preprocess/parser_raw.mly" +# 1206 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29882 "src/ocaml/preprocess/parser_raw.ml" +# 29886 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29903,17 +29907,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3380 "src/ocaml/preprocess/parser_raw.mly" +# 3384 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29912 "src/ocaml/preprocess/parser_raw.ml" +# 29916 "src/ocaml/preprocess/parser_raw.ml" in -# 1205 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29917 "src/ocaml/preprocess/parser_raw.ml" +# 29921 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29945,17 +29949,17 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3380 "src/ocaml/preprocess/parser_raw.mly" +# 3384 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29954 "src/ocaml/preprocess/parser_raw.ml" +# 29958 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1213 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29959 "src/ocaml/preprocess/parser_raw.ml" +# 29963 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29971,9 +29975,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = -# 1068 "src/ocaml/preprocess/parser_raw.mly" +# 1072 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 29977 "src/ocaml/preprocess/parser_raw.ml" +# 29981 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30030,21 +30034,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2224 "src/ocaml/preprocess/parser_raw.mly" +# 2228 "src/ocaml/preprocess/parser_raw.mly" ( _1, _3, make_loc _sloc ) -# 30036 "src/ocaml/preprocess/parser_raw.ml" +# 30040 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 30042 "src/ocaml/preprocess/parser_raw.ml" +# 30046 "src/ocaml/preprocess/parser_raw.ml" in -# 1070 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30048 "src/ocaml/preprocess/parser_raw.ml" +# 30052 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30067,9 +30071,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1082 "src/ocaml/preprocess/parser_raw.mly" +# 1086 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30073 "src/ocaml/preprocess/parser_raw.ml" +# 30077 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30099,9 +30103,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1084 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30105 "src/ocaml/preprocess/parser_raw.ml" +# 30109 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30124,9 +30128,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Asttypes.arg_label * Parsetree.expression) list) = -# 1082 "src/ocaml/preprocess/parser_raw.mly" +# 1086 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30130 "src/ocaml/preprocess/parser_raw.ml" +# 30134 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30156,9 +30160,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Asttypes.arg_label * Parsetree.expression) list) = -# 1084 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30162 "src/ocaml/preprocess/parser_raw.ml" +# 30166 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30181,9 +30185,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (string list) = -# 1082 "src/ocaml/preprocess/parser_raw.mly" +# 1086 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30187 "src/ocaml/preprocess/parser_raw.ml" +# 30191 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30213,9 +30217,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (string list) = -# 1084 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30219 "src/ocaml/preprocess/parser_raw.ml" +# 30223 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30251,21 +30255,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 30257 "src/ocaml/preprocess/parser_raw.ml" +# 30261 "src/ocaml/preprocess/parser_raw.ml" in -# 3438 "src/ocaml/preprocess/parser_raw.mly" +# 3442 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 30263 "src/ocaml/preprocess/parser_raw.ml" +# 30267 "src/ocaml/preprocess/parser_raw.ml" in -# 1082 "src/ocaml/preprocess/parser_raw.mly" +# 1086 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30269 "src/ocaml/preprocess/parser_raw.ml" +# 30273 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30308,21 +30312,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 30314 "src/ocaml/preprocess/parser_raw.ml" +# 30318 "src/ocaml/preprocess/parser_raw.ml" in -# 3438 "src/ocaml/preprocess/parser_raw.mly" +# 3442 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 30320 "src/ocaml/preprocess/parser_raw.ml" +# 30324 "src/ocaml/preprocess/parser_raw.ml" in -# 1084 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30326 "src/ocaml/preprocess/parser_raw.ml" +# 30330 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30347,12 +30351,12 @@ module Tables = struct let _v : (Parsetree.case list) = let _1 = # 124 "" ( None ) -# 30351 "src/ocaml/preprocess/parser_raw.ml" +# 30355 "src/ocaml/preprocess/parser_raw.ml" in -# 1173 "src/ocaml/preprocess/parser_raw.mly" +# 1177 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30356 "src/ocaml/preprocess/parser_raw.ml" +# 30360 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30386,13 +30390,13 @@ module Tables = struct # 126 "" ( Some x ) -# 30390 "src/ocaml/preprocess/parser_raw.ml" +# 30394 "src/ocaml/preprocess/parser_raw.ml" in -# 1173 "src/ocaml/preprocess/parser_raw.mly" +# 1177 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30396 "src/ocaml/preprocess/parser_raw.ml" +# 30400 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30429,9 +30433,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.case list) = -# 1177 "src/ocaml/preprocess/parser_raw.mly" +# 1181 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30435 "src/ocaml/preprocess/parser_raw.ml" +# 30439 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30455,20 +30459,20 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type list) = let xs = let x = -# 3481 "src/ocaml/preprocess/parser_raw.mly" +# 3485 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30461 "src/ocaml/preprocess/parser_raw.ml" +# 30465 "src/ocaml/preprocess/parser_raw.ml" in -# 1108 "src/ocaml/preprocess/parser_raw.mly" +# 1112 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30466 "src/ocaml/preprocess/parser_raw.ml" +# 30470 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30472 "src/ocaml/preprocess/parser_raw.ml" +# 30476 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30506,20 +30510,20 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type list) = let xs = let x = -# 3481 "src/ocaml/preprocess/parser_raw.mly" +# 3485 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30512 "src/ocaml/preprocess/parser_raw.ml" +# 30516 "src/ocaml/preprocess/parser_raw.ml" in -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1116 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30517 "src/ocaml/preprocess/parser_raw.ml" +# 30521 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30523 "src/ocaml/preprocess/parser_raw.ml" +# 30527 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30542,14 +30546,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.with_constraint list) = let xs = -# 1108 "src/ocaml/preprocess/parser_raw.mly" +# 1112 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30548 "src/ocaml/preprocess/parser_raw.ml" +# 30552 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30553 "src/ocaml/preprocess/parser_raw.ml" +# 30557 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30586,14 +30590,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.with_constraint list) = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1116 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30592 "src/ocaml/preprocess/parser_raw.ml" +# 30596 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30597 "src/ocaml/preprocess/parser_raw.ml" +# 30601 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30616,14 +30620,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.row_field list) = let xs = -# 1108 "src/ocaml/preprocess/parser_raw.mly" +# 1112 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30622 "src/ocaml/preprocess/parser_raw.ml" +# 30626 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30627 "src/ocaml/preprocess/parser_raw.ml" +# 30631 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30660,14 +30664,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.row_field list) = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1116 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30666 "src/ocaml/preprocess/parser_raw.ml" +# 30670 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30671 "src/ocaml/preprocess/parser_raw.ml" +# 30675 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30690,14 +30694,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1108 "src/ocaml/preprocess/parser_raw.mly" +# 1112 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30696 "src/ocaml/preprocess/parser_raw.ml" +# 30700 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30701 "src/ocaml/preprocess/parser_raw.ml" +# 30705 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30734,14 +30738,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1116 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30740 "src/ocaml/preprocess/parser_raw.ml" +# 30744 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30745 "src/ocaml/preprocess/parser_raw.ml" +# 30749 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30764,14 +30768,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = -# 1108 "src/ocaml/preprocess/parser_raw.mly" +# 1112 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30770 "src/ocaml/preprocess/parser_raw.ml" +# 30774 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30775 "src/ocaml/preprocess/parser_raw.ml" +# 30779 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30808,14 +30812,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1116 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30814 "src/ocaml/preprocess/parser_raw.ml" +# 30818 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30819 "src/ocaml/preprocess/parser_raw.ml" +# 30823 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30838,14 +30842,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1108 "src/ocaml/preprocess/parser_raw.mly" +# 1112 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30844 "src/ocaml/preprocess/parser_raw.ml" +# 30848 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30849 "src/ocaml/preprocess/parser_raw.ml" +# 30853 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30882,14 +30886,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1116 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30888 "src/ocaml/preprocess/parser_raw.ml" +# 30892 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30893 "src/ocaml/preprocess/parser_raw.ml" +# 30897 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30926,87 +30930,87 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = -# 1139 "src/ocaml/preprocess/parser_raw.mly" - ( x :: xs ) -# 30932 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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) = # 1143 "src/ocaml/preprocess/parser_raw.mly" - ( [ x2; x1 ] ) -# 30971 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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) = -# 1139 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31010 "src/ocaml/preprocess/parser_raw.ml" +# 30936 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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) = +# 1147 "src/ocaml/preprocess/parser_raw.mly" + ( [ x2; x1 ] ) +# 30975 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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) = +# 1143 "src/ocaml/preprocess/parser_raw.mly" + ( x :: xs ) +# 31014 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31043,9 +31047,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.expression list) = -# 1143 "src/ocaml/preprocess/parser_raw.mly" +# 1147 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31049 "src/ocaml/preprocess/parser_raw.ml" +# 31053 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31082,9 +31086,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = -# 1139 "src/ocaml/preprocess/parser_raw.mly" +# 1143 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31088 "src/ocaml/preprocess/parser_raw.ml" +# 31092 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31121,9 +31125,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.core_type list) = -# 1143 "src/ocaml/preprocess/parser_raw.mly" +# 1147 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31127 "src/ocaml/preprocess/parser_raw.ml" +# 31131 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31146,9 +31150,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.row_field) = -# 3621 "src/ocaml/preprocess/parser_raw.mly" +# 3625 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31152 "src/ocaml/preprocess/parser_raw.ml" +# 31156 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31174,9 +31178,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3623 "src/ocaml/preprocess/parser_raw.mly" +# 3627 "src/ocaml/preprocess/parser_raw.mly" ( Rf.inherit_ ~loc:(make_loc _sloc) _1 ) -# 31180 "src/ocaml/preprocess/parser_raw.ml" +# 31184 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31201,12 +31205,12 @@ module Tables = struct let _v : (Parsetree.expression list) = let _2 = # 124 "" ( None ) -# 31205 "src/ocaml/preprocess/parser_raw.ml" +# 31209 "src/ocaml/preprocess/parser_raw.ml" in -# 1160 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31210 "src/ocaml/preprocess/parser_raw.ml" +# 31214 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31240,13 +31244,13 @@ module Tables = struct # 126 "" ( Some x ) -# 31244 "src/ocaml/preprocess/parser_raw.ml" +# 31248 "src/ocaml/preprocess/parser_raw.ml" in -# 1160 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31250 "src/ocaml/preprocess/parser_raw.ml" +# 31254 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31283,9 +31287,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.expression list) = -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1168 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31289 "src/ocaml/preprocess/parser_raw.ml" +# 31293 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31311,9 +31315,9 @@ module Tables = struct } = _menhir_stack in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31317 "src/ocaml/preprocess/parser_raw.ml" +# 31321 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31321,26 +31325,26 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 31325 "src/ocaml/preprocess/parser_raw.ml" +# 31329 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31332 "src/ocaml/preprocess/parser_raw.ml" +# 31336 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31340 "src/ocaml/preprocess/parser_raw.ml" +# 31344 "src/ocaml/preprocess/parser_raw.ml" in -# 2834 "src/ocaml/preprocess/parser_raw.mly" +# 2838 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31350,13 +31354,13 @@ module Tables = struct label, e in label, e ) -# 31354 "src/ocaml/preprocess/parser_raw.ml" +# 31358 "src/ocaml/preprocess/parser_raw.ml" in -# 1160 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31360 "src/ocaml/preprocess/parser_raw.ml" +# 31364 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31389,9 +31393,9 @@ module Tables = struct let x : unit = Obj.magic x in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31395 "src/ocaml/preprocess/parser_raw.ml" +# 31399 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31399,26 +31403,26 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 31403 "src/ocaml/preprocess/parser_raw.ml" +# 31407 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31410 "src/ocaml/preprocess/parser_raw.ml" +# 31414 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31418 "src/ocaml/preprocess/parser_raw.ml" +# 31422 "src/ocaml/preprocess/parser_raw.ml" in -# 2834 "src/ocaml/preprocess/parser_raw.mly" +# 2838 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31428,13 +31432,13 @@ module Tables = struct label, e in label, e ) -# 31432 "src/ocaml/preprocess/parser_raw.ml" +# 31436 "src/ocaml/preprocess/parser_raw.ml" in -# 1160 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31438 "src/ocaml/preprocess/parser_raw.ml" +# 31442 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31474,9 +31478,9 @@ module Tables = struct let _2 : unit = Obj.magic _2 in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31480 "src/ocaml/preprocess/parser_raw.ml" +# 31484 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31484,21 +31488,21 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let x = let label = let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31490 "src/ocaml/preprocess/parser_raw.ml" +# 31494 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31498 "src/ocaml/preprocess/parser_raw.ml" +# 31502 "src/ocaml/preprocess/parser_raw.ml" in -# 2834 "src/ocaml/preprocess/parser_raw.mly" +# 2838 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31508,13 +31512,13 @@ module Tables = struct label, e in label, e ) -# 31512 "src/ocaml/preprocess/parser_raw.ml" +# 31516 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1168 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31518 "src/ocaml/preprocess/parser_raw.ml" +# 31522 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31539,12 +31543,12 @@ module Tables = struct let _v : (Parsetree.pattern list) = let _2 = # 124 "" ( None ) -# 31543 "src/ocaml/preprocess/parser_raw.ml" +# 31547 "src/ocaml/preprocess/parser_raw.ml" in -# 1160 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31548 "src/ocaml/preprocess/parser_raw.ml" +# 31552 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31578,13 +31582,13 @@ module Tables = struct # 126 "" ( Some x ) -# 31582 "src/ocaml/preprocess/parser_raw.ml" +# 31586 "src/ocaml/preprocess/parser_raw.ml" in -# 1160 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31588 "src/ocaml/preprocess/parser_raw.ml" +# 31592 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31621,9 +31625,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.pattern list) = -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1168 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31627 "src/ocaml/preprocess/parser_raw.ml" +# 31631 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31662,7 +31666,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 31666 "src/ocaml/preprocess/parser_raw.ml" +# 31670 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -31670,9 +31674,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31676 "src/ocaml/preprocess/parser_raw.ml" +# 31680 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -31680,7 +31684,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2817 "src/ocaml/preprocess/parser_raw.mly" +# 2821 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -31690,13 +31694,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 31694 "src/ocaml/preprocess/parser_raw.ml" +# 31698 "src/ocaml/preprocess/parser_raw.ml" in -# 1160 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31700 "src/ocaml/preprocess/parser_raw.ml" +# 31704 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31742,7 +31746,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 31746 "src/ocaml/preprocess/parser_raw.ml" +# 31750 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -31750,9 +31754,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31756 "src/ocaml/preprocess/parser_raw.ml" +# 31760 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -31760,7 +31764,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2817 "src/ocaml/preprocess/parser_raw.mly" +# 2821 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -31770,13 +31774,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 31774 "src/ocaml/preprocess/parser_raw.ml" +# 31778 "src/ocaml/preprocess/parser_raw.ml" in -# 1160 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31780 "src/ocaml/preprocess/parser_raw.ml" +# 31784 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31832,9 +31836,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31838 "src/ocaml/preprocess/parser_raw.ml" +# 31842 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -31842,7 +31846,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2817 "src/ocaml/preprocess/parser_raw.mly" +# 2821 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -31852,13 +31856,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 31856 "src/ocaml/preprocess/parser_raw.ml" +# 31860 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1168 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31862 "src/ocaml/preprocess/parser_raw.ml" +# 31866 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31881,9 +31885,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2313 "src/ocaml/preprocess/parser_raw.mly" +# 2317 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31887 "src/ocaml/preprocess/parser_raw.ml" +# 31891 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31913,9 +31917,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2314 "src/ocaml/preprocess/parser_raw.mly" +# 2318 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31919 "src/ocaml/preprocess/parser_raw.ml" +# 31923 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31953,24 +31957,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2316 "src/ocaml/preprocess/parser_raw.mly" +# 2320 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_sequence(_1, _3) ) -# 31959 "src/ocaml/preprocess/parser_raw.ml" +# 31963 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 31968 "src/ocaml/preprocess/parser_raw.ml" +# 31972 "src/ocaml/preprocess/parser_raw.ml" in -# 2317 "src/ocaml/preprocess/parser_raw.mly" +# 2321 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31974 "src/ocaml/preprocess/parser_raw.ml" +# 31978 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32024,11 +32028,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2319 "src/ocaml/preprocess/parser_raw.mly" +# 2323 "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)) ) -# 32032 "src/ocaml/preprocess/parser_raw.ml" +# 32036 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32096,18 +32100,18 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = let attrs = let _1 = _1_inlined4 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32102 "src/ocaml/preprocess/parser_raw.ml" +# 32106 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined4_ in let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32111 "src/ocaml/preprocess/parser_raw.ml" +# 32115 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -32117,17 +32121,17 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32123 "src/ocaml/preprocess/parser_raw.ml" +# 32127 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32131 "src/ocaml/preprocess/parser_raw.ml" +# 32135 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in @@ -32135,14 +32139,14 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3293 "src/ocaml/preprocess/parser_raw.mly" +# 3297 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let loc = make_loc (_startpos, _endpos_attrs2_) in let docs = symbol_docs _sloc in Te.mk_exception ~attrs (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) , ext ) -# 32146 "src/ocaml/preprocess/parser_raw.ml" +# 32150 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32168,21 +32172,21 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 32172 "src/ocaml/preprocess/parser_raw.ml" +# 32176 "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 -# 983 "src/ocaml/preprocess/parser_raw.mly" +# 987 "src/ocaml/preprocess/parser_raw.mly" ( extra_sig _startpos _endpos _1 ) -# 32180 "src/ocaml/preprocess/parser_raw.ml" +# 32184 "src/ocaml/preprocess/parser_raw.ml" in -# 1752 "src/ocaml/preprocess/parser_raw.mly" +# 1756 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32186 "src/ocaml/preprocess/parser_raw.ml" +# 32190 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32214,9 +32218,9 @@ module Tables = struct let _v : (Parsetree.signature_item) = let _2 = let _1 = _1_inlined1 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32220 "src/ocaml/preprocess/parser_raw.ml" +# 32224 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -32224,10 +32228,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1767 "src/ocaml/preprocess/parser_raw.mly" +# 1771 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mksig ~loc:_sloc (Psig_extension (_1, (add_docs_attrs docs _2))) ) -# 32231 "src/ocaml/preprocess/parser_raw.ml" +# 32235 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32251,23 +32255,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1771 "src/ocaml/preprocess/parser_raw.mly" +# 1775 "src/ocaml/preprocess/parser_raw.mly" ( Psig_attribute _1 ) -# 32257 "src/ocaml/preprocess/parser_raw.ml" +# 32261 "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" +# 1035 "src/ocaml/preprocess/parser_raw.mly" ( mksig ~loc:_sloc _1 ) -# 32265 "src/ocaml/preprocess/parser_raw.ml" +# 32269 "src/ocaml/preprocess/parser_raw.ml" in -# 1773 "src/ocaml/preprocess/parser_raw.mly" +# 1777 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32271 "src/ocaml/preprocess/parser_raw.ml" +# 32275 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32291,23 +32295,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1776 "src/ocaml/preprocess/parser_raw.mly" +# 1780 "src/ocaml/preprocess/parser_raw.mly" ( psig_value _1 ) -# 32297 "src/ocaml/preprocess/parser_raw.ml" +# 32301 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32305 "src/ocaml/preprocess/parser_raw.ml" +# 32309 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32311 "src/ocaml/preprocess/parser_raw.ml" +# 32315 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32331,23 +32335,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1778 "src/ocaml/preprocess/parser_raw.mly" +# 1782 "src/ocaml/preprocess/parser_raw.mly" ( psig_value _1 ) -# 32337 "src/ocaml/preprocess/parser_raw.ml" +# 32341 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32345 "src/ocaml/preprocess/parser_raw.ml" +# 32349 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32351 "src/ocaml/preprocess/parser_raw.ml" +# 32355 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32382,26 +32386,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1221 "src/ocaml/preprocess/parser_raw.mly" +# 1225 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 32388 "src/ocaml/preprocess/parser_raw.ml" +# 32392 "src/ocaml/preprocess/parser_raw.ml" in -# 3112 "src/ocaml/preprocess/parser_raw.mly" +# 3116 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32393 "src/ocaml/preprocess/parser_raw.ml" +# 32397 "src/ocaml/preprocess/parser_raw.ml" in -# 3095 "src/ocaml/preprocess/parser_raw.mly" +# 3099 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32399 "src/ocaml/preprocess/parser_raw.ml" +# 32403 "src/ocaml/preprocess/parser_raw.ml" in -# 1780 "src/ocaml/preprocess/parser_raw.mly" +# 1784 "src/ocaml/preprocess/parser_raw.mly" ( psig_type _1 ) -# 32405 "src/ocaml/preprocess/parser_raw.ml" +# 32409 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -32409,15 +32413,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32415 "src/ocaml/preprocess/parser_raw.ml" +# 32419 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32421 "src/ocaml/preprocess/parser_raw.ml" +# 32425 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32452,26 +32456,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1221 "src/ocaml/preprocess/parser_raw.mly" +# 1225 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 32458 "src/ocaml/preprocess/parser_raw.ml" +# 32462 "src/ocaml/preprocess/parser_raw.ml" in -# 3112 "src/ocaml/preprocess/parser_raw.mly" +# 3116 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32463 "src/ocaml/preprocess/parser_raw.ml" +# 32467 "src/ocaml/preprocess/parser_raw.ml" in -# 3100 "src/ocaml/preprocess/parser_raw.mly" +# 3104 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32469 "src/ocaml/preprocess/parser_raw.ml" +# 32473 "src/ocaml/preprocess/parser_raw.ml" in -# 1782 "src/ocaml/preprocess/parser_raw.mly" +# 1786 "src/ocaml/preprocess/parser_raw.mly" ( psig_typesubst _1 ) -# 32475 "src/ocaml/preprocess/parser_raw.ml" +# 32479 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -32479,15 +32483,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32485 "src/ocaml/preprocess/parser_raw.ml" +# 32489 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32491 "src/ocaml/preprocess/parser_raw.ml" +# 32495 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32572,16 +32576,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32578 "src/ocaml/preprocess/parser_raw.ml" +# 32582 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = -# 1213 "src/ocaml/preprocess/parser_raw.mly" +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 32585 "src/ocaml/preprocess/parser_raw.ml" +# 32589 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -32589,46 +32593,46 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32595 "src/ocaml/preprocess/parser_raw.ml" +# 32599 "src/ocaml/preprocess/parser_raw.ml" in let _4 = -# 3872 "src/ocaml/preprocess/parser_raw.mly" +# 3876 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 32601 "src/ocaml/preprocess/parser_raw.ml" +# 32605 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32608 "src/ocaml/preprocess/parser_raw.ml" +# 32612 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3367 "src/ocaml/preprocess/parser_raw.mly" +# 3371 "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 ) -# 32620 "src/ocaml/preprocess/parser_raw.ml" +# 32624 "src/ocaml/preprocess/parser_raw.ml" in -# 3354 "src/ocaml/preprocess/parser_raw.mly" +# 3358 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32626 "src/ocaml/preprocess/parser_raw.ml" +# 32630 "src/ocaml/preprocess/parser_raw.ml" in -# 1784 "src/ocaml/preprocess/parser_raw.mly" +# 1788 "src/ocaml/preprocess/parser_raw.mly" ( psig_typext _1 ) -# 32632 "src/ocaml/preprocess/parser_raw.ml" +# 32636 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -32636,15 +32640,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32642 "src/ocaml/preprocess/parser_raw.ml" +# 32646 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32648 "src/ocaml/preprocess/parser_raw.ml" +# 32652 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32736,16 +32740,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32742 "src/ocaml/preprocess/parser_raw.ml" +# 32746 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = -# 1213 "src/ocaml/preprocess/parser_raw.mly" +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 32749 "src/ocaml/preprocess/parser_raw.ml" +# 32753 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -32753,9 +32757,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32759 "src/ocaml/preprocess/parser_raw.ml" +# 32763 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -32764,41 +32768,41 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3874 "src/ocaml/preprocess/parser_raw.mly" +# 3878 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 32770 "src/ocaml/preprocess/parser_raw.ml" +# 32774 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32778 "src/ocaml/preprocess/parser_raw.ml" +# 32782 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3367 "src/ocaml/preprocess/parser_raw.mly" +# 3371 "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 ) -# 32790 "src/ocaml/preprocess/parser_raw.ml" +# 32794 "src/ocaml/preprocess/parser_raw.ml" in -# 3354 "src/ocaml/preprocess/parser_raw.mly" +# 3358 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32796 "src/ocaml/preprocess/parser_raw.ml" +# 32800 "src/ocaml/preprocess/parser_raw.ml" in -# 1784 "src/ocaml/preprocess/parser_raw.mly" +# 1788 "src/ocaml/preprocess/parser_raw.mly" ( psig_typext _1 ) -# 32802 "src/ocaml/preprocess/parser_raw.ml" +# 32806 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -32806,15 +32810,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32812 "src/ocaml/preprocess/parser_raw.ml" +# 32816 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32818 "src/ocaml/preprocess/parser_raw.ml" +# 32822 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32838,23 +32842,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1786 "src/ocaml/preprocess/parser_raw.mly" +# 1790 "src/ocaml/preprocess/parser_raw.mly" ( psig_exception _1 ) -# 32844 "src/ocaml/preprocess/parser_raw.ml" +# 32848 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32852 "src/ocaml/preprocess/parser_raw.ml" +# 32856 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32858 "src/ocaml/preprocess/parser_raw.ml" +# 32862 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32917,9 +32921,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32923 "src/ocaml/preprocess/parser_raw.ml" +# 32927 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -32929,37 +32933,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32935 "src/ocaml/preprocess/parser_raw.ml" +# 32939 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32943 "src/ocaml/preprocess/parser_raw.ml" +# 32947 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1817 "src/ocaml/preprocess/parser_raw.mly" +# 1821 "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 ) -# 32957 "src/ocaml/preprocess/parser_raw.ml" +# 32961 "src/ocaml/preprocess/parser_raw.ml" in -# 1788 "src/ocaml/preprocess/parser_raw.mly" +# 1792 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 32963 "src/ocaml/preprocess/parser_raw.ml" +# 32967 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -32967,15 +32971,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32973 "src/ocaml/preprocess/parser_raw.ml" +# 32977 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32979 "src/ocaml/preprocess/parser_raw.ml" +# 32983 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33045,9 +33049,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33051 "src/ocaml/preprocess/parser_raw.ml" +# 33055 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -33058,9 +33062,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33064 "src/ocaml/preprocess/parser_raw.ml" +# 33068 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos_id_, _startpos_id_) = (_endpos__1_, _startpos__1_) in @@ -33068,9 +33072,9 @@ module Tables = struct let _symbolstartpos = _startpos_id_ in let _sloc = (_symbolstartpos, _endpos) in -# 1854 "src/ocaml/preprocess/parser_raw.mly" +# 1858 "src/ocaml/preprocess/parser_raw.mly" ( Mty.alias ~loc:(make_loc _sloc) id ) -# 33074 "src/ocaml/preprocess/parser_raw.ml" +# 33078 "src/ocaml/preprocess/parser_raw.ml" in let name = @@ -33079,37 +33083,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33085 "src/ocaml/preprocess/parser_raw.ml" +# 33089 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33093 "src/ocaml/preprocess/parser_raw.ml" +# 33097 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1845 "src/ocaml/preprocess/parser_raw.mly" +# 1849 "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 ) -# 33107 "src/ocaml/preprocess/parser_raw.ml" +# 33111 "src/ocaml/preprocess/parser_raw.ml" in -# 1790 "src/ocaml/preprocess/parser_raw.mly" +# 1794 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 33113 "src/ocaml/preprocess/parser_raw.ml" +# 33117 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -33117,15 +33121,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33123 "src/ocaml/preprocess/parser_raw.ml" +# 33127 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33129 "src/ocaml/preprocess/parser_raw.ml" +# 33133 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33149,23 +33153,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1792 "src/ocaml/preprocess/parser_raw.mly" +# 1796 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modsubst body, ext) ) -# 33155 "src/ocaml/preprocess/parser_raw.ml" +# 33159 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33163 "src/ocaml/preprocess/parser_raw.ml" +# 33167 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33169 "src/ocaml/preprocess/parser_raw.ml" +# 33173 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33251,9 +33255,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33257 "src/ocaml/preprocess/parser_raw.ml" +# 33261 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -33263,49 +33267,49 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33269 "src/ocaml/preprocess/parser_raw.ml" +# 33273 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33277 "src/ocaml/preprocess/parser_raw.ml" +# 33281 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1890 "src/ocaml/preprocess/parser_raw.mly" +# 1894 "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 ) -# 33291 "src/ocaml/preprocess/parser_raw.ml" +# 33295 "src/ocaml/preprocess/parser_raw.ml" in -# 1221 "src/ocaml/preprocess/parser_raw.mly" +# 1225 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 33297 "src/ocaml/preprocess/parser_raw.ml" +# 33301 "src/ocaml/preprocess/parser_raw.ml" in -# 1879 "src/ocaml/preprocess/parser_raw.mly" +# 1883 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33303 "src/ocaml/preprocess/parser_raw.ml" +# 33307 "src/ocaml/preprocess/parser_raw.ml" in -# 1794 "src/ocaml/preprocess/parser_raw.mly" +# 1798 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_recmodule l, ext) ) -# 33309 "src/ocaml/preprocess/parser_raw.ml" +# 33313 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -33313,15 +33317,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33319 "src/ocaml/preprocess/parser_raw.ml" +# 33323 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33325 "src/ocaml/preprocess/parser_raw.ml" +# 33329 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33345,23 +33349,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1796 "src/ocaml/preprocess/parser_raw.mly" +# 1800 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modtype body, ext) ) -# 33351 "src/ocaml/preprocess/parser_raw.ml" +# 33355 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33359 "src/ocaml/preprocess/parser_raw.ml" +# 33363 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33365 "src/ocaml/preprocess/parser_raw.ml" +# 33369 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33385,23 +33389,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1798 "src/ocaml/preprocess/parser_raw.mly" +# 1802 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modtypesubst body, ext) ) -# 33391 "src/ocaml/preprocess/parser_raw.ml" +# 33395 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33399 "src/ocaml/preprocess/parser_raw.ml" +# 33403 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33405 "src/ocaml/preprocess/parser_raw.ml" +# 33409 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33425,23 +33429,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1800 "src/ocaml/preprocess/parser_raw.mly" +# 1804 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_open body, ext) ) -# 33431 "src/ocaml/preprocess/parser_raw.ml" +# 33435 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33439 "src/ocaml/preprocess/parser_raw.ml" +# 33443 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33445 "src/ocaml/preprocess/parser_raw.ml" +# 33449 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33497,38 +33501,38 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33503 "src/ocaml/preprocess/parser_raw.ml" +# 33507 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33512 "src/ocaml/preprocess/parser_raw.ml" +# 33516 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1640 "src/ocaml/preprocess/parser_raw.mly" +# 1644 "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 ) -# 33526 "src/ocaml/preprocess/parser_raw.ml" +# 33530 "src/ocaml/preprocess/parser_raw.ml" in -# 1802 "src/ocaml/preprocess/parser_raw.mly" +# 1806 "src/ocaml/preprocess/parser_raw.mly" ( psig_include _1 ) -# 33532 "src/ocaml/preprocess/parser_raw.ml" +# 33536 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -33536,15 +33540,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33542 "src/ocaml/preprocess/parser_raw.ml" +# 33546 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33548 "src/ocaml/preprocess/parser_raw.ml" +# 33552 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33621,9 +33625,9 @@ module Tables = struct let cty : (Parsetree.class_type) = Obj.magic cty in let _7 : unit = Obj.magic _7 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 33627 "src/ocaml/preprocess/parser_raw.ml" +# 33631 "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 @@ -33641,9 +33645,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33647 "src/ocaml/preprocess/parser_raw.ml" +# 33651 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -33653,24 +33657,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33659 "src/ocaml/preprocess/parser_raw.ml" +# 33663 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33667 "src/ocaml/preprocess/parser_raw.ml" +# 33671 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2245 "src/ocaml/preprocess/parser_raw.mly" +# 2249 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -33678,25 +33682,25 @@ module Tables = struct ext, Ci.mk id cty ~virt ~params ~attrs ~loc ~docs ) -# 33682 "src/ocaml/preprocess/parser_raw.ml" +# 33686 "src/ocaml/preprocess/parser_raw.ml" in -# 1221 "src/ocaml/preprocess/parser_raw.mly" +# 1225 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 33688 "src/ocaml/preprocess/parser_raw.ml" +# 33692 "src/ocaml/preprocess/parser_raw.ml" in -# 2233 "src/ocaml/preprocess/parser_raw.mly" +# 2237 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33694 "src/ocaml/preprocess/parser_raw.ml" +# 33698 "src/ocaml/preprocess/parser_raw.ml" in -# 1804 "src/ocaml/preprocess/parser_raw.mly" +# 1808 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_class l, ext) ) -# 33700 "src/ocaml/preprocess/parser_raw.ml" +# 33704 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -33704,15 +33708,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33710 "src/ocaml/preprocess/parser_raw.ml" +# 33714 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33716 "src/ocaml/preprocess/parser_raw.ml" +# 33720 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33736,23 +33740,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1806 "src/ocaml/preprocess/parser_raw.mly" +# 1810 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_class_type l, ext) ) -# 33742 "src/ocaml/preprocess/parser_raw.ml" +# 33746 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1048 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33750 "src/ocaml/preprocess/parser_raw.ml" +# 33754 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33756 "src/ocaml/preprocess/parser_raw.ml" +# 33760 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33775,9 +33779,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constant) = -# 3697 "src/ocaml/preprocess/parser_raw.mly" +# 3701 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33781 "src/ocaml/preprocess/parser_raw.ml" +# 33785 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33802,18 +33806,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 783 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33808 "src/ocaml/preprocess/parser_raw.ml" +# 33812 "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) = -# 3698 "src/ocaml/preprocess/parser_raw.mly" +# 3702 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _2 in Pconst_integer("-" ^ n, m) ) -# 33817 "src/ocaml/preprocess/parser_raw.ml" +# 33821 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33838,18 +33842,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 758 "src/ocaml/preprocess/parser_raw.mly" +# 762 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33844 "src/ocaml/preprocess/parser_raw.ml" +# 33848 "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) = -# 3699 "src/ocaml/preprocess/parser_raw.mly" +# 3703 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _2 in Pconst_float("-" ^ f, m) ) -# 33853 "src/ocaml/preprocess/parser_raw.ml" +# 33857 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33874,18 +33878,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 783 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33880 "src/ocaml/preprocess/parser_raw.ml" +# 33884 "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) = -# 3700 "src/ocaml/preprocess/parser_raw.mly" +# 3704 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _2 in Pconst_integer (n, m) ) -# 33889 "src/ocaml/preprocess/parser_raw.ml" +# 33893 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33910,18 +33914,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 758 "src/ocaml/preprocess/parser_raw.mly" +# 762 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33916 "src/ocaml/preprocess/parser_raw.ml" +# 33920 "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) = -# 3701 "src/ocaml/preprocess/parser_raw.mly" +# 3705 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _2 in Pconst_float(f, m) ) -# 33925 "src/ocaml/preprocess/parser_raw.ml" +# 33929 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33962,18 +33966,18 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 3024 "src/ocaml/preprocess/parser_raw.mly" +# 3028 "src/ocaml/preprocess/parser_raw.mly" ( let fields, closed = _1 in let closed = match closed with Some () -> Open | None -> Closed in fields, closed ) -# 33970 "src/ocaml/preprocess/parser_raw.ml" +# 33974 "src/ocaml/preprocess/parser_raw.ml" in -# 2995 "src/ocaml/preprocess/parser_raw.mly" +# 2999 "src/ocaml/preprocess/parser_raw.mly" ( let (fields, closed) = _2 in Ppat_record(fields, closed) ) -# 33977 "src/ocaml/preprocess/parser_raw.ml" +# 33981 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -33981,15 +33985,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 33987 "src/ocaml/preprocess/parser_raw.ml" +# 33991 "src/ocaml/preprocess/parser_raw.ml" in -# 3009 "src/ocaml/preprocess/parser_raw.mly" +# 3013 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33993 "src/ocaml/preprocess/parser_raw.ml" +# 33997 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34028,15 +34032,15 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _2 = -# 3018 "src/ocaml/preprocess/parser_raw.mly" +# 3022 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 34034 "src/ocaml/preprocess/parser_raw.ml" +# 34038 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 3000 "src/ocaml/preprocess/parser_raw.mly" +# 3004 "src/ocaml/preprocess/parser_raw.mly" ( fst (mktailpat _loc__3_ _2) ) -# 34040 "src/ocaml/preprocess/parser_raw.ml" +# 34044 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34044,15 +34048,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34050 "src/ocaml/preprocess/parser_raw.ml" +# 34054 "src/ocaml/preprocess/parser_raw.ml" in -# 3009 "src/ocaml/preprocess/parser_raw.mly" +# 3013 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34056 "src/ocaml/preprocess/parser_raw.ml" +# 34060 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34091,14 +34095,14 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _2 = -# 3018 "src/ocaml/preprocess/parser_raw.mly" +# 3022 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 34097 "src/ocaml/preprocess/parser_raw.ml" +# 34101 "src/ocaml/preprocess/parser_raw.ml" in -# 3004 "src/ocaml/preprocess/parser_raw.mly" +# 3008 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_array _2 ) -# 34102 "src/ocaml/preprocess/parser_raw.ml" +# 34106 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34106,15 +34110,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34112 "src/ocaml/preprocess/parser_raw.ml" +# 34116 "src/ocaml/preprocess/parser_raw.ml" in -# 3009 "src/ocaml/preprocess/parser_raw.mly" +# 3013 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34118 "src/ocaml/preprocess/parser_raw.ml" +# 34122 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34145,24 +34149,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3006 "src/ocaml/preprocess/parser_raw.mly" +# 3010 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_array [] ) -# 34151 "src/ocaml/preprocess/parser_raw.ml" +# 34155 "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 -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34160 "src/ocaml/preprocess/parser_raw.ml" +# 34164 "src/ocaml/preprocess/parser_raw.ml" in -# 3009 "src/ocaml/preprocess/parser_raw.mly" +# 3013 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34166 "src/ocaml/preprocess/parser_raw.ml" +# 34170 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34201,9 +34205,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in let _startpos = _startpos__1_ in -# 4066 "src/ocaml/preprocess/parser_raw.mly" +# 4070 "src/ocaml/preprocess/parser_raw.mly" ( Fake.Meta.code _startpos _endpos _2 ) -# 34207 "src/ocaml/preprocess/parser_raw.ml" +# 34211 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34235,9 +34239,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _endpos = _endpos__2_ in let _startpos = _startpos__1_ in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4072 "src/ocaml/preprocess/parser_raw.mly" ( Fake.Meta.uncode _startpos _endpos _2 ) -# 34241 "src/ocaml/preprocess/parser_raw.ml" +# 34245 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34277,9 +34281,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2485 "src/ocaml/preprocess/parser_raw.mly" +# 2489 "src/ocaml/preprocess/parser_raw.mly" ( reloc_exp ~loc:_sloc _2 ) -# 34283 "src/ocaml/preprocess/parser_raw.ml" +# 34287 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34326,9 +34330,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2491 "src/ocaml/preprocess/parser_raw.mly" +# 2495 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_constraint ~loc:_sloc _2 _3 ) -# 34332 "src/ocaml/preprocess/parser_raw.ml" +# 34336 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34380,14 +34384,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2492 "src/ocaml/preprocess/parser_raw.mly" +# 2496 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34386 "src/ocaml/preprocess/parser_raw.ml" +# 34390 "src/ocaml/preprocess/parser_raw.ml" in -# 2375 "src/ocaml/preprocess/parser_raw.mly" +# 2379 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 34391 "src/ocaml/preprocess/parser_raw.ml" +# 34395 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34395,9 +34399,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2493 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34401 "src/ocaml/preprocess/parser_raw.ml" +# 34405 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34449,14 +34453,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2492 "src/ocaml/preprocess/parser_raw.mly" +# 2496 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34455 "src/ocaml/preprocess/parser_raw.ml" +# 34459 "src/ocaml/preprocess/parser_raw.ml" in -# 2377 "src/ocaml/preprocess/parser_raw.mly" +# 2381 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 34460 "src/ocaml/preprocess/parser_raw.ml" +# 34464 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34464,9 +34468,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2493 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34470 "src/ocaml/preprocess/parser_raw.ml" +# 34474 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34518,14 +34522,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2492 "src/ocaml/preprocess/parser_raw.mly" +# 2496 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34524 "src/ocaml/preprocess/parser_raw.ml" +# 34528 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2383 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 34529 "src/ocaml/preprocess/parser_raw.ml" +# 34533 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34533,9 +34537,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2493 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34539 "src/ocaml/preprocess/parser_raw.ml" +# 34543 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34581,9 +34585,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34587 "src/ocaml/preprocess/parser_raw.ml" +# 34591 "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 @@ -34591,31 +34595,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2494 "src/ocaml/preprocess/parser_raw.mly" +# 2498 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34597 "src/ocaml/preprocess/parser_raw.ml" +# 34601 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34602 "src/ocaml/preprocess/parser_raw.ml" +# 34606 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 34608 "src/ocaml/preprocess/parser_raw.ml" +# 34612 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34613 "src/ocaml/preprocess/parser_raw.ml" +# 34617 "src/ocaml/preprocess/parser_raw.ml" in -# 2375 "src/ocaml/preprocess/parser_raw.mly" +# 2379 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 34619 "src/ocaml/preprocess/parser_raw.ml" +# 34623 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34623,9 +34627,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2495 "src/ocaml/preprocess/parser_raw.mly" +# 2499 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34629 "src/ocaml/preprocess/parser_raw.ml" +# 34633 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34683,9 +34687,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34689 "src/ocaml/preprocess/parser_raw.ml" +# 34693 "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 @@ -34695,39 +34699,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2494 "src/ocaml/preprocess/parser_raw.mly" +# 2498 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34701 "src/ocaml/preprocess/parser_raw.ml" +# 34705 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34706 "src/ocaml/preprocess/parser_raw.ml" +# 34710 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 34714 "src/ocaml/preprocess/parser_raw.ml" +# 34718 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 34719 "src/ocaml/preprocess/parser_raw.ml" +# 34723 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34725 "src/ocaml/preprocess/parser_raw.ml" +# 34729 "src/ocaml/preprocess/parser_raw.ml" in -# 2375 "src/ocaml/preprocess/parser_raw.mly" +# 2379 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 34731 "src/ocaml/preprocess/parser_raw.ml" +# 34735 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34735,9 +34739,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2495 "src/ocaml/preprocess/parser_raw.mly" +# 2499 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34741 "src/ocaml/preprocess/parser_raw.ml" +# 34745 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34783,9 +34787,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34789 "src/ocaml/preprocess/parser_raw.ml" +# 34793 "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 @@ -34793,31 +34797,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2494 "src/ocaml/preprocess/parser_raw.mly" +# 2498 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34799 "src/ocaml/preprocess/parser_raw.ml" +# 34803 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34804 "src/ocaml/preprocess/parser_raw.ml" +# 34808 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 34810 "src/ocaml/preprocess/parser_raw.ml" +# 34814 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34815 "src/ocaml/preprocess/parser_raw.ml" +# 34819 "src/ocaml/preprocess/parser_raw.ml" in -# 2377 "src/ocaml/preprocess/parser_raw.mly" +# 2381 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 34821 "src/ocaml/preprocess/parser_raw.ml" +# 34825 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34825,9 +34829,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2495 "src/ocaml/preprocess/parser_raw.mly" +# 2499 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34831 "src/ocaml/preprocess/parser_raw.ml" +# 34835 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34885,9 +34889,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34891 "src/ocaml/preprocess/parser_raw.ml" +# 34895 "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 @@ -34897,39 +34901,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2494 "src/ocaml/preprocess/parser_raw.mly" +# 2498 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34903 "src/ocaml/preprocess/parser_raw.ml" +# 34907 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34908 "src/ocaml/preprocess/parser_raw.ml" +# 34912 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 34916 "src/ocaml/preprocess/parser_raw.ml" +# 34920 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 34921 "src/ocaml/preprocess/parser_raw.ml" +# 34925 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34927 "src/ocaml/preprocess/parser_raw.ml" +# 34931 "src/ocaml/preprocess/parser_raw.ml" in -# 2377 "src/ocaml/preprocess/parser_raw.mly" +# 2381 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 34933 "src/ocaml/preprocess/parser_raw.ml" +# 34937 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34937,9 +34941,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2495 "src/ocaml/preprocess/parser_raw.mly" +# 2499 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34943 "src/ocaml/preprocess/parser_raw.ml" +# 34947 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34985,9 +34989,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34991 "src/ocaml/preprocess/parser_raw.ml" +# 34995 "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 @@ -34995,31 +34999,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2494 "src/ocaml/preprocess/parser_raw.mly" +# 2498 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35001 "src/ocaml/preprocess/parser_raw.ml" +# 35005 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35006 "src/ocaml/preprocess/parser_raw.ml" +# 35010 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 35012 "src/ocaml/preprocess/parser_raw.ml" +# 35016 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35017 "src/ocaml/preprocess/parser_raw.ml" +# 35021 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2383 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35023 "src/ocaml/preprocess/parser_raw.ml" +# 35027 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35027,9 +35031,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2495 "src/ocaml/preprocess/parser_raw.mly" +# 2499 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35033 "src/ocaml/preprocess/parser_raw.ml" +# 35037 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35087,9 +35091,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35093 "src/ocaml/preprocess/parser_raw.ml" +# 35097 "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 @@ -35099,39 +35103,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2494 "src/ocaml/preprocess/parser_raw.mly" +# 2498 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35105 "src/ocaml/preprocess/parser_raw.ml" +# 35109 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35110 "src/ocaml/preprocess/parser_raw.ml" +# 35114 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 35118 "src/ocaml/preprocess/parser_raw.ml" +# 35122 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 35123 "src/ocaml/preprocess/parser_raw.ml" +# 35127 "src/ocaml/preprocess/parser_raw.ml" in -# 2391 "src/ocaml/preprocess/parser_raw.mly" +# 2395 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35129 "src/ocaml/preprocess/parser_raw.ml" +# 35133 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2383 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35135 "src/ocaml/preprocess/parser_raw.ml" +# 35139 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35139,9 +35143,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2495 "src/ocaml/preprocess/parser_raw.mly" +# 2499 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35145 "src/ocaml/preprocess/parser_raw.ml" +# 35149 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35195,15 +35199,15 @@ module Tables = struct let attrs = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35201 "src/ocaml/preprocess/parser_raw.ml" +# 35205 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2512 "src/ocaml/preprocess/parser_raw.mly" ( e.pexp_desc, (ext, attrs @ e.pexp_attributes) ) -# 35207 "src/ocaml/preprocess/parser_raw.ml" +# 35211 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -35211,10 +35215,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2501 "src/ocaml/preprocess/parser_raw.mly" +# 2505 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35218 "src/ocaml/preprocess/parser_raw.ml" +# 35222 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35263,24 +35267,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35269 "src/ocaml/preprocess/parser_raw.ml" +# 35273 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35275 "src/ocaml/preprocess/parser_raw.ml" +# 35279 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2510 "src/ocaml/preprocess/parser_raw.mly" +# 2514 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct (mkloc (Lident "()") (make_loc _sloc), None), _2 ) -# 35284 "src/ocaml/preprocess/parser_raw.ml" +# 35288 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -35288,10 +35292,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2501 "src/ocaml/preprocess/parser_raw.mly" +# 2505 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35295 "src/ocaml/preprocess/parser_raw.ml" +# 35299 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35341,9 +35345,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 35347 "src/ocaml/preprocess/parser_raw.ml" +# 35351 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -35351,21 +35355,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35357 "src/ocaml/preprocess/parser_raw.ml" +# 35361 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35363 "src/ocaml/preprocess/parser_raw.ml" +# 35367 "src/ocaml/preprocess/parser_raw.ml" in -# 2516 "src/ocaml/preprocess/parser_raw.mly" +# 2520 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_new(_3), _2 ) -# 35369 "src/ocaml/preprocess/parser_raw.ml" +# 35373 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -35373,10 +35377,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2501 "src/ocaml/preprocess/parser_raw.mly" +# 2505 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35380 "src/ocaml/preprocess/parser_raw.ml" +# 35384 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35439,21 +35443,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35445 "src/ocaml/preprocess/parser_raw.ml" +# 35449 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35451 "src/ocaml/preprocess/parser_raw.ml" +# 35455 "src/ocaml/preprocess/parser_raw.ml" in -# 2518 "src/ocaml/preprocess/parser_raw.mly" +# 2522 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_pack _4, _3 ) -# 35457 "src/ocaml/preprocess/parser_raw.ml" +# 35461 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -35461,10 +35465,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2501 "src/ocaml/preprocess/parser_raw.mly" +# 2505 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35468 "src/ocaml/preprocess/parser_raw.ml" +# 35472 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35542,11 +35546,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3611 "src/ocaml/preprocess/parser_raw.mly" +# 3615 "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 ) -# 35550 "src/ocaml/preprocess/parser_raw.ml" +# 35554 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -35554,24 +35558,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35560 "src/ocaml/preprocess/parser_raw.ml" +# 35564 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35566 "src/ocaml/preprocess/parser_raw.ml" +# 35570 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2520 "src/ocaml/preprocess/parser_raw.mly" +# 2524 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_constraint (ghexp ~loc:_sloc (Pexp_pack _4), _6), _3 ) -# 35575 "src/ocaml/preprocess/parser_raw.ml" +# 35579 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -35579,10 +35583,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2501 "src/ocaml/preprocess/parser_raw.mly" +# 2505 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35586 "src/ocaml/preprocess/parser_raw.ml" +# 35590 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35647,27 +35651,27 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 35651 "src/ocaml/preprocess/parser_raw.ml" +# 35655 "src/ocaml/preprocess/parser_raw.ml" in -# 2059 "src/ocaml/preprocess/parser_raw.mly" +# 2063 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35656 "src/ocaml/preprocess/parser_raw.ml" +# 35660 "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 -# 984 "src/ocaml/preprocess/parser_raw.mly" +# 988 "src/ocaml/preprocess/parser_raw.mly" ( extra_cstr _startpos _endpos _1 ) -# 35665 "src/ocaml/preprocess/parser_raw.ml" +# 35669 "src/ocaml/preprocess/parser_raw.ml" in -# 2046 "src/ocaml/preprocess/parser_raw.mly" +# 2050 "src/ocaml/preprocess/parser_raw.mly" ( Cstr.mk _1 _2 ) -# 35671 "src/ocaml/preprocess/parser_raw.ml" +# 35675 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -35675,21 +35679,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35681 "src/ocaml/preprocess/parser_raw.ml" +# 35685 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35687 "src/ocaml/preprocess/parser_raw.ml" +# 35691 "src/ocaml/preprocess/parser_raw.ml" in -# 2526 "src/ocaml/preprocess/parser_raw.mly" +# 2530 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_object _3, _2 ) -# 35693 "src/ocaml/preprocess/parser_raw.ml" +# 35697 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -35697,10 +35701,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2501 "src/ocaml/preprocess/parser_raw.mly" +# 2505 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35704 "src/ocaml/preprocess/parser_raw.ml" +# 35708 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35729,30 +35733,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 35735 "src/ocaml/preprocess/parser_raw.ml" +# 35739 "src/ocaml/preprocess/parser_raw.ml" in -# 2534 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_ident (_1) ) -# 35741 "src/ocaml/preprocess/parser_raw.ml" +# 35745 "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" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35750 "src/ocaml/preprocess/parser_raw.ml" +# 35754 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35756 "src/ocaml/preprocess/parser_raw.ml" +# 35760 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35776,23 +35780,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2536 "src/ocaml/preprocess/parser_raw.mly" +# 2540 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_constant _1 ) -# 35782 "src/ocaml/preprocess/parser_raw.ml" +# 35786 "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" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35790 "src/ocaml/preprocess/parser_raw.ml" +# 35794 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35796 "src/ocaml/preprocess/parser_raw.ml" +# 35800 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35821,30 +35825,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 35827 "src/ocaml/preprocess/parser_raw.ml" +# 35831 "src/ocaml/preprocess/parser_raw.ml" in -# 2538 "src/ocaml/preprocess/parser_raw.mly" +# 2542 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct(_1, None) ) -# 35833 "src/ocaml/preprocess/parser_raw.ml" +# 35837 "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" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35842 "src/ocaml/preprocess/parser_raw.ml" +# 35846 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35848 "src/ocaml/preprocess/parser_raw.ml" +# 35852 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35868,23 +35872,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2540 "src/ocaml/preprocess/parser_raw.mly" +# 2544 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_variant(_1, None) ) -# 35874 "src/ocaml/preprocess/parser_raw.ml" +# 35878 "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" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35882 "src/ocaml/preprocess/parser_raw.ml" +# 35886 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35888 "src/ocaml/preprocess/parser_raw.ml" +# 35892 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35910,9 +35914,9 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 817 "src/ocaml/preprocess/parser_raw.mly" +# 821 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35916 "src/ocaml/preprocess/parser_raw.ml" +# 35920 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -35924,15 +35928,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1017 "src/ocaml/preprocess/parser_raw.mly" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 35930 "src/ocaml/preprocess/parser_raw.ml" +# 35934 "src/ocaml/preprocess/parser_raw.ml" in -# 2542 "src/ocaml/preprocess/parser_raw.mly" +# 2546 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 35936 "src/ocaml/preprocess/parser_raw.ml" +# 35940 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -35940,15 +35944,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35946 "src/ocaml/preprocess/parser_raw.ml" +# 35950 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35952 "src/ocaml/preprocess/parser_raw.ml" +# 35956 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35981,23 +35985,23 @@ module Tables = struct let _1 = let _1 = let _1 = -# 2543 "src/ocaml/preprocess/parser_raw.mly" +# 2547 "src/ocaml/preprocess/parser_raw.mly" ("!") -# 35987 "src/ocaml/preprocess/parser_raw.ml" +# 35991 "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" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 35995 "src/ocaml/preprocess/parser_raw.ml" +# 35999 "src/ocaml/preprocess/parser_raw.ml" in -# 2544 "src/ocaml/preprocess/parser_raw.mly" +# 2548 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 36001 "src/ocaml/preprocess/parser_raw.ml" +# 36005 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -36005,15 +36009,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36011 "src/ocaml/preprocess/parser_raw.ml" +# 36015 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36017 "src/ocaml/preprocess/parser_raw.ml" +# 36021 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36052,14 +36056,14 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2829 "src/ocaml/preprocess/parser_raw.mly" +# 2833 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 36058 "src/ocaml/preprocess/parser_raw.ml" +# 36062 "src/ocaml/preprocess/parser_raw.ml" in -# 2546 "src/ocaml/preprocess/parser_raw.mly" +# 2550 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_override _2 ) -# 36063 "src/ocaml/preprocess/parser_raw.ml" +# 36067 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36067,15 +36071,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36073 "src/ocaml/preprocess/parser_raw.ml" +# 36077 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36079 "src/ocaml/preprocess/parser_raw.ml" +# 36083 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36106,24 +36110,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2552 "src/ocaml/preprocess/parser_raw.mly" +# 2556 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_override [] ) -# 36112 "src/ocaml/preprocess/parser_raw.ml" +# 36116 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36121 "src/ocaml/preprocess/parser_raw.ml" +# 36125 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36127 "src/ocaml/preprocess/parser_raw.ml" +# 36131 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36167,15 +36171,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36173 "src/ocaml/preprocess/parser_raw.ml" +# 36177 "src/ocaml/preprocess/parser_raw.ml" in -# 2554 "src/ocaml/preprocess/parser_raw.mly" +# 2558 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_field(_1, _3) ) -# 36179 "src/ocaml/preprocess/parser_raw.ml" +# 36183 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -36183,15 +36187,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36189 "src/ocaml/preprocess/parser_raw.ml" +# 36193 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36195 "src/ocaml/preprocess/parser_raw.ml" +# 36199 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36249,24 +36253,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36255 "src/ocaml/preprocess/parser_raw.ml" +# 36259 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1699 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36264 "src/ocaml/preprocess/parser_raw.ml" +# 36268 "src/ocaml/preprocess/parser_raw.ml" in -# 2556 "src/ocaml/preprocess/parser_raw.mly" +# 2560 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, _4) ) -# 36270 "src/ocaml/preprocess/parser_raw.ml" +# 36274 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36274,15 +36278,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36280 "src/ocaml/preprocess/parser_raw.ml" +# 36284 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36286 "src/ocaml/preprocess/parser_raw.ml" +# 36290 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36335,9 +36339,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2829 "src/ocaml/preprocess/parser_raw.mly" +# 2833 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 36341 "src/ocaml/preprocess/parser_raw.ml" +# 36345 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -36345,18 +36349,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36351 "src/ocaml/preprocess/parser_raw.ml" +# 36355 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1699 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36360 "src/ocaml/preprocess/parser_raw.ml" +# 36364 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_od_ = _startpos__1_ in @@ -36364,10 +36368,10 @@ module Tables = struct let _symbolstartpos = _startpos_od_ in let _sloc = (_symbolstartpos, _endpos) in -# 2558 "src/ocaml/preprocess/parser_raw.mly" +# 2562 "src/ocaml/preprocess/parser_raw.mly" ( (* TODO: review the location of Pexp_override *) Pexp_open(od, mkexp ~loc:_sloc (Pexp_override _4)) ) -# 36371 "src/ocaml/preprocess/parser_raw.ml" +# 36375 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36375,15 +36379,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36381 "src/ocaml/preprocess/parser_raw.ml" +# 36385 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36387 "src/ocaml/preprocess/parser_raw.ml" +# 36391 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36414,9 +36418,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 36420 "src/ocaml/preprocess/parser_raw.ml" +# 36424 "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 @@ -36428,23 +36432,23 @@ module Tables = struct let _3 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36434 "src/ocaml/preprocess/parser_raw.ml" +# 36438 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36442 "src/ocaml/preprocess/parser_raw.ml" +# 36446 "src/ocaml/preprocess/parser_raw.ml" in -# 2565 "src/ocaml/preprocess/parser_raw.mly" +# 2569 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_send(_1, _3) ) -# 36448 "src/ocaml/preprocess/parser_raw.ml" +# 36452 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -36452,15 +36456,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36458 "src/ocaml/preprocess/parser_raw.ml" +# 36462 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36464 "src/ocaml/preprocess/parser_raw.ml" +# 36468 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36492,9 +36496,9 @@ module Tables = struct } = _menhir_stack in let _3 : (Parsetree.expression) = Obj.magic _3 in let _1_inlined1 : ( -# 828 "src/ocaml/preprocess/parser_raw.mly" +# 832 "src/ocaml/preprocess/parser_raw.mly" (string) -# 36498 "src/ocaml/preprocess/parser_raw.ml" +# 36502 "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 @@ -36508,15 +36512,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1017 "src/ocaml/preprocess/parser_raw.mly" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 36514 "src/ocaml/preprocess/parser_raw.ml" +# 36518 "src/ocaml/preprocess/parser_raw.ml" in -# 2567 "src/ocaml/preprocess/parser_raw.mly" +# 2571 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix _1 _2 _3 ) -# 36520 "src/ocaml/preprocess/parser_raw.ml" +# 36524 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36524,15 +36528,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36530 "src/ocaml/preprocess/parser_raw.ml" +# 36534 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36536 "src/ocaml/preprocess/parser_raw.ml" +# 36540 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36556,23 +36560,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2569 "src/ocaml/preprocess/parser_raw.mly" +# 2573 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_extension _1 ) -# 36562 "src/ocaml/preprocess/parser_raw.ml" +# 36566 "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" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36570 "src/ocaml/preprocess/parser_raw.ml" +# 36574 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36576 "src/ocaml/preprocess/parser_raw.ml" +# 36580 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36600,25 +36604,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2571 "src/ocaml/preprocess/parser_raw.mly" +# 2575 "src/ocaml/preprocess/parser_raw.mly" ( let id = mkrhs Ast_helper.hole_txt _loc in Pexp_extension (id, PStr []) ) -# 36607 "src/ocaml/preprocess/parser_raw.ml" +# 36611 "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" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36616 "src/ocaml/preprocess/parser_raw.ml" +# 36620 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36622 "src/ocaml/preprocess/parser_raw.ml" +# 36626 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36666,18 +36670,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2573 "src/ocaml/preprocess/parser_raw.mly" +# 2577 "src/ocaml/preprocess/parser_raw.mly" (Lident "()") -# 36672 "src/ocaml/preprocess/parser_raw.ml" +# 36676 "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 -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36681 "src/ocaml/preprocess/parser_raw.ml" +# 36685 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -36687,25 +36691,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36693 "src/ocaml/preprocess/parser_raw.ml" +# 36697 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1699 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36702 "src/ocaml/preprocess/parser_raw.ml" +# 36706 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2574 "src/ocaml/preprocess/parser_raw.mly" +# 2578 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:(_loc__3_) (Pexp_construct(_3, None))) ) -# 36709 "src/ocaml/preprocess/parser_raw.ml" +# 36713 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -36713,15 +36717,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36719 "src/ocaml/preprocess/parser_raw.ml" +# 36723 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36725 "src/ocaml/preprocess/parser_raw.ml" +# 36729 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36760,25 +36764,25 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2580 "src/ocaml/preprocess/parser_raw.mly" +# 2584 "src/ocaml/preprocess/parser_raw.mly" ( let (exten, fields) = _2 in Pexp_record(fields, exten) ) -# 36767 "src/ocaml/preprocess/parser_raw.ml" +# 36771 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36776 "src/ocaml/preprocess/parser_raw.ml" +# 36780 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36782 "src/ocaml/preprocess/parser_raw.ml" +# 36786 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36837,27 +36841,27 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36843 "src/ocaml/preprocess/parser_raw.ml" +# 36847 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1699 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36852 "src/ocaml/preprocess/parser_raw.ml" +# 36856 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in -# 2587 "src/ocaml/preprocess/parser_raw.mly" +# 2591 "src/ocaml/preprocess/parser_raw.mly" ( let (exten, fields) = _4 in Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_record(fields, exten))) ) -# 36861 "src/ocaml/preprocess/parser_raw.ml" +# 36865 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36865,15 +36869,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36871 "src/ocaml/preprocess/parser_raw.ml" +# 36875 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36877 "src/ocaml/preprocess/parser_raw.ml" +# 36881 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36912,14 +36916,14 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 36918 "src/ocaml/preprocess/parser_raw.ml" +# 36922 "src/ocaml/preprocess/parser_raw.ml" in -# 2595 "src/ocaml/preprocess/parser_raw.mly" +# 2599 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_array(_2) ) -# 36923 "src/ocaml/preprocess/parser_raw.ml" +# 36927 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36927,15 +36931,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36933 "src/ocaml/preprocess/parser_raw.ml" +# 36937 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36939 "src/ocaml/preprocess/parser_raw.ml" +# 36943 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36966,24 +36970,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2601 "src/ocaml/preprocess/parser_raw.mly" +# 2605 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_array [] ) -# 36972 "src/ocaml/preprocess/parser_raw.ml" +# 36976 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36981 "src/ocaml/preprocess/parser_raw.ml" +# 36985 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36987 "src/ocaml/preprocess/parser_raw.ml" +# 36991 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37036,9 +37040,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37042 "src/ocaml/preprocess/parser_raw.ml" +# 37046 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -37046,25 +37050,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37052 "src/ocaml/preprocess/parser_raw.ml" +# 37056 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1699 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37061 "src/ocaml/preprocess/parser_raw.ml" +# 37065 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in -# 2603 "src/ocaml/preprocess/parser_raw.mly" +# 2607 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array(_4))) ) -# 37068 "src/ocaml/preprocess/parser_raw.ml" +# 37072 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37072,15 +37076,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37078 "src/ocaml/preprocess/parser_raw.ml" +# 37082 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37084 "src/ocaml/preprocess/parser_raw.ml" +# 37088 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37131,26 +37135,26 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37137 "src/ocaml/preprocess/parser_raw.ml" +# 37141 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1699 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37146 "src/ocaml/preprocess/parser_raw.ml" +# 37150 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in -# 2605 "src/ocaml/preprocess/parser_raw.mly" +# 2609 "src/ocaml/preprocess/parser_raw.mly" ( (* TODO: review the location of Pexp_array *) Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array [])) ) -# 37154 "src/ocaml/preprocess/parser_raw.ml" +# 37158 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -37158,15 +37162,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37164 "src/ocaml/preprocess/parser_raw.ml" +# 37168 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37170 "src/ocaml/preprocess/parser_raw.ml" +# 37174 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37205,15 +37209,15 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37211 "src/ocaml/preprocess/parser_raw.ml" +# 37215 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2613 "src/ocaml/preprocess/parser_raw.mly" +# 2617 "src/ocaml/preprocess/parser_raw.mly" ( fst (mktailexp _loc__3_ _2) ) -# 37217 "src/ocaml/preprocess/parser_raw.ml" +# 37221 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -37221,15 +37225,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37227 "src/ocaml/preprocess/parser_raw.ml" +# 37231 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37233 "src/ocaml/preprocess/parser_raw.ml" +# 37237 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37282,9 +37286,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2846 "src/ocaml/preprocess/parser_raw.mly" +# 2850 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37288 "src/ocaml/preprocess/parser_raw.ml" +# 37292 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -37292,30 +37296,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37298 "src/ocaml/preprocess/parser_raw.ml" +# 37302 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1699 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37307 "src/ocaml/preprocess/parser_raw.ml" +# 37311 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _loc__5_ = (_startpos__5_, _endpos__5_) in -# 2619 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "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) ) -# 37319 "src/ocaml/preprocess/parser_raw.ml" +# 37323 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37323,15 +37327,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37329 "src/ocaml/preprocess/parser_raw.ml" +# 37333 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37335 "src/ocaml/preprocess/parser_raw.ml" +# 37339 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37379,18 +37383,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2624 "src/ocaml/preprocess/parser_raw.mly" +# 2628 "src/ocaml/preprocess/parser_raw.mly" (Lident "[]") -# 37385 "src/ocaml/preprocess/parser_raw.ml" +# 37389 "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 -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37394 "src/ocaml/preprocess/parser_raw.ml" +# 37398 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -37400,25 +37404,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37406 "src/ocaml/preprocess/parser_raw.ml" +# 37410 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1699 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37415 "src/ocaml/preprocess/parser_raw.ml" +# 37419 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2625 "src/ocaml/preprocess/parser_raw.mly" +# 2629 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:_loc__3_ (Pexp_construct(_3, None))) ) -# 37422 "src/ocaml/preprocess/parser_raw.ml" +# 37426 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -37426,15 +37430,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37432 "src/ocaml/preprocess/parser_raw.ml" +# 37436 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37438 "src/ocaml/preprocess/parser_raw.ml" +# 37442 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37527,11 +37531,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3611 "src/ocaml/preprocess/parser_raw.mly" +# 3615 "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 ) -# 37535 "src/ocaml/preprocess/parser_raw.ml" +# 37539 "src/ocaml/preprocess/parser_raw.ml" in let _5 = @@ -37539,15 +37543,15 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37545 "src/ocaml/preprocess/parser_raw.ml" +# 37549 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 37551 "src/ocaml/preprocess/parser_raw.ml" +# 37555 "src/ocaml/preprocess/parser_raw.ml" in let od = @@ -37556,18 +37560,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37562 "src/ocaml/preprocess/parser_raw.ml" +# 37566 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1699 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37571 "src/ocaml/preprocess/parser_raw.ml" +# 37575 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_od_ = _startpos__1_ in @@ -37575,12 +37579,12 @@ module Tables = struct let _symbolstartpos = _startpos_od_ in let _sloc = (_symbolstartpos, _endpos) in -# 2633 "src/ocaml/preprocess/parser_raw.mly" +# 2637 "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) ) -# 37584 "src/ocaml/preprocess/parser_raw.ml" +# 37588 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__9_ in @@ -37588,15 +37592,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37594 "src/ocaml/preprocess/parser_raw.ml" +# 37598 "src/ocaml/preprocess/parser_raw.ml" in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37600 "src/ocaml/preprocess/parser_raw.ml" +# 37604 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37625,30 +37629,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37631 "src/ocaml/preprocess/parser_raw.ml" +# 37635 "src/ocaml/preprocess/parser_raw.ml" in -# 2929 "src/ocaml/preprocess/parser_raw.mly" +# 2933 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_var (_1) ) -# 37637 "src/ocaml/preprocess/parser_raw.ml" +# 37641 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 37646 "src/ocaml/preprocess/parser_raw.ml" +# 37650 "src/ocaml/preprocess/parser_raw.ml" in -# 2930 "src/ocaml/preprocess/parser_raw.mly" +# 2934 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37652 "src/ocaml/preprocess/parser_raw.ml" +# 37656 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37671,9 +37675,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2931 "src/ocaml/preprocess/parser_raw.mly" +# 2935 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37677 "src/ocaml/preprocess/parser_raw.ml" +# 37681 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37713,9 +37717,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2936 "src/ocaml/preprocess/parser_raw.mly" +# 2940 "src/ocaml/preprocess/parser_raw.mly" ( reloc_pat ~loc:_sloc _2 ) -# 37719 "src/ocaml/preprocess/parser_raw.ml" +# 37723 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37738,9 +37742,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2938 "src/ocaml/preprocess/parser_raw.mly" +# 2942 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37744 "src/ocaml/preprocess/parser_raw.ml" +# 37748 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37803,9 +37807,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37809 "src/ocaml/preprocess/parser_raw.ml" +# 37813 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -37813,24 +37817,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37819 "src/ocaml/preprocess/parser_raw.ml" +# 37823 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 37825 "src/ocaml/preprocess/parser_raw.ml" +# 37829 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2940 "src/ocaml/preprocess/parser_raw.mly" +# 2944 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_unpack _4) _3 ) -# 37834 "src/ocaml/preprocess/parser_raw.ml" +# 37838 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37907,11 +37911,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3611 "src/ocaml/preprocess/parser_raw.mly" +# 3615 "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 ) -# 37915 "src/ocaml/preprocess/parser_raw.ml" +# 37919 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -37920,9 +37924,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37926 "src/ocaml/preprocess/parser_raw.ml" +# 37930 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__4_, _startpos__4_) = (_endpos__1_inlined3_, _startpos__1_inlined3_) in @@ -37931,15 +37935,15 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37937 "src/ocaml/preprocess/parser_raw.ml" +# 37941 "src/ocaml/preprocess/parser_raw.ml" in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 37943 "src/ocaml/preprocess/parser_raw.ml" +# 37947 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in @@ -37947,11 +37951,11 @@ module Tables = struct let _loc__4_ = (_startpos__4_, _endpos__4_) in let _sloc = (_symbolstartpos, _endpos) in -# 2942 "src/ocaml/preprocess/parser_raw.mly" +# 2946 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_constraint(mkpat ~loc:_loc__4_ (Ppat_unpack _4), _6)) _3 ) -# 37955 "src/ocaml/preprocess/parser_raw.ml" +# 37959 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37975,23 +37979,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2954 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_any ) -# 37981 "src/ocaml/preprocess/parser_raw.ml" +# 37985 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 37989 "src/ocaml/preprocess/parser_raw.ml" +# 37993 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37995 "src/ocaml/preprocess/parser_raw.ml" +# 37999 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38015,23 +38019,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2952 "src/ocaml/preprocess/parser_raw.mly" +# 2956 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constant _1 ) -# 38021 "src/ocaml/preprocess/parser_raw.ml" +# 38025 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38029 "src/ocaml/preprocess/parser_raw.ml" +# 38033 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38035 "src/ocaml/preprocess/parser_raw.ml" +# 38039 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38069,24 +38073,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2954 "src/ocaml/preprocess/parser_raw.mly" +# 2958 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_interval (_1, _3) ) -# 38075 "src/ocaml/preprocess/parser_raw.ml" +# 38079 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38084 "src/ocaml/preprocess/parser_raw.ml" +# 38088 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38090 "src/ocaml/preprocess/parser_raw.ml" +# 38094 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38115,30 +38119,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38121 "src/ocaml/preprocess/parser_raw.ml" +# 38125 "src/ocaml/preprocess/parser_raw.ml" in -# 2956 "src/ocaml/preprocess/parser_raw.mly" +# 2960 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(_1, None) ) -# 38127 "src/ocaml/preprocess/parser_raw.ml" +# 38131 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38136 "src/ocaml/preprocess/parser_raw.ml" +# 38140 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38142 "src/ocaml/preprocess/parser_raw.ml" +# 38146 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38162,23 +38166,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2958 "src/ocaml/preprocess/parser_raw.mly" +# 2962 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_variant(_1, None) ) -# 38168 "src/ocaml/preprocess/parser_raw.ml" +# 38172 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38176 "src/ocaml/preprocess/parser_raw.ml" +# 38180 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38182 "src/ocaml/preprocess/parser_raw.ml" +# 38186 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38215,15 +38219,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38221 "src/ocaml/preprocess/parser_raw.ml" +# 38225 "src/ocaml/preprocess/parser_raw.ml" in -# 2960 "src/ocaml/preprocess/parser_raw.mly" +# 2964 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_type (_2) ) -# 38227 "src/ocaml/preprocess/parser_raw.ml" +# 38231 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -38231,15 +38235,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38237 "src/ocaml/preprocess/parser_raw.ml" +# 38241 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38243 "src/ocaml/preprocess/parser_raw.ml" +# 38247 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38282,15 +38286,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38288 "src/ocaml/preprocess/parser_raw.ml" +# 38292 "src/ocaml/preprocess/parser_raw.ml" in -# 2962 "src/ocaml/preprocess/parser_raw.mly" +# 2966 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, _3) ) -# 38294 "src/ocaml/preprocess/parser_raw.ml" +# 38298 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -38298,15 +38302,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38304 "src/ocaml/preprocess/parser_raw.ml" +# 38308 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38310 "src/ocaml/preprocess/parser_raw.ml" +# 38314 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38354,18 +38358,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2963 "src/ocaml/preprocess/parser_raw.mly" +# 2967 "src/ocaml/preprocess/parser_raw.mly" (Lident "[]") -# 38360 "src/ocaml/preprocess/parser_raw.ml" +# 38364 "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 -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38369 "src/ocaml/preprocess/parser_raw.ml" +# 38373 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -38374,18 +38378,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38380 "src/ocaml/preprocess/parser_raw.ml" +# 38384 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2964 "src/ocaml/preprocess/parser_raw.mly" +# 2968 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 38389 "src/ocaml/preprocess/parser_raw.ml" +# 38393 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -38393,15 +38397,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38399 "src/ocaml/preprocess/parser_raw.ml" +# 38403 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38405 "src/ocaml/preprocess/parser_raw.ml" +# 38409 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38449,18 +38453,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2965 "src/ocaml/preprocess/parser_raw.mly" +# 2969 "src/ocaml/preprocess/parser_raw.mly" (Lident "()") -# 38455 "src/ocaml/preprocess/parser_raw.ml" +# 38459 "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 -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38464 "src/ocaml/preprocess/parser_raw.ml" +# 38468 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -38469,18 +38473,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38475 "src/ocaml/preprocess/parser_raw.ml" +# 38479 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2966 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 38484 "src/ocaml/preprocess/parser_raw.ml" +# 38488 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -38488,15 +38492,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38494 "src/ocaml/preprocess/parser_raw.ml" +# 38498 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38500 "src/ocaml/preprocess/parser_raw.ml" +# 38504 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38553,15 +38557,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38559 "src/ocaml/preprocess/parser_raw.ml" +# 38563 "src/ocaml/preprocess/parser_raw.ml" in -# 2968 "src/ocaml/preprocess/parser_raw.mly" +# 2972 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open (_1, _4) ) -# 38565 "src/ocaml/preprocess/parser_raw.ml" +# 38569 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -38569,15 +38573,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38575 "src/ocaml/preprocess/parser_raw.ml" +# 38579 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38581 "src/ocaml/preprocess/parser_raw.ml" +# 38585 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38629,24 +38633,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2978 "src/ocaml/preprocess/parser_raw.mly" +# 2982 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_2, _4) ) -# 38635 "src/ocaml/preprocess/parser_raw.ml" +# 38639 "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 -# 1025 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38644 "src/ocaml/preprocess/parser_raw.ml" +# 38648 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38650 "src/ocaml/preprocess/parser_raw.ml" +# 38654 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38670,23 +38674,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2989 "src/ocaml/preprocess/parser_raw.mly" +# 2993 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_extension _1 ) -# 38676 "src/ocaml/preprocess/parser_raw.ml" +# 38680 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38684 "src/ocaml/preprocess/parser_raw.ml" +# 38688 "src/ocaml/preprocess/parser_raw.ml" in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38690 "src/ocaml/preprocess/parser_raw.ml" +# 38694 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38705,17 +38709,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 38711 "src/ocaml/preprocess/parser_raw.ml" +# 38715 "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) = -# 3952 "src/ocaml/preprocess/parser_raw.mly" +# 3956 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38719 "src/ocaml/preprocess/parser_raw.ml" +# 38723 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38734,17 +38738,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) -# 38740 "src/ocaml/preprocess/parser_raw.ml" +# 38744 "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) = -# 3953 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38748 "src/ocaml/preprocess/parser_raw.ml" +# 38752 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38767,9 +38771,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3954 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( "and" ) -# 38773 "src/ocaml/preprocess/parser_raw.ml" +# 38777 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38792,9 +38796,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3955 "src/ocaml/preprocess/parser_raw.mly" +# 3959 "src/ocaml/preprocess/parser_raw.mly" ( "as" ) -# 38798 "src/ocaml/preprocess/parser_raw.ml" +# 38802 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38817,9 +38821,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3956 "src/ocaml/preprocess/parser_raw.mly" +# 3960 "src/ocaml/preprocess/parser_raw.mly" ( "assert" ) -# 38823 "src/ocaml/preprocess/parser_raw.ml" +# 38827 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38842,9 +38846,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 3961 "src/ocaml/preprocess/parser_raw.mly" ( "begin" ) -# 38848 "src/ocaml/preprocess/parser_raw.ml" +# 38852 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38867,9 +38871,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 3962 "src/ocaml/preprocess/parser_raw.mly" ( "class" ) -# 38873 "src/ocaml/preprocess/parser_raw.ml" +# 38877 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38892,9 +38896,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3959 "src/ocaml/preprocess/parser_raw.mly" +# 3963 "src/ocaml/preprocess/parser_raw.mly" ( "constraint" ) -# 38898 "src/ocaml/preprocess/parser_raw.ml" +# 38902 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38917,9 +38921,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3960 "src/ocaml/preprocess/parser_raw.mly" +# 3964 "src/ocaml/preprocess/parser_raw.mly" ( "do" ) -# 38923 "src/ocaml/preprocess/parser_raw.ml" +# 38927 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38942,9 +38946,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3961 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( "done" ) -# 38948 "src/ocaml/preprocess/parser_raw.ml" +# 38952 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38967,9 +38971,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3962 "src/ocaml/preprocess/parser_raw.mly" +# 3966 "src/ocaml/preprocess/parser_raw.mly" ( "downto" ) -# 38973 "src/ocaml/preprocess/parser_raw.ml" +# 38977 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38992,9 +38996,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3963 "src/ocaml/preprocess/parser_raw.mly" +# 3967 "src/ocaml/preprocess/parser_raw.mly" ( "else" ) -# 38998 "src/ocaml/preprocess/parser_raw.ml" +# 39002 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39017,9 +39021,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3964 "src/ocaml/preprocess/parser_raw.mly" +# 3968 "src/ocaml/preprocess/parser_raw.mly" ( "end" ) -# 39023 "src/ocaml/preprocess/parser_raw.ml" +# 39027 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39042,9 +39046,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3969 "src/ocaml/preprocess/parser_raw.mly" ( "exception" ) -# 39048 "src/ocaml/preprocess/parser_raw.ml" +# 39052 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39067,9 +39071,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3966 "src/ocaml/preprocess/parser_raw.mly" +# 3970 "src/ocaml/preprocess/parser_raw.mly" ( "external" ) -# 39073 "src/ocaml/preprocess/parser_raw.ml" +# 39077 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39092,9 +39096,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3967 "src/ocaml/preprocess/parser_raw.mly" +# 3971 "src/ocaml/preprocess/parser_raw.mly" ( "false" ) -# 39098 "src/ocaml/preprocess/parser_raw.ml" +# 39102 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39117,9 +39121,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3968 "src/ocaml/preprocess/parser_raw.mly" +# 3972 "src/ocaml/preprocess/parser_raw.mly" ( "for" ) -# 39123 "src/ocaml/preprocess/parser_raw.ml" +# 39127 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39142,9 +39146,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3969 "src/ocaml/preprocess/parser_raw.mly" +# 3973 "src/ocaml/preprocess/parser_raw.mly" ( "fun" ) -# 39148 "src/ocaml/preprocess/parser_raw.ml" +# 39152 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39167,9 +39171,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3970 "src/ocaml/preprocess/parser_raw.mly" +# 3974 "src/ocaml/preprocess/parser_raw.mly" ( "function" ) -# 39173 "src/ocaml/preprocess/parser_raw.ml" +# 39177 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39192,9 +39196,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3971 "src/ocaml/preprocess/parser_raw.mly" +# 3975 "src/ocaml/preprocess/parser_raw.mly" ( "functor" ) -# 39198 "src/ocaml/preprocess/parser_raw.ml" +# 39202 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39217,9 +39221,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3972 "src/ocaml/preprocess/parser_raw.mly" +# 3976 "src/ocaml/preprocess/parser_raw.mly" ( "if" ) -# 39223 "src/ocaml/preprocess/parser_raw.ml" +# 39227 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39242,9 +39246,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3973 "src/ocaml/preprocess/parser_raw.mly" +# 3977 "src/ocaml/preprocess/parser_raw.mly" ( "in" ) -# 39248 "src/ocaml/preprocess/parser_raw.ml" +# 39252 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39267,9 +39271,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3974 "src/ocaml/preprocess/parser_raw.mly" +# 3978 "src/ocaml/preprocess/parser_raw.mly" ( "include" ) -# 39273 "src/ocaml/preprocess/parser_raw.ml" +# 39277 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39292,9 +39296,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3975 "src/ocaml/preprocess/parser_raw.mly" +# 3979 "src/ocaml/preprocess/parser_raw.mly" ( "inherit" ) -# 39298 "src/ocaml/preprocess/parser_raw.ml" +# 39302 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39317,9 +39321,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3976 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( "initializer" ) -# 39323 "src/ocaml/preprocess/parser_raw.ml" +# 39327 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39342,9 +39346,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3977 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( "lazy" ) -# 39348 "src/ocaml/preprocess/parser_raw.ml" +# 39352 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39367,9 +39371,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3978 "src/ocaml/preprocess/parser_raw.mly" +# 3982 "src/ocaml/preprocess/parser_raw.mly" ( "let" ) -# 39373 "src/ocaml/preprocess/parser_raw.ml" +# 39377 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39392,9 +39396,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3979 "src/ocaml/preprocess/parser_raw.mly" +# 3983 "src/ocaml/preprocess/parser_raw.mly" ( "match" ) -# 39398 "src/ocaml/preprocess/parser_raw.ml" +# 39402 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39417,9 +39421,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3980 "src/ocaml/preprocess/parser_raw.mly" +# 3984 "src/ocaml/preprocess/parser_raw.mly" ( "method" ) -# 39423 "src/ocaml/preprocess/parser_raw.ml" +# 39427 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39442,9 +39446,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3981 "src/ocaml/preprocess/parser_raw.mly" +# 3985 "src/ocaml/preprocess/parser_raw.mly" ( "module" ) -# 39448 "src/ocaml/preprocess/parser_raw.ml" +# 39452 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39467,9 +39471,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3982 "src/ocaml/preprocess/parser_raw.mly" +# 3986 "src/ocaml/preprocess/parser_raw.mly" ( "mutable" ) -# 39473 "src/ocaml/preprocess/parser_raw.ml" +# 39477 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39492,9 +39496,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3983 "src/ocaml/preprocess/parser_raw.mly" +# 3987 "src/ocaml/preprocess/parser_raw.mly" ( "new" ) -# 39498 "src/ocaml/preprocess/parser_raw.ml" +# 39502 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39517,9 +39521,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3984 "src/ocaml/preprocess/parser_raw.mly" +# 3988 "src/ocaml/preprocess/parser_raw.mly" ( "nonrec" ) -# 39523 "src/ocaml/preprocess/parser_raw.ml" +# 39527 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39542,9 +39546,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3985 "src/ocaml/preprocess/parser_raw.mly" +# 3989 "src/ocaml/preprocess/parser_raw.mly" ( "object" ) -# 39548 "src/ocaml/preprocess/parser_raw.ml" +# 39552 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39567,9 +39571,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3986 "src/ocaml/preprocess/parser_raw.mly" +# 3990 "src/ocaml/preprocess/parser_raw.mly" ( "of" ) -# 39573 "src/ocaml/preprocess/parser_raw.ml" +# 39577 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39592,9 +39596,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3987 "src/ocaml/preprocess/parser_raw.mly" +# 3991 "src/ocaml/preprocess/parser_raw.mly" ( "open" ) -# 39598 "src/ocaml/preprocess/parser_raw.ml" +# 39602 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39617,9 +39621,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3988 "src/ocaml/preprocess/parser_raw.mly" +# 3992 "src/ocaml/preprocess/parser_raw.mly" ( "or" ) -# 39623 "src/ocaml/preprocess/parser_raw.ml" +# 39627 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39642,9 +39646,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3989 "src/ocaml/preprocess/parser_raw.mly" +# 3993 "src/ocaml/preprocess/parser_raw.mly" ( "private" ) -# 39648 "src/ocaml/preprocess/parser_raw.ml" +# 39652 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39667,9 +39671,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3990 "src/ocaml/preprocess/parser_raw.mly" +# 3994 "src/ocaml/preprocess/parser_raw.mly" ( "rec" ) -# 39673 "src/ocaml/preprocess/parser_raw.ml" +# 39677 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39692,9 +39696,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3991 "src/ocaml/preprocess/parser_raw.mly" +# 3995 "src/ocaml/preprocess/parser_raw.mly" ( "sig" ) -# 39698 "src/ocaml/preprocess/parser_raw.ml" +# 39702 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39717,9 +39721,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3992 "src/ocaml/preprocess/parser_raw.mly" +# 3996 "src/ocaml/preprocess/parser_raw.mly" ( "struct" ) -# 39723 "src/ocaml/preprocess/parser_raw.ml" +# 39727 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39742,9 +39746,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3993 "src/ocaml/preprocess/parser_raw.mly" +# 3997 "src/ocaml/preprocess/parser_raw.mly" ( "then" ) -# 39748 "src/ocaml/preprocess/parser_raw.ml" +# 39752 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39767,9 +39771,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3994 "src/ocaml/preprocess/parser_raw.mly" +# 3998 "src/ocaml/preprocess/parser_raw.mly" ( "to" ) -# 39773 "src/ocaml/preprocess/parser_raw.ml" +# 39777 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39792,9 +39796,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3995 "src/ocaml/preprocess/parser_raw.mly" +# 3999 "src/ocaml/preprocess/parser_raw.mly" ( "true" ) -# 39798 "src/ocaml/preprocess/parser_raw.ml" +# 39802 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39817,9 +39821,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3996 "src/ocaml/preprocess/parser_raw.mly" +# 4000 "src/ocaml/preprocess/parser_raw.mly" ( "try" ) -# 39823 "src/ocaml/preprocess/parser_raw.ml" +# 39827 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39842,9 +39846,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3997 "src/ocaml/preprocess/parser_raw.mly" +# 4001 "src/ocaml/preprocess/parser_raw.mly" ( "type" ) -# 39848 "src/ocaml/preprocess/parser_raw.ml" +# 39852 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39867,9 +39871,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3998 "src/ocaml/preprocess/parser_raw.mly" +# 4002 "src/ocaml/preprocess/parser_raw.mly" ( "val" ) -# 39873 "src/ocaml/preprocess/parser_raw.ml" +# 39877 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39892,9 +39896,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3999 "src/ocaml/preprocess/parser_raw.mly" +# 4003 "src/ocaml/preprocess/parser_raw.mly" ( "virtual" ) -# 39898 "src/ocaml/preprocess/parser_raw.ml" +# 39902 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39917,9 +39921,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4000 "src/ocaml/preprocess/parser_raw.mly" +# 4004 "src/ocaml/preprocess/parser_raw.mly" ( "when" ) -# 39923 "src/ocaml/preprocess/parser_raw.ml" +# 39927 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39942,9 +39946,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4001 "src/ocaml/preprocess/parser_raw.mly" +# 4005 "src/ocaml/preprocess/parser_raw.mly" ( "while" ) -# 39948 "src/ocaml/preprocess/parser_raw.ml" +# 39952 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39967,9 +39971,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4002 "src/ocaml/preprocess/parser_raw.mly" +# 4006 "src/ocaml/preprocess/parser_raw.mly" ( "with" ) -# 39973 "src/ocaml/preprocess/parser_raw.ml" +# 39977 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39992,9 +39996,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.type_exception * string Location.loc option) = -# 3270 "src/ocaml/preprocess/parser_raw.mly" +# 3274 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39998 "src/ocaml/preprocess/parser_raw.ml" +# 40002 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40068,18 +40072,18 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = let attrs = let _1 = _1_inlined5 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40074 "src/ocaml/preprocess/parser_raw.ml" +# 40078 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined5_ in let attrs2 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40083 "src/ocaml/preprocess/parser_raw.ml" +# 40087 "src/ocaml/preprocess/parser_raw.ml" in let lid = @@ -40088,9 +40092,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40094 "src/ocaml/preprocess/parser_raw.ml" +# 40098 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -40099,30 +40103,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40105 "src/ocaml/preprocess/parser_raw.ml" +# 40109 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40113 "src/ocaml/preprocess/parser_raw.ml" +# 40117 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3279 "src/ocaml/preprocess/parser_raw.mly" +# 3283 "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 ) -# 40126 "src/ocaml/preprocess/parser_raw.ml" +# 40130 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40152,9 +40156,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2770 "src/ocaml/preprocess/parser_raw.mly" +# 2774 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 40158 "src/ocaml/preprocess/parser_raw.ml" +# 40162 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40187,9 +40191,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2772 "src/ocaml/preprocess/parser_raw.mly" +# 2776 "src/ocaml/preprocess/parser_raw.mly" ( let (l, o, p) = _1 in ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) ) -# 40193 "src/ocaml/preprocess/parser_raw.ml" +# 40197 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40240,17 +40244,17 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _3 = -# 2662 "src/ocaml/preprocess/parser_raw.mly" +# 2666 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 40246 "src/ocaml/preprocess/parser_raw.ml" +# 40250 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2774 "src/ocaml/preprocess/parser_raw.mly" +# 2778 "src/ocaml/preprocess/parser_raw.mly" ( mk_newtypes ~loc:_sloc _3 _5 ) -# 40254 "src/ocaml/preprocess/parser_raw.ml" +# 40258 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40277,39 +40281,39 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 40281 "src/ocaml/preprocess/parser_raw.ml" +# 40285 "src/ocaml/preprocess/parser_raw.ml" in let xs = let items = -# 1060 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 40287 "src/ocaml/preprocess/parser_raw.ml" +# 40291 "src/ocaml/preprocess/parser_raw.ml" in -# 1502 "src/ocaml/preprocess/parser_raw.mly" +# 1506 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 40292 "src/ocaml/preprocess/parser_raw.ml" +# 40296 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 40298 "src/ocaml/preprocess/parser_raw.ml" +# 40302 "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 -# 982 "src/ocaml/preprocess/parser_raw.mly" +# 986 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 40307 "src/ocaml/preprocess/parser_raw.ml" +# 40311 "src/ocaml/preprocess/parser_raw.ml" in -# 1495 "src/ocaml/preprocess/parser_raw.mly" +# 1499 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40313 "src/ocaml/preprocess/parser_raw.ml" +# 40317 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40350,7 +40354,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 40354 "src/ocaml/preprocess/parser_raw.ml" +# 40358 "src/ocaml/preprocess/parser_raw.ml" in let xs = let items = @@ -40358,65 +40362,65 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40364 "src/ocaml/preprocess/parser_raw.ml" +# 40368 "src/ocaml/preprocess/parser_raw.ml" in -# 1509 "src/ocaml/preprocess/parser_raw.mly" +# 1513 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 40369 "src/ocaml/preprocess/parser_raw.ml" +# 40373 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 998 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 40377 "src/ocaml/preprocess/parser_raw.ml" +# 40381 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1013 "src/ocaml/preprocess/parser_raw.mly" +# 1017 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 40387 "src/ocaml/preprocess/parser_raw.ml" +# 40391 "src/ocaml/preprocess/parser_raw.ml" in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 40393 "src/ocaml/preprocess/parser_raw.ml" +# 40397 "src/ocaml/preprocess/parser_raw.ml" in -# 1502 "src/ocaml/preprocess/parser_raw.mly" +# 1506 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 40399 "src/ocaml/preprocess/parser_raw.ml" +# 40403 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 40405 "src/ocaml/preprocess/parser_raw.ml" +# 40409 "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 -# 982 "src/ocaml/preprocess/parser_raw.mly" +# 986 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 40414 "src/ocaml/preprocess/parser_raw.ml" +# 40418 "src/ocaml/preprocess/parser_raw.ml" in -# 1495 "src/ocaml/preprocess/parser_raw.mly" +# 1499 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40420 "src/ocaml/preprocess/parser_raw.ml" +# 40424 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40442,9 +40446,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4074 "src/ocaml/preprocess/parser_raw.mly" +# 4078 "src/ocaml/preprocess/parser_raw.mly" ( val_of_lwt_bindings ~loc:_loc _1 ) -# 40448 "src/ocaml/preprocess/parser_raw.ml" +# 40452 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40470,9 +40474,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1524 "src/ocaml/preprocess/parser_raw.mly" +# 1528 "src/ocaml/preprocess/parser_raw.mly" ( val_of_let_bindings ~loc:_sloc _1 ) -# 40476 "src/ocaml/preprocess/parser_raw.ml" +# 40480 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40506,9 +40510,9 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40512 "src/ocaml/preprocess/parser_raw.ml" +# 40516 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -40516,10 +40520,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1527 "src/ocaml/preprocess/parser_raw.mly" +# 1531 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in Pstr_extension (_1, add_docs_attrs docs _2) ) -# 40523 "src/ocaml/preprocess/parser_raw.ml" +# 40527 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -40527,15 +40531,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mkstr ~loc:_sloc _1 ) -# 40533 "src/ocaml/preprocess/parser_raw.ml" +# 40537 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40539 "src/ocaml/preprocess/parser_raw.ml" +# 40543 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40559,23 +40563,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1530 "src/ocaml/preprocess/parser_raw.mly" +# 1534 "src/ocaml/preprocess/parser_raw.mly" ( Pstr_attribute _1 ) -# 40565 "src/ocaml/preprocess/parser_raw.ml" +# 40569 "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" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mkstr ~loc:_sloc _1 ) -# 40573 "src/ocaml/preprocess/parser_raw.ml" +# 40577 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40579 "src/ocaml/preprocess/parser_raw.ml" +# 40583 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40599,23 +40603,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1534 "src/ocaml/preprocess/parser_raw.mly" +# 1538 "src/ocaml/preprocess/parser_raw.mly" ( pstr_primitive _1 ) -# 40605 "src/ocaml/preprocess/parser_raw.ml" +# 40609 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40613 "src/ocaml/preprocess/parser_raw.ml" +# 40617 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40619 "src/ocaml/preprocess/parser_raw.ml" +# 40623 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40639,23 +40643,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1536 "src/ocaml/preprocess/parser_raw.mly" +# 1540 "src/ocaml/preprocess/parser_raw.mly" ( pstr_primitive _1 ) -# 40645 "src/ocaml/preprocess/parser_raw.ml" +# 40649 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40653 "src/ocaml/preprocess/parser_raw.ml" +# 40657 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40659 "src/ocaml/preprocess/parser_raw.ml" +# 40663 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40690,26 +40694,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1221 "src/ocaml/preprocess/parser_raw.mly" +# 1225 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 40696 "src/ocaml/preprocess/parser_raw.ml" +# 40700 "src/ocaml/preprocess/parser_raw.ml" in -# 3112 "src/ocaml/preprocess/parser_raw.mly" +# 3116 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40701 "src/ocaml/preprocess/parser_raw.ml" +# 40705 "src/ocaml/preprocess/parser_raw.ml" in -# 3095 "src/ocaml/preprocess/parser_raw.mly" +# 3099 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40707 "src/ocaml/preprocess/parser_raw.ml" +# 40711 "src/ocaml/preprocess/parser_raw.ml" in -# 1538 "src/ocaml/preprocess/parser_raw.mly" +# 1542 "src/ocaml/preprocess/parser_raw.mly" ( pstr_type _1 ) -# 40713 "src/ocaml/preprocess/parser_raw.ml" +# 40717 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -40717,15 +40721,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40723 "src/ocaml/preprocess/parser_raw.ml" +# 40727 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40729 "src/ocaml/preprocess/parser_raw.ml" +# 40733 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40810,16 +40814,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40816 "src/ocaml/preprocess/parser_raw.ml" +# 40820 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = -# 1213 "src/ocaml/preprocess/parser_raw.mly" +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 40823 "src/ocaml/preprocess/parser_raw.ml" +# 40827 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -40827,46 +40831,46 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40833 "src/ocaml/preprocess/parser_raw.ml" +# 40837 "src/ocaml/preprocess/parser_raw.ml" in let _4 = -# 3872 "src/ocaml/preprocess/parser_raw.mly" +# 3876 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 40839 "src/ocaml/preprocess/parser_raw.ml" +# 40843 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40846 "src/ocaml/preprocess/parser_raw.ml" +# 40850 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3367 "src/ocaml/preprocess/parser_raw.mly" +# 3371 "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 ) -# 40858 "src/ocaml/preprocess/parser_raw.ml" +# 40862 "src/ocaml/preprocess/parser_raw.ml" in -# 3350 "src/ocaml/preprocess/parser_raw.mly" +# 3354 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40864 "src/ocaml/preprocess/parser_raw.ml" +# 40868 "src/ocaml/preprocess/parser_raw.ml" in -# 1540 "src/ocaml/preprocess/parser_raw.mly" +# 1544 "src/ocaml/preprocess/parser_raw.mly" ( pstr_typext _1 ) -# 40870 "src/ocaml/preprocess/parser_raw.ml" +# 40874 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -40874,15 +40878,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40880 "src/ocaml/preprocess/parser_raw.ml" +# 40884 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40886 "src/ocaml/preprocess/parser_raw.ml" +# 40890 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40974,16 +40978,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40980 "src/ocaml/preprocess/parser_raw.ml" +# 40984 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = -# 1213 "src/ocaml/preprocess/parser_raw.mly" +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 40987 "src/ocaml/preprocess/parser_raw.ml" +# 40991 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -40991,9 +40995,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40997 "src/ocaml/preprocess/parser_raw.ml" +# 41001 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -41002,41 +41006,41 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3874 "src/ocaml/preprocess/parser_raw.mly" +# 3878 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 41008 "src/ocaml/preprocess/parser_raw.ml" +# 41012 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41016 "src/ocaml/preprocess/parser_raw.ml" +# 41020 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3367 "src/ocaml/preprocess/parser_raw.mly" +# 3371 "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 ) -# 41028 "src/ocaml/preprocess/parser_raw.ml" +# 41032 "src/ocaml/preprocess/parser_raw.ml" in -# 3350 "src/ocaml/preprocess/parser_raw.mly" +# 3354 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41034 "src/ocaml/preprocess/parser_raw.ml" +# 41038 "src/ocaml/preprocess/parser_raw.ml" in -# 1540 "src/ocaml/preprocess/parser_raw.mly" +# 1544 "src/ocaml/preprocess/parser_raw.mly" ( pstr_typext _1 ) -# 41040 "src/ocaml/preprocess/parser_raw.ml" +# 41044 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -41044,15 +41048,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41050 "src/ocaml/preprocess/parser_raw.ml" +# 41054 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41056 "src/ocaml/preprocess/parser_raw.ml" +# 41060 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41076,23 +41080,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1542 "src/ocaml/preprocess/parser_raw.mly" +# 1546 "src/ocaml/preprocess/parser_raw.mly" ( pstr_exception _1 ) -# 41082 "src/ocaml/preprocess/parser_raw.ml" +# 41086 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41090 "src/ocaml/preprocess/parser_raw.ml" +# 41094 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41096 "src/ocaml/preprocess/parser_raw.ml" +# 41100 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41155,9 +41159,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41161 "src/ocaml/preprocess/parser_raw.ml" +# 41165 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41167,36 +41171,36 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41173 "src/ocaml/preprocess/parser_raw.ml" +# 41177 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41181 "src/ocaml/preprocess/parser_raw.ml" +# 41185 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1568 "src/ocaml/preprocess/parser_raw.mly" +# 1572 "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 ) -# 41194 "src/ocaml/preprocess/parser_raw.ml" +# 41198 "src/ocaml/preprocess/parser_raw.ml" in -# 1544 "src/ocaml/preprocess/parser_raw.mly" +# 1548 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41200 "src/ocaml/preprocess/parser_raw.ml" +# 41204 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -41204,15 +41208,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41210 "src/ocaml/preprocess/parser_raw.ml" +# 41214 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41216 "src/ocaml/preprocess/parser_raw.ml" +# 41220 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41291,9 +41295,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41297 "src/ocaml/preprocess/parser_raw.ml" +# 41301 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41303,24 +41307,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41309 "src/ocaml/preprocess/parser_raw.ml" +# 41313 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41317 "src/ocaml/preprocess/parser_raw.ml" +# 41321 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1603 "src/ocaml/preprocess/parser_raw.mly" +# 1607 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in @@ -41328,25 +41332,25 @@ module Tables = struct ext, Mb.mk name body ~attrs ~loc ~docs ) -# 41332 "src/ocaml/preprocess/parser_raw.ml" +# 41336 "src/ocaml/preprocess/parser_raw.ml" in -# 1221 "src/ocaml/preprocess/parser_raw.mly" +# 1225 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 41338 "src/ocaml/preprocess/parser_raw.ml" +# 41342 "src/ocaml/preprocess/parser_raw.ml" in -# 1591 "src/ocaml/preprocess/parser_raw.mly" +# 1595 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41344 "src/ocaml/preprocess/parser_raw.ml" +# 41348 "src/ocaml/preprocess/parser_raw.ml" in -# 1546 "src/ocaml/preprocess/parser_raw.mly" +# 1550 "src/ocaml/preprocess/parser_raw.mly" ( pstr_recmodule _1 ) -# 41350 "src/ocaml/preprocess/parser_raw.ml" +# 41354 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -41354,15 +41358,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41360 "src/ocaml/preprocess/parser_raw.ml" +# 41364 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41366 "src/ocaml/preprocess/parser_raw.ml" +# 41370 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41386,23 +41390,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1548 "src/ocaml/preprocess/parser_raw.mly" +# 1552 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Pstr_modtype body, ext) ) -# 41392 "src/ocaml/preprocess/parser_raw.ml" +# 41396 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41400 "src/ocaml/preprocess/parser_raw.ml" +# 41404 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41406 "src/ocaml/preprocess/parser_raw.ml" +# 41410 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41426,23 +41430,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1550 "src/ocaml/preprocess/parser_raw.mly" +# 1554 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Pstr_open body, ext) ) -# 41432 "src/ocaml/preprocess/parser_raw.ml" +# 41436 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41440 "src/ocaml/preprocess/parser_raw.ml" +# 41444 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41446 "src/ocaml/preprocess/parser_raw.ml" +# 41450 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41512,9 +41516,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 41518 "src/ocaml/preprocess/parser_raw.ml" +# 41522 "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 @@ -41532,9 +41536,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41538 "src/ocaml/preprocess/parser_raw.ml" +# 41542 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41544,24 +41548,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41550 "src/ocaml/preprocess/parser_raw.ml" +# 41554 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41558 "src/ocaml/preprocess/parser_raw.ml" +# 41562 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1947 "src/ocaml/preprocess/parser_raw.mly" +# 1951 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -41569,25 +41573,25 @@ module Tables = struct ext, Ci.mk id body ~virt ~params ~attrs ~loc ~docs ) -# 41573 "src/ocaml/preprocess/parser_raw.ml" +# 41577 "src/ocaml/preprocess/parser_raw.ml" in -# 1221 "src/ocaml/preprocess/parser_raw.mly" +# 1225 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 41579 "src/ocaml/preprocess/parser_raw.ml" +# 41583 "src/ocaml/preprocess/parser_raw.ml" in -# 1936 "src/ocaml/preprocess/parser_raw.mly" +# 1940 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41585 "src/ocaml/preprocess/parser_raw.ml" +# 41589 "src/ocaml/preprocess/parser_raw.ml" in -# 1552 "src/ocaml/preprocess/parser_raw.mly" +# 1556 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Pstr_class l, ext) ) -# 41591 "src/ocaml/preprocess/parser_raw.ml" +# 41595 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -41595,15 +41599,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41601 "src/ocaml/preprocess/parser_raw.ml" +# 41605 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41607 "src/ocaml/preprocess/parser_raw.ml" +# 41611 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41627,23 +41631,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1554 "src/ocaml/preprocess/parser_raw.mly" +# 1558 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Pstr_class_type l, ext) ) -# 41633 "src/ocaml/preprocess/parser_raw.ml" +# 41637 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41641 "src/ocaml/preprocess/parser_raw.ml" +# 41645 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41647 "src/ocaml/preprocess/parser_raw.ml" +# 41651 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41699,38 +41703,38 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41705 "src/ocaml/preprocess/parser_raw.ml" +# 41709 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41714 "src/ocaml/preprocess/parser_raw.ml" +# 41718 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1640 "src/ocaml/preprocess/parser_raw.mly" +# 1644 "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 ) -# 41728 "src/ocaml/preprocess/parser_raw.ml" +# 41732 "src/ocaml/preprocess/parser_raw.ml" in -# 1556 "src/ocaml/preprocess/parser_raw.mly" +# 1560 "src/ocaml/preprocess/parser_raw.mly" ( pstr_include _1 ) -# 41734 "src/ocaml/preprocess/parser_raw.ml" +# 41738 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -41738,15 +41742,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1046 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41744 "src/ocaml/preprocess/parser_raw.ml" +# 41748 "src/ocaml/preprocess/parser_raw.ml" in -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41750 "src/ocaml/preprocess/parser_raw.ml" +# 41754 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41769,9 +41773,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3941 "src/ocaml/preprocess/parser_raw.mly" ( "-" ) -# 41775 "src/ocaml/preprocess/parser_raw.ml" +# 41779 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41794,9 +41798,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3942 "src/ocaml/preprocess/parser_raw.mly" ( "-." ) -# 41800 "src/ocaml/preprocess/parser_raw.ml" +# 41804 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41849,9 +41853,9 @@ module Tables = struct let _v : (Parsetree.row_field) = let _5 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41855 "src/ocaml/preprocess/parser_raw.ml" +# 41859 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined1_ in @@ -41860,18 +41864,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 41864 "src/ocaml/preprocess/parser_raw.ml" +# 41868 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 41869 "src/ocaml/preprocess/parser_raw.ml" +# 41873 "src/ocaml/preprocess/parser_raw.ml" in -# 3641 "src/ocaml/preprocess/parser_raw.mly" +# 3645 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41875 "src/ocaml/preprocess/parser_raw.ml" +# 41879 "src/ocaml/preprocess/parser_raw.ml" in let _1 = @@ -41879,20 +41883,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41885 "src/ocaml/preprocess/parser_raw.ml" +# 41889 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3627 "src/ocaml/preprocess/parser_raw.mly" +# 3631 "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 ) -# 41896 "src/ocaml/preprocess/parser_raw.ml" +# 41900 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41924,9 +41928,9 @@ module Tables = struct let _v : (Parsetree.row_field) = let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41930 "src/ocaml/preprocess/parser_raw.ml" +# 41934 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -41935,20 +41939,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41941 "src/ocaml/preprocess/parser_raw.ml" +# 41945 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3631 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "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 [] ) -# 41952 "src/ocaml/preprocess/parser_raw.ml" +# 41956 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41980,7 +41984,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase) = let arg = # 124 "" ( None ) -# 41984 "src/ocaml/preprocess/parser_raw.ml" +# 41988 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined1_ in let dir = @@ -41989,18 +41993,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41995 "src/ocaml/preprocess/parser_raw.ml" +# 41999 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3835 "src/ocaml/preprocess/parser_raw.mly" +# 3839 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42004 "src/ocaml/preprocess/parser_raw.ml" +# 42008 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42031,9 +42035,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : ( -# 831 "src/ocaml/preprocess/parser_raw.mly" +# 835 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 42037 "src/ocaml/preprocess/parser_raw.ml" +# 42041 "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 @@ -42044,23 +42048,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3839 "src/ocaml/preprocess/parser_raw.mly" +# 3843 "src/ocaml/preprocess/parser_raw.mly" ( let (s, _, _) = _1 in Pdir_string s ) -# 42050 "src/ocaml/preprocess/parser_raw.ml" +# 42054 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "src/ocaml/preprocess/parser_raw.mly" +# 1055 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42058 "src/ocaml/preprocess/parser_raw.ml" +# 42062 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42064 "src/ocaml/preprocess/parser_raw.ml" +# 42068 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42070,18 +42074,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42076 "src/ocaml/preprocess/parser_raw.ml" +# 42080 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3835 "src/ocaml/preprocess/parser_raw.mly" +# 3839 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42085 "src/ocaml/preprocess/parser_raw.ml" +# 42089 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42112,9 +42116,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 783 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 42118 "src/ocaml/preprocess/parser_raw.ml" +# 42122 "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 @@ -42125,23 +42129,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3840 "src/ocaml/preprocess/parser_raw.mly" +# 3844 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _1 in Pdir_int (n ,m) ) -# 42131 "src/ocaml/preprocess/parser_raw.ml" +# 42135 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "src/ocaml/preprocess/parser_raw.mly" +# 1055 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42139 "src/ocaml/preprocess/parser_raw.ml" +# 42143 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42145 "src/ocaml/preprocess/parser_raw.ml" +# 42149 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42151,18 +42155,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42157 "src/ocaml/preprocess/parser_raw.ml" +# 42161 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3835 "src/ocaml/preprocess/parser_raw.mly" +# 3839 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42166 "src/ocaml/preprocess/parser_raw.ml" +# 42170 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42202,23 +42206,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3841 "src/ocaml/preprocess/parser_raw.mly" +# 3845 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_ident _1 ) -# 42208 "src/ocaml/preprocess/parser_raw.ml" +# 42212 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "src/ocaml/preprocess/parser_raw.mly" +# 1055 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42216 "src/ocaml/preprocess/parser_raw.ml" +# 42220 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42222 "src/ocaml/preprocess/parser_raw.ml" +# 42226 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42228,18 +42232,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42234 "src/ocaml/preprocess/parser_raw.ml" +# 42238 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3835 "src/ocaml/preprocess/parser_raw.mly" +# 3839 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42243 "src/ocaml/preprocess/parser_raw.ml" +# 42247 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42279,23 +42283,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3842 "src/ocaml/preprocess/parser_raw.mly" +# 3846 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_ident _1 ) -# 42285 "src/ocaml/preprocess/parser_raw.ml" +# 42289 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "src/ocaml/preprocess/parser_raw.mly" +# 1055 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42293 "src/ocaml/preprocess/parser_raw.ml" +# 42297 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42299 "src/ocaml/preprocess/parser_raw.ml" +# 42303 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42305,18 +42309,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42311 "src/ocaml/preprocess/parser_raw.ml" +# 42315 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3835 "src/ocaml/preprocess/parser_raw.mly" +# 3839 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42320 "src/ocaml/preprocess/parser_raw.ml" +# 42324 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42356,23 +42360,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3843 "src/ocaml/preprocess/parser_raw.mly" +# 3847 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_bool false ) -# 42362 "src/ocaml/preprocess/parser_raw.ml" +# 42366 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "src/ocaml/preprocess/parser_raw.mly" +# 1055 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42370 "src/ocaml/preprocess/parser_raw.ml" +# 42374 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42376 "src/ocaml/preprocess/parser_raw.ml" +# 42380 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42382,18 +42386,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42388 "src/ocaml/preprocess/parser_raw.ml" +# 42392 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3835 "src/ocaml/preprocess/parser_raw.mly" +# 3839 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42397 "src/ocaml/preprocess/parser_raw.ml" +# 42401 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42433,23 +42437,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3844 "src/ocaml/preprocess/parser_raw.mly" +# 3848 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_bool true ) -# 42439 "src/ocaml/preprocess/parser_raw.ml" +# 42443 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1051 "src/ocaml/preprocess/parser_raw.mly" +# 1055 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42447 "src/ocaml/preprocess/parser_raw.ml" +# 42451 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42453 "src/ocaml/preprocess/parser_raw.ml" +# 42457 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42459,18 +42463,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42465 "src/ocaml/preprocess/parser_raw.ml" +# 42469 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3835 "src/ocaml/preprocess/parser_raw.mly" +# 3839 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42474 "src/ocaml/preprocess/parser_raw.ml" +# 42478 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42510,37 +42514,37 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42516 "src/ocaml/preprocess/parser_raw.ml" +# 42520 "src/ocaml/preprocess/parser_raw.ml" in -# 1509 "src/ocaml/preprocess/parser_raw.mly" +# 1513 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 42521 "src/ocaml/preprocess/parser_raw.ml" +# 42525 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 998 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 42529 "src/ocaml/preprocess/parser_raw.ml" +# 42533 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 982 "src/ocaml/preprocess/parser_raw.mly" +# 986 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 42538 "src/ocaml/preprocess/parser_raw.ml" +# 42542 "src/ocaml/preprocess/parser_raw.ml" in -# 1261 "src/ocaml/preprocess/parser_raw.mly" +# 1265 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def _1 ) -# 42544 "src/ocaml/preprocess/parser_raw.ml" +# 42548 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42573,21 +42577,21 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 42577 "src/ocaml/preprocess/parser_raw.ml" +# 42581 "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 -# 982 "src/ocaml/preprocess/parser_raw.mly" +# 986 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 42585 "src/ocaml/preprocess/parser_raw.ml" +# 42589 "src/ocaml/preprocess/parser_raw.ml" in -# 1265 "src/ocaml/preprocess/parser_raw.mly" +# 1269 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def _1 ) -# 42591 "src/ocaml/preprocess/parser_raw.ml" +# 42595 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42617,9 +42621,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.toplevel_phrase) = -# 1269 "src/ocaml/preprocess/parser_raw.mly" +# 1273 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42623 "src/ocaml/preprocess/parser_raw.ml" +# 42627 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42642,9 +42646,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.toplevel_phrase) = -# 1272 "src/ocaml/preprocess/parser_raw.mly" +# 1276 "src/ocaml/preprocess/parser_raw.mly" ( raise End_of_file ) -# 42648 "src/ocaml/preprocess/parser_raw.ml" +# 42652 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42667,9 +42671,9 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.core_type) = -# 3533 "src/ocaml/preprocess/parser_raw.mly" +# 3537 "src/ocaml/preprocess/parser_raw.mly" ( ty ) -# 42673 "src/ocaml/preprocess/parser_raw.ml" +# 42677 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42697,18 +42701,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 42701 "src/ocaml/preprocess/parser_raw.ml" +# 42705 "src/ocaml/preprocess/parser_raw.ml" in -# 1152 "src/ocaml/preprocess/parser_raw.mly" +# 1156 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 42706 "src/ocaml/preprocess/parser_raw.ml" +# 42710 "src/ocaml/preprocess/parser_raw.ml" in -# 3536 "src/ocaml/preprocess/parser_raw.mly" +# 3540 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_tuple tys ) -# 42712 "src/ocaml/preprocess/parser_raw.ml" +# 42716 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -42716,15 +42720,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 42722 "src/ocaml/preprocess/parser_raw.ml" +# 42726 "src/ocaml/preprocess/parser_raw.ml" in -# 3538 "src/ocaml/preprocess/parser_raw.mly" +# 3542 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42728 "src/ocaml/preprocess/parser_raw.ml" +# 42732 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42754,9 +42758,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type option * Parsetree.core_type option) = -# 2849 "src/ocaml/preprocess/parser_raw.mly" +# 2853 "src/ocaml/preprocess/parser_raw.mly" ( (Some _2, None) ) -# 42760 "src/ocaml/preprocess/parser_raw.ml" +# 42764 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42800,9 +42804,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.core_type option * Parsetree.core_type option) = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2854 "src/ocaml/preprocess/parser_raw.mly" ( (Some _2, Some _4) ) -# 42806 "src/ocaml/preprocess/parser_raw.ml" +# 42810 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42832,9 +42836,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type option * Parsetree.core_type option) = -# 2851 "src/ocaml/preprocess/parser_raw.mly" +# 2855 "src/ocaml/preprocess/parser_raw.mly" ( (None, Some _2) ) -# 42838 "src/ocaml/preprocess/parser_raw.ml" +# 42842 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42850,9 +42854,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3190 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, Public, None) ) -# 42856 "src/ocaml/preprocess/parser_raw.ml" +# 42860 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42882,9 +42886,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = -# 3188 "src/ocaml/preprocess/parser_raw.mly" +# 3192 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 42888 "src/ocaml/preprocess/parser_raw.ml" +# 42892 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42907,9 +42911,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3794 "src/ocaml/preprocess/parser_raw.mly" +# 3798 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42913 "src/ocaml/preprocess/parser_raw.ml" +# 42917 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42939,9 +42943,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) = -# 3203 "src/ocaml/preprocess/parser_raw.mly" +# 3207 "src/ocaml/preprocess/parser_raw.mly" ( _2, _1 ) -# 42945 "src/ocaml/preprocess/parser_raw.ml" +# 42949 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42957,9 +42961,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = -# 3196 "src/ocaml/preprocess/parser_raw.mly" +# 3200 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 42963 "src/ocaml/preprocess/parser_raw.ml" +# 42967 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42982,9 +42986,9 @@ module Tables = struct let _startpos = _startpos_p_ in let _endpos = _endpos_p_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = -# 3198 "src/ocaml/preprocess/parser_raw.mly" +# 3202 "src/ocaml/preprocess/parser_raw.mly" ( [p] ) -# 42988 "src/ocaml/preprocess/parser_raw.ml" +# 42992 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43024,18 +43028,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 43028 "src/ocaml/preprocess/parser_raw.ml" +# 43032 "src/ocaml/preprocess/parser_raw.ml" in -# 1124 "src/ocaml/preprocess/parser_raw.mly" +# 1128 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 43033 "src/ocaml/preprocess/parser_raw.ml" +# 43037 "src/ocaml/preprocess/parser_raw.ml" in -# 3200 "src/ocaml/preprocess/parser_raw.mly" +# 3204 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 43039 "src/ocaml/preprocess/parser_raw.ml" +# 43043 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43066,24 +43070,24 @@ module Tables = struct let _endpos = _endpos_tyvar_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3208 "src/ocaml/preprocess/parser_raw.mly" +# 3212 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_var tyvar ) -# 43072 "src/ocaml/preprocess/parser_raw.ml" +# 43076 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43081 "src/ocaml/preprocess/parser_raw.ml" +# 43085 "src/ocaml/preprocess/parser_raw.ml" in -# 3211 "src/ocaml/preprocess/parser_raw.mly" +# 3215 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43087 "src/ocaml/preprocess/parser_raw.ml" +# 43091 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43107,23 +43111,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3210 "src/ocaml/preprocess/parser_raw.mly" +# 3214 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 43113 "src/ocaml/preprocess/parser_raw.ml" +# 43117 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43121 "src/ocaml/preprocess/parser_raw.ml" +# 43125 "src/ocaml/preprocess/parser_raw.ml" in -# 3211 "src/ocaml/preprocess/parser_raw.mly" +# 3215 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43127 "src/ocaml/preprocess/parser_raw.ml" +# 43131 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43139,9 +43143,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3215 "src/ocaml/preprocess/parser_raw.mly" +# 3219 "src/ocaml/preprocess/parser_raw.mly" ( NoVariance, NoInjectivity ) -# 43145 "src/ocaml/preprocess/parser_raw.ml" +# 43149 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43164,9 +43168,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3216 "src/ocaml/preprocess/parser_raw.mly" +# 3220 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, NoInjectivity ) -# 43170 "src/ocaml/preprocess/parser_raw.ml" +# 43174 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43189,9 +43193,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3217 "src/ocaml/preprocess/parser_raw.mly" +# 3221 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, NoInjectivity ) -# 43195 "src/ocaml/preprocess/parser_raw.ml" +# 43199 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43214,9 +43218,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3218 "src/ocaml/preprocess/parser_raw.mly" +# 3222 "src/ocaml/preprocess/parser_raw.mly" ( NoVariance, Injective ) -# 43220 "src/ocaml/preprocess/parser_raw.ml" +# 43224 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43246,9 +43250,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3219 "src/ocaml/preprocess/parser_raw.mly" +# 3223 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, Injective ) -# 43252 "src/ocaml/preprocess/parser_raw.ml" +# 43256 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43278,9 +43282,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3219 "src/ocaml/preprocess/parser_raw.mly" +# 3223 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, Injective ) -# 43284 "src/ocaml/preprocess/parser_raw.ml" +# 43288 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43310,9 +43314,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3220 "src/ocaml/preprocess/parser_raw.mly" +# 3224 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, Injective ) -# 43316 "src/ocaml/preprocess/parser_raw.ml" +# 43320 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43342,9 +43346,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3220 "src/ocaml/preprocess/parser_raw.mly" +# 3224 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, Injective ) -# 43348 "src/ocaml/preprocess/parser_raw.ml" +# 43352 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43363,21 +43367,21 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 771 "src/ocaml/preprocess/parser_raw.mly" +# 775 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43369 "src/ocaml/preprocess/parser_raw.ml" +# 43373 "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 -# 3222 "src/ocaml/preprocess/parser_raw.mly" +# 3226 "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) ) -# 43381 "src/ocaml/preprocess/parser_raw.ml" +# 43385 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43396,21 +43400,21 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 817 "src/ocaml/preprocess/parser_raw.mly" +# 821 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43402 "src/ocaml/preprocess/parser_raw.ml" +# 43406 "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 -# 3227 "src/ocaml/preprocess/parser_raw.mly" +# 3231 "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) ) -# 43414 "src/ocaml/preprocess/parser_raw.ml" +# 43418 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43444,39 +43448,39 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 43448 "src/ocaml/preprocess/parser_raw.ml" +# 43452 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _1 = -# 1060 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 43454 "src/ocaml/preprocess/parser_raw.ml" +# 43458 "src/ocaml/preprocess/parser_raw.ml" in -# 1292 "src/ocaml/preprocess/parser_raw.mly" +# 1296 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43459 "src/ocaml/preprocess/parser_raw.ml" +# 43463 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 43465 "src/ocaml/preprocess/parser_raw.ml" +# 43469 "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 -# 986 "src/ocaml/preprocess/parser_raw.mly" +# 990 "src/ocaml/preprocess/parser_raw.mly" ( extra_def _startpos _endpos _1 ) -# 43474 "src/ocaml/preprocess/parser_raw.ml" +# 43478 "src/ocaml/preprocess/parser_raw.ml" in -# 1285 "src/ocaml/preprocess/parser_raw.mly" +# 1289 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43480 "src/ocaml/preprocess/parser_raw.ml" +# 43484 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43524,7 +43528,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 43528 "src/ocaml/preprocess/parser_raw.ml" +# 43532 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _1 = @@ -43532,61 +43536,61 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43538 "src/ocaml/preprocess/parser_raw.ml" +# 43542 "src/ocaml/preprocess/parser_raw.ml" in -# 1509 "src/ocaml/preprocess/parser_raw.mly" +# 1513 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 43543 "src/ocaml/preprocess/parser_raw.ml" +# 43547 "src/ocaml/preprocess/parser_raw.ml" in -# 1004 "src/ocaml/preprocess/parser_raw.mly" +# 1008 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 43549 "src/ocaml/preprocess/parser_raw.ml" +# 43553 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1002 "src/ocaml/preprocess/parser_raw.mly" +# 1006 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 43557 "src/ocaml/preprocess/parser_raw.ml" +# 43561 "src/ocaml/preprocess/parser_raw.ml" in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 43563 "src/ocaml/preprocess/parser_raw.ml" +# 43567 "src/ocaml/preprocess/parser_raw.ml" in -# 1292 "src/ocaml/preprocess/parser_raw.mly" +# 1296 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43569 "src/ocaml/preprocess/parser_raw.ml" +# 43573 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 43575 "src/ocaml/preprocess/parser_raw.ml" +# 43579 "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 -# 986 "src/ocaml/preprocess/parser_raw.mly" +# 990 "src/ocaml/preprocess/parser_raw.mly" ( extra_def _startpos _endpos _1 ) -# 43584 "src/ocaml/preprocess/parser_raw.ml" +# 43588 "src/ocaml/preprocess/parser_raw.ml" in -# 1285 "src/ocaml/preprocess/parser_raw.mly" +# 1289 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43590 "src/ocaml/preprocess/parser_raw.ml" +# 43594 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43623,9 +43627,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = -# 3711 "src/ocaml/preprocess/parser_raw.mly" +# 3715 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 43629 "src/ocaml/preprocess/parser_raw.ml" +# 43633 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43644,17 +43648,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43650 "src/ocaml/preprocess/parser_raw.ml" +# 43654 "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) = -# 3719 "src/ocaml/preprocess/parser_raw.mly" +# 3723 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43658 "src/ocaml/preprocess/parser_raw.ml" +# 43662 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43677,9 +43681,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3720 "src/ocaml/preprocess/parser_raw.mly" +# 3724 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43683 "src/ocaml/preprocess/parser_raw.ml" +# 43687 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43702,9 +43706,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3792 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43708 "src/ocaml/preprocess/parser_raw.ml" +# 43712 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43749,9 +43753,9 @@ module Tables = struct let ty : (Parsetree.core_type) = Obj.magic ty in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43755 "src/ocaml/preprocess/parser_raw.ml" +# 43759 "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 @@ -43762,33 +43766,33 @@ module Tables = struct Parsetree.attributes) = let label = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43768 "src/ocaml/preprocess/parser_raw.ml" +# 43772 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43776 "src/ocaml/preprocess/parser_raw.ml" +# 43780 "src/ocaml/preprocess/parser_raw.ml" in let attrs = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43782 "src/ocaml/preprocess/parser_raw.ml" +# 43786 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3930 "src/ocaml/preprocess/parser_raw.mly" +# 3934 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 43787 "src/ocaml/preprocess/parser_raw.ml" +# 43791 "src/ocaml/preprocess/parser_raw.ml" in -# 2093 "src/ocaml/preprocess/parser_raw.mly" +# 2097 "src/ocaml/preprocess/parser_raw.mly" ( (label, mutable_, Cfk_virtual ty), attrs ) -# 43792 "src/ocaml/preprocess/parser_raw.ml" +# 43796 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43833,9 +43837,9 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43839 "src/ocaml/preprocess/parser_raw.ml" +# 43843 "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 @@ -43846,33 +43850,33 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43852 "src/ocaml/preprocess/parser_raw.ml" +# 43856 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43860 "src/ocaml/preprocess/parser_raw.ml" +# 43864 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43866 "src/ocaml/preprocess/parser_raw.ml" +# 43870 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 43871 "src/ocaml/preprocess/parser_raw.ml" +# 43875 "src/ocaml/preprocess/parser_raw.ml" in -# 2095 "src/ocaml/preprocess/parser_raw.mly" +# 2099 "src/ocaml/preprocess/parser_raw.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 43876 "src/ocaml/preprocess/parser_raw.ml" +# 43880 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43923,9 +43927,9 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43929 "src/ocaml/preprocess/parser_raw.ml" +# 43933 "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 @@ -43937,36 +43941,36 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43943 "src/ocaml/preprocess/parser_raw.ml" +# 43947 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43951 "src/ocaml/preprocess/parser_raw.ml" +# 43955 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43959 "src/ocaml/preprocess/parser_raw.ml" +# 43963 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 43965 "src/ocaml/preprocess/parser_raw.ml" +# 43969 "src/ocaml/preprocess/parser_raw.ml" in -# 2095 "src/ocaml/preprocess/parser_raw.mly" +# 2099 "src/ocaml/preprocess/parser_raw.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 43970 "src/ocaml/preprocess/parser_raw.ml" +# 43974 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44018,9 +44022,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _5 in let _1_inlined1 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44024 "src/ocaml/preprocess/parser_raw.ml" +# 44028 "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 @@ -44031,30 +44035,30 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44037 "src/ocaml/preprocess/parser_raw.ml" +# 44041 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44045 "src/ocaml/preprocess/parser_raw.ml" +# 44049 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44052 "src/ocaml/preprocess/parser_raw.ml" +# 44056 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 44058 "src/ocaml/preprocess/parser_raw.ml" +# 44062 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__7_ in @@ -44070,11 +44074,11 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2098 "src/ocaml/preprocess/parser_raw.mly" +# 2102 "src/ocaml/preprocess/parser_raw.mly" ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 44078 "src/ocaml/preprocess/parser_raw.ml" +# 44082 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44132,9 +44136,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _5 in let _1_inlined2 : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44138 "src/ocaml/preprocess/parser_raw.ml" +# 44142 "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 @@ -44146,33 +44150,33 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3689 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44152 "src/ocaml/preprocess/parser_raw.ml" +# 44156 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44160 "src/ocaml/preprocess/parser_raw.ml" +# 44164 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44169 "src/ocaml/preprocess/parser_raw.ml" +# 44173 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 44176 "src/ocaml/preprocess/parser_raw.ml" +# 44180 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -44187,11 +44191,11 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2098 "src/ocaml/preprocess/parser_raw.mly" +# 2102 "src/ocaml/preprocess/parser_raw.mly" ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 44195 "src/ocaml/preprocess/parser_raw.ml" +# 44199 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44258,9 +44262,9 @@ module Tables = struct let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4027 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44264 "src/ocaml/preprocess/parser_raw.ml" +# 44268 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -44270,30 +44274,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44276 "src/ocaml/preprocess/parser_raw.ml" +# 44280 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44284 "src/ocaml/preprocess/parser_raw.ml" +# 44288 "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" +# 3061 "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 ) -# 44297 "src/ocaml/preprocess/parser_raw.ml" +# 44301 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44309,9 +44313,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.virtual_flag) = -# 3894 "src/ocaml/preprocess/parser_raw.mly" +# 3898 "src/ocaml/preprocess/parser_raw.mly" ( Concrete ) -# 44315 "src/ocaml/preprocess/parser_raw.ml" +# 44319 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44334,9 +44338,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.virtual_flag) = -# 3895 "src/ocaml/preprocess/parser_raw.mly" +# 3899 "src/ocaml/preprocess/parser_raw.mly" ( Virtual ) -# 44340 "src/ocaml/preprocess/parser_raw.ml" +# 44344 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44359,9 +44363,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag) = -# 3918 "src/ocaml/preprocess/parser_raw.mly" +# 3922 "src/ocaml/preprocess/parser_raw.mly" ( Immutable ) -# 44365 "src/ocaml/preprocess/parser_raw.ml" +# 44369 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44391,9 +44395,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag) = -# 3919 "src/ocaml/preprocess/parser_raw.mly" +# 3923 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 44397 "src/ocaml/preprocess/parser_raw.ml" +# 44401 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44423,9 +44427,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag) = -# 3920 "src/ocaml/preprocess/parser_raw.mly" +# 3924 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 44429 "src/ocaml/preprocess/parser_raw.ml" +# 44433 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44448,9 +44452,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = -# 3925 "src/ocaml/preprocess/parser_raw.mly" +# 3929 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 44454 "src/ocaml/preprocess/parser_raw.ml" +# 44458 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44480,9 +44484,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3926 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 44486 "src/ocaml/preprocess/parser_raw.ml" +# 44490 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44512,9 +44516,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3927 "src/ocaml/preprocess/parser_raw.mly" +# 3931 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 44518 "src/ocaml/preprocess/parser_raw.ml" +# 44522 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44576,27 +44580,27 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 44580 "src/ocaml/preprocess/parser_raw.ml" +# 44584 "src/ocaml/preprocess/parser_raw.ml" in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1078 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 44585 "src/ocaml/preprocess/parser_raw.ml" +# 44589 "src/ocaml/preprocess/parser_raw.ml" in -# 3157 "src/ocaml/preprocess/parser_raw.mly" +# 3161 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44591 "src/ocaml/preprocess/parser_raw.ml" +# 44595 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos_xs_ in let _5 = let _1 = _1_inlined2 in -# 3481 "src/ocaml/preprocess/parser_raw.mly" +# 3485 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44600 "src/ocaml/preprocess/parser_raw.ml" +# 44604 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -44605,16 +44609,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44611 "src/ocaml/preprocess/parser_raw.ml" +# 44615 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3400 "src/ocaml/preprocess/parser_raw.mly" +# 3404 "src/ocaml/preprocess/parser_raw.mly" ( let lident = loc_last _3 in Pwith_type (_3, @@ -44624,7 +44628,7 @@ module Tables = struct ~manifest:_5 ~priv:_4 ~loc:(make_loc _sloc))) ) -# 44628 "src/ocaml/preprocess/parser_raw.ml" +# 44632 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44677,9 +44681,9 @@ module Tables = struct let _v : (Parsetree.with_constraint) = let _5 = let _1 = _1_inlined2 in -# 3481 "src/ocaml/preprocess/parser_raw.mly" +# 3485 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44683 "src/ocaml/preprocess/parser_raw.ml" +# 44687 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in @@ -44689,16 +44693,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44695 "src/ocaml/preprocess/parser_raw.ml" +# 44699 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3413 "src/ocaml/preprocess/parser_raw.mly" +# 3417 "src/ocaml/preprocess/parser_raw.mly" ( let lident = loc_last _3 in Pwith_typesubst (_3, @@ -44706,7 +44710,7 @@ module Tables = struct ~params:_2 ~manifest:_5 ~loc:(make_loc _sloc))) ) -# 44710 "src/ocaml/preprocess/parser_raw.ml" +# 44714 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44755,9 +44759,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44761 "src/ocaml/preprocess/parser_raw.ml" +# 44765 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -44766,15 +44770,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44772 "src/ocaml/preprocess/parser_raw.ml" +# 44776 "src/ocaml/preprocess/parser_raw.ml" in -# 3421 "src/ocaml/preprocess/parser_raw.mly" +# 3425 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_module (_2, _4) ) -# 44778 "src/ocaml/preprocess/parser_raw.ml" +# 44782 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44823,9 +44827,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44829 "src/ocaml/preprocess/parser_raw.ml" +# 44833 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -44834,15 +44838,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44840 "src/ocaml/preprocess/parser_raw.ml" +# 44844 "src/ocaml/preprocess/parser_raw.ml" in -# 3423 "src/ocaml/preprocess/parser_raw.mly" +# 3427 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modsubst (_2, _4) ) -# 44846 "src/ocaml/preprocess/parser_raw.ml" +# 44850 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44898,15 +44902,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44904 "src/ocaml/preprocess/parser_raw.ml" +# 44908 "src/ocaml/preprocess/parser_raw.ml" in -# 3425 "src/ocaml/preprocess/parser_raw.mly" +# 3429 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modtype (l, rhs) ) -# 44910 "src/ocaml/preprocess/parser_raw.ml" +# 44914 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44962,15 +44966,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44968 "src/ocaml/preprocess/parser_raw.ml" +# 44972 "src/ocaml/preprocess/parser_raw.ml" in -# 3427 "src/ocaml/preprocess/parser_raw.mly" +# 3431 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modtypesubst (l, rhs) ) -# 44974 "src/ocaml/preprocess/parser_raw.ml" +# 44978 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44993,9 +44997,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = -# 3430 "src/ocaml/preprocess/parser_raw.mly" +# 3434 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 44999 "src/ocaml/preprocess/parser_raw.ml" +# 45003 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45025,9 +45029,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3431 "src/ocaml/preprocess/parser_raw.mly" +# 3435 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 45031 "src/ocaml/preprocess/parser_raw.ml" +# 45035 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45063,9 +45067,9 @@ module MenhirInterpreter = struct | T_VAL : unit terminal | T_UNDERSCORE : unit terminal | T_UIDENT : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 849 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45069 "src/ocaml/preprocess/parser_raw.ml" +# 45073 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_TYPE : unit terminal | T_TRY_LWT : unit terminal @@ -45076,9 +45080,9 @@ module MenhirInterpreter = struct | T_THEN : unit terminal | T_STRUCT : unit terminal | T_STRING : ( -# 831 "src/ocaml/preprocess/parser_raw.mly" +# 835 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 45082 "src/ocaml/preprocess/parser_raw.ml" +# 45086 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_STAR : unit terminal | T_SIG : unit terminal @@ -45089,22 +45093,22 @@ module MenhirInterpreter = struct | T_RBRACKET : unit terminal | T_RBRACE : unit terminal | T_QUOTED_STRING_ITEM : ( -# 836 "src/ocaml/preprocess/parser_raw.mly" +# 840 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 45095 "src/ocaml/preprocess/parser_raw.ml" +# 45099 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_QUOTED_STRING_EXPR : ( -# 833 "src/ocaml/preprocess/parser_raw.mly" +# 837 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 45100 "src/ocaml/preprocess/parser_raw.ml" +# 45104 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_QUOTE : unit terminal | T_QUESTION : unit terminal | T_PRIVATE : unit terminal | T_PREFIXOP : ( -# 817 "src/ocaml/preprocess/parser_raw.mly" +# 821 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45108 "src/ocaml/preprocess/parser_raw.ml" +# 45112 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_PLUSEQ : unit terminal | T_PLUSDOT : unit terminal @@ -45112,9 +45116,9 @@ module MenhirInterpreter = struct | T_PERCENT : unit terminal | T_OR : unit terminal | T_OPTLABEL : ( -# 810 "src/ocaml/preprocess/parser_raw.mly" +# 814 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45118 "src/ocaml/preprocess/parser_raw.ml" +# 45122 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_OPEN : unit terminal | T_OF : unit terminal @@ -45131,15 +45135,15 @@ module MenhirInterpreter = struct | T_MATCH : unit terminal | T_LPAREN : unit terminal | T_LIDENT : ( -# 793 "src/ocaml/preprocess/parser_raw.mly" +# 797 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45137 "src/ocaml/preprocess/parser_raw.ml" +# 45141 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_LET_LWT : unit terminal | T_LETOP : ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 779 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45143 "src/ocaml/preprocess/parser_raw.ml" +# 45147 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_LET : unit terminal | T_LESSMINUS : unit terminal @@ -45157,49 +45161,49 @@ module MenhirInterpreter = struct | T_LBRACE : unit terminal | T_LAZY : unit terminal | T_LABEL : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 784 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45163 "src/ocaml/preprocess/parser_raw.ml" +# 45167 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INT : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 783 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 45168 "src/ocaml/preprocess/parser_raw.ml" +# 45172 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INITIALIZER : unit terminal | T_INHERIT : unit terminal | T_INFIXOP4 : ( -# 773 "src/ocaml/preprocess/parser_raw.mly" +# 777 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45175 "src/ocaml/preprocess/parser_raw.ml" +# 45179 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP3 : ( -# 772 "src/ocaml/preprocess/parser_raw.mly" +# 776 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45180 "src/ocaml/preprocess/parser_raw.ml" +# 45184 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP2 : ( -# 771 "src/ocaml/preprocess/parser_raw.mly" +# 775 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45185 "src/ocaml/preprocess/parser_raw.ml" +# 45189 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP1 : ( -# 770 "src/ocaml/preprocess/parser_raw.mly" +# 774 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45190 "src/ocaml/preprocess/parser_raw.ml" +# 45194 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP0 : ( -# 769 "src/ocaml/preprocess/parser_raw.mly" +# 773 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45195 "src/ocaml/preprocess/parser_raw.ml" +# 45199 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INCLUDE : unit terminal | T_IN : unit terminal | T_IF : unit terminal | T_HASHOP : ( -# 828 "src/ocaml/preprocess/parser_raw.mly" +# 832 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45203 "src/ocaml/preprocess/parser_raw.ml" +# 45207 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_HASH : unit terminal | T_GREATERRBRACKET : unit terminal @@ -45212,9 +45216,9 @@ module MenhirInterpreter = struct | T_FOR_LWT : unit terminal | T_FOR : unit terminal | T_FLOAT : ( -# 758 "src/ocaml/preprocess/parser_raw.mly" +# 762 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 45218 "src/ocaml/preprocess/parser_raw.ml" +# 45222 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_FINALLY_LWT : unit terminal | T_FALSE : unit terminal @@ -45228,25 +45232,25 @@ module MenhirInterpreter = struct | T_DOWNTO : unit terminal | T_DOTTILDE : unit terminal | T_DOTOP : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45234 "src/ocaml/preprocess/parser_raw.ml" +# 45238 "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 : ( -# 853 "src/ocaml/preprocess/parser_raw.mly" +# 857 "src/ocaml/preprocess/parser_raw.mly" (Docstrings.docstring) -# 45243 "src/ocaml/preprocess/parser_raw.ml" +# 45247 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_DO : unit terminal | T_CONSTRAINT : unit terminal | T_COMMENT : ( -# 852 "src/ocaml/preprocess/parser_raw.mly" +# 856 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t) -# 45250 "src/ocaml/preprocess/parser_raw.ml" +# 45254 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_COMMA : unit terminal | T_COLONGREATER : unit terminal @@ -45255,9 +45259,9 @@ module MenhirInterpreter = struct | T_COLON : unit terminal | T_CLASS : unit terminal | T_CHAR : ( -# 738 "src/ocaml/preprocess/parser_raw.mly" +# 742 "src/ocaml/preprocess/parser_raw.mly" (char) -# 45261 "src/ocaml/preprocess/parser_raw.ml" +# 45265 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_BEGIN : unit terminal | T_BARRBRACKET : unit terminal @@ -45268,9 +45272,9 @@ module MenhirInterpreter = struct | T_ASSERT : unit terminal | T_AS : unit terminal | T_ANDOP : ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45274 "src/ocaml/preprocess/parser_raw.ml" +# 45278 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_AND : unit terminal | T_AMPERSAND : unit terminal @@ -46357,12 +46361,12 @@ module Incremental = struct end -# 4118 "src/ocaml/preprocess/parser_raw.mly" +# 4122 "src/ocaml/preprocess/parser_raw.mly" -# 46364 "src/ocaml/preprocess/parser_raw.ml" +# 46368 "src/ocaml/preprocess/parser_raw.ml" # 269 "" -# 46369 "src/ocaml/preprocess/parser_raw.ml" +# 46373 "src/ocaml/preprocess/parser_raw.ml" From 7b7add3782412e773f1ee238db81ab9593e1d0b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 24 Nov 2022 18:00:05 +0100 Subject: [PATCH 023/130] Prepare changelog for relase 4.7-500 --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index ea217dc137..0dabd60e7f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -161,7 +161,7 @@ Fri Feb 24 16:55:42 CEST 2023 merlin 4.7 ========== -Thu Nov 24 13:31:42 CEST 2022 +Thu Nov 24 17:49:42 CEST 2022 + merlin binary - Replace custom "holes" AST nodes by extensions. This restores binary From a3a05622d4137d65ce5230c8a2b7b26b7c69e558 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 7 Dec 2022 16:07:50 +0100 Subject: [PATCH 024/130] Add test for issue #1518 --- tests/test-dirs/issue1518.t | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 tests/test-dirs/issue1518.t diff --git a/tests/test-dirs/issue1518.t b/tests/test-dirs/issue1518.t new file mode 100644 index 0000000000..3064d71384 --- /dev/null +++ b/tests/test-dirs/issue1518.t @@ -0,0 +1,30 @@ + $ cat >dune-project < (lang dune 2.0) + > EOF + + $ cat >main.ml < print_endline "42" + > EOF + + $ cat >dune < (executable + > (name main) + > (flags :standard -safe-string)) + > EOF + + + $ dune exec ./main.exe + 42 + +FIXME: in 5.0 the compiler still accept the deleted flag "-safe-string". It +simply is a noop. Merlin should ignore it as well. + $ $MERLIN single errors -filename main.ml jq '.value' + [ + { + "type": "config", + "sub": [], + "valid": true, + "message": "unknown flag -safe-string" + } + ] From b53c43cedd9409560f8fafdc066a02906cb698ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 7 Dec 2022 16:12:39 +0100 Subject: [PATCH 025/130] Accept -safe-string flag but make it a no-op. --- src/kernel/mconfig.ml | 5 +++++ tests/test-dirs/issue1518.t | 13 +++---------- 2 files changed, 8 insertions(+), 10 deletions(-) diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index de2f420aa5..ad75d7aea5 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -516,6 +516,11 @@ let ocaml_flags = [ Marg.unit (fun ocaml -> {ocaml with threads = `None}), " Add support for VM-scheduled threads library" ); + ( + "-safe-string", + Marg.unit (fun ocaml -> ocaml), + " Default to true unconditionally since 5.00" + ); ( "-nopervasives", Marg.unit (fun ocaml -> {ocaml with nopervasives = true}), diff --git a/tests/test-dirs/issue1518.t b/tests/test-dirs/issue1518.t index 3064d71384..ffc7559cdd 100644 --- a/tests/test-dirs/issue1518.t +++ b/tests/test-dirs/issue1518.t @@ -16,15 +16,8 @@ $ dune exec ./main.exe 42 -FIXME: in 5.0 the compiler still accept the deleted flag "-safe-string". It -simply is a noop. Merlin should ignore it as well. +In 5.0 the compiler still accept the deleted flag "-safe-string". +It simply is a no-op. Merlin should ignore it as well. $ $MERLIN single errors -filename main.ml jq '.value' - [ - { - "type": "config", - "sub": [], - "valid": true, - "message": "unknown flag -safe-string" - } - ] + [] From 1b55284cab2df448a40f1942e088efb4ab09d92f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 13 Dec 2022 10:26:09 +0100 Subject: [PATCH 026/130] Add changelog entry for #1544 --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 0dabd60e7f..5ac06f5e41 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -144,6 +144,9 @@ Fri Feb 24 16:55:42 CEST 2023 - Update internal typer to match OCaml 4.14.1 release (#1557) - Improve type-enclosing behaviour when used on records' labels (#1565, fixes #1564) + - Restore compatibility with the compiler command line by accepting the + `-safe-string` flag as a no-op instead of rejecting it. (#1544, fixes + #1518) - Restore compatibility with some OCaml compiler's debug flags that were incorrectly rejected by Merlin (#1556) - Traverse aliases when jumping to declaration. This matches From 39491ae75ca010c3cf6b244db0afe97e8d08f621 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 13 Dec 2022 10:31:34 +0100 Subject: [PATCH 027/130] Mark some C variables as unused (#1541) from antalsz/unused-c-variables --- CHANGES.md | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 5ac06f5e41..c994c38b3c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -144,9 +144,6 @@ Fri Feb 24 16:55:42 CEST 2023 - Update internal typer to match OCaml 4.14.1 release (#1557) - Improve type-enclosing behaviour when used on records' labels (#1565, fixes #1564) - - Restore compatibility with the compiler command line by accepting the - `-safe-string` flag as a no-op instead of rejecting it. (#1544, fixes - #1518) - Restore compatibility with some OCaml compiler's debug flags that were incorrectly rejected by Merlin (#1556) - Traverse aliases when jumping to declaration. This matches @@ -162,6 +159,16 @@ Fri Feb 24 16:55:42 CEST 2023 - Add multiple tests for locate over ill-typed expressions (#1546) - Add non-regression tests for other fixes in this release +merlin 4.7.1 +============ +Thu Dec 13 11:49:42 CEST 2022 + + + merlin binary + - Restore compatibility with the compiler command line by accepting the + `-safe-string` flag as a no-op instead of rejecting it. (#1544, fixes + #1518) + - mark some C variables as unused to remove warnings (#1541, @antalsz) + merlin 4.7 ========== Thu Nov 24 17:49:42 CEST 2022 From c64b4915a5d2e2a266824088522e22857a212eb4 Mon Sep 17 00:00:00 2001 From: Ulysse <5031221+voodoos@users.noreply.github.com> Date: Tue, 13 Dec 2022 02:28:42 -0800 Subject: [PATCH 028/130] Prepare changelog for release 4.7.1 --- CHANGES.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index c994c38b3c..a04eb2a2fa 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -164,10 +164,10 @@ merlin 4.7.1 Thu Dec 13 11:49:42 CEST 2022 + merlin binary - - Restore compatibility with the compiler command line by accepting the - `-safe-string` flag as a no-op instead of rejecting it. (#1544, fixes - #1518) - - mark some C variables as unused to remove warnings (#1541, @antalsz) + - Restore compatibility with the compiler's command line by accepting + the `-safe-string` flag as a no-op instead of rejecting it. (#1544, + fixes #1518) + - Mark some C variables as unused to remove warnings (#1541, @antalsz) merlin 4.7 ========== From e264c39cec66a79d85b77b3c8a2c6cc23f4cd360 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 27 Dec 2022 11:32:51 +0100 Subject: [PATCH 029/130] test: locate work as expected when the cmt are built --- tests/test-dirs/locate/issue1424.t | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/test-dirs/locate/issue1424.t b/tests/test-dirs/locate/issue1424.t index 874a14ab09..6052465110 100644 --- a/tests/test-dirs/locate/issue1424.t +++ b/tests/test-dirs/locate/issue1424.t @@ -18,7 +18,8 @@ > val foo : int > EOF - $ dune build +NOTE: we need to build the @check target to have the cmt and not only the cmti + $ dune build @check Jump to interface: $ $MERLIN single locate -look-for mli -position 1:16 \ @@ -32,13 +33,12 @@ Jump to interface: } Jump to definition: -FIXME: it should jump to the ml file $ $MERLIN single locate -look-for ml -position 1:16 \ > -filename test.ml Date: Mon, 26 Dec 2022 22:36:36 +0000 Subject: [PATCH 030/130] Recognize OCaml 5.0 cmi magic number MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit And add an assertion that we can recognize our own magic number that we got compiled with. Fixes https://github.com/ocaml/merlin/issues/1553 Signed-off-by: Edwin Török --- src/ocaml/typing/magic_numbers.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/ocaml/typing/magic_numbers.ml b/src/ocaml/typing/magic_numbers.ml index 386f87993c..7ec5200618 100644 --- a/src/ocaml/typing/magic_numbers.ml +++ b/src/ocaml/typing/magic_numbers.ml @@ -22,8 +22,11 @@ module Cmi = struct | "Caml1999I029" -> Some "4.12" | "Caml1999I030" -> Some "4.13" | "Caml1999I031" -> Some "4.14" + | "Caml1999I032" -> Some "5.0" | _ -> None + let () = assert (to_version_opt Config.cmi_magic_number <> None) + open Format let report_error ppf = function From 064b7a246499d76df0eff16011f072d1188220b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= Date: Wed, 28 Dec 2022 12:17:53 +0000 Subject: [PATCH 031/130] Add changelog entry for cmi version fix MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Edwin Török --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index a04eb2a2fa..037e532865 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -141,6 +141,8 @@ merlin 4.8 Fri Feb 24 16:55:42 CEST 2023 + merlin binary + - Recognize OCaml 5.0 cmi magic number in compiler version mismatch message + (#1554, fixes #1553) - Update internal typer to match OCaml 4.14.1 release (#1557) - Improve type-enclosing behaviour when used on records' labels (#1565, fixes #1564) From 4b2d5330edc2959e9e3f88b18aaf771a52baffae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 12 Jan 2023 15:30:09 +0100 Subject: [PATCH 032/130] Add a test illustrating issue #1558 --- tests/test-dirs/issue1558.t | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 tests/test-dirs/issue1558.t diff --git a/tests/test-dirs/issue1558.t b/tests/test-dirs/issue1558.t new file mode 100644 index 0000000000..cf5c6533f3 --- /dev/null +++ b/tests/test-dirs/issue1558.t @@ -0,0 +1,8 @@ + $ cat >main.ml < open Stdlib.Effect + > EOF + +FIXME: this alert should be disabled by default in OCaml 5 + $ $MERLIN single errors -filename main.ml tr '\n' ' ' | jq '.value[0].message' + "Alert unstable: module Stdlib.Effect The Effect interface may change in incompatible ways in the future." From 466a771c8031e59f94cb619fb0cdeab804f61b92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 12 Jan 2023 15:32:29 +0100 Subject: [PATCH 033/130] Fetch ocaml upstream at #5.0.0 --- upstream/ocaml_500/base-rev.txt | 2 +- upstream/ocaml_500/typing/env.ml | 8 ++++++++ upstream/ocaml_500/typing/env.mli | 2 ++ upstream/ocaml_500/typing/mtype.ml | 3 +++ upstream/ocaml_500/utils/warnings.ml | 5 ++++- 5 files changed, 18 insertions(+), 2 deletions(-) diff --git a/upstream/ocaml_500/base-rev.txt b/upstream/ocaml_500/base-rev.txt index 5dd01cf1c9..7984d9a9ab 100644 --- a/upstream/ocaml_500/base-rev.txt +++ b/upstream/ocaml_500/base-rev.txt @@ -1 +1 @@ -1470e1e9b13341893e68f404c5c798d0259bb564 +e86f9e5d41217e8c824455206e854072b803b170 diff --git a/upstream/ocaml_500/typing/env.ml b/upstream/ocaml_500/typing/env.ml index fd2353eed2..31cdbff3c6 100644 --- a/upstream/ocaml_500/typing/env.ml +++ b/upstream/ocaml_500/typing/env.ml @@ -2223,6 +2223,14 @@ and add_cltype ?shape id ty env = let add_module ?arg ?shape id presence mty env = add_module_declaration ~check:false ?arg ?shape id presence (md mty) env +let add_module_lazy ~update_summary id presence mty env = + let md = Subst.Lazy.{mdl_type = mty; + mdl_attributes = []; + mdl_loc = Location.none; + mdl_uid = Uid.internal_not_actually_unique} + in + add_module_declaration_lazy ~update_summary id presence md env + let add_local_type path info env = { env with local_constraints = Path.Map.add path info env.local_constraints } diff --git a/upstream/ocaml_500/typing/env.mli b/upstream/ocaml_500/typing/env.mli index ae8e2cf8dc..418c8a4e7d 100644 --- a/upstream/ocaml_500/typing/env.mli +++ b/upstream/ocaml_500/typing/env.mli @@ -288,6 +288,8 @@ val add_extension: check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t val add_module: ?arg:bool -> ?shape:Shape.t -> Ident.t -> module_presence -> module_type -> t -> t +val add_module_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.modtype -> t -> t val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> Ident.t -> module_presence -> module_declaration -> t -> t val add_module_declaration_lazy: update_summary:bool -> diff --git a/upstream/ocaml_500/typing/mtype.ml b/upstream/ocaml_500/typing/mtype.ml index d649bcdc87..f6aba79222 100644 --- a/upstream/ocaml_500/typing/mtype.ml +++ b/upstream/ocaml_500/typing/mtype.ml @@ -46,6 +46,9 @@ let rec strengthen_lazy ~aliasable env mty p = MtyL_signature(strengthen_lazy_sig ~aliasable env sg p) | MtyL_functor(Named (Some param, arg), res) when !Clflags.applicative_functors -> + let env = + Env.add_module_lazy ~update_summary:false param Mp_present arg env + in MtyL_functor(Named (Some param, arg), strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) | MtyL_functor(Named (None, arg), res) diff --git a/upstream/ocaml_500/utils/warnings.ml b/upstream/ocaml_500/utils/warnings.ml index 65044fc965..c296fba318 100644 --- a/upstream/ocaml_500/utils/warnings.ml +++ b/upstream/ocaml_500/utils/warnings.ml @@ -580,7 +580,7 @@ let current = { 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 *) + alerts = (Misc.Stdlib.String.Set.empty, false); alert_errors = (Misc.Stdlib.String.Set.empty, true); (* all soft *) } @@ -856,9 +856,12 @@ let parse_options errflag s = (* 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 default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] let () = ignore @@ parse_options false defaults_w let () = ignore @@ parse_options true defaults_warn_error +let () = + List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts let ref_manual_explanation () = (* manual references are checked a posteriori by the manual From 453fbd53fb069645e2c5110161251fb80c934aa6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 12 Jan 2023 15:32:57 +0100 Subject: [PATCH 034/130] Upgrade Merlin to 5.0.0 release and fix #1558 --- src/ocaml/utils/warnings.ml | 6 +++++- tests/test-dirs/issue1558.t | 7 ++++++- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/ocaml/utils/warnings.ml b/src/ocaml/utils/warnings.ml index bca751c3df..4f9fa0bede 100644 --- a/src/ocaml/utils/warnings.ml +++ b/src/ocaml/utils/warnings.ml @@ -580,7 +580,7 @@ let current = { active = Array.make (last_warning_number + 1) true; error = Array.make (last_warning_number + 1) false; - alerts = (Std.String.Set.empty, false); (* all enabled *) + alerts = (Std.String.Set.empty, false); alert_errors = (Std.String.Set.empty, true); (* all soft *) } @@ -863,9 +863,13 @@ let parse_options errflag s = (* 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 default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] + let () = ignore @@ parse_options false defaults_w let () = ignore @@ parse_options true defaults_warn_error +let () = + List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts let ref_manual_explanation () = (* manual references are checked a posteriori by the manual diff --git a/tests/test-dirs/issue1558.t b/tests/test-dirs/issue1558.t index cf5c6533f3..de341521a2 100644 --- a/tests/test-dirs/issue1558.t +++ b/tests/test-dirs/issue1558.t @@ -2,7 +2,12 @@ > open Stdlib.Effect > EOF -FIXME: this alert should be disabled by default in OCaml 5 +The unstable alert should be disabled by default in OCaml 5 $ $MERLIN single errors -filename main.ml tr '\n' ' ' | jq '.value[0].message' + null + +But can be enabled + $ $MERLIN single errors -filename main.ml -alert +unstable tr '\n' ' ' | jq '.value[0].message' "Alert unstable: module Stdlib.Effect The Effect interface may change in incompatible ways in the future." From ade86aca46e566940ab92d0531b9e7a551744b26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 12 Jan 2023 15:59:52 +0100 Subject: [PATCH 035/130] Add changelog entry for #1559 --- CHANGES.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 037e532865..0e08c1e060 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -143,7 +143,8 @@ Fri Feb 24 16:55:42 CEST 2023 + merlin binary - Recognize OCaml 5.0 cmi magic number in compiler version mismatch message (#1554, fixes #1553) - - Update internal typer to match OCaml 4.14.1 release (#1557) + - Upgrade Merlin from the RC2 to the stable 5.0.0 compiler release (#1559, + fixes #1558) - Improve type-enclosing behaviour when used on records' labels (#1565, fixes #1564) - Restore compatibility with some OCaml compiler's debug flags that were @@ -160,6 +161,7 @@ Fri Feb 24 16:55:42 CEST 2023 + test suite - Add multiple tests for locate over ill-typed expressions (#1546) - Add non-regression tests for other fixes in this release + - Add a test for incorrect alert defaults (#1559) merlin 4.7.1 ============ From 15fcda67179dd1f286091c68dccef9635ea7f88f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 22 Feb 2023 17:04:26 +0100 Subject: [PATCH 036/130] Backport: Fix Broken `eq` comparison in merlin.el (#1549) from mattiase/eq-warning --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 0e08c1e060..331524c6ff 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -158,6 +158,8 @@ Fri Feb 24 16:55:42 CEST 2023 fixes #1540) - On Windows, change to a harmless directory when launching server to avoid locking down current directory (#1569, fixes #1474) + + editor modes + - emacs: Fix misuse of `eq` comparison (#1549, @mattiase) + test suite - Add multiple tests for locate over ill-typed expressions (#1546) - Add non-regression tests for other fixes in this release From d0b5b59ba9acba3e9863c2d528e32e18438e4966 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 22 Feb 2023 17:06:27 +0100 Subject: [PATCH 037/130] Backport: Emacs Xref improvements (#1385) from mattiase/xref --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 331524c6ff..3af2f6b937 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -160,6 +160,9 @@ Fri Feb 24 16:55:42 CEST 2023 locking down current directory (#1569, fixes #1474) + editor modes - emacs: Fix misuse of `eq` comparison (#1549, @mattiase) + - emacs: xref works from context menus; better highlighting of xref matches; + xref recognises operators and binding operators at the cursor position; + bad locations are filtered out (#1385, fixes #1410, @mattiase) + test suite - Add multiple tests for locate over ill-typed expressions (#1546) - Add non-regression tests for other fixes in this release From 61b917105636c35e7c463aecde97f5e27923d6a9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 23 Feb 2023 09:42:38 +0100 Subject: [PATCH 038/130] Backport: Improve locate of ill-typed exprs (#1546) from voodoos/locate-ill-typed --- CHANGES.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGES.md b/CHANGES.md index 3af2f6b937..748f9d3bb2 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -167,6 +167,7 @@ Fri Feb 24 16:55:42 CEST 2023 - Add multiple tests for locate over ill-typed expressions (#1546) - Add non-regression tests for other fixes in this release - Add a test for incorrect alert defaults (#1559) + - Add multiple tests for locate over ill-typed expressions (#1546) merlin 4.7.1 ============ From 989e86c99459f83db2b61a4547c7cd2931b242b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 24 Feb 2023 16:57:33 +0100 Subject: [PATCH 039/130] Prepare for release 4.8-500 --- CHANGES.md | 1 - 1 file changed, 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 748f9d3bb2..3af2f6b937 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -167,7 +167,6 @@ Fri Feb 24 16:55:42 CEST 2023 - Add multiple tests for locate over ill-typed expressions (#1546) - Add non-regression tests for other fixes in this release - Add a test for incorrect alert defaults (#1559) - - Add multiple tests for locate over ill-typed expressions (#1546) merlin 4.7.1 ============ From 9d48a9d712a059e59a90f51f5e8222f9887ee5b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 24 Feb 2023 17:02:18 +0100 Subject: [PATCH 040/130] Uniformize Changelog --- CHANGES.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 3af2f6b937..15eb2110a9 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -147,8 +147,9 @@ Fri Feb 24 16:55:42 CEST 2023 fixes #1558) - Improve type-enclosing behaviour when used on records' labels (#1565, fixes #1564) - - Restore compatibility with some OCaml compiler's debug flags that were - incorrectly rejected by Merlin (#1556) + - Restore compatibility with the compiler's command line by accepting the + `-safe-string` flag as a no-op instead of rejecting it (#1544, fixes + #1518) - Traverse aliases when jumping to declaration. This matches jump-to-definition's behavior (#1563) - Improve locate's behavior in various ill-typed expressions (#1546, fixes From 35bc765386458ad2054396227a802604685b6bce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 26 May 2023 13:52:14 +0200 Subject: [PATCH 041/130] [B] Add readme note about menhir pin (#1605) from 3Rafal/note-about-menhir-version --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 2716b6400d..842a559310 100644 --- a/README.md +++ b/README.md @@ -178,9 +178,9 @@ If you're a Merlin user and depend on our public API, we recommend that you cont 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, +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. +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. From c9975784530074a10724e4bea0a9fa8d750b6fa7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 24 Aug 2023 12:42:46 +0200 Subject: [PATCH 042/130] [B] Add a CI that check compatibility with ocaml-lsp (#1614) --- .github/workflows/ocaml-lsp-compat.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ocaml-lsp-compat.yml b/.github/workflows/ocaml-lsp-compat.yml index 9d90af58db..79a2641f21 100644 --- a/.github/workflows/ocaml-lsp-compat.yml +++ b/.github/workflows/ocaml-lsp-compat.yml @@ -34,7 +34,7 @@ jobs: os: - ubuntu-latest ocaml-compiler: - - 4.14.x + - 5.2.x # The type of runner that the job will run on runs-on: ${{ matrix.os }} From 2bf0c2e12c3937b22b482995f2aa85b1a318ce51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 14 Apr 2023 15:00:40 -0300 Subject: [PATCH 043/130] wip: add a small utility script to diff and apply patches --- upstream/gen_patch.sh | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 upstream/gen_patch.sh diff --git a/upstream/gen_patch.sh b/upstream/gen_patch.sh new file mode 100644 index 0000000000..04a78357c1 --- /dev/null +++ b/upstream/gen_patch.sh @@ -0,0 +1,28 @@ +#!/bin/sh + +D_MERLIN=../src/ocaml + +FROM=500 +TO=501 + +D_FROM=ocaml_${FROM} +D_TO=ocaml_${TO} +D_PATCH=patches_${TO} + +mkdir "${D_PATCH}" + +for file in "${D_TO}"/*/*.ml*; do + F_TO=${file} + F_FROM=$(echo "${F_TO}" | sed "s/${D_TO}/${D_FROM}/g") + F_MERLIN=$(echo "${F_TO}" | sed "s,${D_TO},${D_MERLIN},g") + F_PATCH=$(echo "${F_TO}" | sed "s/${D_TO}/${D_PATCH}/g") + mkdir "$(dirname "${F_PATCH}")" 2>/dev/null | true + # Make diff + RES=$(diff -u -N "${F_FROM}" "${F_TO}") + if [ -n "${RES}" ]; then + # Write the patch file if non-empty + echo "${RES}" > "${F_PATCH}.patch" + # Apply the patch file + patch "${F_MERLIN}" "${F_PATCH}.patch" + fi +done From 359ed5b844f7681778d22d940e1d1adccb13d1b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 14 Apr 2023 11:43:07 -0300 Subject: [PATCH 044/130] Copy upstream files at 5.1 --- upstream/ocaml_501/base-rev.txt | 1 + upstream/ocaml_501/file_formats/cmi_format.ml | 117 + .../ocaml_501/file_formats/cmi_format.mli | 50 + upstream/ocaml_501/file_formats/cmt_format.ml | 198 + .../ocaml_501/file_formats/cmt_format.mli | 126 + upstream/ocaml_501/parsing/CONFLICTS.md | 54 + upstream/ocaml_501/parsing/ast_helper.ml | 646 ++ upstream/ocaml_501/parsing/ast_helper.mli | 497 ++ upstream/ocaml_501/parsing/ast_invariants.ml | 191 + upstream/ocaml_501/parsing/ast_invariants.mli | 23 + upstream/ocaml_501/parsing/ast_iterator.ml | 697 ++ upstream/ocaml_501/parsing/ast_iterator.mli | 84 + upstream/ocaml_501/parsing/ast_mapper.ml | 1104 +++ upstream/ocaml_501/parsing/ast_mapper.mli | 208 + upstream/ocaml_501/parsing/asttypes.mli | 67 + upstream/ocaml_501/parsing/attr_helper.ml | 54 + upstream/ocaml_501/parsing/attr_helper.mli | 41 + .../ocaml_501/parsing/builtin_attributes.ml | 289 + .../ocaml_501/parsing/builtin_attributes.mli | 84 + upstream/ocaml_501/parsing/depend.ml | 608 ++ upstream/ocaml_501/parsing/depend.mli | 45 + upstream/ocaml_501/parsing/docstrings.ml | 425 ++ upstream/ocaml_501/parsing/docstrings.mli | 223 + upstream/ocaml_501/parsing/lexer.mli | 64 + upstream/ocaml_501/parsing/lexer.mll | 869 +++ upstream/ocaml_501/parsing/location.ml | 1030 +++ upstream/ocaml_501/parsing/location.mli | 359 + upstream/ocaml_501/parsing/longident.ml | 50 + upstream/ocaml_501/parsing/longident.mli | 58 + upstream/ocaml_501/parsing/parse.ml | 155 + upstream/ocaml_501/parsing/parse.mli | 110 + upstream/ocaml_501/parsing/parser.mly | 3904 +++++++++++ upstream/ocaml_501/parsing/parsetree.mli | 1067 +++ upstream/ocaml_501/parsing/pprintast.ml | 1677 +++++ upstream/ocaml_501/parsing/pprintast.mli | 55 + upstream/ocaml_501/parsing/printast.ml | 982 +++ upstream/ocaml_501/parsing/printast.mli | 32 + upstream/ocaml_501/parsing/syntaxerr.ml | 45 + upstream/ocaml_501/parsing/syntaxerr.mli | 38 + upstream/ocaml_501/typing/annot.mli | 23 + upstream/ocaml_501/typing/btype.ml | 772 ++ upstream/ocaml_501/typing/btype.mli | 316 + upstream/ocaml_501/typing/cmt2annot.ml | 184 + upstream/ocaml_501/typing/cmt2annot.mli | 22 + upstream/ocaml_501/typing/ctype.ml | 5526 +++++++++++++++ upstream/ocaml_501/typing/ctype.mli | 459 ++ upstream/ocaml_501/typing/datarepr.ml | 238 + upstream/ocaml_501/typing/datarepr.mli | 45 + upstream/ocaml_501/typing/env.ml | 3692 ++++++++++ upstream/ocaml_501/typing/env.mli | 524 ++ upstream/ocaml_501/typing/envaux.ml | 115 + upstream/ocaml_501/typing/envaux.mli | 36 + upstream/ocaml_501/typing/errortrace.ml | 194 + upstream/ocaml_501/typing/errortrace.mli | 168 + upstream/ocaml_501/typing/ident.ml | 388 + upstream/ocaml_501/typing/ident.mli | 110 + upstream/ocaml_501/typing/includeclass.ml | 116 + upstream/ocaml_501/typing/includeclass.mli | 33 + upstream/ocaml_501/typing/includecore.ml | 1020 +++ upstream/ocaml_501/typing/includecore.mli | 139 + upstream/ocaml_501/typing/includemod.ml | 1239 ++++ upstream/ocaml_501/typing/includemod.mli | 255 + .../typing/includemod_errorprinter.ml | 940 +++ .../typing/includemod_errorprinter.mli | 17 + upstream/ocaml_501/typing/mtype.ml | 565 ++ upstream/ocaml_501/typing/mtype.mli | 55 + upstream/ocaml_501/typing/oprint.ml | 846 +++ upstream/ocaml_501/typing/oprint.mli | 36 + upstream/ocaml_501/typing/outcometree.mli | 155 + upstream/ocaml_501/typing/parmatch.ml | 2355 +++++++ upstream/ocaml_501/typing/parmatch.mli | 117 + upstream/ocaml_501/typing/path.ml | 144 + upstream/ocaml_501/typing/path.mli | 80 + upstream/ocaml_501/typing/patterns.ml | 254 + upstream/ocaml_501/typing/patterns.mli | 109 + upstream/ocaml_501/typing/persistent_env.ml | 359 + upstream/ocaml_501/typing/persistent_env.mli | 104 + upstream/ocaml_501/typing/predef.ml | 252 + upstream/ocaml_501/typing/predef.mli | 87 + upstream/ocaml_501/typing/primitive.ml | 251 + upstream/ocaml_501/typing/primitive.mli | 79 + upstream/ocaml_501/typing/printpat.ml | 169 + upstream/ocaml_501/typing/printpat.mli | 27 + upstream/ocaml_501/typing/printtyp.ml | 2621 +++++++ upstream/ocaml_501/typing/printtyp.mli | 249 + upstream/ocaml_501/typing/printtyped.ml | 959 +++ upstream/ocaml_501/typing/printtyped.mli | 23 + upstream/ocaml_501/typing/rec_check.ml | 1264 ++++ upstream/ocaml_501/typing/rec_check.mli | 19 + upstream/ocaml_501/typing/shape.ml | 538 ++ upstream/ocaml_501/typing/shape.mli | 157 + upstream/ocaml_501/typing/signature_group.ml | 155 + upstream/ocaml_501/typing/signature_group.mli | 85 + upstream/ocaml_501/typing/stypes.ml | 195 + upstream/ocaml_501/typing/stypes.mli | 35 + upstream/ocaml_501/typing/subst.ml | 773 ++ upstream/ocaml_501/typing/subst.mli | 152 + upstream/ocaml_501/typing/tast_iterator.ml | 648 ++ upstream/ocaml_501/typing/tast_iterator.mli | 71 + upstream/ocaml_501/typing/tast_mapper.ml | 874 +++ upstream/ocaml_501/typing/tast_mapper.mli | 75 + upstream/ocaml_501/typing/type_immediacy.ml | 43 + upstream/ocaml_501/typing/type_immediacy.mli | 40 + upstream/ocaml_501/typing/typeclass.ml | 2178 ++++++ upstream/ocaml_501/typing/typeclass.mli | 138 + upstream/ocaml_501/typing/typecore.ml | 6237 +++++++++++++++++ upstream/ocaml_501/typing/typecore.mli | 261 + upstream/ocaml_501/typing/typedecl.ml | 2189 ++++++ upstream/ocaml_501/typing/typedecl.mli | 111 + .../ocaml_501/typing/typedecl_immediacy.ml | 67 + .../ocaml_501/typing/typedecl_immediacy.mli | 27 + .../ocaml_501/typing/typedecl_properties.ml | 73 + .../ocaml_501/typing/typedecl_properties.mli | 55 + .../ocaml_501/typing/typedecl_separability.ml | 668 ++ .../typing/typedecl_separability.mli | 132 + upstream/ocaml_501/typing/typedecl_unboxed.ml | 43 + .../ocaml_501/typing/typedecl_unboxed.mli | 20 + .../ocaml_501/typing/typedecl_variance.ml | 438 ++ .../ocaml_501/typing/typedecl_variance.mli | 75 + upstream/ocaml_501/typing/typedtree.ml | 863 +++ upstream/ocaml_501/typing/typedtree.mli | 832 +++ upstream/ocaml_501/typing/typemod.ml | 3430 +++++++++ upstream/ocaml_501/typing/typemod.mli | 141 + upstream/ocaml_501/typing/typeopt.ml | 231 + upstream/ocaml_501/typing/typeopt.mli | 43 + upstream/ocaml_501/typing/types.ml | 897 +++ upstream/ocaml_501/typing/types.mli | 730 ++ upstream/ocaml_501/typing/typetexp.ml | 965 +++ upstream/ocaml_501/typing/typetexp.mli | 99 + upstream/ocaml_501/typing/untypeast.ml | 919 +++ upstream/ocaml_501/typing/untypeast.mli | 87 + upstream/ocaml_501/utils/arg_helper.ml | 127 + upstream/ocaml_501/utils/arg_helper.mli | 68 + upstream/ocaml_501/utils/binutils.ml | 684 ++ upstream/ocaml_501/utils/binutils.mli | 30 + .../ocaml_501/utils/build_path_prefix_map.ml | 118 + .../ocaml_501/utils/build_path_prefix_map.mli | 61 + upstream/ocaml_501/utils/ccomp.ml | 214 + upstream/ocaml_501/utils/ccomp.mli | 40 + upstream/ocaml_501/utils/clflags.ml | 580 ++ upstream/ocaml_501/utils/clflags.mli | 274 + upstream/ocaml_501/utils/config.common.ml | 165 + upstream/ocaml_501/utils/config.fixed.ml | 71 + upstream/ocaml_501/utils/config.ml | 277 + upstream/ocaml_501/utils/config.mli | 264 + upstream/ocaml_501/utils/consistbl.ml | 95 + upstream/ocaml_501/utils/consistbl.mli | 77 + upstream/ocaml_501/utils/diffing.ml | 447 ++ upstream/ocaml_501/utils/diffing.mli | 147 + upstream/ocaml_501/utils/diffing_with_keys.ml | 208 + .../ocaml_501/utils/diffing_with_keys.mli | 77 + upstream/ocaml_501/utils/domainstate.ml.c | 38 + upstream/ocaml_501/utils/domainstate.mli.c | 24 + upstream/ocaml_501/utils/identifiable.ml | 249 + upstream/ocaml_501/utils/identifiable.mli | 113 + .../utils/int_replace_polymorphic_compare.ml | 8 + .../utils/int_replace_polymorphic_compare.mli | 8 + upstream/ocaml_501/utils/lazy_backtrack.ml | 87 + upstream/ocaml_501/utils/lazy_backtrack.mli | 34 + upstream/ocaml_501/utils/load_path.ml | 176 + upstream/ocaml_501/utils/load_path.mli | 96 + upstream/ocaml_501/utils/local_store.ml | 74 + upstream/ocaml_501/utils/local_store.mli | 66 + upstream/ocaml_501/utils/misc.ml | 1171 ++++ upstream/ocaml_501/utils/misc.mli | 781 +++ upstream/ocaml_501/utils/numbers.ml | 88 + upstream/ocaml_501/utils/numbers.mli | 51 + upstream/ocaml_501/utils/profile.ml | 335 + upstream/ocaml_501/utils/profile.mli | 49 + .../utils/strongly_connected_components.ml | 195 + .../utils/strongly_connected_components.mli | 43 + upstream/ocaml_501/utils/targetint.ml | 104 + upstream/ocaml_501/utils/targetint.mli | 208 + upstream/ocaml_501/utils/terminfo.ml | 45 + upstream/ocaml_501/utils/terminfo.mli | 32 + upstream/ocaml_501/utils/warnings.ml | 1239 ++++ upstream/ocaml_501/utils/warnings.mli | 166 + 177 files changed, 79371 insertions(+) create mode 100644 upstream/ocaml_501/base-rev.txt create mode 100644 upstream/ocaml_501/file_formats/cmi_format.ml create mode 100644 upstream/ocaml_501/file_formats/cmi_format.mli create mode 100644 upstream/ocaml_501/file_formats/cmt_format.ml create mode 100644 upstream/ocaml_501/file_formats/cmt_format.mli create mode 100644 upstream/ocaml_501/parsing/CONFLICTS.md create mode 100644 upstream/ocaml_501/parsing/ast_helper.ml create mode 100644 upstream/ocaml_501/parsing/ast_helper.mli create mode 100644 upstream/ocaml_501/parsing/ast_invariants.ml create mode 100644 upstream/ocaml_501/parsing/ast_invariants.mli create mode 100644 upstream/ocaml_501/parsing/ast_iterator.ml create mode 100644 upstream/ocaml_501/parsing/ast_iterator.mli create mode 100644 upstream/ocaml_501/parsing/ast_mapper.ml create mode 100644 upstream/ocaml_501/parsing/ast_mapper.mli create mode 100644 upstream/ocaml_501/parsing/asttypes.mli create mode 100644 upstream/ocaml_501/parsing/attr_helper.ml create mode 100644 upstream/ocaml_501/parsing/attr_helper.mli create mode 100644 upstream/ocaml_501/parsing/builtin_attributes.ml create mode 100644 upstream/ocaml_501/parsing/builtin_attributes.mli create mode 100644 upstream/ocaml_501/parsing/depend.ml create mode 100644 upstream/ocaml_501/parsing/depend.mli create mode 100644 upstream/ocaml_501/parsing/docstrings.ml create mode 100644 upstream/ocaml_501/parsing/docstrings.mli create mode 100644 upstream/ocaml_501/parsing/lexer.mli create mode 100644 upstream/ocaml_501/parsing/lexer.mll create mode 100644 upstream/ocaml_501/parsing/location.ml create mode 100644 upstream/ocaml_501/parsing/location.mli create mode 100644 upstream/ocaml_501/parsing/longident.ml create mode 100644 upstream/ocaml_501/parsing/longident.mli create mode 100644 upstream/ocaml_501/parsing/parse.ml create mode 100644 upstream/ocaml_501/parsing/parse.mli create mode 100644 upstream/ocaml_501/parsing/parser.mly create mode 100644 upstream/ocaml_501/parsing/parsetree.mli create mode 100644 upstream/ocaml_501/parsing/pprintast.ml create mode 100644 upstream/ocaml_501/parsing/pprintast.mli create mode 100644 upstream/ocaml_501/parsing/printast.ml create mode 100644 upstream/ocaml_501/parsing/printast.mli create mode 100644 upstream/ocaml_501/parsing/syntaxerr.ml create mode 100644 upstream/ocaml_501/parsing/syntaxerr.mli create mode 100644 upstream/ocaml_501/typing/annot.mli create mode 100644 upstream/ocaml_501/typing/btype.ml create mode 100644 upstream/ocaml_501/typing/btype.mli create mode 100644 upstream/ocaml_501/typing/cmt2annot.ml create mode 100644 upstream/ocaml_501/typing/cmt2annot.mli create mode 100644 upstream/ocaml_501/typing/ctype.ml create mode 100644 upstream/ocaml_501/typing/ctype.mli create mode 100644 upstream/ocaml_501/typing/datarepr.ml create mode 100644 upstream/ocaml_501/typing/datarepr.mli create mode 100644 upstream/ocaml_501/typing/env.ml create mode 100644 upstream/ocaml_501/typing/env.mli create mode 100644 upstream/ocaml_501/typing/envaux.ml create mode 100644 upstream/ocaml_501/typing/envaux.mli create mode 100644 upstream/ocaml_501/typing/errortrace.ml create mode 100644 upstream/ocaml_501/typing/errortrace.mli create mode 100644 upstream/ocaml_501/typing/ident.ml create mode 100644 upstream/ocaml_501/typing/ident.mli create mode 100644 upstream/ocaml_501/typing/includeclass.ml create mode 100644 upstream/ocaml_501/typing/includeclass.mli create mode 100644 upstream/ocaml_501/typing/includecore.ml create mode 100644 upstream/ocaml_501/typing/includecore.mli create mode 100644 upstream/ocaml_501/typing/includemod.ml create mode 100644 upstream/ocaml_501/typing/includemod.mli create mode 100644 upstream/ocaml_501/typing/includemod_errorprinter.ml create mode 100644 upstream/ocaml_501/typing/includemod_errorprinter.mli create mode 100644 upstream/ocaml_501/typing/mtype.ml create mode 100644 upstream/ocaml_501/typing/mtype.mli create mode 100644 upstream/ocaml_501/typing/oprint.ml create mode 100644 upstream/ocaml_501/typing/oprint.mli create mode 100644 upstream/ocaml_501/typing/outcometree.mli create mode 100644 upstream/ocaml_501/typing/parmatch.ml create mode 100644 upstream/ocaml_501/typing/parmatch.mli create mode 100644 upstream/ocaml_501/typing/path.ml create mode 100644 upstream/ocaml_501/typing/path.mli create mode 100644 upstream/ocaml_501/typing/patterns.ml create mode 100644 upstream/ocaml_501/typing/patterns.mli create mode 100644 upstream/ocaml_501/typing/persistent_env.ml create mode 100644 upstream/ocaml_501/typing/persistent_env.mli create mode 100644 upstream/ocaml_501/typing/predef.ml create mode 100644 upstream/ocaml_501/typing/predef.mli create mode 100644 upstream/ocaml_501/typing/primitive.ml create mode 100644 upstream/ocaml_501/typing/primitive.mli create mode 100644 upstream/ocaml_501/typing/printpat.ml create mode 100644 upstream/ocaml_501/typing/printpat.mli create mode 100644 upstream/ocaml_501/typing/printtyp.ml create mode 100644 upstream/ocaml_501/typing/printtyp.mli create mode 100644 upstream/ocaml_501/typing/printtyped.ml create mode 100644 upstream/ocaml_501/typing/printtyped.mli create mode 100644 upstream/ocaml_501/typing/rec_check.ml create mode 100644 upstream/ocaml_501/typing/rec_check.mli create mode 100644 upstream/ocaml_501/typing/shape.ml create mode 100644 upstream/ocaml_501/typing/shape.mli create mode 100644 upstream/ocaml_501/typing/signature_group.ml create mode 100644 upstream/ocaml_501/typing/signature_group.mli create mode 100644 upstream/ocaml_501/typing/stypes.ml create mode 100644 upstream/ocaml_501/typing/stypes.mli create mode 100644 upstream/ocaml_501/typing/subst.ml create mode 100644 upstream/ocaml_501/typing/subst.mli create mode 100644 upstream/ocaml_501/typing/tast_iterator.ml create mode 100644 upstream/ocaml_501/typing/tast_iterator.mli create mode 100644 upstream/ocaml_501/typing/tast_mapper.ml create mode 100644 upstream/ocaml_501/typing/tast_mapper.mli create mode 100644 upstream/ocaml_501/typing/type_immediacy.ml create mode 100644 upstream/ocaml_501/typing/type_immediacy.mli create mode 100644 upstream/ocaml_501/typing/typeclass.ml create mode 100644 upstream/ocaml_501/typing/typeclass.mli create mode 100644 upstream/ocaml_501/typing/typecore.ml create mode 100644 upstream/ocaml_501/typing/typecore.mli create mode 100644 upstream/ocaml_501/typing/typedecl.ml create mode 100644 upstream/ocaml_501/typing/typedecl.mli create mode 100644 upstream/ocaml_501/typing/typedecl_immediacy.ml create mode 100644 upstream/ocaml_501/typing/typedecl_immediacy.mli create mode 100644 upstream/ocaml_501/typing/typedecl_properties.ml create mode 100644 upstream/ocaml_501/typing/typedecl_properties.mli create mode 100644 upstream/ocaml_501/typing/typedecl_separability.ml create mode 100644 upstream/ocaml_501/typing/typedecl_separability.mli create mode 100644 upstream/ocaml_501/typing/typedecl_unboxed.ml create mode 100644 upstream/ocaml_501/typing/typedecl_unboxed.mli create mode 100644 upstream/ocaml_501/typing/typedecl_variance.ml create mode 100644 upstream/ocaml_501/typing/typedecl_variance.mli create mode 100644 upstream/ocaml_501/typing/typedtree.ml create mode 100644 upstream/ocaml_501/typing/typedtree.mli create mode 100644 upstream/ocaml_501/typing/typemod.ml create mode 100644 upstream/ocaml_501/typing/typemod.mli create mode 100644 upstream/ocaml_501/typing/typeopt.ml create mode 100644 upstream/ocaml_501/typing/typeopt.mli create mode 100644 upstream/ocaml_501/typing/types.ml create mode 100644 upstream/ocaml_501/typing/types.mli create mode 100644 upstream/ocaml_501/typing/typetexp.ml create mode 100644 upstream/ocaml_501/typing/typetexp.mli create mode 100644 upstream/ocaml_501/typing/untypeast.ml create mode 100644 upstream/ocaml_501/typing/untypeast.mli create mode 100644 upstream/ocaml_501/utils/arg_helper.ml create mode 100644 upstream/ocaml_501/utils/arg_helper.mli create mode 100644 upstream/ocaml_501/utils/binutils.ml create mode 100644 upstream/ocaml_501/utils/binutils.mli create mode 100644 upstream/ocaml_501/utils/build_path_prefix_map.ml create mode 100644 upstream/ocaml_501/utils/build_path_prefix_map.mli create mode 100644 upstream/ocaml_501/utils/ccomp.ml create mode 100644 upstream/ocaml_501/utils/ccomp.mli create mode 100644 upstream/ocaml_501/utils/clflags.ml create mode 100644 upstream/ocaml_501/utils/clflags.mli create mode 100644 upstream/ocaml_501/utils/config.common.ml create mode 100644 upstream/ocaml_501/utils/config.fixed.ml create mode 100644 upstream/ocaml_501/utils/config.ml create mode 100644 upstream/ocaml_501/utils/config.mli create mode 100644 upstream/ocaml_501/utils/consistbl.ml create mode 100644 upstream/ocaml_501/utils/consistbl.mli create mode 100644 upstream/ocaml_501/utils/diffing.ml create mode 100644 upstream/ocaml_501/utils/diffing.mli create mode 100644 upstream/ocaml_501/utils/diffing_with_keys.ml create mode 100644 upstream/ocaml_501/utils/diffing_with_keys.mli create mode 100644 upstream/ocaml_501/utils/domainstate.ml.c create mode 100644 upstream/ocaml_501/utils/domainstate.mli.c create mode 100644 upstream/ocaml_501/utils/identifiable.ml create mode 100644 upstream/ocaml_501/utils/identifiable.mli create mode 100644 upstream/ocaml_501/utils/int_replace_polymorphic_compare.ml create mode 100644 upstream/ocaml_501/utils/int_replace_polymorphic_compare.mli create mode 100644 upstream/ocaml_501/utils/lazy_backtrack.ml create mode 100644 upstream/ocaml_501/utils/lazy_backtrack.mli create mode 100644 upstream/ocaml_501/utils/load_path.ml create mode 100644 upstream/ocaml_501/utils/load_path.mli create mode 100644 upstream/ocaml_501/utils/local_store.ml create mode 100644 upstream/ocaml_501/utils/local_store.mli create mode 100644 upstream/ocaml_501/utils/misc.ml create mode 100644 upstream/ocaml_501/utils/misc.mli create mode 100644 upstream/ocaml_501/utils/numbers.ml create mode 100644 upstream/ocaml_501/utils/numbers.mli create mode 100644 upstream/ocaml_501/utils/profile.ml create mode 100644 upstream/ocaml_501/utils/profile.mli create mode 100644 upstream/ocaml_501/utils/strongly_connected_components.ml create mode 100644 upstream/ocaml_501/utils/strongly_connected_components.mli create mode 100644 upstream/ocaml_501/utils/targetint.ml create mode 100644 upstream/ocaml_501/utils/targetint.mli create mode 100644 upstream/ocaml_501/utils/terminfo.ml create mode 100644 upstream/ocaml_501/utils/terminfo.mli create mode 100644 upstream/ocaml_501/utils/warnings.ml create mode 100644 upstream/ocaml_501/utils/warnings.mli diff --git a/upstream/ocaml_501/base-rev.txt b/upstream/ocaml_501/base-rev.txt new file mode 100644 index 0000000000..9a1aca59eb --- /dev/null +++ b/upstream/ocaml_501/base-rev.txt @@ -0,0 +1 @@ +5717a14d0e3dc2b0e41ab94b82977d5761f70ea2 diff --git a/upstream/ocaml_501/file_formats/cmi_format.ml b/upstream/ocaml_501/file_formats/cmi_format.ml new file mode 100644 index 0000000000..aa3d6777a0 --- /dev/null +++ b/upstream/ocaml_501/file_formats/cmi_format.ml @@ -0,0 +1,117 @@ +(**************************************************************************) +(* *) +(* 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 + +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; + Marshal.(to_channel oc ((cmi.cmi_name, cmi.cmi_sign) : header) [Compression]); + 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_501/file_formats/cmi_format.mli b/upstream/ocaml_501/file_formats/cmi_format.mli new file mode 100644 index 0000000000..2a63deb3dc --- /dev/null +++ b/upstream/ocaml_501/file_formats/cmi_format.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* 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 + +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_501/file_formats/cmt_format.ml b/upstream/ocaml_501/file_formats/cmt_format.ml new file mode 100644 index 0000000000..8fa01e525b --- /dev/null +++ b/upstream/ocaml_501/file_formats/cmt_format.ml @@ -0,0 +1,198 @@ +(**************************************************************************) +(* *) +(* 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; + cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_impl_shape : Shape.t option; (* None for mli *) +} + +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; + Marshal.(to_channel oc (cmt : cmt_infos) [Compression]) + +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 shape = + 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; + cmt_uid_to_loc = Env.get_uid_to_loc_tbl (); + cmt_impl_shape = shape; + } in + output_cmt oc cmt) + end; + clear () diff --git a/upstream/ocaml_501/file_formats/cmt_format.mli b/upstream/ocaml_501/file_formats/cmt_format.mli new file mode 100644 index 0000000000..43e09f1236 --- /dev/null +++ b/upstream/ocaml_501/file_formats/cmt_format.mli @@ -0,0 +1,126 @@ +(**************************************************************************) +(* *) +(* 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 infos\} \{\} + where is the cmi file format: + := . + More precisely, the optional 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; + cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_impl_shape : Shape.t option; (* None for mli *) +} + +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 *) + Shape.t option -> + 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_501/parsing/CONFLICTS.md b/upstream/ocaml_501/parsing/CONFLICTS.md new file mode 100644 index 0000000000..b2a84fcbc3 --- /dev/null +++ b/upstream/ocaml_501/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 -> +``` + +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_501/parsing/ast_helper.ml b/upstream/ocaml_501/parsing/ast_helper.ml new file mode 100644 index 0000000000..e99def77bf --- /dev/null +++ b/upstream/ocaml_501/parsing/ast_helper.ml @@ -0,0 +1,646 @@ +(**************************************************************************) +(* *) +(* 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 apply_unit ?loc ?attrs m1 = mk ?loc ?attrs (Pmod_apply_unit m1) + 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 = []) ?value_constraint pat expr = + { + pvb_pat = pat; + pvb_expr = expr; + pvb_constraint=value_constraint; + 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) + ?(vars = []) ?(args = Pcstr_tuple []) ?res name = + { + pcd_name = name; + pcd_vars = vars; + 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) ?(vars = []) ?(args = Pcstr_tuple []) ?res name = + { + pext_name = name; + pext_kind = Pext_decl(vars, 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_501/parsing/ast_helper.mli b/upstream/ocaml_501/parsing/ast_helper.mli new file mode 100644 index 0000000000..07cb87c7b9 --- /dev/null +++ b/upstream/ocaml_501/parsing/ast_helper.mli @@ -0,0 +1,497 @@ +(**************************************************************************) +(* *) +(* 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 -> + ?vars:str list -> ?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 -> + ?vars:str list -> ?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 apply_unit: ?loc:loc -> ?attrs:attrs -> 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 -> + ?value_constraint:value_constraint -> 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_501/parsing/ast_invariants.ml b/upstream/ocaml_501/parsing/ast_invariants.ml new file mode 100644 index 0000000000..d9b83c0edd --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/ast_invariants.mli b/upstream/ocaml_501/parsing/ast_invariants.mli new file mode 100644 index 0000000000..fdb56aa5ef --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/ast_iterator.ml b/upstream/ocaml_501/parsing/ast_iterator.ml new file mode 100644 index 0000000000..2398e772d1 --- /dev/null +++ b/upstream/ocaml_501/parsing/ast_iterator.ml @@ -0,0 +1,697 @@ +(**************************************************************************) +(* *) +(* 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(vars, ctl, cto) -> + List.iter (iter_loc sub) vars; + 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_apply_unit m1 -> + sub.module_expr sub m1 + | 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; pvb_constraint} -> + this.pat this pvb_pat; + this.expr this pvb_expr; + Option.iter (function + | Parsetree.Pvc_constraint {locally_abstract_univars=vars; typ} -> + List.iter (iter_loc this) vars; + this.typ this typ + | Pvc_coercion { ground; coercion } -> + Option.iter (this.typ this) ground; + this.typ this coercion; + ) pvb_constraint; + this.location this pvb_loc; + this.attributes this pvb_attributes + ); + + + constructor_declaration = + (fun this {pcd_name; pcd_vars; pcd_args; + pcd_res; pcd_loc; pcd_attributes} -> + iter_loc this pcd_name; + List.iter (iter_loc this) pcd_vars; + 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_501/parsing/ast_iterator.mli b/upstream/ocaml_501/parsing/ast_iterator.mli new file mode 100644 index 0000000000..638ac5e8b6 --- /dev/null +++ b/upstream/ocaml_501/parsing/ast_iterator.mli @@ -0,0 +1,84 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** {!Ast_iterator.iterator} enables AST inspection using open recursion. A + typical mapper would be based on {!Ast_iterator.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_501/parsing/ast_mapper.ml b/upstream/ocaml_501/parsing/ast_mapper.ml new file mode 100644 index 0000000000..5d97686bf2 --- /dev/null +++ b/upstream/ocaml_501/parsing/ast_mapper.ml @@ -0,0 +1,1104 @@ +(**************************************************************************) +(* *) +(* 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(vars, ctl, cto) -> + Pext_decl(List.map (map_loc sub) vars, + 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_apply_unit m1 -> + apply_unit ~loc ~attrs (sub.module_expr sub m1) + | 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_constraint; pvb_attributes; pvb_loc} -> + let map_ct (ct:Parsetree.value_constraint) = match ct with + | Pvc_constraint {locally_abstract_univars=vars; typ} -> + Pvc_constraint + { locally_abstract_univars = List.map (map_loc this) vars; + typ = this.typ this typ + } + | Pvc_coercion { ground; coercion } -> + Pvc_coercion { + ground = Option.map (this.typ this) ground; + coercion = this.typ this coercion + } + in + Vb.mk + (this.pat this pvb_pat) + (this.expr this pvb_expr) + ?value_constraint:(Option.map map_ct pvb_constraint) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes) + ); + + + constructor_declaration = + (fun this {pcd_name; pcd_vars; pcd_args; + pcd_res; pcd_loc; pcd_attributes} -> + Type.constructor + (map_loc this pcd_name) + ~vars:(List.map (map_loc this) pcd_vars) + ~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 false; (* kept for compatibility *) + 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" -> + (* Duplicates Compmisc.auto_include, since we can't reference Compmisc + from this module. *) + let auto_include find_in_dir fn = + if !Clflags.no_std_include then + raise Not_found + else + let alert = Location.auto_include_alert in + Load_path.auto_include_otherlibs alert find_in_dir fn + in + Load_path.init ~auto_include (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 + | "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] \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_501/parsing/ast_mapper.mli b/upstream/ocaml_501/parsing/ast_mapper.mli new file mode 100644 index 0000000000..69f6b017ab --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/asttypes.mli b/upstream/ocaml_501/parsing/asttypes.mli new file mode 100644 index 0000000000..7a4f1c1913 --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/attr_helper.ml b/upstream/ocaml_501/parsing/attr_helper.ml new file mode 100644 index 0000000000..0a616cd746 --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/attr_helper.mli b/upstream/ocaml_501/parsing/attr_helper.mli new file mode 100644 index 0000000000..a3ddc0c9cb --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/builtin_attributes.ml b/upstream/ocaml_501/parsing/builtin_attributes.ml new file mode 100644 index 0000000000..c90542567a --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/builtin_attributes.mli b/upstream/ocaml_501/parsing/builtin_attributes.mli new file mode 100644 index 0000000000..6200fd74ec --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/depend.ml b/upstream/ocaml_501/parsing/depend.ml new file mode 100644 index 0000000000..b743516d38 --- /dev/null +++ b/upstream/ocaml_501/parsing/depend.ml @@ -0,0 +1,608 @@ +(**************************************************************************) +(* *) +(* 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 + let add_constraint = function + | Pvc_constraint {locally_abstract_univars=_; typ} -> + add_type bv typ + | Pvc_coercion { ground; coercion } -> + Option.iter (add_type bv) ground; + add_type bv coercion + in + let add_one_binding { pvb_pat= _ ; pvb_loc= _ ; pvb_constraint; pvb_expr } = + add_expr bv pvb_expr; + Option.iter add_constraint pvb_constraint + in + List.iter add_one_binding 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_apply_unit mod1 -> + add_module_expr bv mod1 + | 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_501/parsing/depend.mli b/upstream/ocaml_501/parsing/depend.mli new file mode 100644 index 0000000000..74c095f969 --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/docstrings.ml b/upstream/ocaml_501/parsing/docstrings.ml new file mode 100644 index 0000000000..a39f75d259 --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/docstrings.mli b/upstream/ocaml_501/parsing/docstrings.mli new file mode 100644 index 0000000000..bf2508fdc4 --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/lexer.mli b/upstream/ocaml_501/parsing/lexer.mli new file mode 100644 index 0000000000..b5d3a96ac1 --- /dev/null +++ b/upstream/ocaml_501/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 + | 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_501/parsing/lexer.mll b/upstream/ocaml_501/parsing/lexer.mll new file mode 100644 index 0000000000..7429b603b0 --- /dev/null +++ b/upstream/ocaml_501/parsing/lexer.mll @@ -0,0 +1,869 @@ +(**************************************************************************) +(* *) +(* 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_501/parsing/location.ml b/upstream/ocaml_501/parsing/location.ml new file mode 100644 index 0000000000..980ad10306 --- /dev/null +++ b/upstream/ocaml_501/parsing/location.ml @@ -0,0 +1,1030 @@ +(**************************************************************************) +(* *) +(* 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 = Warnings.ghost_loc_in_file + +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. + + We also use for {!is_first_report}, see below. +*) +let num_loc_lines = ref 0 + +(* We use [num_loc_lines] to determine if the report about to be + printed is the first or a follow-up report of the current + "batch" -- contiguous reports without user input in between, for + example for the current toplevel phrase. We use this to print + a blank line between messages of the same batch. +*) +let is_first_message () = + !num_loc_lines = 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 + +(* This is used by the toplevel and the report printers below. *) +let separate_new_message ppf = + if not (is_first_message ()) then begin + Format.pp_print_newline ppf (); + incr num_loc_lines + end + +(* 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 rewrite_find_first_existing path = + match Misc.get_build_path_prefix_map () with + | None -> + if Sys.file_exists path then Some path + else None + | Some prefix_map -> + match Build_path_prefix_map.rewrite_all prefix_map path with + | [] -> + if Sys.file_exists path then Some path + else None + | matches -> + Some (List.find Sys.file_exists matches) + +let rewrite_find_all_existing_dirs path = + let ok path = Sys.file_exists path && Sys.is_directory path in + match Misc.get_build_path_prefix_map () with + | None -> + if ok path then [path] + else [] + | Some prefix_map -> + match Build_path_prefix_map.rewrite_all prefix_map path with + | [] -> + if ok path then [path] + else [] + | matches -> + match (List.filter ok matches) with + | [] -> raise Not_found + | results -> results + +let absolute_path s = (* This function could go into Filename *) + let open Filename in + let s = if (is_relative s) then (concat (Sys.getcwd ()) s) else s in + let s = rewrite_absolute_path 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 "@{"; + + 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 "@["; + 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) ""; + (* Iterate up to [rightmost], which can be larger than the length of + the line because we may point to a location after the end of the + last token on the line, for instance: + {[ + token + ^ + Did you forget ... + ]} *) + for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do + let pos = line_start_cnum + i in + 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 if i < String.length line then begin + (* For alignment purposes, align using a tab for each tab in the + source code *) + if line.[i] = '\t' then Format.pp_print_char ppf '\t' + else Format.pp_print_char ppf ' ' + end; + 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 "@[%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 (); + separate_new_message ppf; + (* 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 "@[%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@}" + | Report_warning w -> Format.fprintf ppf "@{Warning@} %s" w + | Report_warning_as_error w -> + Format.fprintf ppf "@{Error@} (warning %s)" w + | Report_alert w -> Format.fprintf ppf "@{Alert@} %s" w + | Report_alert_as_error w -> + Format.fprintf ppf "@{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 + +let auto_include_alert lib = + let message = Printf.sprintf "\ + OCaml's lib directory layout changed in 5.0. The %s subdirectory has been \ + automatically added to the search path, but you should add -I +%s to the \ + command-line to silence this alert (e.g. by adding %s to the list of \ + libraries in your dune file, or adding use_%s to your _tags file for \ + ocamlbuild, or using -package %s for ocamlfind)." lib lib lib lib lib in + let alert = + {Warnings.kind="ocaml_deprecated_auto_include"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + +let deprecated_script_alert program = + let message = Printf.sprintf "\ + Running %s where the first argument is an implicit basename with no \ + extension (e.g. %s script-file) is deprecated. Either rename the script \ + (%s script-file.ml) or qualify the basename (%s ./script-file)" + program program program program + in + let alert = + {Warnings.kind="ocaml_deprecated_cli"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + +(******************************************************************************) +(* 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_501/parsing/location.mli b/upstream/ocaml_501/parsing/location.mli new file mode 100644 index 0000000000..85bae4ff76 --- /dev/null +++ b/upstream/ocaml_501/parsing/location.mli @@ -0,0 +1,359 @@ +(**************************************************************************) +(* *) +(* 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 separate_new_message: formatter -> unit +val reset: unit -> unit + + +(** {1 Rewriting path } *) + +val rewrite_absolute_path: string -> string +(** [rewrite_absolute_path path] rewrites [path] to honor the + BUILD_PATH_PREFIX_MAP variable + if it is set. It does not check whether [path] is absolute or not. + The result is as follows: + - If BUILD_PATH_PREFIX_MAP is not set, just return [path]. + - otherwise, rewrite using the mapping (and if there are no + matching prefixes that will just return [path]). + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +val rewrite_find_first_existing: string -> string option +(** [rewrite_find_first_existing path] uses a BUILD_PATH_PREFIX_MAP mapping + and tries to find a source in mapping + that maps to a result that exists in the file system. + There are the following return values: + - [None], means either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [path] does not exists, or} + {- no source prefixes of [path] in the mapping were found,}} + - [Some target], means [target] exists and either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [target] = [path], or} + {- [target] is the first file (in priority + order) that [path] mapped to that exists in the file system.}} + - [Not_found] raised, means some source prefixes in the map + were found that matched [path], but none of them existed + in the file system. The caller should catch this and issue + an appropriate error message. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +val rewrite_find_all_existing_dirs: string -> string list +(** [rewrite_find_all_existing_dirs dir] accumulates a list of existing + directories, [dirs], that are the result of mapping a potentially + abstract directory, [dir], over all the mapping pairs in the + BUILD_PATH_PREFIX_MAP environment variable, if any. The list [dirs] + will be in priority order (head as highest priority). + + The possible results are: + - [[]], means either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [dir] is not an existing + directory, or} + {- if set, then there were no matching prefixes of [dir].}} + - [Some dirs], means dirs are the directories found. Either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [dirs = [dir]], or} + {- it was set and [dirs] are the mapped existing directories.}} + - Not_found raised, means some source prefixes in the map + were found that matched [dir], but none of mapping results + were existing directories (possibly due to misconfiguration). + The caller should catch this and issue an appropriate error + message. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +val absolute_path: string -> string + (** [absolute_path path] first makes an absolute path, [s] from [path], + prepending the current working directory if [path] was relative. + Then [s] is rewritten using [rewrite_absolute_path]. + Finally the result is normalized by eliminating instances of + ['.'] or ['..']. *) + +(** {1 Printing locations} *) + +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. *) + +val auto_include_alert: string -> unit +(** Prints an alert that -I +lib has been automatically added to the load + path *) + +val deprecated_script_alert: string -> unit +(** [deprecated_script_alert command] prints an alert that [command foo] has + been deprecated in favour of [command ./foo] *) + +(** {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_501/parsing/longident.ml b/upstream/ocaml_501/parsing/longident.ml new file mode 100644 index 0000000000..eaafb02bee --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/longident.mli b/upstream/ocaml_501/parsing/longident.mli new file mode 100644 index 0000000000..8704a7780e --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/parse.ml b/upstream/ocaml_501/parsing/parse.ml new file mode 100644 index 0000000000..a8061974f4 --- /dev/null +++ b/upstream/ocaml_501/parsing/parse.ml @@ -0,0 +1,155 @@ +(**************************************************************************) +(* *) +(* 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 module_type = wrap Parser.parse_module_type +let module_expr = wrap Parser.parse_module_expr + +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 + | Removed_string_set loc -> + Location.errorf ~loc + "Syntax error: strings are immutable, there is no assignment \ + syntax for them.\n\ + @{Hint@}: Mutable sequences of bytes are available in \ + the Bytes module.\n\ + @{Hint@}: Did you mean to use 'Bytes.set'?" +let () = + Location.register_error_of_exn + (function + | Syntaxerr.Error err -> Some (prepare_error err) + | _ -> None + ) diff --git a/upstream/ocaml_501/parsing/parse.mli b/upstream/ocaml_501/parsing/parse.mli new file mode 100644 index 0000000000..0de6b48a13 --- /dev/null +++ b/upstream/ocaml_501/parsing/parse.mli @@ -0,0 +1,110 @@ +(**************************************************************************) +(* *) +(* 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 +val module_type : Lexing.lexbuf -> Parsetree.module_type +val module_expr : Lexing.lexbuf -> Parsetree.module_expr + +(** 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_501/parsing/parser.mly b/upstream/ocaml_501/parsing/parser.mly new file mode 100644 index 0000000000..7b0e3b26e6 --- /dev/null +++ b/upstream/ocaml_501/parsing/parser.mly @@ -0,0 +1,3904 @@ +/**************************************************************************/ +/* */ +/* 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 -> mkexp ~loc (Pexp_constraint(e, t)) + | _, Some t -> mkexp ~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 removed_string_set loc = + raise(Syntaxerr.Error(Syntaxerr.Removed_string_set(make_loc loc))) + +(* 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, <>] ] + * [ 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 -> + if assign then removed_string_set loc + else 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 lid = + let lid = loc_map (fun id -> Lident (Longident.last id)) lid in + Exp.mk ~loc:lid.loc (Pexp_ident lid) + +let exp_of_label lbl = + Exp.mk ~loc:lbl.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_constraint: value_constraint option; + 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, typ, is_pun) attrs = + { + lb_pattern = p; + lb_expression = e; + lb_constraint=typ; + 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) + ?value_constraint:lb.lb_constraint 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 + ?value_constraint:lb.lb_constraint 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 + ?value_constraint:lb.lb_constraint 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 "'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 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 INFIXOP0 "!=" (* just an example *) +%token INFIXOP1 "@" (* just an example *) +%token INFIXOP2 "+!" (* chosen with care; see above *) +%token INFIXOP3 "land" (* just an example *) +%token INFIXOP4 "**" (* just an example *) +%token DOTOP ".+" +%token LETOP "let*" (* just an example *) +%token ANDOP "and*" (* just an example *) +%token INHERIT "inherit" +%token INITIALIZER "initializer" +%token INT "42" (* just an example *) +%token 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 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 OPTLABEL "?label:" (* just an example *) +%token OR "or" +/* %token PARSER "parser" */ +%token PERCENT "%" +%token PLUS "+" +%token PLUSDOT "+." +%token PLUSEQ "+=" +%token 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 HASHOP "##" (* just an example *) +%token SIG "sig" +%token STAR "*" +%token + STRING "\"hello\"" (* just an example *) +%token + QUOTED_STRING_EXPR "{%hello|world|}" (* just an example *) +%token + 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 UIDENT "UIdent" (* just an example *) +%token UNDERSCORE "_" +%token VAL "val" +%token VIRTUAL "virtual" +%token WHEN "when" +%token WHILE "while" +%token WITH "with" +%token COMMENT "(* comment *)" +%token 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 OBJECT + 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 implementation +/* BEGIN AVOID */ +%start interface /* for interface files */ +%type interface +/* END AVOID */ +%start toplevel_phrase /* for interactive use */ +%type toplevel_phrase +%start use_file /* for the #use directive */ +%type use_file +/* BEGIN AVOID */ +%start parse_module_type +%type parse_module_type +%start parse_module_expr +%type parse_module_expr +%start parse_core_type +%type parse_core_type +%start parse_expression +%type parse_expression +%start parse_pattern +%type parse_pattern +%start parse_constr_longident +%type parse_constr_longident +%start parse_val_longident +%type parse_val_longident +%start parse_mty_longident +%type parse_mty_longident +%start parse_mod_ext_longident +%type parse_mod_ext_longident +%start parse_mod_longident +%type parse_mod_longident +%start parse_any_longident +%type 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_module_type: + module_type EOF + { $1 } +; + +parse_module_expr: + module_expr EOF + { $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 } +; +/* 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) } + | SIG error + { expecting $loc($1) "struct" } + | 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) } + | (* Functor applied to unit. *) + me = module_expr LPAREN RPAREN + { Pmod_apply_unit me } + | (* 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 } + | COLON error + { expecting $loc($1) "=" } + | 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) } + | STRUCT error + { expecting $loc($1) "sig" } + | 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 } + | LPAREN RPAREN MINUSGREATER module_type + { Pmty_functor(Unit, $4) } + | 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 } + | EQUAL error + { expecting $loc($1) ":" } + | 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_done_expr + { Pexp_while($3, $4), $2 } + | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr + do_done_expr + { Pexp_for($3, $5, $7, $6, $8), $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 } +; +%inline do_done_expr: + | DO e = seq_expr DONE + { e } + | DO seq_expr error + { unclosed "do" $loc($1) "done" $loc($2) } +; +%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) } + | OBJECT ext_attributes class_structure END + { Pexp_object $3, $2 } + | OBJECT ext_attributes class_structure error + { unclosed "object" $loc($1) "end" $loc($4) } +; +%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) } + | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN + { (Labelled label, mkexp_constraint ~loc:($startpos($2), $endpos) + (mkexpvar ~loc:$loc(label) label) ty) } + | 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, None) } + | let_ident type_constraint EQUAL seq_expr + { let v = $1 in (* PR#7344 *) + let t = + match $2 with + Some t, None -> + Pvc_constraint { locally_abstract_univars = []; typ=t } + | ground, Some coercion -> Pvc_coercion { ground; coercion} + | _ -> assert false + in + (v, $4, Some t) + } + | let_ident COLON poly(core_type) EQUAL seq_expr + { + let t = ghtyp ~loc:($loc($3)) $3 in + ($1, $5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) + } + | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr + { let constraint' = + Pvc_constraint { locally_abstract_univars=$4; typ = $6} + in + ($1, $8, Some constraint') } + | pattern_no_exn EQUAL seq_expr + { ($1, $3, None) } + | simple_pattern_not_ident COLON core_type EQUAL seq_expr + { ($1, $5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=$3 })) } +; +let_binding_body: + | let_binding_body_no_punning + { let p,e,c = $1 in (p,e,c,false) } +/* BEGIN AVOID */ + | val_ident %prec below_HASH + { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, None, 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 constraint_loc, label, e = + match eo with + | None -> + (* No pattern; this is a pun. Desugar it. *) + $sloc, make_ghost label, exp_of_longident label + | Some e -> + ($startpos(c), $endpos), label, e + in + label, mkexp_opt_constraint ~loc:constraint_loc 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 label, e = + match oe with + | None -> + (* No expression; this is a pun. Desugar it. *) + make_ghost label, exp_of_label label + | Some e -> + label, 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 constraint_loc, 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). *) + $sloc, make_ghost label, pat_of_label label + | Some pat -> + ($startpos(octy), $endpos), label, pat + in + label, mkpat_opt_constraint ~loc:constraint_loc pat octy + } +; + +/* Value descriptions */ + +value_description: + VAL + ext = ext + attrs1 = attributes + id = mkrhs(val_ident) + COLON + ty = possibly_poly(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 = possibly_poly(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) + vars_args_res = generalized_constructor_arguments + attrs = attributes + { + let vars, args, res = vars_args_res in + let info = symbol_info $endpos in + let loc = make_loc $sloc in + cid, vars, args, res, attrs, loc, info + } +; +%inline constructor_declaration(opening): + d = generic_constructor_declaration(opening) + { + let cid, vars, args, res, attrs, loc, info = d in + Type.constructor cid ~vars ~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) + vars_args_res = generalized_constructor_arguments + attrs2 = attributes + attrs = post_item_attributes + { let vars, args, res = vars_args_res in + let loc = make_loc ($startpos, $endpos(attrs2)) in + let docs = symbol_docs $sloc in + Te.mk_exception ~attrs + (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) + , ext } +; +%inline let_exception_declaration: + mkrhs(constr_ident) generalized_constructor_arguments attributes + { let vars, args, res = $2 in + Te.decl $1 ~vars ~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 typevar_list DOT constructor_arguments MINUSGREATER atomic_type + %prec below_HASH + { ($2,$4,Some $6) } + | COLON atomic_type %prec below_HASH + { ([],Pcstr_tuple [],Some $2) } + | COLON typevar_list DOT atomic_type %prec below_HASH + { ($2,Pcstr_tuple [],Some $4) } +; + +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, vars, args, res, attrs, loc, info = d in + Te.decl cid ~vars ~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_501/parsing/parsetree.mli b/upstream/ocaml_501/parsing/parsetree.mli new file mode 100644 index 0000000000..7bb13135e7 --- /dev/null +++ b/upstream/ocaml_501/parsing/parsetree.mli @@ -0,0 +1,1067 @@ +(**************************************************************************) +(* *) +(* 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 + (** Integer constants such as [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 (** Character such as ['c']. *) + | Pconst_string of string * Location.t * string option + (** Constant string such as ["constant"] or + [{delim|other constant|delim}]. + + The location span the content of the string, without the delimiters. + *) + | Pconst_float of string * char option + (** Float constant such as [3.4], [2e5] or [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; + } +(** Attributes such as [[\@id ARG]] and [[\@\@id ARG]]. + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + +and extension = string loc * payload +(** Extension points such as [[%id ARG] and [%%id ARG]]. + + Sub-language placeholder -- rejected by the typechecker. + *) + +and attributes = attribute list + +and payload = + | PStr of structure + | PSig of signature (** [: SIG] in an attribute or an extension point *) + | PTyp of core_type (** [: T] in an attribute or an extension point *) + | PPat of pattern * expression option + (** [? P] or [? P when E], in an attribute or an extension point *) + +(** {1 Core language} *) +(** {2 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 type variable such as ['a] *) + | Ptyp_arrow of arg_label * core_type * core_type + (** [Ptyp_arrow(lbl, T1, T2)] represents: + - [T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Labelled}[Labelled]}, + - [?l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Optional}[Optional]}. + *) + | Ptyp_tuple of core_type list + (** [Ptyp_tuple([T1 ; ... ; Tn])] + represents a product type [T1 * ... * Tn]. + + Invariant: [n >= 2]. + *) + | Ptyp_constr of Longident.t loc * core_type list + (** [Ptyp_constr(lident, l)] represents: + - [tconstr] when [l=[]], + - [T tconstr] when [l=[T]], + - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. + *) + | Ptyp_object of object_field list * closed_flag + (** [Ptyp_object([ l1:T1; ...; ln:Tn ], flag)] represents: + - [< l1:T1; ...; ln:Tn >] when [flag] is + {{!Asttypes.closed_flag.Closed}[Closed]}, + - [< l1:T1; ...; ln:Tn; .. >] when [flag] is + {{!Asttypes.closed_flag.Open}[Open]}. + *) + | Ptyp_class of Longident.t loc * core_type list + (** [Ptyp_class(tconstr, l)] represents: + - [#tconstr] when [l=[]], + - [T #tconstr] when [l=[T]], + - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. + *) + | Ptyp_alias of core_type * string (** [T as 'a]. *) + | Ptyp_variant of row_field list * closed_flag * label list option + (** [Ptyp_variant([`A;`B], flag, labels)] represents: + - [[ `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [None], + - [[> `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]}, + and [labels] is [None], + - [[< `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some []], + - [[< `A|`B > `X `Y ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [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 + {{!pattern_desc.Ppat_constraint}[Ppat_constraint]} node corresponding + to a constraint on a let-binding: + {[let x : 'a1 ... 'an. T = e ...]} + + - Under {{!class_field_kind.Cfk_virtual}[Cfk_virtual]} for methods + (not values). + + - As the {!core_type} of a + {{!class_type_field_desc.Pctf_method}[Pctf_method]} node. + + - As the {!core_type} of a {{!expression_desc.Pexp_poly}[Pexp_poly]} + node. + + - As the {{!label_declaration.pld_type}[pld_type]} field of a + {!label_declaration}. + + - As a {!core_type} of a {{!core_type_desc.Ptyp_object}[Ptyp_object]} + node. + + - As the {{!value_description.pval_type}[pval_type]} field of a + {!value_description}. + *) + | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_extension of extension (** [[%id]]. *) + +and package_type = Longident.t loc * (Longident.t loc * core_type) list +(** As {!package_type} typed values: + - [(S, [])] represents [(module S)], + - [(S, [(t1, T1) ; ... ; (tn, Tn)])] + represents [(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 + (** [Rtag(`A, b, l)] represents: + - [`A] when [b] is [true] and [l] is [[]], + - [`A of T] when [b] is [false] and [l] is [[T]], + - [`A of T1 & .. & Tn] when [b] is [false] and [l] is [[T1;...Tn]], + - [`A of & T1 & .. & Tn] when [b] is [true] and [l] is [[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 + +(** {2 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 (** The pattern [_]. *) + | Ppat_var of string loc (** A variable pattern such as [x] *) + | Ppat_alias of pattern * string loc + (** An alias pattern such as [P as 'a] *) + | Ppat_constant of constant + (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) + | Ppat_interval of constant * constant + (** Patterns such as ['a'..'z']. + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (** Patterns [(P1, ..., Pn)]. + + Invariant: [n >= 2] + *) + | Ppat_construct of Longident.t loc * (string loc list * pattern) option + (** [Ppat_construct(C, args)] represents: + - [C] when [args] is [None], + - [C P] when [args] is [Some ([], P)] + - [C (P1, ..., Pn)] when [args] is + [Some ([], Ppat_tuple [P1; ...; Pn])] + - [C (type a b) P] when [args] is [Some ([a; b], P)] + *) + | Ppat_variant of label * pattern option + (** [Ppat_variant(`A, pat)] represents: + - [`A] when [pat] is [None], + - [`A P] when [pat] is [Some P] + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (** [Ppat_record([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: + - [{ l1=P1; ...; ln=Pn }] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]} + - [{ l1=P1; ...; ln=Pn; _}] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]} + + Invariant: [n > 0] + *) + | Ppat_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) + | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) + | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) + | Ppat_type of Longident.t loc (** Pattern [#tconst] *) + | Ppat_lazy of pattern (** Pattern [lazy P] *) + | Ppat_unpack of string option loc + (** [Ppat_unpack(s)] represents: + - [(module P)] when [s] is [Some "P"] + - [(module _)] when [s] is [None] + + Note: [(module P : S)] is represented as + [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] + *) + | Ppat_exception of pattern (** Pattern [exception P] *) + | Ppat_extension of extension (** Pattern [[%id]] *) + | Ppat_open of Longident.t loc * pattern (** Pattern [M.(P)] *) + +(** {2 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 + (** Identifiers such as [x] and [M.x] + *) + | Pexp_constant of constant + (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], + [1L], [1n] *) + | Pexp_let of rec_flag * value_binding list * expression + (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: + - [let P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pexp_function of case list (** [function P1 -> E1 | ... | Pn -> En] *) + | Pexp_fun of arg_label * expression option * pattern * expression + (** [Pexp_fun(lbl, exp0, P, E1)] represents: + - [fun P -> E1] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [fun ~l:P -> E1] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [fun ?l:P -> E1] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [fun ?l:(P = E0) -> E1] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Notes: + - If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + - [fun P1 P2 .. Pn -> E1] is represented as nested + {{!expression_desc.Pexp_fun}[Pexp_fun]}. + - [let f P = E] is represented using + {{!expression_desc.Pexp_fun}[Pexp_fun]}. + *) + | Pexp_apply of expression * (arg_label * expression) list + (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] + represents [E0 ~l1:E1 ... ~ln:En] + + [li] can be + {{!Asttypes.arg_label.Nolabel}[Nolabel]} (non labeled argument), + {{!Asttypes.arg_label.Labelled}[Labelled]} (labelled arguments) or + {{!Asttypes.arg_label.Optional}[Optional]} (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 + (** Expressions [(E1, ..., En)] + + Invariant: [n >= 2] + *) + | Pexp_construct of Longident.t loc * expression option + (** [Pexp_construct(C, exp)] represents: + - [C] when [exp] is [None], + - [C E] when [exp] is [Some E], + - [C (E1, ..., En)] when [exp] is [Some (Pexp_tuple[E1;...;En])] + *) + | Pexp_variant of label * expression option + (** [Pexp_variant(`A, exp)] represents + - [`A] when [exp] is [None] + - [`A E] when [exp] is [Some E] + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (** [Pexp_record([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents + - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] + - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [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 + (** [Pexp_for(i, E1, E2, direction, E3)] represents: + - [for i = E1 to E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Upto}[Upto]} + - [for i = E1 downto E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} + *) + | Pexp_constraint of expression * core_type (** [(E : T)] *) + | Pexp_coerce of expression * core_type option * core_type + (** [Pexp_coerce(E, from, T)] represents + - [(E :> T)] when [from] is [None], + - [(E : T0 :> T)] when [from] is [Some T0]. + *) + | 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 + {{!class_field_kind.Cfk_concrete}[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 ME, 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 = E0 in E1] + - [let* P0 = E00 and* P1 = E01 in E1] *) + | Pexp_extension of extension (** [[%id]] *) + | Pexp_unreachable (** [.] *) + +and case = + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } +(** Values of type {!case} represents [(P -> E)] or [(P when E0 -> E)] *) + +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; + } + +(** {2 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; + } +(** Values of type {!value_description} represents: + - [val x: T], + when {{!value_description.pval_prim}[pval_prim]} is [[]] + - [external x: T = "s1" ... "sn"] + when {{!value_description.pval_prim}[pval_prim]} is [["s1";..."sn"]] +*) + +(** {2 Type declarations} *) + +and type_declaration = + { + ptype_name: string loc; + ptype_params: (core_type * (variance * injectivity)) list; + (** [('a1,...'an) t] *) + ptype_cstrs: (core_type * core_type * Location.t) list; + (** [... constraint T1=T1' ... constraint Tn=Tn'] *) + ptype_kind: type_kind; + ptype_private: private_flag; (** for [= private ...] *) + ptype_manifest: core_type option; (** represents [= T] *) + ptype_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + ptype_loc: Location.t; + } +(** + Here are type declarations and their representation, + for various {{!type_declaration.ptype_kind}[ptype_kind]} + and {{!type_declaration.ptype_manifest}[ptype_manifest]} values: + - [type t] when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [None], + - [type t = T0] + when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [Some T0], + - [type t = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [None], + - [type t = T0 = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [Some T0], + - [type t = {l: T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [None], + - [type t = T0 = {l : T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [Some T0], + - [type t = ..] + when [type_kind] is {{!type_kind.Ptype_open}[Ptype_open]}, + and [manifest] is [None]. +*) + +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; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Immutable}[Immutable]}, + - [{ ...; mutable l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Mutable}[Mutable]}. + + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. +*) + +and constructor_declaration = + { + pcd_name: string loc; + pcd_vars: string loc list; + 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 + (** Values of type {!constructor_declaration} + represents the constructor arguments of: + - [C of T1 * ... * Tn] when [res = None], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C: T0] when [res = Some T0], + and [args = Pcstr_tuple []], + - [C: T1 * ... * Tn -> T0] when [res = Some T0], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C of {...}] when [res = None], + and [args = Pcstr_record [...]], + - [C: {...} -> T0] when [res = Some T0], + and [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] *) + } +(** + Definition of new extensions constructors for the extensive sum type [t] + ([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]] *) + } + +and type_exception = + { + ptyexn_constructor : extension_constructor; + ptyexn_loc : Location.t; + ptyexn_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) + } +(** Definition of a new exception ([exception E]). *) + +and extension_constructor_kind = + | Pext_decl of string loc list * constructor_arguments * core_type option + (** [Pext_decl(existentials, c_args, t_opt)] + describes a new extension constructor. It can be: + - [C of T1 * ... * Tn] when: + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [None]}.} + - [C: T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[]],} + {- [t_opt] is [Some T0].}} + - [C: T1 * ... * Tn -> T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [Some T0].}} + - [C: 'a... . T1 * ... * Tn -> T0] when + {ul {- [existentials] is [['a;...]],} + {- [c_args] is [[T1; ... ; Tn]],} + {- [t_opt] is [Some T0].}} + *) + | Pext_rebind of Longident.t loc + (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) + +(** {1 Class language} *) +(** {2 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 + (** [Pcty_arrow(lbl, T, CT)] represents: + - [T -> CT] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]}, + - [?l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Optional}[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; + } +(** Values of type [class_signature] represents: + - [object('selfpat) ... end] + - [object ... end] when {{!class_signature.pcsig_self}[pcsig_self]} + is {{!core_type_desc.Ptyp_any}[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 {{!core_type_desc.Ptyp_poly}[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]] *) + } +(** Values of type [class_expr class_infos] represents: + - [class c = ...] + - [class ['a1,...,'an] c = ...] + - [class virtual c = ...] + + They are also used for "class type" declaration. +*) + +and class_description = class_type class_infos + +and class_type_declaration = class_type class_infos + +(** {2 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] and [['a1, ..., 'an] c] *) + | Pcl_structure of class_structure (** [object ... end] *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (** [Pcl_fun(lbl, exp0, P, CE)] represents: + - [fun P -> CE] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None], + - [fun ~l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None], + - [fun ?l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None], + - [fun ?l:(P = E0) -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0]. + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (** [Pcl_apply(CE, [(l1,E1) ; ... ; (ln,En)])] + represents [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 + (** [Pcl_let(rec, [(P1, E1); ... ; (Pn, En)], CE)] represents: + - [let P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Recursive}[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; + } +(** Values of type {!class_structure} represents: + - [object(selfpat) ... end] + - [object ... end] when {{!class_structure.pcstr_self}[pcstr_self]} + is {{!pattern_desc.Ppat_any}[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 + (** [Pcf_inherit(flag, CE, s)] represents: + - [inherit CE] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [None], + - [inherit CE as x] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [Some x], + - [inherit! CE] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [None], + - [inherit! CE as x] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [Some x] + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (** [Pcf_val(x,flag, kind)] represents: + - [val x = E] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + - [val mutable x = E] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val mutable virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (** - [method x = E] + ([E] can be a {{!expression_desc.Pexp_poly}[Pexp_poly]}) + - [method virtual x: T] + ([T] can be a {{!core_type_desc.Ptyp_poly}[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} *) +(** {2 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 (** [Pmty_ident(S)] represents [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 + (** [Named(name, MT)] represents: + - [(X : MT)] when [name] is [Some X], + - [(_ : MT)] when [name] is [None] *) + +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] and [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] and [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; + } +(** Values of type [module_declaration] represents [S : MT] *) + +and module_substitution = + { + pms_name: string loc; + pms_manifest: Longident.t loc; + pms_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pms_loc: Location.t; + } +(** Values of type [module_substitution] represents [S := M] *) + +and module_type_declaration = + { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pmtd_loc: Location.t; + } +(** Values of type [module_type_declaration] represents: + - [S = MT], + - [S] for abstract module type declaration, + when {{!module_type_declaration.pmtd_type}[pmtd_type]} is [None]. +*) + +and 'a open_infos = + { + popen_expr: 'a; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } +(** Values of type ['a open_infos] represents: + - [open! X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Override}[Override]} + (silences the "used identifier shadowing" warning) + - [open X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Fresh}[Fresh]} +*) + +and open_description = Longident.t loc open_infos +(** Values of type [open_description] represents: + - [open M.N] + - [open M(N).O] *) + +and open_declaration = module_expr open_infos +(** Values of type [open_declaration] represents: + - [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 +(** Values of type [include_description] represents [include MT] *) + +and include_declaration = module_expr include_infos +(** Values of type [include_declaration] represents [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] *) + +(** {2 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_apply_unit of module_expr (** [ME1()] *) + | 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 + (** [Pstr_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: + - [let P1 = E1 and ... and Pn = EN] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN ] + when [rec] is {{!Asttypes.rec_flag.Recursive}[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_constraint = + | Pvc_constraint of { + locally_abstract_univars:string loc list; + typ:core_type; + } + | Pvc_coercion of {ground:core_type option; coercion:core_type } + (** + - [Pvc_constraint { locally_abstract_univars=[]; typ}] + is a simple type constraint on a value binding: [ let x : typ] + - More generally, in [Pvc_constraint { locally_abstract_univars; typ}] + [locally_abstract_univars] is the list of locally abstract type + variables in [ let x: type a ... . typ ] + - [Pvc_coercion { ground=None; coercion }] represents [let x :> typ] + - [Pvc_coercion { ground=Some g; coercion }] represents [let x : g :> typ] + *) + +and value_binding = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_constraint: value_constraint option; + pvb_attributes: attributes; + pvb_loc: Location.t; + }(** [let pat : type_constraint = exp] *) + +and module_binding = + { + pmb_name: string option loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } +(** Values of type [module_binding] represents [module X = ME] *) + +(** {1 Toplevel} *) + +(** {2 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_501/parsing/pprintast.ml b/upstream/ocaml_501/parsing/pprintast.ml new file mode 100644 index 0000000000..9c1d7a0880 --- /dev/null +++ b/upstream/ocaml_501/parsing/pprintast.ml @@ -0,0 +1,1677 @@ +(**************************************************************************) +(* *) +(* 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 + +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 -> match l with + | [] -> () + | _ -> + pp f "%a@;.@;" + (list tyvar_loc ~sep:"@;") 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 "@[%s: %a@ %a@ @]" l.txt + (core_type ctxt) ct (attributes ctxt) x.pof_attributes + | Oinherit ct -> + pp f "@[%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 "@[<@ %a%a@ > @]" + (list core_field_type ~sep:";") l + field_var o (* Cf #7200 *) + | Ptyp_class (li, l) -> (*FIXME*) + pp f "@[%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 "@[(module@ %a)@]" longident_loc lid + |_ -> + pp f "@[(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 "@[%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 "@[!%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 "@[function%a@]" (case_list ctxt) l + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + (expression reset_ctxt) e (case_list ctxt) l + + | Pexp_try (e, l) -> + pp f "@[<0>@[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 "@[%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 ="@[@[<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 "@[%a@]" + (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new (li) -> + pp f "@[new@ %a@]" longident_loc li; + | Pexp_setinstvar (s, e) -> + pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e + | Pexp_override l -> (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in + pp f "@[{<%a>}@]" + (list string_x_expression ~sep:";" ) l; + | Pexp_letmodule (s, me, e) -> + pp f "@[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 "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) cd + (expression ctxt) e + | Pexp_assert e -> + pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy (e) -> + pp f "@[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 "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!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>@[%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 "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> pp f "@[%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 "@[[%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 "@[(%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 "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%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 = + "@[@[@[<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 "@[%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 "@[exception@ %a@]%a" + (extension_constructor ctxt) x.ptyexn_constructor + (item_attributes ctxt) x.ptyexn_attributes + +and class_type_field ctxt 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 + +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = + pp f "@[@[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 ctxt) ~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 "@[%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_constraint=None; + 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 "@[@[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 "@[() ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (Named (s, mt1), mt2) -> + begin match s.txt with + | None -> + pp f "@[%a@ ->@ %a@]" + (module_type1 ctxt) mt1 (module_type ctxt) mt2 + | Some name -> + pp f "@[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 "@[%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)) -> + pp f "type@ %a %a =@ %a" + (type_params ctxt) 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)) -> + pp f "type@ %a %a :=@ %a" + (type_params ctxt) 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 "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) s (* FIXME wrong indentation*) + | Pmty_typeof me -> + pp f "@[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 "@[%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 "@[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 "@[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 "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt + longident_loc pms.pms_manifest + (item_attributes ctxt) pms.pms_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_expr + (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[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 "@[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 "@[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 "@ @[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 "@[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 "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") s; + | Pmod_constraint (me, mt) -> + pp f "@[(%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_apply_unit me1 -> + pp f "(%a)()" (module_expr ctxt) me1 + | 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_constraint = ct; _} = + (* .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 + match ct with + | Some (Pvc_constraint { locally_abstract_univars = []; typ }) -> + pp f "%a@;:@;%a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) typ (expression ctxt) x + | Some (Pvc_constraint { locally_abstract_univars = vars; typ }) -> + pp f "%a@;: type@;%a.@;%a@;=@;%a" + (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") + (List.map (fun x -> x.txt) vars) + (core_type ctxt) typ (expression ctxt) x + | Some (Pvc_coercion {ground=None; coercion }) -> + pp f "%a@;:>@;%a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) coercion (expression ctxt) x + | Some (Pvc_coercion {ground=Some ground; coercion }) -> + pp f "%a@;:%a@;:>@;%a@;=@;%a" + (simple_pattern ctxt) p + (core_type ctxt) ground + (core_type ctxt) coercion + (expression ctxt) x + | None -> begin + match p with + | {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 "@[%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 "@[;;%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 "@[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 "@[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 "@[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 "@[%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 "@[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 "@[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 "@[@ 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 "@[@ 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 "@[@[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 "@[@[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 "@[%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_vars, + 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 "@[@ 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, vars, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s in + let pp_vars f vs = + match vs with + | [] -> () + | vs -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") vs 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@;%a" name + pp_vars vars + (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(v, l, r) -> + constructor_declaration ctxt f + (x.pext_name.txt, v, 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 "@[%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 "@[#%s@]" pdir_name.txt + | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} -> + pp f "@[#%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 module_type = module_type reset_ctxt +let class_field = class_field reset_ctxt +let class_type_field = class_type_field reset_ctxt +let class_expr = class_expr reset_ctxt +let class_type = class_type reset_ctxt +let structure_item = structure_item reset_ctxt +let signature_item = signature_item reset_ctxt +let binding = binding reset_ctxt +let payload = payload reset_ctxt diff --git a/upstream/ocaml_501/parsing/pprintast.mli b/upstream/ocaml_501/parsing/pprintast.mli new file mode 100644 index 0000000000..42acd5f15c --- /dev/null +++ b/upstream/ocaml_501/parsing/pprintast.mli @@ -0,0 +1,55 @@ +(**************************************************************************) +(* *) +(* 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 class_field: Format.formatter -> Parsetree.class_field -> unit +val class_type_field: Format.formatter -> Parsetree.class_type_field -> unit +val class_expr: Format.formatter -> Parsetree.class_expr -> unit +val class_type: Format.formatter -> Parsetree.class_type -> unit +val module_type: Format.formatter -> Parsetree.module_type -> unit +val structure_item: Format.formatter -> Parsetree.structure_item -> unit +val signature_item: Format.formatter -> Parsetree.signature_item -> unit +val binding: Format.formatter -> Parsetree.value_binding -> unit +val payload: Format.formatter -> Parsetree.payload -> 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_501/parsing/printast.ml b/upstream/ocaml_501/parsing/printast.ml new file mode 100644 index 0000000000..cdca427060 --- /dev/null +++ b/upstream/ocaml_501/parsing/printast.ml @@ -0,0 +1,982 @@ +(**************************************************************************) +(* *) +(* 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 typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + +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" typevars 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 "\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(v, a, r) -> + line i ppf "Pext_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; + 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_apply_unit me1 -> + line i ppf "Pmod_apply_unit\n"; + module_expr i ppf me1 + | 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 " %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_vars; 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; + if pcd_vars <> [] then line (i+1) ppf "pcd_vars =%a\n" typevars pcd_vars; + 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 "\n"; + pattern (i+1) ppf pc_lhs; + begin match pc_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf pc_rhs; + +and value_binding i ppf x = + line i ppf "\n"; + attributes (i+1) ppf x.pvb_attributes; + pattern (i+1) ppf x.pvb_pat; + Option.iter (value_constraint (i+1) ppf) x.pvb_constraint; + expression (i+1) ppf x.pvb_expr + +and value_constraint i ppf x = + let pp_sep ppf () = Format.fprintf ppf "@ "; in + let pp_newtypes = Format.pp_print_list fmt_string_loc ~pp_sep in + match x with + | Pvc_constraint { locally_abstract_univars = []; typ } -> + core_type i ppf typ + | Pvc_constraint { locally_abstract_univars=newtypes; typ} -> + line i ppf " %a.\n" pp_newtypes newtypes; + core_type i ppf typ + | Pvc_coercion { ground; coercion} -> + line i ppf "\n"; + option i core_type ppf ground; + core_type i ppf coercion; + + +and binding_op i ppf x = + line i ppf " %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 " %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 "\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_501/parsing/printast.mli b/upstream/ocaml_501/parsing/printast.mli new file mode 100644 index 0000000000..5bc496182f --- /dev/null +++ b/upstream/ocaml_501/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_501/parsing/syntaxerr.ml b/upstream/ocaml_501/parsing/syntaxerr.ml new file mode 100644 index 0000000000..df7b8a0548 --- /dev/null +++ b/upstream/ocaml_501/parsing/syntaxerr.ml @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* 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 + | Removed_string_set of Location.t + +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, _) + | Removed_string_set l -> l + + +let ill_formed_ast loc s = + raise (Error (Ill_formed_ast (loc, s))) diff --git a/upstream/ocaml_501/parsing/syntaxerr.mli b/upstream/ocaml_501/parsing/syntaxerr.mli new file mode 100644 index 0000000000..577d5360cd --- /dev/null +++ b/upstream/ocaml_501/parsing/syntaxerr.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* 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 + | Removed_string_set of Location.t + +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_501/typing/annot.mli b/upstream/ocaml_501/typing/annot.mli new file mode 100644 index 0000000000..bbaade5b03 --- /dev/null +++ b/upstream/ocaml_501/typing/annot.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* 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_501/typing/btype.ml b/upstream/ocaml_501/typing/btype.ml new file mode 100644 index 0000000000..7ac1aff412 --- /dev/null +++ b/upstream/ocaml_501/typing/btype.ml @@ -0,0 +1,772 @@ +(**************************************************************************) +(* *) +(* 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 ****) + +let wrap_repr f ty = f (Transient_expr.repr ty) +let wrap_type_expr f tty = f (Transient_expr.type_expr tty) + +module TransientTypeSet = Set.Make(TransientTypeOps) +module TypeSet = struct + include TransientTypeSet + let add = wrap_repr add + let mem = wrap_repr mem + let singleton = wrap_repr singleton + let exists p = TransientTypeSet.exists (wrap_type_expr p) + let elements set = + List.map Transient_expr.type_expr (TransientTypeSet.elements set) +end +module TransientTypeMap = Map.Make(TransientTypeOps) +module TypeMap = struct + include TransientTypeMap + let add ty = wrap_repr add ty + let find ty = wrap_repr find ty + let singleton ty = wrap_repr singleton ty + let fold f = TransientTypeMap.fold (wrap_type_expr f) +end +module TransientTypeHash = Hashtbl.Make(TransientTypeOps) +module TypeHash = struct + include TransientTypeHash + let add hash = wrap_repr (add hash) + let remove hash = wrap_repr (remove hash) + let find hash = wrap_repr (find hash) + let iter f = TransientTypeHash.iter (wrap_type_expr f) +end +module TransientTypePairs = + Hashtbl.Make (struct + type t = transient_expr * transient_expr + let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') + let hash (t, t') = t.id + 93 * t'.id + end) +module TypePairs = struct + module H = TransientTypePairs + open Transient_expr + + type t = { + set : unit H.t; + mutable elems : (transient_expr * transient_expr) list; + (* elems preserves the (reversed) insertion order of elements *) + } + + let create n = + { elems = []; set = H.create n } + + let clear t = + t.elems <- []; + H.clear t.set + + let repr2 (t1, t2) = (repr t1, repr t2) + + let add t p = + let p = repr2 p in + if H.mem t.set p then () else begin + H.add t.set p (); + t.elems <- p :: t.elems + end + + let mem t p = H.mem t.set (repr2 p) + + let iter f t = + (* iterate in insertion order, not Hashtbl.iter order *) + List.rev t.elems + |> List.iter (fun (t1,t2) -> + f (type_expr t1, type_expr t2)) +end + +(**** 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 newgenty desc = newty2 ~level:generic_level desc +let newgenvar ?name () = newgenty (Tvar name) +let newgenstub ~scope = newty3 ~level:generic_level ~scope (Tvar None) + +(* +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 ty = match get_desc ty with Tvar _ -> true | _ -> false +let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false +let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false + +let dummy_method = "*dummy method*" + +(**** Representative of a type ****) + +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 = + match row_fixed row with + | Some _ as x -> x + | None -> + let ty = row_more row in + match get_desc ty with + | Tvar _ | Tnil -> None + | Tunivar _ -> Some (Univar ty) + | Tconstr (p,_,_) -> Some (Reified p) + | _ -> assert false + +let is_fixed row = match row_fixed row with + | None -> false + | Some _ -> true + +let has_fixed_explanation row = fixed_explanation row <> None + +let static_row row = + row_closed row && + List.for_all + (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true) + (row_fields row) + +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 = + match get_desc ty with + | Tvariant row when not (static_row row) -> + row_more row + | Tobject (ty, _) -> + let rec proxy_obj ty = + match get_desc ty with + Tfield (_, _, _, ty) -> proxy_obj ty + | Tvar _ | Tunivar _ | Tconstr _ -> ty + | Tnil -> ty + | _ -> assert false + in proxy_obj ty + | _ -> ty + +(**** Utilities for fixed row private types ****) + +let row_of_type t = + match get_desc t with + Tobject(t,_) -> + let rec get_row t = + match get_desc t 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 get_desc t 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_static_row_name decl path = + match decl.type_manifest with + None -> () + | Some ty -> + match get_desc ty with + Tvariant row when static_row row -> + let row = + set_row_name row (Some (path, decl.type_params)) in + set_type_desc ty (Tvariant row) + | _ -> () + + + (**********************************) + (* Utilities for type traversal *) + (**********************************) + +let 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_fields row) + in + match get_desc (row_more row) with + | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil -> + begin match + Option.map (fun (_,l) -> List.fold_left f result l) (row_name row) + 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 get_desc ty 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 _ + | 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; + it.it_type_expr it cs.csig_self_row; + Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars; + Meths.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_meths + | 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 get_desc ty with + Tconstr (p, _, _) + | Tobject (_, {contents=Some (p, _)}) + | Tpackage (p, _) -> + it.it_path p + | Tvariant row -> + Option.iter (fun (p,_) -> it.it_path p) (row_name row) + | _ -> () + 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 Row {fields = orig_fields; fixed = orig_fixed; closed; name = orig_name} = + row_repr row in + let fields = List.map + (fun (l, fi) -> l, + match row_field_repr fi with + | Rpresent oty -> rf_present (Option.map f oty) + | Reither(c, tl, m) -> + let use_ext_of = if keep then Some fi else None in + let m = if is_fixed row then fixed else m in + let tl = List.map f tl in + rf_either tl ?use_ext_of ~no_arg:c ~matched:m + | Rabsent -> rf_absent) + orig_fields in + let name = + match orig_name with + | None -> None + | Some (path, tl) -> Some (path, List.map f tl) in + let fixed = if fixed then orig_fixed else None in + create_row ~fields ~more ~fixed ~closed ~name + +let copy_commu c = if is_commu_ok c then commu_ok else commu_var () + +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) -> + Tfield (p, field_kind_internal_repr k, f ty1, f ty2) + (* the kind is kept shared, with indirections removed for performance *) + | Tnil -> Tnil + | Tlink ty -> copy_type_desc f (get_desc ty) + | 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 redirect_desc: copy_scope -> type_expr -> type_desc -> unit + + val with_scope: (copy_scope -> 'a) -> 'a +end = struct + type copy_scope = { + mutable saved_desc : (transient_expr * type_desc) list; + (* Save association of generic nodes with their description. *) + } + + let redirect_desc copy_scope ty desc = + let ty = Transient_expr.repr ty in + copy_scope.saved_desc <- (ty, ty.desc) :: copy_scope.saved_desc; + Transient_expr.set_desc ty desc + + (* Restore type descriptions. *) + let cleanup { saved_desc; _ } = + List.iter (fun (ty, desc) -> Transient_expr.set_desc ty desc) saved_desc + + let with_scope f = + let scope = { saved_desc = [] } 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 +*) + +(* Re-export backtrack *) + +let snapshot = snapshot +let backtrack = backtrack ~cleanup_abbrev + + (**********************************) + (* 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 + + (*******************************) + (* 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 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 + +(* Fully expand the head of a class type *) +let rec scrape_class_type = + function + Cty_constr (_, _, cty) -> scrape_class_type cty + | cty -> cty + +let rec class_type_arity = + function + Cty_constr (_, _, cty) -> class_type_arity cty + | Cty_signature _ -> 0 + | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty + +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) + +let self_type cty = + (signature_of_class_type cty).csig_self + +let self_type_row cty = + (signature_of_class_type cty).csig_self_row + +(* Return the methods of a class signature *) +let methods sign = + Meths.fold + (fun name _ l -> name :: l) + sign.csig_meths [] + +(* Return the virtual methods of a class signature *) +let virtual_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_meths [] + +(* Return the concrete methods of a class signature *) +let concrete_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> MethSet.add name s) + sign.csig_meths MethSet.empty + +(* Return the public methods of a class signature *) +let public_methods sign = + Meths.fold + (fun name (priv, _vr, _ty) l -> + match priv with + | Mprivate _ -> l + | Mpublic -> name :: l) + sign.csig_meths [] + +(* Return the instance variables of a class signature *) +let instance_vars sign = + Vars.fold + (fun name _ l -> name :: l) + sign.csig_vars [] + +(* Return the virtual instance variables of a class signature *) +let virtual_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_vars [] + +(* Return the concrete instance variables of a class signature *) +let concrete_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> VarSet.add name s) + sign.csig_vars VarSet.empty + +let method_type label sign = + match Meths.find label sign.csig_meths with + | (_, _, ty) -> ty + | exception Not_found -> assert false + +let instance_variable_type label sign = + match Vars.find label sign.csig_vars with + | (_, _, ty) -> ty + | exception Not_found -> assert false + + (**********************************) + (* Utilities for level-marking *) + (**********************************) + +let not_marked_node ty = get_level ty >= lowest_level + (* type nodes with negative levels are "marked" *) + +let flip_mark_node ty = + let ty = Transient_expr.repr ty in + Transient_expr.set_level ty (pivot_level - ty.level) +let logged_mark_node ty = + set_level ty (pivot_level - get_level ty) + +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 = + 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 = + 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 = + if get_level ty < 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; + unmark_type sign.csig_self_row; + Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars; + Meths.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_meths + +let unmark_class_type cty = + unmark_iterators.it_class_type unmark_iterators cty + +(**** Type information getter ****) + +let cstr_type_path cstr = + match get_desc cstr.cstr_res with + | Tconstr (p, _, _) -> p + | _ -> assert false diff --git a/upstream/ocaml_501/typing/btype.mli b/upstream/ocaml_501/typing/btype.mli new file mode 100644 index 0000000000..18f7c750a8 --- /dev/null +++ b/upstream/ocaml_501/typing/btype.mli @@ -0,0 +1,316 @@ +(**************************************************************************) +(* *) +(* 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 : sig + include Set.S with type elt = transient_expr + val add: type_expr -> t -> t + val mem: type_expr -> t -> bool + val singleton: type_expr -> t + val exists: (type_expr -> bool) -> t -> bool + val elements: t -> type_expr list +end +module TransientTypeMap : Map.S with type key = transient_expr +module TypeMap : sig + include Map.S with type key = transient_expr + and type 'a t = 'a TransientTypeMap.t + val add: type_expr -> 'a -> 'a t -> 'a t + val find: type_expr -> 'a t -> 'a + val singleton: type_expr -> 'a -> 'a t + val fold: (type_expr -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end +module TypeHash : sig + include Hashtbl.S with type key = transient_expr + val add: 'a t -> type_expr -> 'a -> unit + val remove : 'a t -> type_expr -> unit + val find: 'a t -> type_expr -> 'a + val iter: (type_expr -> 'a -> unit) -> 'a t -> unit +end +module TypePairs : sig + type t + val create: int -> t + val clear: t -> unit + val add: t -> type_expr * type_expr -> unit + val mem: t -> type_expr * type_expr -> bool + val iter: (type_expr * type_expr -> unit) -> t -> unit +end + +(**** Levels ****) + +val generic_level: int + +val newgenty: type_desc -> type_expr + (* Create a generic type *) +val newgenvar: ?name:string -> unit -> type_expr + (* Return a fresh generic variable *) +val newgenstub: scope:int -> type_expr + (* Return a fresh generic node, to be instantiated + by [Transient_expr.set_stub_desc] *) + +(* 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 + +(**** polymorphic variants ****) + +val is_fixed: row_desc -> bool +(* Return whether the row is directly marked as fixed or not *) + +val has_fixed_explanation: row_desc -> bool +(* Return whether the row should be treated as fixed or not. + In particular, [is_fixed row] implies [has_fixed_explanation 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_static_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 *) +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) + + +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 + +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 redirect_desc: copy_scope -> type_expr -> type_desc -> unit + (* Temporarily change a type description *) + + 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 *) +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. + 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 *) + +(**** Backtracking ****) + +val snapshot: unit -> snapshot +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 *) + +(**** 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 class types ****) + +(* Get the class signature within a class type *) +val signature_of_class_type : class_type -> class_signature + +(* Get the body of a class type (i.e. without parameters) *) +val class_body : class_type -> class_type + +(* Fully expand the head of a class type *) +val scrape_class_type : class_type -> class_type + +(* Return the number of parameters of a class type *) +val class_type_arity : class_type -> int + +(* Given a path and type parameters, add an abbreviation to a class type *) +val abbreviate_class_type : + Path.t -> type_expr list -> class_type -> class_type + +(* Get the self type of a class *) +val self_type : class_type -> type_expr + +(* Get the row variable of the self type of a class *) +val self_type_row : class_type -> type_expr + +(* Return the methods of a class signature *) +val methods : class_signature -> string list + +(* Return the virtual methods of a class signature *) +val virtual_methods : class_signature -> string list + +(* Return the concrete methods of a class signature *) +val concrete_methods : class_signature -> MethSet.t + +(* Return the public methods of a class signature *) +val public_methods : class_signature -> string list + +(* Return the instance variables of a class signature *) +val instance_vars : class_signature -> string list + +(* Return the virtual instance variables of a class signature *) +val virtual_instance_vars : class_signature -> string list + +(* Return the concrete instance variables of a class signature *) +val concrete_instance_vars : class_signature -> VarSet.t + +(* Return the type of a method. + @raises [Assert_failure] if the class has no such method. *) +val method_type : label -> class_signature -> type_expr + +(* Return the type of an instance variable. + @raises [Assert_failure] if the class has no such method. *) +val instance_variable_type : label -> class_signature -> type_expr + +(**** Forward declarations ****) +val print_raw: (Format.formatter -> type_expr -> unit) ref + +(**** Type information getter ****) + +val cstr_type_path : constructor_description -> Path.t diff --git a/upstream/ocaml_501/typing/cmt2annot.ml b/upstream/ocaml_501/typing/cmt2annot.ml new file mode 100644 index 0000000000..40ee752e80 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/cmt2annot.mli b/upstream/ocaml_501/typing/cmt2annot.mli new file mode 100644 index 0000000000..2dfa8dec2a --- /dev/null +++ b/upstream/ocaml_501/typing/cmt2annot.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Sebastien Hinderer, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2022 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed 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. *) + +val gen_annot : + string option -> + sourcefile:string option -> + use_summaries:bool -> Cmt_format.binary_annots -> + unit diff --git a/upstream/ocaml_501/typing/ctype.ml b/upstream/ocaml_501/typing/ctype.ml new file mode 100644 index 0000000000..bec19ae528 --- /dev/null +++ b/upstream/ocaml_501/typing/ctype.ml @@ -0,0 +1,5526 @@ +(**************************************************************************) +(* *) +(* 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 knows 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 ****) + +(* There are two classes of errortrace-related exceptions: *traces* and + *errors*. The former, whose names end with [_trace], contain + [Errortrace.trace]s, representing traces that are currently being built; they + are local to this file. All the internal functions that implement + unification, type equality, and moregen raise trace exceptions. Once we are + done, in the top level functions such as [unify], [equal], and [moregen], we + catch the trace exceptions and transform them into the analogous error + exception. This indicates that we are done building the trace, and expect + the error to flow out of unification, type equality, or moregen into + surrounding code (with some few exceptions when these top-level functions are + used as building blocks elsewhere.) Only the error exceptions are exposed in + [ctype.mli]; the trace exceptions are an implementation detail. Any trace + exception that escapes from a function in this file is a bug. *) + +exception Unify_trace of unification trace +exception Equality_trace of comparison trace +exception Moregen_trace of comparison trace + +exception Unify of unification_error +exception Equality of equality_error +exception Moregen of moregen_error +exception Subtype of Subtype.error + +exception Escape of type_expr 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 trace) : 'a = + match tr_exn with + | Unify -> raise (Unify_trace tr) + | Equality -> raise (Equality_trace tr) + | Moregen -> raise (Moregen_trace 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 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_error + +exception Incompatible + +(**** Type level management ****) + +let current_level = s_ref 0 +let nongen_level = s_ref 0 +let global_level = s_ref 0 +let saved_level = s_ref [] + +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 wrap_end_def f = Misc.try_finally f ~always:end_def + +let with_local_level ?post f = + begin_def (); + let result = wrap_end_def f in + Option.iter (fun g -> g result) post; + result +let with_local_level_if cond f ~post = + if cond then with_local_level f ~post else f () +let with_local_level_iter f ~post = + begin_def (); + let result, l = wrap_end_def f in + List.iter post l; + result +let with_local_level_iter_if cond f ~post = + if cond then with_local_level_iter f ~post else fst (f ()) +let with_local_level_if_principal f ~post = + with_local_level_if !Clflags.principal f ~post +let with_local_level_iter_if_principal f ~post = + with_local_level_iter_if !Clflags.principal f ~post +let with_level ~level f = + begin_def (); init_def level; + let result = wrap_end_def f in + result +let with_level_if cond ~level f = + if cond then with_level ~level f else f () + +let with_local_level_for_class ?post f = + begin_class_def (); + let result = wrap_end_def f in + Option.iter (fun g -> g result) post; + result + +let with_raised_nongen_level f = + raise_nongen_level (); + wrap_end_def f + + +let reset_global_level () = + global_level := !current_level +let increase_global_level () = + let gl = !global_level in + global_level := !current_level; + gl +let restore_global_level gl = + global_level := gl + +(**** 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 tl abbrev = + if tl <> [] || !trace_gadt_instances || !Clflags.principal + then abbrev + else simple_abbrevs + +(**** Some type creators ****) + +(* Re-export generic type creators *) + +let newty desc = newty2 ~level:!current_level desc +let new_scoped_ty scope desc = newty3 ~level:!current_level ~scope desc + +let newvar ?name () = newty2 ~level:!current_level (Tvar name) +let newvar2 ?name level = newty2 ~level:level (Tvar name) +let new_global_var ?name () = newty2 ~level:!global_level (Tvar name) +let newstub ~scope = newty3 ~level:!current_level ~scope (Tvar None) + +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 *) + +(**** unification mode ****) + +type equations_generation = + | Forbidden + | Allowed of { equated_types : TypePairs.t } + +type unification_mode = + | Expression (* unification in expression *) + | Pattern of + { equations_generation : equations_generation; + assume_injective : bool; + allow_recursive_equations : bool; } + (* unification in pattern which may add local constraints *) + | Subst + (* unification during type constructor expansion; more + relaxed than [Expression] in some cases. *) + +let umode = ref Expression + +let in_pattern_mode () = + match !umode with + | Expression | Subst -> false + | Pattern _ -> true + +let in_subst_mode () = + match !umode with + | Expression | Pattern _ -> false + | Subst -> true + +let can_generate_equations () = + match !umode with + | Expression | Subst | Pattern { equations_generation = Forbidden } -> false + | Pattern { equations_generation = Allowed _ } -> true + +(* Can only be called when generate_equations is true *) +let record_equation t1 t2 = + match !umode with + | Expression | Subst | Pattern { equations_generation = Forbidden } -> + assert false + | Pattern { equations_generation = Allowed { equated_types } } -> + TypePairs.add equated_types (t1, t2) + +let can_assume_injective () = + match !umode with + | Expression | Subst -> false + | Pattern { assume_injective } -> assume_injective + +let in_counterexample () = + match !umode with + | Expression | Subst -> false + | Pattern { allow_recursive_equations } -> allow_recursive_equations + +let allow_recursive_equations () = + !Clflags.recursive_types + || match !umode with + | Expression | Subst -> false + | Pattern { allow_recursive_equations } -> allow_recursive_equations + +let set_mode_pattern ~allow_recursive_equations ~equated_types f = + let equations_generation = Allowed { equated_types } in + let assume_injective = true in + let new_umode = + Pattern + { equations_generation; + assume_injective; + allow_recursive_equations } + in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f + +let without_assume_injective f = + match !umode with + | Expression | Subst -> f () + | Pattern r -> + let new_umode = Pattern { r with assume_injective = false } in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f + +let without_generating_equations f = + match !umode with + | Expression | Subst -> f () + | Pattern r -> + let new_umode = Pattern { r with equations_generation = Forbidden } in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f + +(*** Checks for type definitions ***) + +let rec in_current_module = function + | Path.Pident _ -> true + | Path.Pdot _ | Path.Papply _ -> false + | Path.Pextra_ty (p, _) -> in_current_module p + +let in_pervasives p = + in_current_module p && + try ignore (Env.find_type p Env.initial); 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 get_desc ty with + Tobject (fields, _) -> fields + | _ -> assert false + +let flatten_fields ty = + let rec flatten l ty = + match get_desc ty 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) + +(**** Check whether an object is open ****) + +(* +++ The abbreviation should eventually be expanded *) +let rec object_row ty = + match get_desc ty with + Tobject (t, _) -> object_row t + | Tfield(_, _, _, t) -> object_row t + | _ -> ty + +let opened_object ty = + match get_desc (object_row ty) with + | Tvar _ | Tunivar _ | Tconstr _ -> true + | _ -> false + +let concrete_object ty = + match get_desc (object_row ty) with + | Tvar _ -> false + | _ -> true + +(**** Row variable of an object type ****) + +let rec fields_row_variable ty = + match get_desc ty with + | Tfield (_, _, _, ty) -> fields_row_variable ty + | Tvar _ -> ty + | _ -> assert false + +(**** Object name manipulation ****) +(* +++ Bientot obsolete *) + +let set_object_name id params ty = + match get_desc ty with + | Tobject (fi, nm) -> + let rv = fields_row_variable fi in + set_name nm (Some (Path.Pident id, rv::params)) + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.set_object_name" + +let remove_object_name ty = + match get_desc ty with + Tobject (_, nm) -> set_name nm None + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.remove_object_name" + + (*******************************************) + (* 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) when erase -> + link_row_field_ext ~inside:f rf_absent; fi + | _ -> p :: fi + + (**************************************) + (* Check genericity of type schemes *) + (**************************************) + +type variable_kind = Row_variable | Type_variable +exception Non_closed of type_expr * variable_kind + +(* [free_vars] collects the variables of the input type expression. It + is used for several different things in the type-checker, with the + following bells and whistles: + - If [env] 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 [variable_kind] to distinguish them. + - 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). + + [free_vars] returns a [(variable * bool) list], while + [free_variables] below drops the type/row information + and only returns a [variable list]. + *) +let free_vars ?env ty = + let rec fv ~kind acc ty = + if not (try_mark_node ty) then acc + else match get_desc ty, env with + | Tvar _, _ -> + (ty, kind) :: acc + | Tconstr (path, tl, _), Some env -> + let acc = + match Env.find_type_expansion path env with + | exception Not_found -> acc + | (_, body, _) -> + if get_level body = generic_level then acc + else (ty, kind) :: acc + in + List.fold_left (fv ~kind:Type_variable) acc tl + | Tobject (ty, _), _ -> + (* ignoring the second parameter of [Tobject] amounts to not + counting "virtual free variables". *) + fv ~kind:Row_variable acc ty + | Tfield (_, _, ty1, ty2), _ -> + let acc = fv ~kind:Type_variable acc ty1 in + fv ~kind:Row_variable acc ty2 + | Tvariant row, _ -> + let acc = fold_row (fv ~kind:Type_variable) acc row in + if static_row row then acc + else fv ~kind:Row_variable acc (row_more row) + | _ -> + fold_type_expr (fv ~kind) acc ty + in fv ~kind:Type_variable [] ty + +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 = { + free_variable: type_expr * variable_kind; + meth: string; + meth_ty: type_expr; +} +exception CCFailure of closed_class_failure + +let closed_class params sign = + List.iter mark_type params; + ignore (try_mark_node sign.csig_self_row); + try + Meths.iter + (fun lab (priv, _, ty) -> + if priv = Mpublic then begin + try closed_type ty with Non_closed (ty0, variable_kind) -> + raise (CCFailure { + free_variable = (ty0, variable_kind); + meth = lab; + meth_ty = ty; + }) + end) + sign.csig_meths; + List.iter unmark_type params; + unmark_class_signature sign; + None + with CCFailure reason -> + 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 level = get_level ty in + if (level > !current_level) && (level <> generic_level) then begin + set_level ty generic_level; + (* recur into abbrev for the speed *) + begin match get_desc ty 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 level = get_level ty in + if level <> generic_level then begin + if is_Tvar ty && level > !current_level then + set_level ty !current_level + else if level > !current_level then begin + begin match get_desc ty with + Tconstr (_, _, abbrev) -> + abbrev := Mnil + | _ -> () + end; + 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 level = get_level ty in + if level < !current_level || level = generic_level then () else + match get_desc ty 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 (_, tyl, memo) -> + 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 orig_level = get_level ty in + if try_logged_mark_node ty then begin + if level < get_scope ty then + raise_scope_escape_exn ty; + begin match get_desc ty 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 + (newty2 ~level: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 = + if get_scope ty < scope then begin + if get_level ty < 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 = + if get_level ty > level then begin + if level < get_scope ty then raise_scope_escape_exn ty; + match get_desc ty with + Tconstr(p, _tl, _abbrev) when level < Path.scope p -> + (* Try first to replace an abbreviation by its expansion. *) + begin try + let ty' = !forward_try_expand_safe env ty in + link_type ty 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 && get_level ty > level) + variance tl + in + begin try + if not needs_expand then raise Cannot_expand; + let ty' = !forward_try_expand_safe env ty in + link_type ty 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 -> + begin match row_name row with + | Some (p, _tl) when level < Path.scope p -> + set_type_desc ty (Tvariant (set_row_name row None)) + | _ -> () + end; + set_level ty level; + iter_type_expr (update_level env level expand) ty + | Tfield(lab, _, ty1, _) + when lab = dummy_method && level < get_scope ty1 -> + 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 = + if get_level ty > 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 must_visit = + get_level ty > var_level && + match Hashtbl.find visited (get_id ty) with + | done_contra -> contra && not done_contra + | exception Not_found -> true + in + if must_visit then begin + Hashtbl.add visited (get_id ty) contra; + let lower_rec = lower_contravariant env var_level visited in + match get_desc ty 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_variables_only env level ty = + simple_abbrevs := Mnil; + lower_contravariant env level (Hashtbl.create 7) true ty + +let lower_contravariant env ty = + simple_abbrevs := Mnil; + lower_contravariant env !nongen_level (Hashtbl.create 7) false ty + +let rec generalize_class_type' gen = + function + Cty_constr (_, params, cty) -> + List.iter gen params; + generalize_class_type' gen cty + | Cty_signature csig -> + gen csig.csig_self; + gen csig.csig_self_row; + Vars.iter (fun _ (_, _, ty) -> gen ty) csig.csig_vars; + Meths.iter (fun _ (_, _, ty) -> gen ty) csig.csig_meths + | Cty_arrow (_, ty, cty) -> + gen ty; + generalize_class_type' gen cty + +let generalize_class_type cty = + generalize_class_type' generalize cty + +let generalize_class_type_structure cty = + generalize_class_type' generalize_structure cty + +(* 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 graph = Hashtbl.create 17 in + let idx = ref lowest_level in + let roots = ref [] in + + let rec inverse pty ty = + let level = get_level ty in + if (level > !current_level) || (level = generic_level) then begin + decr idx; + Hashtbl.add graph !idx (ty, ref pty); + if (level = generic_level) || eq_type ty ty0 then + roots := ty :: !roots; + set_level ty !idx; + iter_type_expr (inverse [ty]) ty + end else if level < lowest_level then begin + let (_, parents) = Hashtbl.find graph level in + parents := pty @ !parents + end + + and generalize_parents ty = + let idx = get_level ty 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 get_desc ty with + Tvariant row -> + let more = row_more row in + let lv = get_level more in + if (lv < lowest_level || lv > !current_level) + && lv <> generic_level then set_level more generic_level + | _ -> () + end + in + + inverse [] ty; + if get_level ty0 < lowest_level then + iter_type_expr (inverse []) ty0; + List.iter generalize_parents !roots; + Hashtbl.iter + (fun _ (ty, _) -> + if get_level ty <> generic_level then set_level ty !current_level) + graph + +let limited_generalize_class_type rv cty = + generalize_class_type' (limited_generalize rv) cty + +(* 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 = + 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 get_desc inv.inv_type with + Tpoly (_ty, tl) when List.memq (get_id univ) (List.map get_id 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 = + if not_marked_node ty then + if get_level ty = 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 result of copying a generic node is + "cached" in-place by temporarily mutating the node description by + a stub [Tsubst (newvar ())] using [For_copy.redirect_desc]. The + scope of this mutation is determined by the [copy_scope] parameter, + and the [For_copy.with_scope] helper is in charge of creating a new + scope and performing the necessary book-keeping -- in particular + reverting the in-place updates after the instantiation is done. *) + +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 copy_scope ty = + let copy = copy ?partial ?keep_names copy_scope in + match get_desc ty with + Tsubst (ty, _) -> ty + | desc -> + let level = get_level ty in + if 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 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 level else !current_level + else generic_level + in + if forget <> generic_level then newty2 ~level:forget (Tvar None) else + let t = newstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let desc' = + match desc with + | Tconstr (p, tl, _) -> + let abbrevs = proper_abbrevs tl !abbreviations in + begin match find_repr p !abbrevs with + Some ty when not (eq_type 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 row -> + let more = row_more row in + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + begin match mored with + Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + (* If the row variable is not generic, we must keep it *) + let keep = get_level more <> generic_level && partial = None in + let more' = + match mored with + Tsubst (ty, None) -> ty + (* TODO: is this case possible? + possibly an interaction with (copy more) below? *) + | Tconstr _ | Tnil -> + copy more + | Tvar _ | Tunivar _ -> + if keep then more else newty mored + | _ -> assert false + in + let row = + match get_desc more' with (* PR#6163 *) + Tconstr (x,_,_) when not (is_fixed row) -> + let Row {fields; more; closed; name} = row_repr row in + create_row ~fields ~more ~closed ~name + ~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 not_reither (_, f) = + match row_field_repr f with + Reither _ -> false + | _ -> true + in + let fields = row_fields row in + if row_closed row && not (is_fixed row) + && TypeSet.is_empty (free_univars ty) + && not (List.for_all not_reither fields) then + let more' = newvar () in + (more', + create_row ~fields:(List.filter not_reither fields) + ~more:more' ~closed:false ~fixed:None ~name:None) + else (more', row) + | _ -> (more', row) + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope more + (Tsubst(more', Some t)); + (* Return a new copy *) + Tvariant (copy_row copy true row keep more') + end + | Tobject (ty1, _) when partial <> None -> + Tobject (copy ty1, ref None) + | _ -> copy_type_desc ?keep_names copy desc + in + Transient_expr.set_stub_desc t desc'; + 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 copy_scope -> + copy ?partial copy_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 copy_scope -> + List.map (fun t -> copy copy_scope t) schl) + +(* Create unique names to new type constructors. + Used for existential types and local constraints. *) +let get_new_abstract_name env s = + (* unique names are needed only for error messages *) + if in_counterexample () then s else + let name index = + if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else + Printf.sprintf "%s%d" s index + in + let check index = + match Env.find_type_by_name (Longident.Lident (name index)) env with + | _ -> false + | exception Not_found -> true + in + let index = Misc.find_first_mono check in + name 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 get_desc ty with + | Tvar (Some name) -> "$" ^ cstr.cstr_name ^ "_'" ^ name + | _ -> "$" ^ cstr.cstr_name + +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of { env: Env.t ref; scope: int } + +let instance_constructor existential_treatment cstr = + For_copy.with_scope (fun copy_scope -> + let copy_existential = + match existential_treatment with + | Keep_existentials_flexible -> copy copy_scope + | Make_existentials_abstract {env; scope = fresh_constr_scope} -> + fun 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 !env 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 copy_scope existential in + assert (is_Tvar tv); + link_type tv to_unify; + tv + in + let ty_ex = List.map copy_existential cstr.cstr_existentials in + let ty_res = copy copy_scope cstr.cstr_res in + let ty_args = List.map (copy copy_scope) cstr.cstr_args in + (ty_args, ty_res, ty_ex) + ) + +let instance_parameterized_type ?keep_names sch_args sch = + For_copy.with_scope (fun copy_scope -> + let ty_args = List.map (fun t -> copy ?keep_names copy_scope t) sch_args in + let ty = copy copy_scope sch in + (ty_args, 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 copy_scope -> + {decl with type_params = List.map (copy copy_scope) decl.type_params; + type_manifest = Option.map (copy copy_scope) decl.type_manifest; + type_kind = map_kind (copy 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 copy_scope = function + | Cty_constr (path, tyl, cty) -> + let tyl' = List.map (copy copy_scope) tyl in + let cty' = copy_class_type copy_scope cty in + Cty_constr (path, tyl', cty') + | Cty_signature sign -> + Cty_signature + {csig_self = copy copy_scope sign.csig_self; + csig_self_row = copy copy_scope sign.csig_self_row; + csig_vars = + Vars.map + (function (m, v, ty) -> (m, v, copy copy_scope ty)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, ty) -> (p, v, copy copy_scope ty)) + sign.csig_meths} + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, copy copy_scope ty, copy_class_type copy_scope cty) + in + For_copy.with_scope (fun copy_scope -> + let params' = List.map (copy copy_scope) params in + let cty' = copy_class_type copy_scope cty in + (params', cty') + ) + +(**** Instantiation for types with free universal variables ****) + +(* [copy_sep] is used to instantiate first-class polymorphic types. + * It first makes a separate copy of the type as a graph, omitting nodes + that have no free univars. + * In this first pass, [visited] is used as a mapping for previously visited + nodes, and must already contain all the free univars in [ty]. + * The remaining (univar-closed) parts of the type are then instantiated + with [copy] using a common [copy_scope]. + The reason to work in two passes lies in recursive types such as: + [let h (x : < m : 'a. < n : 'a; p : 'b > > as 'b) = x#m] + The type of [x#m] should be: + [ < n : 'c; p : < m : 'a. < n : 'a; p : 'b > > as 'b > ] + I.e., the universal type variable ['a] is both instantiated as a fresh + type variable ['c] when outside of its binder, and kept as universal + when under its binder. + Assumption: in the first call to [copy_sep], all the free univars should + be bound by the same [Tpoly] node. This guarantees that they are only + bound when under this [Tpoly] node, which has no free univars, and as + such is not part of the separate copy. In turn, this allows the separate + copy to keep the sharing of the original type without breaking its + binding structure. + *) +let copy_sep ~copy_scope ~fixed ~(visited : type_expr TypeHash.t) sch = + let free = compute_univars sch in + let delayed_copies = ref [] in + let add_delayed_copy t ty = + delayed_copies := + lazy (Transient_expr.set_stub_desc t (Tlink (copy copy_scope ty))) :: + !delayed_copies + in + let rec copy_rec ~may_share (ty : type_expr) = + let univars = free ty in + if is_Tvar ty || may_share && TypeSet.is_empty univars then + if get_level ty <> generic_level then ty else + let t = newstub ~scope:(get_scope ty) in + add_delayed_copy t ty; + t + else try + TypeHash.find visited ty + with Not_found -> begin + let t = newstub ~scope:(get_scope ty) in + TypeHash.add visited ty t; + let desc' = + match get_desc ty with + | Tvariant row -> + let more = row_more row in + (* We shall really check the level on the row variable *) + let keep = is_Tvar more && get_level more <> generic_level in + (* In that case we should keep the original, but we still + call copy to correct the levels *) + if keep then (add_delayed_copy t ty; Tvar None) else + let more' = copy_rec ~may_share:false more in + let fixed' = fixed && (is_Tvar more || is_Tunivar more) in + let row = + copy_row (copy_rec ~may_share:true) fixed' row keep more' in + Tvariant row + | Tfield (p, k, ty1, ty2) -> + (* the kind is kept shared, see Btype.copy_type_desc *) + Tfield (p, field_kind_internal_repr k, + copy_rec ~may_share:true ty1, + copy_rec ~may_share:false ty2) + | desc -> copy_type_desc (copy_rec ~may_share:true) desc + in + Transient_expr.set_stub_desc t desc'; + t + end + in + let ty = copy_rec ~may_share:true sch in + List.iter Lazy.force !delayed_copies; + ty + +let instance_poly' copy_scope ~keep_names fixed univars sch = + (* In order to compute univars below, [sch] should not contain [Tsubst] *) + let copy_var ty = + match get_desc ty with + Tunivar name -> if keep_names then newty (Tvar name) else newvar () + | _ -> assert false + in + let vars = List.map copy_var univars in + let visited = TypeHash.create 17 in + List.iter2 (TypeHash.add visited) univars vars; + let ty = copy_sep ~copy_scope ~fixed ~visited sch in + vars, ty + +let instance_poly ?(keep_names=false) fixed univars sch = + For_copy.with_scope (fun copy_scope -> + instance_poly' copy_scope ~keep_names fixed univars sch + ) + +let instance_label fixed lbl = + For_copy.with_scope (fun copy_scope -> + let vars, ty_arg = + match get_desc lbl.lbl_arg with + Tpoly (ty, tl) -> + instance_poly' copy_scope ~keep_names:false fixed tl ty + | _ -> + [], copy copy_scope lbl.lbl_arg + in + (* call [copy] after [instance_poly] to avoid introducing [Tsubst] *) + let ty_res = copy copy_scope lbl.lbl_res in + (vars, ty_arg, ty_res) + ) + +(**** Instantiation with parameter substitution ****) + +(* NB: since this is [unify_var], it raises [Unify], not [Unify_trace] *) +let unify_var' = (* Forward declaration *) + ref (fun _env _ty1 _ty2 -> assert false) + +let subst env level priv abbrev oty 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 oty with + | None -> fun () -> () (* No abbreviation added *) + | Some ty -> + match get_desc ty with + Tconstr (path, tl, _) -> + let abbrev = proper_abbrevs 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; + let old_umode = !umode in + umode := Subst; + try + !unify_var' env body0 body'; + List.iter2 (!unify_var' env) params' args; + current_level := old_level; + umode := old_umode; + body' + with Unify _ -> + current_level := old_level; + umode := old_umode; + undo_abbrev (); + raise Cannot_subst + +(* + Default to generic level. Usually, 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 ?(use_current_level = false) env params body args = + let level = if use_current_level then !current_level else generic_level in + try + subst env 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 get_desc ty with + Tconstr (path, args, abbrev) -> + let level = get_level ty in + let scope = get_scope ty in + let lookup_abbrev = proper_abbrevs 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; + 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 (get_scope ty) 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 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 = + match get_desc ty with + Tconstr _ -> 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.t -> type_expr -> type_expr) 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 -> 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 -> 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 + *) + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + | Has_no_typedecl + | May_have_typedecl + +let rec extract_concrete_typedecl env ty = + match get_desc ty with + Tconstr (p, _, _) -> + begin match Env.find_type p env with + | exception Not_found -> May_have_typedecl + | decl -> + if decl.type_kind <> Type_abstract then Typedecl(p, p, decl) + else begin + match try_expand_safe env ty with + | exception Cannot_expand -> May_have_typedecl + | ty -> + match extract_concrete_typedecl env ty with + | Typedecl(_, p', decl) -> Typedecl(p, p', decl) + | Has_no_typedecl -> Has_no_typedecl + | May_have_typedecl -> May_have_typedecl + end + end + | Tpoly(ty, _) -> extract_concrete_typedecl env ty + | Tarrow _ | Ttuple _ | Tobject _ | Tfield _ | Tnil + | Tvariant _ | Tpackage _ -> Has_no_typedecl + | Tvar _ | Tunivar _ -> May_have_typedecl + | Tlink _ | Tsubst _ -> assert false + +(* 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 = + match get_desc ty with + Tconstr _ -> 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 -> 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 + try expand_head_unif env ty with Unify_trace _ -> + (* #10277: forget scopes when printing trace *) + with_level ~level:(get_level ty) begin fun () -> + (* 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 -> ty + end + else expand_head env ty + in + match get_desc ty with + Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar v -> + newty2 ~level:(get_level ty) (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 + get_level body = 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} -> + get_level body = 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 ty = + if eq_type ty ty0 then raise Occur; + match get_desc ty 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 = allow_recursive_equations () in + let old = !type_changed in + try + while + type_changed := false; + if not (eq_type ty0 ty) then + 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;*) + if not (List.memq (get_id ty) visited) then begin + match get_desc ty 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 = get_id 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 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 = get_id 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 = allow_recursive_equations () 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',_) -> eq_type t 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 eq_type t2 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 = + 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 get_desc ty with + Tunivar _ -> + if not (TypeSet.mem ty bound) then + raise_escape_exn (Univ ty) + | Tpoly (ty, tyl) -> + let bound = List.fold_right TypeSet.add 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 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 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 = + if TypeSet.mem t !visited then () else begin + visited := TypeSet.add t !visited; + match get_desc t with + Tpoly (t, tl) -> + if List.exists (fun t -> TypeSet.mem 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 + 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 copy_scope ty = + match get_desc ty with + | Tvar name when get_level ty = generic_level -> + let t = newty (Tunivar name) in + For_copy.redirect_desc copy_scope 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 copy_scope -> + let vars' = List.filter_map (subst_univar copy_scope) vars in + let ty = copy copy_scope ty in + let ty = newty2 ~level:(get_level ty) (Tpoly(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 ? *) +(* That's hard to do because it relies on the expansion machinery in Ctype, + but still might be nice. *) + +let expand_type env ty = + { ty = ty; + expanded = full_expand ~may_forget_scope:true env ty } + +let expand_any_trace map env trace = + map (expand_type env) 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 + +let expand_to_unification_error env trace = + unification_error ~trace:(expand_trace env trace) + +let expand_to_equality_error env trace subst = + equality_error ~trace:(expand_trace env trace) ~subst + +let expand_to_moregen_error env trace = + moregen_error ~trace:(expand_trace env trace) + +(* [expand_trace] and the [expand_to_*_error] functions take care of most of the + expansion in this file, but we occasionally need to build [Errortrace.error]s + in other ways/elsewhere, so we expose some machinery for doing so +*) + +(* Equivalent to [expand_trace env [Diff {got; expected}]] for a single + element *) +let expanded_diff env ~got ~expected = + Diff (map_diff (expand_type env) {got; expected}) + +(* Diff while transforming a [type_expr] into an [expanded_type] without + expanding *) +let unexpanded_diff ~got ~expected = + Diff (map_diff trivial_expansion {got; expected}) + +(**** Unification ****) + +(* Return whether [t0] occurs in [ty]. Objects are also traversed. *) +let deep_occur t0 ty = + let rec occur_rec ty = + if get_level ty >= get_level t0 && try_mark_node ty then begin + if eq_type 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 !env name) decl !env + ~scope:fresh_constr_scope in + let path = Path.Pident id in + let t = newty2 ~level:lev (Tconstr (path,[],ref Mnil)) in + env := new_env; + path, t + in + let visited = ref TypeSet.empty in + let rec iterator ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty with + Tvar o -> + let level = get_level ty in + let path, t = create_fresh_constr level o in + link_type ty t; + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) + | Tvariant r -> + if not (static_row r) then begin + if is_fixed r then iterator (row_more r) else + let m = row_more r in + match get_desc m with + Tvar o -> + let level = get_level m in + let path, t = create_fresh_constr level o in + let row = + let fixed = Some (Reified path) in + create_row ~fields:[] ~more:t ~fixed + ~name:(row_name r) ~closed:(row_closed r) in + link_type m (newty2 ~level (Tvariant row)); + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) + | _ -> assert false + end; + iter_row iterator r + | _ -> + iter_type_expr iterator ty + end + in + iterator t + +let find_expansion_scope env path = + match Env.find_type path env with + | { type_manifest = None ; _ } | exception Not_found -> generic_level + | decl -> decl.type_expansion_scope + +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 + + +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 = + match get_desc ty 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 eq_type t1 t2 then () else + match (get_desc t1, get_desc t2) 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... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') 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_unexplained_for Unify + | (_, Tconstr (_, [], _)) when has_injective_univars env t1' -> + raise_unexplained_for 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 = Fpublic) in + mcomp type_pairs env rest1 rest2; + if has_present miss1 && get_desc (object_row ty2) = Tnil + || has_present miss2 && get_desc (object_row ty1) = 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 + (Fpublic, Fabsent) + | (Fabsent, Fpublic) -> raise Incompatible + | _ -> () + +and mcomp_row type_pairs env row1 row2 = + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + let cannot_erase (_,f) = + match row_field_repr f with + Rpresent _ -> true + | Rabsent | Reither _ -> false + in + if row_closed row1 && List.exists cannot_erase r2 + || row_closed row2 && 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 = + if not_marked_node ty then begin + let level = get_level ty in + if level < !lowest then lowest := level; + flip_mark_node ty; + iter_type_expr find ty + end + in find ty; unmark_type ty; !lowest + +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 get_id t1 <= get_id t2 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 = + eq_type t1 t2 + || (in_pattern_mode () + && TypePairs.mem unify_eq_set (order_type_pair t1 t2)) + +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 (get_level t1) t2; + update_scope (get_scope t1) t2; + with Escape e -> + raise_for Unify (Escape e) + end; + link_type t1 t2; + true + | exception Unify_trace _ when in_pattern_mode () -> + false + +(* 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_trace _ when in_pattern_mode () -> + 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 = ]). 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 unify_eq t1 t2 then () else + let reset_tracing = check_trace_gadt_instances !env in + + try + type_changed := true; + begin match (get_desc t1, get_desc t2) 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 (get_level t1) t2; + update_scope_for Unify (get_scope t1) 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 (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + | (Tconstr _, Tconstr _) when Env.has_local_constraints !env -> + unify2_rec env t1 t1 t2 t2 + | _ -> + unify2 env t1 t2 + end; + reset_trace_gadt_instances reset_tracing; + with Unify_trace trace -> + reset_trace_gadt_instances reset_tracing; + raise_trace_for Unify (Diff {got = t1; expected = t2} :: trace) + +and unify2 env t1 t2 = unify2_expand env t1 t1 t2 t2 + +and unify2_rec env t10 t1 t20 t2 = + if unify_eq t1 t2 then () else + try match (get_desc t1, get_desc t2) with + | (Tconstr (p1, tl1, a1), Tconstr (p2, tl2, a2)) -> + if Path.same p1 p2 && tl1 = [] && tl2 = [] + && not (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) + then begin + update_level_for Unify !env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + end else + if find_expansion_scope !env p1 > find_expansion_scope !env p2 + then unify2_rec env t10 t1 t20 (try_expand_safe !env t2) + else unify2_rec env t10 (try_expand_safe !env t1) t20 t2 + | _ -> + raise Cannot_expand + with Cannot_expand -> + unify2_expand env t10 t1 t20 t2 + +and unify2_expand env t1 t1' t2 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 (get_level t1') (get_level t2') in + let scope = Int.max (get_scope t1') (get_scope t2') 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, 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 get_desc t1 with Tconstr (_, [], _) -> t1' | _ -> t1), + (match get_desc t2 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 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 tt1' = Transient_expr.repr t1' in + let d1 = tt1'.desc and d2 = get_desc t2' in + let create_recursion = + (not (eq_type 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' + | _ -> + if in_pattern_mode () then + add_type_equality t1' t2' + else begin + occur_for Unify !env t1' t2; + link_type t1' t2 + end; + try + begin match (d1, d2) with + (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 || + (!Clflags.classic || in_pattern_mode ()) && + not (is_optional l1 || is_optional l2) -> + unify env t1 t2; unify env u1 u2; + begin match is_commu_ok c1, is_commu_ok c2 with + | false, true -> set_commu_ok c1 + | true, false -> set_commu_ok c2 + | false, false -> link_commu ~inside:c1 c2 + | true, true -> () + end + | (Ttuple tl1, Ttuple tl2) -> + unify_list env tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> + if not (can_generate_equations ()) then + unify_list env tl1 tl2 + else if can_assume_injective () then + without_assume_injective (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 + without_generating_equations + begin fun () -> + let snap = snapshot () in + try unify env t1 t2 with Unify_trace _ -> + 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 in_pattern_mode () -> + 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 get_desc t2' with + Tobject (_, {contents = Some (_, va::_)}) when + (match get_desc va with + Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () + | Tobject (_, nm2) -> set_name nm2 !nm1 + | _ -> () + end + | (Tvariant row1, Tvariant row2) -> + if not (in_pattern_mode ()) then + unify_row env row1 row2 + else begin + let snap = snapshot () in + try unify_row env row1 row2 + with Unify_trace _ -> + 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 + Fprivate when f <> dummy_method -> + link_kind ~inside:kind field_absent; + if d2 = Tnil then unify env rem t2' + else unify env (newgenty 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) + (get_level t1) p1 fl1 (get_level t2) p2 fl2 + with Not_found -> + if not (in_pattern_mode ()) 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_for Unify (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> + raise_for Unify (Obj (Abstract_row First)) + | (_, _) -> raise_unexplained_for Unify + end; + (* XXX Commentaires + changer "create_recursion" + ||| Comments + change "create_recursion" *) + if create_recursion then + match get_desc t2 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 t2 t2' + | _ -> + () (* t2 has already been expanded by update_level *) + with Unify_trace trace -> + Transient_expr.set_desc tt1' 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 get_desc ty with + Tvar None -> set_type_desc ty (Tvar name) + | _ -> () + in + let name = + match get_desc rest1, get_desc rest2 with + Tvar (Some _ as name1), Tvar (Some _ as name2) -> + if get_level rest1 <= get_level rest2 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 newty2 ~level (Tvar name) + +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 = get_level ty1 and l2 = get_level ty2 in + let va = make_rowvar (Int.min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in + let tr1 = Transient_expr.repr rest1 and tr2 = Transient_expr.repr rest2 in + let d1 = tr1.desc and d2 = tr2.desc in + try + unify env (build_fields l1 miss1 va) rest2; + unify env rest1 (build_fields l2 miss2 va); + List.iter + (fun (name, k1, t1, k2, t2) -> + unify_kind k1 k2; + try + if !trace_gadt_instances && not (in_subst_mode ()) then begin + (* in_subst_mode: see PR#11771 *) + update_level_for Unify !env (get_level va) t1; + update_scope_for Unify (get_scope va) t1 + end; + unify env t1 t2 + with Unify_trace trace -> + raise_trace_for Unify + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) + ) + pairs + with exn -> + Transient_expr.set_desc tr1 d1; + Transient_expr.set_desc tr2 d2; + raise exn + +and unify_kind k1 k2 = + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fprivate) -> link_kind ~inside:k2 k1 + | (Fpublic, Fpublic) -> () + | _ -> assert false + +and unify_row env row1 row2 = + let Row {fields = row1_fields; more = rm1; + closed = row1_closed; name = row1_name} = row_repr row1 in + let Row {fields = row2_fields; more = rm2; + closed = row2_closed; name = row2_name} = row_repr row2 in + if unify_eq rm1 rm2 then () else + let r1, r2, pairs = merge_row_fields row1_fields row2_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 get_level rm2 < get_level rm1 then rm2 else rm1 + | Some _, None -> rm1 + | None, Some _ -> rm2 + | None, None -> + newty2 ~level:(Int.min (get_level rm1) (get_level rm2)) (Tvar None) + in + let fixed = merge_fixed_explanation fixed1 fixed2 + and closed = row1_closed || row2_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_closed) && (empty r2 || row1_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_name <> None && (row1_closed || empty r2) && + (not row2_closed || keep (fun f1 f2 -> f1, f2) && empty r1) + then row1_name + else if row2_name <> None && (row2_closed || empty r1) && + (not row1_closed || keep (fun f1 f2 -> f2, f1) && empty r2) + then row2_name + else None + in + let set_more pos row rest = + let rest = + if closed then + filter_row_fields (row_closed row) rest + else rest in + begin match fixed_explanation row with + | None -> + if rest <> [] && row_closed row then + raise_for Unify (Variant (No_tags(pos,rest))) + | Some fixed -> + if closed && not (row_closed row) 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 && not (in_subst_mode ()) then + (* in_subst_mode: see PR#11771 *) + update_level_for Unify !env (get_level rm) (newgenty (Tvariant row)); + if has_fixed_explanation row then + if eq_type more rm then () else + if is_Tvar rm then link_type rm more else unify env rm more + else + let ty = + newgenty (Tvariant + (create_row ~fields:rest ~more ~closed ~fixed ~name)) + in + update_level_for Unify !env (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty; + link_type rm ty + in + let tm1 = Transient_expr.repr rm1 and tm2 = Transient_expr.repr rm2 in + let md1 = tm1.desc and md2 = tm2.desc in + begin try + set_more Second row2 r1; + set_more First row1 r2; + List.iter + (fun (l,f1,f2) -> + try unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 + with Unify_trace 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 ~level:(get_level rm) Tnil) + end + with exn -> + Transient_expr.set_desc tm1 md1; + Transient_expr.set_desc tm2 md2; + raise exn + end + +and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = + 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 row_field_repr f1, row_field_repr f2 with + Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 + | Rpresent None, Rpresent None -> () + | Reither(c1, tl1, m1), Reither(c2, tl2, m2) -> + if eq_row_field_ext f1 f2 then () else + let no_arg = c1 || c2 and matched = m1 || m2 in + if either_fixed && not no_arg + && List.length tl1 = List.length tl2 then begin + (* PR#7496 *) + let f = rf_either [] ~no_arg ~matched in + link_row_field_ext ~inside:f1 f; link_row_field_ext ~inside:f2 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 no_arg then raise_unexplained_for Unify; + Types.changed_row_field_exts [f1;f2] (fun () -> + List.iter (unify env t1) tl + ) + end in + if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else + let remq tl = + List.filter (fun ty -> not (List.exists (eq_type ty) 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? *) + let update_levels rm = + List.iter + (fun ty -> + update_level_for Unify !env (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty) + in + update_levels rm2 tl1'; + update_levels rm1 tl2'; + let f1' = rf_either tl2' ~no_arg ~matched in + let f2' = rf_either tl1' ~use_ext_of:f1' ~no_arg ~matched in + link_row_field_ext ~inside:f1 f1'; link_row_field_ext ~inside:f2 f2'; + | Reither(_, _, false), Rabsent -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rabsent, Reither(_, _, false) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | Rabsent, Rabsent -> () + | Reither(false, tl, _), Rpresent(Some t2) -> + if_not_fixed first (fun () -> + let s = snapshot () in + link_row_field_ext ~inside:f1 f2; + update_level_for Unify !env (get_level rm1) t2; + update_scope_for Unify (get_scope rm1) t2; + (try List.iter (fun t1 -> unify env t1 t2) tl + with exn -> undo_first_change_after s; raise exn) + ) + | Rpresent(Some t1), Reither(false, tl, _) -> + if_not_fixed second (fun () -> + let s = snapshot () in + link_row_field_ext ~inside:f2 f1; + update_level_for Unify !env (get_level rm2) t1; + update_scope_for Unify (get_scope rm2) t1; + (try List.iter (unify env t1) tl + with exn -> undo_first_change_after s; raise exn) + ) + | Reither(true, [], _), Rpresent None -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rpresent None, Reither(true, [], _) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | _ -> raise_unexplained_for Unify + +let unify env ty1 ty2 = + let snap = Btype.snapshot () in + try + unify env ty1 ty2 + with + Unify_trace trace -> + undo_compress snap; + raise (Unify (expand_to_unification_error !env trace)) + +let unify_gadt ~equations_level:lev ~allow_recursive_equations + (env:Env.t ref) ty1 ty2 = + try + univar_pairs := []; + gadt_equations_level := Some lev; + let equated_types = TypePairs.create 0 in + set_mode_pattern ~allow_recursive_equations ~equated_types + (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 = + if eq_type t1 t2 then () else + match get_desc t1, get_desc t2 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 (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2; + reset_trace_gadt_instances reset_tracing; + with Unify_trace trace -> + reset_trace_gadt_instances reset_tracing; + raise (Unify (expand_to_unification_error + env + (Diff { got = t1; expected = t2 } :: trace))) + end + | _ -> + unify (ref env) t1 t2 + +let _ = unify_var' := 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 [] + +(* Lower the level of a type to the current level *) +let enforce_current_level env ty = unify_var env (newvar ()) ty + + +(**** 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 +*) + +type filter_arrow_failure = + | Unification_error of unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +let filter_arrow env t l = + let function_type level = + let t1 = newvar2 level and t2 = newvar2 level in + let t' = newty2 ~level (Tarrow (l, t1, t2, commu_ok)) in + t', t1, t2 + in + let t = + try expand_head_trace env t + with Unify_trace trace -> + let t', _, _ = function_type (get_level t) in + raise (Filter_arrow_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = t'; expected = t } :: trace)))) + in + match get_desc t with + | Tvar _ -> + let t', t1, t2 = function_type (get_level t) in + link_type t t'; + (t1, t2) + | Tarrow(l', t1, t2, _) -> + if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') + then (t1, t2) + else raise (Filter_arrow_failed + (Label_mismatch + { got = l; expected = l'; expected_type = t })) + | _ -> + raise (Filter_arrow_failed Not_a_function) + +type filter_method_failure = + | Unification_error of unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + +(* Used by [filter_method]. *) +let rec filter_method_field env name ty = + let method_type ~level = + let ty1 = newvar2 level and ty2 = newvar2 level in + let ty' = newty2 ~level (Tfield (name, field_public, ty1, ty2)) in + ty', ty1 + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let ty', _ = method_type ~level in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let ty', ty1 = method_type ~level in + link_type ty ty'; + ty1 + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + unify_kind kind field_public; + ty1 + end else + filter_method_field env name ty2 + | _ -> + raise (Filter_method_failed Not_a_method) + +(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) +let filter_method env name ty = + let object_type ~level ~scope = + let ty1 = newvar2 level in + let ty' = newty3 ~level ~scope (Tobject (ty1, ref None)) in + let ty_meth = filter_method_field env name ty1 in + (ty', ty_meth) + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let scope = get_scope ty in + let ty', _ = object_type ~level ~scope in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let scope = get_scope ty in + let ty', ty_meth = object_type ~level ~scope in + link_type ty ty'; + ty_meth + | Tobject(f, _) -> + filter_method_field env name f + | _ -> + raise (Filter_method_failed (Not_an_object ty)) + +exception Filter_method_row_failed + +let rec filter_method_row env name priv ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let field = newvar2 level in + let row = newvar2 level in + let kind, priv = + match priv with + | Private -> + let kind = field_private () in + kind, Mprivate kind + | Public -> + field_public, Mpublic + in + let ty' = newty2 ~level (Tfield (name, kind, field, row)) in + link_type ty ty'; + priv, field, row + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + let priv = + match priv with + | Public -> + unify_kind kind field_public; + Mpublic + | Private -> Mprivate kind + in + priv, ty1, ty2 + end else begin + let level = get_level ty in + let priv, field, row = filter_method_row env name priv ty2 in + let row = newty2 ~level (Tfield (n, kind, ty1, row)) in + priv, field, row + end + | Tnil -> + if name = Btype.dummy_method then raise Filter_method_row_failed + else begin + match priv with + | Public -> raise Filter_method_row_failed + | Private -> + let level = get_level ty in + let kind = field_absent in + Mprivate kind, newvar2 level, ty + end + | _ -> + raise Filter_method_row_failed + +(* Operations on class signatures *) + +let new_class_signature () = + let row = newvar () in + let self = newobj row in + { csig_self = self; + csig_self_row = row; + csig_vars = Vars.empty; + csig_meths = Meths.empty; } + +let add_dummy_method env ~scope sign = + let _, ty, row = + filter_method_row env dummy_method Private sign.csig_self_row + in + unify env ty (new_scoped_ty scope (Ttuple [])); + sign.csig_self_row <- row + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +let add_method env label priv virt ty sign = + let meths = sign.csig_meths in + let priv, virt = + match Meths.find label meths with + | (priv', virt', ty') -> begin + let priv = + match priv' with + | Mpublic -> Mpublic + | Mprivate k -> + match priv with + | Public -> + begin match field_kind_repr k with + | Fpublic -> () + | Fprivate -> link_kind ~inside:k field_public + | Fabsent -> assert false + end; + Mpublic + | Private -> priv' + in + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + match unify env ty ty' with + | () -> priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + | exception Not_found -> begin + let priv, ty', row = + match filter_method_row env label priv sign.csig_self_row with + | priv, ty', row -> + priv, ty', row + | exception Filter_method_row_failed -> + raise (Add_method_failed Unexpected_method) + in + match unify env ty ty' with + | () -> + sign.csig_self_row <- row; + priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + in + let meths = Meths.add label (priv, virt, ty) meths in + sign.csig_meths <- meths + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +let check_mutability mut mut' = + match mut, mut' with + | Mutable, Mutable -> () + | Immutable, Immutable -> () + | Mutable, Immutable | Immutable, Mutable -> + raise (Add_instance_variable_failed (Mutability_mismatch mut)) + +let add_instance_variable ~strict env label mut virt ty sign = + let vars = sign.csig_vars in + let virt = + match Vars.find label vars with + | (mut', virt', ty') -> + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + if strict then begin + check_mutability mut mut'; + match unify env ty ty' with + | () -> () + | exception Unify trace -> + raise (Add_instance_variable_failed (Type_mismatch trace)) + end; + virt + | exception Not_found -> virt + in + let vars = Vars.add label (mut, virt, ty) vars in + sign.csig_vars <- vars + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +let unify_self_types env sign1 sign2 = + let self_type1 = sign1.csig_self in + let self_type2 = sign2.csig_self in + match unify env self_type1 self_type2 with + | () -> () + | exception Unify err -> begin + match err.trace with + | Errortrace.Diff _ :: Errortrace.Incompatible_fields {name; _} :: rem -> + let err = Errortrace.unification_error ~trace:rem in + let failure = Method (name, Type_mismatch err) in + raise (Inherit_class_signature_failed failure) + | _ -> + raise (Inherit_class_signature_failed (Self_type_mismatch err)) + end + +(* Unify components of sign2 into sign1 *) +let inherit_class_signature ~strict env sign1 sign2 = + unify_self_types env sign1 sign2; + Meths.iter + (fun label (priv, virt, ty) -> + let priv = + match priv with + | Mpublic -> Public + | Mprivate kind -> + assert (field_kind_repr kind = Fabsent); + Private + in + match add_method env label priv virt ty sign1 with + | () -> () + | exception Add_method_failed failure -> + let failure = Method(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_meths; + Vars.iter + (fun label (mut, virt, ty) -> + match add_instance_variable ~strict env label mut virt ty sign1 with + | () -> () + | exception Add_instance_variable_failed failure -> + let failure = Instance_variable(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_vars + +let update_class_signature env sign = + let self = expand_head env sign.Types.csig_self in + let fields, row = flatten_fields (object_fields self) in + let meths, implicitly_public, implicitly_declared = + List.fold_left + (fun (meths, implicitly_public, implicitly_declared) (lab, k, ty) -> + if lab = dummy_method then + meths, implicitly_public, implicitly_declared + else begin + match Meths.find lab meths with + | priv, virt, ty' -> + let meths, implicitly_public = + match priv, field_kind_repr k with + | Mpublic, _ -> meths, implicitly_public + | Mprivate _, Fpublic -> + let meths = Meths.add lab (Mpublic, virt, ty') meths in + let implicitly_public = lab :: implicitly_public in + meths, implicitly_public + | Mprivate _, _ -> meths, implicitly_public + in + meths, implicitly_public, implicitly_declared + | exception Not_found -> + let meths, implicitly_declared = + match field_kind_repr k with + | Fpublic -> + let meths = Meths.add lab (Mpublic, Virtual, ty) meths in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fprivate -> + let meths = + Meths.add lab (Mprivate k, Virtual, ty) meths + in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fabsent -> meths, implicitly_declared + in + meths, implicitly_public, implicitly_declared + end) + (sign.csig_meths, [], []) fields + in + sign.csig_meths <- meths; + sign.csig_self_row <- row; + implicitly_public, implicitly_declared + +let hide_private_methods env sign = + let self = expand_head env sign.Types.csig_self in + let fields, _ = flatten_fields (object_fields self) in + List.iter + (fun (_, k, _) -> + match field_kind_repr k with + | Fprivate -> link_kind ~inside:k field_absent + | _ -> ()) + fields + +let close_class_signature env sign = + let rec close env ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + link_type ty (newty2 ~level Tnil); true + | Tfield(lab, _, _, _) when lab = dummy_method -> + false + | Tfield(_, _, _, ty') -> close env ty' + | Tnil -> true + | _ -> assert false + in + let self = expand_head env sign.csig_self in + close env (object_fields self) + +let generalize_class_signature_spine env sign = + (* Generalize the spine of methods *) + let meths = sign.csig_meths in + Meths.iter (fun _ (_, _, ty) -> generalize_spine ty) meths; + let new_meths = + Meths.map + (fun (priv, virt, ty) -> (priv, virt, generic_instance ty)) + meths + in + (* But keep levels correct on the type of self *) + Meths.iter + (fun _ (_, _, ty) -> unify_var env (newvar ()) ty) + meths; + sign.csig_meths <- new_meths + + (***********************************) + (* 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 lv = get_level ty in + if lv <= level then () else + if is_Tvar ty && lv >= 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 = + let level = get_level t1 in + if inst_nongen then level <> generic_level - 1 + else level = generic_level + +let rec moregen inst_nongen type_pairs env t1 t2 = + if eq_type t1 t2 then () else + + try + match (get_desc t1, get_desc t2) with + (Tvar _, _) when may_instantiate inst_nongen t1 -> + moregen_occur env (get_level t1) t2; + update_scope_for Moregen (get_scope t1) 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... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, _) when may_instantiate inst_nongen t1' -> + moregen_occur env (get_level t1') t2; + update_scope_for Moregen (get_scope t1') 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) + (get_level t1') p1 fl1 (get_level t2') 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 trace -> + raise_trace_for Moregen (Diff {got = t1; expected = 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 (get_level ty2) miss2 rest2); + List.iter + (fun (name, 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 trace -> + raise_trace_for Moregen + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) + ) + pairs + +and moregen_kind k1 k2 = + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fpublic) -> () + | (Fpublic, Fprivate) -> raise Public_method_to_private_method + | (Fabsent, _) | (_, Fabsent) -> assert false + +and moregen_row inst_nongen type_pairs env row1 row2 = + let Row {fields = row1_fields; more = rm1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = rm2; closed = row2_closed; + fixed = row2_fixed} = row_repr row2 in + if eq_type rm1 rm2 then () else + let may_inst = + is_Tvar rm1 && may_instantiate inst_nongen rm1 || get_desc rm1 = Tnil in + let r1, r2, pairs = merge_row_fields row1_fields row2_fields in + let r1, r2 = + if row2_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_closed then begin + match row2_closed, r2 with + | false, _ -> raise_for Moregen (Variant (Openness Second)) + | _, _ :: _ -> raise_for Moregen (Variant (No_tags (First, r2))) + | _, [] -> () + end; + let md1 = get_desc rm1 (* This lets us undo a following [link_type] *) in + begin match md1, get_desc rm2 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 + (create_row ~fields:r2 ~more:rm2 ~name:None + ~fixed:row2_fixed ~closed:row2_closed)) + in + moregen_occur env (get_level rm1) ext; + update_scope_for Moregen (get_scope rm1) ext; + (* This [link_type] has to be undone if the rest of the function fails *) + link_type rm1 ext + | Tconstr _, Tconstr _ -> + moregen inst_nongen type_pairs env rm1 rm2 + | _ -> raise_unexplained_for Moregen + end; + try + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + moregen inst_nongen type_pairs env t1 t2 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both [Reither] *) + | Reither(c1, tl1, _), Reither(c2, tl2, m2) -> begin + try + if not (eq_row_field_ext f1 f2) then begin + if c1 && not c2 then raise_unexplained_for Moregen; + let f2' = + rf_either [] ~use_ext_of:f2 ~no_arg:c2 ~matched:m2 in + link_row_field_ext ~inside:f1 f2'; + 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 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + (* Generalizing [Reither] *) + | Reither(false, tl1, _), Rpresent(Some t2) when may_inst -> begin + try + link_row_field_ext ~inside:f1 f2; + List.iter + (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Reither(true, [], _), Rpresent None when may_inst -> + link_row_field_ext ~inside:f1 f2 + | Reither(_, _, _), Rabsent when may_inst -> + link_row_field_ext ~inside:f1 f2 + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) -> + raise_for Moregen (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Moregen (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Moregen (Variant (No_tags (Second, [l, f1])))) + pairs + with exn -> + (* Undo [link_type] if we failed *) + set_type_desc rm1 md1; raise exn + +(* 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_inst = instance subj_sch in + let subj = duplicate_type subj_inst in + current_level := generic_level; + (* Duplicate generic variables *) + let patt = instance pat_sch in + + Misc.try_finally + (fun () -> + try + moregen inst_nongen (TypePairs.create 13) env patt subj + with Moregen_trace trace -> + (* Moregen splits the generic level into two finer levels: + [generic_level] and [generic_level - 1]. In order to properly + detect and print weak variables when printing this error, we need to + merge them back together, by regeneralizing the levels of the types + after they were instantiated at [generic_level - 1] above. Because + [moregen] does some unification that we need to preserve for more + legible error messages, we have to manually perform the + regeneralization rather than backtracking. *) + current_level := generic_level - 2; + generalize subj_inst; + raise (Moregen (expand_to_moregen_error env trace))) + ~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 = + if try_mark_node ty then + begin match get_desc ty with + | Tvar _ -> + if not (TypeSet.mem ty !vars) then vars := TypeSet.add ty !vars + | Tvariant row -> + let Row {more; name; closed} = row_repr row in + if is_Tvar more && not (has_fixed_explanation row) then begin + let more' = newty2 ~level:(get_level more) (get_desc more) in + let row' = + create_row ~fixed:(Some Rigid) ~fields:[] ~more:more' + ~name ~closed + in link_type more (newty2 ~level:(get_level ty) (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 TypeSet.empty in + rigidify_rec vars ty; + unmark_type ty; + TypeSet.elements !vars + +let all_distinct_vars env vars = + let tys = ref TypeSet.empty in + List.for_all + (fun ty -> + let ty = expand_head env ty in + if TypeSet.mem ty !tys then false else + (tys := TypeSet.add ty !tys; is_Tvar ty)) + vars + +let matches ~expand_error_trace 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; + let diff = + if expand_error_trace + then expanded_diff env ~got:ty ~expected:ty' + else unexpanded_diff ~got:ty ~expected:ty' + in + raise (Matches_failure (env, unification_error ~trace:[diff])) + end; + backtrack snap + | exception Unify err -> + backtrack snap; + raise (Matches_failure (env, err)) + +let does_match env ty ty' = + match matches ~expand_error_trace:false 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 eqtype_subst type_pairs subst t1 t2 = + if List.exists + (fun (t,t') -> + let found1 = eq_type t1 t in + let found2 = eq_type t2 t' in + if found1 && found2 then true else + if found1 || found2 then raise_unexplained_for Equality else false) + !subst + then () + else begin + subst := (t1, t2) :: !subst; + TypePairs.add type_pairs (t1, t2) + end + +let rec eqtype rename type_pairs subst env t1 t2 = + if eq_type t1 t2 then () else + + try + match (get_desc t1, get_desc t2) with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1 t2 + | (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... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1' t2' + | (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) + (get_level t1') p1 fl1 (get_level t2') 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 trace -> + raise_trace_for Equality (Diff {got = t1; expected = 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 = + eq_type rest1 rest2 || TypePairs.mem type_pairs (rest1,rest2) + in + if same_row then () else + (* Try expansion, needed when called from Includecore.type_manifest *) + match get_desc (expand_head_rigid env rest2) with + 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 (name, k1, t1, k2, t2) -> + eqtype_kind k1 k2; + try + eqtype rename type_pairs subst env t1 t2; + with Equality_trace trace -> + raise_trace_for Equality + (incompatible_fields ~name ~got:t1 ~expected: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 + | (Fprivate, Fprivate) + | (Fpublic, Fpublic) -> () + | _ -> raise_unexplained_for Unify + (* It's probably not possible to hit this case with + real OCaml code *) + +and eqtype_row rename type_pairs subst env row1 row2 = + (* Try expansion, needed when called from Includecore.type_manifest *) + match get_desc (expand_head_rigid env (row_more row2)) with + Tvariant row2 -> eqtype_row rename type_pairs subst env row1 row2 + | _ -> + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + if row_closed row1 <> row_closed row2 then begin + raise_for Equality + (Variant (Openness (if row_closed row2 then First else Second))) + end; + if not (row_closed row1) 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 (row_more row1) (row_more row2); + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + eqtype rename type_pairs subst env t1 t2 + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both matching [Reither]s *) + | Reither(c1, [], _), Reither(c2, [], _) when c1 = c2 -> () + | Reither(c1, t1::tl1, _), Reither(c2, t2::tl2, _) + when c1 = c2 -> begin + try + 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 + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) + | Reither _, Reither _ -> + raise_for Equality (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Equality (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Equality (Variant (No_tags (Second, [l, f1])))) + 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 = + let subst = ref [] in + try eqtype_list rename (TypePairs.create 11) subst env tyl1 tyl2 + with Equality_trace trace -> + raise (Equality (expand_to_equality_error env trace !subst)) + +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 = + CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of Env.t * equality_error + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of Env.t * moregen_error + | CM_Val_type_mismatch of string * Env.t * comparison_error + | CM_Meth_type_mismatch of string * Env.t * comparison_error + | 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 match_class_sig_shape ~strict sign1 sign2 = + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> CM_Missing_method lab::err + | (priv', vr', _) -> + match priv', priv with + | Mpublic, Mprivate _ -> CM_Public_method lab::err + | Mprivate _, Mpublic when strict -> CM_Private_method lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Virtual_method lab::err + | _, _ -> err) + sign2.csig_meths [] + in + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + if Meths.mem lab sign2.csig_meths then err + else begin + let err = + match priv with + | Mpublic -> CM_Hide_public lab :: err + | Mprivate _ -> err + in + match vr with + | Virtual -> CM_Hide_virtual ("method", lab) :: err + | Concrete -> err + end) + sign1.csig_meths errors + in + let errors = + Vars.fold + (fun lab (mut, vr, _) err -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> CM_Missing_value lab::err + | (mut', vr', _) -> + match mut', mut with + | Immutable, Mutable -> CM_Non_mutable_value lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Non_concrete_value lab::err + | _, _ -> err) + sign2.csig_vars errors + in + 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 errors + +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 trace -> + raise (Failure [ + CM_Parameter_mismatch (env, expand_to_moregen_error env trace)]) + end; + moregen_clty false type_pairs env cty1' cty2' + | Cty_signature sign1, Cty_signature sign2 -> + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error env trace))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error 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 sign1 = signature_of_class_type pat_sch in + let sign2 = signature_of_class_type subj_sch in + let errors = match_class_sig_shape ~strict:false sign1 sign2 in + match errors with + | [] -> + 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 type_pairs = TypePairs.create 53 in + let sign1 = signature_of_class_type patt in + let sign2 = signature_of_class_type subj in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + moregen true type_pairs env row1 row2; + let res = + match moregen_clty trace type_pairs env patt subj with + | () -> [] + | exception Failure res -> + (* We've found an error. Moregen splits the generic level into two + finer levels: [generic_level] and [generic_level - 1]. In order + to properly detect and print weak variables when printing this + error, we need to merge them back together, by regeneralizing the + levels of the types after they were instantiated at + [generic_level - 1] above. Because [moregen] does some + unification that we need to preserve for more legible error + messages, we have to manually perform the regeneralization rather + than backtracking. *) + current_level := generic_level - 2; + generalize_class_type subj_inst; + res + in + current_level := old_level; + res + | errors -> + CM_Class_type_mismatch (env, pat_sch, subj_sch) :: errors + +let equal_clsig trace type_pairs subst env sign1 sign2 = + try + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + 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 sign1 = signature_of_class_type patt_type in + let sign2 = signature_of_class_type subj_type in + let errors = match_class_sig_shape ~strict:true sign1 sign2 in + match errors with + | [] -> begin + try + let subst = ref [] in + let type_pairs = TypePairs.create 53 in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + eqtype true type_pairs subst env row1 row2; + 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 trace -> + raise (Failure + [CM_Type_parameter_mismatch + (env, expand_to_equality_error env trace !subst)])) + 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 get_desc ty 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 : transient_expr list) + (loops : (int * type_expr) list) posi level t = + match get_desc t with + Tvar _ -> + if posi then + try + let t' = List.assq (get_id t) loops in + warn := true; + (t', Equiv) + with Not_found -> + (t, Unchanged) + else + (t, Unchanged) + | Tarrow(l, t1, t2, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: 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', commu_ok)), c) + else (t, Unchanged) + | Ttuple tlist -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: 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' = expand_abbrev env t in + let level' = pred_expand level in + begin try match get_desc t' 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 ty1, tl1 = + match get_desc ty 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 = (get_id ty, t'') :: loops in + (* May discard [visited] as level is going down *) + let (ty1', c) = + build_subtype env [Transient_expr.repr 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 *) + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: 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 tt = Transient_expr.repr t in + if memq_warn tt visited || not (static_row row) then (t, Unchanged) else + let level' = pred_enlarge level in + let visited = + tt :: if level' < level then [] else filter_visited visited in + let fields = filter_row_fields false (row_fields row) in + let fields = + List.map + (fun (l,f as orig) -> match row_field_repr f with + Rpresent None -> + if posi then + (l, rf_either_of 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 rf_either_of (Some t') + else rf_present (Some t') + in (l, f), c + | _ -> assert false) + fields + in + let c = collect fields in + let row = + create_row ~fields:(List.map fst fields) ~more:(newvar ()) + ~closed:posi ~fixed:None + ~name:(if c > Unchanged then None else row_name row) + in + (newty (Tvariant row), Changed) + | Tobject (t1, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited || opened_object t1 then (t, Unchanged) else + let level' = pred_enlarge level in + let visited = + tt :: 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, field_public, 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 ~unification_trace = + raise (Subtype (Subtype.error + ~trace:(expand_subtype_trace env (List.rev trace)) + ~unification_trace)) + +let rec subtype_rec env trace t1 t2 cstrs = + if eq_type t1 t2 then cstrs else + + if TypePairs.mem subtypes (t1, t2) then + cstrs + else begin + TypePairs.add subtypes (t1, t2); + match (get_desc t1, get_desc t2) 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 {got = t2; expected = t1} :: trace) + t2 t1 + cstrs + in + subtype_rec + env + (Subtype.Diff {got = u1; expected = 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 ~level:(get_level t1) (Ttuple[t1]), + newty2 ~level:(get_level t2) (Ttuple[t2]), !univar_pairs) + :: cstrs + else + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + else + if cn + then + subtype_rec + env + (Subtype.Diff {got = t2; expected = 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 (get_level t1) (Mty_ident p1) fl1 + and ntl2 = + complete_type_list env fl1 (get_level t2) (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 ~unification_trace:[]; + List.fold_left2 + (fun cstrs t1 t2 -> + subtype_rec + env + (Subtype.Diff { got = t1; expected = 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 get_desc rest2 = Tnil then cstrs else + if miss1 = [] then + subtype_rec + env + (Subtype.Diff {got = rest1; expected = rest2} :: trace) + rest1 rest2 + cstrs + else + (trace, build_fields (get_level ty1) miss1 rest1, rest2, + !univar_pairs) :: cstrs + in + let cstrs = + if miss2 = [] then cstrs else + (trace, rest1, build_fields (get_level ty2) 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 {got = t1; expected = t2} :: trace) + t1 t2 + cstrs) + cstrs pairs + +and subtype_row env trace row1 row2 cstrs = + let Row {fields = row1_fields; more = more1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = more2; closed = row2_closed} = + row_repr row2 in + let r1, r2, pairs = + merge_row_fields row1_fields row2_fields in + let r1 = if row2_closed then filter_row_fields false r1 else r1 in + let r2 = if row1_closed then filter_row_fields false r2 else r2 in + match get_desc more1, get_desc more2 with + Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> + subtype_rec + env + (Subtype.Diff {got = more1; expected = more2} :: trace) + more1 more2 + cstrs + | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) + when row1_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 {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Reither(false, t1::_, _), Rpresent(Some t2) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Rabsent, _ -> cstrs + | _ -> raise Exit) + cstrs pairs + | Tunivar _, Tunivar _ + when row1_closed = row2_closed && r1 = [] && r2 = [] -> + let cstrs = + subtype_rec + env + (Subtype.Diff {got = more1; expected = 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 {got = t1; expected = 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 {got = ty1; expected = 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} -> + subtype_error ~env ~trace:trace0 ~unification_trace:(List.tl trace)) + (List.rev cstrs) + + (*******************) + (* Miscellaneous *) + (*******************) + +(* Utility for printing. The resulting type is not used in computation. *) +let rec unalias_object ty = + let level = get_level ty in + match get_desc ty with + Tfield (s, k, t1, t2) -> + newty2 ~level (Tfield (s, k, t1, unalias_object t2)) + | Tvar _ | Tnil as desc -> + newty2 ~level desc + | Tunivar _ -> + ty + | Tconstr _ -> + newvar2 level + | _ -> + assert false + +let unalias ty = + let level = get_level ty in + match get_desc ty with + Tvar _ | Tunivar _ -> + ty + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + newty2 ~level + (Tvariant + (create_row ~fields ~name ~fixed ~closed ~more: + (newty2 ~level:(get_level more) (get_desc more)))) + | Tobject (ty, nm) -> + newty2 ~level (Tobject (unalias_object ty, nm)) + | desc -> + newty2 ~level desc + +(* Return the arity (as for curried functions) of the given type. *) +let rec arity ty = + match get_desc ty with + Tarrow(_, _t1, t2, _) -> 1 + arity t2 + | _ -> 0 + +(* Check for non-generalizable type variables *) +let add_nongen_vars_in_schema = + let rec loop env ((visited, weak_set) as acc) ty = + if TypeSet.mem ty visited + then acc + else begin + let visited = TypeSet.add ty visited in + match get_desc ty with + | Tvar _ when get_level ty <> generic_level -> + visited, TypeSet.add ty weak_set + | Tconstr _ -> + let (_, unexpanded_candidate) as unexpanded_candidate' = + fold_type_expr + (loop env) + (visited, weak_set) + ty + in + (* Using `==` is okay because `loop` will return the original set + when it does not change it. Similarly, `TypeSet.add` will return + the original set if the element is already present. *) + if unexpanded_candidate == weak_set + then (visited, weak_set) + else begin + match + loop env (visited, weak_set) + (try_expand_head try_expand_safe env ty) + with + | exception Cannot_expand -> unexpanded_candidate' + | expanded_result -> expanded_result + end + | Tfield(_, kind, t1, t2) -> + let visited, weak_set = + match field_kind_repr kind with + | Fpublic -> loop env (visited, weak_set) t1 + | _ -> visited, weak_set + in + loop env (visited, weak_set) t2 + | Tvariant row -> + let visited, weak_set = + fold_row (loop env) (visited, weak_set) row + in + if not (static_row row) + then loop env (visited, weak_set) (row_more row) + else (visited, weak_set) + | _ -> + fold_type_expr (loop env) (visited, weak_set) ty + end + in + fun env acc ty -> + let _, result = loop env (TypeSet.empty, acc) ty in + result + +(* Return all non-generic variables of [ty]. *) +let nongen_vars_in_schema env ty = + let result = add_nongen_vars_in_schema env TypeSet.empty ty in + if TypeSet.is_empty result + then None + else Some result + +(* Check that all type variables are generalizable *) +(* Use Env.empty to prevent expansion of recursively defined object types; + cf. typing-poly/poly.ml *) +let nongen_class_type = + let add_nongen_vars_in_schema' ty weak_set = + add_nongen_vars_in_schema Env.empty weak_set ty + in + let add_nongen_vars_in_schema_fold fold m weak_set = + let f _key (_,_,ty) weak_set = + add_nongen_vars_in_schema Env.empty weak_set ty + in + fold f m weak_set + in + let rec nongen_class_type cty weak_set = + match cty with + | Cty_constr (_, params, _) -> + List.fold_left + (add_nongen_vars_in_schema Env.empty) + weak_set + params + | Cty_signature sign -> + weak_set + |> add_nongen_vars_in_schema' sign.csig_self + |> add_nongen_vars_in_schema' sign.csig_self_row + |> add_nongen_vars_in_schema_fold Meths.fold sign.csig_meths + |> add_nongen_vars_in_schema_fold Vars.fold sign.csig_vars + | Cty_arrow (_, ty, cty) -> + add_nongen_vars_in_schema' ty weak_set + |> nongen_class_type cty + in + nongen_class_type + +let nongen_class_declaration cty = + List.fold_left + (add_nongen_vars_in_schema Env.empty) + TypeSet.empty + cty.cty_params + |> nongen_class_type cty.cty_type + +let nongen_vars_in_class_declaration cty = + let result = nongen_class_declaration cty in + if TypeSet.is_empty result + then None + else Some result + +(* Normalize a type before printing, saving... *) +(* Cannot use mark_type because deep_occur uses it too *) +let rec normalize_type_rec visited ty = + 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 get_desc tm 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 get_desc ty with + | Tvariant row -> + let Row {fields = orig_fields; more; name; fixed; closed} = + row_repr row in + let fields = List.map + (fun (l,f) -> + l, + match row_field_repr f with Reither(b, ty::(_::_ as tyl), m) -> + let tyl' = + List.fold_left + (fun tyl ty -> + if List.exists + (fun ty' -> is_equal Env.empty false [ty] [ty']) + tyl + then tyl + else ty::tyl) + [ty] tyl + in + if List.length tyl' <= List.length tyl then + rf_either (List.rev tyl') ~use_ext_of:f ~no_arg:b ~matched:m + else f + | _ -> f) + orig_fields in + let fields = + List.sort (fun (p,_) (q,_) -> compare p q) + (List.filter (fun (_,fi) -> row_field_repr fi <> Rabsent) fields) in + set_type_desc ty (Tvariant + (create_row ~fields ~more ~name ~fixed ~closed)) + | 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 + begin match get_desc v with + | Tvar _ | Tunivar _ -> () + | Tnil -> set_type_desc ty (Tconstr (n, l, ref Mnil)) + | _ -> set_name nm None + end + | _ -> + fatal_error "Ctype.normalize_type_rec" + end; + let level = get_level fi in + if level < lowest_level then () else + let fields, row = flatten_fields fi in + let fi' = build_fields level fields row in + set_type_desc fi (get_desc fi') + | _ -> () + 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 get_desc ty with + Tvar _ | Tunivar _ -> ty + | _ -> try TypeHash.find nondep_hash ty + with Not_found -> + let ty' = newgenstub ~scope:(get_scope ty) in + TypeHash.add nondep_hash ty ty'; + match + match get_desc ty with + | Tconstr(p, tl, _abbrev) as desc -> + 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 ~level:(get_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 more = row_more row 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_name row with + Some (p, _tl) when Path.exists_free ids p -> + Tvariant (set_row_name row None) + | _ -> Tvariant row + end + | desc -> copy_type_desc (nondep_type_rec env ids) desc + with + | desc -> + Transient_expr.set_stub_desc ty' desc; + ty' + | exception e -> + TypeHash.remove nondep_hash ty; + raise e + +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 get_desc ty' 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_self_row = nondep_type_rec env id sign.csig_self_row; + csig_vars = + Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) + sign.csig_vars; + csig_meths = + Meths.map (function (p, v, t) -> (p, v, nondep_type_rec env id t)) + sign.csig_meths } + +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_hash_type = nondep_type_decl env ids false decl.clty_hash_type ; + 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 id = get_id ty in + if List.memq id visited then () else + let visited = id :: visited in + match get_desc ty with + Tvariant row -> + List.iter + (fun (_l,fi) -> + match row_field_repr fi with + Reither (_c, t1::(_::_ as tl), _m) -> + List.iter (unify env t1) tl + | _ -> + ()) + (row_fields row); + 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 get_desc t1, get_desc t2 with + | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2 + | _ -> false + +let () = + Env.same_constr := same_constr + +let immediacy env typ = + match get_desc typ 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 -> + (* if all labels are devoid of arguments, not a pointer *) + if + not (row_closed row) + || List.exists + (fun (_, f) -> match row_field_repr f with + | Rpresent (Some _) | Reither (false, _, _) -> true + | _ -> false) + (row_fields row) + then + Type_immediacy.Unknown + else + Type_immediacy.Always + | _ -> Type_immediacy.Unknown diff --git a/upstream/ocaml_501/typing/ctype.mli b/upstream/ocaml_501/typing/ctype.mli new file mode 100644 index 0000000000..d252f8a622 --- /dev/null +++ b/upstream/ocaml_501/typing/ctype.mli @@ -0,0 +1,459 @@ +(**************************************************************************) +(* *) +(* 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 + +exception Unify of Errortrace.unification_error +exception Equality of Errortrace.equality_error +exception Moregen of Errortrace.moregen_error +exception Subtype of Errortrace.Subtype.error + +exception Escape of type_expr Errortrace.escape + +exception Tags of label * label +exception Cannot_expand +exception Cannot_apply +exception Matches_failure of Env.t * Errortrace.unification_error + (* Raised from [matches], hence the odd name *) +exception Incompatible + (* Raised from [mcomp] *) + +(* All the following wrapper functions revert to the original level, + even in case of exception. *) +val with_local_level: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* [with_local_level (fun () -> cmd) ~post] evaluates [cmd] at a + raised level. + If given, [post] is applied to the result, at the original level. + It is expected to contain only level related post-processing. *) +val with_local_level_if: bool -> (unit -> 'a) -> post:('a -> unit) -> 'a + (* Same as [with_local_level], but only raise the level conditionally. + [post] also is only called if the level is raised. *) +val with_local_level_iter: (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Variant of [with_local_level], where [post] is iterated on the + returned list. *) +val with_local_level_iter_if: + bool -> (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Conditional variant of [with_local_level_iter] *) +val with_level: level: int -> (unit -> 'a) -> 'a + (* [with_level ~level (fun () -> cmd)] evaluates [cmd] with + [current_level] set to [level] *) +val with_level_if: bool -> level: int -> (unit -> 'a) -> 'a + (* Conditional variant of [with_level] *) +val with_local_level_if_principal: (unit -> 'a) -> post:('a -> unit) -> 'a +val with_local_level_iter_if_principal: + (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Applications of [with_local_level_if] and [with_local_level_iter_if] + to [!Clflags.principal] *) + +val with_local_level_for_class: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* Variant of [with_local_level], where the current level is raised but + the nongen level is not touched *) +val with_raised_nongen_level: (unit -> 'a) -> 'a + (* Variant of [with_local_level], + raises the nongen level to the current level *) + +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 *) + +val create_scope : unit -> int + +val newty: type_desc -> type_expr +val new_scoped_ty: int -> 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 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 set_object_name: + Ident.t -> type_expr list -> type_expr -> unit +val remove_object_name: 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 lower_variables_only: Env.t -> int -> type_expr -> unit + (* Lower all variables to the given level *) +val enforce_current_level: Env.t -> type_expr -> unit + (* Lower whole type to !current_level *) +val generalize_structure: type_expr -> unit + (* Generalize the structure of a type, lowering variables + to !current_level *) +val generalize_class_type : class_type -> unit + (* Generalize the components of a class type *) +val generalize_class_type_structure : class_type -> unit + (* Generalize the structure of the components of a class type *) +val generalize_class_signature_spine : Env.t -> class_signature -> unit + (* Special function to generalize methods 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 limited_generalize_class_type: type_expr -> class_type -> unit + (* Same, but for class types *) + +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 + +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of { env: Env.t ref; scope: int } + +val instance_constructor: existential_treatment -> + 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_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: + ?use_current_level:bool -> + Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr + (* [apply [p1...pN] t [a1...aN]] applies the type function + [fun p1 ... pN -> t] to the arguments [a1...aN] and returns the + resulting instance of [t]. + New nodes default to generic level except if [use_current_level] is + set to true. + 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. *) + +(** Expansion of types for error traces; lives here instead of in [Errortrace] + because the expansion machinery lives here. *) + +(** Create an [Errortrace.Diff] by expanding the two types *) +val expanded_diff : + Env.t -> + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +(** Create an [Errortrace.Diff] by *duplicating* the two types, so that each + one's expansion is identical to itself. Despite the name, does create + [Errortrace.expanded_type]s. *) +val unexpanded_diff : + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +val full_expand: may_forget_scope:bool -> Env.t -> type_expr -> type_expr + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + (* The original path of the types, and the first concrete + type declaration found expanding it. *) + | Has_no_typedecl + | May_have_typedecl + +val extract_concrete_typedecl: + Env.t -> type_expr -> typedecl_extraction_result + +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_equations:bool -> + Env.t ref -> type_expr -> type_expr -> Btype.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]. Raises + [Filter_arrow_failed] instead of [Unify]. *) +val filter_method: Env.t -> string -> type_expr -> type_expr + (* A special case of unification (with {m : 'a; 'b}). Raises + [Filter_method_failed] instead of [Unify]. *) +val occur_in: Env.t -> type_expr -> type_expr -> bool +val deep_occur: type_expr -> type_expr -> bool +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: expand_error_trace:bool -> Env.t -> type_expr -> type_expr -> unit + (* Same as [moregeneral false], implemented using the two above + functions and backtracking. Ignore levels. The [expand_error_trace] + flag controls whether the error raised performs expansion; this + should almost always be [true]. *) +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. *) + +(* Exceptions for special cases of unify *) + +type filter_arrow_failure = + | Unification_error of Errortrace.unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +type filter_method_failure = + | Unification_error of Errortrace.unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + +type class_match_failure = + CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of Env.t * Errortrace.equality_error + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of Env.t * Errortrace.moregen_error + | CM_Val_type_mismatch of string * Env.t * Errortrace.comparison_error + | CM_Meth_type_mismatch of string * Env.t * Errortrace.comparison_error + | 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. *) + +(* Operations on class signatures *) + +val new_class_signature : unit -> class_signature +val add_dummy_method : Env.t -> scope:int -> class_signature -> unit + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +val add_method : Env.t -> + label -> private_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +val add_instance_variable : strict:bool -> Env.t -> + label -> mutable_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +val inherit_class_signature : strict:bool -> Env.t -> + class_signature -> class_signature -> unit + +val update_class_signature : + Env.t -> class_signature -> label list * label list + +val hide_private_methods : Env.t -> class_signature -> unit + +val close_class_signature : Env.t -> class_signature -> bool + +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 nongen_vars_in_schema: Env.t -> type_expr -> Btype.TypeSet.t option + (* Return any non-generic variables in the type scheme *) + +val nongen_vars_in_class_declaration:class_declaration -> Btype.TypeSet.t option + (* Return any non-generic variables in the class type. + Uses the empty environment. *) + +type variable_kind = Row_variable | Type_variable +type closed_class_failure = { + free_variable: type_expr * variable_kind; + meth: string; + meth_ty: type_expr; +} + +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 +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 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 immediacy : Env.t -> type_expr -> Type_immediacy.t + +(* 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_501/typing/datarepr.ml b/upstream/ocaml_501/typing/datarepr.ml new file mode 100644 index 0000000000..004859ee34 --- /dev/null +++ b/upstream/ocaml_501/typing/datarepr.ml @@ -0,0 +1,238 @@ +(**************************************************************************) +(* *) +(* 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 = + if try_mark_node ty then + match get_desc ty with + | Tvar _ -> + ret := TypeSet.add ty !ret + | Tvariant row -> + iter_row loop row; + if not (static_row row) then begin + match get_desc (row_more row) with + | Tvar _ when param -> ret := TypeSet.add ty !ret + | _ -> loop (row_more row) + 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 in + List.iter + (fun {cd_args; _} -> + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts) + 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.(Pextra_ty (ty_path, Pcstr_ty 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_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.(Pextra_ty (path_ext, Pext_ty)) (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_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 = + create_expr (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_501/typing/datarepr.mli b/upstream/ocaml_501/typing/datarepr.mli new file mode 100644 index 0000000000..38f05f74f0 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/env.ml b/upstream/ocaml_501/typing/env.ml new file mode 100644 index 0000000000..3b0b922f8c --- /dev/null +++ b/upstream/ocaml_501/typing/env.ml @@ -0,0 +1,3692 @@ +(**************************************************************************) +(* *) +(* 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 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 + +let uid_to_loc : Location.t Types.Uid.Tbl.t ref = + s_table Types.Uid.Tbl.create 16 + +let register_uid uid loc = Types.Uid.Tbl.add !uid_to_loc uid loc + +let get_uid_to_loc_tbl () = !uid_to_loc + +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 is_mutating_label_usage = function + | Mutation -> true + | (Projection | Construct | Exported_private | Exported) -> false + +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 find_all_idents name tbl () = + let current = + Ident.find_all_seq name tbl.current + |> Seq.map (fun (id, _) -> Some id) + in + let next () = + match tbl.layer with + | Nothing -> Seq.Nil + | Open { next; components; _ } -> + if NameMap.mem name components then + Seq.Cons(None, find_all_idents name next) + else + find_all_idents name next () + | Map {next; _ } -> find_all_idents name next () + in + Seq.append current 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_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_prefixing_subst: Subst.t; + cm_path: Path.t; + cm_addr: address_lazy; + cm_mty: Subst.Lazy.modtype; + cm_shape: Shape.t; +} + +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_shape: Shape.t; + 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; + vda_shape : Shape.t } + +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; + cda_shape: Shape.t; } + +and label_data = label_description + +and type_data = + { tda_declaration : type_declaration; + tda_descriptions : type_descriptions; + tda_shape : Shape.t; } + +and module_data = + { mda_declaration : Subst.Lazy.module_decl; + mda_components : module_components; + mda_address : address_lazy; + mda_shape: Shape.t; } + +and module_entry = + | Mod_local of module_data + | Mod_persistent + | Mod_unbound of module_unbound_reason + +and modtype_data = + { mtda_declaration : Subst.Lazy.modtype_declaration; + mtda_shape : Shape.t; } + +and class_data = + { clda_declaration : class_declaration; + clda_address : address_lazy; + clda_shape : Shape.t } + +and cltype_data = + { cltda_declaration : class_type_declaration; + cltda_shape : Shape.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 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_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, _)} -> begin + match p with + | Pident _ -> true + | Pdot _ | Papply _ | Pextra_ty _ -> false + end + | _ -> 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 -> Subst.Lazy.modtype -> + Path.t -> Subst.Lazy.modtype) + +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 _ | Pextra_ty _ -> 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 ps path addr mty shape = + { + alerts; + uid; + comps = Lazy_backtrack.create { + cm_env = env; + cm_prefixing_subst = ps; + cm_path = path; + cm_addr = addr; + cm_mty = mty; + cm_shape = shape; + } + } + +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 = + Subst.(Lazy.module_decl Make_local identity (Lazy.of_module_decl md)) + in + let mda_shape = Shape.for_persistent_unit name in + let mda_components = + let mty = Subst.Lazy.of_modtype (Mty_signature sign) in + let mty = + if freshen then + Subst.Lazy.modtype (Subst.Rescope (Path.scope path)) + Subst.identity mty + else mty + in + components_of_module ~alerts ~uid:md.md_uid + empty Subst.identity + path mda_address mty mda_shape + in + { + mda_declaration; + mda_components; + mda_address; + mda_shape; + } + +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; + Types.Uid.Tbl.clear !uid_to_loc; + () + +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 + | Pextra_ty _ -> raise Not_found + +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 + Subst.Lazy.force_module_decl data.mda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + Subst.Lazy.force_module_decl 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) + | Pextra_ty _ -> raise Not_found + +let find_module_lazy ~alias path env = + match path with + | Pident id -> + let data = find_ident_module id env in + data.mda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + data.mda_declaration + | Papply(p1, p2) -> + let fc = find_functor_components p1 env in + let md = + if alias then md (fc.fcomp_res) + else md (modtype_of_functor_appl fc p1 p2) + in + Subst.Lazy.of_module_decl md + | Pextra_ty _ -> raise Not_found + +let find_strengthened_module ~aliasable path env = + let md = find_module_lazy ~alias:true path env in + let mty = !strengthen ~aliasable env md.mdl_type path in + Subst.Lazy.force_modtype mty + +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 _ | Pextra_ty _ -> raise Not_found + +let find_extension_full path env = + match path with + | Pident id -> TycompTbl.find_same id env.constrs + | Pdot(p, s) -> begin + let comps = find_structure_components p env in + let cstrs = NameMap.find s comps.comp_constrs in + let exts = List.filter is_ext cstrs in + match exts with + | [cda] -> cda + | _ -> raise Not_found + end + | Papply _ | Pextra_ty _ -> raise Not_found + +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); + tda_shape = Shape.leaf decl.type_uid; + } + | _ -> assert false + end + | _ -> assert false + +let rec find_type_data path env = + match Path.Map.find path env.local_constraints with + | decl -> + { + tda_declaration = decl; + tda_descriptions = Type_abstract; + tda_shape = Shape.leaf decl.type_uid; + } + | exception Not_found -> begin + 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 + | Pextra_ty (p, extra) -> begin + match extra with + | Pcstr_ty s -> + let cstr = find_cstr p s env in + type_of_cstr path cstr + | Pext_ty -> + let cda = find_extension_full p env in + type_of_cstr path cda.cda_description + end + end +and find_cstr path name env = + let tda = find_type_data path env in + match tda.tda_descriptions with + | Type_variant (cstrs, _) -> + List.find (fun cstr -> cstr.cstr_name = name) cstrs + | Type_record _ | Type_abstract | Type_open -> raise Not_found + + + +let find_modtype_lazy path env = + match path with + | Pident id -> (IdTbl.find_same id env.modtypes).mtda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_modtypes).mtda_declaration + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_modtype path env = + Subst.Lazy.force_modtype_decl (find_modtype_lazy path env) + +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 _ | Pextra_ty _ -> raise Not_found + +let find_cltype path env = + match path with + | Pident id -> (IdTbl.find_same id env.cltypes).cltda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_cltypes).cltda_declaration + | Papply _ | Pextra_ty _ -> 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 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 _ | Pextra_ty _ -> 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 _ | Pextra_ty _ -> raise Not_found + +let find_hash_type path env = + match path with + | Pident id -> + let name = Ident.name id in + let _, cltda = + IdTbl.find_name wrap_identity ~mark:false name env.cltypes + in + cltda.cltda_declaration.clty_hash_type + | Pdot(p, name) -> + let c = find_structure_components p env in + let cltda = NameMap.find name c.comp_cltypes in + cltda.cltda_declaration.clty_hash_type + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_shape env (ns : Shape.Sig_component_kind.t) id = + match ns with + | Type -> + (IdTbl.find_same id env.types).tda_shape + | Extension_constructor -> + (TycompTbl.find_same id env.constrs).cda_shape + | Value -> + begin match IdTbl.find_same id env.values with + | Val_bound x -> x.vda_shape + | Val_unbound _ -> raise Not_found + end + | Module -> + begin match IdTbl.find_same id env.modules with + | Mod_local { mda_shape; _ } -> mda_shape + | Mod_persistent -> Shape.for_persistent_unit (Ident.name id) + | Mod_unbound _ -> + (* Only present temporarily while approximating the environment for + recursive modules. + [find_shape] is only ever called after the environment gets + properly populated. *) + assert false + | exception Not_found + when Ident.persistent id && not (Current_unit_name.is_ident id) -> + Shape.for_persistent_unit (Ident.name id) + end + | Module_type -> + (IdTbl.find_same id env.modtypes).mtda_shape + | Class -> + (IdTbl.find_same id env.classes).clda_shape + | Class_type -> + (IdTbl.find_same id env.cltypes).cltda_shape + +let shape_of_path ~namespace env = + Shape.of_path ~namespace ~find_shape:(find_shape env) + +let shape_or_leaf uid = function + | None -> Shape.leaf uid + | Some shape -> shape + +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 + | Pextra_ty _ -> assert false + +and expand_module_path lax env path = + try match find_module_lazy ~alias:true path env with + {mdl_type=MtyL_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 rec 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 + | Pextra_ty (p, extra) -> + let p2 = normalize_path_prefix oloc env p in + if p == p2 then path else Pextra_ty (p2, extra) + | Papply _ -> + assert false + +let normalize_type_path = normalize_path_prefix + +let normalize_value_path = normalize_path_prefix + +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_lazy path env).mtdl_type with + | Some (MtyL_ident path) -> normalize_modtype_path env path + | _ | exception Not_found -> path + +let find_module path env = + find_module ~alias:false path env + +let find_module_lazy path env = + find_module_lazy ~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_lazy path env = + match (find_modtype_lazy path env).mtdl_type with + | None -> raise Not_found + | Some mty -> mty + +let find_modtype_expansion path env = + Subst.Lazy.force_modtype (find_modtype_expansion_lazy path env) + +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, _) | Pextra_ty (p, _) -> 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 (get_id t) + with Not_found -> + let t2 = Subst.type_expr Subst.identity t in + Hashtbl.add memo (get_id t) 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} + ) + +(* 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 mty = + let open Subst.Lazy in + match mty with + | MtyL_alias path -> begin + match 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 (find_module_lazy path env).mdl_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; _ } -> + scrape_alias_for_visit env 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 -> String.Set.add s r) + String.Set.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 _ | Pextra_ty _ -> [] + +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 _ | Pextra_ty _ -> [] + +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 ?path mty = + let open Subst.Lazy in + match mty, path with + MtyL_ident p, _ -> + begin try + scrape_alias env (find_modtype_expansion_lazy p env) ?path + with Not_found -> + mty + end + | MtyL_alias path, _ -> + begin try + scrape_alias env ((find_module_lazy path env).mdl_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 prefixing_sub sg = + let open Subst.Lazy in + let rec prefix_idents root items_and_paths prefixing_sub = + function + | [] -> (List.rev items_and_paths, prefixing_sub) + | SigL_value(id, _, _) as item :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((item, p) :: items_and_paths) prefixing_sub rem + | SigL_type(id, td, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_type(id, td, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_typext(id, ec, es, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + (* we extend the substitution in case of an inlined record *) + prefix_idents root + ((SigL_typext(id, ec, es, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_module(id, pres, md, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_module(id, pres, md, rs, vis), p) :: items_and_paths) + (Subst.add_module id p prefixing_sub) + rem + | SigL_modtype(id, mtd, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_modtype(id, mtd, vis), p) :: items_and_paths) + (Subst.add_modtype id (Mty_ident p) prefixing_sub) + rem + | SigL_class(id, cd, rs, vis) :: rem -> + (* pretend this is a type, cf. PR#6650 *) + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_class(id, cd, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_class_type(id, ctd, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_class_type(id, ctd, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + in + let sg = Subst.Lazy.force_signature_once sg in + prefix_idents root [] 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 + let open Subst.Lazy in + match md.mdl_type with + | MtyL_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_prefixing_subst; + cm_path; cm_addr; cm_mty; cm_shape} : _ result = + match scrape_alias cm_env cm_mty with + MtyL_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, sub = + prefix_idents cm_path 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 + List.iter (fun ((item : Subst.Lazy.signature_item), path) -> + match item with + SigL_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_shape = Shape.proj cm_shape (Shape.Item.value id) in + let vda = + { vda_description = decl'; vda_address = addr; vda_shape } + in + c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values; + | SigL_type(id, decl, _, _) -> + let final_decl = Subst.type_declaration sub decl in + Btype.set_static_row_name final_decl + (Subst.type_path 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_shape = Shape.leaf descr.cstr_uid in + let cda = { + cda_description = descr; + cda_address = None; + cda_shape } + 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 shape = Shape.proj cm_shape (Shape.Item.type_ id) in + let tda = + { tda_declaration = final_decl; + tda_descriptions = descrs; + tda_shape = shape; } + in + c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types; + env := store_type_infos ~tda_shape:shape id decl !env + | SigL_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_shape = + Shape.proj cm_shape (Shape.Item.extension_constructor id) + in + let cda = + { cda_description = descr; cda_address = Some addr; cda_shape } + in + c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs + | SigL_module(id, pres, md, _, _) -> + let md' = + (* The prefixed items get the same scope as [cm_path], which is + the prefix. *) + Subst.Lazy.module_decl + (Subst.Rescope (Path.scope cm_path)) sub md + in + let addr = + match pres with + | Mp_absent -> begin + match md.mdl_type with + | MtyL_alias path -> + Lazy_backtrack.create (ModAlias {env = !env; path}) + | _ -> assert false + end + | Mp_present -> next_address () + in + let alerts = + Builtin_attributes.alerts_of_attrs md.mdl_attributes + in + let shape = Shape.proj cm_shape (Shape.Item.module_ id) in + let comps = + components_of_module ~alerts ~uid:md.mdl_uid !env + sub path addr md.mdl_type shape + in + let mda = + { mda_declaration = md'; + mda_components = comps; + mda_address = addr; + mda_shape = shape; } + in + c.comp_modules <- + NameMap.add (Ident.name id) mda c.comp_modules; + env := + store_module ~update_summary:false ~check:None + id addr pres md shape !env + | SigL_modtype(id, decl, _) -> + let final_decl = + (* The prefixed items get the same scope as [cm_path], which is + the prefix. *) + Subst.Lazy.modtype_decl (Rescope (Path.scope cm_path)) + sub decl + in + let shape = Shape.proj cm_shape (Shape.Item.module_type id) in + let mtda = + { mtda_declaration = final_decl; + mtda_shape = shape; } + in + c.comp_modtypes <- + NameMap.add (Ident.name id) mtda c.comp_modtypes; + env := store_modtype ~update_summary:false id decl shape !env + | SigL_class(id, decl, _, _) -> + let decl' = Subst.class_declaration sub decl in + let addr = next_address () in + let shape = Shape.proj cm_shape (Shape.Item.class_ id) in + let clda = + { clda_declaration = decl'; + clda_address = addr; + clda_shape = shape; } + in + c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes + | SigL_class_type(id, decl, _, _) -> + let decl' = Subst.cltype_declaration sub decl in + let shape = Shape.proj cm_shape (Shape.Item.class_type id) in + let cltda = { cltda_declaration = decl'; cltda_shape = shape } in + c.comp_cltypes <- + NameMap.add (Ident.name id) cltda c.comp_cltypes) + items_and_paths; + Ok (Structure_comps c) + | MtyL_functor(arg, ty_res) -> + let sub = cm_prefixing_subst in + let scoping = Subst.Rescope (Path.scope cm_path) in + let open Subst.Lazy 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, force_modtype (modtype scoping sub ty_arg))); + fcomp_res = force_modtype (modtype scoping sub ty_res); + fcomp_shape = cm_shape; + fcomp_cache = Hashtbl.create 17; + fcomp_subst_cache = Hashtbl.create 17 }) + | MtyL_ident _ -> Error No_components_abstract + | MtyL_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 shape 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; + vda_shape = shape } + 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 = + Builtin_attributes.warning_scope cstr.cstr_attributes (fun () -> + 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); + let cda_shape = Shape.leaf cstr.cstr_uid in + { env with + constrs = + TycompTbl.add cstr_id + { cda_description = cstr; cda_address = None; cda_shape } env.constrs; + } + +and store_label ~check type_decl type_id lbl_id lbl env = + Builtin_attributes.warning_scope lbl.lbl_attributes (fun () -> + 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 shape 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; + tda_shape = shape } + in + { env with + types = IdTbl.add id tda env.types; + summary = Env_type(env.summary, id, info) } + +and store_type_infos ~tda_shape 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; + tda_shape + } + 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 shape 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; + cda_shape = shape } + in + Builtin_attributes.warning_scope ext.ext_attributes (fun () -> + 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 ?(update_summary=true) ~check + id addr presence md shape env = + let open Subst.Lazy in + let loc = md.mdl_loc in + Option.iter + (fun f -> check_usage loc id md.mdl_uid f !module_declarations) check; + let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in + let comps = + components_of_module ~alerts ~uid:md.mdl_uid + env Subst.identity (Pident id) addr md.mdl_type shape + in + let mda = + { mda_declaration = md; + mda_components = comps; + mda_address = addr; + mda_shape = shape } + in + let summary = + if not update_summary then env.summary + else Env_module (env.summary, id, presence, force_module_decl md) in + { env with + modules = IdTbl.add id (Mod_local mda) env.modules; + summary } + +and store_modtype ?(update_summary=true) id info shape env = + let mtda = { mtda_declaration = info; mtda_shape = shape } in + let summary = + if not update_summary then env.summary + else Env_modtype (env.summary, id, Subst.Lazy.force_modtype_decl info) in + { env with + modtypes = IdTbl.add id mtda env.modtypes; + summary } + +and store_class id addr desc shape env = + let clda = + { clda_declaration = desc; + clda_address = addr; + clda_shape = shape; } + in + { env with + classes = IdTbl.add id clda env.classes; + summary = Env_class(env.summary, id, desc) } + +and store_cltype id desc shape env = + let cltda = { cltda_declaration = desc; cltda_shape = shape } in + { env with + cltypes = IdTbl.add id cltda env.cltypes; + summary = Env_cltype(env.summary, id, desc) } + +let scrape_alias env mty = scrape_alias env 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 shape_arg = + shape_of_path ~namespace:Shape.Sig_component_kind.Module env arg + in + let shape = Shape.app f_comp.fcomp_shape ~arg:shape_arg in + let comps = + components_of_module ~alerts:Misc.Stdlib.String.Map.empty + ~uid:Uid.internal_not_actually_unique + (*???*) + env Subst.identity p addr (Subst.Lazy.of_modtype mty) shape + 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 ?shape id desc env = + let addr = value_declaration_address env id desc in + let shape = shape_or_leaf desc.val_uid shape in + store_value ?check id addr desc shape env + +let add_type ~check ?shape id info env = + let shape = shape_or_leaf info.type_uid shape in + store_type ~check id info shape env + +and add_extension ~check ?shape ~rebind id ext env = + let addr = extension_declaration_address env id ext in + let shape = shape_or_leaf ext.ext_uid shape in + store_extension ~check ~rebind id addr ext shape env + +and add_module_declaration ?(arg=false) ?shape ~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 md = Subst.Lazy.of_module_decl md in + let addr = module_declaration_address env id presence md in + let shape = shape_or_leaf md.mdl_uid shape in + let env = store_module ~check id addr presence md shape env in + if arg then add_functor_arg id env else env + +and add_module_declaration_lazy ~update_summary id presence md env = + let addr = module_declaration_address env id presence md in + let shape = Shape.leaf md.Subst.Lazy.mdl_uid in + let env = + store_module ~update_summary ~check:None id addr presence md shape env + in + env + +and add_modtype ?shape id info env = + let shape = shape_or_leaf info.mtd_uid shape in + store_modtype id (Subst.Lazy.of_modtype_decl info) shape env + +and add_modtype_lazy ~update_summary id info env = + let shape = Shape.leaf info.Subst.Lazy.mtdl_uid in + store_modtype ~update_summary id info shape env + +and add_class ?shape id ty env = + let addr = class_declaration_address env id ty in + let shape = shape_or_leaf ty.cty_uid shape in + store_class id addr ty shape env + +and add_cltype ?shape id ty env = + let shape = shape_or_leaf ty.clty_uid shape in + store_cltype id ty shape env + +let add_module ?arg ?shape id presence mty env = + add_module_declaration ~check:false ?arg ?shape id presence (md mty) env + +let add_module_lazy ~update_summary id presence mty env = + let md = Subst.Lazy.{mdl_type = mty; + mdl_attributes = []; + mdl_loc = Location.none; + mdl_uid = Uid.internal_not_actually_unique} + in + add_module_declaration_lazy ~update_summary id presence md env + +let add_local_type path info env = + { env with + local_constraints = Path.Map.add path info env.local_constraints } + +(* Non-lazy version of scrape_alias *) +let scrape_alias t mty = + mty |> Subst.Lazy.of_modtype |> scrape_alias t |> Subst.Lazy.force_modtype + +(* 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 (Shape.leaf desc.val_uid) 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 (Shape.leaf info.type_uid) 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 shape = Shape.leaf ext.ext_uid in + let env = store_extension ~check:true ~rebind id addr ext shape env in + (id, env) + +let enter_module_declaration ~scope ?arg ?shape s presence md env = + let id = Ident.create_scoped ~scope s in + (id, add_module_declaration ?arg ?shape ~check:true id presence md env) + +let enter_modtype ~scope name mtd env = + let id = Ident.create_scoped ~scope name in + let shape = Shape.leaf mtd.mtd_uid in + let env = store_modtype id (Subst.Lazy.of_modtype_decl mtd) shape 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 (Shape.leaf desc.cty_uid) 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 (Shape.leaf desc.clty_uid) 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 (map, mod_shape) comp env = + let proj_shape item = + match mod_shape with + | None -> map, None + | Some mod_shape -> + let shape = Shape.proj mod_shape item in + Shape.Map.add map item shape, Some shape + in + match comp with + | Sig_value(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.value id) in + map, add_value ?shape id decl env + | Sig_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.type_ id) in + map, add_type ~check:false ?shape id decl env + | Sig_typext(id, ext, _, _) -> + let map, shape = proj_shape (Shape.Item.extension_constructor id) in + map, add_extension ~check:false ?shape ~rebind:false id ext env + | Sig_module(id, presence, md, _, _) -> + let map, shape = proj_shape (Shape.Item.module_ id) in + map, add_module_declaration ~check:false ?shape id presence md env + | Sig_modtype(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.module_type id) in + map, add_modtype ?shape id decl env + | Sig_class(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_ id) in + map, add_class ?shape id decl env + | Sig_class_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_type id) in + map, add_cltype ?shape id decl env + +let rec add_signature (map, mod_shape) sg env = + match sg with + [] -> map, env + | comp :: rem -> + let map, env = add_item (map, mod_shape) comp env in + add_signature (map, mod_shape) rem env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + let sg = Subst.signature (Rescope scope) Subst.identity sg in + let shape, env = add_signature (parent_shape, mod_shape) sg env in + sg, shape, env + +let enter_signature ?mod_shape ~scope sg env = + let sg, _, env = + enter_signature_and_shape ~scope ~parent_shape:Shape.Map.empty + mod_shape sg env + in + sg, env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env + +let add_value = add_value ?shape:None +let add_type = add_type ?shape:None +let add_extension = add_extension ?shape:None +let add_class = add_class ?shape:None +let add_cltype = add_cltype ?shape:None +let add_modtype = add_modtype ?shape:None +let add_signature sg env = + let _, env = add_signature (Shape.Map.empty, None) sg env in + 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 = Subst.Lazy.force_module_decl 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 = + 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 = Btype.cstr_type_path cstr 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 get_desc lbl.lbl_res with + | 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 = + let open Subst.Lazy in + if use then begin + mark_modtype_used desc.mtdl_uid; + Builtin_attributes.check_alerts loc desc.mtdl_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; + if is_mutating_label_usage usage then + Builtin_attributes.check_deprecated_mutable 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) -> + use_modtype ~use ~loc path data.mtda_declaration; + (path, data.mtda_declaration) + | 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, cltda -> + use_cltype ~use ~loc path cltda.cltda_declaration; + path, cltda.cltda_declaration + | 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 = Subst.Lazy.force_module_decl data.mda_declaration in + path, md + | Ldot(l, s) -> + let path, data = lookup_dot_module ~errors ~use ~loc l s env in + let md = Subst.Lazy.force_module_decl 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 + | mta -> + let path = Pdot(p, s) in + use_modtype ~use ~loc path mta.mtda_declaration; + (path, mta.mtda_declaration) + | 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 + | cltda -> + let path = Pdot(p, s) in + use_cltype ~use ~loc path cltda.cltda_declaration; + (path, cltda.cltda_declaration) + | 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 + | _ -> + 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_lazy ~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_modtype ~errors ~use ~loc lid env = + let (path, mt) = lookup_modtype_lazy ~errors ~use ~loc lid env in + path, Subst.Lazy.force_modtype_decl mt + +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 + +(* Stable name lookup for printing *) + +let find_index_tbl ident tbl = + let lbs = IdTbl.find_all_idents (Ident.name ident) tbl in + let find_ident (n,p) = match p with + | Some id -> if Ident.same ident id then Some n else None + | _ -> None + in + Seq.find_map find_ident @@ Seq.mapi (fun i x -> i,x) lbs + +let find_value_index id env = find_index_tbl id env.values +let find_type_index id env = find_index_tbl id env.types +let find_module_index id env = find_index_tbl id env.modules +let find_modtype_index id env = find_index_tbl id env.modtypes +let find_class_index id env = find_index_tbl id env.classes +let find_cltype_index id env = find_index_tbl id env.cltypes + +(* 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_modtype_path ?(use=true) ~loc lid env = + fst (lookup_modtype_lazy ~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 = + Subst.Lazy.force_module_decl 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 = + Subst.Lazy.force_module_decl 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 = + Subst.Lazy.force_module_decl 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 = + let f l path data acc = f l path (Subst.Lazy.force_modtype_decl data) acc in + find_all wrap_identity + (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + (fun k p mta acc -> f k p mta.mtda_declaration acc) +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) + (fun k p cltda acc -> f k p cltda.cltda_declaration acc) + +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 + "@.@[@{Hint@}: If this is a recursive definition,@ %s %i@]" + "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 + "@.@[@{Hint@}: There is a module type named %a, %s@]" + !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 + "@.@[@{Hint@}: There is a class type named %a, %s@]" + !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 + "@.@[@{Hint@}: There is a module named %a, %s@]" + !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 "@[@["; + 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_501/typing/env.mli b/upstream/ocaml_501/typing/env.mli new file mode 100644 index 0000000000..9f18d828bc --- /dev/null +++ b/upstream/ocaml_501/typing/env.mli @@ -0,0 +1,524 @@ +(**************************************************************************) +(* *) +(* 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 + +val register_uid : Uid.t -> Location.t -> unit + +val get_uid_to_loc_tbl : unit -> Location.t Types.Uid.Tbl.t + +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: 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 -> Stdlib.String.Set.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_strengthened_module: + aliasable:bool -> Path.t -> t -> module_type + +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_modtype_expansion_lazy: Path.t -> t -> Subst.Lazy.modtype + +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 shape_of_path: + namespace:Shape.Sig_component_kind.t -> t -> Path.t -> Shape.t + +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_value_path: Location.t option -> t -> Path.t -> Path.t +(* Normalize the prefix part of the value path *) + +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_modtype_path: + ?use:bool -> loc:Location.t -> 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 + +(** The [find_*_index] functions computes a "namespaced" De Bruijn index + of an identifier in a given environment. In other words, it returns how many + times an identifier has been shadowed by a more recent identifiers with the + same name in a given environment. + Those functions return [None] when the identifier is not bound in the + environment. This behavior is there to facilitate the detection of + inconsistent printing environment, but should disappear in the long term. +*) +val find_value_index: Ident.t -> t -> int option +val find_type_index: Ident.t -> t -> int option +val find_module_index: Ident.t -> t -> int option +val find_modtype_index: Ident.t -> t -> int option +val find_class_index: Ident.t -> t -> int option +val find_cltype_index: Ident.t -> t -> int option + +(* 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 -> ?shape:Shape.t -> + Ident.t -> module_presence -> module_type -> t -> t +val add_module_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.modtype -> t -> t +val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> + Ident.t -> module_presence -> module_declaration -> t -> t +val add_module_declaration_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.module_decl -> t -> t +val add_modtype: Ident.t -> modtype_declaration -> t -> t +val add_modtype_lazy: update_summary:bool -> + Ident.t -> Subst.Lazy.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_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 -> ?shape:Shape.t -> 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: ?mod_shape:Shape.t -> scope:int -> signature -> t -> + signature * t + +(* Same as [enter_signature] but also extends the shape map ([parent_shape]) + with all the the items from the signature, their shape being a projection + from the given shape. *) +val enter_signature_and_shape: scope:int -> parent_shape:Shape.Map.t -> + Shape.t -> signature -> t -> signature * Shape.Map.t * 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 -> Subst.Lazy.modtype -> + Path.t -> Subst.Lazy.modtype) 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_501/typing/envaux.ml b/upstream/ocaml_501/typing/envaux.ml new file mode 100644 index 0000000000..a0bbbc2684 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/envaux.mli b/upstream/ocaml_501/typing/envaux.mli new file mode 100644 index 0000000000..2869890a14 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/errortrace.ml b/upstream/ocaml_501/typing/errortrace.ml new file mode 100644 index 0000000000..ec380329be --- /dev/null +++ b/upstream/ocaml_501/typing/errortrace.ml @@ -0,0 +1,194 @@ +(**************************************************************************) +(* *) +(* 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 expanded_type = { ty: type_expr; expanded: type_expr } + +let trivial_expansion ty = { ty; expanded = ty } + +type 'a diff = { got: 'a; expected: 'a } + +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 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 map_escape f esc = + {esc with kind = match esc.kind with + | Equation eq -> Equation (f eq) + | (Constructor _ | Univ _ | Self | Module_type _ | Constraint) as c -> c} + +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 *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | 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 ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +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 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 + +type unification_error = { trace : unification error } [@@unboxed] + +type equality_error = + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = { trace : comparison error } [@@unboxed] + +let unification_error ~trace : unification_error = + assert (trace <> []); + { trace } + +let equality_error ~trace ~subst : equality_error = + assert (trace <> []); + { trace; subst } + +let moregen_error ~trace : moregen_error = + assert (trace <> []); + { trace } + +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +let swap_unification_error ({trace} : unification_error) = + ({trace = swap_trace trace} : unification_error) + +module Subtype = struct + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = + { trace : error_trace + ; unification_trace : unification error } + + let error ~trace ~unification_trace = + assert (trace <> []); + { trace; unification_trace } + + let map_elt f = function + | Diff x -> Diff (map_diff f x) + + let map f t = List.map (map_elt f) t +end diff --git a/upstream/ocaml_501/typing/errortrace.mli b/upstream/ocaml_501/typing/errortrace.mli new file mode 100644 index 0000000000..90148893fe --- /dev/null +++ b/upstream/ocaml_501/typing/errortrace.mli @@ -0,0 +1,168 @@ +(**************************************************************************) +(* *) +(* 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 expanded_type = { ty: type_expr; expanded: type_expr } + +(** [trivial_expansion ty] creates an [expanded_type] whose expansion is also + [ty]. Usually, you want [Ctype.expand_type] instead, since the expansion + carries useful information; however, in certain circumstances, the error is + about the expansion of the type, meaning that actually performing the + expansion produces more confusing or inaccurate output. *) +val trivial_expansion : type_expr -> expanded_type + +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 map_escape : ('a -> 'b) -> 'a escape -> 'b escape + +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 *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | 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 ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +val map : ('a -> 'b) -> ('a, 'variety) t -> ('b, 'variety) t + +val incompatible_fields : + name:string -> got:type_expr -> expected:type_expr -> (type_expr, _) elt + +val swap_trace : ('a, 'variety) t -> ('a, 'variety) t + +(** The traces (['variety t]) are the core error types. However, we bundle them + up into three "top-level" error types, which are used elsewhere: + [unification_error], [equality_error], and [moregen_error]. In the case of + [equality_error], this has to bundle in extra information; in general, it + distinguishes the three types of errors and allows us to distinguish traces + that are being built (or processed) from those that are complete and have + become the final error. These error types have the invariants that their + traces are nonempty; we ensure that through three smart constructors with + matching names. *) + +type unification_error = private { trace : unification error } [@@unboxed] + +type equality_error = private + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = private { trace : comparison error } [@@unboxed] + +val unification_error : trace:unification error -> unification_error + +val equality_error : + trace:comparison error -> subst:(type_expr * type_expr) list -> equality_error + +val moregen_error : trace:comparison error -> moregen_error + +(** Wraps up the two different kinds of [comparison] errors in one type *) +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +(** Lift [swap_trace] to [unification_error] *) +val swap_unification_error : unification_error -> unification_error + +module Subtype : sig + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + (** Just as outside [Subtype], we split traces, completed traces, and complete + errors. However, in a minor asymmetry, the name [Subtype.error_trace] + corresponds to the outside [error] type, and [Subtype.error] corresponds + to the outside [*_error] types (e.g., [unification_error]). This [error] + type has the invariant that the subtype trace is nonempty; note that no + such invariant is imposed on the unification trace. *) + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = private + { trace : error_trace + ; unification_trace : unification error } + + val error : + trace:error_trace -> unification_trace:unification_error_trace -> error + + val map : ('a -> 'b) -> 'a t -> 'b t +end diff --git a/upstream/ocaml_501/typing/ident.ml b/upstream/ocaml_501/typing/ident.ml new file mode 100644 index 0000000000..287c0ac86d --- /dev/null +++ b/upstream/ocaml_501/typing/ident.ml @@ -0,0 +1,388 @@ +(**************************************************************************) +(* *) +(* 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 + "_", 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 + +(* For the documentation of ['a Ident.tbl], see ident.mli. + + The implementation is a copy-paste specialization of + a balanced-tree implementation similar to Map. + ['a tbl] + is a slightly more compact version of + [(Ident.t * 'a) list Map.Make(String)] + + This implementation comes from Caml Light where duplication was + unavoidable in absence of functors. It works well enough, and so + far we have not had strong incentives to do the deduplication work + (implementation, tests, benchmarks, etc.). +*) +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 get_all_seq k () = + Seq.unfold (Option.map (fun k -> (k.ident, k.data), k.previous)) + k () + +let rec find_all_seq n tbl () = + match tbl with + | Empty -> Seq.Nil + | Node(l, k, r, _) -> + let c = String.compare n (name k.ident) in + if c = 0 then + Seq.Cons((k.ident, k.data), get_all_seq k.previous) + else + find_all_seq 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_501/typing/ident.mli b/upstream/ocaml_501/typing/ident.mli new file mode 100644 index 0000000000..4132b1fbef --- /dev/null +++ b/upstream/ocaml_501/typing/ident.mli @@ -0,0 +1,110 @@ +(**************************************************************************) +(* *) +(* 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 +(** ['a tbl] represents association tables from identifiers to values + of type ['a]. + + ['a tbl] plays the role of map, but bindings can be looked up + from either the full Ident using [find_same], or just its + user-visible name using [find_name]. In general the two lookups may + not return the same result, as an identifier may have been shadowed + in the environment by a distinct identifier with the same name. + + [find_all] returns the bindings for all idents of a given name, + most recently introduced first. + + In other words, + ['a tbl] + corresponds to + [(Ident.t * 'a) list Map.Make(String)] + and the implementation is very close to that representation. + + Note in particular that searching among idents of the same name + takes linear time, and that [add] simply extends the list without + checking for duplicates. So it is not a good idea to implement + union by repeated [add] calls, which may result in many duplicated + identifiers and poor [find_same] performance. It is even possible + to build overly large same-name lists such that non-recursive + functions like [find_all] or [fold_all] blow the stack. + + You should probably use [Map.Make(Ident)] instead, unless you + really need to query bindings by user-visible name, not just by + unique identifiers. +*) + +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 find_all_seq: string -> 'a tbl -> (t * 'a) Seq.t +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_501/typing/includeclass.ml b/upstream/ocaml_501/typing/includeclass.ml new file mode 100644 index 0000000000..3a2cd57694 --- /dev/null +++ b/upstream/ocaml_501/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 mode 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, err) -> + Printtyp.report_equality_error ppf mode env err + (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, err) -> + Printtyp.report_moregen_error ppf mode env err + (function ppf -> + fprintf ppf "A parameter has type") + (function ppf -> + fprintf ppf "but is expected to have type") + | CM_Val_type_mismatch (lab, env, err) -> + Printtyp.report_comparison_error ppf mode env err + (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, err) -> + Printtyp.report_comparison_error ppf mode env err + (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 mode ppf = function + | [] -> () + | err :: errs -> + let print_errs ppf errs = + List.iter (fun err -> fprintf ppf "@ %a" (include_err mode) err) errs in + fprintf ppf "@[%a%a@]" (include_err mode) err print_errs errs diff --git a/upstream/ocaml_501/typing/includeclass.mli b/upstream/ocaml_501/typing/includeclass.mli new file mode 100644 index 0000000000..84de6212c4 --- /dev/null +++ b/upstream/ocaml_501/typing/includeclass.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* 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 : + Printtyp.type_or_scheme -> formatter -> class_match_failure list -> unit diff --git a/upstream/ocaml_501/typing/includecore.ml b/upstream/ocaml_501/typing/includecore.ml new file mode 100644 index 0000000000..a3cdd189c9 --- /dev/null +++ b/upstream/ocaml_501/typing/includecore.ml @@ -0,0 +1,1020 @@ +(**************************************************************************) +(* *) +(* 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 Errortrace.moregen_error + +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 err -> raise (Dont_match (Type err)) + | () -> 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 manifest types (particularly for private row types) *) + +let is_absrow env ty = + match get_desc ty with + | Tconstr(Pident _, _, _) -> + (* This function is checking for an abstract row on the side that is being + included into (usually numbered with "2" in this file). In this case, + the abstract row variable has been substituted for an object or variant + type. *) + begin match get_desc (Ctype.expand_head env ty) with + | 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 + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type type_kind = + | Kind_abstract + | Kind_record + | Kind_variant + | Kind_open + +let of_kind = function + | Type_abstract -> Kind_abstract + | Type_record (_, _) -> Kind_record + | Type_variant (_, _) -> Kind_variant + | Type_open -> Kind_open + +type kind_mismatch = type_kind * type_kind + +type label_mismatch = + | Type of Errortrace.equality_error + | Mutability of position + +type record_change = + (Types.label_declaration, Types.label_declaration, label_mismatch) + Diffing_with_keys.change + +type record_mismatch = + | Label_mismatch of record_change list + | Unboxed_float_representation of position + +type constructor_mismatch = + | Type of Errortrace.equality_error + | Arity + | Inline_record of record_change list + | Kind of position + | Explicit_return_type of position + +type extension_constructor_mismatch = + | Constructor_privacy + | Constructor_mismatch of Ident.t + * Types.extension_constructor + * Types.extension_constructor + * constructor_mismatch + +type private_variant_mismatch = + | Only_outer_closed (* It's only dangerous in one direction *) + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type variant_change = + (Types.constructor_declaration as 'l, 'l, constructor_mismatch) + Diffing_with_keys.change + +type type_mismatch = + | Arity + | Privacy of privacy_mismatch + | Kind of kind_mismatch + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | 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_change list + | Unboxed_representation of position + | Immediate of Type_immediacy.Violation.t + +let report_primitive_mismatch first second ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : primitive_mismatch) with + | Name -> + pr "The names of the primitives are not the same" + | Arity -> + pr "The syntactic arities of these primitives were not the same.@ \ + (They must have the same number of arrows present in the source.)" + | No_alloc ord -> + pr "%s primitive is [@@@@noalloc] but %s is not" + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + | Native_name -> + pr "The native names of the primitives are not the same" + | Result_repr -> + pr "The two primitives' results have different representations" + | Argument_repr n -> + pr "The two primitives' %d%s arguments have different representations" + n (Misc.ordinal_suffix n) + +let report_value_mismatch first second env ppf err = + let pr fmt = Format.fprintf ppf fmt in + pr "@ "; + match (err : value_mismatch) with + | Primitive_mismatch pm -> + report_primitive_mismatch first second ppf pm + | Not_a_primitive -> + pr "The implementation is not a primitive." + | Type trace -> + Printtyp.report_moregen_error ppf Type_scheme env trace + (fun ppf -> Format.fprintf ppf "The type") + (fun ppf -> Format.fprintf ppf "is not compatible with the type") + +let report_type_inequality env ppf err = + Printtyp.report_equality_error ppf Type_scheme env err + (fun ppf -> Format.fprintf ppf "The type") + (fun ppf -> Format.fprintf ppf "is not equal to the type") + +let report_privacy_mismatch ppf err = + let singular, item = + match err with + | Private_type_abbreviation -> true, "type abbreviation" + | Private_variant_type -> false, "variant constructor(s)" + | Private_record_type -> true, "record constructor" + | Private_extensible_variant -> true, "extensible variant" + | Private_row_type -> true, "row type" + in Format.fprintf ppf "%s %s would be revealed." + (if singular then "A private" else "Private") + item + +let report_label_mismatch first second env ppf err = + match (err : label_mismatch) with + | Type err -> + report_type_inequality env ppf err + | Mutability ord -> + Format.fprintf ppf "%s is mutable and %s is not." + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + +let pp_record_diff first second prefix decl env ppf (x : record_change) = + match x with + | Delete cd -> + Format.fprintf ppf "%aAn extra field, %s, is provided in %s %s." + prefix x (Ident.name cd.delete.ld_id) first decl + | Insert cd -> + Format.fprintf ppf "%aA field, %s, is missing in %s %s." + prefix x (Ident.name cd.insert.ld_id) first decl + | Change Type {got=lbl1; expected=lbl2; reason} -> + Format.fprintf ppf + "@[%aFields do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + Printtyp.label lbl1 + Printtyp.label lbl2 + (report_label_mismatch first second env) reason + | Change Name n -> + Format.fprintf ppf "%aFields have different names, %s and %s." + prefix x n.got n.expected + | Swap sw -> + Format.fprintf ppf "%aFields %s and %s have been swapped." + prefix x sw.first sw.last + | Move {name; got; expected } -> + Format.fprintf ppf + "@[<2>%aField %s has been moved@ from@ position %d@ to %d.@]" + prefix x name expected got + +let report_patch pr_diff first second decl env ppf patch = + let nl ppf () = Format.fprintf ppf "@," in + let no_prefix _ppf _ = () in + match patch with + | [ elt ] -> + Format.fprintf ppf "@[%a@]" + (pr_diff first second no_prefix decl env) elt + | _ -> + let pp_diff = pr_diff first second Diffing_with_keys.prefix decl env in + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list ~pp_sep:nl pp_diff) patch + +let report_record_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match err with + | Label_mismatch patch -> + report_patch pp_record_diff first second decl env ppf patch + | Unboxed_float_representation ord -> + pr "@[Their internal representations differ:@ %s %s %s.@]" + (choose ord first second) decl + "uses unboxed float representation" + +let report_constructor_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : constructor_mismatch) with + | Type err -> report_type_inequality env ppf err + | Arity -> pr "They have different arities." + | Inline_record err -> + report_patch pp_record_diff first second decl env 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 pp_variant_diff first second prefix decl env ppf (x : variant_change) = + match x with + | Delete cd -> + Format.fprintf ppf "%aAn extra constructor, %s, is provided in %s %s." + prefix x (Ident.name cd.delete.cd_id) first decl + | Insert cd -> + Format.fprintf ppf "%aA constructor, %s, is missing in %s %s." + prefix x (Ident.name cd.insert.cd_id) first decl + | Change Type {got; expected; reason} -> + Format.fprintf ppf + "@[%aConstructors do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + Printtyp.constructor got + Printtyp.constructor expected + (report_constructor_mismatch first second decl env) reason + | Change Name n -> + Format.fprintf ppf + "%aConstructors have different names, %s and %s." + prefix x n.got n.expected + | Swap sw -> + Format.fprintf ppf + "%aConstructors %s and %s have been swapped." + prefix x sw.first sw.last + | Move {name; got; expected} -> + Format.fprintf ppf + "@[<2>%aConstructor %s has been moved@ from@ position %d@ to %d.@]" + prefix x name expected got + +let report_extension_constructor_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : extension_constructor_mismatch) with + | Constructor_privacy -> + pr "Private extension constructor(s) would be revealed." + | Constructor_mismatch (id, ext1, ext2, err) -> + pr "@[Constructors do not match:@;<1 2>%a@ is not the same as:\ + @;<1 2>%a@ %a@]" + (Printtyp.extension_only_constructor id) ext1 + (Printtyp.extension_only_constructor id) ext2 + (report_constructor_mismatch first second decl env) err + +let report_private_variant_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : private_variant_mismatch) with + | Only_outer_closed -> + (* It's only dangerous in one direction, so we don't have a position *) + pr "%s is private and closed, but %s is not closed" + (String.capitalize_ascii second) first + | Missing (ord, name) -> + pr "The constructor %s is only present in %s %s." + name (choose ord first second) decl + | Presence s -> + pr "The tag `%s is present in the %s %s,@ but might not be in the %s" + s second decl first + | Incompatible_types_for s -> pr "Types for tag `%s are incompatible" s + | Types err -> + report_type_inequality env ppf err + +let report_private_object_mismatch env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : private_object_mismatch) with + | Missing s -> pr "The implementation is missing the method %s" s + | Types err -> report_type_inequality env ppf err + +let report_kind_mismatch first second ppf (kind1, kind2) = + let pr fmt = Format.fprintf ppf fmt in + let kind_to_string = function + | Kind_abstract -> "abstract" + | Kind_record -> "a record" + | Kind_variant -> "a variant" + | Kind_open -> "an extensible variant" in + pr "%s is %s, but %s is %s." + (String.capitalize_ascii first) + (kind_to_string kind1) + second + (kind_to_string kind2) + +let report_type_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + pr "@ "; + match err with + | Arity -> + pr "They have different arities." + | Privacy err -> + report_privacy_mismatch ppf err + | Kind err -> + report_kind_mismatch first second ppf err + | Constraint err -> + (* This error can come from implicit parameter disagreement or from + explicit `constraint`s. Both affect the parameters, hence this choice + of explanatory text *) + pr "Their parameters differ@,"; + report_type_inequality env ppf err + | Manifest err -> + report_type_inequality env ppf err + | Private_variant (_ty1, _ty2, mismatch) -> + report_private_variant_mismatch first second decl env ppf mismatch + | Private_object (_ty1, _ty2, mismatch) -> + report_private_object_mismatch env ppf mismatch + | Variance -> + pr "Their variances do not agree." + | Record_mismatch err -> + report_record_mismatch first second decl env ppf err + | Variant_mismatch err -> + report_patch pp_variant_diff first second decl env 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 + +module Record_diffing = struct + + let 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 + 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 err -> + Some (Type err : label_mismatch) + | () -> None + + let rec equal ~loc env params1 params2 + (labels1 : Types.label_declaration list) + (labels2 : Types.label_declaration list) = + match labels1, labels2 with + | [], [] -> true + | _ :: _ , [] | [], _ :: _ -> false + | ld1 :: rem1, ld2 :: rem2 -> + if Ident.name ld1.ld_id <> Ident.name ld2.ld_id + then false + 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 _ -> false + (* add arguments to the parameters, cf. PR#7378 *) + | None -> + equal ~loc env + (ld1.ld_type::params1) (ld2.ld_type::params2) + rem1 rem2 + end + + module Defs = struct + type left = Types.label_declaration + type right = left + type diff = label_mismatch + type state = type_expr list * type_expr list + end + module Diff = Diffing_with_keys.Define(Defs) + + let update (d:Diff.change) (params1,params2 as st) = + match d with + | Insert _ | Change _ | Delete _ -> st + | Keep (x,y,_) -> + (* We need to add equality between existential type parameters + (in inline records) *) + x.data.ld_type::params1, y.data.ld_type::params2 + + let test _loc env (params1,params2) + ({pos; data=lbl1}: Diff.left) + ({data=lbl2; _ }: Diff.right) + = + let name1, name2 = Ident.name lbl1.ld_id, Ident.name lbl2.ld_id in + if name1 <> name2 then + let types_match = + match compare_labels env params1 params2 lbl1 lbl2 with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_labels env params1 params2 lbl1 lbl2 with + | Some reason -> + Error ( + Diffing_with_keys.Type {pos; got=lbl1; expected=lbl2; reason} + ) + | None -> Ok () + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name t ) -> + if t.types_match then 10 else 15 + | Change _ -> 10 + + + + let key (x: Defs.left) = Ident.name x.ld_id + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let module Compute = Diff.Simple(struct + let key_left = key + let key_right = key + let update = update + let test = test loc env + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + + let compare_with_representation ~loc env params1 params2 l r rep1 rep2 = + if not (equal ~loc env params1 params2 l r) then + let patch = diffing loc env params1 params2 l r in + Some (Record_mismatch (Label_mismatch patch)) + else + 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 + +end + + +module Variant_diffing = struct + + let 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 err -> Some (Type err) + | () -> None + end + | Types.Cstr_record l1, Types.Cstr_record l2 -> + Option.map + (fun rec_err -> Inline_record rec_err) + (Record_diffing.compare env ~loc params1 params2 l1 l2) + | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch) + | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch) + + let 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 err -> Some (Type err) + | () -> 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 + + let equal ~loc env params1 params2 + (cstrs1 : Types.constructor_declaration list) + (cstrs2 : Types.constructor_declaration list) = + List.length cstrs1 = List.length cstrs2 && + List.for_all2 (fun (cd1:Types.constructor_declaration) + (cd2:Types.constructor_declaration) -> + Ident.name cd1.cd_id = Ident.name cd2.cd_id + && + 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 _ -> false + | None -> true + end) cstrs1 cstrs2 + + module Defs = struct + type left = Types.constructor_declaration + type right = left + type diff = constructor_mismatch + type state = type_expr list * type_expr list + end + module D = Diffing_with_keys.Define(Defs) + + let update _ st = st + + let weight: D.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name t) -> + if t.types_match then 10 else 15 + | Change _ -> 10 + + + let test loc env (params1,params2) + ({pos; data=cd1}: D.left) + ({data=cd2; _}: D.right) = + let name1, name2 = Ident.name cd1.cd_id, Ident.name cd2.cd_id in + if name1 <> name2 then + let types_match = + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some reason -> + Error (Diffing_with_keys.Type {pos; got=cd1; expected=cd2; reason}) + | None -> Ok () + + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let key (x:Defs.left) = Ident.name x.cd_id in + let module Compute = D.Simple(struct + let key_left = key + let key_right = key + let test = test loc env + let update = update + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + let compare_with_representation ~loc env params1 params2 + cstrs1 cstrs2 rep1 rep2 + = + let err = compare ~loc env params1 params2 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) +end + +(* Inclusion between "private" annotations *) +let privacy_mismatch env decl1 decl2 = + match decl1.type_private, decl2.type_private with + | Private, Public -> begin + match decl1.type_kind, decl2.type_kind with + | Type_record _, Type_record _ -> Some Private_record_type + | Type_variant _, Type_variant _ -> Some Private_variant_type + | Type_open, Type_open -> Some Private_extensible_variant + | Type_abstract, Type_abstract + when Option.is_some decl2.type_manifest -> begin + match decl1.type_manifest with + | Some ty1 -> begin + let ty1 = Ctype.expand_head env ty1 in + match get_desc ty1 with + | Tvariant row when Btype.is_constr_row ~allow_ident:true + (row_more row) -> + Some Private_row_type + | Tobject (fi, _) when Btype.is_constr_row ~allow_ident:true + (snd (Ctype.flatten_fields fi)) -> + Some Private_row_type + | _ -> + Some Private_type_abbreviation + end + | None -> + None + end + | _, _ -> + None + end + | _, _ -> + None + +let private_variant env row1 params1 row2 params2 = + let r1, r2, pairs = + Ctype.merge_row_fields (row_fields row1) (row_fields row2) + in + let row1_closed = row_closed row1 in + let row2_closed = row_closed row2 in + let err = + if row2_closed && not row1_closed then Some Only_outer_closed + else begin + match row2_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 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 err -> + Some (Types err : private_variant_mismatch) + | () -> None + end + | (s, f1, f2) :: pairs -> begin + match row_field_repr f1, 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 err -> Some (Types err) + | () -> None + end + +let type_manifest env ty1 params1 ty2 params2 priv2 kind2 = + let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in + match get_desc ty1', get_desc ty2' with + | Tvariant row1, Tvariant row2 + when is_absrow env (row_more row2) -> begin + assert (Ctype.is_equal env true (ty1::params1) (row_more row2::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 + let is_private_abbrev_2 = + match priv2, kind2 with + | Private, Type_abstract -> begin + (* Same checks as the [when] guards from above, inverted *) + match get_desc ty2' with + | Tvariant row -> + not (is_absrow env (row_more row)) + | Tobject (fi, _) -> + not (is_absrow env (snd (Ctype.flatten_fields fi))) + | _ -> true + end + | _, _ -> false + in + match + if is_private_abbrev_2 then + Ctype.equal_private env params1 ty1 params2 ty2 + else + Ctype.equal env true (params1 @ [ty1]) (params2 @ [ty2]) + with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> 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 + let err = + match privacy_mismatch env decl1 decl2 with + | Some err -> Some (Privacy err) + | None -> None + in + if err <> None then err 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 err -> Some (Constraint err) + | () -> None + end + | (Some ty1, Some ty2) -> + type_manifest env ty1 decl1.type_params ty2 decl2.type_params + decl2.type_private decl2.type_kind + | (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 err -> Some (Constraint err) + | () -> + match Ctype.equal env false [ty1] [ty2] with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> 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; + Variant_diffing.compare_with_representation ~loc env + decl1.type_params + decl2.type_params + 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; + Record_diffing.compare_with_representation ~loc env + decl1.type_params decl2.type_params + labels1 labels2 + rep1 rep2 + | (Type_open, Type_open) -> None + | (_, _) -> Some (Kind (of_kind decl1.type_kind, of_kind decl2.type_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 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,j1) = get_lower v1 and (p2,n2,j2) = get_lower v2 in + imp abstr (imp p2 p1 && imp n2 n1 && 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 err -> + Some (Constructor_mismatch (id, ext1, ext2, Type err)) + | () -> + let r = + Variant_diffing.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_501/typing/includecore.mli b/upstream/ocaml_501/typing/includecore.mli new file mode 100644 index 0000000000..50825976ce --- /dev/null +++ b/upstream/ocaml_501/typing/includecore.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. *) +(* *) +(**************************************************************************) + +(* 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 Errortrace.moregen_error + +exception Dont_match of value_mismatch + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type type_kind = + | Kind_abstract + | Kind_record + | Kind_variant + | Kind_open + +type kind_mismatch = type_kind * type_kind + +type label_mismatch = + | Type of Errortrace.equality_error + | Mutability of position + +type record_change = + (Types.label_declaration as 'ld, 'ld, label_mismatch) Diffing_with_keys.change + +type record_mismatch = + | Label_mismatch of record_change list + | Unboxed_float_representation of position + +type constructor_mismatch = + | Type of Errortrace.equality_error + | Arity + | Inline_record of record_change list + | Kind of position + | Explicit_return_type of position + +type extension_constructor_mismatch = + | Constructor_privacy + | Constructor_mismatch of Ident.t + * extension_constructor + * extension_constructor + * constructor_mismatch +type variant_change = + (Types.constructor_declaration as 'cd, 'cd, constructor_mismatch) + Diffing_with_keys.change + +type private_variant_mismatch = + | Only_outer_closed + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type type_mismatch = + | Arity + | Privacy of privacy_mismatch + | Kind of kind_mismatch + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | 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_change list + | 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_value_mismatch : + string -> string -> + Env.t -> + Format.formatter -> value_mismatch -> unit + +val report_type_mismatch : + string -> string -> string -> + Env.t -> + Format.formatter -> type_mismatch -> unit + +val report_extension_constructor_mismatch : + string -> string -> string -> + Env.t -> + Format.formatter -> extension_constructor_mismatch -> unit diff --git a/upstream/ocaml_501/typing/includemod.ml b/upstream/ocaml_501/typing/includemod.ml new file mode 100644 index 0000000000..150bfc8e1e --- /dev/null +++ b/upstream/ocaml_501/typing/includemod.ml @@ -0,0 +1,1239 @@ +(**************************************************************************) +(* *) +(* 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 + | Empty_struct + (** For backward compatibility's sake, an empty struct can be implicitly + converted to an unit module *) + + 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, Includecore.value_mismatch) 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; + leftovers: (signature_item * signature_item * int) 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 (diff vd1 vd2 err))) + +(* 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 ~strengthen env path = + match + if strengthen then Env.find_strengthened_module ~aliasable:true path env + else (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 ~strengthen:false 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. *) + +(* When computing a signature difference, we need to distinguish between + recoverable errors at the value level and unrecoverable errors at the type + level that require us to stop the computation of the difference due to + incoherent types. +*) +type 'a recoverable_error = { error: 'a; recoverable:bool } +let mark_error_as_recoverable r = + Result.map_error (fun error -> { error; recoverable=true}) r +let mark_error_as_unrecoverable r = + Result.map_error (fun error -> { error; recoverable=false}) r + + +module Sign_diff = struct + type t = { + runtime_coercions: (int * Typedtree.module_coercion) list; + shape_map: Shape.Map.t; + deep_modifications:bool; + errors: (Ident.t * Error.sigitem_symptom) list; + leftovers: ((Types.signature_item as 'it) * 'it * int) list + } + + let empty = { + runtime_coercions = []; + shape_map = Shape.Map.empty; + deep_modifications = false; + errors = []; + leftovers = [] + } + + let merge x y = + { + runtime_coercions = x.runtime_coercions @ y.runtime_coercions; + shape_map = y.shape_map; + (* the shape map is threaded the map during the difference computation, + the last shape map contains all previous elements. *) + deep_modifications = x.deep_modifications || y.deep_modifications; + errors = x.errors @ y.errors; + leftovers = x.leftovers @ y.leftovers + } +end + +(** + In the group of mutual functions below, the [~in_eq] argument is [true] when + we are in fact checking equality of module types. + + The module subtyping relation [A <: B] checks that [A.T = B.T] when [A] + and [B] define a module type [T]. The relation [A.T = B.T] is equivalent + to [(A.T <: B.T) and (B.T <: A.T)], but checking both recursively would lead + to an exponential slowdown (see #10598 and #10616). + To avoid this issue, when [~in_eq] is [true], we compute a coarser relation + [A << B] which is the same as [A <: B] except that module types [T] are + checked only for [A.T << B.T] and not the reverse. + Thus, we can implement a cheap module type equality check [A.T = B.T] by + computing [(A.T << B.T) and (B.T << A.T)], avoiding the exponential slowdown + described above. +*) + +let rec modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape = + match try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape 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 ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = + 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, orig_shape) + | (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 ~strengthen:false env p1 with + | Error e -> Error (Error.Mt_core e) + | Ok mty1 -> + match strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark + subst mty1 p1 mty2 orig_shape + 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, orig_shape) + else + begin match expand_modtype_path env p1, expand_modtype_path env p2 with + | Some mty1, Some mty2 -> + try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape + | 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 ~in_eq ~loc env ~mark subst p1 mty2 orig_shape + | 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 ~in_eq ~loc env ~mark subst mty1 p2 orig_shape + | 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 ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape + 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 ~in_eq ~loc env ~mark:(negate_mark mark) + subst param1 param2 + in + let var, res_shape = + match Shape.decompose_abs orig_shape with + | Some (var, res_shape) -> var, res_shape + | None -> + (* Using a fresh variable with a placeholder uid here is fine: users + will never try to jump to the definition of that variable. + If they try to jump to the parameter from inside the functor, + they will use the variable shape that is stored in the local + environment. *) + let var, shape_var = + Shape.fresh_var Uid.internal_not_actually_unique + in + var, Shape.app orig_shape ~arg:shape_var + in + let cc_res = modtypes ~in_eq ~loc env ~mark subst res1 res2 res_shape in + begin match cc_arg, cc_res with + | Ok Tcoerce_none, Ok (Tcoerce_none, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_none, final_shape) + | Ok cc_arg, Ok (cc_res, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_functor(cc_arg, cc_res), final_shape) + | _, 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 ~in_eq ~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 ~in_eq ~loc env ~mark Subst.identity arg2' arg1 + Shape.dummy_mod + with + | Ok (cc, _) -> Ok cc + | Error err -> Error (Error.Mismatch err) + in + let env, subst = equate_one_functor_param subst env arg2' name1 name2 in + cc_arg, env, subst + | _, _ -> + Error (Error.Incompatible_params (param1, param2)), env, subst + +and equate_one_functor_param subst env arg2' name1 name2 = + match name1, name2 with + | Some id1, Some id2 -> + (* two matching abstract parameters: we add one identifier to the + environment and record the equality between the two identifiers + in the substitution *) + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | None, Some id2 -> + let id1 = Ident.rename id2 in + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | Some id1, None -> + Env.add_module id1 Mp_present arg2' env, subst + | None, None -> + env, subst + +and strengthened_modtypes ~in_eq ~loc ~aliasable env ~mark + subst mty1 path1 mty2 shape = + match mty1, mty2 with + | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> + Ok (Tcoerce_none, shape) + | _, _ -> + let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in + modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape + +and strengthened_module_decl ~loc ~aliasable env ~mark + subst md1 path1 md2 shape = + 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, shape) + | _, _ -> + let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in + modtypes ~in_eq:false ~loc env ~mark subst md1.md_type md2.md_type shape + +(* Inclusion between signatures *) + +and signatures ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = + (* 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 nb_exported pos tbl = function + [] -> nb_exported, pos, tbl + | item :: rem -> + let pos, nextpos = + if is_runtime_component item then pos, pos + 1 + else -1, pos + in + match item_visibility item with + | Hidden -> + (* do not pair private items. *) + build_component_table nb_exported nextpos tbl rem + | Exported -> + let (id, _loc, name) = item_ident_name item in + build_component_table (nb_exported + 1) nextpos + (FieldMap.add name (id, item, pos) tbl) rem + in + let exported_len1, runtime_len1, comps1 = + build_component_table 0 0 FieldMap.empty sig1 + in + let exported_len2, runtime_len2 = + List.fold_left (fun (el, rl) i -> + let el = match item_visibility i with Hidden -> el | Exported -> el + 1 in + let rl = if is_runtime_component i then rl + 1 else rl in + el, rl + ) (0, 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 open Sign_diff in + let d = + signature_components ~in_eq ~loc env ~mark new_env subst mod_shape + Shape.Map.empty + (List.rev paired) + in + begin match unpaired, d.errors, d.runtime_coercions, d.leftovers with + | [], [], cc, [] -> + let shape = + if not d.deep_modifications && exported_len1 = exported_len2 + then mod_shape + else Shape.str ?uid:mod_shape.Shape.uid d.shape_map + in + if runtime_len1 = runtime_len2 then (* see PR#5098 *) + Ok (simplify_structure_coercion cc id_pos_list, shape) + else + Ok (Tcoerce_structure (cc, id_pos_list), shape) + | missings, incompatibles, runtime_coercions, leftovers -> + Error { + Error.env=new_env; + missings; + incompatibles; + oks=runtime_coercions; + leftovers; + } + 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 match FieldMap.find name2 comps1 with + | (id1, item1, pos1) -> + 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 + | exception 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 ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map paired = + match paired with + | [] -> Sign_diff.{ empty with shape_map } + | (sigi1, sigi2, pos) :: rem -> + let shape_modified = ref false in + let id, item, shape_map, 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 item = mark_error_as_recoverable item in + let present_at_runtime = match valdecl2.val_kind with + | Val_prim _ -> false + | _ -> true + in + let shape_map = Shape.Map.add_value_proj shape_map id1 orig_shape in + id1, item, shape_map, 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 + let item = mark_error_as_unrecoverable item in + let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in + id1, item, shape_map, false + | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> + let item = + extension_constructors ~loc env ~mark subst id1 ext1 ext2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_extcons_proj shape_map id1 orig_shape + in + id1, item, shape_map, true + | Sig_module(id1, pres1, mty1, _, _), Sig_module(_, pres2, mty2, _, _) + -> begin + let orig_shape = + Shape.(proj orig_shape (Item.module_ id1)) + in + let item = + module_declarations ~in_eq ~loc env ~mark subst id1 mty1 mty2 + orig_shape + in + let item, shape_map = + match item with + | Ok (cc, shape) -> + if shape != orig_shape then shape_modified := true; + let mod_shape = Shape.set_uid_if_none shape mty1.md_uid in + Ok cc, Shape.Map.add_module shape_map id1 mod_shape + | Error diff -> + Error (Error.Module_type diff), + (* We add the original shape to the map, even though + there is a type error. + It could still be useful for merlin. *) + Shape.Map.add_module shape_map id1 orig_shape + 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 + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, present_at_runtime + end + | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) -> + let item = + modtype_infos ~in_eq ~loc env ~mark subst id1 info1 info2 + in + let shape_map = + Shape.Map.add_module_type_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, false + | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) -> + let item = + class_declarations ~old_env env subst decl1 decl2 + in + let shape_map = + Shape.Map.add_class_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, true + | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) -> + let item = + class_type_declarations ~loc ~old_env env subst info1 info2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_class_type_proj shape_map id1 orig_shape + in + id1, item, shape_map, false + | _ -> + assert false + in + let deep_modifications = !shape_modified in + let first = + match item with + | Ok x -> + let runtime_coercions = + if present_at_runtime then [pos,x] else [] + in + Sign_diff.{ empty with deep_modifications; runtime_coercions } + | Error { error; recoverable=_ } -> + Sign_diff.{ empty with errors=[id,error]; deep_modifications } + in + let continue = match item with + | Ok _ -> true + | Error x -> x.recoverable + in + let rest = + if continue then + signature_components ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map rem + else Sign_diff.{ empty with leftovers=rem } + in + Sign_diff.merge first rest + +and module_declarations ~in_eq ~loc env ~mark subst id1 md1 md2 orig_shape = + 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 ~in_eq ~loc ~aliasable:true env ~mark subst + md1.md_type p1 md2.md_type orig_shape + +(* Inclusion between module type specifications *) + +and modtype_infos ~in_eq ~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 ~in_eq ~loc env ~mark mty1 mty2 + | (None, Some mty2) -> + let mty1 = Mty_ident(Path.Pident id) in + check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 in + match r with + | Ok _ as ok -> ok + | Error e -> Error Error.(Module_type_declaration (diff info1 info2 e)) + +and check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 = + let c1 = + modtypes ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2 Shape.dummy_mod + in + let c2 = + (* For nested module type paths, we check only one side of the equivalence: + the outer module type is the one responsible for checking the other side + of the equivalence. + *) + if in_eq then None + else + let mark = negate_mark mark in + Some ( + modtypes ~in_eq:true ~loc env ~mark Subst.identity + mty2 mty1 Shape.dummy_mod + ) + in + match c1, c2 with + | Ok (Tcoerce_none, _), (Some Ok (Tcoerce_none, _)|None) -> Ok Tcoerce_none + | Ok (c1, _), (Some Ok _ | None) -> + (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." + print_coercion _c1 print_coercion _c2; *) + Error Error.(Illegal_permutation c1) + | Ok _, Some Error e -> Error Error.(Not_greater_than e) + | Error e, (Some Ok _ | None) -> Error Error.(Not_less_than e) + | Error less_than, Some 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, _) | Path.Pextra_ty (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 ~in_eq:false ~loc ~aliasable env ~mark:Mark_both + Subst.identity mty1 path1 mty2 Shape.dummy_mod + |> Result.map fst + +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 unit_shape = + match + signatures ~in_eq:false ~loc:(Location.in_file impl_name) env ~mark + Subst.identity impl_sig intf_sig unit_shape + 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 + + module Defs = struct + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state = { + res: module_type option; + env: Env.t; + subst: Subst.t; + } + end + open Defs + + module Diff = Diffing.Define(Defs) + + let param_name = function + | Named(x,_) -> x + | Unit -> None + + let weight: Diff.change -> _ = 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 + + + + 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 + + (* Whenever we have a named parameter that doesn't match it anonymous + counterpart, we add it to the typing environment because it may + contain useful abbreviations, but without adding any equations *) + let bind id arg state = + let arg' = Subst.modtype Keep state.subst arg in + let env = Env.add_module id Mp_present arg' state.env in + { state with env } + + let rec update (d:Diff.change) st = + match d with + | Insert (Unit | Named (None,_)) + | Delete (Unit | Named (None,_)) + | Keep (Unit,_,_) + | Keep (_,Unit,_) -> + (* No named abstract parameters: we keep the same environment *) + st, [||] + | Insert (Named (Some id, arg)) | Delete (Named (Some id, arg)) -> + (* one named parameter to bind *) + st |> bind id arg |> expand_params + | Change (delete, insert, _) -> + (* Change should be delete + insert: we add both abstract parameters + to the environment without equating them. *) + let st, _expansion = update (Diffing.Delete delete) st in + update (Diffing.Insert insert) st + | Keep (Named (name1, _), Named (name2, arg2), _) -> + let arg = Subst.modtype Keep st.subst arg2 in + let env, subst = + equate_one_functor_param st.subst st.env arg name1 name2 + in + expand_params { st with env; subst } + + let diff env (l1,res1) (l2,_) = + let module Compute = Diff.Left_variadic(struct + let test st mty1 mty2 = + let loc = Location.none in + let res, _, _ = + functor_param ~in_eq:false ~loc st.env ~mark:Mark_neither + st.subst mty1 mty2 + in + res + let update = update + let weight = weight + end) + 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 + Compute.diff state param1 param2 + +end + +module Functor_app_diff = struct + module I = Functor_inclusion_diff + module Defs= struct + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state = I.Defs.state + end + module Diff = Diffing.Define(Defs) + + let weight: Diff.change -> _ = 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 | Empty_struct | 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 | Empty_struct | Anonymous), Some _ -> 1 + end + + let update (d: Diff.change) (st:Defs.state) = + let open Error in + match d with + | Insert (Unit|Named(None,_)) + | Delete _ (* delete is a concrete argument, not an abstract parameter*) + | Keep ((Unit,_),_,_) (* Keep(Unit,_) implies Keep(Unit,Unit) *) + | Keep (_,(Unit|Named(None,_)),_) + | Change (_,(Unit|Named (None,_)), _ ) -> + (* no abstract parameters to add, nor any equations *) + st, [||] + | Insert(Named(Some param, param_ty)) + | Change(_, Named(Some param, param_ty), _ ) -> + (* Change is Delete + Insert: we add the Inserted parameter to the + environnement to track equalities with external components that the + parameter might add. *) + let mty = Subst.modtype Keep st.subst param_ty in + let env = Env.add_module ~arg:true param Mp_present mty st.env in + I.expand_params { st with env } + | Keep ((Named arg, _mty) , Named (Some param, _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 } + | Keep (((Anonymous|Empty_struct), mty), + Named (Some param, _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} + + let diff env ~f ~args = + let params, res = retrieve_functor_params env f in + let module Compute = Diff.Right_variadic(struct + let update = update + let test (state:Defs.state) (arg,arg_mty) param = + let loc = Location.none in + let res = match (arg:Error.functor_arg_descr), param with + | (Unit|Empty_struct), Unit -> Ok Tcoerce_none + | Unit, Named _ | (Anonymous | Named _), Unit -> + Result.Error (Error.Incompatible_params(arg,param)) + | ( Anonymous | Named _ | Empty_struct ), Named (_, param) -> + match + modtypes ~in_eq:false ~loc state.env ~mark:Mark_neither + state.subst arg_mty param Shape.dummy_mod + with + | Error mty -> Result.Error (Error.Mismatch mty) + | Ok (cc, _) -> Ok cc + in + res + let weight = weight + end) + in + let args = Array.of_list args in + let params = Array.of_list params in + let state : Defs.state = + { env; subst = Subst.identity; res = I.keep_expansible_param res } + in + Compute.diff state args params + +end + +(* Hide the context and substitution parameters to the outside world *) + +let modtypes_with_shape ~shape ~loc env ~mark mty1 mty2 = + match modtypes ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 shape + with + | Ok (cc, shape) -> cc, shape + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let modtypes ~loc env ~mark mty1 mty2 = + match modtypes ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let signatures env ~mark sig1 sig2 = + match signatures ~in_eq:false ~loc:Location.none env ~mark + Subst.identity sig1 sig2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | 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 Shape.dummy_mod with + | Ok (x, _shape) -> x + | Error mdiff -> + raise (Error(env,Error.(In_Module_type mdiff))) + +let expand_module_alias ~strengthen env path = + match expand_module_alias ~strengthen 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 ~in_eq:false ~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_501/typing/includemod.mli b/upstream/ocaml_501/typing/includemod.mli new file mode 100644 index 0000000000..d5b2ee9a13 --- /dev/null +++ b/upstream/ocaml_501/typing/includemod.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. *) +(* *) +(**************************************************************************) + +(* 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 + | Empty_struct + (** For backward compatibility's sake, an empty struct can be implicitly + converted to an unit module. *) + + type core_sigitem_symptom = + | Value_descriptions of + (Types.value_description, Includecore.value_mismatch) 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; + leftovers: ((Types.signature_item as 'it) * 'it * int) list + (** signature items that could not be compared due to type divergence *) + } + 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 modtypes_with_shape: + shape:Shape.t -> loc:Location.t -> Env.t -> mark:mark -> + module_type -> module_type -> module_coercion * Shape.t + +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 -> Shape.t -> module_coercion * Shape.t + +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: strengthen:bool -> Env.t -> Path.t -> Types.module_type + +module Functor_inclusion_diff: sig + module Defs: sig + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state + end + val diff: Env.t -> + Types.functor_parameter list * Types.module_type -> + Types.functor_parameter list * Types.module_type -> + Diffing.Define(Defs).patch +end + +module Functor_app_diff: sig + module Defs: sig + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state + end + val diff: + Env.t -> + f:Types.module_type -> + args:(Error.functor_arg_descr * Types.module_type) list -> + Diffing.Define(Defs).patch +end diff --git a/upstream/ocaml_501/typing/includemod_errorprinter.ml b/upstream/ocaml_501/typing/includemod_errorprinter.ml new file mode 100644 index 0000000000..e83dfa7ae2 --- /dev/null +++ b/upstream/ocaml_501/typing/includemod_errorprinter.ml @@ -0,0 +1,940 @@ +(**************************************************************************) +(* *) +(* 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 "" + 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 "@[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 "@[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 + "@[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 *) + open Diffing + 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 + | Insert mty -> + Insert (add_shorthand Expected pos mty) + | Delete mty -> + Delete (add_shorthand (elide_if_app ctx Got) pos mty) + | Change (g, e, p) -> + Change + (add_shorthand Got pos g, + add_shorthand Expected pos e, p) + | Keep (g, e, p) -> + 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 "()" + | Empty_struct -> Format.dprintf "(struct end)" + | 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 "()" + | Empty_struct -> Format.dprintf "(struct end)" + | 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 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 = Diffing.(style @@ classify 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: _ Diffing.change -> _ = function + | Insert mty + | Keep(_,mty,_) + | Change (_,mty,_) as x -> + Some (param_id mty,(x, mty)) + | 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: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (param_id mty,(x,mty)) + | 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: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (None,(x,mty)) + | 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" + | Empty_struct -> + (* an empty structure can be used in both applicative and generative + context *) + assert false + end + + let subcase sub ~expansion_token env (pos, diff) = + Location.msg "%a%a%a%a@[%t@]%a" + Format.pp_print_tab () + Format.pp_open_tbox () + Diffing.prefix (pos, Diffing.classify 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@[%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 env id x = + match x with + | Err.Value_descriptions diff -> + Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + "Values do not match" + !Oprint.out_sig_item + (Printtyp.tree_of_value_description id diff.got) + "is not included in" + !Oprint.out_sig_item + (Printtyp.tree_of_value_description id diff.expected) + (Includecore.report_value_mismatch + "the first" "the second" env) diff.symptom + show_locs (diff.got.val_loc, diff.expected.val_loc) + Printtyp.Conflicts.print_explanations + | Err.Type_declarations diff -> + Format.dprintf "@[@[%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" env) diff.symptom + show_locs (diff.got.type_loc, diff.expected.type_loc) + Printtyp.Conflicts.print_explanations + | Err.Extension_constructors diff -> + Format.dprintf "@[@[%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" env) diff.symptom + show_locs (diff.got.ext_loc, diff.expected.ext_loc) + Printtyp.Conflicts.print_explanations + | Err.Class_type_declarations diff -> + Format.dprintf + "@[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 Type_scheme) 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 + "@[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 Type_scheme) 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 + "@[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 + "@[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 + "@[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 = + match diff.symptom with + | Mt_core _ -> + (* In those cases, the refined error messages for the current error + will at most add some minor comments on the current error. + It is thus better to avoid eliding the current error message. + *) + dwith_context ctx (inner diff) + | _ -> 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 + "@[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 env 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 (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.Inclusion.insert mty + | Delete mty -> Functor_suberror.Inclusion.delete mty + | Keep (x, y, _) -> Functor_suberror.Inclusion.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.Inclusion.incompatible i + | 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 (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.App.insert mty + | Delete mty -> Functor_suberror.App.delete mty + | Keep (x, y, _) -> Functor_suberror.App.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.App.incompatible i + | 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 env 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 *) + | [ _, Change (_, _, Err.Incompatible_params (i,_)) ] -> + Location.errorf ~loc "%t" (Functor_suberror.App.incompatible i) + | [ _, 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 + "@[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_501/typing/includemod_errorprinter.mli b/upstream/ocaml_501/typing/includemod_errorprinter.mli new file mode 100644 index 0000000000..12ea2169b0 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/mtype.ml b/upstream/ocaml_501/typing/mtype.ml new file mode 100644 index 0000000000..9f4832bbe8 --- /dev/null +++ b/upstream/ocaml_501/typing/mtype.ml @@ -0,0 +1,565 @@ +(**************************************************************************) +(* *) +(* 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_lazy env mty = + let open Subst.Lazy in + match mty with + MtyL_ident p -> + begin try + scrape_lazy env (Env.find_modtype_expansion_lazy p env) + with Not_found -> + mty + end + | _ -> mty + +let scrape env mty = + match mty with + Mty_ident p -> + Subst.Lazy.force_modtype (scrape_lazy env (MtyL_ident p)) + | _ -> mty + +let freshen ~scope mty = + Subst.modtype (Rescope scope) Subst.identity mty + +let rec strengthen_lazy ~aliasable env mty p = + let open Subst.Lazy in + match scrape_lazy env mty with + MtyL_signature sg -> + MtyL_signature(strengthen_lazy_sig ~aliasable env sg p) + | MtyL_functor(Named (Some param, arg), res) + when !Clflags.applicative_functors -> + let env = + Env.add_module_lazy ~update_summary:false param Mp_present arg env + in + MtyL_functor(Named (Some param, arg), + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) + | MtyL_functor(Named (None, arg), res) + when !Clflags.applicative_functors -> + let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in + MtyL_functor(Named (Some param, arg), + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) + | mty -> + mty + +and strengthen_lazy_sig' ~aliasable env sg p = + let open Subst.Lazy in + match sg with + [] -> [] + | (SigL_value(_, _, _) as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | SigL_type(id, {type_kind=Type_abstract}, _, _) :: rem + when Btype.is_row_name (Ident.name id) -> + strengthen_lazy_sig' ~aliasable env rem p + | SigL_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 + SigL_type(id, newdecl, rs, vis) :: + strengthen_lazy_sig' ~aliasable env rem p + | (SigL_typext _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | SigL_module(id, pres, md, rs, vis) :: rem -> + let str = + strengthen_lazy_decl ~aliasable env md (Pdot(p, Ident.name id)) + in + let env = + Env.add_module_declaration_lazy ~update_summary:false id pres md env in + SigL_module(id, pres, str, rs, vis) + :: strengthen_lazy_sig' ~aliasable env rem p + (* Need to add the module in case it defines manifest module types *) + | SigL_modtype(id, decl, vis) :: rem -> + let newdecl = + match decl.mtdl_type with + | Some _ when not aliasable -> + (* [not alisable] condition needed because of recursive modules. + See [Typemod.check_recmodule_inclusion]. *) + decl + | _ -> + {decl with mtdl_type = Some(MtyL_ident(Pdot(p,Ident.name id)))} + in + let env = Env.add_modtype_lazy ~update_summary:false id decl env in + SigL_modtype(id, newdecl, vis) :: + strengthen_lazy_sig' ~aliasable env rem p + (* Need to add the module type in case it is manifest *) + | (SigL_class _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | (SigL_class_type _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + +and strengthen_lazy_sig ~aliasable env sg p = + let sg = Subst.Lazy.force_signature_once sg in + let sg = strengthen_lazy_sig' ~aliasable env sg p in + Subst.Lazy.of_signature_items sg + +and strengthen_lazy_decl ~aliasable env md p = + let open Subst.Lazy in + match md.mdl_type with + | MtyL_alias _ -> md + | _ when aliasable -> {md with mdl_type = MtyL_alias p} + | mty -> {md with mdl_type = strengthen_lazy ~aliasable env mty p} + +let () = Env.strengthen := strengthen_lazy + +let strengthen ~aliasable env mty p = + let mty = strengthen_lazy ~aliasable env (Subst.Lazy.of_modtype mty) p in + Subst.Lazy.force_modtype mty + +let strengthen_decl ~aliasable env md p = + let md = strengthen_lazy_decl ~aliasable env + (Subst.Lazy.of_module_decl md) p in + Subst.Lazy.force_module_decl md + +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, _) | Pextra_ty (p, _) + -> Path.Set.add p (get_prefixes p) + +let rec get_arg_paths = function + | Pident _ -> Path.Set.empty + | Pdot (p, _) | Pextra_ty (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)) + | Pextra_ty (p1, extra) -> + let p1' = rollback_path subst p1 in + if Path.same p1 p1' then p + else rollback_path subst (Pextra_ty (p1', extra)) + +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 = + match get_desc ty with + Tvar _ -> + let level = get_level ty in + 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_501/typing/mtype.mli b/upstream/ocaml_501/typing/mtype.mli new file mode 100644 index 0000000000..68d290b36f --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/oprint.ml b/upstream/ocaml_501/typing/oprint.ml new file mode 100644 index 0000000000..b70d1c4b66 --- /dev/null +++ b/upstream/ocaml_501/typing/oprint.ml @@ -0,0 +1,846 @@ +(**************************************************************************) +(* *) +(* 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 maxlen = max maxlen 8 in (* always show a little prefix *) + 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 "" + 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 ty_var ~non_gen ppf s = + pr_var ppf (if non_gen then "_" ^ s else s) + +let pr_vars = + print_list pr_var (fun ppf -> fprintf ppf "@ ") + +let rec print_out_type ppf = + function + | Otyp_alias {non_gen; aliased; alias } -> + fprintf ppf "@[%a@ as %a@]" + print_out_type aliased + (ty_var ~non_gen) alias + | Otyp_poly (sl, ty) -> + fprintf ppf "@[%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 (id, tyl) -> + fprintf ppf "@[%a#%a@]" print_typargs tyl 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; open_row} -> + fprintf ppf "@[<2>< %a >@]" (print_fields open_row) fields + | Otyp_stuff s -> pp_print_string ppf s + | Otyp_var (non_gen, s) -> ty_var ~non_gen ppf s + | Otyp_variant (row_fields, closed, tags) -> + let print_present ppf = + function + None | Some [] -> () + | Some l -> fprintf ppf "@;<1 -2>> @[%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@[@[%a@]%a@]@ ]@]" + (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 open_row ppf = + function + [] -> + if open_row then fprintf ppf ".."; + | [s, t] -> + fprintf ppf "%s : %a" s print_out_type t; + if open_row then fprintf ppf ";@ "; + print_fields open_row ppf [] + | (s, t) :: l -> + fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields open_row) 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 "@[`%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 + +let out_type_args = ref print_typargs + +(* 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 "@[@[<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 constructor_of_extension_constructor + (ext : out_extension_constructor) : out_constructor += + { + ocstr_name = ext.oext_name; + ocstr_args = ext.oext_args; + ocstr_return_type = ext.oext_ret_type; + } + +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 "@[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 + (constructor_of_extension_constructor ext :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [constructor_of_extension_constructor ext] + 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 (constructor_of_extension_constructor ext) + | 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>@[%t%a@]%t%t%t@]" + print_name_params + print_out_tkind ty + print_constraints + print_immediate + print_unboxed + +and print_out_constr ppf constr = + let { + ocstr_name = name; + ocstr_args = tyl; + ocstr_return_type = return_type; + } = constr in + let name = + match name with + | "::" -> "(::)" (* #7200 *) + | s -> s + in + match return_type 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 "@[type %t +=%s@;<1 2>%a@]" + print_extended_type + (if ext.oext_private = Asttypes.Private then " private" else "") + print_out_constr + (constructor_of_extension_constructor ext) + +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 "@[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 + (constructor_of_extension_constructor ext :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [constructor_of_extension_constructor ext] + 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 "@[%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_501/typing/oprint.mli b/upstream/ocaml_501/typing/oprint.mli new file mode 100644 index 0000000000..31dad9a906 --- /dev/null +++ b/upstream/ocaml_501/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_type_args : (formatter -> out_type list -> unit) ref +val out_constr : (formatter -> out_constructor -> 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_501/typing/outcometree.mli b/upstream/ocaml_501/typing/outcometree.mli new file mode 100644 index 0000000000..0fc50b90db --- /dev/null +++ b/upstream/ocaml_501/typing/outcometree.mli @@ -0,0 +1,155 @@ +(**************************************************************************) +(* *) +(* 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 {non_gen:bool; aliased:out_type; alias:string} + | Otyp_arrow of string * out_type * out_type + | Otyp_class of out_ident * out_type list + | Otyp_constr of out_ident * out_type list + | Otyp_manifest of out_type * out_type + | Otyp_object of { fields: (string * out_type) list; open_row:bool} + | Otyp_record of (string * bool * out_type) list + | Otyp_stuff of string + | Otyp_sum of out_constructor list + | Otyp_tuple of out_type list + | Otyp_var of bool * string + | Otyp_variant of 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_constructor = { + ocstr_name: string; + ocstr_args: out_type list; + ocstr_return_type: out_type option; +} + +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: out_constructor 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_501/typing/parmatch.ml b/upstream/ocaml_501/typing/parmatch.ml new file mode 100644 index 0000000000..afb9f10777 --- /dev/null +++ b/upstream/ocaml_501/typing/parmatch.ml @@ -0,0 +1,2355 @@ +(**************************************************************************) +(* *) +(* 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 = row_field_repr (get_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 get_level ty = Btype.generic_level then ty + else Subst.type_expr Subst.identity ty + +let get_constructor_type_path ty tenv = + let ty = Ctype.expand_head tenv (clean_copy ty) in + match get_desc ty 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 {fields; more; name=orig_name; closed; fixed} = row_repr row in + let name, static = + List.fold_left + (fun (nm, static) (_tag,f) -> + match row_field_repr f with + | Reither(_, _, false) -> + (* fixed=false means that this tag is not explicitly matched *) + link_row_field_ext ~inside:f rf_absent; + (None, static) + | Reither (_, _, true) -> (nm, false) + | Rabsent | Rpresent _ -> (nm, static)) + (orig_name, true) fields in + if not closed || name != orig_name then begin + let more' = if static then Btype.newgenty Tnil else Btype.newgenvar () in + (* this unification cannot fail *) + Ctype.unify env more + (Btype.newgenty + (Tvariant + (create_row ~fields:[] ~more:more' + ~closed:true ~name ~fixed))) + 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.has_fixed_explanation row) then + (* closing=true, we are considering the variant as closed *) + List.for_all + (fun (tag,f) -> + match 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_fields row) + else + row_closed row && + List.for_all + (fun (tag,f) -> + row_field_repr f = Rabsent || List.mem tag fields) + (row_fields row) + | 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 env ty = + match Ctype.extract_concrete_typedecl env ty with + | Typedecl (_, path, {type_kind = Type_variant _ | Type_record _}) -> + begin match Env.find_type_descrs path env with + | Type_variant (cstrs,_) when 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] + | _ -> [omega] + end + | Has_no_typedecl -> + begin match get_desc (Ctype.expand_head env ty) with + Ttuple tl -> + [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] + | _ -> [omega] + end + | Typedecl (_, _, {type_kind = Type_abstract | Type_open}) + | May_have_typedecl -> [omega] + +let get_variant_constructors env ty = + match Ctype.extract_concrete_typedecl env ty with + | Typedecl (_, path, {type_kind = Type_variant _}) -> + begin match Env.find_type_descrs path env with + | Type_variant (cstrs,_) -> cstrs + | _ -> 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 = "" + +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 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_fields row) + with + [] -> + let tag = + if Btype.has_fixed_explanation 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.has_fixed_explanation 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 partitioned, 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 *) +(************************) + +(* Whether the counter-example contains an extension pattern *) +let contains_extension pat = + exists_pattern + (function + | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true + | _ -> false) + pat + +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 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 = {u with pat_loc = q.pat_loc} in + match pred refute 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 _ + | 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. +*) + +let all_rhs_idents exp = + let ids = ref Ident.Set.empty 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 + 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_501/typing/parmatch.mli b/upstream/ocaml_501/typing/parmatch.mli new file mode 100644 index 0000000000..b278586351 --- /dev/null +++ b/upstream/ocaml_501/typing/parmatch.mli @@ -0,0 +1,117 @@ +(**************************************************************************) +(* *) +(* 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 + +(** [pats_of_type] builds a list of patterns from a given expected type, + for explosion of wildcard patterns in Typecore.type_pat. + + There are four interesting cases: + - the type is empty ([]) + - no further explosion is necessary ([Pat_any]) + - a single pattern is generated, from a record or tuple type + or a single-variant type ([tp]) + - a list of patterns, in the case that all branches + are GADT constructors ([tp1; ..; tpn]). + *) +val pats_of_type : Env.t -> type_expr -> pattern list + +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: + (pattern -> pattern option) -> Location.t -> value case list -> partial +val check_unused: + (bool -> 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_501/typing/path.ml b/upstream/ocaml_501/typing/path.ml new file mode 100644 index 0000000000..69b8f34a01 --- /dev/null +++ b/upstream/ocaml_501/typing/path.ml @@ -0,0 +1,144 @@ +(**************************************************************************) +(* *) +(* 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 + | Pextra_ty of t * extra_ty +and extra_ty = + | Pcstr_ty of string + | Pext_ty + +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 + | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> + let same_extra = match t1, t2 with + | (Pcstr_ty s1, Pcstr_ty s2) -> s1 = s2 + | (Pext_ty, Pext_ty) -> true + | ((Pcstr_ty _ | Pext_ty), _) -> false + in same_extra && same p1 p2 + | (_, _) -> 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 + | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> + let h = compare_extra t1 t2 in + if h <> 0 then h else compare p1 p2 + | (Pident _, (Pdot _ | Papply _ | Pextra_ty _)) + | (Pdot _, (Papply _ | Pextra_ty _)) + | (Papply _, Pextra_ty _) + -> -1 + | ((Pextra_ty _ | Papply _ | Pdot _), Pident _) + | ((Pextra_ty _ | Papply _) , Pdot _) + | (Pextra_ty _, Papply _) + -> 1 +and compare_extra t1 t2 = + match (t1, t2) with + Pcstr_ty s1, Pcstr_ty s2 -> String.compare s1 s2 + | (Pext_ty, Pext_ty) + -> 0 + | (Pcstr_ty _, Pext_ty) + -> -1 + | (Pext_ty, Pcstr_ty _) + -> 1 + +let rec find_free_opt ids = function + Pident id -> List.find_opt (Ident.same id) ids + | Pdot(p, _) | Pextra_ty (p, _) -> find_free_opt ids p + | Papply(p1, p2) -> begin + match find_free_opt ids p1 with + | None -> find_free_opt ids p2 + | Some _ as res -> res + end + +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, _) | Pextra_ty (p, _) -> 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) | Pextra_ty (p, Pcstr_ty s) -> + name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s + | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" + | Pextra_ty (p, Pext_ty) -> name ~paren p + +let rec print ppf = function + | Pident id -> Ident.print_with_scope ppf id + | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> + Format.fprintf ppf "%a.%s" print p s + | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2 + | Pextra_ty (p, Pext_ty) -> print ppf p + +let rec head = function + Pident id -> id + | Pdot(p, _) | Pextra_ty (p, _) -> head p + | Papply _ -> assert false + +let flatten = + let rec flatten acc = function + | Pident id -> `Ok (id, acc) + | Pdot (p, s) | Pextra_ty (p, Pcstr_ty s) -> flatten (s :: acc) p + | Papply _ -> `Contains_apply + | Pextra_ty (p, Pext_ty) -> flatten acc p + in + fun t -> flatten [] t + +let heads p = + let rec heads p acc = match p with + | Pident id -> id :: acc + | Pdot (p, _) | Pextra_ty (p, _) -> 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) | Pextra_ty (_, Pcstr_ty s) -> s + | Papply(_, p) | Pextra_ty (p, Pext_ty) -> last p + +let is_constructor_typath p = + match p with + | Pident _ | Pdot _ | Papply _ -> false + | Pextra_ty _ -> 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_501/typing/path.mli b/upstream/ocaml_501/typing/path.mli new file mode 100644 index 0000000000..39e76a3727 --- /dev/null +++ b/upstream/ocaml_501/typing/path.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. *) +(* *) +(**************************************************************************) + +(* Access paths *) + +type t = + | Pident of Ident.t + (** Examples: x, List, int *) + | Pdot of t * string + (** Examples: List.map, Float.Array *) + | Papply of t * t + (** Examples: Set.Make(Int), Map.Make(Set.Make(Int)) *) + | Pextra_ty of t * extra_ty + (** [Pextra_ty (p, extra)] are additional paths of types + introduced by specific OCaml constructs. See below. + *) +and extra_ty = + | Pcstr_ty of string + (** [Pextra_ty (p, Pcstr_ty c)] is the type of the inline record for + constructor [c] inside type [p]. + + For example, in + {[ + type 'a t = Nil | Cons of {hd : 'a; tl : 'a t} + ]} + + The inline record type [{hd : 'a; tl : 'a t}] cannot + be named by the user in the surface syntax, but internally + it has the path + [Pextra_ty (Pident `t`, Pcstr_ty "Cons")]. + *) + | Pext_ty + (** [Pextra_ty (p, Pext_ty)] is the type of the inline record for + the extension constructor [p]. + + For example, in + {[ + type exn += Error of {loc : loc; msg : string} + ]} + + The inline record type [{loc : loc; msg : string}] cannot + be named by the user in the surface syntax, but internally + it has the path + [Pextra_ty (Pident `Error`, Pext_ty)]. + *) + +val same: t -> t -> bool +val compare: t -> t -> int +val compare_extra: extra_ty -> extra_ty -> 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_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_501/typing/patterns.ml b/upstream/ocaml_501/typing/patterns.ml new file mode 100644 index 0000000000..55f9d4ff43 --- /dev/null +++ b/upstream/ocaml_501/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 get_desc (Ctype.expand_head q.pat_env q.pat_type) with + | Tvariant type_row -> 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_501/typing/patterns.mli b/upstream/ocaml_501/typing/patterns.mli new file mode 100644 index 0000000000..66dd2d05a4 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/persistent_env.ml b/upstream/ocaml_501/typing/persistent_env.ml new file mode 100644 index 0000000000..a63b4ef02a --- /dev/null +++ b/upstream/ocaml_501/typing/persistent_env.ml @@ -0,0 +1,359 @@ +(**************************************************************************) +(* *) +(* 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 + +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 _ -> () + | Opaque -> register_import_as_opaque penv modname) + ps.ps_flags; + Consistbl.check 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)) + | 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 + 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 []; + [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 + "@[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 + "@[Invalid import of %s, which uses recursive types.@ %s@]" + import "The compilation flag -rectypes is required" + +let () = + Location.register_error_of_exn + (function + | Error err -> + Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/upstream/ocaml_501/typing/persistent_env.mli b/upstream/ocaml_501/typing/persistent_env.mli new file mode 100644 index 0000000000..618ea3991e --- /dev/null +++ b/upstream/ocaml_501/typing/persistent_env.mli @@ -0,0 +1,104 @@ +(**************************************************************************) +(* *) +(* 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 + +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_501/typing/predef.ml b/upstream/ocaml_501/typing/predef.ml new file mode 100644 index 0000000000..185825c330 --- /dev/null +++ b/upstream/ocaml_501/typing/predef.ml @@ -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. *) +(* *) +(**************************************************************************) + +(* 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 build_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 + let variant constrs = Type_variant (constrs, Variant_regular) in + empty_env + (* Predefined types - alphabetical order *) + |> add_type1 ident_array + ~variance:Variance.full + ~separability:Separability.Ind + |> add_type ident_bool + ~immediate:Always + ~kind:(variant [cstr ident_false []; cstr ident_true []]) + |> add_type ident_char ~immediate:Always + |> add_type ident_exn ~kind:Type_open + |> add_type ident_extension_constructor + |> add_type ident_float + |> add_type ident_floatarray + |> add_type ident_int ~immediate:Always + |> add_type ident_int32 + |> add_type ident_int64 + |> add_type1 ident_lazy_t + ~variance:Variance.covariant + ~separability:Separability.Ind + |> add_type1 ident_list + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]) + |> add_type ident_nativeint + |> add_type1 ident_option + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_none []; cstr ident_some [tvar]]) + |> add_type ident_string + |> add_type ident_bytes + |> add_type ident_unit + ~immediate:Always + ~kind:(variant [cstr ident_void []]) + (* Predefined exceptions - alphabetical order *) + |> add_extension ident_assert_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_division_by_zero [] + |> add_extension ident_end_of_file [] + |> add_extension ident_failure [type_string] + |> add_extension ident_invalid_argument [type_string] + |> add_extension ident_match_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_not_found [] + |> add_extension ident_out_of_memory [] + |> add_extension ident_stack_overflow [] + |> add_extension ident_sys_blocked_io [] + |> add_extension ident_sys_error [type_string] + |> add_extension ident_undefined_recursive_module + [newgenty (Ttuple[type_string; type_int; type_int])] + +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_501/typing/predef.mli b/upstream/ocaml_501/typing/predef.mli new file mode 100644 index 0000000000..4fde9cce6b --- /dev/null +++ b/upstream/ocaml_501/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 + +(* 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_501/typing/primitive.ml b/upstream/ocaml_501/typing/primitive.ml new file mode 100644 index 0000000000..bf4fe83248 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/primitive.mli b/upstream/ocaml_501/typing/primitive.mli new file mode 100644 index 0000000000..e8376ad552 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/printpat.ml b/upstream/ocaml_501/typing/printpat.ml new file mode 100644 index 0000000000..64094b63ec --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/printpat.mli b/upstream/ocaml_501/typing/printpat.mli new file mode 100644 index 0000000000..1865a2ab29 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/printtyp.ml b/upstream/ocaml_501/typing/printtyp.ml new file mode 100644 index 0000000000..42b11a4d21 --- /dev/null +++ b/upstream/ocaml_501/typing/printtyp.ml @@ -0,0 +1,2621 @@ +(**************************************************************************) +(* *) +(* 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 +module Sig_component_kind = Shape.Sig_component_kind + +(* 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 +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 + + type namespace = Sig_component_kind.t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + +module Namespace = struct + + let id = function + | Type -> 0 + | Module -> 1 + | Module_type -> 2 + | Class -> 3 + | Class_type -> 4 + | Extension_constructor | Value -> 5 + (* we do not handle those component *) + + let size = 1 + id Value + + + let pp ppf x = + Format.pp_print_string ppf (Shape.Sig_component_kind.to_string 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 + | Some Type -> to_lookup Env.find_type_by_name + | Some Module -> to_lookup Env.find_module_by_name + | Some Module_type -> to_lookup Env.find_modtype_by_name + | Some Class -> to_lookup Env.find_class_by_name + | Some Class_type -> to_lookup Env.find_cltype_by_name + | None | Some(Value|Extension_constructor) -> fun _ -> raise Not_found + + let location namespace id = + let path = Path.Pident id in + try Some ( + match namespace with + | Some Type -> (in_printing_env @@ Env.find_type path).type_loc + | Some Module -> (in_printing_env @@ Env.find_module path).md_loc + | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc + | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc + | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc + | Some (Extension_constructor|Value) | None -> Location.none + ) with Not_found -> None + + let best_class_namespace = function + | Papply _ | Pdot _ -> Some Module + | Pextra_ty _ -> assert false (* Only in type path *) + | Pident c -> + match location (Some Class) c with + | Some _ -> Some Class + | None -> Some 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 add namespace name id = + match Namespace.location (Some namespace) id with + | None -> () + | Some location -> + let explanation = + { kind = namespace; location; name; root_name=Ident.name id} + in + explanations := M.add name explanation !explanations + + let collect_explanation namespace id ~name = + let root_name = Ident.name id in + (* if [name] is of the form "root_name/%d", we register both + [id] and the identifier in scope for [root_name]. + *) + if root_name <> name && not (M.mem name !explanations) then + begin + add namespace name id; + if not (M.mem root_name !explanations) then + (* lookup the identifier in scope with name [root_name] and + add it too + *) + match Namespace.lookup (Some namespace) root_name with + | Pident root_id -> add namespace root_name root_id + | exception Not_found | _ -> () + end + + let pp_explanation ppf r= + Format.fprintf ppf "@[%a:@,Definition of %s %s@]" + Location.print_loc r.location (Sig_component_kind.to_string r.kind) r.name + + let print_located_explanations ppf l = + Format.fprintf ppf "@[%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 + +(* Names bound in recursive definitions should be considered as bound + in the environment when printing identifiers but not when trying + to find shortest path. + For instance, if we define + [{ + module Avoid__me = struct + type t = A + end + type t = X + type u = [` A of t * t ] + module M = struct + type t = A of [ u | `B ] + type r = Avoid__me.t + end + }] + It is is important that in the definition of [t] that the outer type [t] is + printed as [t/2] reserving the name [t] to the type being defined in the + current recursive definition. + Contrarily, in the definition of [r], one should not shorten the + path [Avoid__me.t] to [r] until the end of the definition of [r]. + The [bound_in_recursion] bridges the gap between those two slightly different + notions of printing environment. +*) +let bound_in_recursion = ref M.empty + +(* When dealing with functor arguments, identity becomes fuzzy because the same + syntactic argument may be represented by different identifiers 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 = M.add (Ident.name id.ident) id.ident m in + let updated = List.fold_left update !bound_in_recursion ids in + protect_refs [ R(bound_in_recursion, updated )] f + +let human_id id index = + (* The identifier with index [k] is the (k+1)-th most recent identifier in + the printing environment. We print them as [name/(k+1)] except for [k=0] + which is printed as [name] rather than [name/1]. + *) + if index = 0 then + Ident.name id + else + let ordinal = index + 1 in + String.concat "/" [Ident.name id; string_of_int ordinal] + +let indexed_name namespace id = + let find namespace id env = match namespace with + | Type -> Env.find_type_index id env + | Module -> Env.find_module_index id env + | Module_type -> Env.find_modtype_index id env + | Class -> Env.find_class_index id env + | Class_type-> Env.find_cltype_index id env + | Value | Extension_constructor -> None + in + let index = + match M.find_opt (Ident.name id) !bound_in_recursion with + | Some rec_bound_id -> + (* the identifier name appears in the current group of recursive + definition *) + if Ident.same rec_bound_id id then + Some 0 + else + (* the current recursive definition shadows one more time the + previously existing identifier with the same name *) + Option.map succ (in_printing_env (find namespace id)) + | None -> + in_printing_env (find namespace id) + in + let index = + (* If [index] is [None] at this point, it might indicate that + the identifier id is not defined in the environment, while there + are other identifiers in scope that share the same name. + Currently, this kind of partially incoherent environment happens + within functor error messages where the left and right hand side + have a different views of the environment at the source level. + Printing the source-level by using a default index of `0` + seems like a reasonable compromise in this situation however.*) + Option.value index ~default:0 + in + human_id id index + +let ident_name namespace id = + match namespace, !enabled with + | None, _ | _, false -> Out_name.create (Ident.name id) + | Some namespace, true -> + if fuzzy_id namespace id then Out_name.create (Ident.name id) + else + let name = indexed_name namespace id in + Conflicts.collect_explanation namespace id ~name; + Out_name.create name +end +let ident_name = Naming_context.ident_name + +let ident ppf id = pp_print_string ppf + (Out_name.print (Naming_context.ident_name None id)) + +let namespaced_ident namespace id = + Out_name.print (Naming_context.ident_name (Some namespace) id) + + +(* Print a path *) + +let ident_stdlib = Ident.create_persistent "Stdlib" + +let non_shadowed_stdlib namespace = function + | Pdot(Pident id, s) as path -> + Ident.same id ident_stdlib && + (match Namespace.lookup namespace 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) + | Pextra_ty (p, extra) -> + Pextra_ty (rewrite_double_underscore_paths env p, extra) + | 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 ?(disambiguation=true) namespace p = + let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in + let namespace = if disambiguation then namespace else None in + match p with + | Pident id -> + Oide_ident (ident_name namespace id) + | Pdot(_, s) as path when non_shadowed_stdlib namespace path -> + Oide_ident (Out_name.create s) + | Pdot(p, s) -> + Oide_dot (tree_of_path (Some Module) p, s) + | Papply(p1, p2) -> + let t1 = tree_of_path (Some Module) p1 in + let t2 = tree_of_path (Some Module) p2 in + Oide_apply (t1, t2) + | Pextra_ty (p, extra) -> begin + (* inline record types are syntactically prevented from escaping their + binding scope, and are never shown to users. *) + match extra with + Pcstr_ty s -> + Oide_dot (tree_of_path (Some Type) p, s) + | Pext_ty -> + tree_of_path None p + end + +let tree_of_path ?disambiguation namespace p = + tree_of_path ?disambiguation namespace + (rewrite_double_underscore_paths !printing_env p) + +let path ppf p = + !Oprint.out_ident ppf (tree_of_path None p) + +let string_of_path p = + Format.asprintf "%a" path p + +let strings_of_paths namespace p = + 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 string_of_field_kind v = + match field_kind_repr v with + | Fpublic -> "Fpublic" + | Fabsent -> "Fabsent" + | Fprivate -> "Fprivate" + +let rec safe_repr v t = + match Transient_expr.coerce t with + {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 "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" + (string_of_label l) raw_type t1 raw_type t2 + (if is_commu_ok c then "Cok" else "Cunknown") + | Ttuple tl -> + fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl + | Tconstr (p, tl, abbrev) -> + fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p + raw_type_list tl + (raw_list path) (list_of_memo !abbrev) + | Tobject (t, nm) -> + fprintf ppf "@[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 "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f + (string_of_field_kind 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 "@[Tpoly(@,%a,@,%a)@]" + raw_type t + raw_type_list tl + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + fprintf ppf + "@[{@[%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)) + fields + "row_more=" raw_type more + "row_closed=" closed + "row_fixed=" raw_row_fixed fixed + "row_name=" + (fun ppf -> + match 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 "@[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 rf = + match_row_field + ~absent:(fun _ -> fprintf ppf "RFabsent") + ~present:(function + | None -> + fprintf ppf "RFpresent None" + | Some t -> + fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) + ~either:(fun c tl m e -> + fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c + raw_type_list tl m + (fun ppf -> + match e with None -> fprintf ppf " RFnone" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) + rf + +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 String.Set.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 rec index l x = + match l with + [] -> raise Not_found + | a :: l -> if eq_type x a then 0 else 1 + index l x + +let rec uniq = function + [] -> true + | a :: l -> not (List.memq (a : int) l) && uniq l + +let rec normalize_type_path ?(cache=false) env p = + try + let (params, ty, _) = Env.find_type_expansion p env in + match get_desc ty with + Tconstr (p1, tyl, _) -> + if List.length params = List.length tyl + && List.for_all2 eq_type params tyl + then normalize_type_path ~cache env p1 + else if cache || List.length params <= List.length tyl + || not (uniq (List.map get_id 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) + | _ -> + (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, _) | Pextra_ty (p, Pcstr_ty _) -> + 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) + | Pextra_ty (p, _) -> path_size p + +let same_printing_env env = + let used_pers = Env.used_persistent () in + Env.same_types !printing_old env && String.Set.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; + 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) | Path.Pextra_ty (p1, Pcstr_ty s) -> + Longident.Ldot (lid_of_path p1, s) + | Path.Papply (p1, p2) -> + Longident.Lapply (lid_of_path p1, lid_of_path p2) + | Path.Pextra_ty (p, Pext_ty) -> lid_of_path p + +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) + +(* When building a tree for a best type path, we should not disambiguate + identifiers whenever the short-path algorithm detected a better path than + the original one.*) +let tree_of_best_type_path p p' = + if Path.same p p' then tree_of_path (Some Type) p' + else tree_of_path ~disambiguation:false None p' + +(* Print a type expression *) + +let proxy ty = Transient_expr.repr (proxy ty) + +(* When printing a type scheme, we print weak names. When printing a plain + type, we do not. This type controls that behavior *) +type type_or_scheme = Type | Type_scheme + +let is_non_gen mode ty = + match mode with + | Type_scheme -> is_Tvar ty && get_level ty <> generic_level + | Type -> false + +let nameable_row row = + row_name row <> None && + List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither(c, l, _) -> + row_closed row && if c then l = [] else List.length l = 1 + | _ -> true) + (row_fields row) + +(* This specialized version of [Btype.iter_type_expr] normalizes and + short-circuits the traversal of the [type_expr], so that it covers only the + subterms that would be printed by the type printer. *) +let printer_iter_type_expr f ty = + match get_desc ty with + | Tconstr(p, tyl, _) -> + let (_p', s) = best_type_path p in + List.iter f (apply_subst s tyl) + | Tvariant row -> begin + match row_name row with + | Some(_p, tyl) when nameable_row row -> + List.iter f tyl + | _ -> + iter_row f row + end + | Tobject (fi, nm) -> begin + match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpublic then + f ty) + fields + | Some (_, l) -> + List.iter f (List.tl l) + end + | Tfield(_, kind, ty1, ty2) -> + if field_kind_repr kind = Fpublic then + f ty1; + f ty2 + | _ -> + Btype.iter_type_expr f ty + +module Names : sig + val reset_names : unit -> unit + + val add_named_vars : type_expr -> unit + val add_subst : (type_expr * type_expr) list -> unit + + val new_name : unit -> string + val new_var_name : non_gen:bool -> type_expr -> unit -> string + + val name_of_type : (unit -> string) -> transient_expr -> string + val check_name_of_type : non_gen:bool -> transient_expr -> unit + + val remove_names : transient_expr list -> unit + + val with_local_names : (unit -> 'a) -> 'a + + (* Refresh the weak variable map in the toplevel; for [print_items], which is + itself for the toplevel *) + val refresh_weak : unit -> unit +end = struct + (* We map from types to names, but not directly; we also store a substitution, + which maps from types to types. The lookup process is + "type -> apply substitution -> find name". The substitution is presumed to + be acyclic. *) + let names = ref ([] : (transient_expr * string) list) + let name_subst = ref ([] : (transient_expr * transient_expr) list) + let name_counter = ref 0 + let named_vars = ref ([] : string list) + let visited_for_named_vars = ref ([] : transient_expr 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_subst := []; + name_counter := 0; + named_vars := []; + visited_for_named_vars := [] + + let add_named_var tty = + match tty.desc with + Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else + named_vars := name :: !named_vars + | _ -> () + + let rec add_named_vars ty = + let tty = Transient_expr.repr ty in + let px = proxy ty in + if not (List.memq px !visited_for_named_vars) then begin + visited_for_named_vars := px :: !visited_for_named_vars; + match tty.desc with + | Tvar _ | Tunivar _ -> + add_named_var tty + | _ -> + printer_iter_type_expr add_named_vars ty + end + + let rec substitute ty = + match List.assq ty !name_subst with + | ty' -> substitute ty' + | exception Not_found -> ty + + let add_subst subst = + name_subst := + List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) + subst + @ !name_subst + + 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 new_var_name ~non_gen ty () = + if non_gen then new_weak_name ty () + else new_name () + + 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. *) + let t = substitute t in + try List.assq t !names with Not_found -> + try TransientTypeMap.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 available name = + List.for_all + (fun (_, name') -> name <> name') + !names + in + if available name then name + else + let suffixed i = name ^ Int.to_string i in + let i = Misc.find_first_mono (fun i -> available (suffixed i)) in + suffixed i + | _ -> + (* 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 ~non_gen px = + let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in + ignore(name_of_type name_gen px) + + let remove_names tyl = + let tyl = List.map substitute tyl in + names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names + + let with_local_names f = + let old_names = !names in + let old_subst = !name_subst in + names := []; + name_subst := []; + try_finally + ~always:(fun () -> + names := old_names; + name_subst := old_subst) + f + + let refresh_weak () = + let refresh t name (m,s) = + if is_non_gen Type_scheme 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 +end + +let reserve_names ty = + normalize_type ty; + Names.add_named_vars ty + +let visited_objects = ref ([] : transient_expr list) +let aliased = ref ([] : transient_expr list) +let delayed = ref ([] : transient_expr list) +let printed_aliases = ref ([] : transient_expr list) + +(* [printed_aliases] is a subset of [aliased] that records only those aliased + types that have actually been printed; this allows us to avoid naming loops + that the user will never see. *) + +let add_delayed t = + if not (List.memq t !delayed) then delayed := t :: !delayed + +let is_aliased_proxy px = List.memq px !aliased + +let add_alias_proxy px = + if not (is_aliased_proxy px) then + aliased := px :: !aliased + +let add_alias ty = add_alias_proxy (proxy ty) + +let add_printed_alias_proxy ~non_gen px = + Names.check_name_of_type ~non_gen px; + printed_aliases := px :: !printed_aliases + +let add_printed_alias ty = add_printed_alias_proxy (proxy ty) + +let aliasable ty = + match get_desc ty with + Tvar _ | Tunivar _ | Tpoly _ -> false + | Tconstr (p, _, _) -> + not (is_nth (snd (best_type_path p))) + | _ -> true + +let should_visit_object ty = + match get_desc ty with + | Tvariant row -> not (static_row row) + | Tobject _ -> opened_object ty + | _ -> false + +let rec mark_loops_rec visited ty = + let px = proxy ty in + if List.memq px visited && aliasable ty then add_alias_proxy px else + let tty = Transient_expr.repr ty in + let visited = px :: visited in + match tty.desc with + | Tvariant _ | Tobject _ -> + if List.memq px !visited_objects then add_alias_proxy px else begin + if should_visit_object ty then + visited_objects := px :: !visited_objects; + printer_iter_type_expr (mark_loops_rec visited) ty + end + | Tpoly(ty, tyl) -> + List.iter add_alias tyl; + mark_loops_rec visited ty + | _ -> + printer_iter_type_expr (mark_loops_rec visited) ty + +let mark_loops ty = + mark_loops_rec [] ty + +let prepare_type ty = + reserve_names ty; + mark_loops ty + +let reset_loop_marks () = + visited_objects := []; aliased := []; delayed := []; printed_aliases := [] + +let reset_except_context () = + Names.reset_names (); reset_loop_marks () + +let reset () = + Conflicts.reset (); + reset_except_context () + +let prepare_for_printing tyl = + reset_except_context (); + List.iter prepare_type tyl + +let add_type_to_preparation = prepare_type + +(* Disabled in classic mode when printing an unification error *) +let print_labels = ref true + +let alias_nongen_row mode px ty = + match get_desc ty with + | Tvariant _ | Tobject _ -> + if is_non_gen mode (Transient_expr.type_expr px) then + add_alias_proxy px + | _ -> () + +let rec tree_of_typexp mode ty = + let px = proxy ty in + if List.memq px !printed_aliases && not (List.memq px !delayed) then + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + let name = Names.name_of_type (Names.new_var_name ~non_gen ty) px in + Otyp_var (non_gen, name) else + + let pr_typ () = + let tty = Transient_expr.repr ty in + match tty.desc with + | Tvar _ -> + let non_gen = is_non_gen mode ty in + let name_gen = Names.new_var_name ~non_gen ty in + Otyp_var (non_gen, Names.name_of_type name_gen tty) + | 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 get_desc ty1 with + | Tconstr(path, [ty], _) + when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty1 in + Otyp_arrow (lab, t1, tree_of_typexp mode ty2) + | Ttuple tyl -> + Otyp_tuple (tree_of_typlist mode 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 mode (List.hd tyl') + else + let tpath = tree_of_best_type_path p p' in + Otyp_constr (tpath, tree_of_typlist mode tyl') + | Tvariant row -> + let Row {fields; name; closed; _} = row_repr row in + let fields = + if closed then + List.filter (fun (_, f) -> row_field_repr f <> Rabsent) + fields + else 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 name with + | Some(p, tyl) when nameable_row row -> + let (p', s) = best_type_path p in + let id = tree_of_best_type_path p p' in + let args = tree_of_typlist mode (apply_subst s tyl) in + let out_variant = + if is_nth s then List.hd args else Otyp_constr (id, args) in + if closed && all_present then + out_variant + else + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_typ out_variant, closed, tags) + | _ -> + let fields = List.map (tree_of_row_field mode) fields in + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_fields fields, closed, tags) + end + | Tobject (fi, nm) -> + tree_of_typobject mode fi !nm + | Tnil | Tfield _ -> + tree_of_typobject mode ty None + | Tsubst _ -> + (* This case should only happen when debugging the compiler *) + Otyp_stuff "" + | Tlink _ -> + fatal_error "Printtyp.tree_of_typexp" + | Tpoly (ty, []) -> + tree_of_typexp mode ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + if tyl = [] then tree_of_typexp mode ty else begin + let tyl = List.map Transient_expr.repr tyl in + 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 (Names.name_of_type Names.new_name) tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode ty) in + (* Forget names when we leave scope *) + Names.remove_names tyl; + delayed := old_delayed; tr + end + | Tunivar _ -> + Otyp_var (false, Names.name_of_type Names.new_name tty) + | Tpackage (p, fl) -> + let fl = + List.map + (fun (li, ty) -> ( + String.concat "." (Longident.flatten li), + tree_of_typexp mode ty + )) fl in + Otyp_module (tree_of_path (Some Module_type) p, fl) + in + if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; + alias_nongen_row mode px ty; + if is_aliased_proxy px && aliasable ty then begin + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + add_printed_alias_proxy ~non_gen px; + (* add_printed_alias chose a name, thus the name generator + doesn't matter.*) + let alias = Names.name_of_type (Names.new_var_name ~non_gen ty) px in + Otyp_alias {non_gen; aliased = pr_typ (); alias } end + else pr_typ () + +and tree_of_row_field mode (l, f) = + match row_field_repr f with + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) + | Reither(c, tyl, _) -> + if c (* contradiction: constant constructor with an argument *) + then (l, true, tree_of_typlist mode tyl) + else (l, false, tree_of_typlist mode tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode) tyl + +and tree_of_typobject mode 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 + | Fpublic -> (n, t) :: l + | _ -> l) + fields [] in + let sorted_fields = + List.sort + (fun (n, _) (n', _) -> String.compare n n') present_fields in + tree_of_typfields mode rest sorted_fields in + let (fields, open_row) = pr_fields fi in + Otyp_object {fields; open_row} + | Some (p, _ty :: tyl) -> + let args = tree_of_typlist mode tyl in + let (p', s) = best_type_path p in + assert (s = Id); + Otyp_class (tree_of_best_type_path p p', args) + | _ -> + fatal_error "Printtyp.tree_of_typobject" + end + +and tree_of_typfields mode rest = function + | [] -> + let open_row = + match get_desc rest with + | Tvar _ | Tunivar _ | Tconstr _-> true + | Tnil -> false + | _ -> fatal_error "typfields (1)" + in + ([], open_row) + | (s, t) :: l -> + let field = (s, tree_of_typexp mode t) in + let (fields, rest) = tree_of_typfields mode rest l in + (field :: fields, rest) + +let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + +let prepared_type_expr ppf ty = typexp Type 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 *) + prepare_for_printing [ty]; + prepared_type_expr ppf ty + +(* "Half-prepared" type expression: [ty] should have had its names reserved, but + should not have had its loops marked. *) +let type_expr_with_reserved_names ppf ty = + reset_loop_marks (); + mark_loops ty; + prepared_type_expr ppf ty + +let shared_type_scheme ppf ty = + prepare_type ty; + typexp Type_scheme ppf ty + +let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty + +let type_scheme ppf ty = + prepare_for_printing [ty]; + prepared_type_scheme 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_best_type_path p p'' in + !Oprint.out_ident ppf t + +let tree_of_type_scheme ty = + prepare_for_printing [ty]; + tree_of_typexp Type_scheme 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 Type_scheme ty in + (tr, tree_of_typexp Type_scheme ty') :: list + else list) + params [] + +let filter_params tyl = + let params = + List.fold_left + (fun tyl ty -> + if List.exists (eq_type ty) tyl + then newty2 ~level:generic_level (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 prepare_type_constructor_arguments = function + | Cstr_tuple l -> List.iter prepare_type l + | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l + +let tree_of_label l = + (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type l.ld_type) + +let tree_of_constructor_arguments = function + | Cstr_tuple l -> tree_of_typlist Type l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] + +let tree_of_single_constructor cd = + let name = Ident.name cd.cd_id in + let ret = Option.map (tree_of_typexp Type) cd.cd_res in + let args = tree_of_constructor_arguments cd.cd_args in + { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +(* When printing GADT constructor, we need to forget the naming decision we took + for the type parameters and constraints. Indeed, in + {[ + type 'a t = X: 'a -> 'b t + ]} + It is fine to print both the type parameter ['a] and the existentially + quantified ['a] in the definition of the constructor X as ['a] + *) +let tree_of_constructor_in_decl cd = + match cd.cd_res with + | None -> tree_of_single_constructor cd + | Some _ -> Names.with_local_names (fun () -> tree_of_single_constructor cd) + +let prepare_decl id decl = + let params = filter_params decl.type_params in + begin match decl.type_manifest with + | Some ty -> + let vars = free_variables ty in + List.iter + (fun ty -> + if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + params + | None -> () + end; + List.iter add_alias params; + List.iter prepare_type params; + List.iter (add_printed_alias ~non_gen:false) params; + let ty_manifest = + match decl.type_manifest with + | None -> None + | Some ty -> + let ty = + (* Special hack to hide variant name *) + match get_desc ty with + Tvariant row -> + begin match row_name row with + Some (Pident id', _) when Ident.same id id' -> + newgenty (Tvariant (set_row_name row None)) + | _ -> ty + end + | _ -> ty + in + prepare_type ty; + Some ty + in + begin match decl.type_kind with + | Type_abstract -> () + | Type_variant (cstrs, _rep) -> + List.iter + (fun c -> + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) + cstrs + | Type_record(l, _rep) -> + List.iter (fun l -> prepare_type l.ld_type) l + | Type_open -> () + end; + ty_manifest, params + +let tree_of_type_decl id decl = + let ty_manifest, params = prepare_decl id decl in + 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 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 Type ty), cocn) + params vari) + in + let tree_of_manifest ty1 = + match ty_manifest with + | None -> ty1 + | Some ty -> Otyp_manifest (tree_of_typexp Type 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 Type ty, decl.type_private, false + end + | Type_variant (cstrs, rep) -> + tree_of_manifest + (Otyp_sum (List.map tree_of_constructor_in_decl 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 } + +let add_type_decl_to_preparation id decl = + ignore @@ prepare_decl id decl + +let tree_of_prepared_type_decl id decl = + tree_of_type_decl id decl + +let tree_of_type_decl id decl = + reset_except_context(); + tree_of_type_decl id decl + +let add_constructor_to_preparation c = + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res + +let prepared_constructor ppf c = + !Oprint.out_constr ppf (tree_of_single_constructor c) + +let constructor ppf c = + reset_except_context (); + add_constructor_to_preparation c; + prepared_constructor ppf c + +let label ppf l = + reset_except_context (); + prepare_type l.ld_type; + !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 tree_of_prepared_type_declaration id decl rs = + Osig_type (tree_of_prepared_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 add_type_declaration_to_preparation id decl = + add_type_decl_to_preparation id decl + +let prepared_type_declaration id ppf decl = + !Oprint.out_sig_item ppf + (tree_of_prepared_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 = + let ret = Option.map (tree_of_typexp Type) ext_ret_type in + let args = tree_of_constructor_arguments ext_args in + (args, ret) + +(* When printing extension constructor, it is important to ensure that +after printing the constructor, we are still in the scope of the constructor. +For GADT constructor, this can be done by printing the type parameters inside +their own isolated scope. This ensures that in +{[ + type 'b t += A: 'b -> 'b any t +]} +the type parameter `'b` is not bound when printing the type variable `'b` from +the constructor definition from the type parameter. + +Contrarily, for non-gadt constructor, we must keep the same scope for +the type parameters and the constructor because a type constraint may +have changed the name of the type parameter: +{[ +type -'a t = .. constraint 'a> = 'a +(* the universal 'a is here to steal the name 'a from the type parameter *) +type 'a t = X of 'a +]} *) + + +let add_extension_constructor_to_preparation ext = + let ty_params = filter_params ext.ext_type_params in + List.iter add_alias ty_params; + List.iter prepare_type ty_params; + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type + +let prepared_tree_of_extension_constructor + id ext es + = + let ty_name = Path.name ext.ext_type_path in + let ty_params = filter_params ext.ext_type_params in + let type_param = + function + | Otyp_var (_, id) -> id + | _ -> "?" + in + let param_scope f = + match ext.ext_ret_type with + | None -> + (* normal constructor: same scope for parameters and the constructor *) + f () + | Some _ -> + (* gadt constructor: isolated scope for the type parameters *) + Names.with_local_names f + in + let ty_params = + param_scope + (fun () -> + List.iter (add_printed_alias ~non_gen:false) ty_params; + List.map (fun ty -> type_param (tree_of_typexp Type 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 tree_of_extension_constructor id ext es = + reset_except_context (); + add_extension_constructor_to_preparation ext; + prepared_tree_of_extension_constructor id ext es + +let extension_constructor id ppf ext = + !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) + +let prepared_extension_constructor id ppf ext = + !Oprint.out_sig_item ppf + (prepared_tree_of_extension_constructor id ext Text_first) + +let extension_only_constructor id ppf ext = + reset_except_context (); + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type; + 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 "@[%a@]" + !Oprint.out_constr { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = 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 priv ty = + match priv, get_desc ty with + | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) + | _ , _ -> (ty, []) + +let prepare_method _lab (priv, _virt, ty) = + let ty, _ = method_type priv ty in + prepare_type ty + +let tree_of_method mode (lab, priv, virt, ty) = + let (ty, tyl) = method_type priv ty in + let tty = tree_of_typexp mode ty in + Names.remove_names (List.map Transient_expr.repr tyl); + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, tty) + +let rec prepare_class_type params = function + | Cty_constr (_p, tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects + || not (List.for_all is_Tvar params) + || List.exists (deep_occur row) tyl + then prepare_class_type params cty + else List.iter prepare_type tyl + | Cty_signature sign -> + (* Self may have a name *) + let px = proxy sign.csig_self_row in + if List.memq px !visited_objects then add_alias_proxy px + else visited_objects := px :: !visited_objects; + Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; + Meths.iter prepare_method sign.csig_meths + | Cty_arrow (_, ty, cty) -> + prepare_type ty; + prepare_class_type params cty + +let rec tree_of_class_type mode params = + function + | Cty_constr (p', tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects + || not (List.for_all is_Tvar params) + then + tree_of_class_type mode params cty + else + let namespace = Namespace.best_class_namespace p' in + Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl) + | Cty_signature sign -> + let px = proxy sign.csig_self_row in + let self_ty = + if is_aliased_proxy px then + Some + (Otyp_var (false, Names.name_of_type Names.new_name px)) + else None + 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 mode t) + :: csil) + csil all_vars + in + let all_meths = + Meths.fold + (fun l (p, v, t) all -> (l, p, v, t) :: all) + sign.csig_meths [] + in + let all_meths = List.rev all_meths in + let csil = + List.fold_left + (fun csil meth -> tree_of_method mode meth :: csil) + csil all_meths + 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 get_desc ty with + | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty in + Octy_arrow (lab, tr, tree_of_class_type mode params cty) + +let class_type ppf cty = + reset (); + prepare_class_type [] cty; + !Oprint.out_class_type ppf (tree_of_class_type Type [] cty) + +let tree_of_class_param param variance = + (match tree_of_typexp Type_scheme param with + Otyp_var (_, s) -> s + | _ -> "?"), + if is_Tvar 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 px = proxy (Btype.self_type_row cl.cty_type) in + List.iter prepare_type params; + + List.iter (add_printed_alias ~non_gen:false) params; + if is_aliased_proxy px then add_printed_alias_proxy ~non_gen:false px; + + 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 Type_scheme 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 = cl.clty_params in + + reset_except_context (); + List.iter add_alias params; + prepare_class_type params cl.clty_type; + let px = proxy (Btype.self_type_row cl.clty_type) in + List.iter prepare_type params; + + List.iter (add_printed_alias ~non_gen:false) params; + if is_aliased_proxy px then (add_printed_alias_proxy ~non_gen:false) px; + + let sign = Btype.signature_of_class_type cl.clty_type in + let has_virtual_vars = + Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_vars false + in + let has_virtual_meths = + Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_meths false + in + Osig_class_type + (has_virtual_vars || has_virtual_meths, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.clty_variance), + tree_of_class_type Type_scheme 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 (Some 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 (Some 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 = + 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? *) + +let print_items showval env x = + Names.refresh_weak(); + 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 "@[%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 (); + 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 + +(* Trace-specific printing *) + +(* 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" + +(* Print a unification error *) + +let same_path t t' = + eq_type t t' || + match get_desc t, get_desc t' 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 eq_type tl tl' + | _ -> false + end + | _ -> + false + +type 'a diff = Same of 'a | Diff of 'a * 'a + +let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = + reset_loop_marks (); + mark_loops t; + if same_path t t' + then begin add_delayed (proxy t); Same (tree_of_typexp mode t) end + else begin + mark_loops t'; + 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 mode t in + let second = tree_of_typexp mode t' in + if first = second then Same first + else Diff(first,second) + end + +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 mode = + List.map (Errortrace.map_diff (trees_of_type_expansion mode)) + +let trees_of_type_path_expansion (tp,tp') = + if Path.same tp tp' then Same(tree_of_path (Some Type) tp) else + Diff(tree_of_path (Some Type) tp, tree_of_path (Some 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 = {ty = t1; expanded = t1'}; + expected = {ty = t2; expanded = 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 + +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.map f tr) + +(** Keep elements that are [Diff _ ] and take the decision + for the last element, require a prepared trace *) +let rec filter_trace 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 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 get_desc t with + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + if name = None then t else + newty2 ~level:(get_level t) + (Tvariant + (create_row ~fields ~fixed ~closed ~name:None + ~more:(newvar2 (get_level more)))) + | _ -> t + +let prepare_expansion Errortrace.{ty; expanded} = + let expanded = hide_variant_name expanded in + reserve_names ty; + if not (same_path ty expanded) then reserve_names expanded; + Errortrace.{ty; expanded} + +let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = + match get_desc expanded with + Tvariant _ | Tobject _ when compact -> + reserve_names ty; Errortrace.{ty; expanded = ty} + | _ -> prepare_expansion ty_exp + +let print_path p = + Format.dprintf "%a" !Oprint.out_ident (tree_of_path (Some 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 get_desc (Ctype.expand_head env ty) 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 get_desc t3, get_desc t4 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 -> + reserve_names x; + dprintf "The %a variant type is bound to the universal type variable %a" + Errortrace.print_pos pos type_expr_with_reserved_names 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)@ @[%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.Presence_not_guaranteed_for (pos, s) -> Some( + dprintf + "@,@[The tag `%s is guaranteed to be present in the %a variant type,\ + @ but not in the %a@]" + s + Errortrace.print_pos (Errortrace.swap_position pos) + Errortrace.print_pos pos + ) + | 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 -> + reserve_names u; + Some( + dprintf "%t@,The universal variable %a would escape its scope" + pre type_expr_with_reserved_names 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 Errortrace.{ty = _; expanded = t} -> + reserve_names t; + Some( + dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" + pre type_expr_with_reserved_names 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 + : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function + | Errortrace.Diff {got; expected} -> + explanation_diff env got.expanded expected.expanded + | Errortrace.Escape {kind; context} -> + let pre = + match context, kind, prev with + | Some ctx, _, _ -> + reserve_names ctx; + dprintf "@[%t@;<1 2>%a@]" intro type_expr_with_reserved_names ctx + | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> + reserve_names diff.got; + reserve_names diff.expected; + dprintf "@,@[The method %s has type@ %a,@ \ + but the expected method type was@ %a@]" + name + type_expr_with_reserved_names diff.got + type_expr_with_reserved_names 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) -> + reserve_names x; + reserve_names y; + begin match get_desc x with + | Tvar _ | Tunivar _ -> + Some(fun ppf -> + reset_loop_marks (); + mark_loops x; + mark_loops y; + dprintf "@,@[The type variable %a occurs inside@ %a@]" + prepared_type_expr x prepared_type_expr y + ppf) + | _ -> + (* 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 get_desc t 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 mode txt_got txt_but = function + | None -> ignore + | Some d -> + let d = Errortrace.map_diff (trees_of_type_expansion mode) 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 = {ty=te1; expanded=_}; + expected = {ty=te2; expanded=_} } -> + warn_on_missing_def env ppf te1; + warn_on_missing_def env ppf te2 + +(* [subst] comes out of equality, and is [[]] otherwise *) +let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = + reset (); + (* We want to substitute in the opposite order from [Eqtype] *) + Names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); + let tr = + prepare_trace + (fun ty_exp -> + Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) + 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 (Errortrace.map_diff prepare_expansion) tr in + let head_error = head_error_printer mode txt1 txt2 head in + let tr = trees_of_trace mode tr in + fprintf ppf + "@[\ + @[%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 mode env tr + ?(subst = []) + ?(type_expected_explanation = fun _ -> ()) + txt1 txt2 = + wrap_printing_env ~error:true env (fun () -> + error trace_format mode subst env tr txt1 ppf txt2 + type_expected_explanation) + +let report_unification_error + ppf env ({trace} : Errortrace.unification_error) = + report_error Unification ppf Type env + ?subst:None trace + +let report_equality_error + ppf mode env ({subst; trace} : Errortrace.equality_error) = + report_error Equality ppf mode env + ~subst ?type_expected_explanation:None trace + +let report_moregen_error + ppf mode env ({trace} : Errortrace.moregen_error) = + report_error Moregen ppf mode env + ?subst:None ?type_expected_explanation:None trace + +let report_comparison_error ppf mode env = function + | Errortrace.Equality_error error -> report_equality_error ppf mode env error + | Errortrace.Moregen_error error -> report_moregen_error ppf mode env error + +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.map 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 Type + @@ 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 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 Type) diff) + | _ -> None + + let subtype_get_diff = function + | Errortrace.Subtype.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + + let report_error + ppf + env + (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) + txt1 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tr_sub = prepare_trace prepare_expansion tr_sub in + let tr_unif = prepare_unification_trace prepare_expansion tr_unif in + let keep_first = match tr_unif with + | [Obj _ | Variant _ | Escape _ ] | [] -> true + | _ -> false in + fprintf ppf "@[%a" + (trace filter_subtype_trace subtype_get_diff true keep_first txt1) + tr_sub; + if tr_unif = [] then fprintf ppf "@]" else + let mis = mismatch (dprintf "Within this type") env tr_unif in + fprintf ppf "%a%t%t@]" + (trace filter_trace unification_get_diff false + (mis = None) "is not compatible with type") tr_unif + (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>@[%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 None +let tree_of_modtype = tree_of_modtype ~ellipsis:false +let type_expansion mode ppf ty_exp = + type_expansion ppf (trees_of_type_expansion mode ty_exp) +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_501/typing/printtyp.mli b/upstream/ocaml_501/typing/printtyp.mli new file mode 100644 index 0000000000..838a54f362 --- /dev/null +++ b/upstream/ocaml_501/typing/printtyp.mli @@ -0,0 +1,249 @@ +(**************************************************************************) +(* *) +(* 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 namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string +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 := Shape.Sig_component_kind.t option + +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. *) +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: Shape.Sig_component_kind.t; + 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 + +(** Print out a type. This will pick names for type variables, and will not + reuse names for common type variables shared across multiple type + expressions. (It will also reset the printing state, which matters for + other type formatters such as [prepared_type_expr].) If you want multiple + types to use common names for type variables, see [prepare_for_printing] and + [prepared_type_expr]. *) +val type_expr: formatter -> type_expr -> unit + +(** [prepare_for_printing] resets the global printing environment, a la [reset], + and prepares the types for printing by reserving names and marking loops. + Any type variables that are shared between multiple types in the input list + will be given the same name when printed with [prepared_type_expr]. *) +val prepare_for_printing: type_expr list -> unit + +(** [add_type_to_preparation ty] extend a previous type expression preparation + to the type expression [ty] +*) +val add_type_to_preparation: type_expr -> unit + +val prepared_type_expr: formatter -> type_expr -> unit +(** The function [prepared_type_expr] is a less-safe but more-flexible version + of [type_expr] that should only be called on [type_expr]s that have been + passed to [prepare_for_printing]. Unlike [type_expr], this function does no + extra work before printing a type; in particular, this means that any loops + in the type expression may cause a stack overflow (see #8860) since this + function does not mark any loops. The benefit of this is that if multiple + type expressions are prepared simultaneously and then printed with + [prepared_type_expr], they will use the same names for the same type + variables. *) + +val constructor_arguments: formatter -> constructor_arguments -> unit +val tree_of_type_scheme: type_expr -> out_type +val type_scheme: formatter -> type_expr -> unit +val prepared_type_scheme: formatter -> type_expr -> unit +val shared_type_scheme: formatter -> type_expr -> unit +(** [shared_type_scheme] is very similar to [type_scheme], but does not reset + the printing context first. This is intended to be used in cases where the + printing should have a particularly wide context, such as documentation + generators; most use cases, such as error messages, have narrower contexts + for which [type_scheme] is better suited. *) + +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 add_constructor_to_preparation : constructor_declaration -> unit +val prepared_constructor : formatter -> constructor_declaration -> unit +val constructor : formatter -> constructor_declaration -> unit +val tree_of_type_declaration: + Ident.t -> type_declaration -> rec_status -> out_sig_item +val add_type_declaration_to_preparation : + Ident.t -> type_declaration -> unit +val prepared_type_declaration: Ident.t -> formatter -> type_declaration -> unit +val type_declaration: Ident.t -> formatter -> type_declaration -> unit +val tree_of_extension_constructor: + Ident.t -> extension_constructor -> ext_status -> out_sig_item +val add_extension_constructor_to_preparation : + extension_constructor -> unit +val prepared_extension_constructor: + Ident.t -> formatter -> extension_constructor -> unit +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 + +type type_or_scheme = Type | Type_scheme + +val tree_of_signature: Types.signature -> out_sig_item list +val tree_of_typexp: type_or_scheme -> 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_or_scheme -> Format.formatter -> Errortrace.expanded_type -> unit +val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type +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_error -> + ?type_expected_explanation:(formatter -> unit) -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_equality_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.equality_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_moregen_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.moregen_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_comparison_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.comparison_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +module Subtype : sig + val report_error : + formatter -> + Env.t -> + Errortrace.Subtype.error -> + string -> + 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_501/typing/printtyped.ml b/upstream/ocaml_501/typing/printtyped.ml new file mode 100644 index 0000000000..2582ab0ea6 --- /dev/null +++ b/upstream/ocaml_501/typing/printtyped.ml @@ -0,0 +1,959 @@ +(**************************************************************************) +(* *) +(* 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) | Path.(Pextra_ty (y, Pcstr_ty 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 + | Path.Pextra_ty (y, Pext_ty) -> fmt_path_aux f y + +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 typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + +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 + begin match x.pat_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (pattern_extra (i+1) ppf) extra; + end; + 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 = i+1 in + begin match x.exp_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (expression_extra (i+1) ppf) extra; + end; + 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) -> + line i ppf "Texp_send \"%s\"\n" s; + expression i ppf e + | Texp_send (e, Tmeth_val s) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e + | Texp_send (e, Tmeth_ancestor(s, _)) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e + | 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(v, a, r) -> + line i ppf "Text_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; + 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_apply_unit me1 -> + line i ppf "Tmod_apply_unit\n"; + module_expr i ppf me1; + | 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 " %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_vars; + 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; + if cd_vars <> [] then line (i+1) ppf "cd_vars =%a\n" typevars cd_vars; + 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 "\n"; + pattern (i+1) ppf c_lhs; + begin match c_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf c_rhs; + +and value_binding i ppf x = + line i ppf "\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 " \"%a\"\n" fmt_ident 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 "" + +and label_x_expression i ppf (l, e) = + line i ppf "\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 " \"%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_501/typing/printtyped.mli b/upstream/ocaml_501/typing/printtyped.mli new file mode 100644 index 0000000000..43539ead9d --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/rec_check.ml b/upstream/ocaml_501/typing/rec_check.ml new file mode 100644 index 0000000000..d9e44c6023 --- /dev/null +++ b/upstream/ocaml_501/typing/rec_check.ml @@ -0,0 +1,1264 @@ +(**************************************************************************) +(* *) +(* 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 _ | Path.Pextra_ty _ -> + (* 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 |- : m -| G' + G' |- body : m + ------------------------------- + G |- let 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, _) -> + (* + G |- e: m[Dereference] + ---------------------- (plus weird 'eo' option) + G |- e#x: m + *) + join [ + expression e1 << 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_apply_unit f -> + modexp f << 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; + ] + | Path.Pextra_ty (p, _extra) -> + path p + +(* 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 |- : 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 = + match expr.exp_desc with + | Texp_function _ -> + (* Fast path: functions can never have invalid recursive references *) + true + | _ -> + match classify_expression expr with + | Static -> + (* The expression has known size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] + | Dynamic -> + (* The expression has unknown size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] + +(* 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_501/typing/rec_check.mli b/upstream/ocaml_501/typing/rec_check.mli new file mode 100644 index 0000000000..aa5c1ca3c1 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/shape.ml b/upstream/ocaml_501/typing/shape.ml new file mode 100644 index 0000000000..08b5e86ad1 --- /dev/null +++ b/upstream/ocaml_501/typing/shape.ml @@ -0,0 +1,538 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* 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 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 "" + | Predef name -> Format.fprintf fmt "" 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 + +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" + + let can_appear_in_types = function + | Value + | Extension_constructor -> + false + | Type + | Module + | Module_type + | Class + | Class_type -> + true +end + +module Item = struct + module T = struct + type t = string * Sig_component_kind.t + let compare = compare + + let make str ns = str, ns + + let value id = Ident.name id, Sig_component_kind.Value + let type_ id = Ident.name id, Sig_component_kind.Type + let module_ id = Ident.name id, Sig_component_kind.Module + let module_type id = Ident.name id, Sig_component_kind.Module_type + let extension_constructor id = + Ident.name id, Sig_component_kind.Extension_constructor + let class_ id = + Ident.name id, Sig_component_kind.Class + let class_type id = + Ident.name id, Sig_component_kind.Class_type + + let print fmt (name, ns) = + Format.fprintf fmt "%S[%s]" + name + (Sig_component_kind.to_string ns) + end + + include T + + module Map = Map.Make(T) +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + +let print fmt = + let print_uid_opt = + Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print) + in + let rec aux fmt { uid; desc } = + match desc with + | Var id -> + Format.fprintf fmt "%a%a" Ident.print id print_uid_opt uid + | Abs (id, t) -> + let rec collect_idents = function + | { uid = None; desc = Abs(id, t) } -> + let (ids, body) = collect_idents t in + id :: ids, body + | body -> + ([], body) + in + let (other_idents, body) = collect_idents t in + let pp_idents fmt idents = + let pp_sep fmt () = Format.fprintf fmt ",@ " in + Format.pp_print_list ~pp_sep Ident.print fmt idents + in + Format.fprintf fmt "Abs@[%a@,(@[%a,@ @[%a@]@])@]" + print_uid_opt uid pp_idents (id :: other_idents) aux body + | App (t1, t2) -> + Format.fprintf fmt "@[%a(@,%a)%a@]" aux t1 aux t2 + print_uid_opt uid + | Leaf -> + Format.fprintf fmt "<%a>" (Format.pp_print_option Uid.print) uid + | Proj (t, item) -> + begin match uid with + | None -> + Format.fprintf fmt "@[%a@ .@ %a@]" + aux t + Item.print item + | Some uid -> + Format.fprintf fmt "@[(%a@ .@ %a)<%a>@]" + aux t + Item.print item + Uid.print uid + end + | Comp_unit name -> Format.fprintf fmt "CU %s" name + | Struct map -> + let print_map fmt = + Item.Map.iter (fun item t -> + Format.fprintf fmt "@[%a ->@ %a;@]@," + Item.print item + aux t + ) + in + Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + in + Format.fprintf fmt"@[%a@]@;" aux + +let fresh_var ?(name="shape-var") uid = + let var = Ident.create_local name in + var, { uid = Some uid; desc = Var var } + +let for_unnamed_functor_param = Ident.create_local "()" + +let var uid id = + { uid = Some uid; desc = Var id } + +let abs ?uid var body = + { uid; desc = Abs (var, body) } + +let str ?uid map = + { uid; desc = Struct map } + +let leaf uid = + { uid = Some uid; desc = Leaf } + +let proj ?uid t item = + match t.desc with + | Leaf -> + (* When stuck projecting in a leaf we propagate the leaf + as a best effort *) + t + | Struct map -> + begin try Item.Map.find item map + with Not_found -> t (* ill-typed program *) + end + | _ -> + { uid; desc = Proj (t, item) } + +let app ?uid f ~arg = + { uid; desc = App (f, arg) } + +let decompose_abs t = + match t.desc with + | Abs (x, t) -> Some (x, t) + | _ -> None + +module Make_reduce(Params : sig + type env + val fuel : int + val read_unit_shape : unit_name:string -> t option + val find_shape : env -> Ident.t -> t +end) = struct + (* We implement a strong call-by-need reduction, following an + evaluator from Nathanaelle Courant. *) + + type nf = { uid: Uid.t option; desc: nf_desc } + and nf_desc = + | NVar of var + | NApp of nf * nf + | NAbs of local_env * var * t * delayed_nf + | NStruct of delayed_nf Item.Map.t + | NProj of nf * Item.t + | NLeaf + | NComp_unit of string + | NoFuelLeft of desc + (* A type of normal forms for strong call-by-need evaluation. + The normal form of an abstraction + Abs(x, t) + is a closure + NAbs(env, x, t, dnf) + when [env] is the local environment, and [dnf] is a delayed + normal form of [t]. + + A "delayed normal form" is morally equivalent to (nf Lazy.t), but + we use a different representation that is compatible with + memoization (lazy values are not hashable/comparable by default + comparison functions): we represent a delayed normal form as + just a not-yet-computed pair [local_env * t] of a term in a + local environment -- we could also see this as a term under + an explicit substitution. This delayed thunked is "forced" + by calling the normalization function as usual, but duplicate + computations are precisely avoided by memoization. + *) + and delayed_nf = Thunk of local_env * t + + and local_env = delayed_nf option Ident.Map.t + (* When reducing in the body of an abstraction [Abs(x, body)], we + bind [x] to [None] in the environment. [Some v] is used for + actual substitutions, for example in [App(Abs(x, body), t)], when + [v] is a thunk that will evaluate to the normal form of [t]. *) + + let improve_uid uid (nf : nf) = + match nf.uid with + | Some _ -> nf + | None -> { nf with uid } + + let in_memo_table memo_table memo_key f arg = + match Hashtbl.find memo_table memo_key with + | res -> res + | exception Not_found -> + let res = f arg in + Hashtbl.replace memo_table memo_key res; + res + + type env = { + fuel: int ref; + global_env: Params.env; + local_env: local_env; + reduce_memo_table: (local_env * t, nf) Hashtbl.t; + read_back_memo_table: (nf, t) Hashtbl.t; + } + + let bind env var shape = + { env with local_env = Ident.Map.add var shape env.local_env } + + let rec reduce_ env t = + let memo_key = (env.local_env, t) in + in_memo_table env.reduce_memo_table memo_key (reduce__ env) t + (* Memoization is absolutely essential for performance on this + problem, because the normal forms we build can in some real-world + cases contain an exponential amount of redundancy. Memoization + can avoid the repeated evaluation of identical subterms, + providing a large speedup, but even more importantly it + implicitly shares the memory of the repeated results, providing + much smaller normal forms (that blow up again if printed back + as trees). A functor-heavy file from Irmin has its shape normal + form decrease from 100Mio to 2.5Mio when memoization is enabled. + + Note: the local environment is part of the memoization key, while + it is defined using a type Ident.Map.t of non-canonical balanced + trees: two maps could have exactly the same items, but be + balanced differently and therefore hash differently, reducing + the effectivenss of memoization. + This could in theory happen, say, with the two programs + (fun x -> fun y -> ...) + and + (fun y -> fun x -> ...) + having "the same" local environments, with additions done in + a different order, giving non-structurally-equal trees. Should we + define our own hash functions to provide robust hashing on + environments? + + We believe that the answer is "no": this problem does not occur + in practice. We can assume that identifiers are unique on valid + typedtree fragments (identifier "stamps" distinguish + binding positions); in particular the two program fragments above + in fact bind *distinct* identifiers x (with different stamps) and + different identifiers y, so the environments are distinct. If two + environments are structurally the same, they must correspond to + the evaluation evnrionments of two sub-terms that are under + exactly the same scope of binders. So the two environments were + obtained by the same term traversal, adding binders in the same + order, giving the same balanced trees: the environments have the + same hash. +*) + + and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) = + let reduce env t = reduce_ env t in + let delay_reduce env t = Thunk (env.local_env, t) in + let force (Thunk (local_env, t)) = + reduce { env with local_env } t in + let return desc : nf = { uid = t.uid; desc } in + if !fuel < 0 then return (NoFuelLeft t.desc) + else + match t.desc with + | Comp_unit unit_name -> + begin match Params.read_unit_shape ~unit_name with + | Some t -> reduce env t + | None -> return (NComp_unit unit_name) + end + | App(f, arg) -> + let f = reduce env f in + begin match f.desc with + | NAbs(clos_env, var, body, _body_nf) -> + let arg = delay_reduce env arg in + let env = bind { env with local_env = clos_env } var (Some arg) in + reduce env body + |> improve_uid t.uid + | _ -> + let arg = reduce env arg in + return (NApp(f, arg)) + end + | Proj(str, item) -> + let str = reduce env str in + let nored () = return (NProj(str, item)) in + begin match str.desc with + | NStruct (items) -> + begin match Item.Map.find item items with + | exception Not_found -> nored () + | nf -> + force nf + |> improve_uid t.uid + end + | _ -> + nored () + end + | Abs(var, body) -> + let body_nf = delay_reduce (bind env var None) body in + return (NAbs(local_env, var, body, body_nf)) + | Var id -> + begin match Ident.Map.find id local_env with + (* Note: instead of binding abstraction-bound variables to + [None], we could unify it with the [Some v] case by + binding the bound variable [x] to [NVar x]. + + One reason to distinguish the situations is that we can + provide a different [Uid.t] location; for bound + variables, we use the [Uid.t] of the bound occurrence + (not the binding site), whereas for bound values we use + their binding-time [Uid.t]. *) + | None -> return (NVar id) + | Some def -> force def + | exception Not_found -> + match Params.find_shape global_env id with + | exception Not_found -> return (NVar id) + | res when res = t -> return (NVar id) + | res -> + decr fuel; + reduce env res + end + | Leaf -> return NLeaf + | Struct m -> + let mnf = Item.Map.map (delay_reduce env) m in + return (NStruct mnf) + + let rec read_back env (nf : nf) : t = + in_memo_table env.read_back_memo_table nf (read_back_ env) nf + (* The [nf] normal form we receive may contain a lot of internal + sharing due to the use of memoization in the evaluator. We have + to memoize here again, otherwise the sharing is lost by mapping + over the term as a tree. *) + + and read_back_ env (nf : nf) : t = + { uid = nf.uid; desc = read_back_desc env nf.desc } + + and read_back_desc env desc = + let read_back nf = read_back env nf in + let read_back_force (Thunk (local_env, t)) = + read_back (reduce_ { env with local_env } t) in + match desc with + | NVar v -> + Var v + | NApp (nft, nfu) -> + App(read_back nft, read_back nfu) + | NAbs (_env, x, _t, nf) -> + Abs(x, read_back_force nf) + | NStruct nstr -> + Struct (Item.Map.map read_back_force nstr) + | NProj (nf, item) -> + Proj (read_back nf, item) + | NLeaf -> Leaf + | NComp_unit s -> Comp_unit s + | NoFuelLeft t -> t + + let reduce global_env t = + let fuel = ref Params.fuel in + let reduce_memo_table = Hashtbl.create 42 in + let read_back_memo_table = Hashtbl.create 42 in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table; + read_back_memo_table; + local_env; + } in + reduce_ env t |> read_back env +end + +module Local_reduce = + (* Note: this definition with [type env = unit] is only suitable for + reduction of toplevel shapes -- shapes of compilation units, + where free variables are only Comp_unit names. If we wanted to + reduce shapes inside module signatures, we would need to take + a typing environment as parameter. *) + Make_reduce(struct + type env = unit + let fuel = 10 + let read_unit_shape ~unit_name:_ = None + let find_shape _env _id = raise Not_found + end) + +let local_reduce shape = + Local_reduce.reduce () shape + +let dummy_mod = { uid = None; desc = Struct Item.Map.empty } + +let of_path ~find_shape ~namespace = + let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function + | Pident id -> find_shape ns id + | Pdot (path, name) -> proj (aux Module path) (name, ns) + | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) + | Pextra_ty (path, extra) -> begin + match extra with + Pcstr_ty _ -> aux Type path + | Pext_ty -> aux Extension_constructor path + end + in + aux namespace + +let for_persistent_unit s = + { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s)); + desc = Comp_unit s } + +let leaf_for_unpack = { uid = None; desc = Leaf } + +let set_uid_if_none t uid = + match t.uid with + | None -> { t with uid = Some uid } + | _ -> t + +module Map = struct + type shape = t + type nonrec t = t Item.Map.t + + let empty = Item.Map.empty + + let add t item shape = Item.Map.add item shape t + + let add_value t id uid = Item.Map.add (Item.value id) (leaf uid) t + let add_value_proj t id shape = + let item = Item.value id in + Item.Map.add item (proj shape item) t + + let add_type t id uid = Item.Map.add (Item.type_ id) (leaf uid) t + let add_type_proj t id shape = + let item = Item.type_ id in + Item.Map.add item (proj shape item) t + + let add_module t id shape = Item.Map.add (Item.module_ id) shape t + let add_module_proj t id shape = + let item = Item.module_ id in + Item.Map.add item (proj shape item) t + + let add_module_type t id uid = + Item.Map.add (Item.module_type id) (leaf uid) t + let add_module_type_proj t id shape = + let item = Item.module_type id in + Item.Map.add item (proj shape item) t + + let add_extcons t id uid = + Item.Map.add (Item.extension_constructor id) (leaf uid) t + let add_extcons_proj t id shape = + let item = Item.extension_constructor id in + Item.Map.add item (proj shape item) t + + let add_class t id uid = Item.Map.add (Item.class_ id) (leaf uid) t + let add_class_proj t id shape = + let item = Item.class_ id in + Item.Map.add item (proj shape item) t + + let add_class_type t id uid = Item.Map.add (Item.class_type id) (leaf uid) t + let add_class_type_proj t id shape = + let item = Item.class_type id in + Item.Map.add item (proj shape item) t +end diff --git a/upstream/ocaml_501/typing/shape.mli b/upstream/ocaml_501/typing/shape.mli new file mode 100644 index 0000000000..8a5aaca4fb --- /dev/null +++ b/upstream/ocaml_501/typing/shape.mli @@ -0,0 +1,157 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* 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 Uid : sig + type t = private + | Compilation_unit of string + | Item of { comp_unit: string; id: int } + | Internal + | Predef of string + + 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 + +module Sig_component_kind : sig + type t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + val to_string : t -> string + + (** Whether the name of a component of that kind can appear in a type. *) + val can_appear_in_types : t -> bool +end + +module Item : sig + type t + + val make : string -> Sig_component_kind.t -> t + + val value : Ident.t -> t + val type_ : Ident.t -> t + val module_ : Ident.t -> t + val module_type : Ident.t -> t + val extension_constructor : Ident.t -> t + val class_ : Ident.t -> t + val class_type : Ident.t -> t + + module Map : Map.S with type key = t +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + +val print : Format.formatter -> t -> unit + +(* Smart constructors *) + +val for_unnamed_functor_param : var +val fresh_var : ?name:string -> Uid.t -> var * t + +val var : Uid.t -> Ident.t -> t +val abs : ?uid:Uid.t -> var -> t -> t +val app : ?uid:Uid.t -> t -> arg:t -> t +val str : ?uid:Uid.t -> t Item.Map.t -> t +val proj : ?uid:Uid.t -> t -> Item.t -> t +val leaf : Uid.t -> t + +val decompose_abs : t -> (var * t) option + +val for_persistent_unit : string -> t +val leaf_for_unpack : t + +module Map : sig + type shape = t + type nonrec t = t Item.Map.t + + val empty : t + + val add : t -> Item.t -> shape -> t + + val add_value : t -> Ident.t -> Uid.t -> t + val add_value_proj : t -> Ident.t -> shape -> t + + val add_type : t -> Ident.t -> Uid.t -> t + val add_type_proj : t -> Ident.t -> shape -> t + + val add_module : t -> Ident.t -> shape -> t + val add_module_proj : t -> Ident.t -> shape -> t + + val add_module_type : t -> Ident.t -> Uid.t -> t + val add_module_type_proj : t -> Ident.t -> shape -> t + + val add_extcons : t -> Ident.t -> Uid.t -> t + val add_extcons_proj : t -> Ident.t -> shape -> t + + val add_class : t -> Ident.t -> Uid.t -> t + val add_class_proj : t -> Ident.t -> shape -> t + + val add_class_type : t -> Ident.t -> Uid.t -> t + val add_class_type_proj : t -> Ident.t -> shape -> t +end + +val dummy_mod : t + +val of_path : + find_shape:(Sig_component_kind.t -> Ident.t -> t) -> + namespace:Sig_component_kind.t -> Path.t -> t + +val set_uid_if_none : t -> Uid.t -> t + +(** The [Make_reduce] functor is used to generate a reduction function for + shapes. + + It is parametrized by: + - an environment and a function to find shapes by path in that environment + - a function to load the shape of an external compilation unit + - some fuel, which is used to bound recursion when dealing with recursive + shapes introduced by recursive modules. (FTR: merlin currently uses a + fuel of 10, which seems to be enough for most practical examples) +*) +module Make_reduce(Context : sig + type env + + val fuel : int + + val read_unit_shape : unit_name:string -> t option + + val find_shape : env -> Ident.t -> t + end) : sig + val reduce : Context.env -> t -> t +end + +val local_reduce : t -> t diff --git a/upstream/ocaml_501/typing/signature_group.ml b/upstream/ocaml_501/typing/signature_group.ml new file mode 100644 index 0000000000..b98a9eb67f --- /dev/null +++ b/upstream/ocaml_501/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 + syntactic 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 type [c] *) + begin match q with + | ct::t::q -> [ct;t], q + | _ -> assert false + end + | Types.Sig_class_type _ -> + (* a class type declaration for [ct] is followed by the ghost + declaration of type [ct] *) + begin match q with + | t::q -> [t], 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/upstream/ocaml_501/typing/signature_group.mli b/upstream/ocaml_501/typing/signature_group.mli new file mode 100644 index 0000000000..0b736a5b45 --- /dev/null +++ b/upstream/ocaml_501/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 + syntactic 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/upstream/ocaml_501/typing/stypes.ml b/upstream/ocaml_501/typing/stypes.ml new file mode 100644 index 0000000000..c3db19a552 --- /dev/null +++ b/upstream/ocaml_501/typing/stypes.ml @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* 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; + Format.pp_print_string Format.str_formatter " "; + Printtyp.wrap_printing_env ~error:false env + (fun () -> Printtyp.shared_type_scheme 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_501/typing/stypes.mli b/upstream/ocaml_501/typing/stypes.mli new file mode 100644 index 0000000000..3a86d27a57 --- /dev/null +++ b/upstream/ocaml_501/typing/stypes.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* 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_501/typing/subst.ml b/upstream/ocaml_501/typing/subst.ml new file mode 100644 index 0000000000..5c106d146e --- /dev/null +++ b/upstream/ocaml_501/typing/subst.ml @@ -0,0 +1,773 @@ +(**************************************************************************) +(* *) +(* 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) + | Pextra_ty _ -> + fatal_error "Subst.module_path" + +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 _ | Pextra_ty _ -> + fatal_error "Subst.modtype_path" + | Pident _ -> path + +(* For values, extension constructors, classes and class types *) +let value_path s path = + match path with + | Pident _ -> path + | Pdot(p, n) -> Pdot(module_path s p, n) + | Papply _ | Pextra_ty _ -> fatal_error "Subst.value_path" + +let rec 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" + | Pextra_ty (p, extra) -> + match extra with + | Pcstr_ty _ -> Pextra_ty (type_path s p, extra) + | Pext_ty -> Pextra_ty (value_path s p, extra) + +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; + create_expr + 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 desc = get_desc ty in + match desc with + Tvar _ | Tunivar _ -> + if s.for_saving || get_id ty < 0 then + let ty' = + if s.for_saving then newpersty (norm desc) + else newty2 ~level:(get_level ty) desc + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + ty' + else ty + | Tsubst (ty, _) -> + ty + | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method + && field_kind_repr k <> Fabsent && get_level ty < 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 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 newgenstub ~scope:(get_scope ty) + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + let desc = + if has_fixed_row then + match get_desc tm 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 more = row_more row in + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + begin match mored with + Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + let dup = + s.for_saving || get_level more = generic_level || + static_row row || is_Tconstr more in + (* Various cases for the row variable *) + let more' = + match mored with + Tsubst (ty, None) -> ty + | Tconstr _ | Tnil -> typexp copy_scope s more + | Tunivar _ | Tvar _ -> + if s.for_saving then newpersty (norm mored) + else if dup && is_Tvar more then newgenty mored + else more + | _ -> assert false + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope 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_name row with + | Some (p, tl) -> + let name = + if to_subst_by_type_function s p then None + else Some (type_path s p, tl) + in + Tvariant (set_row_name row name) + | 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 + in + Transient_expr.set_stub_desc ty' desc; + 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_self_row = typexp copy_scope s sign.csig_self_row; + csig_vars = + Vars.map + (function (m, v, t) -> (m, v, typexp copy_scope s t)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, t) -> (p, v, typexp copy_scope s t)) + sign.csig_meths; + } + +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_hash_type = type_declaration' copy_scope s decl.clty_hash_type ; + 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) + + +(* 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 }) + +type scoping = + | Keep + | Make_local + | Rescope of int + +module Lazy_types = struct + + type module_decl = + { + mdl_type: modtype; + mdl_attributes: Parsetree.attributes; + mdl_loc: Location.t; + mdl_uid: Uid.t; + } + + and modtype = + | MtyL_ident of Path.t + | MtyL_signature of signature + | MtyL_functor of functor_parameter * modtype + | MtyL_alias of Path.t + + and modtype_declaration = + { + mtdl_type: modtype option; + mtdl_attributes: Parsetree.attributes; + mtdl_loc: Location.t; + mtdl_uid: Uid.t; + } + + and signature' = + | S_eager of Types.signature + | S_lazy of signature_item list + + and signature = + (scoping * t * signature', signature') Lazy_backtrack.t + + and signature_item = + SigL_value of Ident.t * value_description * visibility + | SigL_type of Ident.t * type_declaration * rec_status * visibility + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility + | SigL_module of + Ident.t * module_presence * module_decl * rec_status * visibility + | SigL_modtype of Ident.t * modtype_declaration * visibility + | SigL_class of Ident.t * class_declaration * rec_status * visibility + | SigL_class_type of Ident.t * class_type_declaration * + rec_status * visibility + + and functor_parameter = + | Unit + | Named of Ident.t option * modtype + +end +open Lazy_types + +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 + | SigL_type(id, td, rs, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_type id (Pident id') s) + (SigL_type(id', td, rs, vis) :: sg) + rest + | SigL_module(id, pres, md, rs, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_module id (Pident id') s) + (SigL_module (id', pres, md, rs, vis) :: sg) + rest + | SigL_modtype(id, mtd, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_modtype id (Mty_ident(Pident id')) s) + (SigL_modtype(id', mtd, vis) :: sg) + rest + | SigL_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) + (SigL_class(id', cd, rs, vis) :: sg) + rest + | SigL_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) + (SigL_class_type(id', ctd, rs, vis) :: sg) + rest + | SigL_value(id, vd, vis) :: rest -> + (* scope doesn't matter for value identifiers. *) + let id' = Ident.rename id in + rename_bound_idents s (SigL_value(id', vd, vis) :: sg) rest + | SigL_typext(id, ec, es, vis) :: rest -> + let id' = rename id in + rename_bound_idents s (SigL_typext(id',ec,es,vis) :: sg) rest + in + rename_bound_idents s [] sg + +let rec lazy_module_decl md = + { mdl_type = lazy_modtype md.md_type; + mdl_attributes = md.md_attributes; + mdl_loc = md.md_loc; + mdl_uid = md.md_uid } + +and subst_lazy_module_decl scoping s md = + let mdl_type = subst_lazy_modtype scoping s md.mdl_type in + { mdl_type; + mdl_attributes = attrs s md.mdl_attributes; + mdl_loc = loc s md.mdl_loc; + mdl_uid = md.mdl_uid } + +and force_module_decl md = + let md_type = force_modtype md.mdl_type in + { md_type; + md_attributes = md.mdl_attributes; + md_loc = md.mdl_loc; + md_uid = md.mdl_uid } + +and lazy_modtype = function + | Mty_ident p -> MtyL_ident p + | Mty_signature sg -> + MtyL_signature (Lazy_backtrack.create_forced (S_eager sg)) + | Mty_functor (Unit, mty) -> MtyL_functor (Unit, lazy_modtype mty) + | Mty_functor (Named (id, arg), res) -> + MtyL_functor (Named (id, lazy_modtype arg), lazy_modtype res) + | Mty_alias p -> MtyL_alias p + +and subst_lazy_modtype scoping s = function + | MtyL_ident p -> + begin match Path.Map.find p s.modtypes with + | mty -> lazy_modtype mty + | exception Not_found -> + begin match p with + | Pident _ -> MtyL_ident p + | Pdot(p, n) -> + MtyL_ident(Pdot(module_path s p, n)) + | Papply _ | Pextra_ty _ -> + fatal_error "Subst.modtype" + end + end + | MtyL_signature sg -> + MtyL_signature(subst_lazy_signature scoping s sg) + | MtyL_functor(Unit, res) -> + MtyL_functor(Unit, subst_lazy_modtype scoping s res) + | MtyL_functor(Named (None, arg), res) -> + MtyL_functor(Named (None, (subst_lazy_modtype scoping s) arg), + subst_lazy_modtype scoping s res) + | MtyL_functor(Named (Some id, arg), res) -> + let id' = Ident.rename id in + MtyL_functor(Named (Some id', (subst_lazy_modtype scoping s) arg), + subst_lazy_modtype scoping (add_module id (Pident id') s) res) + | MtyL_alias p -> + MtyL_alias (module_path s p) + +and force_modtype = function + | MtyL_ident p -> Mty_ident p + | MtyL_signature sg -> Mty_signature (force_signature sg) + | MtyL_functor (param, res) -> + let param : Types.functor_parameter = + match param with + | Unit -> Unit + | Named (id, mty) -> Named (id, force_modtype mty) in + Mty_functor (param, force_modtype res) + | MtyL_alias p -> Mty_alias p + +and lazy_modtype_decl mtd = + let mtdl_type = Option.map lazy_modtype mtd.mtd_type in + { mtdl_type; + mtdl_attributes = mtd.mtd_attributes; + mtdl_loc = mtd.mtd_loc; + mtdl_uid = mtd.mtd_uid } + +and subst_lazy_modtype_decl scoping s mtd = + { mtdl_type = Option.map (subst_lazy_modtype scoping s) mtd.mtdl_type; + mtdl_attributes = attrs s mtd.mtdl_attributes; + mtdl_loc = loc s mtd.mtdl_loc; + mtdl_uid = mtd.mtdl_uid } + +and force_modtype_decl mtd = + let mtd_type = Option.map force_modtype mtd.mtdl_type in + { mtd_type; + mtd_attributes = mtd.mtdl_attributes; + mtd_loc = mtd.mtdl_loc; + mtd_uid = mtd.mtdl_uid } + +and subst_lazy_signature scoping s sg = + match Lazy_backtrack.get_contents sg with + | Left (scoping', s', sg) -> + let scoping = + match scoping', scoping with + | sc, Keep -> sc + | _, (Make_local|Rescope _) -> scoping + in + let s = compose s' s in + Lazy_backtrack.create (scoping, s, sg) + | Right sg -> + Lazy_backtrack.create (scoping, s, sg) + +and force_signature sg = + List.map force_signature_item (force_signature_once sg) + +and force_signature_once sg = + lazy_signature' (Lazy_backtrack.force force_signature_once' sg) + +and lazy_signature' = function + | S_lazy sg -> sg + | S_eager sg -> List.map lazy_signature_item sg + +and force_signature_once' (scoping, s, sg) = + let sg = lazy_signature' sg in + (* 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 -> + S_lazy (List.rev_map (subst_lazy_signature_item' copy_scope scoping s') sg') + ) + +and lazy_signature_item = function + | Sig_value(id, d, vis) -> + SigL_value(id, d, vis) + | Sig_type(id, d, rs, vis) -> + SigL_type(id, d, rs, vis) + | Sig_typext(id, ext, es, vis) -> + SigL_typext(id, ext, es, vis) + | Sig_module(id, res, d, rs, vis) -> + SigL_module(id, res, lazy_module_decl d, rs, vis) + | Sig_modtype(id, d, vis) -> + SigL_modtype(id, lazy_modtype_decl d, vis) + | Sig_class(id, d, rs, vis) -> + SigL_class(id, d, rs, vis) + | Sig_class_type(id, d, rs, vis) -> + SigL_class_type(id, d, rs, vis) + +and subst_lazy_signature_item' copy_scope scoping s comp = + match comp with + SigL_value(id, d, vis) -> + SigL_value(id, value_description' copy_scope s d, vis) + | SigL_type(id, d, rs, vis) -> + SigL_type(id, type_declaration' copy_scope s d, rs, vis) + | SigL_typext(id, ext, es, vis) -> + SigL_typext(id, extension_constructor' copy_scope s ext, es, vis) + | SigL_module(id, pres, d, rs, vis) -> + SigL_module(id, pres, subst_lazy_module_decl scoping s d, rs, vis) + | SigL_modtype(id, d, vis) -> + SigL_modtype(id, subst_lazy_modtype_decl scoping s d, vis) + | SigL_class(id, d, rs, vis) -> + SigL_class(id, class_declaration' copy_scope s d, rs, vis) + | SigL_class_type(id, d, rs, vis) -> + SigL_class_type(id, cltype_declaration' copy_scope s d, rs, vis) + +and force_signature_item = function + | SigL_value(id, vd, vis) -> Sig_value(id, vd, vis) + | SigL_type(id, d, rs, vis) -> Sig_type(id, d, rs, vis) + | SigL_typext(id, ext, es, vis) -> Sig_typext(id, ext, es, vis) + | SigL_module(id, pres, d, rs, vis) -> + Sig_module(id, pres, force_module_decl d, rs, vis) + | SigL_modtype(id, d, vis) -> + Sig_modtype (id, force_modtype_decl d, vis) + | SigL_class(id, d, rs, vis) -> Sig_class(id, d, rs, vis) + | SigL_class_type(id, d, rs, vis) -> Sig_class_type(id, d, rs, vis) + +and modtype scoping s t = + t |> lazy_modtype |> subst_lazy_modtype scoping s |> force_modtype + +(* Composition of substitutions: + apply (compose s1 s2) x = apply s2 (apply s1 x) *) + +and compose s1 s2 = + if s1 == identity then s2 else + if s2 == identity then s1 else + { 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; + } + + +let subst_lazy_signature_item scoping s comp = + For_copy.with_scope + (fun copy_scope -> subst_lazy_signature_item' copy_scope scoping s comp) + +module Lazy = struct + include Lazy_types + + let of_module_decl = lazy_module_decl + let of_modtype = lazy_modtype + let of_modtype_decl = lazy_modtype_decl + let of_signature sg = Lazy_backtrack.create_forced (S_eager sg) + let of_signature_items sg = Lazy_backtrack.create_forced (S_lazy sg) + let of_signature_item = lazy_signature_item + + let module_decl = subst_lazy_module_decl + let modtype = subst_lazy_modtype + let modtype_decl = subst_lazy_modtype_decl + let signature = subst_lazy_signature + let signature_item = subst_lazy_signature_item + + let force_module_decl = force_module_decl + let force_modtype = force_modtype + let force_modtype_decl = force_modtype_decl + let force_signature = force_signature + let force_signature_once = force_signature_once + let force_signature_item = force_signature_item +end + +let signature sc s sg = + Lazy.(sg |> of_signature |> signature sc s |> force_signature) + +let signature_item sc s comp = + Lazy.(comp|> of_signature_item |> signature_item sc s |> force_signature_item) + +let modtype_declaration sc s decl = + Lazy.(decl |> of_modtype_decl |> modtype_decl sc s |> force_modtype_decl) + +let module_declaration scoping s decl = + Lazy.(decl |> of_module_decl |> module_decl scoping s |> force_module_decl) diff --git a/upstream/ocaml_501/typing/subst.mli b/upstream/ocaml_501/typing/subst.mli new file mode 100644 index 0000000000..b55d2cc6f2 --- /dev/null +++ b/upstream/ocaml_501/typing/subst.mli @@ -0,0 +1,152 @@ +(**************************************************************************) +(* *) +(* 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 + + +module Lazy : sig + type module_decl = + { + mdl_type: modtype; + mdl_attributes: Parsetree.attributes; + mdl_loc: Location.t; + mdl_uid: Uid.t; + } + + and modtype = + | MtyL_ident of Path.t + | MtyL_signature of signature + | MtyL_functor of functor_parameter * modtype + | MtyL_alias of Path.t + + and modtype_declaration = + { + mtdl_type: modtype option; (* Note: abstract *) + mtdl_attributes: Parsetree.attributes; + mtdl_loc: Location.t; + mtdl_uid: Uid.t; + } + + and signature + + and signature_item = + SigL_value of Ident.t * value_description * visibility + | SigL_type of Ident.t * type_declaration * rec_status * visibility + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility + | SigL_module of + Ident.t * module_presence * module_decl * rec_status * visibility + | SigL_modtype of Ident.t * modtype_declaration * visibility + | SigL_class of Ident.t * class_declaration * rec_status * visibility + | SigL_class_type of Ident.t * class_type_declaration * + rec_status * visibility + + and functor_parameter = + | Unit + | Named of Ident.t option * modtype + + + val of_module_decl : Types.module_declaration -> module_decl + val of_modtype : Types.module_type -> modtype + val of_modtype_decl : Types.modtype_declaration -> modtype_declaration + val of_signature : Types.signature -> signature + val of_signature_items : signature_item list -> signature + val of_signature_item : Types.signature_item -> signature_item + + val module_decl : scoping -> t -> module_decl -> module_decl + val modtype : scoping -> t -> modtype -> modtype + val modtype_decl : scoping -> t -> modtype_declaration -> modtype_declaration + val signature : scoping -> t -> signature -> signature + val signature_item : scoping -> t -> signature_item -> signature_item + + val force_module_decl : module_decl -> Types.module_declaration + val force_modtype : modtype -> Types.module_type + val force_modtype_decl : modtype_declaration -> Types.modtype_declaration + val force_signature : signature -> Types.signature + val force_signature_once : signature -> signature_item list + val force_signature_item : signature_item -> Types.signature_item +end diff --git a/upstream/ocaml_501/typing/tast_iterator.ml b/upstream/ocaml_501/typing/tast_iterator.ml new file mode 100644 index 0000000000..d103cf9e32 --- /dev/null +++ b/upstream/ocaml_501/typing/tast_iterator.ml @@ -0,0 +1,648 @@ +(**************************************************************************) +(* *) +(* 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 = + { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attributes -> unit; + 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; + location: iterator -> Location.t -> 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 iter_snd f (_, y) = f y +let iter_loc sub {loc; _} = sub.location sub loc + +let location _sub _l = () + +let attribute sub x = + let iterator = { + Ast_iterator.default_iterator + with location = fun _this x -> sub.location sub x + } in + iter_loc sub x.Parsetree.attr_name; + iterator.payload iterator x.Parsetree.attr_payload; + sub.location sub x.Parsetree.attr_loc + +let attributes sub l = List.iter (attribute sub) l + +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 = + sub.location sub x.ci_loc; + sub.attributes sub x.ci_attributes; + iter_loc sub x.ci_id_name; + List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params; + f x.ci_expr + +let module_type_declaration sub x = + sub.location sub x.mtd_loc; + sub.attributes sub x.mtd_attributes; + iter_loc sub x.mtd_name; + Option.iter (sub.module_type sub) x.mtd_type + +let module_declaration sub {md_loc; md_name; md_type; md_attributes; _} = + sub.location sub md_loc; + sub.attributes sub md_attributes; + iter_loc sub md_name; + sub.module_type sub md_type + +let module_substitution sub {ms_loc; ms_name; ms_txt; ms_attributes; _} = + sub.location sub ms_loc; + sub.attributes sub ms_attributes; + iter_loc sub ms_name; + iter_loc sub ms_txt + +let include_infos sub f {incl_loc; incl_mod; incl_attributes; _} = + sub.location sub incl_loc; + sub.attributes sub incl_attributes; + 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_loc; str_desc; str_env; _} = + sub.location sub str_loc; + sub.env sub str_env; + match str_desc with + | Tstr_eval (exp, attrs) -> sub.expr sub exp; sub.attributes sub attrs + | 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 (_, s, cltd) -> + iter_loc sub s; sub.class_type_declaration sub cltd) list + | Tstr_include incl -> include_infos sub (sub.module_expr sub) incl + | Tstr_open od -> sub.open_declaration sub od + | Tstr_attribute attr -> sub.attribute sub attr + +let value_description sub x = + sub.location sub x.val_loc; + sub.attributes sub x.val_attributes; + iter_loc sub x.val_name; + sub.typ sub x.val_desc + +let label_decl sub {ld_loc; ld_name; ld_type; ld_attributes; _} = + sub.location sub ld_loc; + sub.attributes sub ld_attributes; + iter_loc sub ld_name; + 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 x = + sub.location sub x.cd_loc; + sub.attributes sub x.cd_attributes; + iter_loc sub x.cd_name; + List.iter (iter_loc sub) x.cd_vars; + constructor_args sub x.cd_args; + Option.iter (sub.typ sub) x.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 x = + sub.location sub x.typ_loc; + sub.attributes sub x.typ_attributes; + iter_loc sub x.typ_name; + List.iter + (fun (c1, c2, loc) -> + sub.typ sub c1; + sub.typ sub c2; + sub.location sub loc) + x.typ_cstrs; + sub.type_kind sub x.typ_kind; + Option.iter (sub.typ sub) x.typ_manifest; + List.iter (fun (c, _) -> sub.typ sub c) x.typ_params + +let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list + +let type_extension sub x = + sub.location sub x.tyext_loc; + sub.attributes sub x.tyext_attributes; + iter_loc sub x.tyext_txt; + List.iter (fun (c, _) -> sub.typ sub c) x.tyext_params; + List.iter (sub.extension_constructor sub) x.tyext_constructors + +let type_exception sub {tyexn_loc; tyexn_constructor; tyexn_attributes; _} = + sub.location sub tyexn_loc; + sub.attributes sub tyexn_attributes; + sub.extension_constructor sub tyexn_constructor + +let extension_constructor sub {ext_loc; ext_name; ext_kind; ext_attributes; _} = + sub.location sub ext_loc; + sub.attributes sub ext_attributes; + iter_loc sub ext_name; + match ext_kind with + | Text_decl (ids, ctl, cto) -> + List.iter (iter_loc sub) ids; + constructor_args sub ctl; + Option.iter (sub.typ sub) cto + | Text_rebind (_, lid) -> iter_loc sub lid + +let pat_extra sub (e, loc, attrs) = + sub.location sub loc; + sub.attributes sub attrs; + match e with + | Tpat_type (_, lid) -> iter_loc sub lid + | Tpat_unpack -> () + | Tpat_open (_, lid, env) -> iter_loc sub lid; sub.env sub env + | Tpat_constraint ct -> sub.typ sub ct + +let pat + : type k . iterator -> k general_pattern -> unit + = fun sub {pat_loc; pat_extra=extra; pat_desc; pat_env; pat_attributes; _} -> + sub.location sub pat_loc; + sub.attributes sub pat_attributes; + sub.env sub pat_env; + List.iter (pat_extra sub) extra; + match pat_desc with + | Tpat_any -> () + | Tpat_var (_, s) -> iter_loc sub s + | Tpat_constant _ -> () + | Tpat_tuple l -> List.iter (sub.pat sub) l + | Tpat_construct (lid, _, l, vto) -> + iter_loc sub lid; + List.iter (sub.pat sub) l; + Option.iter (fun (ids, ct) -> + List.iter (iter_loc sub) ids; sub.typ sub ct) vto + | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po + | Tpat_record (l, _) -> + List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l + | Tpat_array l -> List.iter (sub.pat sub) l + | Tpat_alias (p, _, s) -> sub.pat sub p; iter_loc sub s + | 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_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = + 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 + sub.location sub exp_loc; + sub.attributes sub exp_attributes; + List.iter (fun (e, loc, _) -> extra e; sub.location sub loc) exp_extra; + sub.env sub exp_env; + match exp_desc with + | Texp_ident (_, lid, _) -> iter_loc sub lid + | 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 (lid, _, args) -> + iter_loc sub lid; + 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 (lid, exp) -> iter_loc sub lid; sub.expr sub exp) + fields; + Option.iter (sub.expr sub) extended_expression; + | Texp_field (exp, lid, _) -> + iter_loc sub lid; + sub.expr sub exp + | Texp_setfield (exp1, lid, _, exp2) -> + iter_loc sub lid; + 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, _) -> + sub.expr sub exp + | Texp_new (_, lid, _) -> iter_loc sub lid + | Texp_instvar (_, _, s) -> iter_loc sub s + | Texp_setinstvar (_, _, s, exp) -> + iter_loc sub s; + sub.expr sub exp + | Texp_override (_, list) -> + List.iter (fun (_, s, e) -> iter_loc sub s; sub.expr sub e) list + | Texp_letmodule (_, s, _, mexpr, exp) -> + iter_loc sub s; + 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 (lid, _) -> iter_loc sub lid + | Texp_open (od, e) -> + sub.open_declaration sub od; + sub.expr sub e + + +let package_type sub {pack_fields; pack_txt; _} = + List.iter (fun (lid, p) -> iter_loc sub lid; sub.typ sub p) pack_fields; + iter_loc sub pack_txt + +let binding_op sub {bop_loc; bop_op_name; bop_exp; _} = + sub.location sub bop_loc; + iter_loc sub bop_op_name; + 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_loc; sig_desc; sig_env; _} = + sub.location sub sig_loc; + 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 (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 (_, s, mtype) -> iter_loc sub s; sub.module_type sub mtype + +let module_type sub {mty_loc; mty_desc; mty_env; mty_attributes; _} = + sub.location sub mty_loc; + sub.attributes sub mty_attributes; + sub.env sub mty_env; + match mty_desc with + | Tmty_ident (_, lid) -> iter_loc sub lid + | Tmty_alias (_, lid) -> iter_loc sub lid + | 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 (_, lid, e) -> + iter_loc sub lid; 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 (_, lid) -> iter_loc sub lid + | Twith_modsubst (_, lid) -> iter_loc sub lid + | Twith_modtype mty -> sub.module_type sub mty + | Twith_modtypesubst mty -> sub.module_type sub mty + + +let open_description sub {open_loc; open_expr; open_env; open_attributes; _} = + sub.location sub open_loc; + sub.attributes sub open_attributes; + iter_snd (iter_loc sub) open_expr; + sub.env sub open_env + +let open_declaration sub {open_loc; open_expr; open_env; open_attributes; _} = + sub.location sub open_loc; + sub.attributes sub open_attributes; + 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_loc; pc_env; _} -> + sub.location sub pc_loc; + sub.env sub pc_env + +let module_expr sub {mod_loc; mod_desc; mod_env; mod_attributes; _} = + sub.location sub mod_loc; + sub.attributes sub mod_attributes; + sub.env sub mod_env; + match mod_desc with + | Tmod_ident (_, lid) -> iter_loc sub lid + | 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_apply_unit mexp1 -> + sub.module_expr sub mexp1; + | 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_loc; mb_name; mb_expr; mb_attributes; _} = + sub.location sub mb_loc; + sub.attributes sub mb_attributes; + iter_loc sub mb_name; + sub.module_expr sub mb_expr + +let class_expr sub {cl_loc; cl_desc; cl_env; cl_attributes; _} = + sub.location sub cl_loc; + sub.attributes sub cl_attributes; + 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 (_, lid, tyl) -> + iter_loc sub lid; + 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_loc; cltyp_desc; cltyp_env; cltyp_attributes; _} = + sub.location sub cltyp_loc; + sub.attributes sub cltyp_attributes; + sub.env sub cltyp_env; + match cltyp_desc with + | Tcty_signature csg -> sub.class_signature sub csg + | Tcty_constr (_, lid, list) -> + iter_loc sub lid; + 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_loc; ctf_desc; ctf_attributes; _} = + sub.location sub ctf_loc; + sub.attributes sub ctf_attributes; + 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 attr -> sub.attribute sub attr + +let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = + sub.location sub ctyp_loc; + sub.attributes sub ctyp_attributes; + 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 (_, lid, list) -> + iter_loc sub lid; + List.iter (sub.typ sub) list + | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list + | Ttyp_class (_, lid, list) -> + iter_loc sub lid; + 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_loc; rf_desc; rf_attributes; _} = + sub.location sub rf_loc; + sub.attributes sub rf_attributes; + match rf_desc with + | Ttag (s, _, list) -> iter_loc sub s; List.iter (sub.typ sub) list + | Tinherit ct -> sub.typ sub ct + +let object_field sub {of_loc; of_desc; of_attributes; _} = + sub.location sub of_loc; + sub.attributes sub of_attributes; + match of_desc with + | OTtag (s, ct) -> iter_loc sub s; 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_loc; cf_desc; cf_attributes; _} = + sub.location sub cf_loc; + sub.attributes sub cf_attributes; + 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 (s, _, _, k, _) -> iter_loc sub s; class_field_kind sub k + | Tcf_method (s, _, k) -> iter_loc sub s;class_field_kind sub k + | Tcf_initializer exp -> sub.expr sub exp + | Tcf_attribute attr -> sub.attribute sub attr + +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_loc; vb_pat; vb_expr; vb_attributes; _} = + sub.location sub vb_loc; + sub.attributes sub vb_attributes; + sub.pat sub vb_pat; + sub.expr sub vb_expr + +let env _sub _ = () + +let default_iterator = + { + attribute; + attributes; + 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; + location; + 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_501/typing/tast_iterator.mli b/upstream/ocaml_501/typing/tast_iterator.mli new file mode 100644 index 0000000000..96352fc351 --- /dev/null +++ b/upstream/ocaml_501/typing/tast_iterator.mli @@ -0,0 +1,71 @@ +(**************************************************************************) +(* *) +(* 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 = + { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attributes -> unit; + 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; + location: iterator -> Location.t -> 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_501/typing/tast_mapper.ml b/upstream/ocaml_501/typing/tast_mapper.ml new file mode 100644 index 0000000000..d2cf5201f0 --- /dev/null +++ b/upstream/ocaml_501/typing/tast_mapper.ml @@ -0,0 +1,874 @@ +(**************************************************************************) +(* *) +(* 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 extension, + include_declaration, include_description *) + +type mapper = + { + attribute : mapper -> attribute -> attribute; + attributes : mapper -> attributes -> attributes; + 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; + location: mapper -> Location.t -> Location.t; + 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 map_loc sub {loc; txt} = {loc=sub.location sub loc; txt} + +let location _sub l = l + +let attribute sub x = + let mapper = { + Ast_mapper.default_mapper + with location = fun _this x -> sub.location sub x + } in + Parsetree.{ + attr_name = map_loc sub x.attr_name; + attr_payload = mapper.payload mapper x.attr_payload; + attr_loc = sub.location sub x.attr_loc + } + +let attributes sub l = List.map (attribute sub) l + +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_loc = sub.location sub x.ci_loc; + ci_id_name = map_loc sub x.ci_id_name; + ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params; + ci_expr = f x.ci_expr; + ci_attributes = sub.attributes sub x.ci_attributes; + } + +let module_type_declaration sub x = + let mtd_loc = sub.location sub x.mtd_loc in + let mtd_name = map_loc sub x.mtd_name in + let mtd_type = Option.map (sub.module_type sub) x.mtd_type in + let mtd_attributes = sub.attributes sub x.mtd_attributes in + {x with mtd_loc; mtd_name; mtd_type; mtd_attributes} + +let module_declaration sub x = + let md_loc = sub.location sub x.md_loc in + let md_name = map_loc sub x.md_name in + let md_type = sub.module_type sub x.md_type in + let md_attributes = sub.attributes sub x.md_attributes in + {x with md_loc; md_name; md_type; md_attributes} + +let module_substitution sub x = + let ms_loc = sub.location sub x.ms_loc in + let ms_name = map_loc sub x.ms_name in + let ms_txt = map_loc sub x.ms_txt in + let ms_attributes = sub.attributes sub x.ms_attributes in + {x with ms_loc; ms_name; ms_txt; ms_attributes} + +let include_infos sub f x = + let incl_loc = sub.location sub x.incl_loc in + let incl_attributes = sub.attributes sub x.incl_attributes in + {x with incl_loc; incl_attributes; 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_loc; str_desc; str_env} = + let str_loc = sub.location sub str_loc in + 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, sub.attributes sub 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 (map_loc sub) (sub.class_type_declaration sub)) list) + | Tstr_include incl -> + Tstr_include (include_infos sub (sub.module_expr sub) incl) + | Tstr_open od -> Tstr_open (sub.open_declaration sub od) + | Tstr_attribute attr -> Tstr_attribute (sub.attribute sub attr) + in + {str_desc; str_env; str_loc} + +let value_description sub x = + let val_loc = sub.location sub x.val_loc in + let val_name = map_loc sub x.val_name in + let val_desc = sub.typ sub x.val_desc in + let val_attributes = sub.attributes sub x.val_attributes in + {x with val_loc; val_name; val_desc; val_attributes} + +let label_decl sub x = + let ld_loc = sub.location sub x.ld_loc in + let ld_name = map_loc sub x.ld_name in + let ld_type = sub.typ sub x.ld_type in + let ld_attributes = sub.attributes sub x.ld_attributes in + {x with ld_loc; ld_name; ld_type; ld_attributes} + +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_loc = sub.location sub cd.cd_loc in + let cd_name = map_loc sub cd.cd_name in + let cd_vars = List.map (map_loc sub) cd.cd_vars in + let cd_args = constructor_args sub cd.cd_args in + let cd_res = Option.map (sub.typ sub) cd.cd_res in + let cd_attributes = sub.attributes sub cd.cd_attributes in + {cd with cd_loc; cd_name; cd_vars; cd_args; cd_res; cd_attributes} + +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_loc = sub.location sub x.typ_loc in + let typ_name = map_loc sub x.typ_name in + let typ_cstrs = + List.map + (tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + 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 + let typ_attributes = sub.attributes sub x.typ_attributes in + {x with typ_loc; typ_name; typ_cstrs; typ_kind; typ_manifest; typ_params; + typ_attributes} + +let type_declarations sub (rec_flag, list) = + (rec_flag, List.map (sub.type_declaration sub) list) + +let type_extension sub x = + let tyext_loc = sub.location sub x.tyext_loc in + let tyext_txt = map_loc sub x.tyext_txt in + 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 + let tyext_attributes = sub.attributes sub x.tyext_attributes in + {x with tyext_loc; tyext_txt; tyext_constructors; tyext_params; + tyext_attributes} + +let type_exception sub x = + let tyexn_loc = sub.location sub x.tyexn_loc in + let tyexn_constructor = + sub.extension_constructor sub x.tyexn_constructor + in + let tyexn_attributes = sub.attributes sub x.tyexn_attributes in + {tyexn_loc; tyexn_constructor; tyexn_attributes} + +let extension_constructor sub x = + let ext_loc = sub.location sub x.ext_loc in + let ext_name = map_loc sub x.ext_name in + let ext_kind = + match x.ext_kind with + Text_decl(ids, ctl, cto) -> + Text_decl( + List.map (map_loc sub) ids, + constructor_args sub ctl, + Option.map (sub.typ sub) cto + ) + | Text_rebind (path, lid) -> + Text_rebind (path, map_loc sub lid) + in + let ext_attributes = sub.attributes sub x.ext_attributes in + {x with ext_loc; ext_name; ext_kind; ext_attributes} + +let pat_extra sub = function + | Tpat_unpack as d -> d + | Tpat_type (path,loc) -> Tpat_type (path, map_loc sub loc) + | Tpat_open (path,loc,env) -> + Tpat_open (path, map_loc sub 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_loc = sub.location sub x.pat_loc in + let pat_env = sub.env sub x.pat_env in + let pat_extra = + List.map (tuple3 (pat_extra sub) id (sub.attributes sub)) x.pat_extra in + let pat_desc : k pattern_desc = + match x.pat_desc with + | Tpat_any + | Tpat_constant _ -> x.pat_desc + | Tpat_var (id, s) -> Tpat_var (id, map_loc sub s) + | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) + | Tpat_construct (loc, cd, l, vto) -> + let vto = Option.map (fun (vl,cty) -> + List.map (map_loc sub) vl, sub.typ sub cty) vto in + Tpat_construct (map_loc sub 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 (map_loc sub) 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, map_loc sub 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 + let pat_attributes = sub.attributes sub x.pat_attributes in + {x with pat_loc; pat_extra; pat_desc; pat_env; pat_attributes} + +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_loc = sub.location sub x.exp_loc in + let exp_extra = List.map (tuple3 extra (sub.location sub) 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 (path, lid, vd) -> + Texp_ident (path, map_loc sub lid, vd) + | 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 (map_loc sub 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, mut) -> label, Kept (t, mut) + | label, Overridden (lid, exp) -> + label, Overridden (map_loc sub 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, map_loc sub lid, ld) + | Texp_setfield (exp1, lid, ld, exp2) -> + Texp_setfield ( + sub.expr sub exp1, + map_loc sub 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) -> + Texp_send + ( + sub.expr sub exp, + meth + ) + | Texp_new (path, lid, cd) -> + Texp_new ( + path, + map_loc sub lid, + cd + ) + | Texp_instvar (path1, path2, id) -> + Texp_instvar ( + path1, + path2, + map_loc sub id + ) + | Texp_setinstvar (path1, path2, id, exp) -> + Texp_setinstvar ( + path1, + path2, + map_loc sub id, + sub.expr sub exp + ) + | Texp_override (path, list) -> + Texp_override ( + path, + List.map (tuple3 id (map_loc sub) (sub.expr sub)) list + ) + | Texp_letmodule (id, s, pres, mexpr, exp) -> + Texp_letmodule ( + id, + map_loc sub 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, loc) -> + Texp_assert (sub.expr sub exp, loc) + | 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 (lid, path) -> + Texp_extension_constructor (map_loc sub lid, path) + | Texp_open (od, e) -> + Texp_open (sub.open_declaration sub od, sub.expr sub e) + in + let exp_attributes = sub.attributes sub x.exp_attributes in + {x with exp_loc; exp_extra; exp_desc; exp_env; exp_attributes} + + +let package_type sub x = + let pack_txt = map_loc sub x.pack_txt in + let pack_fields = List.map + (tuple2 (map_loc sub) (sub.typ sub)) x.pack_fields in + {x with pack_txt; pack_fields} + +let binding_op sub x = + let bop_loc = sub.location sub x.bop_loc in + let bop_op_name = map_loc sub x.bop_op_name in + { x with bop_loc; bop_op_name; 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_loc = sub.location sub x.sig_loc in + 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 (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 attr -> Tsig_attribute (sub.attribute sub attr) + in + {sig_loc; 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, map_loc sub s, sub.module_type sub mtype) + +let module_type sub x = + let mty_loc = sub.location sub x.mty_loc in + let mty_env = sub.env sub x.mty_env in + let mty_desc = + match x.mty_desc with + | Tmty_ident (path, lid) -> Tmty_ident (path, map_loc sub lid) + | Tmty_alias (path, lid) -> Tmty_alias (path, map_loc sub lid) + | 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 (map_loc sub) (sub.with_constraint sub)) list + ) + | Tmty_typeof mexpr -> + Tmty_typeof (sub.module_expr sub mexpr) + in + let mty_attributes = sub.attributes sub x.mty_attributes in + {x with mty_loc; mty_desc; mty_env; mty_attributes} + +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_modtype mty -> Twith_modtype (sub.module_type sub mty) + | Twith_modtypesubst mty -> Twith_modtypesubst (sub.module_type sub mty) + | Twith_module (path, lid) -> Twith_module (path, map_loc sub lid) + | Twith_modsubst (path, lid) -> Twith_modsubst (path, map_loc sub lid) + +let open_description sub od = + {od with open_loc = sub.location sub od.open_loc; + open_expr = tuple2 id (map_loc sub) od.open_expr; + open_env = sub.env sub od.open_env; + open_attributes = sub.attributes sub od.open_attributes} + +let open_declaration sub od = + {od with open_loc = sub.location sub od.open_loc; + open_expr = sub.module_expr sub od.open_expr; + open_env = sub.env sub od.open_env; + open_attributes = sub.attributes sub od.open_attributes} + +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_loc = sub.location sub pc.pc_loc; + pc_env = sub.env sub pc.pc_env} + +let module_expr sub x = + let mod_loc = sub.location sub x.mod_loc in + let mod_env = sub.env sub x.mod_env in + let mod_desc = + match x.mod_desc with + | Tmod_ident (path, lid) -> Tmod_ident (path, map_loc sub lid) + | 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_apply_unit mexp1 -> + Tmod_apply_unit (sub.module_expr sub mexp1) + | 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 + let mod_attributes = sub.attributes sub x.mod_attributes in + {x with mod_loc; mod_desc; mod_env; mod_attributes} + +let module_binding sub x = + let mb_loc = sub.location sub x.mb_loc in + let mb_name = map_loc sub x.mb_name in + let mb_expr = sub.module_expr sub x.mb_expr in + let mb_attributes = sub.attributes sub x.mb_attributes in + {x with mb_loc; mb_name; mb_expr; mb_attributes} + +let class_expr sub x = + let cl_loc = sub.location sub x.cl_loc in + 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, map_loc sub lid, List.map (sub.typ sub) tyl) + | Tcl_open (od, e) -> + Tcl_open (sub.open_description sub od, sub.class_expr sub e) + in + let cl_attributes = sub.attributes sub x.cl_attributes in + {x with cl_loc; cl_desc; cl_env; cl_attributes} + +let class_type sub x = + let cltyp_loc = sub.location sub x.cltyp_loc in + 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, + map_loc sub 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 + let cltyp_attributes = sub.attributes sub x.cltyp_attributes in + {x with cltyp_loc; cltyp_desc; cltyp_env; cltyp_attributes} + +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_loc = sub.location sub x.ctf_loc in + 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 attr -> + Tctf_attribute (sub.attribute sub attr) + in + let ctf_attributes = sub.attributes sub x.ctf_attributes in + {ctf_loc; ctf_desc; ctf_attributes} + +let typ sub x = + let ctyp_loc = sub.location sub x.ctyp_loc in + 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, map_loc sub 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, + map_loc sub 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 + let ctyp_attributes = sub.attributes sub x.ctyp_attributes in + {x with ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes} + +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_loc = sub.location sub x.rf_loc in + let rf_desc = match x.rf_desc with + | Ttag (label, b, list) -> + Ttag (map_loc sub label, b, List.map (sub.typ sub) list) + | Tinherit ct -> Tinherit (sub.typ sub ct) + in + let rf_attributes = sub.attributes sub x.rf_attributes in + {rf_loc; rf_desc; rf_attributes} + +let object_field sub x = + let of_loc = sub.location sub x.of_loc in + let of_desc = match x.of_desc with + | OTtag (label, ct) -> + OTtag (map_loc sub label, (sub.typ sub ct)) + | OTinherit ct -> OTinherit (sub.typ sub ct) + in + let of_attributes = sub.attributes sub x.of_attributes in + {of_loc; of_desc; of_attributes} + +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_loc = sub.location sub x.cf_loc in + 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 (map_loc sub s, mf, id, class_field_kind sub k, b) + | Tcf_method (s, priv, k) -> + Tcf_method (map_loc sub s, priv, class_field_kind sub k) + | Tcf_initializer exp -> + Tcf_initializer (sub.expr sub exp) + | Tcf_attribute attr -> + Tcf_attribute (sub.attribute sub attr) + in + let cf_attributes = sub.attributes sub x.cf_attributes in + {cf_loc; cf_desc; cf_attributes} + +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_loc = sub.location sub x.vb_loc in + let vb_pat = sub.pat sub x.vb_pat in + let vb_expr = sub.expr sub x.vb_expr in + let vb_attributes = sub.attributes sub x.vb_attributes in + {vb_loc; vb_pat; vb_expr; vb_attributes} + +let env _sub x = x + +let default = + { + attribute; + attributes; + 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; + location; + 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_501/typing/tast_mapper.mli b/upstream/ocaml_501/typing/tast_mapper.mli new file mode 100644 index 0000000000..f54cef2b06 --- /dev/null +++ b/upstream/ocaml_501/typing/tast_mapper.mli @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* 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 = + { + attribute : mapper -> attribute -> attribute; + attributes : mapper -> attributes -> attributes; + 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; + location: mapper -> Location.t -> Location.t; + 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_501/typing/type_immediacy.ml b/upstream/ocaml_501/typing/type_immediacy.ml new file mode 100644 index 0000000000..557ed4271a --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/type_immediacy.mli b/upstream/ocaml_501/typing/type_immediacy.mli new file mode 100644 index 0000000000..3fc2e3b4f9 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/typeclass.ml b/upstream/ocaml_501/typing/typeclass.ml new file mode 100644 index 0000000000..7005bd54c2 --- /dev/null +++ b/upstream/ocaml_501/typing/typeclass.ml @@ -0,0 +1,2178 @@ +(**************************************************************************) +(* *) +(* 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_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_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; + arity: int; + pub_meths: string list; + coe: Warnings.loc list; + req: 'a Typedtree.class_infos; +} + +type kind = + | Object + | Class + | Class_type + +type final = + | Final + | Not_final + +let kind_of_final = function + | Final -> Object + | Not_final -> Class + +type error = + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string + | 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_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of Errortrace.unification_error + | Bad_parameters of Ident.t * type_expr list * type_expr list + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list + | 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 + { id : Ident.t + ; clty : Types.class_declaration + ; nongen_vars : type_expr list + } + | Cannot_coerce_self of type_expr + | Non_collapsable_conjunction of + Ident.t * Types.class_declaration * Errortrace.unification_error + | Self_clash of Errortrace.unification_error + | Mutability_mismatch of string * mutable_flag + | No_overriding of string * string + | Duplicate of string * string + | Closing_self_type of class_signature + +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 = [] } + +(* + 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 *) + (************************************) + +let extract_constraints cty = + let sign = Btype.signature_of_class_type cty in + (Btype.instance_vars sign, + Btype.methods sign, + Btype.concrete_methods sign) + +(* Record a class type *) +let rc node = + Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); + node + +let update_class_signature loc env ~warn_implicit_public virt kind sign = + let implicit_public, implicit_declared = + Ctype.update_class_signature env sign + in + if implicit_declared <> [] then begin + match virt with + | Virtual -> () (* Should perhaps emit warning 17 here *) + | Concrete -> + raise (Error(loc, env, Undeclared_methods(kind, implicit_declared))) + end; + if warn_implicit_public && implicit_public <> [] then begin + Location.prerr_warning + loc (Warnings.Implicit_public_methods implicit_public) + end + +let complete_class_signature loc env virt kind sign = + update_class_signature loc env ~warn_implicit_public:false virt kind sign; + Ctype.hide_private_methods env sign + +let complete_class_type loc env virt kind typ = + let sign = Btype.signature_of_class_type typ in + complete_class_signature loc env virt kind sign + +let check_virtual loc env virt kind sign = + match virt with + | Virtual -> () + | Concrete -> + match Btype.virtual_methods sign, Btype.virtual_instance_vars sign with + | [], [] -> () + | meths, vars -> + raise(Error(loc, env, Virtual_class(kind, meths, vars))) + +let rec check_virtual_clty loc env virt kind clty = + match clty with + | Cty_constr(_, _, clty) | Cty_arrow(_, _, clty) -> + check_virtual_clty loc env virt kind clty + | Cty_signature sign -> + check_virtual loc env virt kind sign + +(* 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, commu_ok)) + + (***********************************) + (* Primitives for typing classes *) + (***********************************) + +let raise_add_method_failure loc env label sign failure = + match (failure : Ctype.add_method_failure) with + | Ctype.Unexpected_method -> + raise(Error(loc, env, Unexpected_field (sign.Types.csig_self, label))) + | Ctype.Type_mismatch trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +let raise_add_instance_variable_failure loc env label failure = + match (failure : Ctype.add_instance_variable_failure) with + | Ctype.Mutability_mismatch mut -> + raise (Error(loc, env, Mutability_mismatch(label, mut))) + | Ctype.Type_mismatch trace -> + raise (Error(loc, env, + Field_type_mismatch("instance variable", label, trace))) + +let raise_inherit_class_signature_failure loc env sign = function + | Ctype.Self_type_mismatch trace -> + raise(Error(loc, env, Self_clash trace)) + | Ctype.Method(label, failure) -> + raise_add_method_failure loc env label sign failure + | Ctype.Instance_variable(label, failure) -> + raise_add_instance_variable_failure loc env label failure + +let add_method loc env label priv virt ty sign = + match Ctype.add_method env label priv virt ty sign with + | () -> () + | exception Ctype.Add_method_failed failure -> + raise_add_method_failure loc env label sign failure + +let add_instance_variable ~strict loc env label mut virt ty sign = + match Ctype.add_instance_variable ~strict env label mut virt ty sign with + | () -> () + | exception Ctype.Add_instance_variable_failed failure -> + raise_add_instance_variable_failure loc env label failure + +let inherit_class_signature ~strict loc env sign1 sign2 = + match Ctype.inherit_class_signature ~strict env sign1 sign2 with + | () -> () + | exception Ctype.Inherit_class_signature_failed failure -> + raise_inherit_class_signature_failure loc env sign1 failure + +let inherit_class_type ~strict loc env sign1 cty2 = + let sign2 = + match Btype.scrape_class_type cty2 with + | Cty_signature sign2 -> sign2 + | _ -> + raise(Error(loc, env, Structure_expected cty2)) + in + inherit_class_signature ~strict loc env sign1 sign2 + +let unify_delayed_method_type loc env label ty expected_ty= + match Ctype.unify env ty expected_ty with + | () -> () + | exception Ctype.Unify trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +let type_constraint val_env sty sty' loc = + let cty = transl_simple_type val_env ~closed:false sty in + let ty = cty.ctyp_type in + let cty' = transl_simple_type val_env ~closed:false sty' in + let ty' = cty'.ctyp_type in + begin + try Ctype.unify val_env ty ty' with Ctype.Unify err -> + raise(Error(loc, val_env, Unconsistent_constraint err)); + 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 delayed_meth_specs = ref [] + +let rec class_type_field env sign self_scope ctf = + let loc = ctf.pctf_loc in + let mkctf desc = + { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } + in + let mkctf_with_attrs f = + Builtin_attributes.warning_scope ctf.pctf_attributes + (fun () -> mkctf (f ())) + in + match ctf.pctf_desc with + | Pctf_inherit sparent -> + mkctf_with_attrs + (fun () -> + let parent = class_type env Virtual self_scope sparent in + complete_class_type parent.cltyp_loc + env Virtual Class_type parent.cltyp_type; + inherit_class_type ~strict:false loc env sign parent.cltyp_type; + Tctf_inherit parent) + | Pctf_val ({txt=lab}, mut, virt, sty) -> + mkctf_with_attrs + (fun () -> + let cty = transl_simple_type env ~closed:false sty in + let ty = cty.ctyp_type in + add_instance_variable ~strict:false loc env lab mut virt ty sign; + Tctf_val (lab, mut, virt, cty)) + + | Pctf_method ({txt=lab}, priv, virt, sty) -> + mkctf_with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + match sty.ptyp_desc, priv with + | Ptyp_poly ([],sty'), Public -> + let expected_ty = Ctype.newvar () in + add_method loc env lab priv virt expected_ty sign; + let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) env loc in + delayed_meth_specs := + Warnings.mk_lazy (fun () -> + let cty = transl_simple_type_univars env sty' in + let ty = cty.ctyp_type in + unify_delayed_method_type loc env lab ty expected_ty; + returned_cty.ctyp_desc <- Ttyp_poly ([], cty); + returned_cty.ctyp_type <- ty; + ) :: !delayed_meth_specs; + Tctf_method (lab, priv, virt, returned_cty) + | _ -> + let cty = transl_simple_type env ~closed:false sty in + let ty = cty.ctyp_type in + add_method loc env lab priv virt ty sign; + Tctf_method (lab, priv, virt, cty)) + + | Pctf_constraint (sty, sty') -> + mkctf_with_attrs + (fun () -> + let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in + Tctf_constraint (cty, cty')) + + | Pctf_attribute x -> + Builtin_attributes.warning_attribute x; + mkctf (Tctf_attribute x) + + | Pctf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_signature virt env pcsig self_scope loc = + let {pcsig_self=sty; pcsig_fields=psign} = pcsig in + let sign = Ctype.new_class_signature () in + (* Introduce a dummy method preventing self type from being closed. *) + Ctype.add_dummy_method env ~scope:self_scope sign; + + let self_cty = transl_simple_type env ~closed:false sty in + let self_type = self_cty.ctyp_type in + begin try + Ctype.unify env self_type sign.csig_self + with Ctype.Unify _ -> + raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type)) + end; + + (* Class type fields *) + let fields = + Builtin_attributes.warning_scope [] + (fun () -> List.map (class_type_field env sign self_scope) psign) + in + check_virtual loc env virt Class_type sign; + { csig_self = self_cty; + csig_fields = fields; + csig_type = sign; } + +and class_type env virt self_scope scty = + Builtin_attributes.warning_scope scty.pcty_attributes + (fun () -> class_type_aux env virt self_scope scty) + +and class_type_aux env virt self_scope 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 + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method env ~scope:self_scope + (Btype.signature_of_class_type clty); + 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 ~closed:false sty in + let ty' = cty'.ctyp_type in + begin + try Ctype.unify env ty' ty with Ctype.Unify err -> + raise(Error(sty.ptyp_loc, env, Parameter_mismatch err)) + end; + cty' + ) styl params + in + let typ = Cty_constr (path, params, clty) in + (* Check for unexpected virtual methods *) + check_virtual_clty scty.pcty_loc env virt Class_type typ; + cltyp (Tcty_constr ( path, lid , ctys)) typ + + | Pcty_signature pcsig -> + let clsig = class_signature virt env pcsig self_scope scty.pcty_loc 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 ~closed: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 virt self_scope 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 virt self_scope 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 virt self_scope scty = + delayed_meth_specs := []; + let cty = class_type env virt self_scope scty in + List.iter Lazy.force (List.rev !delayed_meth_specs); + delayed_meth_specs := []; + cty + +(*******************************) + +let enter_ancestor_val name val_env = + Env.enter_unbound_value name Val_unbound_ancestor val_env + +let enter_self_val name val_env = + Env.enter_unbound_value name Val_unbound_self val_env + +let enter_instance_var_val name val_env = + Env.enter_unbound_value name Val_unbound_instance_variable val_env + +let enter_ancestor_met ~loc name ~sign ~meths ~cl_num ~ty ~attrs met_env = + let check s = Warnings.Unused_ancestor s in + let kind = Val_anc (sign, meths, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.enter_value ~check name desc met_env + +let add_self_met loc id sign self_var_kind vars cl_num + as_var ty attrs met_env = + let check = + if as_var then (fun s -> Warnings.Unused_var s) + else (fun s -> Warnings.Unused_var_strict s) + in + let kind = Val_self (sign, self_var_kind, vars, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.add_value ~check id desc met_env + +let add_instance_var_met loc label id sign cl_num attrs met_env = + let mut, ty = + match Vars.find label sign.csig_vars with + | (mut, _, ty) -> mut, ty + | exception Not_found -> assert false + in + let kind = Val_ivar (mut, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.add_value id desc met_env + +let add_instance_vars_met loc vars sign cl_num met_env = + List.fold_left + (fun met_env (label, id) -> + add_instance_var_met loc label id sign cl_num [] met_env) + met_env vars + +type intermediate_class_field = + | Inherit of + { override : override_flag; + parent : class_expr; + super : string option; + inherited_vars : (string * Ident.t) list; + super_meths : (string * Ident.t) list; + loc : Location.t; + attributes : attribute list; } + | Virtual_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + cty : core_type; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Concrete_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + override : override_flag; + definition : expression; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Virtual_method of + { label : string loc; + priv : private_flag; + cty : core_type; + loc : Location.t; + attributes : attribute list; } + | Concrete_method of + { label : string loc; + priv : private_flag; + override : override_flag; + sdefinition : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Constraint of + { cty1 : core_type; + cty2 : core_type; + loc : Location.t; + attributes : attribute list; } + | Initializer of + { sexpr : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Attribute of + { attribute : attribute; + loc : Location.t; + attributes : attribute list; } + +type first_pass_accummulater = + { rev_fields : intermediate_class_field list; + val_env : Env.t; + par_env : Env.t; + concrete_meths : MethSet.t; + concrete_vals : VarSet.t; + local_meths : MethSet.t; + local_vals : VarSet.t; + vars : Ident.t Vars.t; } + +let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = + let { rev_fields; val_env; par_env; concrete_meths; concrete_vals; + local_meths; local_vals; vars } = acc + in + let loc = cf.pcf_loc in + let attributes = cf.pcf_attributes in + let with_attrs f = Builtin_attributes.warning_scope attributes f in + match cf.pcf_desc with + | Pcf_inherit (override, sparent, super) -> + with_attrs + (fun () -> + let parent = + class_expr cl_num val_env par_env + Virtual self_scope sparent + in + complete_class_type parent.cl_loc + par_env Virtual Class parent.cl_type; + inherit_class_type ~strict:true loc val_env sign parent.cl_type; + let parent_sign = Btype.signature_of_class_type parent.cl_type in + let new_concrete_meths = Btype.concrete_methods parent_sign in + let new_concrete_vals = Btype.concrete_instance_vars parent_sign in + let over_meths = MethSet.inter new_concrete_meths concrete_meths in + let over_vals = VarSet.inter new_concrete_vals concrete_vals in + begin match override with + | Fresh -> + let cname = + match parent.cl_type with + | Cty_constr (p, _, _) -> Path.name p + | _ -> "inherited" + in + if not (MethSet.is_empty over_meths) then + Location.prerr_warning loc + (Warnings.Method_override + (cname :: MethSet.elements over_meths)); + if not (VarSet.is_empty over_vals) then + Location.prerr_warning loc + (Warnings.Instance_variable_override + (cname :: VarSet.elements over_vals)); + | Override -> + if MethSet.is_empty over_meths && VarSet.is_empty over_vals then + raise (Error(loc, val_env, No_overriding ("",""))) + end; + let concrete_vals = VarSet.union new_concrete_vals concrete_vals in + let concrete_meths = + MethSet.union new_concrete_meths concrete_meths + in + let val_env, par_env, inherited_vars, vars = + Vars.fold + (fun label _ (val_env, par_env, inherited_vars, vars) -> + let val_env = enter_instance_var_val label val_env in + let par_env = enter_instance_var_val label par_env in + let id = Ident.create_local label in + let inherited_vars = (label, id) :: inherited_vars in + let vars = Vars.add label id vars in + (val_env, par_env, inherited_vars, vars)) + parent_sign.csig_vars (val_env, par_env, [], vars) + in + (* Methods available through super *) + let super_meths = + MethSet.fold + (fun label acc -> (label, Ident.create_local label) :: acc) + new_concrete_meths [] + in + (* Super *) + let (val_env, par_env, super) = + match super with + | None -> (val_env, par_env, None) + | Some {txt=name} -> + let val_env = enter_ancestor_val name val_env in + let par_env = enter_ancestor_val name par_env in + (val_env, par_env, Some name) + in + let field = + Inherit + { override; parent; super; inherited_vars; + super_meths; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; + concrete_meths; concrete_vals; vars }) + | Pcf_val (label, mut, Cfk_virtual styp) -> + with_attrs + (fun () -> + let cty = + Ctype.with_local_level_if_principal + (fun () -> Typetexp.transl_simple_type val_env + ~closed:false styp) + ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type) + in + add_instance_variable ~strict:true loc val_env + label.txt mut Virtual cty.ctyp_type sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Virtual_val + { label; mut; id; cty; already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; vars }) + | Pcf_val (label, mut, Cfk_concrete (override, sdefinition)) -> + with_attrs + (fun () -> + if VarSet.mem label.txt local_vals then + raise(Error(loc, val_env, + Duplicate ("instance variable", label.txt))); + if VarSet.mem label.txt concrete_vals then begin + if override = Fresh then + Location.prerr_warning label.loc + (Warnings.Instance_variable_override[label.txt]) + end else begin + if override = Override then + raise(Error(loc, val_env, + No_overriding ("instance variable", label.txt))) + end; + let definition = + Ctype.with_local_level_if_principal + ~post:Typecore.generalize_structure_exp + (fun () -> type_exp val_env sdefinition) + in + add_instance_variable ~strict:true loc val_env + label.txt mut Concrete definition.exp_type sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Concrete_val + { label; mut; id; override; definition; + already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_vals = VarSet.add label.txt concrete_vals in + let local_vals = VarSet.add label.txt local_vals in + { acc with rev_fields; val_env; par_env; + concrete_vals; local_vals; vars }) + + | Pcf_method (label, priv, Cfk_virtual sty) -> + with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = transl_simple_type val_env ~closed:false sty in + let ty = cty.ctyp_type in + add_method loc val_env label.txt priv Virtual ty sign; + let field = + Virtual_method { label; priv; cty; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_method (label, priv, Cfk_concrete (override, expr)) -> + with_attrs + (fun () -> + if MethSet.mem label.txt local_meths then + raise(Error(loc, val_env, Duplicate ("method", label.txt))); + if MethSet.mem label.txt concrete_meths then begin + if override = Fresh then begin + Location.prerr_warning loc + (Warnings.Method_override [label.txt]) + end + end else begin + if override = Override then begin + raise(Error(loc, val_env, No_overriding("method", label.txt))) + end + end; + let expr = + match expr.pexp_desc with + | Pexp_poly _ -> expr + | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None + in + let sbody, sty = + match expr.pexp_desc with + | Pexp_poly (sbody, sty) -> sbody, sty + | _ -> assert false + in + let ty = + match sty with + | None -> Ctype.newvar () + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty' = + Typetexp.transl_simple_type val_env ~closed:false sty + in + cty'.ctyp_type + in + add_method loc val_env label.txt priv Concrete ty sign; + begin + try + match get_desc ty 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 + with Ctype.Unify err -> + raise(Error(loc, val_env, + Field_type_mismatch ("method", label.txt, err))) + end; + let sdefinition = make_method self_loc cl_num expr in + let warning_state = Warnings.backup () in + let field = + Concrete_method + { label; priv; override; sdefinition; + warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_meths = MethSet.add label.txt concrete_meths in + let local_meths = MethSet.add label.txt local_meths in + { acc with rev_fields; concrete_meths; local_meths }) + + | Pcf_constraint (sty1, sty2) -> + with_attrs + (fun () -> + let (cty1, cty2) = type_constraint val_env sty1 sty2 loc in + let field = + Constraint { cty1; cty2; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_initializer sexpr -> + with_attrs + (fun () -> + let sexpr = make_method self_loc cl_num sexpr in + let warning_state = Warnings.backup () in + let field = + Initializer { sexpr; warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + | Pcf_attribute attribute -> + Builtin_attributes.warning_attribute attribute; + let field = Attribute { attribute; loc; attributes } in + let rev_fields = field :: rev_fields in + { acc with rev_fields } + | Pcf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env cfs = + let rev_fields = [] in + let concrete_meths = MethSet.empty in + let concrete_vals = VarSet.empty in + let local_meths = MethSet.empty in + let local_vals = VarSet.empty in + let vars = Vars.empty in + let init_acc = + { rev_fields; val_env; par_env; + concrete_meths; concrete_vals; + local_meths; local_vals; vars } + in + let acc = + Builtin_attributes.warning_scope [] + (fun () -> + List.fold_left + (class_field_first_pass self_loc cl_num sign self_scope) + init_acc cfs) + in + List.rev acc.rev_fields, acc.vars + +and class_field_second_pass cl_num sign met_env field = + let mkcf desc loc attrs = + { cf_desc = desc; cf_loc = loc; cf_attributes = attrs } + in + match field with + | Inherit { override; parent; super; + inherited_vars; super_meths; loc; attributes } -> + let met_env = + add_instance_vars_met loc inherited_vars sign cl_num met_env + in + let met_env = + match super with + | None -> met_env + | Some name -> + let meths = + List.fold_left + (fun acc (label, id) -> Meths.add label id acc) + Meths.empty super_meths + in + let ty = Btype.self_type parent.cl_type in + let attrs = [] in + let _id, met_env = + enter_ancestor_met ~loc name ~sign ~meths + ~cl_num ~ty ~attrs met_env + in + met_env + in + let desc = + Tcf_inherit(override, parent, super, inherited_vars, super_meths) + in + met_env, mkcf desc loc attributes + | Virtual_val { label; mut; id; cty; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end + in + let kind = Tcfk_virtual cty in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Concrete_val { label; mut; id; override; + definition; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end + in + let kind = Tcfk_concrete(override, definition) in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Virtual_method { label; priv; cty; loc; attributes } -> + let kind = Tcfk_virtual cty in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes + | Concrete_method { label; priv; override; + sdefinition; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + let ty = Btype.method_type label.txt sign in + let self_type = sign.Types.csig_self in + let meth_type = + mk_expected + (Btype.newgenty (Tarrow(Nolabel, self_type, ty, commu_ok))) + in + let texp = + Ctype.with_raised_nongen_level + (fun () -> type_expect met_env sdefinition meth_type) in + let kind = Tcfk_concrete (override, texp) in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes) + | Constraint { cty1; cty2; loc; attributes } -> + let desc = Tcf_constraint(cty1, cty2) in + met_env, mkcf desc loc attributes + | Initializer { sexpr; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + let unit_type = Ctype.instance Predef.type_unit in + let self_type = sign.Types.csig_self in + let meth_type = + mk_expected + (Ctype.newty (Tarrow (Nolabel, self_type, unit_type, commu_ok))) + in + let texp = + Ctype.with_raised_nongen_level + (fun () -> type_expect met_env sexpr meth_type) in + let desc = Tcf_initializer texp in + met_env, mkcf desc loc attributes) + | Attribute { attribute; loc; attributes; } -> + let desc = Tcf_attribute attribute in + met_env, mkcf desc loc attributes + +and class_fields_second_pass cl_num sign met_env fields = + let _, rev_cfs = + List.fold_left + (fun (met_env, cfs) field -> + let met_env, cf = + class_field_second_pass cl_num sign met_env field + in + met_env, cf :: cfs) + (met_env, []) fields + in + List.rev rev_cfs + +(* 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 virt self_scope 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 sign = Ctype.new_class_signature () in + + (* Adding a dummy method to the signature prevents it from being closed / + escaping. That isn't needed for objects though. *) + begin match final with + | Not_final -> Ctype.add_dummy_method val_env ~scope:self_scope sign; + | Final -> () + end; + + (* Self binder *) + let (self_pat, self_pat_vars) = type_self_pattern val_env spat in + let val_env, par_env = + List.fold_right + (fun {pv_id; _} (val_env, par_env) -> + let name = Ident.name pv_id in + let val_env = enter_self_val name val_env in + let par_env = enter_self_val name par_env in + val_env, par_env) + self_pat_vars (val_env, par_env) + in + + (* Check that the binder has a correct type *) + begin try Ctype.unify val_env self_pat.pat_type sign.csig_self with + Ctype.Unify _ -> + raise(Error(spat.ppat_loc, val_env, + Pattern_type_clash self_pat.pat_type)) + end; + + (* Typing of class fields *) + let (fields, vars) = + class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env str + in + let kind = kind_of_final final in + + (* Check for unexpected virtual methods *) + check_virtual loc val_env virt kind sign; + + (* Update the class signature *) + update_class_signature loc val_env + ~warn_implicit_public:false virt kind sign; + + let meths = + Meths.fold + (fun label _ meths -> + Meths.add label (Ident.create_local label) meths) + sign.csig_meths Meths.empty + in + + (* Close the signature if it is final *) + begin match final with + | Not_final -> () + | Final -> + if not (Ctype.close_class_signature val_env sign) then + raise(Error(loc, val_env, Closing_self_type sign)); + end; + (* Typing of method bodies *) + Ctype.generalize_class_signature_spine val_env sign; + let self_var_kind = + match virt with + | Virtual -> Self_virtual(ref meths) + | Concrete -> Self_concrete meths + in + let met_env = + List.fold_right + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} met_env -> + add_self_met pv_loc pv_id sign self_var_kind vars + cl_num pv_as_var pv_type pv_attributes met_env) + self_pat_vars met_env + in + let fields = + class_fields_second_pass cl_num sign met_env fields + in + + (* Update the class signature and warn about public methods made private *) + update_class_signature loc val_env + ~warn_implicit_public:true virt kind sign; + + let meths = + match self_var_kind with + | Self_virtual meths_ref -> !meths_ref + | Self_concrete meths -> meths + in + { cstr_self = self_pat; + cstr_fields = fields; + cstr_type = sign; + cstr_meths = meths; } + +and class_expr cl_num val_env met_env virt self_scope scl = + Builtin_attributes.warning_scope scl.pcl_attributes + (fun () -> class_expr_aux cl_num val_env met_env virt self_scope scl) + +and class_expr_aux cl_num val_env met_env virt self_scope 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 ~closed:false sty) + styl + in + let (params, clty) = + Ctype.instance_class decl.cty_params decl.cty_type + in + let clty' = Btype.abbreviate_class_type path params clty in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type clty'); + 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 err -> + raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch err))) + tyl params; + (* Check for unexpected virtual methods *) + check_virtual_clty scl.pcl_loc val_env virt Class clty'; + 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 = + class_structure cl_num virt self_scope Not_final + 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 desc.cstr_type; + 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 virt self_scope sfun + | Pcl_fun (l, None, spat, scl') -> + let (pat, pv, val_env', met_env) = + Ctype.with_local_level_if_principal + (fun () -> + Typecore.type_class_arg_pattern cl_num val_env met_env l spat) + ~post: begin fun (pat, _, _, _) -> + let gen {pat_type = ty} = Ctype.generalize_structure ty in + iter_pattern gen pat + end + in + 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 Modules_rejected val_env pat.pat_type pat.pat_loc + [{c_lhs = pat; c_guard = None; c_rhs = dummy}] + in + let cl = + Ctype.with_raised_nongen_level + (fun () -> class_expr cl_num val_env' met_env virt self_scope scl') in + 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 <> []); + let cl = + Ctype.with_local_level_if_principal + (fun () -> class_expr cl_num val_env met_env virt self_scope scl') + ~post:(fun cl -> Ctype.generalize_class_type_structure cl.cl_type) + in + 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 + let ty = + Ctype.with_local_level ~post:Ctype.generalize + (fun () -> Ctype.instance vd.val_type) + in + let expr = + {exp_desc = + Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd); + exp_loc = Location.none; exp_extra = []; + exp_type = ty; + exp_attributes = []; + exp_env = val_env; + } + in + 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 virt self_scope 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) -> + let cl, clty = + Ctype.with_local_level_for_class begin fun () -> + let cl = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let cl = class_expr cl_num val_env met_env virt self_scope scl' in + complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type; + cl + end + and clty = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let clty = class_type val_env virt self_scope scty in + complete_class_type + clty.cltyp_loc val_env virt Class clty.cltyp_type; + clty + end + in + cl, clty + end + ~post: begin fun ({cl_type=cl}, {cltyp_type=clty}) -> + Ctype.limited_generalize_class_type (Btype.self_type_row cl) cl; + Ctype.limited_generalize_class_type (Btype.self_type_row clty) clty; + end + in + 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 + let ty = snd (Ctype.instance_class [] clty.cltyp_type) in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type ty); + rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); + cl_loc = scl.pcl_loc; + cl_type = ty; + 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 virt self_scope 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, commu_ok)) + | 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, commu_ok)) + | _ -> Ctype.newvar () + +(*******************************) + +let temp_abbrev loc 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 ty_td = + {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; + } + in + (!params, ty, ty_td) + +let initial_env define_class approx + (res, env) (cl, id, ty_id, obj_id, uid) = + (* Temporary abbreviations *) + let arity = List.length cl.pci_params in + let (obj_params, obj_ty, obj_td) = temp_abbrev cl.pci_loc arity uid in + let env = Env.add_type ~check:true obj_id obj_td env in + let (cl_params, cl_ty, cl_td) = temp_abbrev cl.pci_loc arity uid in + + (* Temporary type for the class constructor *) + let constr_type = + Ctype.with_local_level_if_principal (fun () -> approx cl.pci_expr) + ~post:Ctype.generalize_structure + in + let dummy_cty = Cty_signature (Ctype.new_class_signature ()) 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_hash_type = cl_td; (* Dummy value *) + 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_params, cl_ty, cl_td, + constr_type, + dummy_class)::res, + env) + +let class_infos define_class kind + (cl, id, ty_id, + obj_id, obj_params, obj_ty, + cl_params, cl_ty, cl_td, + constr_type, + dummy_class) + (res, env) = + + let ci_params, params, coercion_locs, expr, typ, sign = + Ctype.with_local_level_for_class begin fun () -> + TyVarEnv.reset (); + (* 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_virt cl.pci_expr in + Typecore.self_coercion := List.tl !Typecore.self_coercion; + res + with exn -> + Typecore.self_coercion := []; raise exn + in + let sign = Btype.signature_of_class_type typ in + (ci_params, params, coercion_locs, expr, typ, sign) + end + ~post: begin fun (_, params, _, _, typ, sign) -> + (* Generalize the row variable *) + List.iter (Ctype.limited_generalize sign.csig_self_row) params; + Ctype.limited_generalize_class_type sign.csig_self_row typ; + end + in + (* 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 row = Btype.self_type_row obj_type in + Ctype.unify env row (Ctype.newty Tnil); + begin try + List.iter2 (Ctype.unify env) obj_params obj_params' + with Ctype.Unify _ -> + raise(Error(cl.pci_loc, env, + Bad_parameters (obj_id, obj_params, obj_params'))) + end; + let ty = Btype.self_type obj_type in + 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; + + Ctype.set_object_name obj_id params (Btype.self_type typ); + + (* Check the other temporary abbreviation (#-type) *) + begin + let (cl_params', cl_type) = Ctype.instance_class params typ in + let ty = Btype.self_type cl_type in + begin try + List.iter2 (Ctype.unify env) cl_params cl_params' + with Ctype.Unify _ -> + raise(Error(cl.pci_loc, env, + Bad_class_type_parameters (ty_id, cl_params, cl_params'))) + end; + begin try + Ctype.unify env ty cl_ty + with Ctype.Unify _ -> + let ty_expanded = Ctype.object_fields ty in + raise(Error(cl.pci_loc, env, Abbrev_type_clash (ty, ty_expanded, 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 err -> + raise(Error(cl.pci_loc, env, + Constructor_type_mismatch (cl.pci_name.txt, err))) + 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 = Btype.class_body typ; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_hash_type = cl_td; + 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 + + (* Misc. *) + let arity = Btype.class_type_arity typ in + let pub_meths = Btype.public_methods sign in + + (* Final definitions *) + let (params', typ') = Ctype.instance_class params typ in + let 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 (Btype.self_type typ) + in + Ctype.set_object_name obj_id cl_params cl_ty; + let cl_abbr = + { cl_td with + type_params = cl_params; + type_manifest = Some cl_ty + } + in + let cltydef = + {clty_params = params'; clty_type = Btype.class_body typ'; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_hash_type = cl_abbr; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; + clty_uid = dummy_class.cty_uid; + } + in + ((cl, id, clty, ty_id, cltydef, obj_id, obj_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, ci_params, + arity, pub_meths, coe, expr) = + let cl_abbr = cltydef.clty_hash_type in + + begin try Ctype.collapse_conj_params env clty.cty_params + with Ctype.Unify err -> + raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, err))) + end; + + List.iter Ctype.generalize clty.cty_params; + Ctype.generalize_class_type 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; + + Ctype.nongen_vars_in_class_declaration clty + |> Option.iter (fun vars -> + let nongen_vars = Btype.TypeSet.elements vars in + raise(Error(cl.pci_loc, env + , Non_generalizable_class { id; clty; nongen_vars })); + ); + + begin match + Ctype.closed_class clty.cty_params + (Btype.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; 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_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_params, cl_ty, cl_td, + 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_params, cl_ty, cl_td, + constr_type, + dummy_class) + (res, env) + ) + +let extract_type_decls { clty; cltydef; obj_id; obj_abbr; req} decls = + (obj_id, obj_abbr, clty, cltydef, req) :: decls + +let merge_type_decls decl (obj_abbr, clty, cltydef) = + {decl with obj_abbr; clty; cltydef} + +let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_abbr; } = + (* Add definitions after cleaning them *) + Env.add_type ~check:true obj_id + (Subst.type_declaration Subst.identity obj_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; + arity; pub_meths; coe; req } = + let cl_abbr = cltydef.clty_hash_type in + 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 err -> + raise(Typecore.Error(loc, env, Typecore.Not_subtype err)) + 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_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, + Uid.mk ~current_unit:(Env.get_unit_name ()) + )) + cls + in + let res, env = + Ctype.with_local_level_for_class begin fun () -> + 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 + res, env + end + in + 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 virt sexpr = + incr class_num; + let self_scope = Ctype.get_current_level () in + let expr = + class_expr (Int.to_string !class_num) env env virt self_scope sexpr + in + complete_class_type expr.cl_loc env virt Class expr.cl_type; + (expr, expr.cl_type) + +let class_description env virt sexpr = + let self_scope = Ctype.get_current_level () in + let expr = class_type env virt self_scope sexpr in + complete_class_type expr.cltyp_loc env virt Class_type expr.cltyp_type; + (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_abbr = decl.cls_abbr; + clsty_info = decl.cls_info}) + decls, + env) + +let type_object env loc s = + incr class_num; + let desc = + class_structure (Int.to_string !class_num) + Concrete Btype.lowest_level Final env env loc s + in + complete_class_signature loc env Concrete Object desc.cstr_type; + let meths = Btype.public_methods desc.cstr_type in + (desc, meths) + +let () = + Typecore.type_object := type_object + +(*******************************) + +(* Check that there is no references through recursive modules (GPR#6491) *) +let rec check_recmod_class_type env cty = + match cty.pcty_desc with + | Pcty_constr(lid, _) -> + ignore (Env.lookup_cltype ~use:false ~loc:lid.loc lid.txt env) + | Pcty_extension _ -> () + | Pcty_arrow(_, _, cty) -> + check_recmod_class_type env cty + | Pcty_open(od, cty) -> + let _, env = !type_open_descr env od in + check_recmod_class_type env cty + | Pcty_signature csig -> + check_recmod_class_sig env csig + +and check_recmod_class_sig env csig = + List.iter + (fun ctf -> + match ctf.pctf_desc with + | Pctf_inherit cty -> check_recmod_class_type env cty + | Pctf_val _ | Pctf_method _ + | Pctf_constraint _ | Pctf_attribute _ | Pctf_extension _ -> ()) + csig.pcsig_fields + +let check_recmod_decl env sdecl = + check_recmod_class_type env sdecl.pci_expr + +(* 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 = + let decls, env = class_type_declarations env (List.map approx_class sdecls) in + List.iter (check_recmod_decl env) sdecls; + decls, env + +(*******************************) + +(* Error report *) + +open Format + +let non_virtual_string_of_kind = function + | Object -> "object" + | Class -> "non-virtual class" + | Class_type -> "non-virtual class type" + +let report_error env ppf = function + | Repeated_parameter -> + fprintf ppf "A type parameter occurs several times" + | Unconsistent_constraint err -> + fprintf ppf "@[The class constraints are not consistent.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type"); + fprintf ppf "@]" + | Field_type_mismatch (k, m, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The %s %s@ has type" k m) + (function ppf -> + fprintf ppf "but is expected to have type") + | Unexpected_field (ty, lab) -> + fprintf ppf + "@[@[<2>This object is expected to have type :@ %a@]\ + @ This type does not have a method %s." + Printtyp.type_expr ty lab + | 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.prepare_for_printing [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 Type abbrev) + !Oprint.out_type (Printtyp.tree_of_typexp Type actual) + !Oprint.out_type (Printtyp.tree_of_typexp Type expected) + | Constructor_type_mismatch (c, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The expression \"new %s\" has type" c) + (function ppf -> + fprintf ppf "but is used with type") + | Virtual_class (kind, mets, vals) -> + let kind = non_virtual_string_of_kind kind in + let missings = + match mets, vals with + [], _ -> "variables" + | _, [] -> "methods" + | _ -> "methods and variables" + in + fprintf ppf + "@[This %s has virtual %s.@ \ + @[<2>The following %s are virtual : %a@]@]" + kind missings missings + (pp_print_list ~pp_sep:pp_print_space pp_print_string) (mets @ vals) + | Undeclared_methods(kind, mets) -> + let kind = non_virtual_string_of_kind kind in + fprintf ppf + "@[This %s has undeclared virtual methods.@ \ + @[<2>The following methods were not declared : %a@]@]" + kind (pp_print_list ~pp_sep:pp_print_space pp_print_string) mets + | 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 err -> + Printtyp.report_unification_error ppf env err + (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.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The abbreviation %a@ is used with parameter(s)@ %a@ \ + which are incompatible with constraint(s)@ %a@]" + Printtyp.ident id + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) params) + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) cstrs) + | Bad_class_type_parameters (id, params, cstrs) -> + Printtyp.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The class type #%a@ is used with parameter(s)@ %a,@ \ + whereas the class type definition@ constrains@ \ + those parameters to be@ %a@]" + Printtyp.ident id + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) params) + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) cstrs) + | Class_match_failure error -> + Includeclass.report_error Type ppf error + | Unbound_val lab -> + fprintf ppf "Unbound instance variable %s" lab + | Unbound_type_var (printer, reason) -> + let print_reason ppf { Ctype.free_variable; meth; meth_ty; } = + let (ty0, kind) = free_variable in + let ty1 = + match kind with + | Type_variable -> ty0 + | Row_variable -> Btype.newgenty(Tobject(ty0, ref None)) + in + Printtyp.add_type_to_preparation meth_ty; + Printtyp.add_type_to_preparation ty1; + fprintf ppf + "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound" + meth + !Oprint.out_type (Printtyp.tree_of_typexp Type meth_ty) + !Oprint.out_type (Printtyp.tree_of_typexp Type ty0) + in + fprintf ppf + "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ + @[%a@]@]" + printer print_reason reason + | Non_generalizable_class {id; clty; nongen_vars } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in + Printtyp.prepare_for_printing nongen_vars; + fprintf ppf + "@[The type of this class,@ %a,@ \ + contains the non-generalizable type variable(s): %a.@ %a@]" + (Printtyp.class_declaration id) clty + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + Printtyp.prepared_type_scheme) nongen_vars + Misc.print_see_manual manual_ref + + | 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, err) -> + 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 err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type") + ) + | Self_clash err -> + Printtyp.report_unification_error ppf env err + (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 sign -> + 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 sign.csig_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_501/typing/typeclass.mli b/upstream/ocaml_501/typing/typeclass.mli new file mode 100644 index 0000000000..cdecc8dfb7 --- /dev/null +++ b/upstream/ocaml_501/typing/typeclass.mli @@ -0,0 +1,138 @@ +(**************************************************************************) +(* *) +(* 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_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_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 * Env.t + +(* +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 kind = + | Object + | Class + | Class_type + +type error = + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string + | 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_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of Errortrace.unification_error + | Bad_parameters of Ident.t * type_expr list * type_expr list + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list + | 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 + { id : Ident.t + ; clty : Types.class_declaration + ; nongen_vars : type_expr list + } + | Cannot_coerce_self of type_expr + | Non_collapsable_conjunction of + Ident.t * Types.class_declaration * Errortrace.unification_error + | Self_clash of Errortrace.unification_error + | Mutability_mismatch of string * mutable_flag + | No_overriding of string * string + | Duplicate of string * string + | Closing_self_type of class_signature + +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_501/typing/typecore.ml b/upstream/ocaml_501/typing/typecore.ml new file mode 100644 index 0000000000..90e98ff447 --- /dev/null +++ b/upstream/ocaml_501/typing/typecore.ml @@ -0,0 +1,6237 @@ +(**************************************************************************) +(* *) +(* 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 wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +let wrong_kind_sort_of_constructor (lid : Longident.t) = + match lid with + | Lident "true" | Lident "false" | Ldot(_, "true") | Ldot(_, "false") -> + Boolean + | Lident "[]" | Lident "::" | Ldot(_, "[]") | Ldot(_, "::") -> List + | Lident "()" | Ldot(_, "()") -> Unit + | _ -> Constructor + +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_error + | Pattern_type_clash : + Errortrace.unification_error * Parsetree.pattern_desc option -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * type_forcing_context option + * Parsetree.expression_desc option + | Apply_non_function of { + funct : Typedtree.expression; + func_ty : type_expr; + res_ty : type_expr; + previous_arg_loc : Location.t; + extra_arg_loc : Location.t; + } + | 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 + | Not_an_object of type_expr * type_forcing_context option + | Undefined_method of type_expr * string * string list option + | Undefined_self_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.error + | Outside_class + | Value_multiply_overridden of string + | Coercion_failure of + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } + | Scoping_let_module of string * type_expr + | Not_a_polymorphic_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * Errortrace.unification_error + | 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_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + +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 * Shape.t) + +(* 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 * 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 + +(* Whether or not patterns of the form (module M) are accepted. (If they are, + the idents will be created at the provided scope.) When module patterns are + allowed, the caller should take care to check that the introduced module + bindings' types don't escape their scope; see the callsites in [type_let] + and [type_cases] for examples. +*) +type module_patterns_restriction = + | Modules_allowed of { scope : int } + | Modules_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 get_desc (expand_head env ty) with + Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty + | _ -> assert false + +let protect_expansion env ty = + if Env.has_local_constraints env then generic_instance ty else ty + +type record_extraction_result = + | Record_type of Path.t * Path.t * Types.label_declaration list + | Not_a_record_type + | Maybe_a_record_type + +let extract_concrete_typedecl_protected env ty = + extract_concrete_typedecl env (protect_expansion env ty) + +let extract_concrete_record env ty = + match extract_concrete_typedecl_protected env ty with + | Typedecl(p0, p, {type_kind=Type_record (fields, _)}) -> + Record_type (p0, p, fields) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_record_type + | May_have_typedecl -> Maybe_a_record_type + +type variant_extraction_result = + | Variant_type of Path.t * Path.t * Types.constructor_declaration list + | Not_a_variant_type + | Maybe_a_variant_type + +let extract_concrete_variant env ty = + match extract_concrete_typedecl_protected env ty with + | Typedecl(p0, p, {type_kind=Type_variant (cstrs, _)}) -> + Variant_type (p0, p, cstrs) + | Typedecl(p0, p, {type_kind=Type_open}) -> + Variant_type (p0, p, []) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_variant_type + | May_have_typedecl -> Maybe_a_variant_type + +let extract_label_names env ty = + match extract_concrete_record env ty with + | Record_type (_, _,fields) -> List.map (fun l -> l.Types.ld_id) fields + | Not_a_record_type | Maybe_a_record_type -> assert false + +let is_principal ty = + not !Clflags.principal || get_level ty = generic_level + +(* 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 err -> + raise(Error(loc, env, Expr_type_clash(err, 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_equations -> + unify_gadt ~equations_level:(get_gadt_equations_level ()) + ~allow_recursive_equations env ty ty' + | None -> + unify !env ty ty'; + nothing_equated + with + | Unify err -> + raise(Error(loc, !env, Pattern_type_clash(err, 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') + + +(** [sdesc_for_hint] is used by error messages to report literals in their + original formatting *) +let unify_pat ?refine ?sdesc_for_hint 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(err, None)) -> + raise(Error(loc, env, Pattern_type_clash(err, sdesc_for_hint))) + +(* unification of a type with a Tconstr with freshly created arguments *) +let unify_head_only ~refine loc env ty constr = + let path = cstr_type_path constr 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 get_desc (expand_head pat.pat_env pat.pat_type) with + Tvariant row -> r := row; row + | _ -> assert false + in + let f = get_row_field tag row in + begin match row_field_repr f with + | Rabsent -> () (* assert false *) + | Reither (true, [], _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present None) + | Reither (false, ty::tl, _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present (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) when not (has_fixed_explanation row) -> + link_row_field_ext ~inside:f (rf_either [] ~no_arg:c ~matched:false) + | _ -> () + 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 = + { + mv_id: Ident.t; + mv_name: string Location.loc; + mv_loc: Location.t; + mv_uid: Uid.t + } + +let pattern_variables = ref ([] : pattern_variable list) +let pattern_force = ref ([] : (unit -> unit) list) +let allow_modules = ref Modules_rejected +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 = + if is_module then begin + (* Unpack patterns result in both a module declaration and a value + variable of the same name being entered into the environment. (The + module is via [module_variables], and the variable is via + [pattern_variables].) *) + match !allow_modules with + | Modules_rejected -> + raise (Error (loc, Env.empty, Modules_not_allowed)); + | Modules_allowed { scope } -> + let id = Ident.create_scoped name.txt ~scope in + module_variables := + { mv_id = id; + mv_name = name; + mv_loc = loc; + mv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } :: !module_variables; + id + end else + 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; + 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 err -> + raise(Error(loc, env, Or_pattern_type_clash(x1, err))) + 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 ~refine (env : Env.t ref) p = + let as_ty = build_as_type_aux ~refine 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]. *) + let ty = + with_local_level ~post:generalize_structure + (fun () -> instance cty.ctyp_type) + in + (* This call to unify can't fail since the pattern is well typed. *) + unify_pat_types ~refine p.pat_loc env (instance as_ty) (instance ty); + ty + ) as_ty p.pat_extra + +and build_as_type_aux ~refine (env : Env.t ref) p = + let build_as_type = build_as_type ~refine in + 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 Keep_existentials_flexible cstr + in + List.iter2 (fun (p,ty) -> unify_pat ~refine 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 + let fields = [l, rf_present ty] in + newty (Tvariant (create_row ~fields ~more:(newvar()) + ~name:None ~fixed:None ~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 ~refine env {p with pat_type = ty} ty_res; + let refinable = + lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && + match get_desc lbl.lbl_arg with Tpoly _ -> false | _ -> true in + if refinable then begin + let arg = List.assoc lbl.lbl_pos ppl in + unify_pat ~refine 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_pat_types ~refine p.pat_loc env ty_arg ty_arg'; + unify_pat ~refine 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 ~refine env {p2 with pat_type = ty2} ty1; + ty1 + | Some row -> + let Row {fields; fixed; name} = row_repr row in + newty (Tvariant (create_row ~fields ~fixed ~name + ~closed:false ~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 get_desc ty with + | Tpoly (body, tyl) -> + let _, ty' = + with_level ~level:generic_level + (fun () -> instance_poly ~keep_names:true false tyl body) + in + (cty, ty, ty') + | _ -> assert false + +let solve_Ppat_alias ~refine env pat = + with_local_level ~post:generalize (fun () -> build_as_type ~refine env pat) + +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 + let cty, ty, force = + with_local_level ~post:(fun (_,ty,_) -> generalize_structure ty) + (fun () -> Typetexp.transl_simple_type_delayed !env sty) + in + 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 get_desc (expand_head !env ty2) with + 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 get_desc tv with + 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; + + (* PR#7214: do not use gadt unification for toplevel lets *) + let unify_res ty_res expected_ty = + 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 ty_args, equated_types, existential_ctyp = + with_local_level_iter ~post: generalize_structure begin fun () -> + let expected_ty = instance 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 + (Make_existentials_abstract { env; scope = expansion_scope }) + constr + in + ty_args, ty_res, unify_res ty_res expected_ty, None + | Some (name_list, sty) -> + let existential_treatment = + if name_list = [] then + Make_existentials_abstract { env; scope = expansion_scope } + else + (* we will unify them (in solve_constructor_annotation) with the + local types provided by the user *) + Keep_existentials_flexible + in + let ty_args, ty_res, ty_ex = + instance_constructor existential_treatment constr + in + let equated_types = unify_res ty_res expected_ty 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 + if constr.cstr_existentials <> [] then + lower_variables_only !env expansion_scope ty_res; + ((ty_args, equated_types, existential_ctyp), + expected_ty :: ty_res :: ty_args) + end + in + if !Clflags.principal && refine = None then begin + (* Do not warn for counter-examples *) + 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 = + with_local_level_iter ~post:generalize_structure begin fun () -> + 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(err, _)) -> + raise(Error(label_lid.loc, !env, + Label_mismatch(label_lid.txt, err))) + end; + (ty_arg, [ty_res; ty_arg]) + end + +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 = + let cty, ty, force = + with_local_level ~post:(fun (_, ty, _) -> generalize_structure ty) + (fun () -> Typetexp.transl_simple_type_delayed !env sty) + in + pattern_force := force :: !pattern_force; + 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 no_arg expected_ty = + let arg_type = if no_arg then [] else [newgenvar()] in + let fields = [tag, rf_either ~no_arg arg_type ~matched:true] in + let make_row more = + create_row ~fields ~closed:false ~more ~fixed:None ~name:None + in + let row = make_row (newgenvar ()) 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, make_row (newvar ()), 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 get_desc ty with + Tvariant row when static_row row -> row + | _ -> raise(Error(lid.loc, env, Not_a_polymorphic_variant_type lid.txt)) + in + let pats, fields = + List.fold_left + (fun (pats,fields) (l,f) -> + match row_field_repr f with + Rpresent None -> + let f = rf_either [] ~no_arg:true ~matched:true in + (l,None) :: pats, + (l, f) :: fields + | Rpresent (Some ty) -> + let f = rf_either [ty] ~no_arg:false ~matched:true in + (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; + pat_type=ty; pat_extra=[]; pat_attributes=[]}) + :: pats, + (l, f) :: fields + | _ -> pats, fields) + ([],[]) (row_fields row0) in + let fields = List.rev fields in + let name = Some (path, tyl) in + let make_row more = + create_row ~fields ~more ~closed:false ~fixed:None ~name in + let ty = newty (Tvariant (make_row (newvar()))) in + let gloc = {loc with Location.loc_ghost=true} in + let row' = ref (make_row (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_polymorphic_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 get_desc ty with + 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 get_desc ty 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 (Some 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 = + if Warnings.is_active (Ambiguous_name ([],[],false,"")) then begin + 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)) + end + + (* 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 = + if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin + 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)) + end + + (* 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 = + (* If one label is qualified [{ foo = ...; M.bar = ... }], + we will disambiguate all labels using one of the qualifying modules, + as if the user had written [{ M.foo = ...; M.bar = ... }]. + + #11630: It is important to process first the + user-qualified labels, instead of processing all labels in + order, so that error messages coming from the lookup of + M (maybe no such module/path exists) are shown to the user + in context of a qualified field [M.bar] they wrote + themselves, instead of the "ghost" qualification [M.foo] + that does not come from the source program. *) + let lbl_list = + List.map (fun (lid, _) -> + match lid.txt with + | Longident.Ldot _ -> Some (process_label lid) + | _ -> None + ) lid_a_list + in + (* Find a module prefix (if any) to qualify unqualified labels *) + let qual = + List.find_map (function + | {txt = Longident.Ldot (modname, _); _}, _ -> Some modname + | _ -> None + ) lid_a_list + in + (* Prefix unqualified labels with [qual] and resolve them. + + Prefixing unqualified labels does not change the final + disambiguation result, it restricts the set of candidates + without removing any valid choice. + It matters if users activated warnings for ambiguous or + out-of-scope resolutions -- they get less warnings by + qualifying at least one of the fields. *) + List.map2 (fun lid_a lbl -> + match lbl, lid_a with + | Some lbl, (lid, a) -> lid, lbl, a + | None, (lid, a) -> + let qual_lid = + match qual, lid.txt with + | Some modname, Longident.Lident s -> + {lid with txt = Longident.Ldot (modname, s)} + | _ -> lid + in + lid, process_label qual_lid, a + ) lid_a_list lbl_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 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 loc closed env usage type_lbl_a expected_type lid_a_list = + let lbl_a_list = + 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 + List.map type_lbl_a lbl_a_list + +(* 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; + module_vars: 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 esc -> + (* We don't expand the type here because if we do, we might expand to the + type that escaped, leading to confusing error messages. *) + let trace = Errortrace.[Escape (map_escape trivial_expansion esc)] in + raise (Error(loc, + env, + Pattern_type_clash(Errortrace.unification_error ~trace, None))) + + +(** 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, and + unification may update the typing environment. *) +let rec type_pat + : type k . k pattern_category -> + no_existentials: existential_restriction option -> + env: Env.t ref -> Parsetree.pattern -> type_expr -> k general_pattern + = fun category ~no_existentials ~env sp expected_ty -> + Builtin_attributes.warning_scope sp.ppat_attributes + (fun () -> + type_pat_aux category ~no_existentials ~env sp expected_ty + ) + +and type_pat_aux + : type k . k pattern_category -> no_existentials:_ -> + env:_ -> _ -> _ -> k general_pattern + = fun category ~no_existentials ~env sp expected_ty -> + let type_pat category ?(env=env) = + type_pat category ~no_existentials ~env + in + let loc = sp.ppat_loc in + let refine = None in + let solve_expected (x : pattern) : pattern = + unify_pat ~refine ~sdesc_for_hint:sp.ppat_desc env x (instance expected_ty); + x + in + let crp (x : k general_pattern) : k general_pattern = + match category with + | Value -> rp x + | Computation -> rcp x + in + (* record {general,value,computation} pattern *) + let rp = crp + and rvp x = crp (pure category x) + and rcp x = crp (only_impure category x) in + match sp.ppat_desc with + Ppat_any -> + rvp { + pat_desc = Tpat_any; + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_var name -> + let ty = instance expected_ty in + let id = enter_variable loc name ty sp.ppat_attributes in + rvp { + 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 -> + let t = instance expected_ty in + begin match name.txt with + | None -> + rvp { + 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 + (* We're able to pass ~is_module:true here without an error because + [Ppat_unpack] is a case identified by [may_contain_modules]. See + the comment on [may_contain_modules]. *) + let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in + rvp { + 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 *) + 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 { 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) -> + let q = type_pat Value sq expected_ty in + let ty_var = solve_Ppat_alias ~refine env q in + let id = + enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes + in + rvp { 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 @@ 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 p expected_ty + (* 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 pl = List.map2 (type_pat Value) spl expected_tys in + rvp { + 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 = + match extract_concrete_variant !env expected_ty with + | Variant_type(p0, p, _) -> + Some (p0, p, is_principal expected_ty) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let error = Wrong_expected_kind(srt, Pattern, expected_ty) in + raise (Error (loc, !env, error)) + in + let constr = + 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 + 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; + + let args = List.map2 (type_pat Value) sargs ty_args in + rvp { 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) -> + assert (tag <> Parmatch.some_private_tag); + let constant = (sarg = None) in + let arg_type, row, pat_type = + solve_Ppat_variant ~refine loc env tag constant expected_ty in + let arg = + (* PR#6235: propagate type information *) + match sarg, arg_type with + Some sp, [ty] -> Some (type_pat Value sp ty) + | _ -> None + in + rvp { + pat_desc = Tpat_variant(tag, arg, ref row); + pat_loc = loc; pat_extra = []; + pat_type = pat_type; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Ppat_record(lid_sp_list, closed) -> + assert (lid_sp_list <> []); + let expected_type, record_ty = + match extract_concrete_record !env expected_ty with + | Record_type(p0, p, _) -> + let ty = generic_instance expected_ty in + Some (p0, p, is_principal expected_ty), ty + | Maybe_a_record_type -> None, newvar () + | Not_a_record_type -> + let error = Wrong_expected_kind(Record, Pattern, expected_ty) in + raise (Error (loc, !env, error)) + in + let type_label_pat (label_lid, label, sarg) = + let ty_arg = + solve_Ppat_record_field ~refine loc env label label_lid record_ty in + (label_lid, label, type_pat Value sarg ty_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 lbl_a_list = + 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 + in + rvp @@ solve_expected (make_record_pat lbl_a_list) + | Ppat_array spl -> + let ty_elt = solve_Ppat_array ~refine loc env expected_ty in + let pl = List.map (fun p -> type_pat Value p ty_elt) spl in + rvp { + 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 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 using with_local_level without generalizations *) + let env1, p1, p1_variables, p1_module_variables, env2, p2 = + with_local_level begin fun () -> + let lev = get_current_level () in + gadt_equations_level := Some lev; + let type_pat_rec env sp = type_pat category sp expected_ty ~env 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 + (env1, p1, p1_variables, p1_module_variables, env2, p2) + end + in + 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 { 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 } + | Ppat_lazy sp1 -> + let nv = solve_Ppat_lazy ~refine loc env expected_ty in + let p1 = type_pat Value sp1 nv in + rvp { + 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 *) + let cty, ty, expected_ty' = + solve_Ppat_constraint ~refine loc env sty expected_ty in + let p = type_pat category sp expected_ty' in + let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in + begin 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 } + end + | Ppat_type lid -> + let (path, p) = build_or_pat !env loc lid in + pure category @@ solve_expected + { 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 + env := new_env; + let p = type_pat category ~env p expected_ty in + 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; + { p with pat_extra = (Tpat_open (path,lid,new_env), + loc, sp.ppat_attributes) :: p.pat_extra } + | Ppat_exception p -> + let p_exn = type_pat Value p Predef.type_exn in + rcp { + 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 + ?(lev=get_current_level()) env sp expected_ty = + Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] + (fun () -> type_pat category ~no_existentials ~env sp expected_ty) + +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 add_module_variables env module_variables = + List.fold_left (fun env { mv_id; mv_loc; mv_name; mv_uid } -> + Typetexp.TyVarEnv.with_local_scope begin fun () -> + (* This code is parallel to the typing of Pexp_letmodule. However we + omit the call to [Mtype.lower_nongen] as it's not necessary here. + For Pexp_letmodule, the call to [type_module] is done in a raised + level and so needs to be modified to have the correct, outer level. + Here, on the other hand, we're calling [type_module] outside the + raised level, so there's no extra step to take. + *) + let modl, md_shape = + !type_module env + Ast_helper.( + Mod.unpack ~loc:mv_loc + (Exp.ident ~loc:mv_name.loc + (mkloc (Longident.Lident mv_name.txt) + mv_name.loc))) + in + let pres = + match modl.mod_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let md = + { md_type = modl.mod_type; md_attributes = []; + md_loc = mv_name.loc; + md_uid = mv_uid; } + in + Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md env + end + ) env module_variables + +let type_pattern category ~lev env spat expected_ty allow_modules = + reset_pattern allow_modules; + 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 mvs = get_ref module_variables in + (pat, !new_env, get_ref pattern_force, pvs, mvs) + +let type_pattern_list + category no_existentials env spatl expected_tys allow_modules + = + reset_pattern allow_modules; + 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 mvs = get_ref module_variables in + (patl, !new_env, get_ref pattern_force, pvs, mvs) + +let type_class_arg_pattern cl_num val_env met_env l spat = + reset_pattern Modules_rejected; + 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 env spat = + let open Ast_helper in + let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in + reset_pattern Modules_rejected; + let nv = newvar() in + let pat = + type_pat Value ~no_existentials:In_self_pattern (ref env) spat nv in + List.iter (fun f -> f()) (get_ref pattern_force); + let pv = !pattern_variables in + pattern_variables := []; + pat, pv + + +(** In [check_counter_example_pat], we will check a counter-example candidate + produced by Parmatch. This is a 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 [check_counter_example_pat] is to refine this untyped 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}) + *) + +type counter_example_checking_info = { + explosion_fuel: int; + splitting_mode: splitting_mode; + } +(** + [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. + *) + +(** 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, + [check_counter_example_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 [check_counter_example_pat], + 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 [check_counter_example_pat]. + 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). + In the GADT mode, [env] may be extended by unification, + and therefore it needs to be saved along with a [snapshot]. *) +type unification_state = + { snapshot: snapshot; + env: Env.t; } +let save_state env = + { snapshot = Btype.snapshot (); + env = !env; } +let set_state s env = + Btype.backtrack s.snapshot; + 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.pat_desc with + | Tpat_or(p1,p2,_) -> + (try find_valid_alternative f p1 with + | Empty_branch | Error _ -> find_valid_alternative f p2 + ) + | _ -> f pat + +let no_explosion info = { info with explosion_fuel = 0 } + +let enter_nonsplit_or 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 { info with splitting_mode } + +let rec check_counter_example_pat ~info ~env tp expected_ty k = + let check_rec ?(info=info) ?(env=env) = + check_counter_example_pat ~info ~env in + let loc = tp.pat_loc in + let refine = Some true in + let solve_expected (x : pattern) : pattern = + unify_pat ~refine env x (instance expected_ty); + x + in + (* "make pattern" and "make pattern then continue" *) + let mp ?(pat_type = expected_ty) desc = + { pat_desc = desc; pat_loc = loc; pat_extra=[]; + pat_type = instance pat_type; pat_attributes = []; pat_env = !env } in + let mkp k ?pat_type desc = k (mp ?pat_type desc) in + let must_backtrack_on_gadt = + match info.splitting_mode with + | Backtrack_or -> false + | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or + in + match tp.pat_desc with + Tpat_any | Tpat_var _ -> + let k' () = mkp k tp.pat_desc in + if info.explosion_fuel <= 0 then k' () else + let decrease n = {info with explosion_fuel = info.explosion_fuel - n} in + begin match Parmatch.pats_of_type !env expected_ty with + | [] -> raise Empty_branch + | [{pat_desc = Tpat_any}] -> k' () + | [tp] -> check_rec ~info:(decrease 1) tp expected_ty k + | tp :: tpl -> + if must_backtrack_on_gadt then raise Need_backtrack; + let tp = + List.fold_left + (fun tp tp' -> {tp with pat_desc = Tpat_or (tp, tp', None)}) + tp tpl + in + check_rec ~info:(decrease 5) tp expected_ty k + end + | Tpat_alias (p, _, _) -> check_rec ~info p expected_ty k + | Tpat_constant cst -> + let cst = constant_or_raise !env loc (Untypeast.constant cst) in + k @@ solve_expected (mp (Tpat_constant cst) ~pat_type:(type_constant cst)) + | Tpat_tuple tpl -> + assert (List.length tpl >= 2); + let expected_tys = solve_Ppat_tuple ~refine loc env tpl expected_ty in + let tpl_ann = List.combine tpl expected_tys in + map_fold_cont (fun (p,t) -> check_rec p t) tpl_ann (fun pl -> + mkp k (Tpat_tuple pl) + ~pat_type:(newty (Ttuple(List.map (fun p -> p.pat_type) pl)))) + | Tpat_construct(cstr_lid, constr, targs, _) -> + if constr.cstr_generalized && must_backtrack_on_gadt then + raise Need_backtrack; + let (ty_args, existential_ctyp) = + solve_Ppat_construct ~refine env loc constr None None expected_ty + in + map_fold_cont + (fun (p,t) -> check_rec p t) + (List.combine targs ty_args) + (fun args -> + mkp k (Tpat_construct(cstr_lid, constr, args, existential_ctyp))) + | Tpat_variant(tag, targ, _) -> + let constant = (targ = None) in + let arg_type, row, pat_type = + solve_Ppat_variant ~refine loc env tag constant expected_ty in + let k arg = + mkp k ~pat_type (Tpat_variant(tag, arg, ref row)) + in begin + (* PR#6235: propagate type information *) + match targ, arg_type with + Some p, [ty] -> check_rec p ty (fun p -> k (Some p)) + | _ -> k None + end + | Tpat_record(fields, closed) -> + let record_ty = generic_instance expected_ty in + let type_label_pat (label_lid, label, targ) k = + let ty_arg = + solve_Ppat_record_field ~refine loc env label label_lid record_ty in + check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) + in + map_fold_cont type_label_pat fields + (fun fields -> mkp k (Tpat_record (fields, closed))) + | Tpat_array tpl -> + let ty_elt = solve_Ppat_array ~refine loc env expected_ty in + map_fold_cont (fun p -> check_rec p ty_elt) tpl + (fun pl -> mkp k (Tpat_array pl)) + | Tpat_or(tp1, tp2, _) -> + (* We are in counter-example mode, but try to avoid backtracking *) + let must_split = + match info.splitting_mode with + | Backtrack_or -> true + | Refine_or _ -> false in + let state = save_state env in + let split_or tp = + let type_alternative pat = + set_state state env; check_rec pat expected_ty k in + find_valid_alternative type_alternative tp + in + if must_split then split_or tp else + let check_rec_result env tp : (_, abort_reason) result = + let info = enter_nonsplit_or info in + match check_rec ~info tp expected_ty ~env (fun x -> x) with + | res -> Ok res + | exception Need_backtrack -> Error Adds_constraints + | exception Empty_branch -> Error Empty + in + let p1 = check_rec_result (ref !env) tp1 in + let p2 = check_rec_result (ref !env) tp2 in + 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 info.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 tp + | Ok p, Error _ + | Error _, Ok p -> + k p + | Ok p1, Ok p2 -> + mkp k (Tpat_or (p1, p2, None)) + end + | Tpat_lazy tp1 -> + let nv = solve_Ppat_lazy ~refine loc env expected_ty in + (* do not explode under lazy: PR#7421 *) + check_rec ~info:(no_explosion info) tp1 nv + (fun p1 -> mkp k (Tpat_lazy p1)) + +let check_counter_example_pat ~counter_example_args + ?(lev=get_current_level()) env tp expected_ty = + Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () -> + check_counter_example_pat + ~info:counter_example_args ~env tp expected_ty (fun x -> x) + ) + +(* this function is passed to Partial.parmatch + to type check gadt nonexhaustiveness *) +let partial_pred ~lev ~allow_modules ~splitting_mode ?(explode=0) + env expected_ty p = + let env = ref env in + let state = save_state env in + let counter_example_args = + { + splitting_mode; + explosion_fuel = explode; + } in + try + reset_pattern allow_modules; + let typed_p = + check_counter_example_pat ~lev ~counter_example_args 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 ()) allow_modules 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 ~allow_modules ~splitting_mode ~explode env expected_ty) + loc cases + +let check_unused + ?(lev=get_current_level ()) allow_modules env expected_ty cases + = + Parmatch.check_unused + (fun refute pat -> + match + partial_pred ~lev ~allow_modules ~splitting_mode:Backtrack_or ~explode:5 + env expected_ty pat + with + Some pat' when refute -> + raise (Error (pat.pat_loc, env, Unrefuted_pattern pat')) + | r -> r) + cases + +(** Some delayed checks, to be executed after typing the whole + compilation unit or toplevel phrase *) +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) -> Btype.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 _ | Tmod_apply_unit _ -> 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, commu_ok)) + | 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, commu_ok)) + | Pexp_function ({pc_rhs=e}::_) -> + newty (Tarrow(Nolabel, newvar (), type_approx env e, commu_ok)) + | 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 err -> + raise(Error(sexp.pexp_loc, env, Expr_type_clash (err, 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 err -> + raise(Error(sexp.pexp_loc, env, Expr_type_clash (err, 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 TypeSet.mem ty visited then + List.rev ls, false + else match get_desc ty with + Tarrow (l, _, ty_res, _) -> + list_labels_aux env (TypeSet.add 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 TypeSet.empty []) 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 + let exp_ty, vars = + with_local_level_iter ~post:generalize begin fun () -> + match get_desc pty with + Tpoly (body, tl) -> + (* Enforce scoping for type_let: + since body is not generic, instance_poly only makes + copies of nodes that have a Tunivar 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), exp_ty::vars) + | _ -> assert false + end + in + 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.unification_error + ~trace:[Ctype.expanded_diff env + ~got:ty ~expected: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 + +(* [check_statement] implements the [non-unit-statement] check. + + This check is called in contexts where the value of the expression is known + to be discarded (eg. the lhs of a sequence). We check that [exp] has type + unit, or has an explicit type annotation; otherwise we raise the + [non-unit-statement] warning. *) + +let check_statement exp = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () + | Tvar _ -> () + | _ -> + 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 + + +(* [check_partial_application] implements the [ignored-partial-application] + warning (and if [statement] is [true], also [non-unit-statement]). + + If [exp] has a function type, we check that it is not syntactically the + result of a function application, as this is often a bug in certain contexts + (eg the rhs of a let-binding or in the argument of [ignore]). For example, + [ignore (List.map print_int)] written by mistake instead of [ignore (List.map + print_int li)]. + + The check can be disabled by explicitly annotating the expression with a type + constraint, eg [(e : _ -> _)]. + + If [statement] is [true] and the [ignored-partial-application] is {em not} + triggered, then the [non-unit-statement] check is performed (see + [check_statement]). + + If the type of [exp] is not known at the time this function is called, the + check is retried again after typechecking. *) + +let check_partial_application ~statement exp = + let check_statement () = if statement then check_statement exp in + let doit () = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty 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 + | _ -> + check_statement () + in + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tvar _ -> + (* The type of [exp] is not known. Delay the check until after + typechecking in order to give a chance for the type to become known + through unification. *) + add_delayed_check doit + | _ -> + doit () + +let pattern_needs_partial_application_check p = + let rec check : type a. a general_pattern -> bool = fun p -> + not (List.exists (function (Tpat_constraint _, _, _) -> true | _ -> false) + p.pat_extra) && + match p.pat_desc with + | Tpat_any -> true + | Tpat_exception _ -> true + | Tpat_or (p1, p2, _) -> check p1 && check p2 + | Tpat_value p -> check (p :> value general_pattern) + | _ -> false + in + check p + +(* Check that a type is generalizable at some level *) +let generalizable level ty = + let rec check ty = + if not_marked_node ty then + if get_level ty <= 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 = + if try_mark_node ty then + begin match get_desc ty with + Tvariant row -> + if not (is_fixed row) then + List.iter + (fun (_,f) -> + match row_field_repr f with Reither _ -> raise Exit | _ -> ()) + (row_fields row); + 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 + +(* There are various things that we need to do in presence of module patterns + that aren't required if there are none. Most notably, we need to ensure the + modules are entered at the appropriate scope. The caller should use + [may_contain_modules] as an indication to set up the proper scope handling + code (via [allow_modules]) to permit module patterns. + The class of patterns identified here should stay in sync with the patterns + whose typing involves [enter_variable ~is_module:true], as these calls + will error if the scope handling isn't set up. +*) +let may_contain_modules p = + exists_ppat + (function + | {ppat_desc = Ppat_unpack _} -> 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 in + if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent) + (row_fields row) + || 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 fields = [s, rf_either ty_arg ~no_arg:(arg=None) ~matched:true] in + let row' = + create_row ~fields + ~more:(newvar ()) ~closed:false ~fixed:None ~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 *) + +(** [sdesc_for_hint] is used by error messages to report literals in their + original formatting *) +let unify_exp ?sdesc_for_hint 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(err, tfc, None)) -> + raise (Error(loc, env, Expr_type_clash(err, tfc, sdesc_for_hint))) + +(* 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 get_desc typ with + | Tarrow (Nolabel,a,b,_) -> + begin match get_desc b with + | Tarrow(Nolabel,c,d,_) -> + let f, x, res = + match prim with + | Apply -> a, c, d + | Revapply -> c, a, d + in + begin match get_desc f with + | Tarrow(Nolabel,fl,fr,_) -> + is_Tvar fl && is_Tvar fr && is_Tvar x && is_Tvar res + && Types.eq_type fl x && Types.eq_type 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(err', None, exp')) + when not loc'.Location.loc_ghost -> + let err = Expr_type_clash(err', Some explanation, exp') in + raise (Error (loc', env', err)) + +(* Generalize expressions *) +let generalize_structure_exp exp = generalize_structure exp.exp_type +let may_lower_contravariant_then_generalize env exp = + if maybe_expansive exp then lower_contravariant env exp.exp_type; + generalize exp.exp_type + +(* value binding elaboration *) + +let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; _ } = + let open Ast_helper in + match ct with + | None -> expr + | Some (Pvc_constraint { locally_abstract_univars=[]; typ }) -> + begin match typ.ptyp_desc with + | Ptyp_poly _ -> expr + | _ -> + let loc = { expr.pexp_loc with Location.loc_ghost = true } in + Exp.constraint_ ~loc expr typ + end + | Some (Pvc_coercion { ground; coercion}) -> + let loc = { expr.pexp_loc with Location.loc_ghost = true } in + Exp.coerce ~loc expr ground coercion + | Some (Pvc_constraint { locally_abstract_univars=vars;typ}) -> + let loc_start = pat.ppat_loc.Location.loc_start in + let loc = { expr.pexp_loc with loc_start; loc_ghost=true } in + let expr = Exp.constraint_ ~loc expr typ in + List.fold_right (Exp.newtype ~loc) vars expr + +let vb_pat_constraint ({pvb_pat=pat; pvb_expr = exp; _ } as vb) = + vb.pvb_attributes, + let open Ast_helper in + match vb.pvb_constraint, pat.ppat_desc, exp.pexp_desc with + | Some (Pvc_constraint {locally_abstract_univars=[]; typ} + | Pvc_coercion { coercion=typ; _ }), + _, _ -> + Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat typ + | Some (Pvc_constraint {locally_abstract_univars=vars; typ }), _, _ -> + let varified = Typ.varify_constructors vars typ in + let t = Typ.poly ~loc:typ.ptyp_loc vars varified in + let loc_end = typ.ptyp_loc.Location.loc_end in + let loc = { pat.ppat_loc with loc_end; loc_ghost=true } in + Pat.constraint_ ~loc pat t + | None, (Ppat_any | Ppat_constraint _), _ -> pat + | None, _, Pexp_coerce (_, _, sty) + | None, _, Pexp_constraint (_, sty) when !Clflags.principal -> + (* propagate type annotation to pattern, + to allow it to be generalized in -principal mode *) + Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat sty + | _ -> pat + +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, structural nodes of [type_expected_explained] may be + at [generic_level] (but its variables no higher than [!current_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 + let desc = sexp.pexp_desc in + (* Record the expression type before unifying it with the expected type *) + let with_explanation = with_explanation explanation in + (* Unify the result with [ty_expected], enforcing the current level *) + let rue exp = + with_explanation (fun () -> + unify_exp ~sdesc_for_hint:desc env (re exp) (instance ty_expected)); + exp + in + match 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 (protect_expansion env ty_expected) in + let fmt6_path = + Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"), + "format6")) + in + let is_format = match get_desc ty_exp with + | Tconstr(path, _, _) when Path.same path fmt6_path -> + if !Clflags.principal && get_level ty_exp <> 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_attributes=[]; _ } as vb], sbody) + when may_contain_gadts spat -> + (* TODO: allow non-empty attributes? *) + let sval = vb_exp_constraint vb in + 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 may_contain_modules = + List.exists (fun pvb -> may_contain_modules pvb.pvb_pat) spat_sexp_list + in + let outer_level = get_current_level () in + let (pat_exp_list, body, _new_env) = + (* If the patterns contain module unpacks, there is a possibility that + the types of the let body or bound expressions mention types + introduced by those unpacks. The below code checks for scope escape + via both of these pathways (body, bound expressions). + *) + with_local_level_if may_contain_modules begin fun () -> + let allow_modules = + if may_contain_modules + then + let scope = create_scope () in + Modules_allowed { scope } + else Modules_rejected + in + let (pat_exp_list, new_env) = + type_let existential_context env rec_flag spat_sexp_list + allow_modules + in + let body = type_expect new_env sbody ty_expected_explained in + let () = + if rec_flag = Recursive then + check_recursive_bindings env pat_exp_list + in + (* The "bound expressions" component of the scope escape check. + + This kind of scope escape is relevant only for recursive + module definitions. + *) + if rec_flag = Recursive && may_contain_modules then begin + List.iter + (fun vb -> + (* [type_let] already generalized bound expressions' types + in-place. We first take an instance before checking scope + escape at the outer level to avoid losing generality of + types added to [new_env]. + *) + let bound_exp = vb.vb_expr in + generalize_structure_exp bound_exp; + let bound_exp_type = Ctype.instance bound_exp.exp_type in + let loc = proper_exp_loc bound_exp in + let outer_var = newvar2 outer_level in + (* Checking unification within an environment extended with the + module bindings allows us to correctly accept more programs. + This environment allows unification to identify more cases + where a type introduced by the module is equal to a type + introduced at an outer scope. *) + unify_exp_types loc new_env bound_exp_type outer_var) + pat_exp_list + end; + (pat_exp_list, body, new_env) + end + ~post:(fun (_pat_exp_list, body, new_env) -> + (* The "body" component of the scope escape check. *) + unify_exp new_env body (newvar ())) + 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 default_ghost = {default.pexp_loc with loc_ghost = true} in + let scases = [ + Exp.case + (Pat.construct ~loc:default_ghost + (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) + (Some ([], Pat.var ~loc:default_ghost (mknoloc "*sth*")))) + (Exp.ident ~loc:default_ghost (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 TypeSet.mem ty seen then () else + match get_desc ty with + Tarrow (_l, ty_arg, ty_fun, _com) -> + (try enforce_current_level env ty_arg + with Unify _ -> assert false); + lower_args (TypeSet.add ty seen) ty_fun + | _ -> () + in + let type_sfunct sfunct = + (* one more level for warning on non-returning functions *) + with_local_level_iter + begin fun () -> + let funct = + with_local_level_if_principal (fun () -> type_exp env sfunct) + ~post: generalize_structure_exp + in + let ty = instance funct.exp_type in + (funct, [ty]) + end + ~post:(wrap_trace_gadt_instances env (lower_args TypeSet.empty)) + 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 + let (args, ty_res) = type_application env funct sargs in + 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) -> + let arg = + with_local_level (fun () -> type_exp env sarg) + ~post:(may_lower_contravariant_then_generalize env) + in + let cases, partial = + type_cases Computation env + arg.exp_type ty_expected_explained true loc caselist in + if + List.for_all (fun c -> pattern_needs_partial_application_check c.c_lhs) + cases + then check_partial_application ~statement:false arg; + 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_expected1 = protect_expansion env ty_expected in + let ty_expected0 = instance ty_expected in + begin try match + sarg, get_desc (expand_head env ty_expected1), + get_desc (expand_head env ty_expected0) + with + | Some sarg, Tvariant row, Tvariant row0 -> + begin match + row_field_repr (get_row_field l row), + row_field_repr (get_row_field l row0) + 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 Exit + end + | _ -> raise Exit + with Exit -> + let arg = Option.map (type_exp env) sarg in + let arg_type = Option.map (fun arg -> arg.exp_type) arg in + let row = + create_row + ~fields: [l, rf_present arg_type] + ~more: (newvar ()) + ~closed: false + ~fixed: None + ~name: None + in + rue { + exp_desc = Texp_variant(l, arg); + exp_loc = loc; exp_extra = []; + exp_type = newty (Tvariant row); + 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 -> + let exp = + with_local_level_if_principal + (fun () -> type_exp ~recarg env sexp) + ~post: generalize_structure_exp + in + Some exp + in + let ty_record, expected_type = + let expected_opath = + match extract_concrete_record env ty_expected with + | Record_type (p0, p, _) -> Some (p0, p, is_principal ty_expected) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = + Wrong_expected_kind(Record, Expression explanation, ty_expected) + in + raise (Error (loc, env, error)) + in + let opt_exp_opath = + match opt_exp with + | None -> None + | Some exp -> + match extract_concrete_record env exp.exp_type with + | Record_type (p0, p, _) -> Some (p0, p, is_principal exp.exp_type) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type exp.exp_type in + raise (Error (exp.exp_loc, env, error)) + in + match expected_opath, opt_exp_opath with + | None, None -> newvar (), None + | Some _, None -> ty_expected, expected_opath + | Some(_, _, true), Some _ -> ty_expected, expected_opath + | (None | Some (_, _, false)), Some (_, p', _) -> + let decl = Env.find_type p' env in + let ty = + with_local_level ~post:generalize_structure + (fun () -> newconstr p' (instance_list decl.type_params)) + in + ty, opt_exp_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 + (type_label_exp true env loc ty_record) + expected_type) + lid_sexp_list + 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, lbl.lbl_mut) + 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 *) + let cty = + with_local_level begin fun () -> + Typetexp.transl_simple_type env ~closed:false sty + end + ~post:(fun cty -> generalize_structure cty.ctyp_type) + in + let ty = cty.ctyp_type in + 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 + let arg, gen = + let lv = get_current_level () in + with_local_level begin fun () -> + let arg = type_exp env sarg in + (arg, generalizable lv arg.exp_type) + end + ~post:(fun (arg,_) -> enforce_current_level env arg.exp_type) + in + begin match arg.exp_desc, !self_coercion, get_desc ty' 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 err -> + (* prerr_endline "coercion failed"; *) + raise (Error(loc, env, Not_subtype err)) + end; + | _ -> + let ty, b = enlarge_type env ty' in + force (); + begin try Ctype.unify env arg.exp_type ty with Unify err -> + let expanded = full_expand ~may_forget_scope:true env ty' in + raise(Error(sarg.pexp_loc, env, + Coercion_failure({ty = ty'; expanded}, err, b))) + end + end; + (arg, ty', None, cty') + | Some sty -> + let cty, ty, force, cty', ty', force' = + with_local_level_iter ~post:generalize_structure begin fun () -> + let (cty, ty, force) = + Typetexp.transl_simple_type_delayed env sty + and (cty', ty', force') = + Typetexp.transl_simple_type_delayed env sty' + in + ((cty, ty, force, cty', ty', force'), + [ty; ty']) + end + in + begin try + let force'' = subtype env (instance ty) (instance ty') in + force (); force' (); force'' () + with Subtype err -> + raise (Error(loc, env, Not_subtype err)) + end; + (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}) -> + let (obj,meth,typ) = + with_local_level_if_principal + (fun () -> type_send env loc explanation e met) + ~post:(fun (_,_,typ) -> generalize_structure typ) + in + let typ = + match get_desc typ with + | Tpoly (ty, []) -> + instance ty + | Tpoly (ty, tl) -> + if !Clflags.principal && get_level typ <> generic_level then + Location.prerr_warning loc + (Warnings.Not_principal "this use of a polymorphic method"); + snd (instance_poly false tl ty) + | Tvar _ -> + let ty' = newvar () in + unify env (instance typ) (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_loc = loc; exp_extra = []; + exp_type = typ; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | 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 (sign, _, vars, _)}), + (path_self, _) -> + let type_override (lab, snewval) = + begin try + let id = Vars.find lab.txt vars in + let ty = Btype.instance_variable_type lab.txt sign in + (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 lv = get_current_level () in + let (id, pres, modl, _, body) = + with_local_level begin fun () -> + let modl, pres, id, new_env = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let modl, md_shape = !type_module env smodl in + Mtype.lower_nongen lv 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 ~shape:md_shape name pres md env + in + Some id, env + in + modl, pres, id, new_env + end + 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 new_env sbody ty_expected_explained in + (id, pres, modl, new_env, body) + end + ~post: begin fun (_id, _pres, _modl, new_env, body) -> + (* Ensure that local definitions do not leak. *) + (* required for implicit unpack *) + enforce_current_level new_env body.exp_type + end + in + re { + exp_desc = Texp_letmodule(id, name, pres, modl, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + 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 + let rec innermost_location loc_stack = + match loc_stack with + | [] -> loc + | [l] -> l + | _ :: s -> innermost_location s + in + rue { + exp_desc = Texp_assert (cond, innermost_location sexp.pexp_loc_stack); + 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, meths = !type_object env loc s in + rue { + exp_desc = Texp_object (desc, meths); + exp_loc = loc; exp_extra = []; + exp_type = desc.cstr_type.csig_self; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_poly(sbody, sty) -> + let ty, cty = + with_local_level_if_principal + ~post:(fun (ty,_) -> generalize_structure ty) + begin fun () -> + match sty with None -> protect_expansion env ty_expected, None + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = Typetexp.transl_simple_type env ~closed:false sty in + cty.ctyp_type, Some cty + end + in + if sty <> None then + with_explanation (fun () -> + unify_exp_types loc env (instance ty) (instance ty_expected)); + let exp = + match get_desc (expand_head env ty) 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 *) + let (exp,_) = + with_local_level begin fun () -> + let vars, ty'' = + with_local_level_if_principal + (fun () -> instance_poly true tl ty') + ~post:(fun (_,ty'') -> generalize_structure ty'') + in + let exp = type_expect env sbody (mk_expected ty'') in + (exp, vars) + end + ~post: begin fun (exp,vars) -> + generalize_and_check_univars env "method" exp ty_expected vars + end + in + { 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 + (* Use [with_local_level] just for scoping *) + let body, ety = with_local_level begin fun () -> + (* 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 (get_id t) then () + else begin + Hashtbl.add seen (get_id t) (); + match get_desc t 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; + (body, ety) + end + in + (* 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 get_desc (Ctype.expand_head env (instance ty_expected)) with + Tpackage (p, fl) -> + if !Clflags.principal && + get_level (Ctype.expand_head env + (protect_expansion env ty_expected)) + < Btype.generic_level + then + Location.prerr_warning loc + (Warnings.Not_principal "this module packing"); + (p, fl) + | 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 + let op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops = + with_local_level_iter_if_principal + ~post:generalize_structure begin fun () -> + 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, commu_ok)) 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, commu_ok)), commu_ok)) + in + begin try + unify env op_type ty_op + with Unify err -> + raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err))) + end; + ((op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops), + [ty_andops; ty_params; ty_func_result; ty_result]) + end + in + 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 get_desc desc.val_type with + | Tconstr(p, _, _) -> Path.is_constructor_typath p + | _ -> false + in + begin match is_recarg, recarg, get_desc desc.val_type 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 + let ty_arg, ty_res = + with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + let (ty_arg, ty_res) = + try filter_arrow env (instance ty_expected) arg_label + with Filter_arrow_failed err -> + let err = match err with + | Unification_error unif_err -> + Expr_type_clash(unif_err, explanation, None) + | Label_mismatch { got; expected; expected_type} -> + Abstract_wrong_label { got; expected; expected_type; explanation } + | Not_a_function -> begin + match in_function with + | Some _ -> Too_many_arguments(ty_fun, explanation) + | None -> Not_a_function(ty_fun, explanation) + end + in + raise (Error(loc_fun, env, err)) + 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 + ((ty_arg, ty_res), [ty_arg; ty_res]) + end + in + 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, commu_ok))); + exp_attributes = attrs; + exp_env = env } + + +and type_label_access env srecord usage lid = + let record = + with_local_level_if_principal ~post:generalize_structure_exp + (fun () -> type_exp ~recarg:Allowed env srecord) + in + let ty_exp = record.exp_type in + let expected_type = + match extract_concrete_record env ty_exp with + | Record_type(p0, p, _) -> + Some(p0, p, is_principal ty_exp) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type ty_exp in + raise (Error (record.exp_loc, env, error)) + 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 *) + let separate = !Clflags.principal || Env.has_local_constraints env in + (* #4682: we try two type-checking approaches for [arg] using backtracking: + - first try: we try with [ty_arg] as expected type; + - second try; if that fails, we backtrack and try without + *) + let (vars, ty_arg, snap, arg) = + (* try the first approach *) + with_local_level begin fun () -> + let (vars, ty_arg) = + with_local_level_iter_if separate begin fun () -> + let (vars, ty_arg, ty_res) = + with_local_level_iter_if separate ~post:generalize_structure + begin fun () -> + let ((_, ty_arg, ty_res) as r) = instance_label true label in + (r, [ty_arg; ty_res]) + end + in + begin try + unify env (instance ty_res) (instance ty_expected) + with Unify err -> + raise (Error(lid.loc, env, Label_mismatch(lid.txt, err))) + end; + (* Instantiate so that we can generalize internal nodes *) + let ty_arg = instance ty_arg in + ((vars, ty_arg), [ty_arg]) + end + ~post:generalize_structure + in + + 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 snap = if vars = [] then None else Some (Btype.snapshot ()) in + let arg = type_argument env sarg ty_arg (instance ty_arg) in + (vars, ty_arg, snap, arg) + end + (* Note: there is no generalization logic here as could be expected, + because it is part of the backtracking logic below. *) + in + let arg = + try + if (vars = []) then arg + else begin + (* We detect if the first try failed here, + during generalization. *) + 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 first_try_exn when maybe_expansive arg -> try + (* backtrack and try the second approach *) + Option.iter Btype.backtrack snap; + let arg = with_local_level (fun () -> type_exp env sarg) + ~post:(fun arg -> lower_contravariant env arg.exp_type) + in + let arg = + with_local_level begin fun () -> + let arg = {arg with exp_type = instance arg.exp_type} in + unify_exp env arg (instance ty_arg); + arg + end + ~post: begin fun arg -> + generalize_and_check_univars env "field value" arg label.lbl_arg vars + end + in + {arg with exp_type = instance arg.exp_type} + with Error (_, _, Less_general _) as e -> raise e + | _ -> raise first_try_exn + 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 () = + let te = expand_head env ty_expected' in + match get_desc te with + Tarrow(Nolabel,_,ty_res0,_) -> + Some (no_labels ty_res0, get_level te) + | _ -> 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 *) + let texp = + with_local_level_if_principal ~post:generalize_structure_exp + (fun () -> type_exp env sarg) + in + let rec make_args args ty_fun = + match get_desc (expand_head env ty_fun) 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 || get_level ty_fun' <> generic_level) + and ty_fun = instance ty_fun' in + let ty_arg, ty_res = + match get_desc (expand_head env ty_expected) with + 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 ~level:lv (Tarrow(l,ty,ty_fun,commu_ok))) + 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 get_desc ty_fun with + | Tvar _ -> + let t1 = newvar () and t2 = newvar () in + if get_level ty_fun >= get_level t1 && + 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,commu_var ()))); + (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 get_desc ty_res 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)) + | _ -> + let previous_arg_loc = + (* [typed_args] is the arguments typed until now, in reverse + order of appearance. Not all arguments have a location + attached (eg. an optional argument that is not passed). *) + typed_args + |> List.find_map + (function (_, Some (_, loc)) -> loc | _ -> None) + |> Option.value ~default:funct.exp_loc + in + raise(Error(funct.exp_loc, env, Apply_non_function { + funct; + func_ty = expand_head env funct.exp_type; + res_ty = expand_head env ty_res; + previous_arg_loc; + extra_arg_loc = sarg.pexp_loc; })) + 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, Some sarg.pexp_loc)) :: 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 + (* [args] remember the location of each argument in sources. *) + let rec type_args args ty_fun ty_fun0 sargs = + let type_unknown_args () = + (* 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, _loc) -> l, Some (f ())) + (List.rev typed_args) + in + let result_ty = instance (result_type !omitted_parameters ty_fun) in + args, result_ty + in + if sargs = [] then type_unknown_args () else + let ty_fun' = expand_head env ty_fun in + match get_desc ty_fun', get_desc (expand_head env ty_fun0) with + | Tarrow (l, ty, ty_fun, com), Tarrow (_, ty0, ty_fun0, _) + when is_commu_ok com -> + let lv = get_level ty_fun' in + 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' = + 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; + (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, Some (use_arg sarg l', Some sarg.pexp_loc)) + else if + optional && + not (List.exists (fun (l, _) -> name = label_name l) + remaining_sargs) && + List.exists (function (Nolabel, _) -> true | _ -> false) + sargs + then + (sargs, Some (eliminate_optional_arg (), Some sarg.pexp_loc)) + 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, Some (use_arg sarg l', Some sarg.pexp_loc) + | None -> + sargs, + if optional && List.mem_assoc Nolabel sargs then + Some (eliminate_optional_arg (), None) + 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 + | _ -> + type_unknown_args () + in + let is_ignore funct = + is_prim ~name:"%ignore" funct && + (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true + with Filter_arrow_failed _ -> false) + in + (* Extra scope to check for non-returning functions *) + with_local_level begin fun () -> + 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 ~statement:false exp; + ([Nolabel, Some exp], ty_res) + | _ -> + let ty = funct.exp_type in + type_args [] ty (instance ty) sargs + end + +and type_construct env loc lid sarg ty_expected_explained attrs = + let { ty = ty_expected; explanation } = ty_expected_explained in + let expected_type = + match extract_concrete_variant env ty_expected with + | Variant_type(p0, p,_) -> + Some(p0, p, is_principal ty_expected) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let ctx = Expression explanation in + let error = Wrong_expected_kind(srt, ctx, ty_expected) in + raise (Error (loc, env, error)) + 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 + let ty_args, ty_res, texp = + with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + let ty_args, ty_res, texp = + with_local_level_if separate begin fun () -> + let (ty_args, ty_res, _) = + instance_constructor Keep_existentials_flexible 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 + (ty_args, ty_res, texp) + end + ~post: begin fun (_, ty_res, texp) -> + generalize_structure ty_res; + with_explanation explanation (fun () -> + unify_exp env {texp with exp_type = instance ty_res} + (instance ty_expected)); + end + in + ((ty_args, ty_res, texp), ty_res::ty_args) + end + in + 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 = + (* Raise the current level to detect non-returning functions *) + let exp = with_local_level (fun () -> type_exp env sexp) in + let ty = expand_head env exp.exp_type in + if is_Tvar ty && get_level ty > get_current_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 ~statement:true exp; + enforce_current_level env ty; + exp + end + +(* 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 may_contain_modules = List.exists may_contain_modules patterns in + let create_inner_level = may_contain_gadts || may_contain_modules 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 + with_local_level_iter_if create_inner_level begin fun () -> + let lev = get_current_level () in + let allow_modules = + if may_contain_modules + then + (* The corresponding check for scope escape is done together with + the check for GADT-induced existentials by + [with_local_level_iter_if create_inner_level]. + *) + Modules_allowed { scope = lev } + else Modules_rejected + in + let take_partial_instance = + if erase_either + then Some false else None + in + let half_typed_cases, ty_res, do_copy_types, ty_arg' = + (* propagation of the argument *) + with_local_level begin fun () -> + 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 htc = + with_local_level_if_principal begin fun () -> + let ty_arg = + (* propagation of pattern *) + with_local_level ~post:generalize_structure + (fun () -> instance ?partial:take_partial_instance ty_arg) + in + let (pat, ext_env, force, pvs, mvs) = + type_pattern category ~lev env pc_lhs ty_arg allow_modules + in + pattern_force := force @ !pattern_force; + { typed_pat = pat; + pat_type_for_unif = ty_arg; + untyped_case = case; + branch_env = ext_env; + pat_vars = pvs; + module_vars = mvs; + contains_gadt = contains_gadt (as_comp_pattern category pat); } + end + ~post: begin fun htc -> + iter_pattern_variables_type generalize_structure htc.pat_vars; + end + in + (* Ensure that no ambivalent pattern type escapes its branch *) + check_scope_escape htc.typed_pat.pat_loc env outer_level + htc.pat_type_for_unif; + let pat = htc.typed_pat in + {htc with typed_pat = { pat with pat_type = instance pat.pat_type }} + ) + 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 (enforce_current_level env) pat_vars + ) half_typed_cases; + (half_typed_cases, ty_res, do_copy_types, ty_arg') + end + ~post: begin fun (half_typed_cases, _, _, ty_arg') -> + generalize ty_arg'; + List.iter (fun { pat_vars; _ } -> + iter_pattern_variables_type generalize pat_vars + ) half_typed_cases + end + in + (* type bodies *) + let in_function = if List.length caselist = 1 then in_function else None in + let ty_res' = instance ty_res in + let cases = with_local_level_if_principal ~post:ignore begin fun () -> + List.map + (fun { typed_pat = pat; branch_env = ext_env; + pat_vars = pvs; module_vars = mvs; + 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 ext_env = add_module_variables ext_env mvs in + let ty_expected = + if contains_gadt && not !Clflags.principal then + (* Take a generic copy of [ty_res] again to allow propagation of + type information from preceding branches *) + correct_levels ty_res + else ty_res in + let guard = + match pc_guard with + | None -> None + | Some scond -> + Some + (type_expect ext_env scond + (mk_expected ~explanation:When_guard Predef.type_bool)) + in + let exp = + type_expect ?in_function ext_env + pc_rhs (mk_expected ?explanation ty_expected) + in + { + c_lhs = pat; + c_guard = guard; + c_rhs = {exp with exp_type = ty_res'} + } + ) + half_typed_cases + end in + 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 allow_modules 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; + with_level_if delayed ~level:lev begin fun () -> + check_unused ~lev allow_modules env ty_arg_check val_cases ; + check_unused ~lev allow_modules env Predef.type_exn exn_cases ; + end; + 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; + ((cases, partial), [ty_res']) + end + (* Ensure that existential types do not escape *) + ~post:(fun ty_res' -> unify_exp_types loc env ty_res' (newvar ())) + +(* Typing of let bindings *) + +and type_let ?check ?check_strict + existential_context env rec_flag spat_sexp_list allow_modules = + let spatl = List.map vb_pat_constraint spat_sexp_list in + let attrs_list = List.map fst spatl in + let is_recursive = (rec_flag = Recursive) in + + let (pat_list, exp_list, new_env, mvs, _pvs) = + with_local_level begin fun () -> + if existential_context = At_toplevel then Typetexp.TyVarEnv.reset (); + let (pat_list, new_env, force, pvs, mvs) = + with_local_level_if_principal begin fun () -> + let nvs = List.map (fun _ -> newvar ()) spatl in + let (pat_list, _new_env, _force, _pvs, _mvs as res) = + type_pattern_list + Value existential_context env spatl nvs allow_modules in + (* If recursive, first unify with an approximation of the + expression *) + if is_recursive then + List.iter2 + (fun pat binding -> + let pat = + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + {pat with pat_type = + snd (instance_poly ~keep_names:true false tl ty)} + | _ -> pat + in + let bound_expr = vb_exp_constraint binding in + unify_pat (ref env) pat (type_approx env bound_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; + res + end + ~post: begin fun (pat_list, _, _, pvs, _) -> + (* Generalize the structure *) + iter_pattern_variables_type generalize_structure pvs; + List.iter (fun pat -> generalize_structure pat.pat_type) pat_list + end + in + (* Note [add_module_variables after checking expressions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Don't call [add_module_variables] here, because its use of + [type_module] will fail until after we have type-checked the expression + of the let. Example: [let m : (module S) = ... in let (module M) = m in + ...] We learn the signature [S] from the type of [m] in the RHS of the + second let, and we need that knowledge for [type_module] to succeed. If + we type-checked expressions before patterns, then we could call + [add_module_variables] here. + *) + let new_env = add_pattern_variables new_env pvs in + let pat_list = + List.map + (fun pat -> {pat with pat_type = instance pat.pat_type}) + pat_list + in + (* Only bind pattern variables after generalizing *) + List.iter (fun f -> f()) force; + + let exp_list = + (* See Note [add_module_variables after checking expressions] + We can't defer type-checking module variables with recursive + definitions, so things like [let rec (module M) = m in ...] always + fail, even if the type of [m] is known. + *) + let exp_env = + if is_recursive then add_module_variables new_env mvs else env + in + type_let_def_wrap_warnings ?check ?check_strict ~is_recursive + ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs + (fun exp_env ({pvb_attributes; _} as vb) pat -> + let sexp = vb_exp_constraint vb in + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + let vars, ty' = + with_local_level_if_principal + ~post:(fun (_,ty') -> generalize_structure ty') + (fun () -> instance_poly ~keep_names:true true tl ty) + in + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp (mk_expected ty')) + in + exp, Some vars + | _ -> + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp (mk_expected pat.pat_type)) + in + exp, None) + in + List.iter2 + (fun pat (attrs, exp) -> + Builtin_attributes.warning_scope ~ppwarning:false attrs + (fun () -> + ignore(check_partial allow_modules env pat.pat_type pat.pat_loc + [case pat exp] : Typedtree.partial) + ) + ) + pat_list + (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list); + (pat_list, exp_list, new_env, mvs, + List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs) + end + ~post: begin fun (pat_list, exp_list, _, _, pvs) -> + 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 = + ]} + 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 + end + in + 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 (fun vb -> + if pattern_needs_partial_application_check vb.vb_pat then + check_partial_application ~statement:false vb.vb_expr + ) l; + (* See Note [add_module_variables after checking expressions] *) + let new_env = add_module_variables new_env mvs in + (l, new_env) + +and type_let_def_wrap_warnings + ?(check = fun s -> Warnings.Unused_var s) + ?(check_strict = fun s -> Warnings.Unused_var_strict s) + ~is_recursive ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs + type_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 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 sexp_is_fun { pvb_expr = sexp; _ } = + match sexp.pexp_desc with + | Pexp_fun _ | Pexp_function _ -> true + | _ -> false + in + let exp_env = + if not is_recursive && 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 exp_env pvs + | _ -> assert false + end + else exp_env + in + (* 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. + *) + let current_slot = ref None in + let rec_needed = ref false in + let pat_slot_list = + 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 case (pat, slot) -> + if is_recursive then current_slot := slot; + type_def exp_env case pat) + 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; + exp_list + +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 -> + let op_path, op_desc, op_type, ty_arg, ty_rest, ty_result = + with_local_level_iter_if_principal begin fun () -> + 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, commu_ok)) in + let ty_op = + newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, commu_ok)) in + begin try + unify env op_type ty_op + with Unify err -> + raise(Error(sop.loc, env, Andop_type_clash(sop.txt, err))) + end; + ((op_path, op_desc, op_type, ty_arg, ty_rest, ty_result), + [ty_rest; ty_arg; ty_result]) + end + ~post:generalize_structure + in + 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 err -> + raise(Error(loc, env, Bindings_type_clash(err))) + 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 method call *) +and type_send env loc explanation e met = + let obj = type_exp env e in + let (meth, typ) = + match obj.exp_desc with + | Texp_ident(_, _, {val_kind = Val_self(sign, meths, _, _)}) -> + let id, typ = + match meths with + | Self_concrete meths -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (Error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + id, typ + | Self_virtual meths_ref -> begin + match Meths.find met !meths_ref with + | id -> id, Btype.method_type met sign + | exception Not_found -> + let id = Ident.create_local met in + let ty = newvar () in + meths_ref := Meths.add met id !meths_ref; + add_method env met Private Virtual ty sign; + Location.prerr_warning loc + (Warnings.Undeclared_virtual_method met); + id, ty + end + in + Tmeth_val id, typ + | Texp_ident(_, _, {val_kind = Val_anc (sign, meths, cl_num)}) -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (Error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + let (self_path, _) = + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env + in + Tmeth_ancestor(id, self_path), typ + | _ -> + let ty = + match filter_method env met obj.exp_type with + | ty -> ty + | exception Filter_method_failed err -> + let error = + match err with + | Unification_error err -> + Expr_type_clash(err, explanation, None) + | Not_an_object ty -> + Not_an_object(ty, explanation) + | Not_a_method -> + let valid_methods = + match get_desc (expand_head env obj.exp_type) with + | Tobject (fields, _) -> + let (fields, _) = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if field_kind_repr meth_kind = Fpublic + then meth::li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None + in + Undefined_method(obj.exp_type, met, valid_methods) + in + raise (Error(e.pexp_loc, env, error)) + in + Tmeth_name met, ty + in + (obj,meth,typ) + +(* Typing of toplevel bindings *) + +let type_binding env rec_flag spat_sexp_list = + let (pat_exp_list, new_env) = + 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 Modules_rejected + in + (pat_exp_list, new_env) + +let type_let existential_ctx env rec_flag spat_sexp_list = + let (pat_exp_list, new_env) = + type_let existential_ctx env rec_flag spat_sexp_list Modules_rejected in + (pat_exp_list, new_env) + +(* Typing of toplevel expressions *) + +let type_expression env sexp = + let exp = + with_local_level begin fun () -> + Typetexp.TyVarEnv.reset(); + type_exp env sexp + end + ~post:(may_lower_contravariant_then_generalize env) + in + 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 + | Pconst_integer (s, _) -> Some s + | _ -> 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 tr -> + begin match get_desc Errortrace.(tr.expected.ty) with + Tconstr (typ, [], _) -> + report_literal_type_constraint typ const + | _ -> [] + end + | None -> [] + +let report_partial_application = function + | Some tr -> begin + match get_desc tr.Errortrace.got.Errortrace.expanded with + | Tarrow _ -> + [ Location.msg + "@[@{Hint@}: This function application is partial,@ \ + maybe some arguments are missing.@]" ] + | _ -> [] + end + | None -> [] + +let report_expr_type_clash_hints exp diff = + match exp with + | Some (Pexp_constant const) -> report_literal_type_constraint const diff + | Some (Pexp_apply _) -> report_partial_application diff + | _ -> [] + +let report_pattern_type_clash_hints pat diff = + match pat with + | Some (Ppat_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 err + ?type_expected_explanation txt1 txt2 = + Location.error_of_printer ~loc ?sub (fun ppf () -> + Printtyp.report_unification_error ppf env err + ?type_expected_explanation txt1 txt2 + ) () + +let report_this_function ppf funct = + if Typedtree.exp_is_nominal funct then + let pexp = Untypeast.untype_expression funct in + Format.fprintf ppf "The function '%a'" Pprintast.expression pexp + else Format.fprintf ppf "This function" + +let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc = + let open Location in + let cnum_offset off (pos : Lexing.position) = + { pos with pos_cnum = pos.pos_cnum + off } + in + let app_loc = + (* Span the application, including the extra argument. *) + { loc_start = loc.loc_start; + loc_end = extra_arg_loc.loc_end; + loc_ghost = false } + and tail_loc = + (* Possible location for a ';'. The location is widened to overlap the end + of the argument. *) + let arg_end = previous_arg_loc.loc_end in + { loc_start = cnum_offset ~-1 arg_end; + loc_end = cnum_offset ~+1 arg_end; + loc_ghost = false } + in + let hint_semicolon = if returns_unit then [ + msg ~loc:tail_loc "@{Hint@}: Did you forget a ';'?"; + ] else [] in + let sub = hint_semicolon @ [ + msg ~loc:extra_arg_loc "This extra argument is not expected."; + ] in + errorf ~loc:app_loc ~sub + "@[@[<2>%a has type@ %a@]\ + @ It is applied to too many arguments@]" + report_this_function funct Printtyp.type_expr func_ty + +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, err) -> + report_unification_error ~loc env err + (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 (err, pat) -> + let diff = type_clash_of_trace err.trace in + let sub = report_pattern_type_clash_hints pat diff in + report_unification_error ~loc ~sub env err + (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, err) -> + report_unification_error ~loc env err + (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 (err, explanation, exp) -> + let diff = type_clash_of_trace err.trace in + let sub = report_expr_type_clash_hints exp diff in + report_unification_error ~loc ~sub env err + ~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 { + funct; func_ty; res_ty; previous_arg_loc; extra_arg_loc + } -> + begin match get_desc func_ty with + Tarrow _ -> + let returns_unit = match get_desc res_ty with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + in + report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc + | _ -> + Location.errorf ~loc "@[@[<2>This expression has type@ %a@]@ %s@]" + Printtyp.type_expr func_ty + "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 + "@[@[<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 "@[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 + | Not_an_object (ty, explanation) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "This expression is not an object;@ \ + it has type %a" + Printtyp.type_expr ty; + report_type_expected_explanation_opt explanation ppf + ) () + | Undefined_method (ty, me, valid_methods) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.wrap_printing_env ~error:true env (fun () -> + fprintf ppf + "@[@[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_self_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 err -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.Subtype.report_error ppf env err "is not a subtype of" + ) () + | 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_exp, err, b) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.report_unification_error ppf env err + (function ppf -> + let ty_exp = Printtyp.prepare_expansion ty_exp in + fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \ + it has type" + (Printtyp.type_expansion Type) ty_exp) + (function ppf -> + fprintf ppf "but is here used with type"); + if b then + fprintf ppf ".@.@[%s@ @{Hint@}: Consider using a fully \ + explicit coercion@ %s@]" + "This simple coercion was not fully general." + "of the form: `(foo : ty1 :> ty2)'." + ) () + | Not_a_function (ty, explanation) -> + 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) + | Too_many_arguments (ty, explanation) -> + 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) + | Abstract_wrong_label {got; expected; expected_type; explanation} -> + let label ~long = function + | Nolabel -> "unlabeled" + | l -> (if long then "labeled " else "") ^ prefixed_label_name l + in + let second_long = match got, expected with + | Nolabel, _ | _, Nolabel -> true + | _ -> false + in + Location.errorf ~loc + "@[@[<2>This function should have type@ %a%t@]@,\ + @[but its first argument is %s@ instead of %s%s@]@]" + Printtyp.type_expr expected_type + (report_type_expected_explanation_opt explanation) + (label ~long:true got) + (if second_long then "being " else "") + (label ~long:second_long expected) + | 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_polymorphic_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, err) -> + report_unification_error ~loc env err + (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, err) -> + report_unification_error ~loc env err + (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, err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "The operator %s has type" name) + (function ppf -> + fprintf ppf "but it was expected to have type") + | Bindings_type_clash(err) -> + report_unification_error ~loc env err + (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." + | Wrong_expected_kind(sort, ctx, ty) -> + let ctx, explanation = + match ctx with + | Expression explanation -> "expression", explanation + | Pattern -> "pattern", None + in + let sort = + match sort with + | Constructor -> "constructor" + | Boolean -> "boolean literal" + | List -> "list literal" + | Unit -> "unit literal" + | Record -> "record" + in + Location.errorf ~loc + "This %s should not be a %s,@ \ + the expected type is@ %a%t" + ctx sort Printtyp.type_expr ty + (report_type_expected_explanation_opt explanation) + | Expr_not_a_record_type ty -> + Location.errorf ~loc + "This expression has type %a@ \ + which is not a record type." + Printtyp.type_expr ty + +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_501/typing/typecore.mli b/upstream/ocaml_501/typing/typecore.mli new file mode 100644 index 0000000000..6c73b08b4f --- /dev/null +++ b/upstream/ocaml_501/typing/typecore.mli @@ -0,0 +1,261 @@ +(**************************************************************************) +(* *) +(* 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; +} + +(* Variables in patterns *) +type pattern_variable = + { + pv_id: Ident.t; + pv_type: type_expr; + pv_loc: Location.t; + pv_as_var: bool; + pv_attributes: Typedtree.attributes; + } + +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 wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +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 *) + +type module_patterns_restriction = + | Modules_allowed of { scope : int } + | Modules_rejected + +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: + Env.t -> Parsetree.pattern -> + Typedtree.pattern * pattern_variable list +val check_partial: + ?lev:int -> module_patterns_restriction -> 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 generalize_structure_exp: Typedtree.expression -> unit +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_error + | Pattern_type_clash : + Errortrace.unification_error * Parsetree.pattern_desc option + -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * type_forcing_context option + * Parsetree.expression_desc option + | Apply_non_function of { + funct : Typedtree.expression; + func_ty : type_expr; + res_ty : type_expr; + previous_arg_loc : Location.t; + extra_arg_loc : Location.t; + } + | 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 + | Not_an_object of type_expr * type_forcing_context option + | Undefined_method of type_expr * string * string list option + | Undefined_self_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.error + | Outside_class + | Value_multiply_overridden of string + | Coercion_failure of + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } + | Scoping_let_module of string * type_expr + | Not_a_polymorphic_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * Errortrace.unification_error + | 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_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + +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 * Shape.t) 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 * 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_501/typing/typedecl.ml b/upstream/ocaml_501/typing/typedecl.ml new file mode 100644 index 0000000000..fcfbae876b --- /dev/null +++ b/upstream/ocaml_501/typing/typedecl.ml @@ -0,0 +1,2189 @@ +(**************************************************************************) +(* *) +(* 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 + +(* Our static analyses explore the set of type expressions "reachable" + from a type declaration, by expansion of definitions or by the + subterm relation (a type expression is syntactically contained + in another). *) +type reaching_type_path = reaching_type_step list +and reaching_type_step = + | Expands_to of type_expr * type_expr + | Contains of type_expr * type_expr + +type error = + Repeated_parameter + | Duplicate_constructor of string + | Too_many_constructors + | Duplicate_label of string + | Recursive_abbrev of string * Env.t * reaching_type_path + | Cycle_in_def of string * Env.t * reaching_type_path + | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error + | Non_regular of { + definition: Path.t; + used_as: type_expr; + defined_as: type_expr; + reaching_path: reaching_type_path; + } + | 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 * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error + | 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 err -> + raise (Error(loc, Type_clash (env, err))) + +(* Determine if a type's values are represented by floats at run-time. *) +let is_float env ty = + match Typedecl_unboxed.get_unboxed_type_representation env ty with + Some ty' -> + begin match get_desc ty' with + Tconstr(p, _, _) -> Path.same p Predef.path_float + | _ -> false + end + | _ -> 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 get_desc tm with + Tvariant row -> + let Row {fields; more; closed; name} = row_repr row in + set_type_desc tm + (Tvariant (create_row ~fields ~more ~closed ~name + ~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 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 + 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 univars 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 ?univars ~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 get_desc ty 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 univars closed = function + | Pcstr_tuple l -> + let l = List.map (transl_simple_type env ?univars ~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 univars closed l in + Types.Cstr_record lbls', + Cstr_record lbls + +let make_constructor env loc type_path type_params svars sargs sret_type = + match sret_type with + | None -> + let args, targs = + transl_constructor_arguments env None 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 *) + (* narrow and widen are now invoked through wrap_type_variable_scope *) + TyVarEnv.with_local_scope begin fun () -> + let closed = svars <> [] in + let targs, tret_type, args, ret_type, _univars = + Ctype.with_local_level_if closed begin fun () -> + TyVarEnv.reset (); + let univar_list = + TyVarEnv.make_poly_univars (List.map (fun v -> v.txt) svars) in + let univars = if closed then Some univar_list else None in + let args, targs = + transl_constructor_arguments env univars closed sargs + in + let tret_type = + transl_simple_type env ?univars ~closed sret_type in + let ret_type = tret_type.ctyp_type in + (* TODO add back type_path as a parameter ? *) + begin match get_desc ret_type with + | Tconstr (p', _, _) when Path.same type_path p' -> () + | _ -> + let trace = + (* Expansion is not helpful here -- the restriction on GADT + return types is purely syntactic. (In the worst case, + expansion produces gibberish.) *) + [Ctype.unexpanded_diff + ~got:ret_type + ~expected:(Ctype.newconstr type_path type_params)] + in + raise (Error(sret_type.ptyp_loc, + Constraint_failed( + env, Errortrace.unification_error ~trace))) + end; + (targs, tret_type, args, ret_type, univar_list) + end + ~post: begin fun (_, _, args, ret_type, univars) -> + Btype.iter_type_expr_cstr_args Ctype.generalize args; + Ctype.generalize ret_type; + let _vars = TyVarEnv.instance_poly_univars env loc univars in + let set_level t = Ctype.enforce_current_level env t in + Btype.iter_type_expr_cstr_args set_level args; + set_level ret_type; + end + in + targs, Some tret_type, args, Some ret_type + end + +let transl_declaration env sdecl (id, uid) = + (* Bind type parameters *) + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + 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 ~closed:false sty, + transl_simple_type env ~closed: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 scstr.pcd_loc (Path.Pident id) params + scstr.pcd_vars scstr.pcd_args scstr.pcd_res + in + let tcstr = + { cd_id = name; + cd_name = scstr.pcd_name; + cd_vars = scstr.pcd_vars; + 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 None 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 ~closed: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 err -> + raise(Error(loc, Inconsistent_constraint (env, err)))) + cstrs; + (* 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; + } + end + +(* 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 = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty 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 + (* We don't expand the error trace because that produces types that + *already* violate the constraints -- we need to report a problem with + the unexpanded types, or we get errors that talk about the same type + twice. This is generally true for constraint errors. *) + try Ctype.matches ~expand_error_trace:false env ty ty' + with Ctype.Matches_failure (env, err) -> + raise (Error(loc, Constraint_failed (env, err))) + 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 get_desc ty 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 err -> + Some (Includecore.Constraint err) + | () -> + 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, env, err))) + with Not_found -> + raise(Error(loc, Unavailable_type_constructor path)) + end + | _ -> raise(Error(loc, Definition_mismatch (ty, env, None))) + end + | _ -> () + +let check_abbrev env sdecl (id, decl) = + check_coherence env sdecl.ptype_loc (Path.Pident id) decl + + +(* Note: Well-foundedness for OCaml types + + We want to guarantee that all cycles within OCaml types are + "guarded". + + More precisly, we consider a reachability relation + "[t] is reachable [guarded|unguarded] from [u]" + defined as follows: + + - [t1, t2...] are reachable guarded from object types + [< m1 : t1; m2 : t2; ... >] + or polymorphic variants + [[`A of t1 | `B of t2 | ...]]. + + - [t1, t2...] are reachable rectypes-guarded from + [t1 -> t2], [t1 * t2 * ...], and all other built-in + contractive type constructors. + + (By rectypes-guarded we mean: guarded if -rectypes is set, + unguarded if it is not set.) + + - If [(t1, t2...) c] is a datatype (variant or record), + then [t1, t2...] are reachable rectypes-guarded from it. + + - If [(t1, t2...) c] is an abstract type, + then [t1, t2...] are reachable unguarded from it. + + - If [(t1, t2...) c] is an (expandable) abbreviation, + then its expansion is reachable unguarded from it. + Note that we do not define [t1, t2...] as reachable. + + - The relation is transitive and guardedness of a composition + is the disjunction of each guardedness: + if t1 is reachable from t2 and t2 is reachable from t3; + then t1 is reachable guarded from t3 if t1 is guarded in t2 + or t2 is guarded in t3, and reachable unguarded otherwise. + + A type [t] is not well-founded if and only if [t] is reachable + unguarded in [t]. + + Notice that, in the case of datatypes, the arguments of + a parametrized datatype are reachable (they must not contain + recursive occurrences of the type), but the definition of the + datatype is not defined as reachable. + + (* well-founded *) + type t = Foo of u + and u = t + + (* ill-founded *) + type 'a t = Foo of 'a + and u = u t + > Error: The type abbreviation u is cyclic + + Indeed, in the second example [u] is reachable unguarded in [u t] + -- its own definition. +*) + +(* Note: Forms of ill-foundedness + + Several OCaml language constructs could introduce ill-founded + types, and there are several distinct checks that forbid different + sources of ill-foundedness. + + 1. Type aliases. + + (* well-founded *) + type t = < x : 'a > as 'a + + (* ill-founded, unless -rectypes is used *) + type t = (int * 'a) as 'a + > Error: This alias is bound to type int * 'a + > but is used as an instance of type 'a + > The type variable 'a occurs inside int * 'a + + Ill-foundedness coming from type aliases is detected by the "occur check" + used by our type unification algorithm. See typetexp.ml. + + 2. Type abbreviations. + + (* well-founded *) + type t = < x : t > + + (* ill-founded, unless -rectypes is used *) + type t = (int * t) + > Error: The type abbreviation t is cyclic + + Ill-foundedness coming from type abbreviations is detected by + [check_well_founded] below. + + 3. Recursive modules. + + (* well-founded *) + module rec M : sig type t = < x : M.t > end = M + + (* ill-founded, unless -rectypes is used *) + module rec M : sig type t = int * M.t end = M + > Error: The definition of M.t contains a cycle: + > int * M.t + + This is also checked by [check_well_founded] below, + as called from [check_recmod_typedecl]. + + 4. Functor application + + A special case of (3) is that a type can be abstract + in a functor definition, and be instantiated with + an abbreviation in an application of the functor. + This can introduce ill-foundedness, so functor applications + must be checked by re-checking the type declarations of their result. + + module type T = sig type t end + module Fix(F:(T -> T)) = struct + (* this recursive definition is well-founded + as F(Fixed).t contains no reachable type expression. *) + module rec Fixed : T with type t = F(Fixed).t = F(Fixed) + end + + (* well-founded *) + Module M = Fix(functor (M:T) -> struct type t = < x : M.t > end) + + (* ill-founded *) + module M = Fix(functor (M:T) -> struct type t = int * M.t end);; + > Error: In the signature of this functor application: + > The definition of Fixed.t contains a cycle: + > F(Fixed).t +*) + +(* Check that a type expression is well-founded: + - if -rectypes is used, we must prevent non-contractive fixpoints + ('a as 'a) + - if -rectypes is not used, we only allow cycles in the type graph + if they go through an object or polymorphic variant type *) + +let check_well_founded env loc path to_check visited ty0 = + let rec check parents trace ty = + if TypeSet.mem ty parents then begin + (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) + let err = + let reaching_path, rec_abbrev = + (* The reaching trace is accumulated in reverse order, we + reverse it to get a reaching path. *) + match trace with + | [] -> assert false + | Expands_to (ty1, _) :: trace when (match get_desc ty1 with + Tconstr (p,_,_) -> Path.same p path | _ -> false) -> + List.rev trace, true + | trace -> List.rev trace, false + in + if rec_abbrev + then Recursive_abbrev (Path.name path, env, reaching_path) + else Cycle_in_def (Path.name path, env, reaching_path) + in raise (Error (loc, err)) + end; + let (fini, parents) = + try + (* Map each node to the set of its already checked parents *) + let prev = TypeMap.find ty !visited in + if TypeSet.subset parents prev then (true, parents) else + let parents = TypeSet.union parents prev in + visited := TypeMap.add ty parents !visited; + (false, parents) + with Not_found -> + visited := TypeMap.add ty parents !visited; + (false, parents) + in + if fini then () else + let rec_ok = + match get_desc ty with + | Tconstr(p,_,_) -> + !Clflags.recursive_types && Ctype.is_contractive env p + | Tobject _ | Tvariant _ -> true + | _ -> !Clflags.recursive_types + in + if rec_ok then () else + let parents = TypeSet.add ty parents in + match get_desc ty with + | Tconstr(p, tyl, _) -> + let to_check = to_check p in + if to_check then List.iter (check_subtype parents trace ty) tyl; + begin match Ctype.try_expand_once_opt env ty with + | ty' -> check parents (Expands_to (ty, ty') :: trace) ty' + | exception Ctype.Cannot_expand -> + if not to_check then List.iter (check_subtype parents trace ty) tyl + end + | _ -> + Btype.iter_type_expr (check_subtype parents trace ty) ty + and check_subtype parents trace outer_ty inner_ty = + check parents (Contains (outer_ty, inner_ty) :: trace) inner_ty + in + let snap = Btype.snapshot () in + try Ctype.wrap_trace_gadt_instances env (check TypeSet.empty []) ty0 + with Ctype.Escape _ -> + (* Will be detected by check_regularity *) + 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 + let visited = ref TypeMap.empty in + check_well_founded env loc path (Path.same path) visited + (Ctype.newconstr path args) + +(* Given a new type declaration [type t = ...] (potentially mutually-recursive), + we check that accepting the declaration does not introduce ill-founded types. + + Note: we check that the types at the toplevel of the declaration + are not reachable unguarded from themselves, that is, we check that + there is no cycle going through the "root" of the declaration. But + we *also* check that all the type sub-expressions reachable from + the root even those that are guarded, are themselves + well-founded. (So we check the absence of cycles, even for cycles + going through inner type subexpressions but not the root. + + We are not actually sure that this "deep check" is necessary + (we don't have an example at hand where it is necessary), but we + are doing it anyway out of caution. +*) +let check_well_founded_decl env loc path decl to_check = + let open Btype in + (* We iterate on all subexpressions of the declaration to check + "in depth" that no ill-founded type exists. *) + let it = + let checked = + (* [checked] remembers the types that the iterator already + checked, to avoid looping on cyclic types. *) + ref TypeSet.empty in + let visited = + (* [visited] remembers the inner visits performed by + [check_well_founded] on each type expression reachable from + this declaration. This avoids unnecessary duplication of + [check_well_founded] work when invoked on two parts of the + type declaration that have common subexpressions. *) + ref TypeMap.empty in + {type_iterators with it_type_expr = + (fun self ty -> + if TypeSet.mem ty !checked then () else begin + check_well_founded env loc path to_check visited ty; + checked := TypeSet.add ty !checked; + self.it_do_type_expr self ty + end)} in + it.it_type_declaration it (Ctype.generic_instance_declaration decl) + +(* Check for non-regular abbreviations; an abbreviation + [type 'a t = ...] is non-regular if the expansion of [...] + contains instances [ty t] where [ty] is not equal to ['a]. + + Note: in the case of a constrained type definition + [type 'a t = ... constraint 'a = ...], we require + that all instances in [...] be equal to the constrainted type. +*) + +let check_regularity ~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 TypeSet.empty in + + let rec check_regular cpath args prev_exp trace ty = + if not (TypeSet.mem ty !visited) then begin + visited := TypeSet.add ty !visited; + match get_desc ty 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; + reaching_path=List.rev trace; + })) + 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 err -> + raise (Error(loc, Constraint_failed (orig_env, err))); + end; + check_regular path' args + (path' :: prev_exp) (Expands_to (ty,body) :: trace) + body + with Not_found -> () + end; + List.iter (check_subtype cpath args prev_exp trace ty) args' + | Tpoly (ty, tl) -> + let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in + check_regular cpath args prev_exp trace ty + | _ -> + Btype.iter_type_expr + (check_subtype cpath args prev_exp trace ty) ty + end + and check_subtype cpath args prev_exp trace outer_ty inner_ty = + let trace = Contains (outer_ty, inner_ty) :: trace in + check_regular cpath args prev_exp trace inner_ty + 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_regularity ~orig_env env id_loc_list to_check tdecl = + let decl = tdecl.typ_type in + let id = tdecl.typ_id in + check_regularity ~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' = newty2 ~level:(get_level ty) (get_desc ty) in + if Ctype.deep_occur ty ty' then + let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in + link_type ty (newty2 ~level:(get_level ty) 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 + let tdecls, decls, new_env = + Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> + (* 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; + ((tdecls, decls, new_env), List.map snd decls) + end + in + (* 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_regularity ~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(svars, sargs, sret_type) -> + let targs, tret_type, args, ret_type = + make_constructor env sext.pext_loc type_path typext_params + svars sargs sret_type + in + args, ret_type, Text_decl(svars, 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 Keep_existentials_flexible 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 err -> + raise (Error(lid.loc, + Rebind_wrong_type(lid.txt, env, err))) + 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 + (fun ty -> + if get_desc ty = Tvar (Some "_") + && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + typext_params + end; + (* Ensure that constructor's type matches the type being extended *) + let cstr_type_path = Btype.cstr_type_path cdescr in + let cstr_type_params = (Env.find_type cstr_type_path env).type_params 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 List.map get_desc args with + | [ 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 = + 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, env, err))) + end; + let ttype_params, _type_params, constructors = + (* Note: it would be incorrect to call [create_scope] *after* + [TyVarEnv.reset] or after [with_local_level] (see #10010). *) + let scope = Ctype.create_scope () in + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + 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 + (ttype_params, type_params, constructors) + end + ~post: begin fun (_, type_params, constructors) -> + (* 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; + end + in + (* 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 ext = + let scope = Ctype.create_scope () in + Ctype.with_local_level + (fun () -> + TyVarEnv.reset(); + transl_extension_constructor ~scope env + Predef.path_exn [] [] Asttypes.Public sext) + ~post: begin 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; + end + in + (* 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, get_desc (Ctype.expand_head_opt env ty) 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, get_desc ty, + 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_poly (_, t) | Ptyp_alias (t, _)), _, _ -> + parse_native_repr_attributes env t ty ~global_repr + | 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.expand_head_opt env ty in + try match get_desc ty 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; + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + (* 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 ~closed:false ty in + let cty' = transl_simple_type env ~closed: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 ~closed: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 err -> + raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, err))) + ) 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 err -> + raise(Error(loc, Inconsistent_constraint (env, err))) + ) 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:(Some id) 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 + { + 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; + } + end + ~post:(fun ttyp -> generalize_decl ttyp.typ_type) + +(* 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.with_local_level ~post:generalize_decl begin fun () -> + { 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; + } + end + +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 + +(* 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_regularity ~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.prepare_for_printing [typ ti; ty0]; + fprintf ppf + ".@ @[In %s@ %a@;<1 -2>the variable %a is unbound@]" + kwd pr ti Printtyp.prepared_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.prepared_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 get_desc ty with + Tobject(fi,_) -> + let (tl, rv) = Ctype.flatten_fields fi in + if eq_type rv tv then trivial ty else + explain_unbound ppf tv tl (fun (_,_,t) -> t) + "method" (fun (lab,_,_) -> lab ^ ": ") + | Tvariant row -> + if eq_type (row_more row) tv then trivial ty else + explain_unbound ppf tv (row_fields row) + (fun (_l,f) -> match 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 + +module Reaching_path = struct + type t = reaching_type_path + + (* Simplify a reaching path before showing it in error messages. *) + let simplify path = + let rec simplify : t -> t = function + | Contains (ty1, _ty2) :: Contains (_ty2', ty3) :: rest -> + (* If t1 contains t2 and t2 contains t3, then t1 contains t3 + and we don't need to show t2. *) + simplify (Contains (ty1, ty3) :: rest) + | hd :: rest -> hd :: simplify rest + | [] -> [] + in simplify path + + (* See Printtyp.add_type_to_preparation. + + Note: it is better to call this after [simplify], otherwise some + type variable names may be used for types that are removed + by simplification and never actually shown to the user. + *) + let add_to_preparation path = + List.iter (function + | Contains (ty1, ty2) | Expands_to (ty1, ty2) -> + List.iter Printtyp.add_type_to_preparation [ty1; ty2] + ) path + + let pp ppf reaching_path = + let pp_step ppf = function + | Expands_to (ty, body) -> + Format.fprintf ppf "%a = %a" + Printtyp.prepared_type_expr ty + Printtyp.prepared_type_expr body + | Contains (outer, inner) -> + Format.fprintf ppf "%a contains %a" + Printtyp.prepared_type_expr outer + Printtyp.prepared_type_expr inner + in + let comma ppf () = Format.fprintf ppf ",@ " in + Format.(pp_print_list ~pp_sep:comma pp_step) ppf reaching_path + + let pp_colon ppf path = + Format.fprintf ppf ":@;<1 2>@[%a@]" + pp path +end + +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, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Printtyp.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The type abbreviation %s is cyclic%a@]" + s + Reaching_path.pp_colon reaching_path + | Cycle_in_def (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Printtyp.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The definition of %s contains a cycle%a@]" + s + Reaching_path.pp_colon reaching_path + | Definition_mismatch (ty, _env, None) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" + "This variant or record definition" "does not match that of type" + Printtyp.type_expr ty + | Definition_mismatch (ty, env, Some err) -> + fprintf ppf "@[@[%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" env) + err + | Constraint_failed (env, err) -> + fprintf ppf "@[Constraints are not satisfied in this type.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "should be an instance of"); + fprintf ppf "@]" + | Non_regular { definition; used_as; defined_as; reaching_path } -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.prepare_for_printing [used_as; defined_as]; + Reaching_path.add_to_preparation reaching_path; + fprintf ppf + "@[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%t\ + All uses need to match the definition for the recursive type \ + to be regular.@]" + (Path.name definition) + !Oprint.out_type (Printtyp.tree_of_typexp Type defined_as) + !Oprint.out_type (Printtyp.tree_of_typexp Type used_as) + (fun pp -> + let is_expansion = function Expands_to _ -> true | _ -> false in + if List.exists is_expansion reaching_path then + fprintf pp "@ after the following expansion(s)%a@ " + Reaching_path.pp_colon reaching_path + else fprintf pp ".@ ") + | Inconsistent_constraint (env, err) -> + fprintf ppf "@[The type constraints are not consistent.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type"); + fprintf ppf "@]" + | Type_clash (env, err) -> + Printtyp.report_unification_error ppf env err + (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 "@[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"; + 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, env, err) -> + fprintf ppf "@[@[%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" env) + err + | Rebind_wrong_type (lid, env, err) -> + Printtyp.report_unification_error ppf env err + (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 + (match n with + | Variance_variable_error { error; variable; context } -> + Printtyp.prepare_for_printing [ variable ]; + begin match context with + | Type_declaration (id, decl) -> + Printtyp.add_type_declaration_to_preparation id decl; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the definition" + (Printtyp.prepared_type_declaration id) + decl + | Gadt_constructor c -> + Printtyp.add_constructor_to_preparation c; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the GADT constructor" + Printtyp.prepared_constructor + c + | Extension_constructor (id, e) -> + Printtyp.add_extension_constructor_to_preparation e; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the extension constructor" + (Printtyp.prepared_extension_constructor id) + e + end; + begin match error with + | Variance_not_reflected -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" + Printtyp.prepared_type_expr variable + "has a variance that" + "is not reflected by its occurrence in type parameters." + | No_variable -> + fprintf ppf "@[%s@ %a@ %s@ %s@]@]" + "the type variable" + Printtyp.prepared_type_expr variable + "cannot be deduced" + "from the type parameters." + | Variance_not_deducible -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" + Printtyp.prepared_type_expr variable + "has a variance that" + "cannot be deduced from the type parameters." + end + | Variance_not_satisfied n -> + fprintf ppf "@[@[%s@ %s@ The %d%s type parameter" + "In this definition, expected parameter" + "variances are not satisfied." + n (Misc.ordinal_suffix n)); + (match n with + | Variance_variable_error { error = 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 + "@[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.@]@,\ + @[@[@{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_501/typing/typedecl.mli b/upstream/ocaml_501/typing/typedecl.mli new file mode 100644 index 0000000000..013fae4300 --- /dev/null +++ b/upstream/ocaml_501/typing/typedecl.mli @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* 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 + +type native_repr_kind = Unboxed | Untagged + +type reaching_type_path = reaching_type_step list +and reaching_type_step = + | Expands_to of type_expr * type_expr + | Contains of type_expr * type_expr + +type error = + Repeated_parameter + | Duplicate_constructor of string + | Too_many_constructors + | Duplicate_label of string + | Recursive_abbrev of string * Env.t * reaching_type_path + | Cycle_in_def of string * Env.t * reaching_type_path + | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error + | Non_regular of { + definition: Path.t; + used_as: type_expr; + defined_as: type_expr; + reaching_path: reaching_type_path; + } + | 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 * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error + | 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_501/typing/typedecl_immediacy.ml b/upstream/ocaml_501/typing/typedecl_immediacy.ml new file mode 100644 index 0000000000..f1f0594f9a --- /dev/null +++ b/upstream/ocaml_501/typing/typedecl_immediacy.ml @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* 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 + | None -> Type_immediacy.Unknown + | Some argrepr -> Ctype.immediacy env argrepr + end + | (Type_variant (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_501/typing/typedecl_immediacy.mli b/upstream/ocaml_501/typing/typedecl_immediacy.mli new file mode 100644 index 0000000000..17fb985c80 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/typedecl_properties.ml b/upstream/ocaml_501/typing/typedecl_properties.ml new file mode 100644 index 0000000000..28a1bb6673 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/typedecl_properties.mli b/upstream/ocaml_501/typing/typedecl_properties.mli new file mode 100644 index 0000000000..153c3f719c --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/typedecl_separability.ml b/upstream/ocaml_501/typing/typedecl_separability.ml new file mode 100644 index 0000000000..c6ded4cf6a --- /dev/null +++ b/upstream/ocaml_501/typing/typedecl_separability.ml @@ -0,0 +1,668 @@ +(**************************************************************************) +(* *) +(* 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 get_desc ret_type with + | Tconstr (_, tyl, _) -> 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 get_desc ty 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 get_desc ty 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 (row_fields desc) in + let add_row acc = + let row = row_more desc in + match get_desc row with + | Tvariant more -> immediate_subtypes_variant_row acc more + | _ -> row :: acc + in + add_row (add_subtypes acc) + +and immediate_subtypes_variant_row_field acc f = + match row_field_repr f with + | Rpresent(None) + | Rabsent -> acc + | Rpresent(Some(ty)) -> ty :: acc + | Reither(_,field_types,_) -> + List.rev_append field_types acc + +let free_variables ty = + Ctype.free_variables ty + |> List.map (fun ty -> + match get_desc ty with + Tvar text -> {text; id = get_id ty} + | _ -> + (* 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 = + 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 (get_desc ty, 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 = get_id ty} 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 = ) + for each type parameter 'a of the type constructor. For each + such equation, we should "strengthen" the current context in + the following way: + - if is another variable 'b, + the mode of 'a is set to the mode of 'b, + and 'b is set to Ind + - if 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 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 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 get_desc param_instance with + | Tvar text -> + let var = {text; id = get_id param_instance} 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_501/typing/typedecl_separability.mli b/upstream/ocaml_501/typing/typedecl_separability.mli new file mode 100644 index 0000000000..079e640807 --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/typedecl_unboxed.ml b/upstream/ocaml_501/typing/typedecl_unboxed.ml new file mode 100644 index 0000000000..16290f0fbb --- /dev/null +++ b/upstream/ocaml_501/typing/typedecl_unboxed.ml @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* 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 + +(* 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 None else + let ty = Ctype.expand_head_opt env ty in + match get_desc ty with + | Tconstr (p, args, _) -> + begin match Env.find_type p env with + | exception Not_found -> Some ty + | {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 get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in + get_unboxed_type_representation env + (Ctype.apply env type_params ty2 args) (fuel - 1) + | _ -> Some ty + end + | _ -> Some 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_501/typing/typedecl_unboxed.mli b/upstream/ocaml_501/typing/typedecl_unboxed.mli new file mode 100644 index 0000000000..9e860dc128 --- /dev/null +++ b/upstream/ocaml_501/typing/typedecl_unboxed.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* 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 + +(* for typeopt.ml *) +val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option diff --git a/upstream/ocaml_501/typing/typedecl_variance.ml b/upstream/ocaml_501/typing/typedecl_variance.ml new file mode 100644 index 0000000000..ca0521aec9 --- /dev/null +++ b/upstream/ocaml_501/typing/typedecl_variance.ml @@ -0,0 +1,438 @@ +(**************************************************************************) +(* *) +(* 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_variable_context = + | Type_declaration of Ident.t * type_declaration + | Gadt_constructor of constructor_declaration + | Extension_constructor of Ident.t * extension_constructor + +type variance_variable_error = + | No_variable + | Variance_not_reflected + | Variance_not_deducible + +type variance_error = + | Variance_not_satisfied of int + | Variance_variable_error of { + error : variance_variable_error; + context : variance_variable_context; + variable : type_expr + } + +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 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 get_desc ty with + Tarrow (_, ty1, ty2, _) -> + compute_variance_rec (Variance.conjugate vari) 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 + List.iter2 + (fun ty v -> compute_variance_rec (compose vari v) 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 -> + List.iter + (fun (_,f) -> + match row_field_repr f with + Rpresent (Some ty) -> + compute_same ty + | Reither (_, tyl, _) -> + let v = Variance.(inter vari unknown) in (* cf PR#7269 *) + List.iter (compute_variance_rec v) tyl + | _ -> ()) + (row_fields row); + compute_same (row_more row) + | Tpoly (ty, _) -> + compute_same ty + | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () + | Tpackage (_, fl) -> + let v = Variance.(compose vari full) 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_if p May_pos (set_if n May_neg (set_if i Inj null)) + +let injective = Variance.(set Inj 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 = 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 = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + if mem Inj (get_variance ty tvl) then () else + match get_desc ty 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 eq_type 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; + begin match check with + | None -> () + | Some context -> + (* 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.exists (eq_type 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 = + 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 begin + match List.find_opt (eq_type ty) fvl with + | Some variable -> + let error = + if not i2 then + No_variable + else if c2 || n2 then + Variance_not_reflected + else + Variance_not_deducible + in + let variance_error = + Variance_variable_error { error; context; variable } + in + raise + (Error (loc + , Bad_variance ( variance_error + , (c1,n1,false) + , (c2,n2,false)))) + | None -> + Btype.iter_type_expr check ty + end + 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 + if not concr || Btype.is_Tvar ty then v else + union v + (if p then if n then full else covariant else conjugate covariant)) + 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 get_desc ty with + | Tvar _ -> List.exists (List.exists (eq_type ty)) 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 get_desc ret_type with + | Tconstr (_, tyl, _) -> + (* let tyl = List.map (Ctype.expand_head env) 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 decl ext rloc = + let check = + Some (Extension_constructor (ext.Typedtree.ext_id, ext.Typedtree.ext_type)) + in + let ext = ext.Typedtree.ext_type in + compute_variance_gadt env ~check rloc + {decl with type_params = ext.ext_type_params} + (ext.ext_args, ext.ext_ret_type) + +let compute_variance_gadt_constructor env ~check rloc decl tl = + let check = + match check with + | Some _ -> Some (Gadt_constructor tl) + | None -> None + in + compute_variance_gadt env ~check rloc decl + (tl.Types.cd_args, tl.Types.cd_res) + +let compute_variance_decl env ~check decl (required, _ as rloc) = + let check = + Option.map (fun id -> Type_declaration (id, decl)) check + in + 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 begin + let mn = + match decl.type_manifest with + None -> [] + | Some ty -> [ false, ty ] + in + let vari = + 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 vari = + List.map + (fun ty -> + compute_variance_type env ~check rloc + {decl with type_private = Private} + (add_false [ ty ]) + ) + (Option.to_list decl.type_manifest) + in + let constructor_variance = + List.map + (compute_variance_gadt_constructor env ~check rloc decl) + tll + in + match List.append vari constructor_variance with + | vari :: rem -> + List.fold_left (List.map2 Variance.union) vari rem + | _ -> 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) + in + if mn = [] || decl.type_kind <> Type_abstract then + List.map Variance.strengthen vari + else vari + end + +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 decl ext rloc) + +let compute_decl env ~check decl req = + compute_variance_decl env ~check decl (req, decl.type_loc) + +let check_decl env id decl req = + ignore (compute_variance_decl env ~check:(Some id) 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:None 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 id 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, _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) (_, _, clty, cltydef, _) -> + let variance = decl.type_variance in + (decl, {clty with cty_variance = variance}, + {cltydef with + clty_variance = variance; + clty_hash_type = {cltydef.clty_hash_type with type_variance = variance} + })) + decls cldecls diff --git a/upstream/ocaml_501/typing/typedecl_variance.mli b/upstream/ocaml_501/typing/typedecl_variance.mli new file mode 100644 index 0000000000..6392e61dd1 --- /dev/null +++ b/upstream/ocaml_501/typing/typedecl_variance.mli @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* 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_variable_context = + | Type_declaration of Ident.t * type_declaration + | Gadt_constructor of constructor_declaration + | Extension_constructor of Ident.t * extension_constructor + +type variance_variable_error = + | No_variable + | Variance_not_reflected + | Variance_not_deducible + +type variance_error = + | Variance_not_satisfied of int + | Variance_variable_error of { + error : variance_variable_error; + context : variance_variable_context; + variable : type_expr + } + +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:Ident.t option -> 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.class_declaration * Types.class_type_declaration * + 'a Typedtree.class_infos) list -> + (Typedecl_properties.decl * + Types.class_declaration * Types.class_type_declaration) list +(* FIXME: improve this horrible interface *) diff --git a/upstream/ocaml_501/typing/typedtree.ml b/upstream/ocaml_501/typing/typedtree.ml new file mode 100644 index 0000000000..e437f5ceb0 --- /dev/null +++ b/upstream/ocaml_501/typing/typedtree.ml @@ -0,0 +1,863 @@ +(**************************************************************************) +(* *) +(* 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 + | 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 * (Ident.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 * Location.t + | 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 + | Tmeth_ancestor of Ident.t * Path.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 * mutable_flag + | 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 * MethSet.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_apply_unit of module_expr + | 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_vars: string loc list; + 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 string loc list * 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_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; + shape: Shape.t; +} + + +(* 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 + +(* Expressions are considered nominal if they can be used as the subject of a + sentence or action. In practice, we consider that an expression is nominal + if they satisfy one of: + - Similar to an identifier: words separated by '.' or '#'. + - Do not contain spaces when printed. + *) +let rec exp_is_nominal exp = + match exp.exp_desc with + | _ when exp.exp_attributes <> [] -> false + | Texp_ident _ | Texp_instvar _ | Texp_constant _ + | Texp_variant (_, None) + | Texp_construct (_, _, []) -> + true + | Texp_field (parent, _, _) | Texp_send (parent, _) -> exp_is_nominal parent + | _ -> false diff --git a/upstream/ocaml_501/typing/typedtree.mli b/upstream/ocaml_501/typing/typedtree.mli new file mode 100644 index 0000000000..985f7d8b25 --- /dev/null +++ b/upstream/ocaml_501/typing/typedtree.mli @@ -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 *) + + +(** 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, _, _) :: ... } + (module _) { pat_desc = Tpat_any + ; 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 + | 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 * (Ident.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 * Location.t + | 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 + | Tmeth_ancestor of Ident.t * Path.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 * mutable_flag + | 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.MethSet.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_apply_unit of module_expr + | 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_vars: string loc list; + 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 string loc list * 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_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; + shape: Shape.t; +} +(** 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 + +(** Whether an expression looks nice as the subject of a sentence in a error + message. *) +val exp_is_nominal : expression -> bool diff --git a/upstream/ocaml_501/typing/typemod.ml b/upstream/ocaml_501/typing/typemod.ml new file mode 100644 index 0000000000..4ad993be2b --- /dev/null +++ b/upstream/ocaml_501/typing/typemod.ml @@ -0,0 +1,3430 @@ +(**************************************************************************) +(* *) +(* 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 Sig_component_kind = Shape.Sig_component_kind +module String = Misc.Stdlib.String + +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 { vars : type_expr list; expression : type_expr } + | Non_generalizable_module of + { vars : type_expr list; item : value_description; mty : 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 + | Pextra_ty (p, extra) -> Pextra_ty (path_concat head p, extra) + +(* 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 ~initially_opened_module + ~open_implicit_modules = + let env = Env.initial 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 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_if p May_pos (set_if n May_neg (set_if i Inj 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 *) + | Pextra_ty _ -> assert false + +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 get_desc ty 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 get_desc hd 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 = + Env.lookup_modtype_path ~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_path ~use:false ~load:false + ~loc:lid'.loc lid'.txt env) + | Pwith_modsubst (_, lid') -> + ignore (Env.lookup_module_path ~use:false ~load: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, env = 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); + ] + ) 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 = + Env.lookup_modtype_path ~loc lid env + +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; + Env.register_uid tdesc.val_val.val_uid tdesc.val_loc; + 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; + if not (Btype.is_row_name (Ident.name td.typ_id)) then + Env.register_uid td.typ_type.type_uid td.typ_loc + ) 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; + Env.register_uid td.typ_type.type_uid td.typ_loc + ) 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; + Env.register_uid ext.ext_type.ext_uid ext.ext_loc + ) 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; + Env.register_uid + constructor.ext_type.ext_uid + constructor.ext_loc; + 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 + Env.register_uid md.md_uid md.md_loc; + 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; + Env.register_uid md.md_uid md.md_loc; + 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, uid) -> + Signature_names.check_module names md.md_loc id; + Env.register_uid uid md.md_loc + ) decls; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_recmodule (List.map (fun (md, _, _) -> md) 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, decl = transl_modtype_decl env pmtd in + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + Env.register_uid decl.mtd_uid mtd.mtd_loc; + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_modtype mtd) env loc :: trem, + Sig_modtype (mtd.mtd_id, decl, Exported) :: rem, + final_env + | Psig_modtypesubst pmtd -> + let newenv, mtd, decl = 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; + Env.register_uid decl.mtd_uid mtd.mtd_loc; + 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; + Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc; + ) 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) + ] + ) 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; + Env.register_uid + decl.clsty_ty_decl.clty_uid + decl.clsty_ty_decl.clty_loc; + ) 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); + ] + ) 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, decl + +and transl_recmodule_modtypes env sdecls = + let make_env curr = + List.fold_left (fun env (id_shape, _, md, _) -> + Option.fold ~none:env ~some:(fun (id, shape) -> + Env.add_module_declaration ~check:true ~shape ~arg:true + id Mp_present md env + ) id_shape + ) env curr + in + let transition env_c curr = + List.map2 + (fun pmd (id_shape, 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_shape, id_loc, md, tmty)) + sdecls curr in + let map_mtys curr = + List.filter_map + (fun (id_shape, _, md, _) -> + Option.map (fun (id, _) -> (id, md)) id_shape) + 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_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let md = + { md_type = approx_modtype approx_env pmd.pmd_type; + md_loc = pmd.pmd_loc; + md_attributes = pmd.pmd_attributes; + md_uid } + in + let id_shape = + Option.map (fun id -> id, Shape.var md_uid id) id + in + (id_shape, 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_shape, id_loc, md, mty) -> + let tmd = + {md_id=Option.map fst id_shape; 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, Option.map snd id_shape + ) 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 + | (Tmod_structure _ | Tmod_functor _ | Tmod_apply_unit _ | Tmod_unpack _ | + Tmod_apply _) -> + 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 + do not contain non-generalized type variable *) + +let rec nongen_modtype env = function + Mty_ident _ -> None + | Mty_alias _ -> None + | Mty_signature sg -> + let env = Env.add_signature sg env in + List.find_map (nongen_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 + nongen_modtype env body + +and nongen_signature_item env = function + | Sig_value(_id, desc, _) -> + Ctype.nongen_vars_in_schema env desc.val_type + |> Option.map (fun vars -> (vars, desc)) + | Sig_module(_id, _, md, _, _) -> nongen_modtype env md.md_type + | _ -> None + +let check_nongen_modtype env loc mty = + nongen_modtype env mty + |> Option.iter (fun (vars, item) -> + let vars = Btype.TypeSet.elements vars in + let error = + Non_generalizable_module { vars; item; mty } + in + raise(Error(loc, env, error)) + ) + +let check_nongen_signature_item env sig_item = + match sig_item with + Sig_value(_id, vd, _) -> + Ctype.nongen_vars_in_schema env vd.val_type + |> Option.iter (fun vars -> + let vars = Btype.TypeSet.elements vars in + let error = + Non_generalizable { vars; expression = vd.val_type } + in + raise (Error (vd.val_loc, env, error)) + ) + | Sig_module (_id, _, md, _, _) -> + check_nongen_modtype env md.md_loc md.md_type + | _ -> () + +let check_nongen_signature env sg = + List.iter (check_nongen_signature_item 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, shape, _uid) -> + let ids = + Option.map + (fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id + in + (ids, mty_actual, shape)) + 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, shape) -> + 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 ~shape 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, _shape) -> + 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, shape, 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, shape = + try + Includemod.modtypes_with_shape ~shape + ~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, shape, 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 = + (* We call Ctype.correct_levels to ensure that the types being added to the + module type are at generic_level. *) + let mty = + package_constraints env loc (Mty_ident p) + (List.map (fun (n, t) -> Longident.flatten n, Ctype.correct_levels t) fl) + in + Subst.modtype Keep Subst.identity mty + +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_package env mark arg mty explicit = + let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let mty1 = Subst.modtype Keep Subst.identity arg.mod_type in + let mty2 = Subst.modtype Keep Subst.identity mty in + let coercion = + try + Includemod.modtypes ~loc:arg.mod_loc env ~mark mty1 mty2 + 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 } + +let wrap_constraint_with_shape env mark arg mty + shape explicit = + let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let coercion, shape = + try + Includemod.modtypes_with_shape ~shape ~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 }, shape + +(* Type a module value expression *) + + +(* These describe the X in [F(X)] (which might be missing, for [F ()]) *) +type argument_summary = { + is_syntactic_unit: bool; + arg: Typedtree.module_expr; + path: Path.t option; + shape: Shape.t +} + +type application_summary = { + loc: Location.t; + attributes: attributes; + f_loc: Location.t; (* loc for F *) + arg: argument_summary option (* None for () *) +} + +let simplify_app_summary app_view = match app_view.arg with + | None -> + Includemod.Error.Unit, Mty_signature [] + | Some arg -> + let mty = arg.arg.mod_type in + match arg.is_syntactic_unit , arg.path with + | true , _ -> Includemod.Error.Empty_struct, 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 shape = + Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path + in + let md = + if alias && aliasable then + (Env.add_required_global (Path.head path); md) + else begin + let mty = + if sttn then + Env.find_strengthened_module ~aliasable path env + else + (Env.find_module path env).md_type + in + match mty 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 + ~strengthen:sttn env p1 in + { md with + mod_desc = + Tmod_constraint (md, mty, Tmodtype_implicit, + Tcoerce_alias (env, path, Tcoerce_none)); + mod_type = mty } + | mty -> + { md with mod_type = mty } + end + in + md, shape + | Pmod_structure sstr -> + let (str, sg, names, shape, _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, shape else + wrap_constraint_with_shape env false md + (Mty_signature sg') shape Tmodtype_implicit + | Pmod_functor(arg_opt, sbody) -> + let t_arg, ty_arg, newenv, funct_shape_param, funct_body = + match arg_opt with + | Unit -> + Unit, Types.Unit, env, Shape.for_unnamed_functor_param, false + | Named (param, smty) -> + let mty = transl_modtype_functor_arg env smty in + let scope = Ctype.create_scope () in + let (id, newenv, var) = + match param.txt with + | None -> None, env, Shape.for_unnamed_functor_param + | Some name -> + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let arg_md = + { md_type = mty.mty_type; + md_attributes = []; + md_loc = param.loc; + md_uid; + } + in + let id = Ident.create_scoped ~scope name in + let shape = Shape.var md_uid id in + let newenv = Env.add_module_declaration + ~shape ~arg:true ~check:true id Mp_present arg_md env + in + Some id, newenv, id + in + Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, + var, true + in + let body, body_shape = 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 }, + Shape.abs funct_shape_param body_shape + | Pmod_apply _ | Pmod_apply_unit _ -> + type_application smod.pmod_loc sttn funct_body env smod + | Pmod_constraint(sarg, smty) -> + let arg, arg_shape = type_module ~alias true funct_body anchor env sarg in + let mty = transl_modtype env smty in + let md, final_shape = + wrap_constraint_with_shape env true arg mty.mty_type arg_shape + (Tmodtype_explicit mty) + in + { md with + mod_loc = smod.pmod_loc; + mod_attributes = smod.pmod_attributes; + }, + final_shape + | Pmod_unpack sexp -> + let exp = + Ctype.with_local_level_if_principal + (fun () -> Typecore.type_exp env sexp) + ~post:Typecore.generalize_structure_exp + in + let mty = + match get_desc (Ctype.expand_head env exp.exp_type) with + 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 + | 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 }, + Shape.leaf_for_unpack + | 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, shape = 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 = Some { + is_syntactic_unit = sarg.pmod_desc = Pmod_structure []; + arg; + path = path_of_module arg; + shape; + } + } in + extract_application funct_body env (summary::sargs) f + | Pmod_apply_unit f -> + let summary = { + loc = smod.pmod_loc; + attributes = smod.pmod_attributes; + f_loc = f.pmod_loc; + arg = None + } in + extract_application funct_body env (summary::sargs) f + | _ -> smod, sargs + in + let sfunct, args = extract_application funct_body env [] smod in + let funct, funct_shape = + let has_path { arg } = match arg with + | None | Some { path = None } -> false + | Some { path = Some _ } -> true + in + let strengthen = strengthen && List.for_all has_path 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, funct_shape) args + +and type_one_application ~ctx:(apply_loc,md_f,args) + funct_body env (funct, funct_shape) app_view = + match Env.scrape_alias env funct.mod_type with + | Mty_functor (Unit, mty_res) -> + begin match app_view.arg with + | None -> () + | Some arg -> + if arg.is_syntactic_unit then + (* this call to warning_scope allows e.g. + [ F (struct end [@warning "-73"]) ] + not to warn; useful when generating code that must + work over multiple versions of OCaml *) + Builtin_attributes.warning_scope arg.arg.mod_attributes @@ fun () -> + Location.prerr_warning arg.arg.mod_loc + Warnings.Generative_application_expects_unit + else + raise (Error (app_view.f_loc, env, Apply_generative)); + end; + 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_unit funct; + mod_type = mty_res; + mod_env = env; + mod_attributes = app_view.attributes; + mod_loc = funct.mod_loc }, + Shape.app funct_shape ~arg:Shape.dummy_mod + | Mty_functor (Named (param, mty_param), mty_res) as mty_functor -> + let apply_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 + begin match app_view with + | { arg = None; _ } -> apply_error () + | { loc = app_loc; attributes = app_attributes; + arg = Some { shape = arg_shape; path = arg_path; arg } } -> + let coercion = + try Includemod.modtypes + ~loc:arg.mod_loc ~mark:Mark_both env arg.mod_type mty_param + with Includemod.Error _ -> apply_error () + in + let mty_appl = + match 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 arg.mod_type env + in + check_well_formed_module env app_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_loc, env, error)) + in + begin match + Includemod.modtypes + ~loc:app_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, arg, coercion); + mod_type = mty_appl; + mod_env = env; + mod_attributes = app_attributes; + mod_loc = app_loc }, + Shape.app ~arg:arg_shape funct_shape + end + | 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, mod_shape = type_module true funct_body None env od.popen_expr in + let scope = Ctype.create_scope () in + let sg, newenv = + Env.enter_signature ~scope ~mod_shape + (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 shape_map {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), [], shape_map, 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. *) + let items, shape_map = + List.fold_left + (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ)-> + Signature_names.check_value names loc id; + let vd = Env.find_value (Pident id) newenv in + Env.register_uid vd.val_uid vd.val_loc; + Sig_value(id, vd, Exported) :: acc, + Shape.Map.add_value shape_map id vd.val_uid + ) + ([], shape_map) + (let_bound_idents_full defs) + in + Tstr_value(rec_flag, defs), + List.rev items, + shape_map, + 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; + Env.register_uid desc.val_val.val_uid desc.val_val.val_loc; + Tstr_primitive desc, + [Sig_value(desc.val_id, desc.val_val, Exported)], + Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid, + 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; + let items = map_rec_type_with_row_types ~rec_flag + (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported)) + decls [] + in + let shape_map = List.fold_left + (fun shape_map -> function + | Sig_type (id, vd, _, _) -> + if not (Btype.is_row_name (Ident.name id)) then begin + Env.register_uid vd.type_uid vd.type_loc; + Shape.Map.add_type shape_map id vd.type_uid + end else shape_map + | _ -> assert false + ) + shape_map + items + in + Tstr_type (rec_flag, decls), + items, + shape_map, + 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 + let shape_map = List.fold_left (fun shape_map ext -> + Signature_names.check_typext names ext.ext_loc ext.ext_id; + Env.register_uid ext.ext_type.ext_uid ext.ext_loc; + Shape.Map.add_extcons shape_map ext.ext_id ext.ext_type.ext_uid + ) shape_map constructors + in + (Tstr_typext tyext, + map_ext + (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported)) + constructors [], + shape_map, + 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; + Env.register_uid + constructor.ext_type.ext_uid + constructor.ext_loc; + Tstr_exception ext, + [Sig_typext(constructor.ext_id, + constructor.ext_type, + Text_exception, + Exported)], + Shape.Map.add_extcons shape_map + constructor.ext_id + constructor.ext_type.ext_uid, + 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, md_shape = + 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 + let md_shape = Shape.set_uid_if_none md_shape md_uid in + Env.register_uid md_uid pmb_loc; + (*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 ~shape:md_shape 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 + let shape_map = match id with + | Some id -> Shape.Map.add_module shape_map id md_shape + | None -> shape_map + in + Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; + mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; }, + sg, + shape_map, + 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, _prev_shape) + (name, _, smodl, attrs, loc) -> + let modl, shape = + 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, shape, uid)) + decls sbind in + let newenv = (* allow aliasing recursive modules from outside *) + List.fold_left + (fun env (id_opt, _, mty, _, _, attrs, loc, shape, uid) -> + match id_opt with + | None -> env + | Some id -> + let mdecl = + { + md_type = mty.mty_type; + md_attributes = attrs; + md_loc = loc; + md_uid = uid; + } + in + Env.add_module_declaration ~check:true ~shape + id Mp_present mdecl env + ) + env bindings1 + in + let bindings2 = + check_recmodule_inclusion newenv bindings1 in + let mbs = + List.filter_map (fun (mb, shape, uid) -> + Option.map (fun id -> id, mb, uid, shape) mb.mb_id + ) bindings2 + in + let shape_map = + List.fold_left (fun map (id, mb, uid, shape) -> + Env.register_uid uid mb.mb_loc; + Shape.Map.add_module map id shape + ) shape_map mbs + in + Tstr_recmodule (List.map (fun (mb, _, _) -> mb) bindings2), + map_rec (fun rs (id, mb, uid, _shape) -> + 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 [], + shape_map, + newenv + | Pstr_modtype pmtd -> + (* check that it is non-abstract *) + let newenv, mtd, decl = transl_modtype_decl env pmtd in + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + Env.register_uid decl.mtd_uid decl.mtd_loc; + let id = mtd.mtd_id in + let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in + Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv + | Pstr_open sod -> + let (od, sg, newenv) = + type_open_decl ~toplevel funct_body names env sod + in + Tstr_open od, sg, shape_map, newenv + | Pstr_class cl -> + let (classes, new_env) = Typeclass.class_declarations env cl in + let shape_map = List.fold_left (fun acc 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; + Env.register_uid cls.cls_decl.cty_uid loc; + let map f id acc = f acc id cls.cls_decl.cty_uid in + map Shape.Map.add_class cls.cls_id acc + |> map Shape.Map.add_class_type cls.cls_ty_id + |> map Shape.Map.add_type cls.cls_obj_id + ) shape_map classes + in + 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) + ]) + classes []), + shape_map, + new_env + | Pstr_class_type cl -> + let (classes, new_env) = Typeclass.class_type_declarations env cl in + let shape_map = List.fold_left (fun acc 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; + Env.register_uid decl.clsty_ty_decl.clty_uid loc; + let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in + map Shape.Map.add_class_type decl.clsty_ty_id acc + |> map Shape.Map.add_type decl.clsty_obj_id + ) shape_map classes + in + 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); + ]) + classes []), + shape_map, + new_env + | Pstr_include sincl -> + let smodl = sincl.pincl_mod in + let modl, modl_shape = + 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, shape, new_env = + Env.enter_signature_and_shape ~scope ~parent_shape:shape_map + modl_shape (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, shape, 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, [], shape_map, env + in + let rec type_struct env shape_map sstr = + match sstr with + | [] -> ([], [], shape_map, env) + | pstr :: srem -> + let previous_saved_types = Cmt_format.get_saved_types () in + let desc, sg, shape_map, new_env = type_str_item env shape_map 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, shape_map, final_env) = + type_struct new_env shape_map srem + in + (str :: str_rem, sg @ sig_rem, shape_map, final_env) + in + let previous_saved_types = Cmt_format.get_saved_types () in + let run () = + let (items, sg, shape_map, final_env) = + type_struct env Shape.Map.empty 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, Shape.str shape_map, final_env + in + if toplevel then run () + else Builtin_attributes.warning_scope [] run + +let type_toplevel_phrase env s = + Env.reset_required_globals (); + type_structure ~toplevel:true false None env s + +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 } + | _ -> + let me, _shape = type_module env smod in + me + in + let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in + (* PR#5036: must not contain non-generalized type variables *) + check_nongen_modtype env smod.pmod_loc 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 *) + let modl, scope = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + (* type the module and create a scope in a raised level *) + Ctype.with_local_level begin fun () -> + let modl, _mod_shape = type_module env m in + let scope = Ctype.create_scope () in + modl, scope + end + end + in + 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 + 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_package 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, shape, finalenv) = + type_structure initial_env ast in + let shape = + Shape.set_uid_if_none shape + (Uid.of_compilation_unit_id (Ident.create_persistent modulename)) + in + let simple_sg = Signature_names.simplify finalenv names sg in + if !Clflags.print_types then begin + Typecore.force_delayed_checks (); + let shape = Shape.local_reduce shape in + 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; + shape; + signature = simple_sg + } (* result is ignored by Compile.implementation *) + end else begin + let sourceintf = + Filename.remove_extension sourcefile ^ !Config.interface_suffix in + if !Clflags.cmi_file <> None || Sys.file_exists sourceintf then begin + let intf_file = + match !Clflags.cmi_file with + | None -> + (try + Load_path.find_uncap (modulename ^ ".cmi") + with Not_found -> + raise(Error(Location.in_file sourcefile, Env.empty, + Interface_not_compiled sourceintf))) + | Some cmi_file -> cmi_file + in + let dclsig = Env.read_signature modulename intf_file in + let coercion, shape = + Includemod.compunit initial_env ~mark:Mark_positive + sourcefile sg intf_file dclsig shape + 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 shape = Shape.local_reduce shape in + let annots = Cmt_format.Implementation str in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + annots (Some sourcefile) initial_env None (Some shape); + gen_annot outputprefix sourcefile annots; + { structure = str; + coercion; + shape; + signature = dclsig + } + end else begin + Location.prerr_warning (Location.in_file sourcefile) + Warnings.Missing_mli; + let coercion, shape = + Includemod.compunit initial_env ~mark:Mark_positive + sourcefile sg "(inferred signature)" simple_sg shape + in + check_nongen_signature finalenv simple_sg; + normalize_signature simple_sg; + Typecore.force_delayed_checks (); + (* See comment above. Here the target signature contains all + the values 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. *) + let shape = Shape.local_reduce shape in + 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) (Some shape); + gen_annot outputprefix sourcefile annots + end; + { structure = str; + coercion; + shape; + 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 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) None + +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 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 + (* Compute the shape of the package *) + let prefix = Filename.remove_extension cmifile in + let pack_uid = Uid.of_compilation_unit_id (Ident.create_persistent prefix) in + let shape = + List.fold_left (fun map (name, _sg) -> + let id = Ident.create_persistent name in + Shape.Map.add_module map id (Shape.for_persistent_unit name) + ) Shape.Map.empty units + |> Shape.str ~uid:pack_uid + in + (* See if explicit interface is provided *) + 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 + let cc, _shape = + Includemod.compunit initial_env ~mark:Mark_both + "(obtained by packing)" sg mlifile dclsig shape + in + Cmt_format.save_cmt (prefix ^ ".cmt") modulename + (Cmt_format.Packed (sg, objfiles)) None initial_env None (Some shape); + cc + 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) (Some shape); + 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 "@[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 + "@[\ + @[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 + "@[\ + @[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 + "@[\ + @[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 + "@[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 { vars; expression } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + prepare_for_printing vars; + add_type_to_preparation expression; + Location.errorf ~loc + "@[The type of this expression,@ %a,@ \ + contains the non-generalizable type variable(s): %a.@ %a@]" + prepared_type_scheme expression + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + prepared_type_scheme) vars + Misc.print_see_manual manual_ref + | Non_generalizable_module { vars; mty; item } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + prepare_for_printing vars; + add_type_to_preparation item.val_type; + let sub = + [ Location.msg ~loc:item.val_loc + "The type of this value,@ %a,@ \ + contains the non-generalizable type variable(s) %a." + prepared_type_scheme + item.val_type + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + prepared_type_scheme) vars + ] + in + Location.errorf ~loc ~sub + "@[The type of this module,@ %a,@ \ + contains non-generalizable type variable(s).@ %a@]" + modtype mty + Misc.print_see_manual manual_ref + | 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 = + Printtyp.namespaced_ident shadowed_item_kind shadowed_item_id + in + let shadower = + Printtyp.namespaced_ident shadowed_item_kind shadower_id + in + let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in + let shadowed_msg = + Location.msg ~loc:shadowed_item_loc + "@[%s %s came from this include.@]" + (String.capitalize_ascii shadowed_item_kind) + shadowed + in + let user_msg = + Location.msg ~loc:user_loc + "@[The %s %s has no valid type@ if %s is shadowed.@]" + (Sig_component_kind.to_string user_kind) (Ident.name user_id) + shadowed + in + Location.errorf ~loc ~sub:[shadowed_msg; user_msg] + "Illegal shadowing of included %s %s@ by %s." + shadowed_item_kind shadowed shadower + | 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 + let opened_id = Ident.name opened_item_id in + let user_msg = + Location.msg ~loc:user_loc + "@[The %s %s has no valid type@ if %s is hidden.@]" + (Sig_component_kind.to_string user_kind) (Ident.name user_id) + opened_id + in + Location.errorf ~loc ~sub:[user_msg] + "The %s %s introduced by this open appears in the signature." + opened_item_kind opened_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_501/typing/typemod.mli b/upstream/ocaml_501/typing/typemod.mli new file mode 100644 index 0000000000..859c2e9b3d --- /dev/null +++ b/upstream/ocaml_501/typing/typemod.mli @@ -0,0 +1,141 @@ +(**************************************************************************) +(* *) +(* 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 * Shape.t +val type_structure: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Signature_names.t * Shape.t * + Env.t +val type_toplevel_phrase: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Signature_names.t * Shape.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_signature: + 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 -> + 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 { vars : type_expr list; expression : type_expr } + | Non_generalizable_module of + { vars : type_expr list; item : value_description; mty : 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_501/typing/typeopt.ml b/upstream/ocaml_501/typing/typeopt.ml new file mode 100644 index 0000000000..0015252bc4 --- /dev/null +++ b/upstream/ocaml_501/typing/typeopt.ml @@ -0,0 +1,231 @@ +(**************************************************************************) +(* *) +(* 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 = + match get_desc ty with + | Tconstr _ -> + let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in + begin match get_desc ty with + | Tconstr (p, _, _) -> + begin match Env.find_type p env with + | {type_kind = ( Type_variant (_, Variant_unboxed) + | Type_record (_, Record_unboxed _) ); _} -> begin + match Typedecl_unboxed.get_unboxed_type_representation env ty with + | None -> ty + | Some ty2 -> ty2 + end + | _ -> ty + | exception Not_found -> ty + end + | _ -> + ty + end + | _ -> ty + +let scrape env ty = + get_desc (scrape_ty env ty) + +let scrape_poly env ty = + let ty = scrape_ty env ty in + match get_desc ty with + | Tpoly (ty, _) -> get_desc ty + | d -> d + +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 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 maybe_pointer_type env ty = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Immediate + else Pointer + +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 get_desc ty 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_poly env ty with + | 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, [], _) 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 = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Pintval + else begin + match get_desc ty with + | 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 + end + +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_501/typing/typeopt.mli b/upstream/ocaml_501/typing/typeopt.mli new file mode 100644 index 0000000000..0f6b9f373f --- /dev/null +++ b/upstream/ocaml_501/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_501/typing/types.ml b/upstream/ocaml_501/typing/types.ml new file mode 100644 index 0000000000..45a4f896d6 --- /dev/null +++ b/upstream/ocaml_501/typing/types.ml @@ -0,0 +1,897 @@ +(**************************************************************************) +(* *) +(* 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 transient_expr = + { mutable desc: type_desc; + mutable level: int; + mutable scope: int; + id: int } + +and type_expr = transient_expr + +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_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 = [`some] row_field_gen +and _ row_field_gen = + RFpresent : type_expr option -> [> `some] row_field_gen + | RFeither : + { no_arg: bool; + arg_type: type_expr list; + matched: bool; + ext: [`some | `none] row_field_gen ref} -> [> `some] row_field_gen + | RFabsent : [> `some] row_field_gen + | RFnone : [> `none] row_field_gen + +and abbrev_memo = + Mnil + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo + | Mlink of abbrev_memo ref + +and any = [`some | `none | `var] +and field_kind = [`some|`var] field_kind_gen +and _ field_kind_gen = + FKvar : {mutable field_kind: any field_kind_gen} -> [> `var] field_kind_gen + | FKprivate : [> `none] field_kind_gen (* private method; only under FKvar *) + | FKpublic : [> `some] field_kind_gen (* public method *) + | FKabsent : [> `some] field_kind_gen (* hidden private method *) + +and commutable = [`some|`var] commutable_gen +and _ commutable_gen = + Cok : [> `some] commutable_gen + | Cunknown : [> `none] commutable_gen + | Cvar : {mutable commu: any commutable_gen} -> [> `var] commutable_gen + +module TransientTypeOps = 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 = Shape.Uid + +(* Maps of methods and instance variables *) + +module MethSet = Misc.Stdlib.String.Set +module VarSet = Misc.Stdlib.String.Set + +module Meths = Misc.Stdlib.String.Map +module Vars = Misc.Stdlib.String.Map + + +(* 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 + class_signature * self_meths * Ident.t Vars.t * string + (* Self *) + | Val_anc of class_signature * Ident.t Meths.t * string + (* Ancestor *) + +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + +(* Variance *) +(* Variance forms a product lattice of the following partial orders: + 0 <= may_pos <= pos + 0 <= may_weak <= may_neg <= neg + 0 <= inj + Additionally, the following implications are valid + pos => inj + neg => inj + Examples: + type 'a t : may_pos + may_neg + may_weak + type 'a t = 'a : pos + type 'a t = 'a -> unit : neg + type 'a t = ('a -> unit) -> unit : pos + may_weak + type 'a t = A of (('a -> unit) -> unit) : pos + type +'a p = .. : may_pos + inj + type +!'a t : may_pos + inj + type -!'a t : may_neg + inj + type 'a t = A : inj + *) + +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 + 4 + | May_weak -> 4 + | Inj -> 8 + | Pos -> 16 + 8 + 1 + | Neg -> 32 + 8 + 4 + 2 + | Inv -> 63 + 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 v = union v (single x) + let set_if b x v = if b then set x v else v + let mem x = subset (single x) + let null = 0 + let unknown = 7 + let full = single Inv + let covariant = single Pos + let swap f1 f2 v v' = + set_if (mem f2 v) f1 (set_if (mem f1 v) f2 v') + let conjugate v = + let v' = inter v (union (single Inj) (single May_weak)) in + swap Pos Neg v (swap May_pos May_neg v v') + let compose v1 v2 = + if mem Inv v1 && mem Inj v2 then full else + let mp = + mem May_pos v1 && mem May_pos v2 || mem May_neg v1 && mem May_neg v2 + and mn = + mem May_pos v1 && mem May_neg v2 || mem May_pos v1 && mem May_neg v2 + and mw = mem May_weak v1 && v2 <> null || v1 <> null && mem May_weak v2 + and inj = mem Inj v1 && mem Inj v2 + and pos = mem Pos v1 && mem Pos v2 || mem Neg v1 && mem Neg v2 + and neg = mem Pos v1 && mem Neg v2 || mem Neg v1 && mem Pos v2 in + List.fold_left (fun v (b,f) -> set_if b f v) null + [mp, May_pos; mn, May_neg; mw, May_weak; inj, Inj; pos, Pos; neg, Neg] + let strengthen v = + if mem May_neg v then v else v land (full - single May_weak) + let get_upper v = (mem May_pos v, mem May_neg v) + let get_lower v = (mem Pos v, mem Neg v, mem Inj v) + let unknown_signature ~injective ~arity = + let v = if injective then set Inj 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 *) + +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 + +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_hash_type: type_declaration; + 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_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) + +let item_visibility = function + | Sig_value (_, _, vis) + | Sig_type (_, _, _, vis) + | Sig_typext (_, _, _, vis) + | Sig_module (_, _, _, _, vis) + | Sig_modtype (_, _, vis) + | Sig_class (_, _, _, vis) + | Sig_class_type (_, _, _, vis) -> vis + +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 + +(**** 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 [`none|`some] row_field_gen ref + | Ckind of [`var] field_kind_gen + | Ccommu of [`var] commutable_gen + | Cuniv of type_expr option ref * type_expr option + +type changes = + Change of change * changes ref + | Unchanged + | Invalid + +let trail = Local_store.s_table ref Unchanged + +let log_change ch = + let r' = ref Unchanged in + !trail := Change (ch, r'); + trail := r' + +(* constructor and accessors for [field_kind] *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +let rec field_kind_internal_repr : field_kind -> field_kind = function + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as fk} -> + field_kind_internal_repr fk + | kind -> kind + +let field_kind_repr fk = + match field_kind_internal_repr fk with + | FKvar _ -> Fprivate + | FKpublic -> Fpublic + | FKabsent -> Fabsent + +let field_public = FKpublic +let field_absent = FKabsent +let field_private () = FKvar {field_kind=FKprivate} + +(* Constructor and accessors for [commutable] *) + +let rec is_commu_ok : type a. a commutable_gen -> bool = function + | Cvar {commu} -> is_commu_ok commu + | Cunknown -> false + | Cok -> true + +let commu_ok = Cok +let commu_var () = Cvar {commu=Cunknown} + +(**** Representative of a type ****) + +let rec repr_link (t : type_expr) d : type_expr -> type_expr = + function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> + log_change (Ccompress (t, t.desc, d)); + t.desc <- d; + t' + +let repr_link1 t = function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> t' + +let repr t = + match t.desc with + Tlink t' -> + repr_link1 t t' + | Tfield (_, k, _, t') when field_kind_internal_repr k = FKabsent -> + repr_link1 t t' + | _ -> t + +(* getters for type_expr *) + +let get_desc t = (repr t).desc +let get_level t = (repr t).level +let get_scope t = (repr t).scope +let get_id t = (repr t).id + +(* transient type_expr *) + +module Transient_expr = struct + let create desc ~level ~scope ~id = {desc; level; scope; id} + let set_desc ty d = ty.desc <- d + let set_stub_desc ty d = assert (ty.desc = Tvar None); ty.desc <- d + let set_level ty lv = ty.level <- lv + let set_scope ty sc = ty.scope <- sc + let coerce ty = ty + let repr = repr + let type_expr ty = ty +end + +(* Comparison for [type_expr]; cannot be used for functors *) + +let eq_type t1 t2 = t1 == t2 || repr t1 == repr t2 +let compare_type t1 t2 = compare (get_id t1) (get_id t2) + +(* Constructor and accessors for [row_desc] *) + +let create_row ~fields ~more ~closed ~fixed ~name = + { row_fields=fields; row_more=more; + row_closed=closed; row_fixed=fixed; row_name=name } + +(* [row_fields] subsumes the original [row_repr] *) +let rec row_fields row = + match get_desc row.row_more with + | Tvariant row' -> + row.row_fields @ row_fields row' + | _ -> + row.row_fields + +let rec row_repr_no_fields row = + match get_desc row.row_more with + | Tvariant row' -> row_repr_no_fields row' + | _ -> row + +let row_more row = (row_repr_no_fields row).row_more +let row_closed row = (row_repr_no_fields row).row_closed +let row_fixed row = (row_repr_no_fields row).row_fixed +let row_name row = (row_repr_no_fields row).row_name + +let rec get_row_field tag row = + let rec find = function + | (tag',f) :: fields -> + if tag = tag' then f else find fields + | [] -> + match get_desc row.row_more with + | Tvariant row' -> get_row_field tag row' + | _ -> RFabsent + in find row.row_fields + +let set_row_name row row_name = + let row_fields = row_fields row in + let row = row_repr_no_fields row in + {row with row_fields; row_name} + +type row_desc_repr = + Row of { fields: (label * row_field) list; + more:type_expr; + closed:bool; + fixed:fixed_explanation option; + name:(Path.t * type_expr list) option } + +let row_repr row = + let fields = row_fields row in + let row = row_repr_no_fields row in + Row { fields; + more = row.row_more; + closed = row.row_closed; + fixed = row.row_fixed; + name = row.row_name } + +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +let rec row_field_repr_aux tl : row_field -> row_field = function + | RFeither ({ext = {contents = RFnone}} as r) -> + RFeither {r with arg_type = tl@r.arg_type} + | RFeither {arg_type; + ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_repr_aux (tl@arg_type) rf + | RFpresent (Some _) when tl <> [] -> + RFpresent (Some (List.hd tl)) + | RFpresent _ as rf -> rf + | RFabsent -> RFabsent + +let row_field_repr fi = + match row_field_repr_aux [] fi with + | RFeither {no_arg; arg_type; matched} -> Reither (no_arg, arg_type, matched) + | RFpresent t -> Rpresent t + | RFabsent -> Rabsent + +let rec row_field_ext (fi : row_field) = + match fi with + | RFeither {ext = {contents = RFnone} as ext} -> ext + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_ext rf + | _ -> Misc.fatal_error "Types.row_field_ext " + +let rf_present oty = RFpresent oty +let rf_absent = RFabsent +let rf_either ?use_ext_of ~no_arg arg_type ~matched = + let ext = + match use_ext_of with + Some rf -> row_field_ext rf + | None -> ref RFnone + in + RFeither {no_arg; arg_type; matched; ext} + +let rf_either_of = function + | None -> + RFeither {no_arg=true; arg_type=[]; matched=false; ext=ref RFnone} + | Some ty -> + RFeither {no_arg=false; arg_type=[ty]; matched=false; ext=ref RFnone} + +let eq_row_field_ext rf1 rf2 = + row_field_ext rf1 == row_field_ext rf2 + +let changed_row_field_exts l f = + let exts = List.map row_field_ext l in + f (); + List.exists (fun r -> !r <> RFnone) exts + +let match_row_field ~present ~absent ~either (f : row_field) = + match f with + | RFabsent -> absent () + | RFpresent t -> present t + | RFeither {no_arg; arg_type; matched; ext} -> + let e : row_field option = + match !ext with + | RFnone -> None + | RFeither _ | RFpresent _ | RFabsent as e -> Some e + in + either no_arg arg_type matched e + + +(**** Some type creators ****) + +let new_id = Local_store.s_ref (-1) + +let create_expr = Transient_expr.create + +let newty3 ~level ~scope desc = + incr new_id; + create_expr desc ~level ~scope ~id:!new_id + +let newty2 ~level desc = + newty3 ~level ~scope:Ident.lowest_scope desc + + (**********************************) + (* Utilities for backtracking *) + (**********************************) + +let undo_change = function + Ctype (ty, desc) -> Transient_expr.set_desc ty desc + | Ccompress (ty, desc, _) -> Transient_expr.set_desc ty desc + | Clevel (ty, level) -> Transient_expr.set_level ty level + | Cscope (ty, scope) -> Transient_expr.set_scope ty scope + | Cname (r, v) -> r := v + | Crow r -> r := RFnone + | Ckind (FKvar r) -> r.field_kind <- FKprivate + | Ccommu (Cvar r) -> r.commu <- Cunknown + | Cuniv (r, v) -> r := v + +type snapshot = changes ref * int +let last_snapshot = Local_store.s_ref 0 + +let log_type ty = + if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) +let link_type ty ty' = + let ty = repr ty in + let ty' = repr ty' in + if ty == ty' then () else begin + log_type ty; + let desc = ty.desc in + Transient_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'; Transient_expr.set_desc ty' (Tvar name) + | None, Some _ -> () + | Some _, Some _ -> + if ty.level < ty'.level then + (log_type ty'; Transient_expr.set_desc ty' (Tvar name)) + | None, None -> () + end + | _ -> () + 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 = + let ty = repr ty in + if td != ty.desc then begin + log_type ty; + Transient_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 = + let ty = repr ty in + if level <> ty.level then begin + if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); + Transient_expr.set_level ty level + end +(* TODO: introduce a guard and rename it to set_higher_scope? *) +let set_scope ty scope = + let ty = repr ty in + if scope <> ty.scope then begin + if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); + Transient_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 rec link_row_field_ext ~(inside : row_field) (v : row_field) = + match inside with + | RFeither {ext = {contents = RFnone} as e} -> + let RFeither _ | RFpresent _ | RFabsent as v = v in + log_change (Crow e); e := v + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + link_row_field_ext ~inside:rf v + | _ -> invalid_arg "Types.link_row_field_ext" + +let rec link_kind ~(inside : field_kind) (k : field_kind) = + match inside with + | FKvar ({field_kind = FKprivate} as rk) as inside -> + (* prevent a loop by normalizing k and comparing it with inside *) + let FKvar _ | FKpublic | FKabsent as k = field_kind_internal_repr k in + if k != inside then begin + log_change (Ckind inside); + rk.field_kind <- k + end + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as inside} -> + link_kind ~inside k + | _ -> invalid_arg "Types.link_kind" + +let rec commu_repr : commutable -> commutable = function + | Cvar {commu = Cvar _ | Cok as commu} -> commu_repr commu + | c -> c + +let rec link_commu ~(inside : commutable) (c : commutable) = + match inside with + | Cvar ({commu = Cunknown} as rc) as inside -> + (* prevent a loop by normalizing c and comparing it with inside *) + let Cvar _ | Cok as c = commu_repr c in + if c != inside then begin + log_change (Ccommu inside); + rc.commu <- c + end + | Cvar {commu = Cvar _ | Cok as inside} -> + link_commu ~inside c + | _ -> invalid_arg "Types.link_commu" + +let set_commu_ok c = link_commu ~inside:c Cok + +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 ~cleanup_abbrev (changes, old) = + match !changes with + Unchanged -> last_snapshot := old + | Invalid -> failwith "Types.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 undo_first_change_after (changes, _) = + match !changes with + | Change (ch, _) -> + undo_change ch + | _ -> () + +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 -> + Transient_expr.set_desc ty desc; r := !next + | _ -> ()) + log diff --git a/upstream/ocaml_501/typing/types.mli b/upstream/ocaml_501/typing/types.mli new file mode 100644 index 0000000000..d2db385ca4 --- /dev/null +++ b/upstream/ocaml_501/typing/types.mli @@ -0,0 +1,730 @@ +(**************************************************************************) +(* *) +(* 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 +type row_desc +type row_field +type field_kind +type commutable + +type 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", field_public, 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). *) + +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 *) + +(** [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 *) + +(** [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 [commu_ok] arrows, otherwise as + [commu_var ()]. + + 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 must rely on [is_commu_ok] arrows, + otherwise they 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. +*) + +val is_commu_ok: commutable -> bool +val commu_ok: commutable +val commu_var: unit -> commutable + +(** [field_kind] indicates the accessibility of a method. + + An [Fprivate] field may become [Fpublic] or [Fabsent] during unification, + but not the other way round. + + The same [field_kind] is kept shared when copying [Tfield] nodes + so that the copies of the self-type of a class share the same accessibility + (see also PR#10539). + *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +val field_kind_repr: field_kind -> field_kind_view +val field_public: field_kind +val field_absent: field_kind +val field_private: unit -> field_kind +val field_kind_internal_repr: field_kind -> field_kind + (* Removes indirections in [field_kind]. + Only needed for performance. *) + +(** Getters for type_expr; calls repr before answering a value *) + +val get_desc: type_expr -> type_desc +val get_level: type_expr -> int +val get_scope: type_expr -> int +val get_id: type_expr -> int + +(** Transient [type_expr]. + Should only be used immediately after [Transient_expr.repr] *) +type transient_expr = private + { mutable desc: type_desc; + mutable level: int; + mutable scope: int; + id: int } + +module Transient_expr : sig + (** Operations on [transient_expr] *) + + val create: type_desc -> level: int -> scope: int -> id: int -> transient_expr + val set_desc: transient_expr -> type_desc -> unit + val set_level: transient_expr -> int -> unit + val set_scope: transient_expr -> int -> unit + val repr: type_expr -> transient_expr + val type_expr: transient_expr -> type_expr + val coerce: type_expr -> transient_expr + (** Coerce without normalizing with [repr] *) + + val set_stub_desc: type_expr -> type_desc -> unit + (** Instantiate a not yet instantiated stub. + Fail if already instantiated. *) +end + +val create_expr: type_desc -> level: int -> scope: int -> id: int -> type_expr + +(** Functions and definitions moved from Btype *) + +val newty3: level:int -> scope:int -> type_desc -> type_expr + (** Create a type with a fresh id *) + +val newty2: level:int -> type_desc -> type_expr + (** Create a type with a fresh id and no scope *) + +module TransientTypeOps : sig + (** Comparisons for functors *) + + type t = transient_expr + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +(** Comparisons for [type_expr]; cannot be used for functors *) + +val eq_type: type_expr -> type_expr -> bool +val compare_type: type_expr -> type_expr -> int + +(** Constructor and accessors for [row_desc] *) + +(** [ `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 = _; + _ }; + _ }; + _ + } + +*) + +val create_row: + fields:(label * row_field) list -> + more:type_expr -> + closed:bool -> + fixed:fixed_explanation option -> + name:(Path.t * type_expr list) option -> row_desc + +val row_fields: row_desc -> (label * row_field) list +val row_more: row_desc -> type_expr +val row_closed: row_desc -> bool +val row_fixed: row_desc -> fixed_explanation option +val row_name: row_desc -> (Path.t * type_expr list) option + +val set_row_name: row_desc -> (Path.t * type_expr list) option -> row_desc + +val get_row_field: label -> row_desc -> row_field + +(** get all fields at once; different from the old [row_repr] *) +type row_desc_repr = + Row of { fields: (label * row_field) list; + more: type_expr; + closed: bool; + fixed: fixed_explanation option; + name: (Path.t * type_expr list) option } + +val row_repr: row_desc -> row_desc_repr + +(** Current contents of a row field *) +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +val row_field_repr: row_field -> row_field_view +val rf_present: type_expr option -> row_field +val rf_absent: row_field +val rf_either: + ?use_ext_of:row_field -> + no_arg:bool -> type_expr list -> matched:bool -> row_field +val rf_either_of: type_expr option -> row_field + +val eq_row_field_ext: row_field -> row_field -> bool +val changed_row_field_exts: row_field list -> (unit -> unit) -> bool + +val match_row_field: + present:(type_expr option -> 'a) -> + absent:(unit -> 'a) -> + either:(bool -> type_expr list -> bool -> row_field option ->'a) -> + row_field -> 'a + +(* *) + +module Uid = Shape.Uid + +(* Sets and maps of methods and instance variables *) + +module MethSet : Set.S with type elt = string +module VarSet : Set.S with type elt = string + +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 class_signature * self_meths * Ident.t Vars.t * string + (* Self *) + | Val_anc of class_signature * Ident.t Meths.t * string + (* Ancestor *) + +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + (* The [field_kind] is always [Fabsent] in a complete class type. *) + +(* 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 -> t -> t + val set_if : bool -> f -> t -> t + val mem : f -> t -> bool + val conjugate : t -> t (* exchange positive and negative *) + val compose : t -> t -> t + val strengthen : t -> t (* remove May_weak when possible *) + val get_upper : t -> bool * bool (* may_pos, may_neg *) + val get_lower : t -> bool * bool * bool (* pos, neg, 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 *) + (* The argument is the path of the 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 *) + +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 + +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_hash_type: type_declaration; (* object type with an open row *) + 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 + +val item_visibility : signature_item -> visibility + +(* 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_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 + +(**** Utilities for backtracking ****) + +type snapshot + (* A snapshot for backtracking *) +val snapshot: unit -> snapshot + (* Make a snapshot for later backtracking. Costs nothing *) +val backtrack: cleanup_abbrev:(unit -> unit) -> 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_first_change_after: snapshot -> unit + (* Backtrack only the first change after a snapshot. + Does not update the list of changes *) +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?). + The old values are logged and reverted on backtracking. + *) + +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 link_row_field_ext: inside:row_field -> row_field -> unit + (* Extract the extension variable of [inside] and set it to the + second argument *) +val set_univar: type_expr option ref -> type_expr -> unit +val link_kind: inside:field_kind -> field_kind -> unit +val link_commu: inside:commutable -> commutable -> unit +val set_commu_ok: commutable -> unit diff --git a/upstream/ocaml_501/typing/typetexp.ml b/upstream/ocaml_501/typing/typetexp.ml new file mode 100644 index 0000000000..65f5c7b367 --- /dev/null +++ b/upstream/ocaml_501/typing/typetexp.ml @@ -0,0 +1,965 @@ +(**************************************************************************) +(* *) +(* 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 * string list + | No_type_wildcards + | 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_error + | Alias_type_mismatch of Errortrace.unification_error + | 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 + +module TyVarEnv : sig + val reset : unit -> unit + (* see mli file *) + + val is_in_scope : string -> bool + + val add : string -> type_expr -> unit + (* add a global type variable to the environment *) + + val with_local_scope : (unit -> 'a) -> 'a + (* see mli file *) + + type poly_univars + val with_univars : poly_univars -> (unit -> 'a) -> 'a + (* evaluate with a locally extended set of univars *) + + val make_poly_univars : string list -> poly_univars + (* see mli file *) + + val check_poly_univars : Env.t -> Location.t -> poly_univars -> type_expr list + (* see mli file *) + + val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (* see mli file *) + + type policy + val fixed_policy : policy (* no wildcards allowed *) + val extensible_policy : policy (* common case *) + val univars_policy : policy (* fresh variables are univars (in methods) *) + val new_any_var : Location.t -> Env.t -> policy -> type_expr + (* create a new variable to represent a _; fails for fixed_policy *) + val new_var : ?name:string -> policy -> type_expr + (* create a new variable according to the given policy *) + + val add_pre_univar : type_expr -> policy -> unit + (* remember that a variable might become a univar if it isn't unified; + used for checking method types *) + + val collect_univars : (unit -> 'a) -> 'a * type_expr list + (* collect univars during a computation; returns the univars. + The wrapped computation should use [univars_policy]. + postcondition: the returned type_exprs are all Tunivar *) + + val reset_locals : ?univars:poly_univars -> unit -> unit + (* clear out the local type variable env't; call this when starting + a new e.g. type signature. Optionally pass some univars that + are in scope. *) + + val lookup_local : + row_context:type_expr option ref list -> string -> type_expr + (* look up a local type variable; throws Not_found if it isn't in scope *) + + val remember_used : string -> type_expr -> Location.t -> unit + (* remember that a given name is bound to a given type *) + + val globalize_used_variables : policy -> Env.t -> unit -> unit + (* after finishing with a type signature, used variables are unified to the + corresponding global type variables if they exist. Otherwise, in function + of the policy, fresh used variables are either + - added to the global type variable scope if they are not longer + variables under the {!fixed_policy} + - added to the global type variable scope under the {!extensible_policy} + - expected to be collected later by a call to `collect_univar` under the + {!universal_policy} + *) + +end = struct + (** Map indexed by type variable names. *) + module TyVarMap = Misc.Stdlib.String.Map + + let not_generic v = get_level v <> Btype.generic_level + + (* These are the "global" type variables: they were in scope before + we started processing the current type. + *) + let type_variables = ref (TyVarMap.empty : type_expr TyVarMap.t) + + (* These are variables that have been used in the currently-being-checked + type. + *) + let used_variables = + ref (TyVarMap.empty : (type_expr * Location.t) TyVarMap.t) + + (* These are variables we expect to become univars (they were introduced with + e.g. ['a .]), but we need to make sure they don't unify first. Why not + just birth them as univars? Because they might successfully unify with a + row variable in the ['a. < m : ty; .. > as 'a] idiom. They are like the + [used_variables], but will not be globalized in [globalize_used_variables]. + *) + type pending_univar = { + univar: type_expr (** the univar itself *); + mutable associated: type_expr option ref list + (** associated references to row variables that we want to generalize + if possible *) + } + + let univars = ref ([] : (string * pending_univar) list) + let assert_univars uvs = + assert (List.for_all (fun (_name, v) -> not_generic v.univar) uvs) + + (* These are variables that will become univars when we're done with the + current type. Used to force free variables in method types to become + univars. + *) + let pre_univars = ref ([] : type_expr list) + + let reset () = + reset_global_level (); + type_variables := TyVarMap.empty + + let is_in_scope name = + TyVarMap.mem name !type_variables + + let add name v = + assert (not_generic v); + type_variables := TyVarMap.add name v !type_variables + + let narrow () = + (increase_global_level (), !type_variables) + + let widen (gl, tv) = + restore_global_level gl; + type_variables := tv + + let with_local_scope f = + let context = narrow () in + Fun.protect + f + ~finally:(fun () -> widen context) + + (* throws Not_found if the variable is not in scope *) + let lookup_global_type_variable name = + TyVarMap.find name !type_variables + + let get_in_scope_names () = + let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in + TyVarMap.fold add_name !type_variables [] + + (*****) + type poly_univars = (string * pending_univar) list + + let with_univars new_ones f = + assert_univars new_ones; + let old_univars = !univars in + univars := new_ones @ !univars; + Fun.protect + f + ~finally:(fun () -> univars := old_univars) + + let make_poly_univars vars = + let make name = { univar=newvar ~name (); associated = [] } in + List.map (fun name -> name, make name ) vars + + let promote_generics_to_univars promoted vars = + List.fold_left + (fun acc v -> + match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name); + v :: acc + | _ -> acc + ) + promoted vars + + let check_poly_univars env loc vars = + vars |> List.iter (fun (_, p) -> generalize p.univar); + let univars = + vars |> List.map (fun (name, {univar=ty1; _ }) -> + let v = Btype.proxy ty1 in + begin match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name) + | _ -> + raise (Error (loc, env, Cannot_quantify(name, v))) + end; + v) + in + (* Since we are promoting variables to univars in + {!promote_generics_to_univars}, even if a row variable is associated with + multiple univars we will promote it once, when checking the nearest + univar associated to this row variable. + *) + let promote_associated acc (_,v) = + let enclosed_rows = List.filter_map (!) v.associated in + promote_generics_to_univars acc enclosed_rows + in + List.fold_left promote_associated univars vars + + let instance_poly_univars env loc vars = + let vs = check_poly_univars env loc vars in + vs |> List.iter (fun v -> + match get_desc v with + | Tunivar name -> + set_type_desc v (Tvar name) + | _ -> assert false); + vs + + (*****) + let reset_locals ?univars:(uvs=[]) () = + assert_univars uvs; + univars := uvs; + used_variables := TyVarMap.empty + + let associate row_context p = + let add l x = if List.memq x l then l else x :: l in + p.associated <- List.fold_left add row_context p.associated + + (* throws Not_found if the variable is not in scope *) + let lookup_local ~row_context name = + try + let p = List.assoc name !univars in + associate row_context p; + p.univar + with Not_found -> + instance (fst (TyVarMap.find name !used_variables)) + (* This call to instance might be redundant; all variables + inserted into [used_variables] are non-generic, but some + might get generalized. *) + + let remember_used name v loc = + assert (not_generic v); + used_variables := TyVarMap.add name (v, loc) !used_variables + + + type flavor = Unification | Universal + type extensibility = Extensible | Fixed + type policy = { flavor : flavor; extensibility : extensibility } + + let fixed_policy = { flavor = Unification; extensibility = Fixed } + let extensible_policy = { flavor = Unification; extensibility = Extensible } + let univars_policy = { flavor = Universal; extensibility = Extensible } + + let add_pre_univar tv = function + | { flavor = Universal } -> + assert (not_generic tv); + pre_univars := tv :: !pre_univars + | _ -> () + + let collect_univars f = + pre_univars := []; + let result = f () in + let univs = promote_generics_to_univars [] !pre_univars in + result, univs + + let new_var ?name policy = + let tv = Ctype.newvar ?name () in + add_pre_univar tv policy; + tv + + let new_any_var loc env = function + | { extensibility = Fixed } -> raise(Error(loc, env, No_type_wildcards)) + | policy -> new_var policy + + let globalize_used_variables { flavor; extensibility } env = + let r = ref [] in + TyVarMap.iter + (fun name (ty, loc) -> + if flavor = Unification || is_in_scope name then + 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, lookup_global_type_variable name) :: !r + with Not_found -> + if extensibility = Fixed && Btype.is_Tvar ty then + raise(Error(loc, env, + Unbound_type_variable ("'"^name, + get_in_scope_names ()))); + let v2 = new_global_var () in + r := (loc, v, v2) :: !r; + add name v2) + !used_variables; + used_variables := TyVarMap.empty; + fun () -> + List.iter + (function (loc, t1, t2) -> + try unify env t1 t2 with Unify err -> + raise (Error(loc, env, Type_mismatch err))) + !r +end + +(* Support for first-class modules. *) + +let transl_modtype_longident = ref (fun _ -> assert false) +let transl_modtype = ref (fun _ -> assert false) + +let sort_constraints_no_duplicates loc env 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 + +let create_package_mty loc p l = + List.fold_left + (fun mty (s, _) -> + 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 = None; + 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 generalize_ctyp typ = generalize typ.ctyp_type + +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 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 = + if not (valid_tyvar_name name) then + raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); + if TyVarEnv.is_in_scope name then + raise Already_bound; + let v = new_global_var ~name () in + TyVarEnv.add name v; + 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 rec transl_type env ~policy ?(aliased=false) ~row_context styp = + Builtin_attributes.warning_scope styp.ptyp_attributes + (fun () -> transl_type_aux env ~policy ~aliased ~row_context styp) + +and transl_type_aux env ~row_context ~aliased ~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 = TyVarEnv.new_any_var styp.ptyp_loc env policy 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 + TyVarEnv.lookup_local ~row_context:row_context name + with Not_found -> + let v = TyVarEnv.new_var ~name policy in + TyVarEnv.remember_used name v styp.ptyp_loc; + v + end + in + ctyp (Ttyp_var name) ty + | Ptyp_arrow(l, st1, st2) -> + let cty1 = transl_type env ~policy ~row_context st1 in + let cty2 = transl_type env ~policy ~row_context 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, commu_ok)) in + ctyp (Ttyp_arrow (l, cty1, cty2)) ty + | Ptyp_tuple stl -> + assert (List.length stl >= 2); + let ctys = List.map (transl_type env ~policy ~row_context) 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 ~row_context) stl in + let params = instance_list decl.type_params in + let unify_param = + match decl.type_manifest with + None -> unify_var + | Some ty -> + if get_level ty = 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 err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) + ) + (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 ~row_context o fields in + ctyp (Ttyp_object (fields, o)) (newobj ty) + | Ptyp_class(lid, stl) -> + let (path, decl) = + let path, decl = Env.lookup_cltype ~loc:lid.loc lid.txt env in + (path, decl.clty_hash_type) + 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 ~row_context) stl in + let body = Option.get decl.type_manifest in + let (params, body) = instance_parameterized_type decl.type_params body in + List.iter2 + (fun (sty, cty) ty' -> + try unify_var env ty' cty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) + ) + (List.combine stl args) params; + let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in + let ty = Ctype.apply ~use_current_level:true env params body ty_args in + let ty = match get_desc ty with + | Tobject (fi, _) -> + let _, tv = flatten_fields fi in + TyVarEnv.add_pre_univar tv policy; + ty + | _ -> + assert false + in + ctyp (Ttyp_class (path, lid, args)) ty + | Ptyp_alias(st, alias) -> + let cty = + try + let t = TyVarEnv.lookup_local ~row_context alias in + let ty = transl_type env ~policy ~aliased:true ~row_context st in + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) + end; + ty + with Not_found -> + let t, ty = + with_local_level_if_principal begin fun () -> + let t = newvar () in + TyVarEnv.remember_used alias t styp.ptyp_loc; + let ty = transl_type env ~policy ~row_context st in + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) + end; + (t, ty) + end + ~post: (fun (t, _) -> generalize_structure t) + in + let t = instance t in + let px = Btype.proxy t in + begin match get_desc px with + | Tvar None -> set_type_desc px (Tvar (Some alias)) + | Tunivar None -> 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 (create_row ~fields:[l,f] ~more:(newvar()) + ~closed:true ~fixed:None ~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 row_context 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 ~row_context) 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 + rf_either ty_tl ~no_arg:c ~matched:false + | _ -> + if List.length stl > 1 || c && stl <> [] then + raise(Error(styp.ptyp_loc, env, + Present_has_conjunction l.txt)); + match tl with [] -> rf_present None + | st :: _ -> rf_present (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 ~row_context sty in + let ty = cty.ctyp_type in + let nm = + match get_desc cty.ctyp_type with + Tconstr(p, tl, _) -> Some(p, tl) + | _ -> None + in + name := if Hashtbl.length hfields <> 0 then None else nm; + let fl = match get_desc (expand_head env cty.ctyp_type), nm with + Tvariant row, _ when Btype.static_row row -> + row_fields row + | 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 row_field_repr f with + Rpresent oty -> rf_either_of oty + | _ -> 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 more_slot = ref None in + let row_context = + if aliased then row_context else more_slot :: row_context + in + let tfields = List.map (add_field row_context) fields in + let fields = List.rev (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 name = !name in + let make_row more = + create_row ~fields ~more ~closed:(closed = Closed) ~fixed:None ~name + in + let more = + if Btype.static_row (make_row (newvar ())) then newty Tnil else + TyVarEnv.new_var policy + in + more_slot := Some more; + let ty = newty (Tvariant (make_row more)) in + ctyp (Ttyp_variant (tfields, closed, present)) ty + | Ptyp_poly(vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + let new_univars, cty = + with_local_level begin fun () -> + let new_univars = TyVarEnv.make_poly_univars vars in + let cty = TyVarEnv.with_univars new_univars begin fun () -> + transl_type env ~policy ~row_context st + end in + (new_univars, cty) + end + ~post:(fun (_,cty) -> generalize_ctyp cty) + in + let ty = cty.ctyp_type in + let ty_list = TyVarEnv.check_poly_univars env styp.ptyp_loc new_univars in + let ty_list = List.filter (fun v -> deep_occur v ty) ty_list in + let ty' = Btype.newgenty (Tpoly(ty, ty_list)) in + unify_var env (newvar()) ty'; + ctyp (Ttyp_poly (vars, cty)) ty' + | Ptyp_package (p, l) -> + let loc = styp.ptyp_loc in + let l = sort_constraints_no_duplicates loc env l in + let mty = create_package_mty loc p l in + let mty = + TyVarEnv.with_local_scope (fun () -> !transl_modtype env mty) in + let ptys = List.map (fun (s, pty) -> + s, transl_type env ~policy ~row_context pty + ) l in + let path = !transl_modtype_longident 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_fields env ~policy ~row_context 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_type env ~policy ~row_context + (Ast_helper.Typ.force_poly 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 ~row_context sty in + let nm = + match get_desc cty.ctyp_type with + Tconstr(p, _, _) -> Some p + | _ -> None in + let t = expand_head env cty.ctyp_type in + match get_desc t, nm with + Tobject (tf, _), _ + when (match get_desc tf with Tfield _ | Tnil -> true | _ -> false) -> + begin + if opened_object t then + raise (Error (sty.ptyp_loc, env, Opened_object nm)); + let rec iter_add ty = + match get_desc ty with + | Tfield (s, _k, ty1, ty2) -> + add_typed_field sty.ptyp_loc s ty1; + iter_add ty2 + | Tnil -> () + | _ -> assert false + in + iter_add tf; + OTinherit cty + end + | 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 with + | Closed -> newty Tnil + | Open -> TyVarEnv.new_var policy + in + let ty = List.fold_left (fun ty (s, ty') -> + newty (Tfield (s, field_public, 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 = + if Btype.try_mark_node ty then + begin match get_desc ty with + | Tvariant row -> + let Row {fields; more; name; closed} = row_repr row in + if Btype.is_Tunivar more then + let fields = + List.map + (fun (s,f as p) -> match row_field_repr f with + Reither (no_arg, tl, _m) -> + s, rf_either tl ~use_ext_of:f ~no_arg ~matched:true + | _ -> p) + fields + in + set_type_desc ty + (Tvariant + (create_row ~fields ~more ~name ~closed + ~fixed:(Some (Univar more)))); + Btype.iter_row make_fixed_univars row + | _ -> + Btype.iter_type_expr make_fixed_univars ty + end + +let transl_type env policy styp = + transl_type env ~policy ~row_context:[] styp + +let make_fixed_univars ty = + make_fixed_univars ty; + Btype.unmark_type ty + +let transl_simple_type env ?univars ~closed styp = + TyVarEnv.reset_locals ?univars (); + let policy = TyVarEnv.(if closed then fixed_policy else extensible_policy) in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); + make_fixed_univars typ.ctyp_type; + typ + +let transl_simple_type_univars env styp = + TyVarEnv.reset_locals (); + let typ, univs = + TyVarEnv.collect_univars begin fun () -> + with_local_level ~post:generalize_ctyp begin fun () -> + let policy = TyVarEnv.univars_policy in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); + typ + end + end 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 = + TyVarEnv.reset_locals (); + let typ, force = + with_local_level begin fun () -> + let policy = TyVarEnv.extensible_policy in + let typ = transl_type env policy styp in + 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 = TyVarEnv.globalize_used_variables policy env in + (typ, force) + end + (* Generalize everything except the variables that were just globalized. *) + ~post:(fun (typ,_) -> generalize_ctyp typ) + in + (typ, instance typ.ctyp_type, force) + +let transl_type_scheme env styp = + match styp.ptyp_desc with + | Ptyp_poly (vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + let univars, typ = + with_local_level begin fun () -> + TyVarEnv.reset (); + let univars = TyVarEnv.make_poly_univars vars in + let typ = transl_simple_type env ~univars ~closed:true st in + (univars, typ) + end + ~post:(fun (_,typ) -> generalize_ctyp typ) + in + let _ = TyVarEnv.instance_poly_univars env styp.ptyp_loc univars in + { ctyp_desc = Ttyp_poly (vars, typ); + ctyp_type = typ.ctyp_type; + ctyp_env = env; + ctyp_loc = styp.ptyp_loc; + ctyp_attributes = styp.ptyp_attributes } + | _ -> + with_local_level + (fun () -> TyVarEnv.reset (); transl_simple_type env ~closed:false styp) + ~post:generalize_ctyp + + +(* Error report *) + +open Format +open Printtyp + +let report_error env ppf = function + | Unbound_type_variable (name, in_scope_names) -> + fprintf ppf "The type variable %s is unbound in this type declaration.@ %a" + name + did_you_mean (fun () -> Misc.spellcheck in_scope_names name ) + | No_type_wildcards -> + fprintf ppf "A type wildcard \"_\" is not allowed in this type declaration." + | 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 + "@[@[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.prepare_for_printing [ty; ty']; + fprintf ppf "@[%s %a@ %s@ %a@]" + "This variant type contains a constructor" + !Oprint.out_type (tree_of_typexp Type ty) + "which should be" + !Oprint.out_type (tree_of_typexp Type ty')) + | Not_a_variant ty -> + fprintf ppf + "@[The type %a@ does not expand to a polymorphic variant type@]" + Printtyp.type_expr ty; + begin match get_desc ty 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 + "@[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 "@[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_501/typing/typetexp.mli b/upstream/ocaml_501/typing/typetexp.mli new file mode 100644 index 0000000000..ca058a5cf0 --- /dev/null +++ b/upstream/ocaml_501/typing/typetexp.mli @@ -0,0 +1,99 @@ +(**************************************************************************) +(* *) +(* 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 + +module TyVarEnv : sig + (* this is just the subset of [TyVarEnv] that is needed outside + of [Typetexp]. See the ml file for more. *) + + val reset : unit -> unit + (** removes all type variables from scope *) + + val with_local_scope : (unit -> 'a) -> 'a + (** Evaluate in a narrowed type-variable scope *) + + type poly_univars + val make_poly_univars : string list -> poly_univars + (** remember that a list of strings connotes univars; this must + always be paired with a [check_poly_univars]. *) + + val check_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (** Verify that the given univars are universally quantified, + and return the list of variables. The type in which the + univars are used must be generalised *) + + val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (** Same as [check_poly_univars], but instantiates the resulting + type scheme (i.e. variables become Tvar rather than Tunivar) *) + +end + +val valid_tyvar_name : string -> bool + +val transl_simple_type: + Env.t -> ?univars:TyVarEnv.poly_univars -> closed: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 transl_type_param: + Env.t -> Parsetree.core_type -> Typedtree.core_type + +exception Already_bound + +type error = + | Unbound_type_variable of string * string list + | No_type_wildcards + | 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_error + | Alias_type_mismatch of Errortrace.unification_error + | 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 diff --git a/upstream/ocaml_501/typing/untypeast.ml b/upstream/ocaml_501/typing/untypeast.ml new file mode 100644 index 0000000000..777cc3b7af --- /dev/null +++ b/upstream/ocaml_501/typing/untypeast.ml @@ -0,0 +1,919 @@ +(**************************************************************************) +(* *) +(* 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.Papply (p1, p2) -> + Longident.Lapply (lident_of_path p1, lident_of_path p2) + | Path.Pdot (p, s) | Path.Pextra_ty (p, Pcstr_ty s) -> + Longident.Ldot (lident_of_path p, s) + | Path.Pextra_ty (p, _) -> lident_of_path p + +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 name i = s ^ Int.to_string i in + let available i = not (Env.bound_value (name i) env) in + let first_i = Misc.find_first_mono available in + name first_i + +(** 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 + ~vars:cd.cd_vars + ~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 (vs, args, ret) -> + Pext_decl (vs, 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 + | Tmeth_ancestor(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_apply_unit mexp1 -> + Pmod_apply_unit (sub.module_expr sub mexp1) + | 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_501/typing/untypeast.mli b/upstream/ocaml_501/typing/untypeast.mli new file mode 100644 index 0000000000..809df9ad08 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/arg_helper.ml b/upstream/ocaml_501/utils/arg_helper.ml new file mode 100644 index 0000000000..fa80007ad4 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/arg_helper.mli b/upstream/ocaml_501/utils/arg_helper.mli new file mode 100644 index 0000000000..18f60fea5c --- /dev/null +++ b/upstream/ocaml_501/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 + | =[,...] + + (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_501/utils/binutils.ml b/upstream/ocaml_501/utils/binutils.ml new file mode 100644 index 0000000000..cf8a53e70a --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/binutils.mli b/upstream/ocaml_501/utils/binutils.mli new file mode 100644 index 0000000000..44e17fec38 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/build_path_prefix_map.ml b/upstream/ocaml_501/utils/build_path_prefix_map.ml new file mode 100644 index 0000000000..17cfac82e2 --- /dev/null +++ b/upstream/ocaml_501/utils/build_path_prefix_map.ml @@ -0,0 +1,118 @@ +(**************************************************************************) +(* *) +(* 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.ksprintf (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 make_target path : pair option -> path option = function + | None -> None + | Some { target; source } -> + let is_prefix = + String.length source <= String.length path + && String.equal source (String.sub path 0 (String.length source)) in + if is_prefix then + Some (target ^ (String.sub path (String.length source) + (String.length path - String.length source))) + else None + +let rewrite_first prefix_map path = + List.find_map (make_target path) (List.rev prefix_map) + +let rewrite_all prefix_map path = + List.filter_map (make_target path) (List.rev prefix_map) + +let rewrite prefix_map path = + match rewrite_first prefix_map path with + | None -> path + | Some path -> path diff --git a/upstream/ocaml_501/utils/build_path_prefix_map.mli b/upstream/ocaml_501/utils/build_path_prefix_map.mli new file mode 100644 index 0000000000..d8ec9caf4d --- /dev/null +++ b/upstream/ocaml_501/utils/build_path_prefix_map.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* 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}. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} +*) + + +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_first : map -> path -> path option +(** [rewrite_first 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_all : map -> path -> path list +(** [rewrite_all map path] finds all sources in [map] + that are a prefix of the input [path]. For each matching + source, in priority order, it replaces this prefix with + the corresponding target and adds the result to + the returned list. + If there are no matches, it just returns [[]]. *) + +val rewrite : map -> path -> path +(** [rewrite path] uses [rewrite_first] to try to find a + mapping for path. If found, it returns that, otherwise + it just returns [path]. *) diff --git a/upstream/ocaml_501/utils/ccomp.ml b/upstream/ocaml_501/utils/ccomp.ml new file mode 100644 index 0000000000..33a4c9d0b4 --- /dev/null +++ b/upstream/ocaml_501/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_response_file 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 ~response_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 response_files && + (String.length s >= 65536 + || (String.length s >= 4096 && Sys.os_type = "Win32")) + then build_response_file quoted + else s + +let quote_prefixed ~response_files pr lst = + let lst = List.filter (fun f -> f <> "") lst in + let lst = List.map (fun f -> pr ^ f) lst in + quote_files ~response_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 ~response_files:true "-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 ~response_files:true file_list)) + | _ -> + assert(String.length Config.ar > 0); + command(Printf.sprintf "%s rc %s %s" + Config.ar quoted_archive + (quote_files ~response_files:Config.ar_supports_response_files + file_list)) + +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 ~response_files:true + l_prefix (Load_path.get_paths ())) + (quote_files ~response_files:true (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 ~response_files:true "-L" (Load_path.get_paths ())) + (String.concat " " (List.rev !Clflags.all_ccopts)) + (quote_files ~response_files:true 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_501/utils/ccomp.mli b/upstream/ocaml_501/utils/ccomp.mli new file mode 100644 index 0000000000..84f5041871 --- /dev/null +++ b/upstream/ocaml_501/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: response_files:bool -> 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_501/utils/clflags.ml b/upstream/ocaml_501/utils/clflags.ml new file mode 100644 index 0000000000..5ba6e04688 --- /dev/null +++ b/upstream/ocaml_501/utils/clflags.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. *) +(* *) +(**************************************************************************) + +(* 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 cmi_file = ref None + +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 no_cwd = ref false (* -nocwd *) +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 safer_matching = ref false (* -safer-matching *) +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 (* -bin-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 true (* -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_shape = ref false (* -dshape *) +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 "" + +let with_runtime = ref true (* -with-runtime *) + +let keep_docs = ref false (* -keep-docs *) +let keep_locs = ref true (* -keep-locs *) + +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 *) +let dump_dir: string option ref = ref None (* -dump-dir *) + +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 | Lambda | Scheduling | Emit + + let to_string = function + | Parsing -> "parsing" + | Typing -> "typing" + | Lambda -> "lambda" + | Scheduling -> "scheduling" + | Emit -> "emit" + + let of_string = function + | "parsing" -> Some Parsing + | "typing" -> Some Typing + | "lambda" -> Some Lambda + | "scheduling" -> Some Scheduling + | "emit" -> Some Emit + | _ -> None + + let rank = function + | Parsing -> 0 + | Typing -> 1 + | Lambda -> 2 + | Scheduling -> 50 + | Emit -> 60 + + let passes = [ + Parsing; + Typing; + Lambda; + 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 \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_501/utils/clflags.mli b/upstream/ocaml_501/utils/clflags.mli new file mode 100644 index 0000000000..0fc0c56e4f --- /dev/null +++ b/upstream/ocaml_501/utils/clflags.mli @@ -0,0 +1,274 @@ +(**************************************************************************) +(* *) +(* 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 cmi_file : string option 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 no_cwd : 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 safer_matching : bool 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_shape : 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 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 +val dump_dir : string option 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 | Lambda | 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_501/utils/config.common.ml b/upstream/ocaml_501/utils/config.common.ml new file mode 100644 index 0000000000..9fa25b1dfa --- /dev/null +++ b/upstream/ocaml_501/utils/config.common.ml @@ -0,0 +1,165 @@ +#2 "utils/config.common.ml" +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Portions of the Config module common to both the boot and main compiler. *) + +(* The main OCaml version string has moved to ../build-aux/ocaml_version.m4 *) +let version = Sys.ocaml_version + +let standard_library = + try + Sys.getenv "OCAMLLIB" + with Not_found -> + try + Sys.getenv "CAMLLIB" + with Not_found -> + standard_library_default + +let exec_magic_number = "Caml1999X033" + (* exec_magic_number is duplicated in runtime/caml/exec.h *) +and cmi_magic_number = "Caml1999I033" +and cmo_magic_number = "Caml1999O033" +and cma_magic_number = "Caml1999A033" +and cmx_magic_number = + if flambda then + "Caml1999y033" + else + "Caml1999Y033" +and cmxa_magic_number = + if flambda then + "Caml1999z033" + else + "Caml1999Z033" +and ast_impl_magic_number = "Caml1999M033" +and ast_intf_magic_number = "Caml1999N033" +and cmxs_magic_number = "Caml1999D033" +and cmt_magic_number = "Caml1999T033" +and linear_magic_number = "Caml1999L033" + +let safe_string = true +let default_safe_string = true +let naked_pointers = false + +let interface_suffix = ref ".mli" + +let max_tag = 243 +(* 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 = 32 (* see runtime/caml/config.h *) +let stack_safety_margin = 6 +let default_executable_name = + match Sys.os_type with + "Unix" -> "a.out" + | "Win32" | "Cygwin" -> "camlprog.exe" + | _ -> "camlprog" +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_bool "native_compiler" native_compiler; + 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_bool "native_dynlink" native_dynlink; + p_bool "naked_pointers" naked_pointers; + p_bool "compression_supported" (Marshal.compression_supported()); + + 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_501/utils/config.fixed.ml b/upstream/ocaml_501/utils/config.fixed.ml new file mode 100644 index 0000000000..e0ca8d4aca --- /dev/null +++ b/upstream/ocaml_501/utils/config.fixed.ml @@ -0,0 +1,71 @@ +#2 "utils/config.fixed.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* David Allsopp, Tarides UK. *) +(* *) +(* Copyright 2022 David Allsopp Ltd. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Configuration for the boot compiler. The compiler should refuse to bootstrap + if configured with values which would contradict the configuration below. + The values below are picked to trigger errors if accidentally used in the + compiler (e.g. for the C compiler). *) + +let boot_cannot_call s = "/ The boot compiler should not call " ^ s + +let bindir = "/tmp" +let standard_library_default = "/tmp" +let ccomp_type = "n/a" +let c_compiler = boot_cannot_call "the C compiler" +let c_output_obj = "" +let c_has_debug_prefix_map = false +let as_has_debug_prefix_map = false +let ocamlc_cflags = "" +let ocamlc_cppflags = "" +let ocamlopt_cflags = "" +let ocamlopt_cppflags = "" +let bytecomp_c_libraries = "" +let bytecomp_c_compiler = "" +let native_c_compiler = c_compiler +let native_c_libraries = "" +let native_pack_linker = boot_cannot_call "the linker" +let default_rpath = "" +let mksharedlibrpath = "" +let ar = boot_cannot_call "ar" +let supports_shared_libraries = false +let native_dynlink = false +let mkdll = native_pack_linker +let mkexe = native_pack_linker +let mkmaindll = native_pack_linker +let flambda = false +let with_flambda_invariants = false +let with_cmm_invariants = false +let windows_unicode = false +let flat_float_array = true +let function_sections = false +let afl_instrument = false +let native_compiler = false +let architecture = "none" +let model = "default" +let system = "unknown" +let asm = boot_cannot_call "the assembler" +let asm_cfi_supported = false +let with_frame_pointers = false +let reserved_header_bits = 0 +let ext_exe = ".ex_The boot compiler should not be using Config.ext_exe" +let ext_obj = ".o_The boot compiler cannot process C objects" +let ext_asm = ".s_The boot compiler should not be using Config.ext_asm" +let ext_lib = ".a_The boot compiler cannot process C libraries" +let ext_dll = ".so_The boot compiler cannot load DLLs" +let host = "zinc-boot-ocaml" +let target = host +let systhread_supported = false +let flexdll_dirs = [] +let ar_supports_response_files = true diff --git a/upstream/ocaml_501/utils/config.ml b/upstream/ocaml_501/utils/config.ml new file mode 100644 index 0000000000..cb65204acc --- /dev/null +++ b/upstream/ocaml_501/utils/config.ml @@ -0,0 +1,277 @@ +(* utils/config.generated.ml. Generated from config.generated.ml.in by configure. *) +#2 "utils/config.generated.ml.in" +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* This file is included in config_main.ml during the build rather + than compiled on its own *) + +let bindir = {|/usr/local/bin|} + +let standard_library_default = {|/usr/local/lib/ocaml|} + +let ccomp_type = {|cc|} +let c_compiler = {|gcc|} +let c_output_obj = {|-o |} +let c_has_debug_prefix_map = true +let as_has_debug_prefix_map = false +let ocamlc_cflags = {|-O2 -fno-strict-aliasing -fwrapv -pthread |} +let ocamlc_cppflags = {| -D_FILE_OFFSET_BITS=64 |} +(* #7678: ocamlopt uses these only to compile .c files, and the behaviour for + the two drivers should be identical. *) +let ocamlopt_cflags = {|-O2 -fno-strict-aliasing -fwrapv -pthread |} +let ocamlopt_cppflags = {| -D_FILE_OFFSET_BITS=64 |} +let bytecomp_c_libraries = {| -L/opt/homebrew/Cellar/zstd/1.5.2/lib -lzstd -lm -lpthread|} +(* 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 = {| -L/opt/homebrew/Cellar/zstd/1.5.2/lib -lzstd -lm -lpthread|} +let native_pack_linker = {|ld -r -o |} +let default_rpath = {||} +let mksharedlibrpath = {||} +let ar = {|ar|} +let supports_shared_libraries = true +let native_dynlink = true +let mkdll, mkexe, mkmaindll = + if Sys.win32 || Sys.cygwin && supports_shared_libraries then + let flexlink = + let flexlink = + Option.value ~default:"flexlink" (Sys.getenv_opt "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 + in + let flexdll_chain = {||} in + let flexlink_flags = {||} in + let flags = " -chain " ^ flexdll_chain ^ " " ^ flexlink_flags in + flexlink ^ flags ^ {| |}, + flexlink ^ " -exe" ^ flags + ^ {| |} ^ {| |}, + flexlink ^ " -maindll" ^ flags ^ {| |} + else + {|gcc -shared -undefined dynamic_lookup -Wl,-w |}, + {|gcc -O2 -fno-strict-aliasing -fwrapv -pthread |}, + {|gcc -shared -undefined dynamic_lookup -Wl,-w|} + +let flambda = false +let with_flambda_invariants = false +let with_cmm_invariants = false +let windows_unicode = 0 != 0 + +let flat_float_array = true + +let function_sections = false +let afl_instrument = false + +let native_compiler = true + +let architecture = {|arm64|} +let model = {|default|} +let system = {|macosx|} + +let asm = {|gcc -c -Wno-trigraphs|} +let asm_cfi_supported = true +let with_frame_pointers = false +let reserved_header_bits = 0 + +let ext_exe = {||} +let ext_obj = "." ^ {|o|} +let ext_asm = "." ^ {|s|} +let ext_lib = "." ^ {|a|} +let ext_dll = "." ^ {|so|} + +let host = {|aarch64-apple-darwin22.3.0|} +let target = {|aarch64-apple-darwin22.3.0|} + +let systhread_supported = true + +let flexdll_dirs = [] + +let ar_supports_response_files = true +#2 "utils/config.common.ml" +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Portions of the Config module common to both the boot and main compiler. *) + +(* The main OCaml version string has moved to ../build-aux/ocaml_version.m4 *) +let version = Sys.ocaml_version + +let standard_library = + try + Sys.getenv "OCAMLLIB" + with Not_found -> + try + Sys.getenv "CAMLLIB" + with Not_found -> + standard_library_default + +let exec_magic_number = "Caml1999X033" + (* exec_magic_number is duplicated in runtime/caml/exec.h *) +and cmi_magic_number = "Caml1999I033" +and cmo_magic_number = "Caml1999O033" +and cma_magic_number = "Caml1999A033" +and cmx_magic_number = + if flambda then + "Caml1999y033" + else + "Caml1999Y033" +and cmxa_magic_number = + if flambda then + "Caml1999z033" + else + "Caml1999Z033" +and ast_impl_magic_number = "Caml1999M033" +and ast_intf_magic_number = "Caml1999N033" +and cmxs_magic_number = "Caml1999D033" +and cmt_magic_number = "Caml1999T033" +and linear_magic_number = "Caml1999L033" + +let safe_string = true +let default_safe_string = true +let naked_pointers = false + +let interface_suffix = ref ".mli" + +let max_tag = 243 +(* 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 = 32 (* see runtime/caml/config.h *) +let stack_safety_margin = 6 +let default_executable_name = + match Sys.os_type with + "Unix" -> "a.out" + | "Win32" | "Cygwin" -> "camlprog.exe" + | _ -> "camlprog" +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_bool "native_compiler" native_compiler; + 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_bool "native_dynlink" native_dynlink; + p_bool "naked_pointers" naked_pointers; + p_bool "compression_supported" (Marshal.compression_supported()); + + 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_501/utils/config.mli b/upstream/ocaml_501/utils/config.mli new file mode 100644 index 0000000000..800d23c477 --- /dev/null +++ b/upstream/ocaml_501/utils/config.mli @@ -0,0 +1,264 @@ +(**************************************************************************) +(* *) +(* 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 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 native_compiler: bool +(** Whether the native compiler is available or not + + @since 5.1 *) + +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 *) + +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 reserved_header_bits : int +(** How many bits of a block's header are reserved *) + +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 naked_pointers : bool +(** Whether the runtime supports naked pointers + + @since 4.14 *) + +val supports_shared_libraries: bool +(** Whether shared libraries are supported + + @since 4.08 *) + +val native_dynlink: bool +(** Whether native shared libraries are supported + + @since 5.1 *) + +val afl_instrument : bool +(** Whether afl-fuzz instrumentation is generated by default *) + +val ar_supports_response_files: bool +(** Whether ar supports @FILE arguments. *) + +(** 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_501/utils/consistbl.ml b/upstream/ocaml_501/utils/consistbl.ml new file mode 100644 index 0000000000..29289201f6 --- /dev/null +++ b/upstream/ocaml_501/utils/consistbl.ml @@ -0,0 +1,95 @@ +(**************************************************************************) +(* *) +(* 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 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_501/utils/consistbl.mli b/upstream/ocaml_501/utils/consistbl.mli new file mode 100644 index 0000000000..acc89eb31d --- /dev/null +++ b/upstream/ocaml_501/utils/consistbl.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* 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 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_501/utils/diffing.ml b/upstream/ocaml_501/utils/diffing.ml new file mode 100644 index 0000000000..e5b230e233 --- /dev/null +++ b/upstream/ocaml_501/utils/diffing.ml @@ -0,0 +1,447 @@ +(**************************************************************************) +(* *) +(* 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 + 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. + +*) + +(** Shared types *) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation + +let style = function + | Preservation -> Misc.Color.[ FG Green ] + | Deletion -> Misc.Color.[ FG Red; Bold] + | Insertion -> Misc.Color.[ FG Red; Bold] + | Modification -> 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 (let*) = Option.bind +let (let+) x f = Option.map f x +let (let*!) x f = Option.iter f x + +module type Defs = sig + type left + type right + type eq + type diff + type state +end + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +let classify = function + | Delete _ -> Deletion + | Insert _ -> Insertion + | Change _ -> Modification + | Keep _ -> Preservation + +module Define(D:Defs) = struct + open D + +type nonrec change = (left,right,eq,diff) change + +type patch = change list +module type S = sig + val diff: state -> left array -> right array -> patch +end + + +type full_state = { + line: left array; + column: right array; + state: state +} + +(* 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 t + + val make : shape -> t + val reshape : shape -> t -> t + + (** accessor functions *) + val diff : t -> int -> int -> change option + val state : t -> int -> int -> full_state option + val weight : t -> int -> int -> int + + val line : t -> int -> int -> left option + val column : t -> int -> int -> right option + + val set : + t -> int -> int -> + diff:change option -> + weight:int -> + state: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 t = + { states: full_state option array array; + weight: int array array; + 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 + + +(* 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) + +(* 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 + + module type Full_core = sig + type update_result + type update_state + val weight: change -> int + val test: state -> left -> right -> (eq, diff) result + val update: change -> update_state -> update_result + end + +module Generic + (X: Full_core + with type update_result := full_state + and type update_state := full_state) = struct + open X + + (* Boundary cell update *) + let compute_column0 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 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 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 m i j = + match i, j with + | _ when Matrix.diff m i j <> None -> () + | 0,0 -> () + | 0,j -> compute_line0 m j + | i,0 -> compute_column0 m i; + | _ -> compute_inner_cell 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 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 m i j + done + done; + loop m + else + m + in + loop m0 + end + + + module type Parameters = Full_core with type update_state := state + + module Simple(X:Parameters with type update_result := state) = struct + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = { fs with state = X.update d fs.state } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + + let may_append x = function + | [||] -> x + | y -> Array.append x y + + + module Left_variadic + (X:Parameters with type update_result := state * left array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; line = may_append fs.line a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + module Right_variadic + (X:Parameters with type update_result := state * right array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; column = may_append fs.column a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + +end diff --git a/upstream/ocaml_501/utils/diffing.mli b/upstream/ocaml_501/utils/diffing.mli new file mode 100644 index 0000000000..80cfa5e279 --- /dev/null +++ b/upstream/ocaml_501/utils/diffing.mli @@ -0,0 +1,147 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** 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 ). + + 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 core types of a diffing implementation *) +module type Defs = sig + type left + type right + type eq + (** Detailed equality trace *) + + type diff + (** Detailed difference trace *) + + type state + (** environment of a partial patch *) +end + +(** The kind of changes which is used to share printing and styling + across implementation*) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation +val prefix: Format.formatter -> (int * change_kind) -> unit +val style: change_kind -> Misc.Color.style list + + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +val classify: _ change -> change_kind + +(** [Define(Defs)] creates the diffing types from the types + defined in [Defs] and the functors that need to be instantatied + with the diffing algorithm parameters +*) +module Define(D:Defs): sig + open D + + (** The type of potential changes on a list. *) + type nonrec change = (left,right,eq,diff) change + type patch = change list + (** A patch is an ordered list of changes. *) + + module type Parameters = sig + type update_result + + val weight: change -> int + (** [weight ch] returns the weight of the change [ch]. + Used to find the smallest patch. *) + + val test: state -> left -> right -> (eq, diff) result + (** + [test st xl xr] tests if the elements [xl] and [xr] are + co mpatible ([Ok]) or not ([Error]). + *) + + val update: change -> state -> update_result + (** [update ch st] returns the new state after applying a change. + The [update_result] type also contains expansions in the variadic + case. + *) + end + + module type S = sig + val diff: state -> left array -> right array -> patch + (** [diff state l r] computes the optimal patch between [l] and [r], + using the initial state [state]. + *) + end + + + module Simple: (Parameters with type update_result := state) -> S + + (** {1 Variadic diffing} + + Variadic diffing allows to expand the lists being diffed during diffing. + in one specific direction. + *) + module Left_variadic: + (Parameters with type update_result := state * left array) -> S + + module Right_variadic: + (Parameters with type update_result := state * right array) -> S + +end diff --git a/upstream/ocaml_501/utils/diffing_with_keys.ml b/upstream/ocaml_501/utils/diffing_with_keys.ml new file mode 100644 index 0000000000..3e1ea13680 --- /dev/null +++ b/upstream/ocaml_501/utils/diffing_with_keys.ml @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + + +type 'a with_pos = {pos:int; data:'a} +let with_pos l = List.mapi (fun n data -> {pos=n+1; data}) l + +(** Composite change and mismatches *) +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +let prefix ppf x = + let kind = match x with + | Change _ | Swap _ | Move _ -> Diffing.Modification + | Insert _ -> Diffing.Insertion + | Delete _ -> Diffing.Deletion + in + let style k ppf inner = + let sty = Diffing.style k in + Format.pp_open_stag ppf (Misc.Color.Style sty); + Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner + in + match x with + | Change (Name {pos; _ } | Type {pos; _}) + | Insert { pos; _ } | Delete { pos; _ } -> + style kind ppf "%i. " pos + | Swap { pos = left, right; _ } -> + style kind ppf "%i<->%i. " left right + | Move { got; expected; _ } -> + style kind ppf "%i->%i. " expected got + + + +(** To detect [move] and [swaps], we are using the fact that + there are 2-cycles in the graph of name renaming. + - [Change (x,y,_) is then an edge from + [key_left x] to [key_right y]. + - [Insert x] is an edge between the special node epsilon and + [key_left x] + - [Delete x] is an edge between [key_right] and the epsilon node + Since for 2-cycle, knowing one edge is enough to identify the cycle + it might belong to, we are using maps of partial 2-cycles. +*) +module Two_cycle: sig + type t = private (string * string) + val create: string -> string -> t +end = struct + type t = string * string + let create kx ky = + if kx <= ky then kx, ky else ky, kx +end +module Swap = Map.Make(struct + type t = Two_cycle.t + let compare: t -> t -> int = Stdlib.compare + end) +module Move = Misc.Stdlib.String.Map + + +module Define(D:Diffing.Defs with type eq := unit) = struct + + module Internal_defs = struct + type left = D.left with_pos + type right = D.right with_pos + type diff = (D.left, D.right, D.diff) mismatch + type eq = unit + type state = D.state + end + module Diff = Diffing.Define(Internal_defs) + + type left = Internal_defs.left + type right = Internal_defs.right + type diff = (D.left, D.right, D.diff) mismatch + type composite_change = (D.left,D.right,D.diff) change + type nonrec change = (left, right, unit, diff) Diffing.change + type patch = composite_change list + + module type Parameters = sig + include Diff.Parameters with type update_result := D.state + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple(Impl:Parameters) = struct + open Impl + + (** Partial 2-cycles *) + type ('l,'r) partial_cycle = + | Left of int * D.state * 'l + | Right of int * D.state * 'r + | Both of D.state * 'l * 'r + + (** Compute the partial cycle and edge associated to an edge *) + let edge state (x:left) (y:right) = + let kx, ky = key_left x.data, key_right y.data in + let edge = + if kx <= ky then + Left (x.pos, state, (x,y)) + else + Right (x.pos,state, (x,y)) + in + Two_cycle.create kx ky, edge + + let merge_edge ex ey = match ex, ey with + | ex, None -> Some ex + | Left (lpos, lstate, l), Some Right (rpos, rstate,r) + | Right (rpos, rstate,r), Some Left (lpos, lstate, l) -> + let state = if lpos < rpos then rstate else lstate in + Some (Both (state,l,r)) + | Both _ as b, _ | _, Some (Both _ as b) -> Some b + | l, _ -> Some l + + let two_cycles state changes = + let add (state,(swaps,moves)) (d:change) = + update d state, + match d with + | Change (x,y,_) -> + let k, edge = edge state x y in + Swap.update k (merge_edge edge) swaps, moves + | Insert nx -> + let k = key_right nx.data in + let edge = Right (nx.pos, state,nx) in + swaps, Move.update k (merge_edge edge) moves + | Delete nx -> + let k, edge = key_left nx.data, Left (nx.pos, state, nx) in + swaps, Move.update k (merge_edge edge) moves + | _ -> swaps, moves + in + List.fold_left add (state,(Swap.empty,Move.empty)) changes + + (** Check if an edge belongs to a known 2-cycle *) + let swap swaps x y = + let kx, ky = key_left x.data, key_right y.data in + let key = Two_cycle.create kx ky in + match Swap.find_opt key swaps with + | None | Some (Left _ | Right _)-> None + | Some Both (state, (ll,lr),(rl,rr)) -> + match test state ll rr, test state rl lr with + | Ok _, Ok _ -> + Some ({pos=ll.pos; data=kx}, {pos=rl.pos; data=ky}) + | Error _, _ | _, Error _ -> None + + let move moves x = + let name = + match x with + | Either.Left x -> key_left x.data + | Either.Right x -> key_right x.data + in + match Move.find_opt name moves with + | None | Some (Left _ | Right _)-> None + | Some Both (state,got,expected) -> + match test state got expected with + | Ok _ -> + Some (Move {name; got=got.pos; expected=expected.pos}) + | Error _ -> None + + let refine state patch = + let _, (swaps, moves) = two_cycles state patch in + let filter: change -> composite_change option = function + | Keep _ -> None + | Insert x -> + begin match move moves (Either.Right x) with + | Some _ as move -> move + | None -> Some (Insert {pos=x.pos;insert=x.data}) + end + | Delete x -> + begin match move moves (Either.Left x) with + | Some _ -> None + | None -> Some (Delete {pos=x.pos; delete=x.data}) + end + | Change(x,y, reason) -> + match swap swaps x y with + | Some ({pos=pos1; data=first}, {pos=pos2; data=last}) -> + if x.pos = pos1 then + Some (Swap { pos = pos1, pos2; first; last}) + else None + | None -> Some (Change reason) + in + List.filter_map filter patch + + let diff state left right = + let left = with_pos left in + let right = with_pos right in + let module Raw = Diff.Simple(Impl) in + let raw = Raw.diff state (Array.of_list left) (Array.of_list right) in + refine state raw + + end +end diff --git a/upstream/ocaml_501/utils/diffing_with_keys.mli b/upstream/ocaml_501/utils/diffing_with_keys.mli new file mode 100644 index 0000000000..2da8268767 --- /dev/null +++ b/upstream/ocaml_501/utils/diffing_with_keys.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** + + When diffing lists where each element has a distinct key, we can refine + the diffing patch by introducing two composite edit moves: swaps and moves. + + [Swap]s exchange the position of two elements. [Swap] cost is set to + [2 * change - epsilon]. + [Move]s change the position of one element. [Move] cost is set to + [delete + addition - epsilon]. + + When the cost [delete + addition] is greater than [change] and with those + specific weights, the optimal patch with [Swap]s and [Move]s can be computed + directly and cheaply from the original optimal patch. + +*) + +type 'a with_pos = {pos: int; data:'a} +val with_pos: 'a list -> 'a with_pos list + +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +(** This specialized version of changes introduces two composite + changes: [Move] and [Swap] +*) +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +val prefix: Format.formatter -> ('l,'r,'diff) change -> unit + +module Define(D:Diffing.Defs with type eq := unit): sig + + type diff = (D.left, D.right, D.diff) mismatch + type left = D.left with_pos + type right = D.right with_pos + + (** Composite changes and patches *) + type composite_change = (D.left,D.right,D.diff) change + type patch = composite_change list + + (** Atomic changes *) + type change = (left,right,unit,diff) Diffing.change + + module type Parameters = sig + val weight: change -> int + val test: D.state -> left -> right -> (unit, diff) result + val update: change -> D.state -> D.state + + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple: Parameters -> sig + val diff: D.state -> D.left list -> D.right list -> patch + end + +end diff --git a/upstream/ocaml_501/utils/domainstate.ml.c b/upstream/ocaml_501/utils/domainstate.ml.c new file mode 100644 index 0000000000..6dbae1d07a --- /dev/null +++ b/upstream/ocaml_501/utils/domainstate.ml.c @@ -0,0 +1,38 @@ +/**************************************************************************/ +/* */ +/* 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. */ +/* */ +/**************************************************************************/ + +#define CAML_CONFIG_H_NO_TYPEDEFS +#include "config.h" +let stack_ctx_words = Stack_ctx_words + +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_501/utils/domainstate.mli.c b/upstream/ocaml_501/utils/domainstate.mli.c new file mode 100644 index 0000000000..66a4750d4c --- /dev/null +++ b/upstream/ocaml_501/utils/domainstate.mli.c @@ -0,0 +1,24 @@ +/**************************************************************************/ +/* */ +/* 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. */ +/* */ +/**************************************************************************/ + +val stack_ctx_words : int + +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_501/utils/identifiable.ml b/upstream/ocaml_501/utils/identifiable.ml new file mode 100644 index 0000000000..9bbfb65733 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/identifiable.mli b/upstream/ocaml_501/utils/identifiable.mli new file mode 100644 index 0000000000..0da5a66191 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/int_replace_polymorphic_compare.ml b/upstream/ocaml_501/utils/int_replace_polymorphic_compare.ml new file mode 100644 index 0000000000..7cd6bf1099 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/int_replace_polymorphic_compare.mli b/upstream/ocaml_501/utils/int_replace_polymorphic_compare.mli new file mode 100644 index 0000000000..689e741b66 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/lazy_backtrack.ml b/upstream/ocaml_501/utils/lazy_backtrack.ml new file mode 100644 index 0000000000..13e4eb4400 --- /dev/null +++ b/upstream/ocaml_501/utils/lazy_backtrack.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* 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 get_contents x = + match !x with + | Thunk a -> Either.Left a + | Done b -> Either.Right b + | Raise e -> raise e + +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_501/utils/lazy_backtrack.mli b/upstream/ocaml_501/utils/lazy_backtrack.mli new file mode 100644 index 0000000000..4e2fbd3808 --- /dev/null +++ b/upstream/ocaml_501/utils/lazy_backtrack.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* 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 get_contents : ('a,'b) t -> ('a,'b) Either.t +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_501/utils/load_path.ml b/upstream/ocaml_501/utils/load_path.ml new file mode 100644 index 0000000000..42330d5623 --- /dev/null +++ b/upstream/ocaml_501/utils/load_path.ml @@ -0,0 +1,176 @@ +(**************************************************************************) +(* *) +(* 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 + + let find t fn = + if List.mem fn t.files then + Some (Filename.concat t.path fn) + else + None + + let find_uncap t fn = + let fn = String.uncapitalize_ascii fn in + let search base = + if String.uncapitalize_ascii base = fn then + Some (Filename.concat t.path base) + else + None + in + List.find_map search 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 + +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string + +let dirs = s_ref [] +let no_auto_include _ _ = raise Not_found +let auto_include_callback = ref no_auto_include + +let reset () = + assert (not Config.merlin || Local_store.is_bound ()); + STbl.clear !files; + STbl.clear !files_uncap; + dirs := []; + auto_include_callback := no_auto_include + +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 ~auto_include l = + reset (); + dirs := List.rev_map Dir.create l; + List.iter prepend_add !dirs; + auto_include_callback := auto_include + +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 auto_include_libs libs alert find_in_dir fn = + let scan (lib, lazy dir) = + let file = find_in_dir dir fn in + let alert_and_add_dir _ = + alert lib; + append_dir dir + in + Option.iter alert_and_add_dir file; + file + in + match List.find_map scan libs with + | Some base -> base + | None -> raise Not_found + +let auto_include_otherlibs = + (* Ensure directories are only ever scanned once *) + let expand = Misc.expand_directory Config.standard_library in + let otherlibs = + let read_lib lib = lazy (Dir.create (expand ("+" ^ lib))) in + List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in + auto_include_libs otherlibs + +let find fn = + assert (not Config.merlin || Local_store.is_bound ()); + try + if is_basename fn && not !Sys.interactive then + STbl.find !files fn + else + Misc.find_in_path (get_paths ()) fn + with Not_found -> + !auto_include_callback Dir.find fn + +let find_uncap fn = + assert (not Config.merlin || Local_store.is_bound ()); + try + 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 + with Not_found -> + let fn_uncap = String.uncapitalize_ascii fn in + !auto_include_callback Dir.find_uncap fn_uncap diff --git a/upstream/ocaml_501/utils/load_path.mli b/upstream/ocaml_501/utils/load_path.mli new file mode 100644 index 0000000000..fe3abaf95d --- /dev/null +++ b/upstream/ocaml_501/utils/load_path.mli @@ -0,0 +1,96 @@ +(**************************************************************************) +(* *) +(* 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 *) + +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. *) + + val find : t -> string -> string option + (** [find dir fn] returns the full path to [fn] in [dir]. *) + + val find_uncap : t -> string -> string option + (** As {!find}, but search also for uncapitalized name, i.e. if name is + Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) +end + +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string +(** The type of callback functions on for [init ~auto_include] *) + +val no_auto_include : auto_include_callback +(** No automatic directory inclusion: misses in the load path raise [Not_found] + as normal. *) + +val init : auto_include:auto_include_callback -> string list -> unit +(** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *) + +val auto_include_otherlibs : + (string -> unit) -> auto_include_callback +(** [auto_include_otherlibs alert] is a callback function to be passed to + {!Load_path.init} and automatically adds [-I +lib] to the load path after + calling [alert lib]. *) + +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. *) + +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_501/utils/local_store.ml b/upstream/ocaml_501/utils/local_store.ml new file mode 100644 index 0000000000..4babf61d82 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/local_store.mli b/upstream/ocaml_501/utils/local_store.mli new file mode 100644 index 0000000000..3ea05d5889 --- /dev/null +++ b/upstream/ocaml_501/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 {!val:Stdlib.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_store 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 store is active (i.e. when called from the callback + passed to {!with_store}), [false] otherwise. *) diff --git a/upstream/ocaml_501/utils/misc.ml b/upstream/ocaml_501/utils/misc.ml new file mode 100644 index 0000000000..ad178c9217 --- /dev/null +++ b/upstream/ocaml_501/utils/misc.ml @@ -0,0 +1,1171 @@ +(**************************************************************************) +(* *) +(* 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.is_regular_file 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 + +(* [find_first_mono p] assumes that there exists a natural number + N such that [p] is false on [0; N[ and true on [N; max_int], and + returns this N. (See misc.mli for the detailed specification.) *) +let find_first_mono = + let rec find p ~low ~jump ~high = + (* Invariants: + [low, jump, high] are non-negative with [low < high], + [p low = false], + [p high = true]. *) + if low + 1 = high then high + (* ensure that [low + jump] is in ]low; high[ *) + else if jump < 1 then find p ~low ~jump:1 ~high + else if jump >= high - low then find p ~low ~jump:((high - low) / 2) ~high + else if p (low + jump) then + (* We jumped too high: continue with a smaller jump and lower limit *) + find p ~low:low ~jump:(jump / 2) ~high:(low + jump) + else + (* we jumped too low: + continue from [low + jump] with a larger jump *) + let next_jump = max jump (2 * jump) (* avoid overflows *) in + find p ~low:(low + jump) ~jump:next_jump ~high + in + fun p -> + if p 0 then 0 + else find p ~low:0 ~jump:1 ~high:max_int + +(* String operations *) + +let split_null_terminated s = + let[@tail_mod_cons] rec discard_last_sep = function + | [] | [""] -> [] + | x :: xs -> x :: discard_last_sep xs + in + discard_last_sep (String.split_on_char '\000' s) + +let concat_null_terminated = function + | [] -> "" + | l -> String.concat "\000" (l @ [""]) + +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 "@\n@{Hint@}: 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) + +let ordinal_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" + +(* 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; + hint:style list; + } + + let default_styles = { + warning = [Bold; FG Magenta]; + error = [Bold; FG Red]; + loc = [Bold]; + hint = [Bold; FG Blue]; + } + + 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 + | Format.String_tag "hint" -> (!cur_styles).hint + | 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 "@["; + 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 + +let print_see_manual ppf manual_section = + let open Format in + fprintf ppf "(see manual section %a)" + (pp_print_list ~pp_sep:(fun f () -> pp_print_char f '.') pp_print_int) + manual_section + + +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_501/utils/misc.mli b/upstream/ocaml_501/utils/misc.mli new file mode 100644 index 0000000000..6151f269ae --- /dev/null +++ b/upstream/ocaml_501/utils/misc.mli @@ -0,0 +1,781 @@ +(**************************************************************************) +(* *) +(* 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}. + +*) + +(** {1 Reporting fatal errors} *) + +val fatal_error: string -> 'a + (** Raise the [Fatal_error] exception with the given string. *) + +val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a + (** Format the arguments according to the given format string + and raise [Fatal_error] with the resulting string. *) + +exception Fatal_error + +(** {1 Exceptions and finalization} *) + +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. *) + +(** {1 List operations} *) + +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. *) + +(** {1 Hash table operations} *) + +val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t + (** Create a hashtable with the given initial size and fills it + with the given bindings. *) + +(** {1 Extensions to the standard library} *) + +module Stdlib : sig + +(** {2 Extensions to the List module} *) + 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 + +(** {2 Extensions to the Option module} *) + module Option : sig + type 'a t = 'a option + + val print + : (Format.formatter -> 'a -> unit) + -> Format.formatter + -> 'a t + -> unit + end + +(** {2 Extensions to the Array module} *) + module Array : sig + val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool + (** Same as [Array.exists2] from the standard library. *) + + val for_alli : (int -> 'a -> bool) -> 'a array -> bool + (** Same as [Array.for_all] from the standard library, 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 + +(** {2 Extensions to the String module} *) + 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 + +(** {1 Operations on files and file paths} *) + +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 and is a regular file. + Does nothing for other kinds of files. + Never raises 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 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 protect_writing_to_file + : filename:string + -> f:(out_channel -> 'a) + -> 'a + (** 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 concat_null_terminated : string list -> string +(** [concat_null_terminated [x1;x2; ... xn]] is + [x1 ^ "\000" ^ x2 ^ "\000" ^ ... ^ xn ^ "\000"] *) + +val split_null_terminated : string -> string list +(** [split_null_terminated s] is similar + [String.split_on_char '\000'] but ignores the trailing separator, if any *) + +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. *) + +(** {1 Integer operations} *) + +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 + (** Convert a string to an integer. Unlike {!Stdlib.int_of_string}, + this function accepts the string representation of [max_int + 1] + and returns [min_int] in this case. *) + + val int32 : string -> int32 + (** Likewise, at type [int32] *) + + val int64 : string -> int64 + (** Likewise, at type [int64] *) + + val nativeint : string -> nativeint + (** Likewise, at type [nativeint] *) + +end + +val find_first_mono : (int -> bool) -> int + (**[find_first_mono p] takes an integer predicate [p : int -> bool] + that we assume: + 1. is monotonic on natural numbers: + if [a <= b] then [p a] implies [p b], + 2. is satisfied for some natural numbers in range [0; max_int] + (this is equivalent to: [p max_int = true]). + + [find_first_mono p] is the smallest natural number N that satisfies [p], + computed in O(log(N)) calls to [p]. + + Our implementation supports two cases where the preconditions on [p] + are not respected: + - If [p] is always [false], we silently return [max_int] + instead of looping or crashing. + - If [p] is non-monotonic but eventually true, + we return some satisfying value. + *) + +(** {1 String operations} *) + +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 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 ordinal_suffix : int -> string +(** [ordinal_suffix n] is the appropriate suffix to append to the numeral [n] as + an ordinal number: [1] -> ["st"], [2] -> ["nd"], [3] -> ["rd"], + [4] -> ["th"], and so on. Handles larger numbers (e.g., [42] -> ["nd"]) and + the numbers 11--13 (which all get ["th"]) correctly. *) + +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. *) + +(** {1 Operations on references} *) + +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. +*) + +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]. *) + +(** {1 Operations on triples and quadruples} *) + +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 + +(** {1 Long strings} *) + +(** ``Long strings'' are mutable arrays of characters that are not limited + in length to {!Sys.max_string_length}. *) + +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 + +(** {1 Spell checking and ``did you mean'' suggestions} *) + +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. +*) + +(** {1 Colored terminal output } *) + +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; + hint: 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 + +(** {1 Formatted output} *) + +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. *) + +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} +*) + +val print_see_manual : Format.formatter -> int list -> unit +(** See manual section *) + +(** {1 Displaying configuration variables} *) + +val show_config_and_exit : unit -> unit + (** Display the values of all compiler configuration variables from module + [Config], then exit the program with code 0. *) + +val show_config_variable_and_exit : string -> unit + (** Display the value of the given configuration variable, + then exit the program with code 0. *) + +(** {1 Handling of build maps} *) + +(** Build maps cause the compiler to normalize file names embedded in + object files, thus leading to more reproducible builds. *) + +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. *) + +(** {1 Handling of magic numbers} *) + +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 + *) + + 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 + +(** {1 Miscellaneous type aliases} *) + +type filepath = string +type modname = string +type crcs = (modname * Digest.t option) list + +type alerts = string Stdlib.String.Map.t diff --git a/upstream/ocaml_501/utils/numbers.ml b/upstream/ocaml_501/utils/numbers.ml new file mode 100644 index 0000000000..1680675bab --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/numbers.mli b/upstream/ocaml_501/utils/numbers.mli new file mode 100644 index 0000000000..fa565e67e1 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/profile.ml b/upstream/ocaml_501/utils/profile.ml new file mode 100644 index 0000000000..27c92a5463 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/profile.mli b/upstream/ocaml_501/utils/profile.mli new file mode 100644 index 0000000000..7eff6957b6 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/strongly_connected_components.ml b/upstream/ocaml_501/utils/strongly_connected_components.ml new file mode 100644 index 0000000000..eb1501ca7c --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/strongly_connected_components.mli b/upstream/ocaml_501/utils/strongly_connected_components.mli new file mode 100644 index 0000000000..e700952792 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/targetint.ml b/upstream/ocaml_501/utils/targetint.ml new file mode 100644 index 0000000000..9d15a2ff56 --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/targetint.mli b/upstream/ocaml_501/utils/targetint.mli new file mode 100644 index 0000000000..a222f5d68c --- /dev/null +++ b/upstream/ocaml_501/utils/targetint.mli @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* 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 +(** [abs x] is the absolute value of [x]. On [min_int] this + is [min_int] itself and thus remains negative. *) + +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_501/utils/terminfo.ml b/upstream/ocaml_501/utils/terminfo.ml new file mode 100644 index 0000000000..1b4a3578eb --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/terminfo.mli b/upstream/ocaml_501/utils/terminfo.mli new file mode 100644 index 0000000000..10f5f5453f --- /dev/null +++ b/upstream/ocaml_501/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_501/utils/warnings.ml b/upstream/ocaml_501/utils/warnings.ml new file mode 100644 index 0000000000..65721fe1b0 --- /dev/null +++ b/upstream/ocaml_501/utils/warnings.ml @@ -0,0 +1,1239 @@ +(**************************************************************************) +(* *) +(* 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 *) + was turned into a hard error *) + | 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 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) + +(* 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 + | 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 + | Unused_tmc_attribute -> 71 + | Tmc_breaks_tailcall -> 72 + | Generative_application_expects_unit -> 73 +;; +(* DO NOT REMOVE the ;; above: it is used by + the testsuite/ests/warnings/mnemonics.mll test to determine where + the definition of the number function above ends *) + +let last_warning_number = 73 + +type description = + { number : int; + names : string list; + (* 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. *) + description : string; + since : Sys.ocaml_release_info option; + (* The compiler version introducing this warning; only tagged for warnings + created after 3.12, which introduced the numbered syntax. *) + } + +let since major minor = Some { Sys.major; minor; patchlevel=0; extra=None } + +let descriptions = [ + { number = 1; + names = ["comment-start"]; + description = "Suspicious-looking start-of-comment mark."; + since = None }; + { number = 2; + names = ["comment-not-end"]; + description = "Suspicious-looking end-of-comment mark."; + since = None }; + { number = 3; + names = []; + description = "Deprecated synonym for the 'deprecated' alert."; + since = None }; + { number = 4; + names = ["fragile-match"]; + description = + "Fragile pattern matching: matching that will remain complete even\n\ + \ if additional constructors are added to one of the variant types\n\ + \ matched."; + since = None }; + { number = 5; + names = ["ignored-partial-application"]; + description = + "Partially applied function: expression whose result has function\n\ + \ type and is ignored."; + since = None }; + { number = 6; + names = ["labels-omitted"]; + description = "Label omitted in function application."; + since = None }; + { number = 7; + names = ["method-override"]; + description = "Method overridden."; + since = None }; + { number = 8; + names = ["partial-match"]; + description = "Partial match: missing cases in pattern-matching."; + since = None }; + { number = 9; + names = ["missing-record-field-pattern"]; + description = "Missing fields in a record pattern."; + since = None }; + { number = 10; + names = ["non-unit-statement"]; + description = + "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)."; + since = None }; + { number = 11; + names = ["redundant-case"]; + description = + "Redundant case in a pattern matching (unused match case)."; + since = None }; + { number = 12; + names = ["redundant-subpat"]; + description = "Redundant sub-pattern in a pattern-matching." ; + since = None}; + { number = 13; + names = ["instance-variable-override"]; + description = "Instance variable overridden."; + since = None }; + { number = 14; + names = ["illegal-backslash"]; + description = "Illegal backslash escape in a string constant."; + since = None }; + { number = 15; + names = ["implicit-public-methods"]; + description = "Private method made public implicitly."; + since = None }; + { number = 16; + names = ["unerasable-optional-argument"]; + description = "Unerasable optional argument."; + since = None }; + { number = 17; + names = ["undeclared-virtual-method"]; + description = "Undeclared virtual method."; + since = None }; + { number = 18; + names = ["not-principal"]; + description = "Non-principal type."; + since = None }; + { number = 19; + names = ["non-principal-labels"]; + description = "Type without principality."; + since = None }; + { number = 20; + names = ["ignored-extra-argument"]; + description = "Unused function argument."; + since = None }; + { number = 21; + names = ["nonreturning-statement"]; + description = "Non-returning statement."; + since = None }; + { number = 22; + names = ["preprocessor"]; + description = "Preprocessor warning."; + since = None }; + { number = 23; + names = ["useless-record-with"]; + description = "Useless record \"with\" clause."; + since = None }; + { number = 24; + names = ["bad-module-name"]; + description = + "Bad module name: the source file name is not a valid OCaml module name."; + since = None }; + { number = 25; + names = []; + description = "Ignored: now part of warning 8."; + since = None }; + { number = 26; + names = ["unused-var"]; + description = + "Suspicious unused variable: unused variable that is bound\n\ + \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character."; + since = None }; + { number = 27; + names = ["unused-var-strict"]; + description = + "Innocuous unused variable: unused variable that is not bound with\n\ + \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character."; + since = None }; + { number = 28; + names = ["wildcard-arg-to-constant-constr"]; + description = + "Wildcard pattern given as argument to a constant constructor."; + since = None }; + { number = 29; + names = ["eol-in-string"]; + description = + "Unescaped end-of-line in a string constant (non-portable code)."; + since = None }; + { number = 30; + names = ["duplicate-definitions"]; + description = + "Two labels or constructors of the same name are defined in two\n\ + \ mutually recursive types."; + since = None }; + { number = 31; + names = ["module-linked-twice"]; + description = + "A module is linked twice in the same executable.\n\ + \ Ignored: now a hard error (since 5.1)."; + since = None }; + { number = 32; + names = ["unused-value-declaration"]; + description = "Unused value declaration."; + since = since 4 0 }; + { number = 33; + names = ["unused-open"]; + description = "Unused open statement."; + since = since 4 0 }; + { number = 34; + names = ["unused-type-declaration"]; + description = "Unused type declaration."; + since = since 4 0 }; + { number = 35; + names = ["unused-for-index"]; + description = "Unused for-loop index."; + since = since 4 0 }; + { number = 36; + names = ["unused-ancestor"]; + description = "Unused ancestor variable."; + since = since 4 0 }; + { number = 37; + names = ["unused-constructor"]; + description = "Unused constructor."; + since = since 4 0 }; + { number = 38; + names = ["unused-extension"]; + description = "Unused extension constructor."; + since = since 4 0 }; + { number = 39; + names = ["unused-rec-flag"]; + description = "Unused rec flag."; + since = since 4 0 }; + { number = 40; + names = ["name-out-of-scope"]; + description = "Constructor or label name used out of scope."; + since = since 4 1 }; + { number = 41; + names = ["ambiguous-name"]; + description = "Ambiguous constructor or label name."; + since = since 4 1 }; + { number = 42; + names = ["disambiguated-name"]; + description = + "Disambiguated constructor or label name (compatibility warning)."; + since = since 4 1 }; + { number = 43; + names = ["nonoptional-label"]; + description = "Nonoptional label applied as optional."; + since = since 4 1 }; + { number = 44; + names = ["open-shadow-identifier"]; + description = "Open statement shadows an already defined identifier."; + since = since 4 1 }; + { number = 45; + names = ["open-shadow-label-constructor"]; + description = + "Open statement shadows an already defined label or constructor."; + since = since 4 1 }; + { number = 46; + names = ["bad-env-variable"]; + description = "Error in environment variable."; + since = since 4 1 }; + { number = 47; + names = ["attribute-payload"]; + description = "Illegal attribute payload."; + since = since 4 2 }; + { number = 48; + names = ["eliminated-optional-arguments"]; + description = "Implicit elimination of optional arguments."; + since = since 4 2 }; + { number = 49; + names = ["no-cmi-file"]; + description = "Absent cmi file when looking up module alias."; + since = since 4 2 }; + { number = 50; + names = ["unexpected-docstring"]; + description = "Unexpected documentation comment."; + since = since 4 3 }; + { number = 51; + names = ["wrong-tailcall-expectation"]; + description = + "Function call annotated with an incorrect @tailcall attribute."; + since = since 4 3 }; + { number = 52; + names = ["fragile-literal-pattern"]; + description = "Fragile constant pattern."; + since = since 4 3 }; + { number = 53; + names = ["misplaced-attribute"]; + description = "Attribute cannot appear in this context."; + since = since 4 3 }; + { number = 54; + names = ["duplicated-attribute"]; + description = "Attribute used more than once on an expression."; + since = since 4 3 }; + { number = 55; + names = ["inlining-impossible"]; + description = "Inlining impossible."; + since = since 4 3 }; + { number = 56; + names = ["unreachable-case"]; + description = + "Unreachable case in a pattern-matching (based on type information)."; + since = since 4 3 }; + { number = 57; + names = ["ambiguous-var-in-pattern-guard"]; + description = "Ambiguous or-pattern variables under guard."; + since = since 4 3 }; + { number = 58; + names = ["no-cmx-file"]; + description = "Missing cmx file."; + since = since 4 3 }; + { number = 59; + names = ["flambda-assignment-to-non-mutable-value"]; + description = "Assignment to non-mutable value."; + since = since 4 3 }; + { number = 60; + names = ["unused-module"]; + description = "Unused module declaration."; + since = since 4 4 }; + { number = 61; + names = ["unboxable-type-in-prim-decl"]; + description = "Unboxable type in primitive declaration."; + since = since 4 4 }; + { number = 62; + names = ["constraint-on-gadt"]; + description = "Type constraint on GADT type declaration."; + since = since 4 6 }; + { number = 63; + names = ["erroneous-printed-signature"]; + description = "Erroneous printed signature."; + since = since 4 8 }; + { number = 64; + names = ["unsafe-array-syntax-without-parsing"]; + description = + "-unsafe used with a preprocessor returning a syntax tree."; + since = since 4 8 }; + { number = 65; + names = ["redefining-unit"]; + description = "Type declaration defining a new '()' constructor."; + since = since 4 8 }; + { number = 66; + names = ["unused-open-bang"]; + description = "Unused open! statement."; + since = since 4 8 }; + { number = 67; + names = ["unused-functor-parameter"]; + description = "Unused functor parameter."; + since = since 4 10 }; + { number = 68; + names = ["match-on-mutable-state-prevent-uncurry"]; + description = + "Pattern-matching depending on mutable state prevents the remaining \n\ + \ arguments from being uncurried."; + since = since 4 12 }; + { number = 69; + names = ["unused-field"]; + description = "Unused record field."; + since = since 4 13 }; + { number = 70; + names = ["missing-mli"]; + description = "Missing interface file."; + since = since 4 13 }; + { number = 71; + names = ["unused-tmc-attribute"]; + description = "Unused @tail_mod_cons attribute."; + since = since 4 14 }; + { number = 72; + names = ["tmc-breaks-tailcall"]; + description = "A tail call is turned into a non-tail call \ + by the @tail_mod_cons transformation."; + since = since 4 14 }; + { number = 73; + names = ["generative-application-expects-unit"]; + description = "A generative functor is applied to an empty structure \ + (struct end) rather than to ()."; + since = since 5 1 }; +] + +let name_to_number = + let h = Hashtbl.create last_warning_number in + List.iter (fun {number; names; _} -> + List.iter (fun name -> Hashtbl.add h name number) 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); + 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 with_state state f = + let prev = backup () in + restore state; + try + let r = f () in + restore prev; + r + with exn -> + restore prev; + raise exn + +let mk_lazy f = + let state = backup () in + lazy (with_state state f) + +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 ghost_loc_in_file name = + let pos = { Lexing.dummy_pos with pos_fname = name } in + { loc_start = pos; loc_end = pos; loc_ghost = true } + +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 nowhere = ghost_loc_in_file "_none_" 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 + "@[@[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" +let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] + +let () = ignore @@ parse_options false defaults_w +let () = ignore @@ parse_options true defaults_warn_error +let () = + List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts + +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." + | Instance_variable_override (cname :: slist) -> + String.concat " " + ("the following instance variables are overridden by the class" + :: cname :: ":\n " :: slist) + | Instance_variable_override [] -> assert false + | Illegal_backslash -> + "illegal backslash escape in string.\n\ + Hint: Single backslashes \\ are reserved for escape sequences\n\ + (\\n, \\r, ...). Did you check the list of OCaml escape sequences?\n\ + To get a backslash character, escape it with a second backslash: \\\\." + | 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 + | 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 -> + let[@manual.ref "ss:warn52"] ref_manual = [ 13; 5; 3 ] in + Format.asprintf + "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. %a" + Misc.print_see_manual ref_manual + | Unreachable_case -> + "this match case is unreachable.\n\ + Consider replacing it with a refutation case ' -> .'" + | 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[@manual.ref "ss:warn57"] ref_manual = [ 13; 5; 4 ] in + let vars = List.sort String.compare vars in + let vars_explanation = + let in_different_places = + "in different places in different or-pattern alternatives" + in + match vars with + | [] -> assert false + | [x] -> "variable " ^ x ^ " appears " ^ in_different_places + | _::_ -> + let vars = String.concat ", " vars in + "variables " ^ vars ^ " appear " ^ in_different_places + in + Format.asprintf + "Ambiguous or-pattern variables under guard;\n\ + %s.\n\ + Only the first match will be used to evaluate the guard expression.\n\ + %a" + vars_explanation Misc.print_see_manual ref_manual + | 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." + | Unused_tmc_attribute -> + "This function is marked @tail_mod_cons\n\ + but is never applied in TMC position." + | Tmc_breaks_tailcall -> + "This call\n\ + is in tail-modulo-cons position in a TMC function,\n\ + but the function called is not itself specialized for TMC,\n\ + so the call will not be transformed into a tail call.\n\ + Please either mark the called function with the [@tail_mod_cons]\n\ + attribute, or mark this call with the [@tailcall false] attribute\n\ + to make its non-tailness explicit." + | Generative_application_expects_unit -> + "A generative functor\n\ + should be applied to '()'; using '(struct end)' is deprecated." +;; + +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 {number; _} -> number = n) descriptions with + | Some {names = 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 pp_since out release_info = + Printf.fprintf out " (since %d.%0*d)" + release_info.Sys.major + (if release_info.Sys.major >= 5 then 0 else 2) + release_info.Sys.minor + +let help_warnings () = + List.iter + (fun {number; description; names; since} -> + let name = + match names with + | s :: _ -> " [" ^ s ^ "]" + | [] -> "" + in + Printf.printf "%3i%s %s%a\n" + number name description (fun out -> Option.iter (pp_since out)) since) + 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_501/utils/warnings.mli b/upstream/ocaml_501/utils/warnings.mli new file mode 100644 index 0000000000..8af3d53b43 --- /dev/null +++ b/upstream/ocaml_501/utils/warnings.mli @@ -0,0 +1,166 @@ +(**************************************************************************) +(* *) +(* 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; +} + +val ghost_loc_in_file : string -> loc +(** Return an empty ghost range located in a given file *) + +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 *) + | 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 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) + +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 with_state : state -> (unit -> 'a) -> 'a +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. *) + +type description = + { number : int; + names : string list; + description : string; + since : Sys.ocaml_release_info option; } + +val descriptions : description list From e215a13c9356657cdac077c13914bd9339aab565 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 17 Apr 2023 18:02:44 -0300 Subject: [PATCH 045/130] Apply changes to vendored compiler --- src/analysis/completion.mli | 2 +- src/analysis/destruct.ml | 81 +- src/analysis/locate.ml | 8 +- src/analysis/locate.mli | 5 +- src/analysis/namespace.ml | 34 + src/analysis/namespace.mli | 15 + src/analysis/namespaced_path.ml | 133 - src/analysis/namespaced_path.mli | 49 - src/analysis/ptyp_of_type.ml | 6 +- src/analysis/type_utils.ml | 3 +- src/config/gen_config.ml | 2 +- src/ocaml/merlin_specific/browse_raw.ml | 4 +- src/ocaml/merlin_specific/typer_raw.ml | 548 - src/ocaml/merlin_specific/typer_raw.mli | 6 - src/ocaml/parsing/ast_helper.ml | 9 +- src/ocaml/parsing/ast_helper.mli | 5 +- src/ocaml/parsing/ast_iterator.ml | 15 +- src/ocaml/parsing/ast_mapper.ml | 17 +- src/ocaml/parsing/location.ml | 183 +- src/ocaml/parsing/location.mli | 90 +- src/ocaml/parsing/parsetree.mli | 22 +- src/ocaml/parsing/pprintast.ml | 83 +- src/ocaml/parsing/printast.ml | 18 + src/ocaml/preprocess/parser_raw.ml | 9585 +++++++++-------- src/ocaml/preprocess/parser_raw.mli | 6 +- src/ocaml/preprocess/parser_raw.mly | 80 +- src/ocaml/preprocess/parser_recover.ml | 4609 ++++---- src/ocaml/typing/btype.ml | 1 + src/ocaml/typing/btype.mli | 1 + src/ocaml/typing/ctype.ml | 896 +- src/ocaml/typing/ctype.mli | 80 +- src/ocaml/typing/datarepr.ml | 4 +- src/ocaml/typing/env.ml | 273 +- src/ocaml/typing/env.mli | 20 +- src/ocaml/typing/ident.ml | 15 + src/ocaml/typing/ident.mli | 1 + src/ocaml/typing/includecore.ml | 39 +- src/ocaml/typing/includecore.mli | 10 +- src/ocaml/typing/includemod.ml | 165 +- src/ocaml/typing/includemod.mli | 3 + src/ocaml/typing/includemod_errorprinter.ml | 7 +- src/ocaml/typing/magic_numbers.ml | 1 + src/ocaml/typing/mtype.ml | 10 +- src/ocaml/typing/oprint.ml | 42 +- src/ocaml/typing/oprint.mli | 1 + src/ocaml/typing/outcometree.mli | 9 +- src/ocaml/typing/parmatch.ml | 193 +- src/ocaml/typing/parmatch.mli | 42 +- src/ocaml/typing/path.ml | 87 +- src/ocaml/typing/path.mli | 48 +- src/ocaml/typing/persistent_env.ml | 2 +- src/ocaml/typing/printtyp.ml | 684 +- src/ocaml/typing/printtyp.mli | 24 +- src/ocaml/typing/printtyped.ml | 9 +- src/ocaml/typing/rec_check.ml | 10 +- src/ocaml/typing/shape.ml | 21 +- src/ocaml/typing/short_paths.ml | 1 + src/ocaml/typing/short_paths_graph.ml | 55 +- src/ocaml/typing/short_paths_graph.mli | 1 + src/ocaml/typing/signature_group.ml | 8 +- src/ocaml/typing/subst.ml | 27 +- src/ocaml/typing/tast_iterator.ml | 314 +- src/ocaml/typing/tast_iterator.mli | 3 + src/ocaml/typing/tast_mapper.ml | 294 +- src/ocaml/typing/tast_mapper.mli | 3 + src/ocaml/typing/typeclass.ml | 464 +- src/ocaml/typing/typeclass.mli | 16 +- src/ocaml/typing/typecore.ml | 3242 +++--- src/ocaml/typing/typecore.mli | 25 +- src/ocaml/typing/typedecl.ml | 796 +- src/ocaml/typing/typedecl.mli | 11 +- src/ocaml/typing/typedecl_immediacy.ml | 2 +- src/ocaml/typing/typedecl_variance.ml | 232 +- src/ocaml/typing/typedecl_variance.mli | 30 +- src/ocaml/typing/typedtree.ml | 20 +- src/ocaml/typing/typedtree.mli | 10 +- src/ocaml/typing/typemod.ml | 320 +- src/ocaml/typing/typemod.mli | 5 +- src/ocaml/typing/types.ml | 61 +- src/ocaml/typing/types.mli | 11 +- src/ocaml/typing/typetexp.ml | 702 +- src/ocaml/typing/typetexp.mli | 58 +- src/ocaml/typing/untypeast.ml | 21 +- src/ocaml/utils/build_path_prefix_map.ml | 29 +- src/ocaml/utils/build_path_prefix_map.mli | 18 +- src/ocaml/utils/clflags.ml | 2 +- src/ocaml/utils/config.ml | 24 +- src/ocaml/utils/consistbl.ml | 2 - src/ocaml/utils/consistbl.mli | 5 - src/ocaml/utils/warnings.ml | 55 +- src/ocaml/utils/warnings.mli | 2 +- src/utils/misc.ml | 52 +- src/utils/misc.mli | 74 +- tests/test-dirs/completion/kind.t/run.t | 2 + tests/test-dirs/destruct/from_val.t | 20 +- tests/test-dirs/dune | 9 +- tests/test-dirs/errors/undefined-meth.t | 13 + .../locate-state/reset-file-switching.t | 2 +- .../server-tests/typer-cache/stamps.t/run.t | 20 +- tests/test-dirs/short-paths.t/run.t | 37 +- tests/test-dirs/type-expr.t/run.t | 16 +- tests/test-dirs/typing-recovery.t | 114 +- 102 files changed, 13434 insertions(+), 12110 deletions(-) create mode 100644 src/analysis/namespace.ml create mode 100644 src/analysis/namespace.mli delete mode 100644 src/analysis/namespaced_path.ml delete mode 100644 src/analysis/namespaced_path.mli create mode 100644 tests/test-dirs/errors/undefined-meth.t diff --git a/src/analysis/completion.mli b/src/analysis/completion.mli index 8cc348526d..74e68e6971 100644 --- a/src/analysis/completion.mli +++ b/src/analysis/completion.mli @@ -52,7 +52,7 @@ val map_entry : ('a -> 'b) -> val branch_complete : Mconfig.t - -> ?get_doc:([> `Completion_entry of Namespaced_path.Namespace.t + -> ?get_doc:([> `Completion_entry of Namespace.t * Path.t * Location.t ] -> [> `Found of string ]) -> ?target_type:Types.type_expr -> ?kinds:Compl.kind list diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index 740e281a8e..895d6c2311 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -122,7 +122,7 @@ let rec gen_patterns ?(recurse=true) env type_expr = try ignore ( Ctype.unify_gadt ~equations_level:0 - ~allow_recursive:true (* really? *) + ~allow_recursive_equations:true (* really? *) (ref env) type_expr typ ); true @@ -398,16 +398,14 @@ let rec qualify_constructors ~unmangling_tables f 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) -> + let (_, labels) = unmangling_tables in (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)) + | None -> (lid, lbl_des, pat))) in let closed = if List.length labels > 0 then @@ -423,12 +421,11 @@ let rec qualify_constructors ~unmangling_tables f pat = match lid.Asttypes.txt with | Longident.Lident name -> (* Un-mangle *) - let name = match unmangling_tables with - | Some (constrs, _) -> + let name = + let constrs, _ = unmangling_tables in (match Hashtbl.find_opt constrs name with | Some cstr_des -> cstr_des.Types.cstr_name | None -> name) - | None -> name in begin match Types.get_desc pat.pat_type with | Types.Tconstr (path, _, _) -> @@ -500,6 +497,70 @@ let print_pretty ?punned_field config source subject = | Some label -> label.Types.lbl_name ^ " = " ^ result +(* conversion from Typedtree.pattern to Parsetree.pattern list *) +module Conv = struct + open Asttypes + open Types + open Typedtree + 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 ~f: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 ~f: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 ~f:loop p_opt in + mkpat (Ppat_variant(label, arg)) + | Tpat_record (subpatterns, _closed_flag) -> + let fields = + List.map + ~f:(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 ~f:loop lst)) + | Tpat_lazy p -> + mkpat (Ppat_lazy (loop p)) + in + let ps = loop typed in + (ps, constrs, labels) +end + let destruct_expression loc config source parents expr = let ty = expr.Typedtree.exp_type in let pexp = filter_expr_attr (Untypeast.untype_expression expr) in @@ -525,7 +586,9 @@ let destruct_expression loc config source parents expr = let refine_partial_match last_case_loc config source patterns = - let cases = List.map patterns ~f:(fun (pat, unmangling_tables) -> + let cases = List.map patterns ~f:(fun pat -> + let _pat, constrs, labels = Conv.conv pat in + let unmangling_tables = constrs, labels in (* Unmangling and prefixing *) let pat = qualify_constructors ~unmangling_tables Printtyp.shorten_type_path pat in diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 44236c0df5..177bc3c8b5 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -596,9 +596,11 @@ let find_source ~config loc path = matches) module Namespace = struct + type all = Namespace.t + type under_type = [ `Constr | `Labels ] - type t = (* TODO: share with [Namespaced_path.Namespace.t] *) + type t =(* TODO: share with [Namespace.t] *) [ `Type | `Mod | `Modtype | `Vals | under_type ] type inferred = @@ -622,7 +624,7 @@ module Env_lookup : sig val loc : Path.t - -> Namespaced_path.Namespace.t + -> Namespace.all -> Env.t -> (Location.t * Shape.Uid.t * Shape.Sig_component_kind.t) option @@ -634,7 +636,7 @@ module Env_lookup : sig end = struct - let loc path (namespace : Namespaced_path.Namespace.t) env = + let loc path (namespace : Namespace.all) env = try Some ( match namespace with diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli index 581d75c294..b4a6145bec 100644 --- a/src/analysis/locate.mli +++ b/src/analysis/locate.mli @@ -29,13 +29,14 @@ val log : 'a Logger.printf module Namespace : sig + type all = Namespace.t type t = [ `Type | `Mod | `Modtype | `Vals | `Constr | `Labels ] end val from_path : config:Mconfig.t -> env:Env.t - -> namespace:Namespaced_path.Namespace.t + -> namespace:Namespace.all -> [ `ML | `MLI ] -> Path.t -> [> `File_not_found of string @@ -68,7 +69,7 @@ val get_doc -> pos:Lexing.position -> [ `User_input of string | `Completion_entry of - Namespaced_path.Namespace.t * Path.t * Location.t ] + Namespace.all * Path.t * Location.t ] -> [> `File_not_found of string | `Found of string | `Builtin of string diff --git a/src/analysis/namespace.ml b/src/analysis/namespace.ml new file mode 100644 index 0000000000..6088dfb6da --- /dev/null +++ b/src/analysis/namespace.ml @@ -0,0 +1,34 @@ +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)" + diff --git a/src/analysis/namespace.mli b/src/analysis/namespace.mli new file mode 100644 index 0000000000..28b938c6af --- /dev/null +++ b/src/analysis/namespace.mli @@ -0,0 +1,15 @@ +type t = [ + | `Vals + | `Type + | `Constr + | `Mod + | `Modtype + | `Functor + | `Labels + | `Unknown + | `Apply +] + +val to_tag_string : t -> string + +val to_string : t -> string diff --git a/src/analysis/namespaced_path.ml b/src/analysis/namespaced_path.ml deleted file mode 100644 index 2ade36f4c7..0000000000 --- a/src/analysis/namespaced_path.ml +++ /dev/null @@ -1,133 +0,0 @@ -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 deleted file mode 100644 index 4e4a75cec2..0000000000 --- a/src/analysis/namespaced_path.mli +++ /dev/null @@ -1,49 +0,0 @@ -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/ptyp_of_type.ml b/src/analysis/ptyp_of_type.ml index 3f76d4c704..3163de99a6 100644 --- a/src/analysis/ptyp_of_type.ml +++ b/src/analysis/ptyp_of_type.ml @@ -152,7 +152,7 @@ and type_declaration id { = 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 pos, neg, inj = Types.Variance.get_lower variance in let v = if pos then Asttypes.Covariant else (if neg then Contravariant else NoVariance) @@ -228,9 +228,9 @@ and group_items (items : Types.signature_item list) = | 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 -> + | Sig_class _ as item :: _ :: _ :: rest -> group (Item item :: acc) rest - | Sig_class_type _ as item :: _ :: _ :: rest -> + | Sig_class_type _ as item :: _ :: rest -> group (Item item :: acc) rest | item :: rest -> group (Item item :: acc) rest | [] -> List.rev acc diff --git a/src/analysis/type_utils.ml b/src/analysis/type_utils.ml index 8ad734bd83..e3fb86e759 100644 --- a/src/analysis/type_utils.ml +++ b/src/analysis/type_utils.ml @@ -234,8 +234,9 @@ let print_type_with_decl ~verbosity env ppf typ = end; let ident = match path with | Path.Papply _ -> assert false - | Path.Pdot _ -> Ident.create_persistent (Path.last path) | Path.Pident ident -> ident + | Path.Pdot _ | Path.Pextra_ty _ -> + Ident.create_persistent (Path.last path) in Printtyp.type_declaration env ident ppf decl end diff --git a/src/config/gen_config.ml b/src/config/gen_config.ml index 56d0c0cb7a..1e42ebf8f3 100644 --- a/src/config/gen_config.ml +++ b/src/config/gen_config.ml @@ -17,5 +17,5 @@ let ocamlversion : | `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 - | `OCaml_4_14_0 | `OCaml_5_0_0 ] = %s + | `OCaml_4_14_0 | `OCaml_5_0_0 | `OCaml_5_1_0 ] = %s |} ocaml_version_val diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml index 88caa4bed6..057e6c8d8b 100644 --- a/src/ocaml/merlin_specific/browse_raw.ml +++ b/src/ocaml/merlin_specific/browse_raw.ml @@ -341,7 +341,7 @@ let of_expression_desc loc = function | 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) -> + | Texp_assert (e, _) | Texp_lazy e | Texp_setinstvar (_,_,_,e) -> of_expression e | Texp_record { fields; extended_expression } -> option_fold of_expression extended_expression ** @@ -445,6 +445,8 @@ and of_module_expr_desc = function | Tmod_apply (me1,me2,_) -> of_module_expr me1 ** of_module_expr me2 + | Tmod_apply_unit (me1) -> + of_module_expr me1 | Tmod_constraint (me,_,mtc,_) -> of_module_expr me ** app (Module_type_constraint mtc) diff --git a/src/ocaml/merlin_specific/typer_raw.ml b/src/ocaml/merlin_specific/typer_raw.ml index a880159c79..26926f6688 100644 --- a/src/ocaml/merlin_specific/typer_raw.ml +++ b/src/ocaml/merlin_specific/typer_raw.ml @@ -27,8 +27,6 @@ )* }}} *) open Std -open Location -open Parsetree let fresh_env () = (*Ident.reinit();*) @@ -42,549 +40,3 @@ let fresh_env () = ~loc:(Location.in_file "command line") ~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_vars; pcd_args; pcd_res; pcd_loc; pcd_attributes} = - enter (); - let pcd_name = u_loc pcd_name in - let pcd_vars = List.map ~f:u_loc pcd_vars 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_vars; 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 (locs, cargs, cto) -> - Pext_decl (List.map ~f:u_loc locs, - 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 index 669bdf1dd7..b6550aa7b6 100644 --- a/src/ocaml/merlin_specific/typer_raw.mli +++ b/src/ocaml/merlin_specific/typer_raw.mli @@ -27,9 +27,3 @@ )* }}} *) 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 index 06a47bb48e..ce4c27234c 100644 --- a/src/ocaml/parsing/ast_helper.ml +++ b/src/ocaml/parsing/ast_helper.ml @@ -259,8 +259,8 @@ module Mty = struct end module Mod = struct -let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} + 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) @@ -268,6 +268,7 @@ let mk ?(loc = !default_loc) ?(attrs = []) d = 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 apply_unit ?loc ?attrs m1 = mk ?loc ?attrs (Pmod_apply_unit m1) 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) @@ -499,10 +500,11 @@ end module Vb = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = + ?(text = []) ?value_constraint pat expr = { pvb_pat = pat; pvb_expr = expr; + pvb_constraint=value_constraint; pvb_attributes = add_text_attrs text (add_docs_attrs docs attrs); pvb_loc = loc; @@ -665,6 +667,7 @@ end type let_binding = { lb_pattern: pattern; lb_expression: expression; + lb_constraint: value_constraint option; lb_is_pun: bool; lb_attributes: attributes; lb_docs: docs Lazy.t; diff --git a/src/ocaml/parsing/ast_helper.mli b/src/ocaml/parsing/ast_helper.mli index cfa37629df..8ac40ed7c2 100644 --- a/src/ocaml/parsing/ast_helper.mli +++ b/src/ocaml/parsing/ast_helper.mli @@ -277,6 +277,7 @@ module Mod: functor_parameter -> module_expr -> module_expr val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> module_expr + val apply_unit: ?loc:loc -> ?attrs:attrs -> 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 @@ -376,7 +377,8 @@ module Incl: module Vb: sig val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding + ?value_constraint:value_constraint -> pattern -> expression -> + value_binding end @@ -507,6 +509,7 @@ module Of: type let_binding = { lb_pattern: pattern; lb_expression: expression; + lb_constraint: value_constraint option; lb_is_pun: bool; lb_attributes: attributes; lb_docs: docs Lazy.t; diff --git a/src/ocaml/parsing/ast_iterator.ml b/src/ocaml/parsing/ast_iterator.ml index 468baedce0..2398e772d1 100644 --- a/src/ocaml/parsing/ast_iterator.ml +++ b/src/ocaml/parsing/ast_iterator.ml @@ -313,7 +313,10 @@ module M = struct iter_functor_param sub param; sub.module_expr sub body | Pmod_apply (m1, m2) -> - sub.module_expr sub m1; sub.module_expr sub m2 + sub.module_expr sub m1; + sub.module_expr sub m2 + | Pmod_apply_unit m1 -> + sub.module_expr sub m1 | Pmod_constraint (m, mty) -> sub.module_expr sub m; sub.module_type sub mty | Pmod_unpack e -> sub.expr sub e @@ -632,9 +635,17 @@ let default_iterator = value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc; pvb_constraint} -> this.pat this pvb_pat; this.expr this pvb_expr; + Option.iter (function + | Parsetree.Pvc_constraint {locally_abstract_univars=vars; typ} -> + List.iter (iter_loc this) vars; + this.typ this typ + | Pvc_coercion { ground; coercion } -> + Option.iter (this.typ this) ground; + this.typ this coercion; + ) pvb_constraint; this.location this pvb_loc; this.attributes this pvb_attributes ); diff --git a/src/ocaml/parsing/ast_mapper.ml b/src/ocaml/parsing/ast_mapper.ml index d7ad7d2d0d..12d9018880 100644 --- a/src/ocaml/parsing/ast_mapper.ml +++ b/src/ocaml/parsing/ast_mapper.ml @@ -350,6 +350,8 @@ module M = struct (sub.module_expr sub body) | Pmod_apply (m1, m2) -> apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) + | Pmod_apply_unit m1 -> + apply_unit ~loc ~attrs (sub.module_expr sub m1) | Pmod_constraint (m, mty) -> constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) @@ -691,10 +693,23 @@ let default_mapper = value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> + (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc} -> + let map_ct (ct:Parsetree.value_constraint) = match ct with + | Pvc_constraint {locally_abstract_univars=vars; typ} -> + Pvc_constraint + { locally_abstract_univars = List.map (map_loc this) vars; + typ = this.typ this typ + } + | Pvc_coercion { ground; coercion } -> + Pvc_coercion { + ground = Option.map (this.typ this) ground; + coercion = this.typ this coercion + } + in Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + ?value_constraint:(Option.map map_ct pvb_constraint) ~loc:(this.location this pvb_loc) ~attrs:(this.attributes this pvb_attributes) ); diff --git a/src/ocaml/parsing/location.ml b/src/ocaml/parsing/location.ml index 4272a47be2..1b8b5f1552 100644 --- a/src/ocaml/parsing/location.ml +++ b/src/ocaml/parsing/location.ml @@ -85,15 +85,34 @@ 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. + + We also use for {!is_first_report}, see below. *) let num_loc_lines = ref 0 +(* We use [num_loc_lines] to determine if the report about to be + printed is the first or a follow-up report of the current + "batch" -- contiguous reports without user input in between, for + example for the current toplevel phrase. We use this to print + a blank line between messages of the same batch. +*) +let is_first_message () = + !num_loc_lines = 0 + (* This is used by the toplevel to reset [num_loc_lines] before each phrase *) let reset () = num_loc_lines := 0 @@ -103,6 +122,13 @@ let echo_eof () = print_newline (); incr num_loc_lines +(* This is used by the toplevel and the report printers below. *) +let separate_new_message ppf = + if not (is_first_message ()) then begin + Format.pp_print_newline ppf (); + incr num_loc_lines + end + (* Code printing errors and warnings must be wrapped using this function, in order to update [num_loc_lines]. @@ -135,12 +161,40 @@ let rewrite_absolute_path path = *) path +(* +let rewrite_find_first_existing path = + match Misc.get_build_path_prefix_map () with + | None -> + if Sys.file_exists path then Some path + else None + | Some prefix_map -> + match Build_path_prefix_map.rewrite_all prefix_map path with + | [] -> + if Sys.file_exists path then Some path + else None + | matches -> + Some (List.find Sys.file_exists matches) + +let rewrite_find_all_existing_dirs path = + let ok path = Sys.file_exists path && Sys.is_directory path in + match Misc.get_build_path_prefix_map () with + | None -> + if ok path then [path] + else [] + | Some prefix_map -> + match Build_path_prefix_map.rewrite_all prefix_map path with + | [] -> + if ok path then [path] + else [] + | matches -> + match (List.filter ok matches) with + | [] -> raise Not_found + | results -> results *) + 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 + let s = if (is_relative s) then (concat (Sys.getcwd ()) s) else s in + let s = rewrite_absolute_path s in (* Now simplify . and .. components *) let rec aux s = let base = basename s in @@ -378,6 +432,79 @@ let infer_line_numbers 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 "@["; + 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) ""; + (* Iterate up to [rightmost], which can be larger than the length of + the line because we may point to a location after the end of the + last token on the line, for instance: + {[ + token + ^ + Did you forget ... + ]} *) + for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do + let pos = line_start_cnum + i in + 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 if i < String.length line then begin + (* For alignment purposes, align using a tab for each tab in the + source code *) + if line.[i] = '\t' then Format.pp_print_char ppf '\t' + else Format.pp_print_char ppf ' ' + end; + 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 "@]" +*) @@ -446,6 +573,25 @@ let lines_around_from_lexbuf 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 @@ -614,6 +760,7 @@ let batch_mode_printer : report_printer = in let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in let pp self ppf report = + separate_new_message ppf; (* 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 @@ -664,6 +811,34 @@ let batch_mode_printer : report_printer = { 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 = batch_mode_printer diff --git a/src/ocaml/parsing/location.mli b/src/ocaml/parsing/location.mli index c6aa29b167..6681309d53 100644 --- a/src/ocaml/parsing/location.mli +++ b/src/ocaml/parsing/location.mli @@ -87,17 +87,86 @@ val input_phrase_buffer: Buffer.t option ref (** {1 Toplevel-specific functions} *) val echo_eof: unit -> unit +val separate_new_message: formatter -> unit val reset: unit -> unit -(** {1 Printing locations} *) +(** {1 Rewriting path } *) 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. *) +(** [rewrite_absolute_path path] rewrites [path] to honor the + BUILD_PATH_PREFIX_MAP variable + if it is set. It does not check whether [path] is absolute or not. + The result is as follows: + - If BUILD_PATH_PREFIX_MAP is not set, just return [path]. + - otherwise, rewrite using the mapping (and if there are no + matching prefixes that will just return [path]). + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +(* +val rewrite_find_first_existing: string -> string option +*) +(** [rewrite_find_first_existing path] uses a BUILD_PATH_PREFIX_MAP mapping + and tries to find a source in mapping + that maps to a result that exists in the file system. + There are the following return values: + - [None], means either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [path] does not exists, or} + {- no source prefixes of [path] in the mapping were found,}} + - [Some target], means [target] exists and either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [target] = [path], or} + {- [target] is the first file (in priority + order) that [path] mapped to that exists in the file system.}} + - [Not_found] raised, means some source prefixes in the map + were found that matched [path], but none of them existed + in the file system. The caller should catch this and issue + an appropriate error message. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +(* +val rewrite_find_all_existing_dirs: string -> string list +*) +(** [rewrite_find_all_existing_dirs dir] accumulates a list of existing + directories, [dirs], that are the result of mapping a potentially + abstract directory, [dir], over all the mapping pairs in the + BUILD_PATH_PREFIX_MAP environment variable, if any. The list [dirs] + will be in priority order (head as highest priority). + + The possible results are: + - [[]], means either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [dir] is not an existing + directory, or} + {- if set, then there were no matching prefixes of [dir].}} + - [Some dirs], means dirs are the directories found. Either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [dirs = [dir]], or} + {- it was set and [dirs] are the mapped existing directories.}} + - Not_found raised, means some source prefixes in the map + were found that matched [dir], but none of mapping results + were existing directories (possibly due to misconfiguration). + The caller should catch this and issue an appropriate error + message. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) val absolute_path: string -> string + (** [absolute_path path] first makes an absolute path, [s] from [path], + prepending the current working directory if [path] was relative. + Then [s] is rewritten using [rewrite_absolute_path]. + Finally the result is normalized by eliminating instances of + ['.'] or ['..']. *) + +(** {1 Printing locations} *) val show_filename: string -> string (** In -absname mode, return the absolute path for this filename. @@ -108,7 +177,11 @@ 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} *) @@ -134,6 +207,7 @@ type report = { source : error_source; } +(* Exposed for Merlin *) val loc_of_report: report -> t val print_main : formatter -> report -> unit val print_sub_msg : formatter -> msg -> unit @@ -166,6 +240,12 @@ type report_printer = { (** {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]} *) diff --git a/src/ocaml/parsing/parsetree.mli b/src/ocaml/parsing/parsetree.mli index d0e64bd4fd..7bb13135e7 100644 --- a/src/ocaml/parsing/parsetree.mli +++ b/src/ocaml/parsing/parsetree.mli @@ -960,7 +960,8 @@ and module_expr_desc = | 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_apply of module_expr * module_expr (** [ME1(ME2)] *) + | Pmod_apply_unit of module_expr (** [ME1()] *) | Pmod_constraint of module_expr * module_type (** [(ME : MT)] *) | Pmod_unpack of expression (** [(val E)] *) | Pmod_extension of extension (** [[%id]] *) @@ -1004,13 +1005,30 @@ and structure_item_desc = | Pstr_attribute of attribute (** [[\@\@\@id]] *) | Pstr_extension of extension * attributes (** [[%%id]] *) +and value_constraint = + | Pvc_constraint of { + locally_abstract_univars:string loc list; + typ:core_type; + } + | Pvc_coercion of {ground:core_type option; coercion:core_type } + (** + - [Pvc_constraint { locally_abstract_univars=[]; typ}] + is a simple type constraint on a value binding: [ let x : typ] + - More generally, in [Pvc_constraint { locally_abstract_univars; typ}] + [locally_abstract_univars] is the list of locally abstract type + variables in [ let x: type a ... . typ ] + - [Pvc_coercion { ground=None; coercion }] represents [let x :> typ] + - [Pvc_coercion { ground=Some g; coercion }] represents [let x : g :> typ] + *) + and value_binding = { pvb_pat: pattern; pvb_expr: expression; + pvb_constraint: value_constraint option; pvb_attributes: attributes; pvb_loc: Location.t; - } + }(** [let pat : type_constraint = exp] *) and module_binding = { diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml index 7e2d5095f4..ce6fc4f5b3 100644 --- a/src/ocaml/parsing/pprintast.ml +++ b/src/ocaml/parsing/pprintast.ml @@ -26,7 +26,6 @@ open Format open Location open Longident open Parsetree -open Ast_helper let prefix_symbols = [ '!'; '?'; '~' ] let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; @@ -307,14 +306,11 @@ and core_type ctxt f x = 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 @@ -981,6 +977,7 @@ and class_field ctxt f x = ppat_loc_stack=[]; ppat_attributes=[]}; pvb_expr=e; + pvb_constraint=None; pvb_attributes=[]; pvb_loc=Location.none; } @@ -1060,7 +1057,7 @@ and module_type ctxt f x = end else match x.pmty_desc with | Pmty_functor (Unit, mt2) -> - pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 + pp f "@[() ->@ %a@]" (module_type ctxt) mt2 | Pmty_functor (Named (s, mt1), mt2) -> begin match s.txt with | None -> @@ -1237,6 +1234,8 @@ and module_expr ctxt f x = | Pmod_apply (me1, me2) -> pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 (* Cf: #7200 *) + | Pmod_apply_unit me1 -> + pp f "(%a)()" (module_expr ctxt) me1 | Pmod_unpack e -> pp f "(val@ %a)" (expression ctxt) e | Pmod_extension ({ txt; _ }, _) when txt = Ast_helper.hole_txt -> @@ -1259,7 +1258,7 @@ and payload ctxt f = function 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; _} = +and binding ctxt f {pvb_pat=p; pvb_expr=x; pvb_constraint = ct; _} = (* .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 @@ -1274,62 +1273,26 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = 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 + match ct with + | Some (Pvc_constraint { locally_abstract_univars = []; typ }) -> + pp f "%a@;:@;%a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) typ (expression ctxt) x + | Some (Pvc_constraint { locally_abstract_univars = vars; typ }) -> + pp f "%a@;: type@;%a.@;%a@;=@;%a" + (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") + (List.map (fun x -> x.txt) vars) + (core_type ctxt) typ (expression ctxt) x + | Some (Pvc_coercion {ground=None; coercion }) -> + pp f "%a@;:>@;%a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) coercion (expression ctxt) x + | Some (Pvc_coercion {ground=Some ground; coercion }) -> + pp f "%a@;:%a@;:>@;%a@;=@;%a" + (simple_pattern ctxt) p + (core_type ctxt) ground + (core_type ctxt) coercion + (expression ctxt) x | 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 | _ -> diff --git a/src/ocaml/parsing/printast.ml b/src/ocaml/parsing/printast.ml index 559d01c4a9..4b5612ede7 100644 --- a/src/ocaml/parsing/printast.ml +++ b/src/ocaml/parsing/printast.ml @@ -790,6 +790,9 @@ and module_expr i ppf x = line i ppf "Pmod_apply\n"; module_expr i ppf me1; module_expr i ppf me2; + | Pmod_apply_unit me1 -> + line i ppf "Pmod_apply_unit\n"; + module_expr i ppf me1 | Pmod_constraint (me, mt) -> line i ppf "Pmod_constraint\n"; module_expr i ppf me; @@ -909,8 +912,23 @@ and value_binding i ppf x = line i ppf "\n"; attributes (i+1) ppf x.pvb_attributes; pattern (i+1) ppf x.pvb_pat; + Option.iter (value_constraint (i+1) ppf) x.pvb_constraint; expression (i+1) ppf x.pvb_expr +and value_constraint i ppf x = + let pp_sep ppf () = Format.fprintf ppf "@ "; in + let pp_newtypes = Format.pp_print_list fmt_string_loc ~pp_sep in + match x with + | Pvc_constraint { locally_abstract_univars = []; typ } -> + core_type i ppf typ + | Pvc_constraint { locally_abstract_univars=newtypes; typ} -> + line i ppf " %a.\n" pp_newtypes newtypes; + core_type i ppf typ + | Pvc_coercion { ground; coercion} -> + line i ppf "\n"; + option i core_type ppf ground; + core_type i ppf coercion; + and binding_op i ppf x = line i ppf " %a %a" fmt_string_loc x.pbop_op fmt_location x.pbop_loc; diff --git a/src/ocaml/preprocess/parser_raw.ml b/src/ocaml/preprocess/parser_raw.ml index 1ff0eace23..83dc615ee5 100644 --- a/src/ocaml/preprocess/parser_raw.ml +++ b/src/ocaml/preprocess/parser_raw.ml @@ -17,7 +17,7 @@ module MenhirBasics = struct | VAL | UNDERSCORE | UIDENT of ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) # 23 "src/ocaml/preprocess/parser_raw.ml" ) @@ -30,7 +30,7 @@ module MenhirBasics = struct | THEN | STRUCT | STRING of ( -# 835 "src/ocaml/preprocess/parser_raw.mly" +# 837 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) # 36 "src/ocaml/preprocess/parser_raw.ml" ) @@ -43,12 +43,12 @@ module MenhirBasics = struct | RBRACKET | RBRACE | QUOTED_STRING_ITEM of ( -# 840 "src/ocaml/preprocess/parser_raw.mly" +# 842 "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 ( -# 837 "src/ocaml/preprocess/parser_raw.mly" +# 839 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) # 54 "src/ocaml/preprocess/parser_raw.ml" ) @@ -56,7 +56,7 @@ module MenhirBasics = struct | QUESTION | PRIVATE | PREFIXOP of ( -# 821 "src/ocaml/preprocess/parser_raw.mly" +# 823 "src/ocaml/preprocess/parser_raw.mly" (string) # 62 "src/ocaml/preprocess/parser_raw.ml" ) @@ -66,7 +66,7 @@ module MenhirBasics = struct | PERCENT | OR | OPTLABEL of ( -# 814 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) # 72 "src/ocaml/preprocess/parser_raw.ml" ) @@ -85,13 +85,13 @@ module MenhirBasics = struct | MATCH | LPAREN | LIDENT of ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) # 91 "src/ocaml/preprocess/parser_raw.ml" ) | LET_LWT | LETOP of ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 781 "src/ocaml/preprocess/parser_raw.mly" (string) # 97 "src/ocaml/preprocess/parser_raw.ml" ) @@ -111,39 +111,39 @@ module MenhirBasics = struct | LBRACE | LAZY | LABEL of ( -# 784 "src/ocaml/preprocess/parser_raw.mly" +# 786 "src/ocaml/preprocess/parser_raw.mly" (string) # 117 "src/ocaml/preprocess/parser_raw.ml" ) | INT of ( -# 783 "src/ocaml/preprocess/parser_raw.mly" +# 785 "src/ocaml/preprocess/parser_raw.mly" (string * char option) # 122 "src/ocaml/preprocess/parser_raw.ml" ) | INITIALIZER | INHERIT | INFIXOP4 of ( -# 777 "src/ocaml/preprocess/parser_raw.mly" +# 779 "src/ocaml/preprocess/parser_raw.mly" (string) # 129 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP3 of ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) # 134 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP2 of ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 777 "src/ocaml/preprocess/parser_raw.mly" (string) # 139 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP1 of ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 776 "src/ocaml/preprocess/parser_raw.mly" (string) # 144 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP0 of ( -# 773 "src/ocaml/preprocess/parser_raw.mly" +# 775 "src/ocaml/preprocess/parser_raw.mly" (string) # 149 "src/ocaml/preprocess/parser_raw.ml" ) @@ -151,7 +151,7 @@ module MenhirBasics = struct | IN | IF | HASHOP of ( -# 832 "src/ocaml/preprocess/parser_raw.mly" +# 834 "src/ocaml/preprocess/parser_raw.mly" (string) # 157 "src/ocaml/preprocess/parser_raw.ml" ) @@ -166,7 +166,7 @@ module MenhirBasics = struct | FOR_LWT | FOR | FLOAT of ( -# 762 "src/ocaml/preprocess/parser_raw.mly" +# 764 "src/ocaml/preprocess/parser_raw.mly" (string * char option) # 172 "src/ocaml/preprocess/parser_raw.ml" ) @@ -182,7 +182,7 @@ module MenhirBasics = struct | DOWNTO | DOTTILDE | DOTOP of ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) # 188 "src/ocaml/preprocess/parser_raw.ml" ) @@ -191,14 +191,14 @@ module MenhirBasics = struct | DOT | DONE | DOCSTRING of ( -# 857 "src/ocaml/preprocess/parser_raw.mly" +# 859 "src/ocaml/preprocess/parser_raw.mly" (Docstrings.docstring) # 197 "src/ocaml/preprocess/parser_raw.ml" ) | DO | CONSTRAINT | COMMENT of ( -# 856 "src/ocaml/preprocess/parser_raw.mly" +# 858 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t) # 204 "src/ocaml/preprocess/parser_raw.ml" ) @@ -209,7 +209,7 @@ module MenhirBasics = struct | COLON | CLASS | CHAR of ( -# 742 "src/ocaml/preprocess/parser_raw.mly" +# 744 "src/ocaml/preprocess/parser_raw.mly" (char) # 215 "src/ocaml/preprocess/parser_raw.ml" ) @@ -222,7 +222,7 @@ module MenhirBasics = struct | ASSERT | AS | ANDOP of ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 782 "src/ocaml/preprocess/parser_raw.mly" (string) # 228 "src/ocaml/preprocess/parser_raw.ml" ) @@ -728,10 +728,11 @@ let extra_rhs_core_type ct ~pos = let docs = rhs_info pos in { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes } -(* +(* moved to ast_helper type let_binding = { lb_pattern: pattern; lb_expression: expression; + lb_constraint: value_constraint option; lb_is_pun: bool; lb_attributes: attributes; lb_docs: docs Lazy.t; @@ -744,10 +745,11 @@ type let_bindings = lbs_extension: string Asttypes.loc option } *) -let mklb first ~loc (p, e, is_pun) attrs = +let mklb first ~loc (p, e, typ, is_pun) attrs = { lb_pattern = p; lb_expression = e; + lb_constraint=typ; lb_is_pun = is_pun; lb_attributes = attrs; lb_docs = symbol_docs_lazy loc; @@ -780,7 +782,7 @@ let val_of_let_bindings ~loc lbs = 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) + ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) lbs.lbs_bindings in let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in @@ -793,7 +795,7 @@ let expr_of_let_bindings ~loc lbs body = List.map (fun lb -> Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - lb.lb_pattern lb.lb_expression) + ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) lbs.lbs_bindings in mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body)) @@ -804,7 +806,7 @@ let class_of_let_bindings ~loc lbs body = List.map (fun lb -> Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - lb.lb_pattern lb.lb_expression) + ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) lbs.lbs_bindings in (* Our use of let_bindings(no_ext) guarantees the following: *) @@ -898,7 +900,7 @@ let expr_of_lwt_bindings ~loc lbs body = (lbs.lbs_extension, [])) -# 902 "src/ocaml/preprocess/parser_raw.ml" +# 904 "src/ocaml/preprocess/parser_raw.ml" module Tables = struct @@ -1444,22 +1446,22 @@ module Tables = struct Obj.repr () and default_reduction = - (16, "\000\000\000\000\000\000\002\221\002\220\002\219\002\218\002\217\002\172\002\216\002\215\002\214\002\213\002\212\002\211\002\210\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\171\002\197\002\196\002\195\002\194\002\193\002\192\002\191\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\000\000\000\000\000,\000\189\000\000\000\000\000\000\000\000\000\000\000\000\002\141\001[\000\000\000\000\000\000\000\000\000\000\000\000\000h\000c\000\191\000\000\000\000\000\000\000\000\000\000\002\159\000\000\002f\002g\000\000\002d\002e\000\000\001\178\000f\001\157\001\175\001\174\000\000\001\179\001\183\000\000\000\000\000\000\001q\001p\000\000\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\173\001\177\001\176\001\158\001\181\001\172\001\171\001\170\001\169\001\168\001\166\001\182\001\180\000\000\000\000\000\000\000\226\000\000\000\000\001\161\000\000\000\000\000\000\001\163\000\000\000\000\000\000\001\165\001\187\001\184\001\167\001\159\001\185\001\186\000\000\003\031\003 \000\000\000\000\000\026\001O\000\000\000\222\000\223\000\000\000\000\000\000\001\209\001\208\000\000\000\000\000\025\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001o\000\000\000\000\000\000\000\000\000\000\003\028\000\000\003\023\000\000\000\000\003\025\000\000\003\027\000\000\003\024\003\026\000\000\003\018\000\000\003\017\003\r\0022\000\000\003\016\000\000\0023\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\000\000\000\000\000\000\000\000\000\000\000\000\000\229\000\017\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001Y\000\000\000\000\001\\\001Z\001a\000C\002{\000\000\001\028\002\247\002\246\000\000\000\000\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\014\000\000\000\000\000\000\000e\000\000\000\237\000\000\002h\000\000\000\000\000\000\001\191\000\000\000\000\000'\000\000\000\000\000\000\000\000\000\000\000\000\001`\000\000\001P\001_\000\000\001N\000`\000 \000\000\000\000\001\134\000\027\000\000\000\000\000\000\000\000\003\012\000*\000\000\000\000\000!\000\028\000\000\000\000\000\000\000\204\000\000\000\000\000\000\000\206\002<\002.\000\000\000$\000\000\002/\000\000\000\000\001\188\000\000\000\000\000\000\000\018\000\000\000\000\000\000\000\019\002\248\000\000\002\249\000\000\000w\000\000\000\000\000#\000\000\000\000\000\000\000%\000\000\000&\000\000\000(\000\000\000\000\000)\002$\002#\000\000\000\000\000\000\000\000\000\000\000\000\000a\000\000\002\164\000d\000g\000b\002\153\003!\002\154\001\242\002\156\000\000\000\000\002\161\002c\002\163\000\000\000\000\000\000\002\167\000\000\000\000\000\000\001\238\001\229\000\000\000\000\000\000\000\000\000\000\001\228\000\000\001\241\002\170\000\000\000\000\000\000\000\000\001\136\000\000\000\000\001\240\002\162\000o\000\000\000\000\000n\000\000\002\155\000\000\000\000\000\000\000\000\002\169\000\000\000\000\000\000\001\230\001\239\001\233\000\000\000m\000\000\002\168\000\000\002\166\000\000\002i\000\000\000\000\002F\002\165\000\000\000\000\000\000\000\000\001\193\0017\0018\002k\000\000\002j\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\248\000\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\250\000\000\000\000\000\000\000\000\000\000\000\000\000\246\001\249\000\247\000\000\000\000\000\000\000\000\000\000\000\250\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\207\000\000\000\000\000\000\000\000\000\000\000\000\002 \000\000\000\000\001x\000\000\000\000\000\000\000\000\000\000\000\000\0038\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\015\000\000\000\000\000\000\000\000\000\000\001w\000\000\000\000\000\000\001X\001~\001W\001{\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\031\000\000\001v\000\000\000\208\000\000\000\000\001i\000\000\000\000\001m\000\000\001\211\000\000\000\000\001\210\001l\001j\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\127\001]\002\132\002\130\000\000\000\000\000\000\002\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\152\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\241\000\240\000\000\000\242\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002p\000\000\000\000\000\000\000\000\003\"\002\140\002\129\002\128\000\000\000\000\000z\001:\000\000\000\000\000\173\000\000\000\000\000\000\000\000\000\000\000\187\000\000\000\000\000\000\000\172\000\000\000\000\000\000\002M\002L\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\003\000\000\000\000\001\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\246\001\244\001\245\000\000\000\000\000\000\000\252\000\000\000\000\000\000\000\000\000\000\000\000\001\255\000\000\000\000\000\000\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\001\024\000\000\001d\002\240\000\000\000\000\002\239\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\245\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\001\138\000\000\002\005\000\000\000\000\000\000\000\000\000i\000\000\000\000\000j\000\000\000\000\000\000\000\000\001\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\231\000\000\000\000\000s\000\000\000\234\000\232\000\000\000\000\000\000\000\211\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\223\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002N\000k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\149\001\145\000\000\000\000\000\000\000\216\000\000\000\000\002\019\002\029\000\000\000\219\002\017\002\018\000\000\000\000\000\000\000\000\000\000\001\152\001\148\001\144\000\000\000\000\000\217\000\000\000\000\001\151\001\147\001\143\001\141\002\029\000\000\000\221\000\000\000\000\002\007\000\000\000\000\002W\002\028\002\026\002\027\000\000\000\000\000\000\002\029\000\000\000\218\002\029\000\000\000\220\000\000\000\000\000\000\000\000\002V\000\000\000\000\000\000\000\000\000\000\000\000\001\156\000\000\000\000\000\000\001\155\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\001r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\026\002\\\000\000\000\000\000\000\002Z\000\000\000\000\000\000\002Y\000\000\001f\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\003*\000\000\000\000\000\000\000\196\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000G\000\000\000\000\000\000\000\000\001\133\000\000\001\132\000\000\000\000\000\000\000\000\000J\000\000\000\000\000\000\002\012\000\000\002\011\000\000\000\000\000\000\000\000\000K\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000P\000\000\000\000\000\000\000Q\000O\000\000\000S\000\000\000\000\000\000\000\000\000\000\000I\000\000\000\000\000\000\000\000\000\000\000\000\000L\000\000\000R\000\000\000M\000N\000\000\001+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\022\000_\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\\\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\020\002a\002R\000\000\002X\002S\002_\002^\002]\002[\001%\000\000\002P\000\000\000\000\000\000\000\000\000\000\002\029\000\000\000\000\001\030\002T\000\000\000\000\000\000\000\000\000\000\000\000\002\029\000\000\000\000\001 \002U\002Q\002b\001$\001\252\002O\000\000\000\000\000\000\000\000\000\000\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\000\000\000\003'\000\000\0008\000\000\000\000\003-\000\000\003,\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003$\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\001L\000\000\000\000\001J\001H\000\251\000\000\000\000\000\000\000\198\000\197\002\225\000\000\0009\000\000\000\000\0030\000\000\003/\000\000\000\000\000\000\001F\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001K\000\000\000\000\001I\001G\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000X\000\000\000\000\000\000\000\000\000\000\000\000\0005\000\000\000\000\000\000\000\000\000\000\002\"\002!\000W\000\000\0003\001\b\000\000\000B\000/\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\006\000\000\000V\000\000\000\000\000Y\000\000\000\000\001\195\000\000\0007\000\000\000\000\000\000\0006\000\000\000\000\000\000\000:\000\000\000Z\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\018\002\243\002\234\000\000\000\000\000\000\000\000\000\000\000\000\001\004\002\238\002\222\002\233\002\242\002\241\000\000\001;\001)\000\000\001\005\000\000\002\231\000\000\002\235\002\232\002\244\001\251\000\000\000\000\002\228\000\000\000\194\000\000\002\227\000\000\000\000\000\228\000\000\002\004\000\020\000\000\000\000\000\000\002r\000\000\000\000\002q\000\000\000\000\000\000\000\000\002t\000\000\000\000\002@\000\000\000\000\002x\000\000\000\000\002v\002\135\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\171\000\000\002s\000\000\000\000\002w\000\000\000\000\002u\001\r\000\000\000\000\001\014\000\000\000\000\000\174\000\000\001\016\001\015\000\000\000\000\002\136\000\000\002\148\000\000\002\147\000\000\002\151\000\000\002\150\000\000\000\000\002\137\000\000\000\000\000\000\002\016\000\000\001\207\000\000\000\000\000\000\002I\002\015\000\000\002\144\000\000\000\000\000\000\001^\000\000\000x\000y\000\000\000\000\000\000\000\000\000\144\000\000\000\000\000\000\000\130\000\000\000\000\000\000\000\000\000\000\000\000\000\129\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\200\000\000\000\201\000\202\000\138\000\000\000\137\000\000\000\000\001=\000\000\001>\001<\002(\000\000\000\000\002)\002'\000\000\000\000\000\000\000\000\000\000\002z\000\000\002y\000\000\000\000\002l\000\000\000\000\002\143\000\000\000\000\000\000\002C\002\134\000\000\002\133\000\000\002\149\000\135\000\000\000\000\000\000\000\000\000\134\000\000\000\000\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\133\002\224\002\226\001\011\001\205\000\000\000\244\000\245\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\255\000\254\000\000\0019\000\000\002\146\000\000\002\145\002\131\000\000\000\000\000\000\000\000\002|\000\000\000\000\002}\000\000\002n\000\000\002o\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\212\000\000\000\000\001\215\000\000\000\000\001\213\000\000\000\000\001\214\000\000\001\154\000\000\000\000\000\000\001\153\000\000\000\000\001(\001'\000\000\000\190\000\000\000\000\000\000\000\000\001E\001?\000\000\000\000\001@\000\031\000\000\000\030\000\000\000\000\000\205\000\000\000\000\000\000\000\"\000\029\000\000\000\000\000\000\000\023\000\000\000\000\000\000\000\000\001\150\001\146\000\000\001\142\003\011\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000\000\002\237\002\024\002\025\002\020\002\022\002\021\002\023\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\000\000\000\000\000\002\236\000\000\001g\000\000\000\000\000\024\000\000\003(\000\000\001s\000\000\002\158\000\000\000D\000\000\000\000\000E\000\000\000\000\002~\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\127\000\000\000~\000\000\000\000\000\000\000\143\000\000\000-\000\000\000\000\000\000\000\000\000\128\000\000\000\224\000\001\000\000\000\000\000\227\000\002\000\000\000\000\000\000\001R\001S\000\003\000\000\000\000\000\000\000\000\001U\001V\001T\000\021\001Q\000\022\000\000\001\216\000\000\000\004\000\000\001\217\000\000\000\005\000\000\001\218\000\000\000\000\001\219\000\006\000\000\000\007\000\000\001\220\000\000\000\b\000\000\001\221\000\000\000\t\000\000\001\222\000\000\000\n\000\000\001\223\000\000\000\011\000\000\001\224\000\000\000\000\001\225\000\012\000\000\000\000\001\226\000\r\000\000\000\000\000\000\000\000\000\000\003\000\002\251\002\252\002\255\002\253\000\000\003\004\000\014\000\000\003\003\000\000\001/\000\000\000\000\003\001\000\000\003\002\000\000\000\000\000\000\000\000\0013\0014\000\000\000\000\0012\0011\000\015\000\000\000\000\000\000\003\030\000\000\003\029") + (16, "\000\000\000\000\000\000\002\222\002\221\002\220\002\219\002\218\002\173\002\217\002\216\002\215\002\214\002\213\002\212\002\211\002\210\002\209\002\208\002\207\002\206\002\205\002\204\002\203\002\202\002\201\002\200\002\199\002\172\002\198\002\197\002\196\002\195\002\194\002\193\002\192\002\191\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\000\000\000\000\000,\000\189\000\000\000\000\000\000\000\000\000\000\000\000\002\142\001[\000\000\000\000\000\000\000\000\000\000\000\000\000h\000c\000\191\000\000\000\000\000\000\000\000\000\000\002\160\000\000\002g\002h\000\000\002e\002f\000\000\001\179\000f\001\158\001\176\001\175\000\000\001\180\001\184\000\000\000\000\000\000\001q\001p\000\000\002\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\174\001\178\001\177\001\159\001\182\001\173\001\172\001\171\001\170\001\169\001\167\001\183\001\181\000\000\000\000\000\000\000\226\000\000\000\000\001\162\000\000\000\000\000\000\001\164\000\000\000\000\000\000\001\166\001\188\001\185\001\168\001\160\001\186\001\187\000\000\003 \003!\000\000\000\000\000\026\001O\000\000\000\222\000\223\000\000\000\000\000\000\001\210\001\209\000\000\000\000\000\025\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001o\000\000\000\000\000\000\000\000\000\000\003\029\000\000\003\024\000\000\000\000\003\026\000\000\003\028\000\000\003\025\003\027\000\000\003\019\000\000\003\018\003\014\0023\000\000\003\017\000\000\0024\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\000\000\000\000\000\000\000\000\000\000\000\000\000\229\000\017\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001Y\000\000\000\000\001\\\001Z\001a\000C\002|\000\000\001\028\002\248\002\247\000\000\000\000\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\015\000\000\000\000\000\000\000e\000\000\000\237\000\000\002i\000\000\000\000\000\000\001\192\000\000\000\000\000'\000\000\000\000\000\000\000\000\000\000\000\000\001`\000\000\001P\001_\000\000\001N\000`\000 \000\000\000\000\001\135\000\027\000\000\000\000\000\000\000\000\003\r\000*\000\000\000\000\000!\000\028\000\000\000\000\000\000\000\204\000\000\000\000\000\000\000\206\002=\002/\000\000\000$\000\000\0020\000\000\000\000\001\189\000\000\000\000\000\000\000\018\000\000\000\000\000\000\000\019\002\249\000\000\002\250\000\000\000w\000\000\000\000\000#\000\000\000\000\000\000\000%\000\000\000&\000\000\000(\000\000\000\000\000)\002%\002$\000\000\000\000\000\000\000\000\000\000\000\000\000a\000\000\002\165\000d\000g\000b\002\154\003\"\002\155\001\243\002\157\000\000\000\000\002\162\002d\002\164\000\000\000\000\000\000\002\168\000\000\000\000\000\000\001\239\001\230\000\000\000\000\000\000\000\000\000\000\001\229\000\000\001\242\002\171\000\000\000\000\000\000\000\000\001\137\000\000\000\000\001\241\002\163\000o\000\000\000\000\000n\000\000\002\156\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\001\231\001\240\001\234\000\000\000m\000\000\002\169\000\000\002\167\000\000\002j\000\000\000\000\002G\002\166\000\000\000\000\000\000\000\000\001\194\0017\0018\002l\000\000\002k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\248\000\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\251\000\000\000\000\000\000\000\000\000\000\000\000\000\246\001\250\000\247\000\000\000\000\000\000\000\000\000\000\000\250\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\207\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002!\000\000\000\000\001x\000\000\000\000\000\000\000\000\000\000\000\000\0039\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\000\000\000\000\000\000\000\000\000\000\001w\000\000\000\000\000\000\001X\001\127\001W\001|\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 \000\000\000\000\001v\000\000\000\208\000\000\000\000\001i\000\000\000\000\001m\000\000\001\212\000\000\000\000\001\211\001l\001j\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\128\001]\002\133\002\131\000\000\000\000\000\000\002\143\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\153\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\241\000\240\000\000\000\242\000\000\000\000\000\000\002\139\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\003#\002\141\002\130\002\129\000\000\000\000\000z\001:\000\000\000\000\000\173\000\000\000\000\000\000\000\000\000\000\000\187\000\000\000\000\000\000\000\172\000\000\000\000\000\000\002N\002M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\003\000\000\000\000\001\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\247\001\245\001\246\000\000\000\000\000\000\000\252\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\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\001\024\000\000\001d\002\241\000\000\000\000\002\240\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\246\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\001\139\000\000\002\006\000\000\000\000\000\000\000\000\000i\000\000\000\000\000j\000\000\000\000\000\000\000\000\001\129\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\231\000\000\000\000\000s\000\000\000\234\000\232\000\000\000\000\000\000\000\211\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\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\002O\000k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\150\001\146\000\000\000\000\000\000\000\216\000\000\000\000\002\020\002\030\000\000\000\219\002\018\002\019\000\000\000\000\000\000\000\000\000\000\001\153\001\149\001\145\000\000\000\000\000\217\000\000\000\000\001\152\001\148\001\144\001\142\002\030\000\000\000\221\000\000\000\000\002\b\000\000\000\000\002X\002\029\002\027\002\028\000\000\000\000\000\000\002\030\000\000\000\218\002\030\000\000\000\220\000\000\000\000\000\000\000\000\002W\000\000\000\000\000\000\000\000\000\000\000\000\001\157\000\000\000\000\000\000\001\156\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\001r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\026\002]\000\000\000\000\000\000\002[\000\000\000\000\000\000\002Z\000\000\001f\000\000\000\000\000\000\000\000\002a\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\196\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000G\000\000\000\000\000\000\000\000\001\134\000\000\001\133\000\000\000\000\000\000\000\000\000J\000\000\000\000\000\000\002\r\000\000\002\012\000\000\000\000\000\000\000\000\000K\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000P\000\000\000\000\000\000\000Q\000O\000\000\000S\000\000\000\000\000\000\000\000\000\000\000I\000\000\000\000\000\000\000\000\000\000\000\000\000L\000\000\000R\000\000\000M\000N\000\000\001+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\022\000_\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\\\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\020\002b\002S\000\000\002Y\002T\002`\002_\002^\002\\\001%\000\000\002Q\000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\000\001\030\002U\000\000\000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\000\001 \002V\002R\002c\001$\001\253\002P\000\000\000\000\000\000\000\000\000\000\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\000\000\000\003(\000\000\0008\000\000\000\000\003.\000\000\003-\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003%\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\001L\000\000\000\000\001J\001H\000\251\000\000\000\000\000\000\000\198\000\197\002\226\000\000\0009\000\000\000\000\0031\000\000\0030\000\000\000\000\000\000\001F\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001K\000\000\000\000\001I\001G\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000X\000\000\000\000\000\000\000\000\000\000\000\000\0005\000\000\000\000\000\000\000\000\000\000\002#\002\"\000W\000\000\0003\001\b\000\000\000B\000/\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\006\000\000\000V\000\000\000\000\000Y\000\000\000\000\001\196\000\000\0007\000\000\000\000\000\000\0006\000\000\000\000\000\000\000:\000\000\000Z\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\018\002\244\002\235\000\000\000\000\000\000\000\000\000\000\000\000\001\004\002\239\002\223\002\234\002\243\002\242\000\000\001;\001)\000\000\001\005\000\000\002\232\000\000\002\236\002\233\002\245\001\252\000\000\000\000\002\229\000\000\000\194\000\000\002\228\000\000\000\000\000\228\000\000\002\005\000\020\000\000\000\000\000\000\002s\000\000\000\000\002r\000\000\000\000\000\000\000\000\002u\000\000\000\000\002A\000\000\000\000\002y\000\000\000\000\002w\002\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\171\000\000\002t\000\000\000\000\002x\000\000\000\000\002v\001\r\000\000\000\000\001\014\000\000\000\000\000\174\000\000\001\016\001\015\000\000\000\000\002\137\000\000\002\149\000\000\002\148\000\000\002\152\000\000\002\151\000\000\000\000\002\138\000\000\000\000\000\000\002\017\000\000\001\208\000\000\000\000\000\000\002J\002\016\000\000\002\145\000\000\000\000\000\000\001^\000\000\000x\000y\000\000\000\000\000\000\000\000\000\144\000\000\000\000\000\000\000\130\000\000\000\000\000\000\000\000\000\000\000\000\000\129\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\200\000\000\000\201\000\202\000\138\000\000\000\137\000\000\000\000\001=\000\000\001>\001<\002)\000\000\000\000\002*\002(\000\000\000\000\000\000\000\000\000\000\002{\000\000\002z\000\000\000\000\002m\000\000\000\000\002\144\000\000\000\000\000\000\002D\002\135\000\000\002\134\000\000\002\150\000\135\000\000\000\000\000\000\000\000\000\134\000\000\000\000\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\133\002\225\002\227\001\011\001\206\000\000\000\244\000\245\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\255\000\254\000\000\0019\000\000\002\147\000\000\002\146\002\132\000\000\000\000\000\000\000\000\002}\000\000\000\000\002~\000\000\002o\000\000\002p\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\213\000\000\000\000\001\216\000\000\000\000\001\214\000\000\000\000\001\215\000\000\001\155\000\000\000\000\000\000\001\154\000\000\000\000\001(\001'\000\000\000\190\000\000\000\000\000\000\000\000\001E\001?\000\000\000\000\001@\000\031\000\000\000\030\000\000\000\000\000\205\000\000\000\000\000\000\000\"\000\029\000\000\000\000\000\000\000\023\000\000\000\000\000\000\000\000\001\151\001\147\000\000\001\143\003\012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000\000\002\238\002\025\002\026\002\021\002\023\002\022\002\024\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\000\000\000\000\000\002\237\000\000\001g\000\000\000\000\000\024\000\000\003)\000\000\001s\000\000\002\159\000\000\000D\000\000\000\000\000E\000\000\000\000\002\127\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\127\000\000\000~\000\000\000\000\000\000\000\143\000\000\000-\000\000\000\000\000\000\000\000\000\128\000\000\000\224\000\001\000\000\000\000\000\227\000\002\000\000\000\000\000\000\001R\001S\000\003\000\000\000\000\000\000\000\000\001U\001V\001T\000\021\001Q\000\022\000\000\001\217\000\000\000\004\000\000\001\218\000\000\000\005\000\000\001\219\000\000\000\000\001\220\000\006\000\000\000\007\000\000\001\221\000\000\000\b\000\000\001\222\000\000\000\t\000\000\001\223\000\000\000\n\000\000\001\224\000\000\000\011\000\000\001\225\000\000\000\000\001\226\000\012\000\000\000\000\001\227\000\r\000\000\000\000\000\000\000\000\000\000\003\001\002\252\002\253\003\000\002\254\000\000\003\005\000\014\000\000\003\004\000\000\001/\000\000\000\000\003\002\000\000\003\003\000\000\000\000\000\000\000\000\0013\0014\000\000\000\000\0012\0011\000\015\000\000\000\000\000\000\003\031\000\000\003\030") 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\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\"\001@0$r\000\000\n\001@\001\140\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\128\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\001\128\000\000\016\000\000\000@\000\000\000\000\000\000\000\000\012\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\001\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\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000B@\n\160\002\012\021!\192\001\016\000\236\b\025\000 \018\000A\000\016@\001\n\000\b\000\006 \000\b\000\000\144\002\b\000\130\000\b@\000@\0001\000\000@\000\000\000\000\000 \0000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\004\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\128\007\224\012\t\000\000\248\132\000\129\000 Q`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\002\128\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\000\000\000\000\000\000\000\000\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\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\t\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\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\136\000\000\000\000\000\000\000\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\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\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\192\000\014\002\000\012.\016\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\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\005\128Y\208\004\025\026C\129\131\"\001\216\017\"\017@\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\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\001\128\000\028\004\b\024\\ \000\016\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\001\000 \0160 \128\000\001\000\000\000\000\000\000\b\001\001\000\000\129\129\004\000\000\b\000\000\000\000\000\000@\b\b\000\004\012\b\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\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\000\000\000\000\000\000\000\000\000\000\000g\240\144b\197V\254f\250\002\128\251\137@\003\142\003?\132\131\022*\183\2433\208\020\007\220J\000\028p\000\192\000\004\152 \140\000 \004\000\000\000\000\000\002\000\006\000\000$\129\004`\001\000 \000\000\000\000\000\016\0000\000\001$\b#\000\000\001\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\000@\000\000\000\000\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\000\018@\0020\000\000\016\000\000\000\000\000\b\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\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\001\000\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\002\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\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\016\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\002\000\000\018@\002\000\000\000\016\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\004\000\000\000\000\000\000\000\000\000\000\t\000\"\130\b \020\134\000\004@\003\176\002\004\000\1281\000\003\192\128\003\011\133\000\002\000 \002\000\001\000\002@\b\160\003\b\021!\192\001\016\000\204\b\131\b \012@\000\224 \000\194\225@\000\128\b\000\128\000@\000`\000\135\001\002\006\023\b\000\004\000\000\000\001\000\000\133\128]\192\004\025\026C\129\130\"\001\216\001f\017`\024\000\001\128\000\001\133\194\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\006\000\000`\000\000ap\128\000D\000\000@\000\000\000\016\000\128\000\000\001\000\000\000\002 \000\000\000@\000\001\128\000\028\004\000\024\\ \000\016\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\192g\240\145b\197V\254fz\002\128\251\153@\003\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\0000\016\002\002\000\002\002\b\000\000\016\000\000\000\000\128\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\000\000\000\000\000\000` \004\000\000\004\004\000\000\000 \000\000\000\000\000\007\001\000 \000\000 \000\000\001\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\128\002\000\000\000@\000 \001\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\b\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\002\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\191\214\239\2517\223\251\255\254N\143\238e\132\014y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\2241\184@\017p\163\127\018}\000@}\000\160\000\199\001\141\194\000\139\005\027\248\147\232\002\003\232\005\000\0068\012n\016\004X(\223\196\143@\016\031@(\0001\192cp\196#\241V\254\164z|\194\250A\192\025\174\176\024\132!\016\n\001\129#\144\000\000P\n\000\012`\024\220 \b\176Q\191\137\030\128 >\128P\000s\129\015=\187\215\250\190w\207\239\254\220\031\191\182\255\249\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224\001\136A\0160\001\024\018m\000\016\005\000\000\000\130\000\012B\b\129\000\b\192\147h\000\128(\000\000\004\016\000b\016D\b\000F\004\139@\004\001@\000\000 \128\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\000P\000\000\b \000\196 \b\016\000\140\t\022\128\b\002\160\000\000Q\000\006!\002@\128\004`H\180\000@\021\000\000\002\b\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\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\000D\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\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\002 \000\000\000\000 \000\000\000\016\000\000\000\000\000\000\017\000\000\000\000\000\000\000\000\000\128\000\000\000\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\001\136@\0160\001\024\018i\000\016\005\000\000\000\130\000\012B\000\129\000\b\192\147H\000\128(\000\000\004\016\000b\016\004\b\000F\004\138@\004\001@\000\000 \128\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000&)\027P\144\020`I\172\002@\020\160@\218\170\000\000\b\000\004\000 \000\000 \000\000\128\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\019\020\141\168H\n0$\222\001 \n\208\016mU\000\b\000\000\000\000\001\000\"\128\000\000\000\000\000\000\000\000\196!\b\016\000\140\t\022\128\b\002\160\000\002A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\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\000l\000\000@\000\004\000\b\000\002\128\002b\136\000\196 \b\016\000\140\t\022\128\b\002\160\000\000A\000 \000\027\000\000\016\000\001\000\002\000\000\160\000\152\162\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\000\000\000\000\000\000\000\000\000\000\002b\017\180\b\001F\004\155@$\001Z\000\t\170\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\004\196#h\016\002\140\t6\128H\002\180\000\019U@\007!\136G\224,iH\180\248\196\021\129\0002Y`\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\b\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\128\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\128 @\0020$R\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\128\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\016\000\000\000\000\000\t\130 \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 \004\000\003`\000\002\000\000 \000@\000\020\000\019\020@\006\000\000p\016\000ap\128\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\012B\000\129\000\b\192\145h\000\128*\000\000\004\016\002\000\001\176\000\001\000\000\016\000 \000\n\000\t\138 \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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\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\002\000\000\000\000\000\001 D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\129 @\0020$Z\000 \n\128\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\144\000\000\000\000\b\000\000\000\000\000\004\133\016\001\136@\144 \001\024\018-\000\016\005@\000\000\162\000\000\000\000\000\000\000\000\000\000\000\000\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\128\000\000\000\000\128\000\000\000\000\000H\017\000\000\000D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000 \000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\017\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\229$Z\019\004\142\153\245\128\200\002\246\000\027\197P\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\002\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\000\000\128\000\000\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\002\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\016\004\b\000F\004\139@\004\001@\000\000 \128\003\020\128(H\0020$\214\001 \n@\000M\021\128\016\000\000\000\000\001\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\006!\000@\128\004`H\180\000@\021\000\000\002\b\000\000\000@\000\000\000\000\b\000\000\000\004\000\004\193\016\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\016\000\000\000\000\002\000\000\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\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\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\000b\144\005\t\000F\004\138\192\004\001H\000\004\160\128\003\016\128 @\0020$R\000 \n\000\000\001\004\000\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\006!\004@\200$`I\180\000@\021\000\000\002\b\0000\016\002\002\000\002\002\b\000\000\016\000\000\000\000\128\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\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\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\000\192\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\128\016\016\000\b\024\016\000\000\000\128\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\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\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\016\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\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\003\000\000\018@\0020\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\004\000\000\006\000\000x\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\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\002\018\000U\000\016`)\014\000\b\128\007`\000\136\005\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\132\128\021@\004\024\nC\128\002 \001\216\001\"\001D$\000\170\000 \192R\028\000\017\000\014\192\t\016\002\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\0000\000\003\128\128\003\011\132\000\002\000\000\000\000\000\000B@\n\160\002\012\005!\192\001\016\000\236\000\145\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\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\002\000\000\128\000\000@\b\b\000\004\012\b\000\000\000@\000\000\000\000\001\t\000*\128\b0\020\135\000\004@\003\176\000D\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\000\000\000\000\b\000\000\000\004\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\016\144\002\168\000\131\005Hp\000D\000;\002\006@\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\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000B@\n\160\002\012\005!\192\001\016\000\236\000\017\000 \004\000\128\128\000@\192\128\000\000\004\000\000\000\000\000\016\144\002\168\000\131\001Hp\000D\000;\000\004@\b\000\000\000\000\000\000\000\000\000\000\000\000@\016\016\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000! \005P\001\006\n\144\224\000\136\000v\004\b\128\016\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\000B@\n\160\002\012\021!\192\001\016\000\236\b\017\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\144\002\168\000\131\001Hp\000D\000;\000\004@\b\000\128\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\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\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\000\000\001\000\000\000\000\000\000\000\000\000\000\000\003\001\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! \005P\001\006\n\144\224\000\200\000v\000\t\128\016\014\002\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\002\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 \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\000\000\000\000\000\000\000\000\000\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\001T\000A\130\1648\0002\000\029\129\002`\004\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\004\000\000\000\000\000\000\012n\016\004X(\223\196\143@\016\031@(\0001\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 \020\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\005\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\n\001\129'\144\000\000P\n\000\012`\000\196 \b\128P\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\n\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\245|\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\136P\012\t<\128\000\002\128P\000c\000\006!\000D\002\128`I\228\000\000\020\002\128\003\024\0001\b\002 \020\003\002G \000\000\160\020\000\024\192BE.\224\250\015\133a\192\255\183\002\239M\1918x\012B\000\136\005\000\192\145\200\000\000(\005\000\0060\016\243\219\189\127\171\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\250\190u\207\239\254\220\031\191\182\255\249\224\000\000\000\000\000\003\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\144\000\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\012\128\000\000\000\000\128\000\000\000@\000\000\000\000\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000\000\000\003 \000\000\000\000 \000\000\000\016\000\b\000\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\200\000\000\000\000\b\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\000\000\000\000\000\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\196 \b\128P\012\t\028\128\000\002\128P\000c\001\015=\187\215\250\190u\207\239\254\220\031\191\182\255\251\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\004\000\000\000\000\000\192\001@\000\000\000\000\000\000\000\012n\016\004X(\223\196\143@\016\031@(\0001\192\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!\"\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\by\237\222\191\213\243\174\127\127\246\224\253\253\183\255\207BE.\224\250\015\133a\192\255\183\002\239M\1918x\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\001\012n\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\243\219\189\127\171\231\\\254\255\237\193\251\251o\255\158\132\138]\193\244\031\n\195\129\255n\005\222\155~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\001\207\245\187\199\234\191\253\207\247\255]\255\190\150\255\253\235\219\178 A\127\021 \000\1528\0298\224\176(41\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\000cp\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\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\030\003\016\128 @\0020$\218\000 \n\000\000\001\004\000\024\132\001\002\000\017\129\"\208\001\000P\000\000\b \000\000\000\000\000\000\000\000 \000\000\000\016\000\019\004@\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\004\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\016\000\000\000\b\000\t\002 cp\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\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\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 \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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\016\001\136@\016 \001\024\018-\000\016\005@\000\000\130\000\000\000\000\000\000\000\000\002\000\000\000\001\000\001 D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\017@\004\016\nC\000\003 \001\152\000\002\000E\237\217\016 \191\138\144\000L\028\014\156pX\020\026\025\252$Z\177U\191\153\158\128\160>\224P\001\227\128\006!\000@\128\004`H\180\000@\021\000\000\002\b\001\000\000\016\000\000\000\000\b\000\000\000\000\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\000p\000@\004\000\000\000\016\000\000\000\000\000\000\000\000\001\000\000\000 \000\016\000\128\000\000\000\000\000\000\000\000\b\000\000\000\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\000\t\000\"\128\b \020\134\000\004@\003\176\000\004\000\000\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000B@\b\160\002\012\005!\192\001\016\000\204\000\001\000\000\018\000E\000\016@)\012\000\b\128\006`\000\b\000\000\144\002(\000\130!H`0d\0003\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\192\000\128\000\000\000\000 \000\000\000\000\000\000\000\000\006\000\004\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\016\000\000\000\000\000 \000\002\000\000\012\004\000\128\000\000\128\128\000\000\004\000\000\000\000\000\000\144\002(\000\130\005Hp\000d\0003\000\000@\b\001\000 \000\0160 \000\000\001\000\000\000\000\000\004\000\000\000\000\000@\000\004\000\000\000\002\000\000\000\000\000\192@\b\000\000\b\b\000\000\000@\000\000\000\000\000\t\000\"\128\b T\135\000\006@\0030\000\004\000\128H\001\020\000A\000\1640\000\"\000\025\128\000 \004\002@\b\160\002\b\005!\000\001\016\000\204\000\001\000 \012\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\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\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\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\b\000\000\128\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/n\200\129\005\252T\128\002`\224t\227\130\192\160\208\207\225\"\213\138\173\252\204\244\005\001\247\002\128\015\028\011\219\178 A\127\021 \000\1528\0298\224\176(43\248H\181b\171\1273=\001@}\192\160\003\199\000\012\004\000\128\128\000\128\130\000\000\004\000\000\000\000\000\000` \004\000\000\004\004\016\000\000 \000\000\000\000\000\003\001\000 \000\000 \000\000\001\000\000\000\000\000\000$\000\138\000 \129R\028\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\000\000\000\000@\000`\001\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\016\000\000\000\000\000\000\000\000\000\016\000\000\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\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000H\001\020\000A\016\1648\024\"\000\029\128\016 \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\144\018(\000\130\001H`\000D\0003\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\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\135\003\004@\003\176\002\004\000\000\017\000\000\002\000\002\000\012\000\000\000 \000\000\000\000\000\136\000\000\000\000\016\000`\000\000\001\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\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 \000\000\000\000\000\000\000\000\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\000H\001\020\000a\000\1648\000\"\000\029\128\000`\000\001\128\000\024\000\000\024\\(\000\016\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\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\004@\000\000\000\000@\000\001\000\000\000\000\000\128\000\000\"\000\000\000\000\002\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\128\000 \016\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\002 \000\000\000\000 \000\000\128\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\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\000\000\000\000\000\000\000\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\000\001\128\000\001\133\194\000\001\000\000\000\000\000\000\001`\020P\001\006\006\144\224\000\200\000f\000@\132\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000X\005\020\000A\001\1648\0002\000\025\128\016!\004\000\136\000\000\000\000\016\000 \000\000\001\000\000\000\000\000\000\000\016\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\001 \004P\001\004\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\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\006\000\000\006\023\n\000\004\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\024\000\001\128\000\001\133\194\000\001\000\000\000\000\000\000\001`\004P\001\004\006\144\224\000\200\000f\000@\132\016\011\000\162\128\b04\135\000\006@\0030\002\004 \128\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\001\128\000\024\000\000\024\\ \000\016\000\000\000\000\000\000\022\000E\000\016@i\014\000\012\128\006`\004\bA\000\176\n(\000\131\003Hp\000d\0003\000 B\b\004\128\017@\004\016\nC\128\002 \001\152\000\002\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000x\001\023\128\193\003\015\164\000\"\000\024\000\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\003\000\000\018@\0020\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\001 \004PA\004\000\016\192\000\128\000v\000D\128\016\006 \000x\016\000ap\160\000@\004\000@\000 \0000\000\019\128\128\003\011\132\000\002\000\000\000\000\001@\000\000\000\000\000\016\b\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,\128\138\000 \129R\026\000\017\000\028\192\b\016\002\001 \004P\001\132\002\144\224\000\136\000f\000A\132\016\t\000\"\128\b \020\135\000\004@\0030\002\004 \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\b \004@\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\138\000 \128\002\024\000\016\000\012\192\b\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\000\000\000\000\000\000\002@\b\160\002\b\005!\192\001\016\000\236\000\129\000 \004@\000\016\000\000\128\001@\000\000\b\000\128\000@\000\"\000\000\000\000\004\000\n\000\000\000@\004\000\002\000\000\000\000\000\000 \016\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\002@\b\160\003\b\005!\192\001\016\000\204\000\131\b \018\000E\000\016@)\014\000\b\128\006`\004\bA\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017\000\000\000\000\002\000\004\000\000\000 \000\000\001\000\002@\b\160\002\b\000!\128\001\000\000\204\000\001\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\004\000\000\000\000\000\000\000\000\000\000\t\000\"\130\b \000\134\000\004\000\003\176\002$\000\1281\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\000\000\000\000\000\000\000\000\000\000\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\017\000\012\192\b\016\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\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\004\128\017@\004\016\000B\000\002\000\001\152\000\002\000\000\b\000\000\001\000\000\000\004\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\001\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\002@\b\160\002\b\016!\128\001\000\000\204\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\016\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\138\000 \129\002\024\000\016\000\012\192\128\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007\000\004\000@\000\000\001\000\000\000\000\000\000\000\000\000\016\000\000\002\000\001\000\b\000\000\000\000\000\000\000\000\000\128\000\000\000\000\b\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\144\002(\000\130\000\b`\000@\000;\000\002@\000\001\000 \000\0160 \000\000\001\000\000\000\000\000\004$\000\138\000 \192\002\028\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\006\000\004\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\016\000\000\000\000\000 \000\n\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\004\b`\000@\0003\002\000@\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\002\000@@\000 `@\000\000\002\000\000\000\000\000\bH\001\020\000A\128\0048\000 \000\025\128\000 \004\002@\b\160\002\b\000!\000\001\000\000\204\000\001\000 \012\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\004\000\000\b\001\001\000\000\129\129\000\000\000\b\000\000\000\000\000! \004P\001\006\000\016\224\000\128\000f\000\000\128\016\t\000\"\128\b \000\132\000\004\000\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\128\000\000\000\000\001\000\000\016\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\017@\004\016\000C\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@\b\b\000\004\012\b\000\000\000@\000\000\000\000\001\t\000\"\128\b0\000\135\000\004\000\0030\000\004\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\128\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\001\000 \0160 \128\000\001\000\000\000\000\000\000\b\001\001\000\000\129\129\004\000\000\b\000\000\000\000\000\000@\b\b\000\004\012\b\000\000\000@\000\000\000\000\001\t\000\"\128\b0\000\135\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\136\000\000\016\000\016\000`\000\000\001\000\000\000\000\000\004@\000\000\000\000\128\003\000\000\000\b\000\000\000\000\000\"\000\000\000\000\004\000\b\000\000\000@\000\000\000\000\004\128\017@\006\016\000C\128\002\000\001\152\000\006\000\000D\000\000\001\000\000\128\006\000\000\000\000\000\000\000\000\002\000\000\000\b\000\004\0000\000\000\000\000\000\000\000\000\016\000\000\000\000\000 \001\128\000\000\000\000\000\000\000\000\128\000\000\000\000\001\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@\001\000\000\000\000\000\000\000\000\000@\000\002H\000@\000\000\002\000\000\000\000\000\001\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\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\016\000\002\000\016\001\"\004\000\000\000\000\000\000\000\000\002\000\000 \000\000\144!@@\000\000\004\000\128\000\000\016\000\001\000\000\004\129\b\002\000\000\000 \004\000\000\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\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\001\000\000\016\000\000@\016\128 \000\000\002\000@\000\000\016\000\000\000\000@ \001\000\000\000\000\000\000\000\000\000\128\000\000\000\002\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\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\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\001\000\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000@\000\004\000\000\016\0048\b\000\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\016\000\000@\002\000\000\000\000\000\000\000\000\001\000\000\000\128\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\004\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 \b`\016\000\000\001\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\001\000\b\000\145\006\000\000\000\000\000\000\000\000\000@\000\b\000@\004\136\016\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\016\000\000\000\000\000\000\b\000\000\000\000\000\000\000\128\000\128\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\002\000\000\000\001\000\000 \001\000\018 @\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@\000\000\000\000\000\000\000\000\000\000\016\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\004\000\000\000\000\002\000\000\000\000\000\001\000\000\000\000\000 \000\000\000\000\016\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\001 \005P\001\004B\144\224 \136\000v\000@\128\016\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\b\000\000\000\004\000\000\128\004\000H\129\000\000\000\000\000\000\000\000\000\144\002\168\000\130!Hp\016D\000;\000 @\b\004\000\000@\000\001\000C\128\128\000\000\b\001\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.0\000\b\000\000\000\000\000\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\004\000\000\000\000\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\016\000\001\000\000\004\001\014\006\000\000\000 \004\000\000\000\128\000\b\000\000 \b`\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\000\000\000\000\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\001\000\000\004\001\b\002\000\000\000 \004\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\128\002 \001\152\000\002\000@$\000\138\000 \128R\016\000\017\000\012\192\000\016\002\002\000\000\000\000\000\004\0000\000\000\000\000\000\000\000\000\016\000\000\000\000\000 \000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\004\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\128\017@\004\016\nC\128\002 \001\152\000\002\000@$\000\138\000 \128R\016\000\017\000\012\192\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\128\000\000\000\000\001\000\012\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@\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\000\000\000\000\000\000\000\000\000\004\000\000\024\000\001\192H\001\149\194\000\001\000\000\000\000\000\000\001`\021P\001\006\004\016\224\000\136\000v\000\001\128\016\006\000\000`\000\000ap\128\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\128\025\\ \000\016\000\000\000\000\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000P\000\000\000 \000\000\000\000\016\000\000\000\000\000\b\002\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\024\000\001\192H\001\149\194\000\001\000\000\000\000\000\000\000\192\000\012\000\000\012.\016\000\b\000\000\000\000\000\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\002\192*\160\002\012\b!\192\001\016\000\236\000\001\000 \022\001U\000\016`A\014\000\b\128\007`\000\b\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\021@\004\016\000C\128\002\000\001\216\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\t\000\"\128\b \000\134\000\004\000\0030\000\004\000\128H\001\020\000A\000\004 \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\000\000\000 \000\000\192\000\014\002@\012\174\016\000\b\000\000\000\000\000\000\t\000\"\128\b \000\134\000\004\000\0030\000\004\000\128H\001\020\000A\000\004 \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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\017@\004\016\000B\000\002\000\001\152\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\004\128\017@\004\016\000C\000\002\000\001\152\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004P\001\004\000\016\128\000\128\000f\000\000\128\016\004\000\000$\128\004`\001\000 \000\000\000\000\000\016\000 \000\001$\000#\000\000\001\000\000\000\000\000\000\128\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\018\000E\000\016@)\012\000\b\128\007`\004\b\001\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 \001\152\001\002\000@$\000\138\000 \128R\016\000\017\000\012\192\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\000H\001\020\000A\000\004 \000 \000\025\128\000 \004\001\000\000\t \001\024\000@\b\000\000\000\000\000\004\000\b\000\000I\000\b\192\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\016\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\128H\001\020\000A\000\004 \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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\b\000\000\000\000\000\000\000\000\004@\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\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\197 \n\018\000\140\t\021\128\b\002\144\000\001A\000\002\000\000@\002\000d@\128\000\000\128\000\000\000\000\000@\000\004\000\000\018\004(\024\000\000\000\128\016\000\000\002\000\000 \000\000\144!\000\192\000\000\004\000\128\000\000\016\000\001\000\000\004\001\b\006\000\000\000 \004\000\000\001\000\000\000\000\004\002\000\016\000\000\000\000\000\000\001\000\000\000\000\000\000 \016\000\128\000\000\000\000\000\000\000\000\000\000\000\000\001\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\000\000\000\000\128\000H\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\001\000\000\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\000\000\000\000 \000\002\000\000\b\002\024\012\000\000\000@\b\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\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\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\b\000\000\128\000\002\000\135\003\000\000\000\016\002\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\018\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\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\016\000\000\b\000\000 \001\000\000\000\000\000\000\000\016\000\000\000\000@\000\001\000\b\000\000\000\000\000\000\000\000\000\000\000\002\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\000b\144\005\t\000F\004\138\192\004\001H\000\000\160\128\003\128\0008\b\0000\184@\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\004\000\000\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\004\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0001H\002\132\128#\002E`\002\000\164\000\002P@\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\000\000\000\000\000\000\000\000\000\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\128\000\000@\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\002\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\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\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\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\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\001\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\171Pj\137\211?\188\017\000\\\202\b\128P\000c\128\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\0001\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\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\001\000\002\128\000\000\000\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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&\192\248\003\000@@>\001\000 \000,0\025\141\194\022\139\005\027\248\145\232\002\003\232\005\000\0078\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\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\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\004\000\n\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\000\000!\231\183z\255W\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\016\243\219\189\127\171\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\152\220 \b\176Q\191\137\030\128 >\128P\000c\128\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\by\237\222\191\213\243\190\127\127\246\224\253\253\183\255\2071\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\192 \000\000\000\000\006\000\n\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\000\000!\231\183z\255W\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\016\243\219\189\127\171\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\152\220 \b\176Q\191\137\030\128 >\128P\000c\128\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\by\237\222\191\213\243\190\127\127\246\224\253\253\183\255\2071\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\192\000\000\000\000\000\000\000\000\000\000\000\000\018\000\000\000\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\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\001\015=\187\215\250\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 \000\000\000\000\000\000\000\000\000\000\000\000\000\135\158\221\235\253_;\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<\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000C\207n\245\254\175\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\030\135\158\221\235\253_;\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\250\190u\207\239\254\\\031\190\150\255\249\224\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\012n\016\004X(\223\196\143@\016\031@(\0001\192\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\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\002\000\000\000\001\000\001 D\012n\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\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\004\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\0001\b\002\004\000#\002E\160\002\000\160\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\000b\016\132@(\006\004\142@\000\001@(\0001\128\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\024\220 \b\176Q\191\137\030\128 >\128P\000s\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\141\194\004\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\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\004\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\001\136@\017\000\160\024\0189\000\000\005\000\160\000\198\002\000\000\000\000\000\000\000\000\000\001\128\000\002@\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\000D\000\000\000\000\000\000\000\000\002\000\001 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\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\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\024\000\000$\000\000\000\002\000\000\000\000\000`\b\224\000\000\000\000\000\000\000\b\000\000\136\000\000\000\000\000\000\006\000\004\t\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\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\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\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\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\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\000\016\000\000\000\000\000\000\000\000\000\000\004\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\012\000\000\192\000\000\194\225\000\000\128\000\000\000\000\000\000 \000\000\000\001\002\000\000\000\004\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\000\000\000\000\197 \n\018\002\140\t\021\128\b\002\128\000\001A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012R\000\161 (\192\145X\000\128(\000\000\020\016\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\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\198\225\000E\130\141\252H\244\001\001\244\002\160\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\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\030\003\016\128 @\0020$Z\000 \n\128\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\004\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\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\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\020\187\131\232>\021\135\003\254\220\011\1896\252\225\224\000\004\000\031\000`\b\b\007\192`\004\000\005\130\003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\030{w\175\245|\235\159\223\253\184?\127m\255\247\192\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\002D\015\1280\004\004\003\224P\002\000\002\193\001\128\000\002\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \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\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\014\000\000\224 \000\194\225\000\000\128\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\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\b\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\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\132\138]\193\244\031\n\195\129\255.\005\222\011~p\240\000\000\000\000\000\000\000\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\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\000\000\000\000\000\000` \004\000\000\004\004\000\000\000 \000\000\000\000\000\000\000\004\000\000\000 \000\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@\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\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\018\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\004\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\160\000\000E\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\192\000\b\128>\000\192\016\016\015\128@\b\000\015\132\006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\001\001\000\000\129\129\000\000\000\b\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\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\016\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\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\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\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\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\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\002\000\000\b\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000@\000\000\000\000\000\003\000\0000\000\0000\184\192\000\"\000\000 \000\000\000\024\000\001\128\000\001\133\194\000\001\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\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\128\000\000\001\000\000\000\002 \000\000\000\000\000\001\128\000\024\000\000\024\\ \000\017\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\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\002\000\000\000\000\000\000\000\000\000\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\002\000\000\000\000\000\000\000\000\000\000\000 \000\000\004\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000@\000\000\000\000\b\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\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\000\000\000 \016\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\000H\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\000\000\000\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\004\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\128\000D\000\000\000\000\b\000\016\000\000\000\128\000\000\000\000\t\000\"\128\012 \020\135\000\004@\003\176\000\012 \000\017\000\000\000\000\002\000\004\000\000\000 \000\000\000\000\002@\b\160\002\b\005!\192\001\016\000\204\000\001\b\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\002\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000H\001\020\016A\000\1640\000\"\000\029\128\016 \004\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\004\000\b\000\000\000@\000\000\002\000\004\128\017@\004\016\nC\000\002 \001\152\000\002\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\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\bH\001T\000A\130\1648\000\"\000\029\128\002 \004@\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\144\002(\000\130\001H`\000D\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\000\000\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\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\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\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\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\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\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\012B\000\129\000\b\192\145h\000\128*\000\000\004P\016\145K\184>\131\225Xp?\229\192\187\193o\206\030\132\138]\193\244\031\n\195\129\255.\005\222\011~p\240\024\132\001\002\000\017\129\"\208\001\000T\000\000\b\160!\"\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\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\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\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\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\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@\b \002\b\000!\000\001\000\000\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\b\128\000\000\000\001\128\002\000\000\000\016\000\000\000\000\000\000\017\000\252\001\129 \000\031\016\128\016 \006\n,\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\004\000\000\000\000\000\000\002\000\000\000\001\000\000\000\000\0000\000\000\000\000\000\000\000\000\000\000\000\002\000\031\1280$\000\003\226\016\002\004\000\193E\128\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\128\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\000\000\000\000\000\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\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\000\004\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\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\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\001\000\000\000\000\000\000\128\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\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\000\000\000\000\000\000\001\000\004\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\002\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\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\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\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006!\000@\128\004`H\180\000@\021\000\000\002\b\000\000\000\000\000\000\000\000\b\000\000\000\001\000\004\129\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\006\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\000\000\000 \000\000\000\016\000\000\000\000\003\000\000\000\000\000\000\000\000\000\0003\248H1b\171\1273=\001P}\200\160\001\199\000\004\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\178\018\b\000\130\007H@@D\000r\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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!\000\001\016\000\200\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\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\001 \004\016\001\004\002\144\128\000\128\000`\000\000\128\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\000\000\000\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\003?\132\131\022*\183\2433\208\021\007\220\138\000\028p\025\252$\024\177U\191\153\158\128\168>\228P\000\227\128\t\000 \128\b \020\132\000\004@\003 \000\004\000\000H\001\004\000A\000\164 \000\"\000\025\000\000 \000\000\000\000\000\000\000\000\000\000\000\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\b\000\130\001H`\000D\0002\000\000@\000\004\128\016@\004\016\nB\000\002 \001\144\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\000H\001\004\000A\000\1640\000\"\000\025\000\000 \000\002@\b \002\b\005!\000\001\016\000\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\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000") + (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\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\"\001@0$r\000\000\n\001@\001\140\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\128\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\001\128\000\000\016\000\000\000@\000\000\000\000\000\000\000\000\012\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\001\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\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000B@\n\160\002\012\021!\192\001\016\000\236\b\025\000 \018\000A\000\016@\001\n\000\b\000\006 \000\b\000\000\144\002\b\000\130\000\b@\000@\0001\000\000@\000\000\000\000\000 \0000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\004\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\128\007\224\012\t\000\000\248\132\000\129\000 Q`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\002\128\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\000\000\000\000\000\000\000\000\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\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\t\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\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\136\000\000\000\000\000\000\000\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\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\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\192\000\014\002\000\012.\016\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\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\005\128Y\208\004\025\026C\129\131\"\001\216\017\"\017@\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\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\001\128\000\028\004\b\024\\ \000\016\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\001\000 \0160 \128\000\001\000\000\000\000\000\000\b\001\001\000\000\129\129\004\000\000\b\000\000\000\000\000\000@\b\b\000\004\012\b\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\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\000\000\000\000\000\000\000\000\000\000\000g\240\144b\197V\254f\250\002\128\251\137@\003\142\003?\132\131\022*\183\2433\208\020\007\220J\000\028p\000\192\000\004\152 \140\000 \004\000\000\000\000\000\002\000\006\000\000$\129\004`\001\000 \000\000\000\000\000\016\0000\000\001$\b#\000\000\001\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\000@\000\000\000\000\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\000\018@\0020\000\000\016\000\000\000\000\000\b\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\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\001\000\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\002\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\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\016\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\002\000\000\018@\002\000\000\000\016\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\004\000\000\000\000\000\000\000\000\000\000\t\000\"\130\b \020\134\000\004@\003\176\002\004\000\1281\000\003\192\128\003\011\133\000\002\000 \002\000\001\000\002@\b\160\003\b\021!\192\001\016\000\204\b\131\b \012@\000\224 \000\194\225@\000\128\b\000\128\000@\000`\000\135\001\002\006\023\b\000\004\000\000\000\001\000\000\133\128]\192\004\025\026C\129\130\"\001\216\001f\017`\024\000\001\128\000\001\133\194\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\006\000\000`\000\000ap\128\000D\000\000@\000\000\000\016\000\128\000\000\001\000\000\000\002 \000\000\000@\000\001\128\000\028\004\000\024\\ \000\016\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\192g\240\145b\197V\254fz\002\128\251\153@\003\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\0000\016\002\002\000\002\002\b\000\000\016\000\000\000\000\128\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\000\000\000\000\000\000` \004\000\000\004\004\000\000\000 \000\000\000\000\000\007\001\000 \000\000 \000\000\001\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\128\002\000\000\000@\000 \001\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\b\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\002\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\191\214\239\2517\223\251\255\254N\143\238e\132\014y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\2241\184@\017p\163\127\018}\000@}\000\160\000\199\001\141\194\000\139\005\027\248\147\232\002\003\232\005\000\0068\012n\016\004X(\223\196\143@\016\031@(\0001\192cp\196#\241V\254\164z|\194\250A\192\025\174\176\024\132!\016\n\001\129#\144\000\000P\n\000\012`\024\220 \b\176Q\191\137\030\128 >\128P\000s\129\015=\187\215\250\190w\207\239\254\220\031\191\182\255\249\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224\001\136A\0160\001\024\018m\000\016\005\000\000\000\130\000\012B\b\129\000\b\192\147h\000\128(\000\000\004\016\000b\016D\b\000F\004\139@\004\001@\000\000 \128\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\000P\000\000\b \000\196 \b\016\000\140\t\022\128\b\002\160\000\000Q\000\006!\002@\128\004`H\180\000@\021\000\000\002\b\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\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\000D\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\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\002 \000\000\000\000 \000\000\000\016\000\000\000\000\000\000\017\000\000\000\000\000\000\000\000\000\128\000\000\000\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\001\136@\0160\001\024\018i\000\016\005\000\000\000\130\000\012B\000\129\000\b\192\147H\000\128(\000\000\004\016\000b\016\004\b\000F\004\138@\004\001@\000\000 \128\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000&)\027P\144\020`I\172\002@\020\160@\218\170\000\000\b\000\004\000 \000\000 \000\000\128\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\019\020\141\168H\n0$\222\001 \n\208\016mU\000\b\000\000\000\000\001\000\"\128\000\000\000\000\000\000\000\000\196!\b\016\000\140\t\022\128\b\002\160\000\002A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\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\000l\000\000@\000\004\000\b\000\002\128\002b\136\000\196 \b\016\000\140\t\022\128\b\002\160\000\000A\000 \000\027\000\000\016\000\001\000\002\000\000\160\000\152\162\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\000\000\000\000\000\000\000\000\000\000\002b\017\180\b\001F\004\155@$\001Z\000\t\170\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\004\196#h\016\002\140\t6\128H\002\180\000\019U@\007!\136G\224,iH\180\248\196\021\129\0002Y`\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\b\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\128\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\128 @\0020$R\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\128\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\016\000\000\000\000\000\t\130 \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 \004\000\003`\000\002\000\000 \000@\000\020\000\019\020@\006\000\000p\016\000ap\128\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\012B\000\129\000\b\192\145h\000\128*\000\000\004\016\002\000\001\176\000\001\000\000\016\000 \000\n\000\t\138 \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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\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\002\000\000\000\000\000\001 D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\129 @\0020$Z\000 \n\128\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\144\000\000\000\000\b\000\000\000\000\000\004\133\016\001\136@\144 \001\024\018-\000\016\005@\000\000\162\000\000\000\000\000\000\000\000\000\000\000\000\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\128\000\000\000\000\128\000\000\000\000\000H\017\000\000\000D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000 \000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\017\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\229$Z\019\004\142\153\245\128\200\002\246\000\027\197P\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\002\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\000\000\128\000\000\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\002\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\016\004\b\000F\004\139@\004\001@\000\000 \128\003\020\128(H\0020$\214\001 \n@\000M\021\128\016\000\000\000\000\001\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\006!\000@\128\004`H\180\000@\021\000\000\002\b\000\000\000@\000\000\000\000\b\000\000\000\004\000\004\193\016\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\016\000\000\000\000\002\000\000\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\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\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\000b\144\005\t\000F\004\138\192\004\001H\000\004\160\128\003\016\128 @\0020$R\000 \n\000\000\001\004\000\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\006!\004@\200$`I\180\000@\021\000\000\002\b\0000\016\002\002\000\002\002\b\000\000\016\000\000\000\000\128\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\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\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\000\192\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\128\016\016\000\b\024\016\000\000\000\128\000\000\000\000\000\004\000\144\128\000@\192\128\000\000\004\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\001\000\004\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\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\004\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\000\000\000\000\000\000\000\000\000\000\000\000\132\128\021@\004\024\nC\128\002 \001\216\000\"\000@\004\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\192\000\004\144\000\140\000\000\004\000\000\000\000\000\002\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\004\000\001\000\000\001\128\000\030\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\007\001\000\006\023\b\000\004\000\000\000\000\000\000\132\128\021@\004\024\nC\128\002 \001\216\000\"\001@\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000! \005P\001\006\002\144\224\000\136\000v\000H\128Q\t\000*\128\b0\020\135\000\004@\003\176\002D\000\1280\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\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\016\144\002\168\000\131\001Hp\000D\000;\000$@\b\000\000\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\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\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000B@\n\160\002\012\005!\192\001\016\000\236\000\017\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\002\000\000\000\001\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\004$\000\170\000 \193R\028\000\017\000\014\192\129\144\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\004\000\128\128\000@\192\128\000\000\004\000\000\000\000\000\016\144\002\168\000\131\001Hp\000D\000;\000\004@\b\001\000 \000\0160 \000\000\001\000\000\000\000\000\004$\000\170\000 \192R\028\000\017\000\014\192\001\016\002\000\000\000\000\000\000\000\000\000\000\000\000\016\004\004\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\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\016\144\002\168\000\131\005Hp\000D\000;\002\004@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004$\000\170\000 \192R\028\000\017\000\014\192\001\016\002\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\000B@\n\160\002\012\005!\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\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\000\000\000\000\000\002\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000B@\n\160\002\012\021!\192\001\144\000\236\000\019\000 \028\004\016\128\000\000\128\128\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\004\000\000\000 \000\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@\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\000\000\000\000\000\000\000\000\000\000\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\144\002\168\000\131\005Hp\000d\000;\002\004\192\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\004\000\b\000\000\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\198\225\002E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\001\000\000\000\000\128\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\004\000 \000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000b\016\004@(\006\004\142@\000\001@(\0001\128\128\000\b\128\000\000\000\000\000\000`\000@\144$\000\000\024\132\001\016\n\001\129#\144\000\000P\n\000\012`\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\006!\000DB\128`I\228\000\000\020\002\128\003\024\0001\b\002 \020\003\002O \000\000\160\020\000\024\192\001\136@\017\000\160\024\0189\000\000\005\000\160\000\198\001\141\194\000\139\133\027\248\147\232\002\003\232%\000\0068\012n\016\004X(\223\196\159@\016\031A(\0001\192cp\128\"\193F\254$z\000\128\250\t@\001\142\003\027\132\001\023\n7\241'\208\004\007\208\n\000\012p\024\220 \b\176Q\191\137>\128 >\128P\000c\128\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\017@\001\136@\016 \001\024\018m\000\016\005@\000\000\138\000\012B\000\129\000\b\192\145h\000\128*\000\000\004P\000b\016\004\b\000F\004\139@\004\001P\000\000 \128\016\000\000\000\000\b\000\000\128\000\000\000\000\000H\017\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\197 \n\026\000\140\t5\128\b\002\128\000\000A\000\006)\000P\144\004`I\172\000@\020\000\000\002\b\0001H\002\132\128#\002E`\002\000\160\000\000\016@\001\200b\017\248\011\026R->1\005`@\012\150X\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\003\020\128(H\n0$V\000 \n\000\000\005\004\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\196 \b\024\000\140\t6\128\b\002\160\000\000A\000\006!\000@\128\004`I\180\000@\021\000\000\002\b\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\000\000\000\000\000\000\000\000@\000\128\000 \000$\b\129\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\000\016\000\018\004@\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\0001\b\002 \020\003\002G \000\000\160\020\000\024\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\004<\246\239_\234\249\215?\191\251p~\254\219\255\239\128@\000\000\000\000\012\001\028\000\000\000\000\000\000\000\000\198\225\136G\226\173\253H\244\249\133\244\131\1283]`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0001\184B\017`\163\127\018=\000@}\000\160\000\199\001\141\194\016\139\005\027\248\145\232\002\003\232\005\000\0068\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\000\000\000\000\b\000 \000\000\000\000\000\001\000\000\002\000@@\000 `@\000\000\002\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\001\141\194\016\139\005\027\248\145\232\002\003\232\005\000\0068\012n\016\132X(\223\196\143@\016\031@(\0001\192\003\016\132 @\0020$Z\000 \n\000\000\001\004\000\000\000\000\000\000\000\000\004\000\000\000\002\000\002`\136\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\001\136@\017\016\160\024\018y\000\000\005\000\160\000\198\000\012B\000\136\005\000\192\147\200\000\000(\005\000\0060\000b\016\004@(\006\004\142@\000\001@(\0001\128\132\138]\193\244\031\n\195\129\255n\005\222\155~p\240\024\132\001\016\n\001\129#\144\000\000P\n\000\012`!\231\183z\255W\206\185\253\255\219\131\247\246\223\255|\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\2241\184@\017`\163\127\018=\000@}\000\160\000\199\002\030{w\175\245|\235\159\223\253\184?\127m\255\243\192\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\000\000\000\001 \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\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\016\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\000\001\144\000\000\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\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@\017\000\160\024\0189\000\000\005\000\160\000\198\002\030{w\175\245|\235\159\223\253\184?\127m\255\247\192\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\b\000\000\000\000\001\128\002\128\000\000\000\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\000BE.\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\243\219\189\127\171\231\\\254\255\237\193\251\251o\255\158\132\138]\193\244\031\n\195\129\255n\005\222\155~p\240\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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!\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\000\000\000\000\000\000\000\000\b\000\000\000\000\000\002\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\bH\165\220\031A\240\1728\031\242\224]\224\183\231\0151\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\204n\016\004X(\223\196\143@\016\031@(\0001\192\132\138]\193\244\031\n\195\129\255.\005\222\011~p\240\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000!\231\183z\255W\206\185\253\255\219\131\247\246\223\255=\t\020\187\131\232>\021\135\003\254\220\011\1896\252\225\2307\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\003\159\235w\143\213\127\251\159\239\254\187\255}-\255\251\215\183d@\130\254*@\0010p:q\193`Phcp\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\000\000\000\000\000\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\002\018)w\007\208|+\014\007\252\184\023x-\249\195\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!\"\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\0151\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\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!\"\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\0151\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\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!\"\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\0151\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\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!\"\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\0151\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\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!\"\151p}\007\194\176\224\127\203\129w\130\223\156<\006!\000@\128\004`I\180\000@\020\000\000\002\b\0001\b\002\004\000#\002E\160\002\000\160\000\000\016@\000\000\000\000\000\000\000\000@\000\000\000 \000&\b\128\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\016\000\018\004@\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\001\136@\016 \001\024\018-\000\016\005@\000\000\130\000\000\000\000\000\000\000\000\002\000\000\000\001\000\001 D\000b\016\004\b\000F\004\139@\004\001P\000\000 \128\000\000\000\000\000\000\000\000\128\000\000\000@\000H\017\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\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\b\000\t\002 \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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \020\134\000\006@\0030\000\004\000\139\219\178 A\127\021 \000\1528\0298\224\176(43\248H\181b\171\1273=\001@}\192\160\003\199\000\012B\000\129\000\b\192\145h\000\128*\000\000\004\016\002\000\000 \000\000\000\000\016\000\000\000\000\000\t\002 cp\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\224\000\128\b\000\000\000 \000\000\000\000\000\000\000\000\002\000\000\000@\000 \001\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\b\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\000\016@)\012\000\b\128\007`\000\b\000\000 \004\004\000\002\006\004\000\000\000 \000\000\000\000\000\132\128\017@\004\024\nC\128\002 \001\152\000\002\000\000$\000\138\000 \128R\024\000\017\000\012\192\000\016\000\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\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\024\b\001\000\000\001\001\000\000\000\b\000\000\000\000\000\001 \004P\001\004\n\144\224\000\200\000f\000\000\128\016\002\000@@\000 `@\000\000\002\000\000\000\000\000\b\000\000\000\000\000\128\000\b\000\000\000\004\000\000\000\000\001\128\128\016\000\000\016\016\000\000\000\128\000\000\000\000\000\018\000E\000\016@\169\014\000\012\128\006`\000\b\001\000\144\002(\000\130\001H`\000D\0003\000\000@\b\004\128\017@\004\016\nB\000\002 \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\128\000\b\000\000H\001\020\000A\000\1640\000\"\000\025\128\000 \004\002@\b\160\002\b\005!\000\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\000\000\004\000\000\000\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\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\023\183d@\130\254*@\0010p:q\193`Phg\240\145j\197V\254fz\002\128\251\129@\007\142\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\000H\001\020\000A\002\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\128\000\192\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\000\016\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\192\000\014\002\000\012.\016\000\b\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\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\144\002(\000\130!Hp0D\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\001 $P\001\004\002\144\192\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016D)\014\006\b\128\007`\004\b\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\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\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\194\001Hp\000D\000;\000\000\192\000\003\000\0000\000\0000\184P\000 \000\000\000\000\000\000\000\000\000\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\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\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\b\128\000\000\000\000\128\000\002\000\000\000\000\001\000\000\000D\000\000\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\000\000\000\000\001\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\004@\000\000\000\000@\000\001\000\000\000\000\000\128\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 \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\128\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\002\192(\160\002\012\r!\192\001\144\000\204\000\129\b \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\176\n(\000\130\003Hp\000d\0003\000 B\b\001\016\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 \004P\001\004\002\144\224\000\136\000f\004\000\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\000\000\000\000\000\000\128\000\002@\b\160\002\b\005!\192\001\016\000\204\000\001\000\000\018\000E\000\016@)\012\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\000\0000\000\0000\184P\000 \000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\128\000\000\000\192\000\012\000\000\012.\020\000\b\000\000\000\000\000\000\000\000\000\000\000\016\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\002\192\b\160\002\b\r!\192\001\144\000\204\000\129\b \022\001E\000\016`i\014\000\012\128\006`\004\bA\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\003\000\0000\000\0000\184@\000 \000\000\000\000\000\000,\000\138\000 \128\210\028\000\025\000\012\192\b\016\130\001`\020P\001\006\006\144\224\000\200\000f\000@\132\016\t\000\"\128\b \020\135\000\004@\0030\000\004\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\240\002/\001\130\006\031H\000D\0000\000\000@\000\003\000\000\018`\1300\000\128\016\000\000\000\000\000\b\000\024\000\000\146\004\017\128\004\000\128\000\000\000\000\000@\000\192\000\004\144 \140\000\000\004\000\000\000\000\000\002\000\006\000\000$\128\004`\000\000 \000\000\000\000\000\016\000\016\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\002@\b\160\130\b\000!\128\001\000\000\236\000\137\000 \012@\000\240 \000\194\225@\000\128\b\000\128\000@\000`\000'\001\000\006\023\b\000\004\000\000\000\000\002\128\000\000\000\000\000 \016\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\000Y\001\020\000A\002\1644\000\"\0009\128\016 \004\002@\b\160\003\b\005!\192\001\016\000\204\000\131\b \018\000E\000\016@)\014\000\b\128\006`\004\bA\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 \001\152\001\002\016@\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\000H\001\020\000A\000\0040\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\000\000\000\000\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\128\002 \001\216\001\002\000@\b\128\000 \000\001\000\002\128\000\000\016\001\000\000\128\000D\000\000\000\000\b\000\020\000\000\000\128\b\000\004\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\004\128\017@\006\016\nC\128\002 \001\152\001\006\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\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\001 \004P\001\004\002\144\192\000\136\000f\000@\128\016\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\136\000\002\000\000\016\000 \000\000\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\000\000\004\000\b\000\000\000@\000\000\002\000\004\128\017@\004\016\000C\000\002\000\001\152\000\002\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\138\000 \128\002\024\000\016\000\012\192\b\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\000H\001\020\000A\000\1640\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\"\000\000\128\000\004\000\b\000\000\000@\000\000\002\000\001\016\000\000\000\000 \000@\000\000\002\000\000\000\016\000$\000\138\000 \128\002\024\000\016\000\012\192\000\016\128\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\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\002\000\000\000\000\b\004\000 \000\000\000\000\000\000\002\000\000\000\000\000\000@ \001\000\000\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\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\144\000\012n\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\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\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 \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\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\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\016\000\001\000\000\004\001\014\006\000\000\000 \004\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\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\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\016\000\000@\002\000\000\000\000\000\000\000 \000\000\000\000\128\000\002\000\016\000\000\000\000\000\000\000\000\000\000\000\004\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000b\144\005\t\000F\004\138\192\004\001H\000\004\160\128\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000 \000\000\128!\128\192\000\000\004\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\128\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\004\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\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\024\164\001B@\017\129\"\176\001\000R\000\000( \000\224\000\014\002\000\012.\016\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\001\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\002\000\000\000\001\000\000\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\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\000\000\000\000\000\000\000\000\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\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\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\b\000\001\000\b\001\145\006\000\000\002\000\000\000\000@\000@\000\b\000@\012\1360\000\000\016\000\000\000\000\000\002\000\000@\002\000d@\128\000\000\128\000\000\000\000\000\016\000\002\000\016\003\"\004\000\000\004\000\000\000\000\000\001\136A\0162\001\024\018m\000\016\005\000\000\000\130\002\246\236\136\016_\197H\000&\014\007N8,\n\r\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 \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\016\000\000\000\000\000\000\b\000\000\000\000\000\000\000\128\000\128\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\002\000\000\000\001\000\000 \001\0002 @\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@\000\000\000\000\000\000\000\000\000\000\016\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\138@\020$\001\024\018k\000\016\005\000\000\000\130\000\012R\000\161 \b\192\145X\000\128(\000\000\004\016\000b\144\005\t\001F\004\138\192\004\001@\000\000 \128\001\000\000 \001\0002 @\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\002\000@\000\b\000@\012\136\016\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000yIV\160\213\019\166\127x\"\000\185\148\016x\212\001\136@\017\000\160\024\0189\000\000\005\000\160\000\198\002\030{w\175\245|\235\159\223\253\184?\127m\255\247\208\243\219\189\127\171\231\\\254\255\237\193\251\251o\255\190\007\148\149j\rQ:g\247\130 \011\153A\007\141@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\024\132\017\002\000\017\129&\208\001\000P\000\000\b \000\196 \136\016\000\140\t\022\128\b\002\128\000\000A\000\006!\000@\128\004`H\180\000@\020\000\000\002\b\000H\001\020\000A\000\1640\0002\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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@\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\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\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 \004P\001\004\002\144\128\000\136\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\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\004\128\017@\004\016\nB\000\002\000\001\152\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\000H\001\020\000A\000\164 \0002\000\025\128\000 \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016@)\b\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\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\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\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\001 \000\000\000\000\000\000\000\000\002\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\000\000M\129\240\006\000\128\128|\002\000@\000X`3\027\132-\022\n7\241#\208\004\007\208\n\000\014p\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\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\000\000\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\000C\207n\245\254\175\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\255W\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\171\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\175\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\255W\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\171\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\245|\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\250\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\253_;\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\250\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\245|\235\159\223\252\184?}-\255\243\192\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\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\0001\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\b1\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\016\004\b\000F\004\139@\004\001@\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\196!\b\128P\012\t\028\128\000\002\128P\000c\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\231\000\000\000\000\000\000\000\000\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\003\027\132\t\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\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\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\003\016\128\"\001@0$r\000\000\n\001@\001\140\004\000\000\000\000\000\000\000\000\000\003\000\000\004\128\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\136\000\000\000\000\000\000\000\000\004\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\001\000\000\000\000\000\000\001\016\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\128\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\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\0000\000\000H\000\000\000\004\000\000\000\000\000\192\017\192\000\000\000\000\000\000\000\016\000\001\016\000\000\000\000\000\000\012\000\b\018\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\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\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\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\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\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\012n\016\004X(\223\196\143@\016\031@(\0001\192\000\000\000\000\000\000\000\000\000\000\000\000\000\002\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\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\001\200b\017\248\011\026R->1\005`@\012\150X\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\003\020\128(H\n0$V\000 \n\000\000\005\004\000\024\000\001\128\000\001\133\194\000\001\000\000\000\000\000\000\000@\000\000\000\002\004\000\000\000\b\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\001\138@\020$\005\024\018+\000\016\005\000\000\002\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\000\000\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\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\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\001\141\194\000\139\005\027\248\145\232\002\003\232\005@\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\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<\006!\000@\128\004`H\180\000@\021\000\000\002\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\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012n\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!\"\151p}\007\194\176\224\127\203\129w\130\223\156<\000\000\000\000\000\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\002\018)w\007\208|+\014\007\253\184\023zm\249\195\192\000\b\000>\000\192\016\016\015\128\192\b\000\011\004\006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004<\246\239_\234\249\215?\191\251p~\254\219\255\239\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\136\031\000`\b\b\007\192\160\004\000\005\130\003\000\000\004\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\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\128\001\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\006\000\000\000@\000\000\001\000\000\000\000\000\000\000\000\0000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\001\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\001\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000D\000\000\b\000\b\0000\000\000\000\128\000\000\000\000\002 \000\000\000\000@\001\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\000\000\000\001\000\000\000@\000\128\000\000\000\002\000\000\000\000\000\000\000\000\000\002\000\004\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\003\001\000 \000 \128\000\001\000\000\000\000\000\000\024\b\001\000\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\000\000\000\b\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\000\128\016\016\000\b\024\016\000\000\000\128\000\000\000\000\002\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\000\000\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\b\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\000\002@\b\160\002\b\021!\192\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` \004\000\000\004\004\016\000\000 \000\000\000\000\000\003\001\000 \000\000 \000\000\001\000\000\000\000\000\000$\000\138\000 \129R\028\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\134\000\004\000\0030\000\004\000\000H\001\020\000A\000\164 \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\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\016\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\128\000\000\000\000\000\006\000\000`\000\000aq\128\000D\000\000@\000\000\0000\000\003\000\000\003\011\132\000\002 \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 \001\000\000\000\002\000\000\000\004@\000\000\000\000\000\003\000\0000\000\0000\184@\000\"\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\000\000\004\000\000\000\000\000\000\000\000\000\000\000@\000\000\b\000\000\000\000\000\128\000\000\001\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\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\016\000\000\000\000\002\000\000\000\000\000\001\000\000\000\000\000\128\000\000\000\000\016\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\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\016\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\144\002(\000\130\001Hp\000D\0003\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\002 \000\b\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\000\000\018\000E\000\024@)\014\000\b\128\007`\000\024@\000\"\000\000\000\000\004\000\b\000\000\000@\000\000\000\000\004\128\017@\004\016\nC\128\002 \001\152\000\002\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004P\001\004\002\144\192\000\136\000f\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\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\004\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\144\002( \130\001H`\000D\000;\000 @\b\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\b\128\000 \000\001\000\002\000\000\000\016\000\000\000\128\000D\000\000\000\000\b\000\016\000\000\000\128\000\000\004\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\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\016\144\002\168\000\131\005Hp\000D\000;\000\004@\b\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\192\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\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\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\000\000\000\000\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\024\132\001\002\000\017\129\"\208\001\000T\000\000\b\160!\"\151p}\007\194\176\224\127\203\129w\130\223\156=\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\2241\b\002\004\000#\002E\160\002\000\168\000\000\017@BE.\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\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\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\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\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\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\004\128\016@\004\016\000B\000\002\000\001\144\000\002\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\017\000\000\000\000\003\000\004\000\000\000 \000\000\000\000\000\000\"\001\248\003\002@\000>!\000 @\012\020X\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\b\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\004\000?\000`H\000\007\196 \004\b\001\130\139\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\001\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\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\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\192\000\014\002\000\012.\016\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\b\000\000\000\001\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\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\002\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\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\016\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192@\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\000\002\000\b\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\004\000\128\128\000@\192\128\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\128\000\000\000\000\b\000\000\128\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\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\001\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\016\000\000\000\002\000\t\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\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\000\000\000\000\000\000@\000\000\000 \000\000\000\000\006\000\000\000\000\000\000\000\000\000\000g\240\144b\197V\254fz\002\160\251\145@\003\142\000\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\001d$\016\001\004\014\144\128\128\136\000\228\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\004\128\016@\004\016\nB\000\002 \001\144\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\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!\000\001\000\000\192\000\001\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\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\000\000\000\000\000\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\2243\248H1b\171\1273=\001P}\200\160\001\199\000\018\000A\000\016@)\b\000\b\128\006@\000\b\000\000\144\002\b\000\130\001H@\000D\0002\000\000@\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\b\000\130\001H`\000D\0002\000\000@\000\004\128\016@\004\016\nB\000\002 \001\144\000\002\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") and start = 15 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\022N\006\021\218P\240^0\000\000\000\025\000\000\000\000\001\030\000\000\000\000P\130\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\002\248\002\160\000\t\000\000\000\000\002\236\000\000Q\168c\208\022\022\\\148\022|\003\168\0001k\026\000\000\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\234\001\132\000\157\000\000\000\168\004B\000\000\000\242\000\226\004J\000\000\005L\002\000\n\\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\000\000\002\160]`\000\000\000\000\000h\000\000\000\000^\002\003<\002\200\000\000\000\000L$\000h\000\000P\172\022\022Q\168\004\130\004\242\003\168\004\176\000\000\022\022I\186TB\022\022_\180\000\000\001<\000\000Yj\004\250\000\000\028x\000\000\000\016\000\000\000\000\001\166\000\000\000h\000\000\000\000\000\000\001\206\000\000\028x\000\000\004\004}\210\133\030k\176\135.O\016YX_\198\000\000s\172\026\018]`N\160I\186I\186\000\000\000\000\000\000I\244I\244\003\168\004\176\004\176\022\022\000\003\025\174\000\208\005\182\000\000\004v\005\186\000\000\000\000\000\000\000\000\000\000\022\022\000\000\000\000\000\000T|\022\022\000\003T|\022\022\000\003G\174w\030I\186\000\252\000\003Tr\022\022\131j\000\000^0{\002~F\000\000\005\182\000\000\0056\000\000\023\164K([\140\000\000K([\140\000\000K(\137z\007\028\006\194\004\004\002\164\000\000\005\164\000\000\000\000\b0\000\000\000\000\000\000K(\000h\000\000\000\000_\180K(^\234_\198\000\000\000\000[J\007\028\000\000\000\000_\198\005\252K(\000\000\\4_\198]\030\000\000\000\000\000\000\003(\000\000K(\000\000\021\024\140N\000\000K(\007VK(\000\000\030.\006\148\000h\000\000\000\000\031,\000\000\bT\000\000a\166\0040\000\000\006\204K(\004|\000\000\004\146\000\000\003\138\000\000\000\003\006b\000\000\000\000\000\000$@\tX^0Tr\022\022^0\000\000\007\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000ZR\030\140\000\000\000\000\000\000\001\254\026\002~F\000\000Tr\022\022^0\000\000\000\000Z\160^0\138\012^0\138f\000\000`X\000\000\000\000`\252P\130\004\180\004\180\000\000\b,^0\000\000\000\000\000\000\bB\b~\000\000\027\138\000\000^0\138\152K(\003~\000\000^0\138\230\0001\000\000\000\000\000\000\b\186\000\000\022Z\000\000\129\148\000\000\b\198\000\000QF^0\000\000\000\000H\250\tB\005\182\t\156\000\000\000\000\000\000\000\000\b\180\000\000O\138\006\022\th\007\174K(\016\186\t\200\000\000\000\000\007l\th\t\018\000\003^0b\128\002\254\000\000^0\024\144K(\017\138\t\018\n\152\000\000\000\000\000\000Q~\004\180\n\168pb^0\000\000\000\003T|P&I\244\003\168\004\176\003~\002\004\000\t\000\000\n\132Q\168Q\168\003~\002\004\002\004\000\000\011bQ\168\000\000p\230\001LYj\005\182\005\248\140\158\000\000K(lVK(e&l\222K(\005lK(mh\000\000\t\134\n\150\006\140Q\168qn\000\000\006\196\011\148d\020\000\000\000\000\000\000\000\000Q\168q\246Q\168r~\000\218\004\004e\176\005\186\004\004f:\000\000s\006\001L\000\000\000\000\023f\000\000\025\228\000\000\011x\004\176\000\000d\158S\184\000\000\000$\000\000Q\168\026P\000\000\000\000\000\000cF\000\000\000$\000\003K\178\005\234\t\170\000\003\024\006L\184\018\022\000\003T|\022\022\018\022T|\022\022J\182T|\022\022\000\003Tr\022\022^0^0H\250\000\003Tr\022\022~\214Rz\004\180\012(w\172\000\003Tr\022\022^0\028N\000\003Tr\022\022^0\027\138\000\003\018\022\000\000\000\000\000\000\000\000\001\250\023rH\180\000\000UPV$I\244\003\168\004\176\006\192Q\168\026b\000\000V\248W\204{\002\029LK(\t\174\000\003T|\022\022\018\022\024\006\018\022\003\002\017\254\000\003\000\003\018\022\n\200\012\006\007\220K(#|K(\028\nK(#\154\012P\000\000\000\000\012:\000\000\018\022\004\n\012b\000\000$\236\000\003\r\n\000\000\027\254\000\003\019\020\025\004\000\000\000\000\000\000\000\000\b\224\000\003\000\000\000\000\t\202\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^0\029\134K(\n\208\000\003\000\000\031\130\000\003\000\000^0 F^0 \128^0!D\0001\000\000\000\000\000\000!~^0\"B\000\000x\020N\160I\186^0N,\000\003\000\000I~\025\174\000\208\000h\133jQ\168\130\000x\020x\020\000\000\000\000\004\002\005\n\000\t\006\n\004\176\127>Q\168\005\198\004\176\127\200x\020\135\140\002\160\000\t\006\nx\020\135\140\000\000\006\n\000\000\000\000\006\nx\020\000\000N\160I\186N\160I\186I\244\003\168\004\176x\020\000\000\022|\003\168\0001\012X]`\n\n\000h\000\000K(x\158\012\142\rX\133\206\000\000x\020\000\000y\004K\198\022\022\005\170\000\000\t\148\r\176\000\000\014 \128,_\198\000=\000\000\014\014\r\162]`\011\030K(#\250\022\022\011\152\021\220\000\000$\248\014l\000\000\000\248\000\000\000\000\014\146_\198f\194\000\000m\242\006\178\n\146\002\004\b&\r\218\022\022x\020\000\000\141\160\011\184_\198\014l_\198s\142gj\014p_\198t,h\018\022\022x\020\000\000\000\000n\200TB\022\022k\254Yj\011\208n\006\133\030\137z\000=\014\168\000\000\000\000t\174yh\022\022\000\000\130d\005\170\000\000\000\000\131\174\000\000\000\000\000\000\128\144\025z\026x\000=\014\224\000\000\000\000\000\000yh\022\022\000\000\000=\015\006\000\000\000\000\000\000\000\000\000\000\131\174\000\000\015\000\027\226\000\000\022\232\137\146\000\000\000\000\000\000\000\000\012\028}\210\133\030\000\000\131\174\000\000\000\000\131\174\000\000\015\014\027\226\022\232\137\146\000\000\140\216\023\152\002\248\000\208\004\004\131\174\000\000\000\208\004\004\131\174\000\000JP\025\174\000\208\000h\133jQ\168x\020\000\000\004\002\006\194\bn\004\004\131\174\000\000\000\t\014tQ\168x\020Y\252\002\160\000\t\014xQ\168x\020Y\252\000\000\000\000\007\018\000\003x\020\000\000Q\168\135\192x\020\000\000\007\018\000\000P\172\022\022Q\168x\020\000\000K\198\022\022\005\170yh#\242\029j\021\220\017\184\000\000\012v\028x\011b\000\000\015\014\014\198\0312\021\218[ZK(\012N\000\000Rf\003\218\006\242\011\232\000\000\011\198\000\000\015L\014\206K(UP\000\000\003\168\017\180\012*\000\000\012`\000\000\015Z\014\216]`Q\236\000\000\022\022\0312\015z\004j\000\208\000\003\002X\0312K(\012\158\007\028\000\000K(\b\238\n\234\000\000\000\000uT\000\000\000\003\005\204\0312u\222UP\000\000\022\022K(\012\168K(H\180Q\236\000\000\014\254\000\000Q\236\000\000\000\000Rf\000\000x\020\136^\021\220\017\184\012v\015b\015$\0312x\020\136^\000\000\000\000\021\220\017\184\012v\015\134\015$\139>Y<_\198\015\202\139>\137z\028\202\015\204\139>_\198\015\220\139>y\232zh\000\000b0\000\000\000\000x\020\138\252\021\220\017\184\012v\015\214\015\\\139>x\020\138\252\000\000\000\000\000\000\140\216\000\000\000\000\000\000\000\000\000\000\000\000\000\000x\020\000\000\136l\022\022M\004\015\228}\210\000\000\131\174\136l\000\000\000\000\139\202\022\022M\004\015\246\015z\133\030\000\000\131\174\139\202\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\026#\242\021\220\017\184\012v\015\254{\002J\224\021\218P\240V\248\022f\002\210\000=\016\n\n\012\000\003\000\000\015\176\000\003\000\000Q\236\000\000\007\222\012\230\000\000\r^\000\000\016\020\015\156K(O\156\016\"\012\b\000\003\000\000\015\214\000\003\000\000\022\138\003\168\r(\016J{\132]`\004\180\015\224K(\rp\000\003\000\000\015\252\000\003\000\000\000\000\000\000pb\015\254\000\003\000\000\000\000\000\000Q\236\000\000\021\182\rd\000\000\r\132\000\000\016\\\015\218]`\000\000\016`|\006_,\004\180\015\254K(\rv\000\003\000\000\016(\000\003\000\000\000\000\022\022\000\003Q\236\000\000\022<\022\022J\224J\224|\250N\160\022\022\131j^0\n\200\000\000\021\178\000\208\000\003\tZJ\224K(\r\228\005\182\000\000\022\022{\002{\002J\224\r\136J\224\000\000L\166\018\022\005\018\006\026M\160\000\000\000\000\000\000hv\000\000\000\000i\000\000\000\000\000i\138\000\003\r\138J\224j\020\131j^0\n\200\000\000\007\012\000\000\139>\016\198\000\000G\174\016\166\000\000Q\236\000\000J\224G\174Q\236\000\000\022\022K(Q\236\000\000\016X\000\000Q\236\000\000\000\000V\248\000\000\1328\139>\016`J\224\132\156{\002\000\000x\020\137\b\021\220\017\184\012v\016\198{\002x\020\137\b\000\000\000\000\000\000\129vTr\022\022\131j^0x\020\000\000\000\000\000\000\000\000\000\000\000\000\1342\000\000\000\000\134\180\000\000x\020\000\000\136l\000\000\000\000\000\000\000\000x\020\129v\000\000\017\004\000\000\1342\000\000\134\180\017\022\000\000\017\026\000\000\000\0003\206\000\003\017,\000\000\000\003\017.\000\000\012\230\018\252\000\003\0178\000\000j\160J\182\000\000\000\003\017@\000\000\000\003\017@\000\000\000\000\019\250\000\003\017N\007\"\000\0034\204\000\003\017V\b \000\0035\202\000\003\017V\t\030\000\0036\200%\234\000\003\017l\n\028\000\0037\198\000\003\017\128\011\026\000\0038\196\000\003\017\142\012\024\000\0039\194\012\246\020\248\000\003\017\152\r\022\000\003:\192\000\003\017\150\014\020\000\003;\190\000\003\017\178\015\018\000\003<\188\016\016\000\003=\186\021\016\000\000\017\190\000\000\000\003\017\234\000\000\000\003\017\236\000\000\000\000\"|\000\003\000\000\007\214\000\003\000\000^0\000\000\000\000|x\018\n\000\000K\178\000\000\017P\000\000X\158\000\000\018\"\000\000\005\234\017\190\000\000\024\006\031r\005\182\000\000\031\192\000\000\011T\014N\023|\000\000\000\000\018:\000\000\001t\027\000R\128\000\000\014(\000\000\000\000\000\003\017\154\000\003\017\160\000\000\017\176\000\003\017\182\000\000\000\003\014(\000\003\017\194\000\003\017\222\000\000\000\000Sv\004\180\018\146w\172_\198\t\240\000\003\000\000w\172\000\000\000\000\000\000w\172\000\000\018l\000\003\000\000\000\003\000\000\000\000\000\000>\184^0\000\000\000\000\018\170\000\003?\182\000\003@\180\000\000\018\000\000\000\027\000j\160\000\000\017\014\018\154\000\000vP\014\"\014\136\000\000\000\000\018$\000\000\018\172\000\000\000\000\003\168\004\176\023\160\000\003\000\000\002\248\002\160\000\t\006\n\018L\000\003\000\000K\198\022\022\005\170\000\230\003~\018R\000\003\000\000\000\000\000\000\000\000\000\000\018\204\000\000\000\000\141\024\004\180\018\006\246\n)\n)\n)\n)\002J\001\154\n)\n)\n)\n)\000\238\n)\n)\004i\n)\n)\n)\b\026\n)\n)\n)\n)\004i\n)\000\n\n)\n)\n)\n)\n)\n)\n)\n)\001\246\n)\000\238\n)\004\202\n)\n)\n)\n)\n)\006\250\007\022\n)\n)\n)\002\014\n)\002\030\n)\n)\n)\002\237\004J\n)\n)\n)\n)\n)\n)\n)\002V\n)\n)\n)\n)\n)\n)\n)\n)\n)\n)\n)\002v\n)\n)\006B\n)\n)\n)\004i\002z\004i\004i\005>\n)\n)\n)\n)\n)\n)\004i\n)\n)\n)\n)\n)\t\174\n)\001\158\n\006\n)\004i\n)\n)\004i\n)\n)\n)\n)\n)\n)\n)\n)\n)\n)\n)\n)\n)\000\238\n)\n)\n)\n)\n)\003\201\004i\004i\004i\002^\003\201\003\201\003\201\003\201\004i\004\206\003\201\003\201\003\201\003\201\000\238\003\201\003\201\004i\003\201\003\201\003\201\005B\003\201\003\201\003\201\003\201\004i\003\201\027\247\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\004i\003\201\000\238\003\201\005\030\003\201\003\201\003\201\003\201\003\201\003\026\006}\003\201\003\201\003\201\006\133\003\201\004i\003\201\003\201\003\201\004\206\000\238\003\201\003\201\003\201\003\201\003\201\003\201\003\201\002\158\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\005.\t\166\t\254\002\n\003\201\003\201\003\201\002\026\003r\002\170\001\006\0056\003\201\003\201\003\201\003\201\003\201\003\201\002\174\003\201\003\201\003\201\003\201\003\201\t\174\003\201\006\025\n\006\003\201\001*\003\201\003\201\000\238\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\012Q\003\201\003\201\003\201\003\201\003\201\003\185\003n\001\142\001\146\006\002\003\185\003\185\003\185\003\185\003F\b\237\003\185\003\185\003\185\003\185\012Q\003\185\003\185\011\222\003\185\003\185\003\185\002\162\003\185\003\185\003\185\003\185\007\241\003\185\003\142\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\007N\003\185\016\"\003\185\004\014\003\185\003\185\003\185\003\185\003\185\004\206\001\250\003\185\003\185\003\185\003\129\003\185\b\213\003\185\003\185\003\185\004\206\006\025\003\185\003\185\003\185\003\185\003\185\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\004N\t\166\t\254\012\170\003\185\003\185\003\185\001\"\006\154\001\006\007\138\003\146\003\185\003\185\003\185\003\185\003\185\003\185\000\238\003\185\003\185\003\185\003\185\003\185\t\174\003\185\004\213\n\006\003\185\000\238\003\185\003\185\002\214\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\012\174\003\185\003\185\003\185\003\185\003\185\003\181\003\134\b\006\003\150\bZ\003\181\003\181\003\181\003\181\012\186\007\190\003\181\003\181\003\181\003\181\b\213\003\181\003\181\000\238\003\181\003\181\003\181\000\238\003\181\003\181\003\181\003\181\b\150\003\181\004\166\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\005~\003\181\016f\003\181\007V\003\181\003\181\003\181\003\181\003\181\006\190\006\214\003\181\003\181\003\181\0287\003\181\011\246\003\181\003\181\003\181\005J\024b\003\181\003\181\003\181\003\181\003\181\003\181\003\181\b\026\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\007\154\t\166\t\254\001\006\003\181\003\181\003\181\001\"\004\250\011\230\001\142\014\226\003\181\003\181\003\181\003\181\003\181\003\181\007\162\003\181\003\181\003\181\003\181\003\181\t\174\003\181\014\242\n\006\003\181\011\238\003\181\003\181\015\194\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\r&\003\181\003\181\003\181\003\181\003\181\t\201\bZ\004>\004>\002^\t\201\t\201\t\201\t\201\012\186\0202\t\201\t\201\t\201\t\201\000\238\t\201\t\201\015\202\t\201\t\201\t\201\007\214\t\201\t\201\t\201\t\201\006\001\t\201\004j\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\005~\t\201\007\254\t\201\007V\t\201\t\201\t\201\t\201\t\201\0036\004i\t\201\t\201\t\201\000\238\t\201\021\218\t\201\t\201\t\201\004V\007\230\t\201\t\201\t\201\t\201\t\201\t\201\t\201\tn\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\005&\t\201\t\201\026B\t\201\t\201\t\201\006\222\024\226\015*\000\238\003\169\t\201\t\201\t\201\t\201\t\201\t\201\018^\t\201\t\201\t\201\t\201\t\201\t\201\t\201\0206\t\201\t\201\0156\t\201\t\201\004i\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\000\238\t\217\t\201\t\201\t\201\t\201\t\217\t\217\t\217\t\217\018f\003\146\t\217\t\217\t\217\t\217\004N\t\217\t\217\005\249\t\217\t\217\t\217\004i\t\217\t\217\t\217\t\217\006\014\t\217\004\234\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\006\189\t\217\003\169\t\217\022\214\t\217\t\217\t\217\t\217\t\217\026F\b\241\t\217\t\217\t\217\r2\t\217\021\238\t\217\t\217\t\217\004Z\006\198\t\217\t\217\t\217\t\217\t\217\t\217\t\217\006&\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\202\t\217\t\217\t\210\t\217\t\217\t\217\001V\004>\005\189\000\238\022\222\t\217\t\217\t\217\t\217\t\217\t\217\006b\t\217\t\217\t\217\t\217\t\217\t\217\t\217\006z\t\217\t\217\001Z\t\217\t\217\b\241\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\b\193\t\209\t\217\t\217\t\217\t\217\t\209\t\209\t\209\t\209\005\189\028\023\t\209\t\209\t\209\t\209\007-\t\209\t\209\004J\t\209\t\209\t\209\b\241\t\209\t\209\t\209\t\209\014\230\t\209\005\189\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\006\150\t\209\000\238\t\209\004\209\t\209\t\209\t\209\t\209\t\209\n:\007%\t\209\t\209\t\209\007%\t\209\022\002\t\209\t\209\t\209\001\006\007\206\t\209\t\209\t\209\t\209\t\209\t\209\t\209\006\178\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\001f\t\209\t\209\006\158\t\209\t\209\t\209\006\253\006\194\b\193\007\021\006\230\t\209\t\209\t\209\t\209\t\209\t\209\011.\t\209\t\209\t\209\t\209\t\209\t\209\t\209\006\210\t\209\t\209\019\162\t\209\t\209\002^\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\005^\t\189\t\209\t\209\t\209\t\209\t\189\t\189\t\189\t\189\000\238\b\026\t\189\t\189\t\189\t\189\002^\t\189\t\189\012r\t\189\t\189\t\189\023\206\t\189\t\189\t\189\t\189\007\021\t\189\0036\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\nJ\t\189\b\154\t\189\t\146\t\189\t\189\t\189\t\189\t\189\012\178\025f\t\189\t\189\t\189\006\141\t\189\022\026\t\189\t\189\t\189\0036\004\146\t\189\t\189\t\189\t\189\t\189\t\189\t\189\001\162\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\189\001f\t\189\t\189\007\018\t\189\t\189\t\189\002*\011.\018>\026*\007*\t\189\t\189\t\189\t\189\t\189\t\189\012z\t\189\t\189\t\189\t\189\t\189\t\189\t\189\t\202\t\189\t\189\t\210\t\189\t\189\002j\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\b\189\t\197\t\189\t\189\t\189\t\189\t\197\t\197\t\197\t\197\t\194\t\234\t\197\t\197\t\197\t\197\t\202\t\197\t\197\t\210\t\197\t\197\t\197\011\146\t\197\t\197\t\197\t\197\000\238\t\197\012r\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\004\129\t\197\000\238\t\197\007b\t\197\t\197\t\197\t\197\t\197\006\"\007\021\t\197\t\197\t\197\007\021\t\197\022.\t\197\t\197\t\197\015\146\011B\t\197\t\197\t\197\t\197\t\197\t\197\t\197\007\234\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\007~\t\197\t\197\012\238\t\197\t\197\t\197\003\149\004\129\b\189\015\206\bN\t\197\t\197\t\197\t\197\t\197\t\197\002^\t\197\t\197\t\197\t\197\t\197\t\197\t\197\012r\t\197\t\197\012\222\t\197\t\197\002j\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\b\154\t\193\t\197\t\197\t\197\t\197\t\193\t\193\t\193\t\193\002^\006\005\t\193\t\193\t\193\t\193\r\150\t\193\t\193\015\198\t\193\t\193\t\193\003\014\t\193\t\193\t\193\t\193\006\t\t\193\t\002\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\015\242\t\193\015\250\t\193\t\198\t\193\t\193\t\193\t\193\t\193\015\178\t\230\t\193\t\193\t\193\014Z\t\193\022B\t\193\t\193\t\193\rJ\b%\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\242\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\004>\t\193\t\193\b\217\t\193\t\193\t\193\b!\n\002\018\134\016:\000\238\t\193\t\193\t\193\t\193\t\193\t\193\003\t\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\202\t\193\t\193\t\210\t\193\t\193\015\138\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\205\t\193\t\193\t\193\t\193\t\205\t\205\t\205\t\205\000\238\027\174\t\205\t\205\t\205\t\205\n\018\t\205\t\205\018b\t\205\t\205\t\205\012j\t\205\t\205\t\205\t\205\012\169\t\205\012\134\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\014:\t\205\018j\t\205\016\130\t\205\t\205\t\205\t\205\t\205\b\217\012\138\t\205\t\205\t\205\016B\t\205\022^\t\205\t\205\t\205\019\014\b\021\t\205\t\205\t\205\t\205\t\205\t\205\t\205\019\006\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\021\146\t\205\t\205\003\142\t\205\t\205\t\205\005\253\022N\012r\012\181\003\142\t\205\t\205\t\205\t\205\t\205\t\205\012\182\t\205\t\205\t\205\t\205\t\205\t\205\t\205\b\025\t\205\t\205\000\238\t\205\t\205\000\238\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\019\174\t\221\t\205\t\205\t\205\t\205\t\221\t\221\t\221\t\221\019\202\020\022\t\221\t\221\t\221\t\221\018\194\t\221\t\221\019>\t\221\t\221\t\221\023j\t\221\t\221\t\221\t\221\024Z\t\221\003\254\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\b\026\t\221\025\238\t\221\025\006\t\221\t\221\t\221\t\221\t\221\012\210\023B\t\221\t\221\t\221\t\025\t\221\022r\t\221\t\221\t\221\011.\012\214\t\221\t\221\t\221\t\221\t\221\t\221\t\221\012\254\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\r\018\t\221\t\221\026&\t\221\t\221\t\221\006^\rR\016B\rb\t\001\t\221\t\221\t\221\t\221\t\221\t\221\r\170\t\221\t\221\t\221\t\221\t\221\t\221\t\221\005\t\t\221\t\221\b\150\t\221\t\221\023n\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\r\246\t\213\t\221\t\221\t\221\t\221\t\213\t\213\t\213\t\213\000\238\027\018\t\213\t\213\t\213\t\213\t\005\t\213\t\213\014\022\t\213\t\213\t\213\0146\t\213\t\213\t\213\t\213\000\238\t\213\014~\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\014\250\t\213\015\018\t\213\024\250\t\213\t\213\t\213\t\213\t\213\0266\015\154\t\213\t\213\t\213\000\238\t\213\022\134\t\213\t\213\t\213\015\158\025\014\t\213\t\213\t\213\t\213\t\213\t\213\t\213\002^\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\015\214\t\213\t\213\015\218\t\213\t\213\t\213\016\002\016\006\016\030\016\150\016\198\t\213\t\213\t\213\t\213\t\213\t\213\004\129\t\213\t\213\t\213\t\213\t\213\t\213\t\213\016\202\t\213\t\213\016\238\t\213\t\213\026\190\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\016\242\n\025\t\213\t\213\t\213\t\213\n\025\n\025\n\025\n\025\017\002\017\018\n\025\n\025\n\025\n\025\011\146\n\025\n\025\017\030\n\025\n\025\n\025\017R\n\025\n\025\n\025\n\025\017V\n\025\017\166\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\017\206\n\025\017\210\n\025\018\022\n\025\n\025\n\025\n\025\n\025\018:\018J\n\025\n\025\n\025\018r\n\025\022\146\n\025\n\025\n\025\018v\018\130\n\025\n\025\n\025\n\025\n\025\n\025\n\025\018\146\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\018\170\n\025\n\025\018\186\n\025\n\025\n\025\018\206\018\230\019\022\019\026\019&\n\025\n\025\n\025\n\025\n\025\n\025\0196\n\025\n\025\n\025\n\025\n\025\n\025\n\025\003\173\n\025\n\025\019J\n\025\n\025\020>\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\n\025\020J\t\177\n\025\n\025\n\025\n\025\t\177\t\177\t\177\t\177\020z\020\158\t\177\t\177\t\177\t\177\020\198\t\177\t\177\021N\t\177\t\177\t\177\000\238\t\177\t\177\t\177\t\177\021b\t\177\021j\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\021~\t\177\021\138\t\177\021\158\t\177\t\177\t\177\t\177\t\177\021\182\021\194\t\177\t\177\t\177\021\214\t\177\003\173\t\177\t\177\t\177\021\234\021\254\t\177\t\177\t\177\t\177\t\177\t\177\t\177\022\022\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\t\177\022*\t\166\t\254\004%\t\177\t\177\t\177\015\238\022>\015\130\022Z\022n\t\177\t\177\t\177\t\177\t\177\t\177\007\234\t\177\t\177\t\177\t\177\t\177\t\174\t\177\022\130\n\006\t\177\022\166\t\177\t\177\015\246\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\177\t\177\t\177\t\177\t\177\002\t\022\178\b\029\022\190\012\161\002\t\001\002\001\006\002\t\027\178\002j\001\"\002\t\t\190\002\t\022\242\001&\002\t\012\161\002\t\002\t\002\t\023\002\002\t\002\t\002\t\001*\004%\t\238\023\018\001.\002\t\002\t\002\t\002\t\002\t\t\246\002\t\t\178\0012\023\030\003z\023R\002\t\002\t\002\t\002\t\002\t\023z\023\130\003\206\002N\002\t\022\170\002\t\022\182\002\t\002\t\003F\023\138\023\146\003\214\002\t\002\t\002\t\b\142\b\146\b\158\023\166\019\214\005n\002\t\002\t\002\t\002\t\002\t\002\t\002\t\002\t\002\t\023\174\t\166\t\254\023\194\002\t\002\t\002\t\023\242\024\030\0246\024N\024j\005z\002\t\005~\002\t\002\t\002\t\024r\002\t\002\t\002\t\002\t\b\166\021\202\b\170\024\162\022\n\002\t\024\194\002\t\002\t\024\222\002\t\002\t\002\t\002\t\002\t\002\t\005\130\b\186\002\t\002\t\002\t\t2\004j\024\242\n\005\002\t\002\t\002\t\002\t\n\005\001\002\001\006\n\005\025\026\025:\001\"\n\005\n\005\n\005\025n\001&\n\005\025v\n\005\n\005\n\005\025\130\n\005\n\005\n\005\001*\025\226\n\005\026\018\001.\n\005\n\005\n\005\n\005\n\005\n\005\n\005\021\150\0012\026\026\003z\026V\n\005\n\005\n\005\n\005\n\005\026n\026\198\003\206\002N\n\005\021\174\n\005\021\186\n\005\n\005\003F\026\218\026\246\003\214\n\005\n\005\n\005\b\142\b\146\b\158\027\030\n\005\005n\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\027&\n\005\n\005\027N\n\005\n\005\n\005\027V\027^\027j\027r\027{\005z\n\005\005~\n\005\n\005\n\005\027\139\n\005\n\005\n\005\n\005\b\166\n\005\b\170\027\158\n\005\n\005\027\186\n\005\n\005\027\215\n\005\n\005\n\005\n\005\n\005\n\005\005\130\b\186\n\005\n\005\n\005\t2\004j\027\231\n\001\n\005\n\005\n\005\n\005\n\001\001\002\001\006\n\001\028\003\028W\001\"\n\001\n\001\n\001\028s\001&\n\001\028~\n\001\n\001\n\001\028\179\n\001\n\001\n\001\001*\028\199\n\001\028\207\001.\n\001\n\001\n\001\n\001\n\001\n\001\n\001\021\206\0012\029\011\003z\029\019\n\001\n\001\n\001\n\001\n\001\000\000\000\000\003\206\002N\n\001\021\226\n\001\021\246\n\001\n\001\003F\000\000\000\000\003\214\n\001\n\001\n\001\b\142\b\146\b\158\000\000\n\001\005n\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\000\000\n\001\n\001\000\000\n\001\n\001\n\001\000\000\000\000\000\000\000\000\000\000\005z\n\001\005~\n\001\n\001\n\001\000\000\n\001\n\001\n\001\n\001\b\166\n\001\b\170\000\000\n\001\n\001\000\000\n\001\n\001\000\000\n\001\n\001\n\001\n\001\n\001\n\001\005\130\b\186\n\001\n\001\n\001\t2\004j\000\000\002I\n\001\n\001\n\001\n\001\002I\001\002\001\006\002I\000\000\000\000\001\"\002I\t\190\002I\004i\001&\002I\000\000\002I\002I\002I\000\000\002I\002I\002I\001*\004i\t\238\000\000\001.\002I\002I\002I\002I\002I\t\246\002I\022R\0012\000\000\003z\004\218\002I\002I\002I\002I\002I\000\000\000\000\003\206\002N\002I\022f\002I\022z\002I\002I\003F\000\238\000\000\003\214\002I\002I\002I\b\142\b\146\b\158\000\238\019\214\005n\002I\002I\002I\002I\002I\002I\002I\002I\002I\000\000\004i\002I\000\000\002I\002I\002I\019\002\004i\000\000\004i\000\000\005z\002I\005~\002I\002I\002I\000\000\002I\002I\002I\002I\b\166\000\000\b\170\004i\000\000\002I\000\000\002I\002I\019\n\002I\002I\002I\002I\002I\002I\005\130\b\186\002I\002I\002I\t2\004j\004i\004i\002I\002I\002I\002I\004i\004i\b\021\004i\004i\004i\004i\004i\004i\004i\004i\000\000\004i\000\238\004i\004i\004i\004i\004i\004i\000\000\004i\004i\004i\004i\004i\004i\004i\004i\004i\000\000\004i\004i\000\238\000\238\004i\004i\000\000\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\006j\004i\004i\004i\004i\004i\004i\004i\004i\000\238\004i\004i\004i\004i\004i\004i\004i\004i\004i\019\150\004i\000\000\004i\004i\004i\004i\004i\004i\000\238\004i\000\n\004i\004i\004i\004i\004i\004i\004i\000\000\004i\004i\004i\000\000\000\238\004i\004i\002\237\002\237\004i\000\238\004i\004i\000\000\004i\004i\000\000\004i\012\170\000\000\000\000\002\237\001\"\000\000\004i\004i\004i\000\000\000\238\004i\004i\004i\004i\000\169\000\169\004i\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\000\000\169\000\000\000\169\000\169\019j\000\169\000\169\000\000\0062\000\169\000\169\005\222\000\169\000\169\000\169\000\169\012\174\000\169\006F\000\169\000\169\000\000\006N\000\169\000\169\018.\000\169\000\169\000\169\007\138\000\169\012\186\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\003\146\018\158\000\169\000\169\000\000\001\006\000\169\000\169\b>\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\005~\002\237\000\169\000\000\t\029\000\169\000\000\000\169\000\000\000\169\000\000\000\000\000\000\b\006\000\169\000\169\000\169\000\169\000\169\000\169\007\r\000\169\000\169\000\169\007\r\tN\002N\000\169\000\n\r\198\000\169\003\134\000\169\000\238\000\222\000\000\022\246\000\000\000\169\000\000\023\006\023\022\023\"\000\000\000\169\000\169\000\169\000\169\bZ\002A\000\169\000\169\000\169\000\169\002A\001\002\001\006\002A\002\237\000\000\001\"\002A\000\238\002A\000\000\001&\002A\000\000\002A\002A\002A\000\000\002A\002A\002A\001*\000\000\024\134\000\000\001.\002A\002A\002A\002A\002A\000\000\002A\000\000\0012\000\000\003z\000\000\002A\002A\002A\002A\002A\007\r\000\000\003\206\b\162\002A\000\000\002A\000\000\002A\002A\003F\000\000\000\000\003\214\002A\002A\002A\b\142\b\146\b\158\004\022\014\150\005n\002A\002A\002A\002A\002A\002A\002A\002A\002A\000\000\t\166\t\254\000\000\002A\002A\002A\000\000\000\000\000\000\004!\000\000\005z\002A\005~\002A\002A\002A\000\000\002A\002A\002A\002A\b\166\t\174\b\170\000\000\n\006\002A\000\000\002A\002A\001\006\002A\002A\002A\002A\002A\002A\005\130\b\186\002A\002A\002A\t2\004j\000\000\002U\002A\002A\002A\002A\002U\000\238\025R\002U\000\000\000\000\000\000\002U\000\000\002U\000\000\000\000\002U\000\000\002U\002U\002U\000\000\002U\002U\002U\000\000\000\000\001\186\002N\000\000\002U\002U\002U\002U\002U\bZ\002U\000\000\004!\000\000\028c\000\000\002U\002U\002U\002U\002U\000\000\000\000\000\238\000\000\002U\000\000\002U\0062\002U\002U\005\222\007\002\000\000\000\000\002U\002U\002U\006F\012\170\000\000\000\000\006N\001\"\002U\002U\002U\002U\002U\002U\002U\002U\002U\000\000\t\166\t\254\000\000\002U\002U\002U\000\000\r\234\000\000\000\000\000\000\002\237\002U\003\146\002U\002U\002U\000\000\002U\002U\002U\002U\025V\t\174\000\000\000\000\n\006\002U\012\174\002U\002U\007\138\002U\002U\002U\002U\002U\002U\000\n\000\000\002U\002U\002U\012\186\000\000\014\014\002Q\002U\002U\002U\002U\002Q\bF\003\146\002Q\002\237\001\186\002N\002Q\000\000\002Q\0051\000\000\002Q\000\000\002Q\002Q\002Q\002\237\002Q\002Q\002Q\005~\000\000\0051\b\006\000\000\002Q\002Q\002Q\002Q\002Q\000\000\002Q\014\026\007\138\000\000\000\000\000\000\002Q\002Q\002Q\002Q\002Q\007\138\000\238\005\182\000\000\002Q\000\000\002Q\r\178\002Q\002Q\000\000\0051\br\003\246\002Q\002Q\002Q\006n\012\170\004\002\000\000\tv\001\"\002Q\002Q\002Q\002Q\002Q\002Q\002Q\002Q\002Q\000\000\t\166\t\254\b\006\002Q\002Q\002Q\000\000\000\000\000\000\0051\000\000\b\006\002Q\0051\002Q\002Q\002Q\000\000\002Q\002Q\002Q\002Q\000\238\t\174\000\000\000\000\n\006\002Q\012\174\002Q\002Q\000\238\002Q\002Q\002Q\002Q\002Q\002Q\000\000\000\000\002Q\002Q\002Q\012\186\003B\r\238\002E\002Q\002Q\002Q\002Q\002E\000\000\003\146\002E\000\000\000\000\028G\002E\000\000\002E\000\000\000\000\002E\000\000\002E\002E\002E\000\000\002E\002E\002E\005~\000\000\000\000\000\000\000\000\002E\002E\002E\002E\002E\000\000\002E\r\250\007\138\000\000\000\000\000\000\002E\002E\002E\002E\002E\007\138\000\000\tN\023^\002E\000\000\002E\r\178\002E\002E\000\000\000\000\025^\022\246\002E\002E\002E\023\006\023\022\023\"\000\000\025\154\000\000\002E\002E\002E\002E\002E\002E\002E\002E\002E\000\000\t\166\t\254\b\006\002E\002E\002E\000\000\000\000\000\000\006.\000\000\b\006\002E\000\000\002E\002E\002E\000\000\002E\002E\002E\002E\000\238\t\174\007\138\000\000\n\006\002E\000\000\002E\002E\000\238\002E\002E\002E\002E\002E\002E\000\000\b\021\002E\002E\002E\b\021\000\000\025\166\002M\002E\002E\002E\002E\002M\000\238\000\000\002M\000\000\000\000\000\000\002M\000\000\002M\014:\000\000\002M\000\000\002M\002M\002M\b\006\002M\002M\002M\012\025\012\025\000\000\000\000\012\025\002M\002M\002M\002M\002M\b\021\002M\000\000\t.\000\000\000\000\000\238\002M\002M\002M\002M\002M\000\000\000\000\000\000\b\021\002M\000\000\002M\0062\002M\002M\005\222\006:\000\000\027\006\002M\002M\002M\006F\000\000\012I\000\000\006N\000\238\002M\002M\002M\002M\002M\002M\002M\002M\002M\b\021\000\000\002M\000\000\002M\002M\002M\000\000\012I\000\000\000\000\002\194\025\170\002M\002\198\002M\002M\002M\000\000\002M\002M\002M\002M\012\025\000\238\007\138\000\000\002\210\002M\b\021\002M\002M\000\000\n\026\002M\002M\002M\002M\002M\t\026\t\218\002M\002M\002M\007\138\b\189\025\178\t%\002M\002M\002M\002M\t%\000\000\001\162\t%\002\222\023\150\001\"\t%\000\000\t%\000\000\000\000\nV\026\230\t%\nz\t%\b\006\t%\t%\t%\0062\000\000\000\000\005\222\027\n\n\142\n\166\n\174\n\150\n\182\006F\t%\000\000\000\238\006N\b\006\000\238\t%\t%\n\190\n\198\t%\000\000\012\170\027\150\002j\t%\001\"\t%\000\000\n\206\t%\002\226\002\237\000\000\000\238\t%\t%\000\238\012\186\000\000\000\000\000\000\000\000\000\000\t%\t%\n^\n\158\n\214\n\222\n\238\t%\t%\000\000\000\000\t%\000\000\t%\t%\n\246\000\000\b\189\000\n\000\000\000\000\012\174\t%\005~\t%\t%\n\254\b\241\t%\t%\t%\t%\000\000\007\181\007\138\002\237\012\186\t%\000\000\t%\t%\000\000\011\030\t%\011&\n\230\t%\t%\002\237\002\237\t%\011\006\t%\000\000\000\000\026\254\002\129\t%\t%\011\014\011\022\002\129\ne\000\000\002\129\005~\007\181\000\000\002\129\000\000\002\129\000\000\000\000\002\129\000\000\002\129\002\129\002\129\b\006\002\129\002\129\002\129\007\181\000\000\000\000\007\181\t\138\002\129\002\129\002\129\002\129\002\129\007\181\002\129\026v\ne\007\181\000\000\000\238\002\129\002\129\002\129\002\129\002\129\000\000\b\169\000\000\000\000\002\129\000\000\002\129\ne\002\129\002\129\ne\011:\000\000\000\000\002\129\002\129\002\129\ne\000\000\000\000\000\000\ne\000\000\002\129\002\129\n^\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\001&\b\169\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\000\000\000\000\001F\000\000\002\129\000\000\002\129\002\129\b\169\002\129\002\129\002\129\002\129\002\129\002\129\001R\000\000\002\129\002\129\002\129\000\000\000\000\000\000\002i\002\129\002\129\002\129\002\129\002i\000\000\000\000\002i\000\000\000\000\000\000\002i\000\000\002i\000\000\005n\002i\000\000\002i\002i\002i\b\169\002i\002i\002i\004\246\000\000\000\000\b\169\000\000\002i\002i\002i\002i\002i\002^\002i\005z\000\000\000\000\000\000\000\000\002i\002i\002i\002i\002i\000\000\b\165\000\000\000\000\002i\000\000\002i\001*\002i\002i\000\000\000\000\000\000\023*\002i\002i\002i\005\130\000\000\000\000\015\162\000\000\000\000\002i\002i\n^\002i\002i\002i\002i\002i\002i\0036\000\000\002i\016\026\002i\002i\002i\003F\000\000\000\000\b\165\000\000\000\000\002i\0162\002i\002i\002i\000\000\002i\002i\002i\002i\000\000\000\000\000\000\000\000\000\000\002i\000\000\002i\002i\b\165\002i\002i\002i\002i\002i\002i\000\000\0075\002i\002i\002i\0075\000\000\000\000\002u\002i\002i\002i\002i\002u\000\238\000\000\002u\000\000\000\000\000\000\002u\000\000\002u\t\166\t\254\nV\000\000\002u\002u\002u\b\165\002u\002u\002u\004\246\000\000\000\000\b\165\000\000\002u\002u\002u\n\150\002u\000\000\002u\t\174\011N\000\000\n\006\000\000\002u\002u\002u\002u\002u\000\000\000\000\000\000\000\000\002u\000\000\002u\011V\002u\002u\011^\000\000\000\000\000\000\002u\002u\002u\011f\000\000\000\000\000\000\011n\0075\002u\002u\n^\n\158\002u\002u\002u\002u\002u\000\000\000\000\002u\000\000\002u\002u\002u\t\202\000\000\000\000\t\210\000\000\000\000\002u\000\000\002u\002u\002u\000\000\002u\002u\002u\002u\000\000\000\238\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\133\002u\002u\002u\002u\002\133\007\201\000\000\002\133\000\000\007\177\000\000\002\133\000\000\002\133\002^\000\000\002\133\000\000\002\133\002\133\002\133\000\000\002\133\002\133\002\133\007\177\000\000\026\002\005\222\000\000\002\133\002\133\002\133\002\133\002\133\007\177\002\133\000\000\007\201\007\177\000\000\000\000\002\133\002\133\002\133\002\133\002\133\000\000\000\000\000\000\000\000\002\133\000\000\002\133\007\201\002\133\002\133\005\222\0036\000\000\000\000\002\133\002\133\002\133\007\201\000\000\000\000\000\000\007\201\000\000\002\133\002\133\n^\002\133\002\133\002\133\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\004\146\000\000\000\000\002\133\005\r\002\133\002\133\002\133\000\000\002\133\002\133\002\133\002\133\000\000\000\238\000\000\000\000\000\000\002\133\000\000\002\133\002\133\000\000\002\133\002\133\002\133\002\133\002\133\002\133\000\000\000\000\002\133\002\133\002\133\000\000\000\000\000\000\002e\002\133\002\133\002\133\002\133\002e\007\217\000\000\002e\000\000\007\221\000\000\002e\000\000\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\0062\000\000\000\000\005\222\000\000\002e\002e\002e\002e\002e\007\221\002e\000\000\007\217\007\221\000\000\000\000\002e\002e\002e\002e\002e\000\000\000\000\000\000\000\000\002e\000\000\002e\011\130\002e\002e\007\217\000\000\000\000\000\000\002e\002e\002e\007\217\000\000\000\000\000\000\007\217\000\000\002e\002e\n^\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\002e\000\000\000\238\000\000\000\000\000\000\002e\000\000\002e\002e\000\000\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\002e\002e\000\000\000\000\000\000\002q\002e\002e\002e\002e\002q\000\238\000\000\002q\000\000\007\173\000\000\002q\000\000\002q\000\000\000\000\nV\000\000\002q\002q\002q\000\000\002q\002q\002q\007\173\000\000\000\000\005\222\000\000\002q\002q\002q\n\150\002q\007\173\002q\000\000\022\202\007\173\000\000\000\000\002q\002q\002q\002q\002q\000\000\000\000\000\000\000\000\002q\000\000\002q\011V\002q\002q\011^\000\000\000\000\000\000\002q\002q\002q\011f\000\000\000\000\000\000\011n\000\000\002q\002q\n^\n\158\002q\002q\002q\002q\002q\000\000\000\000\002q\000\000\002q\002q\002q\000\000\000\000\000\000\012!\012!\000\000\002q\012!\002q\002q\002q\000\000\002q\002q\002q\002q\000\000\000\000\012\029\012\029\000\000\002q\012\029\002q\002q\000\000\002q\002q\002q\002q\002q\002q\000\000\000\000\002q\002q\002q\000\000\000\000\000\000\002m\002q\002q\002q\002q\002m\002\237\000\238\002m\000\000\015v\000\000\002m\000\000\002m\000\000\000\000\nV\000\000\002m\002m\002m\000\238\002m\002m\002m\b\t\000\000\000\000\000\000\b\t\002m\002m\002m\n\150\002m\000\n\002m\000\000\000\000\012!\000\000\000\000\002m\002m\002m\002m\002m\000\000\000\000\000\000\000\000\002m\002\237\002m\012\029\002m\002m\000\000\000\000\000\000\007\017\002m\002m\002m\007\017\002\237\002\237\000\000\000\000\b\t\002m\002m\n^\n\158\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\b\t\002m\000\000\002m\002m\002m\000\000\002m\002m\002m\002m\000\000\000\000\000\238\000\000\000\000\002m\000\000\002m\002m\000\000\002m\002m\002m\002m\002m\002m\000\000\000\000\002m\002m\002m\000\000\000\000\000\000\002\149\002m\002m\002m\002m\002\149\004\246\001\006\002\149\000\000\000\000\007\017\002\149\000\000\002\149\000\000\000\000\nV\000\000\002\149\002\149\002\149\000\000\002\149\002\149\002\149\b\005\000\000\000\000\000\000\b\005\n\142\n\166\n\174\n\150\n\182\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002\149\002\149\n\190\n\198\002\149\000\000\000\000\n\n\003\134\002\149\000\000\002\149\000\000\n\206\002\149\000\000\000\000\000\000\000\000\002\149\002\149\000\238\021v\000\000\021\130\000\000\000\000\b\005\002\149\002\149\n^\n\158\n\214\n\222\n\238\002\149\002\149\000\000\000\000\002\149\000\000\002\149\002\149\n\246\000\000\000\000\000\000\000\000\000\000\b\005\002\149\000\000\002\149\002\149\n\254\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\n\230\002\149\002\149\000\000\000\000\002\149\011\006\002\149\000\000\000\000\000\000\002}\002\149\002\149\011\014\011\022\002}\004\246\001\006\002}\000\000\000\000\000\000\002}\000\000\002}\000\000\000\000\nV\000\000\002}\002}\002}\000\000\002}\002}\002}\000\000\000\000\000\000\000\000\000\000\002}\002}\002}\n\150\002}\000\000\002}\000\000\000\000\000\000\000\000\000\000\002}\002}\002}\002}\002}\000\000\000\000\022\014\003\134\002}\000\000\002}\000\000\002}\002}\000\000\000\000\000\000\000\000\002}\002}\002}\022\"\000\000\0226\000\000\000\000\000\000\002}\002}\n^\n\158\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\nV\000\000\002y\002y\002y\000\000\002y\002y\002y\000\000\000\000\000\000\000\000\000\000\002y\002y\002y\n\150\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\000\000\002y\002y\n^\n\158\002y\002y\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\002y\002y\002y\000\000\000\000\002y\002y\002y\000\000\000\000\000\000\002\141\002y\002y\002y\002y\002\141\000\000\000\000\002\141\000\000\000\000\000\000\002\141\000\000\002\141\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\002\141\000\000\002\141\000\000\000\000\000\000\000\000\000\000\002\141\002\141\n\190\n\198\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\n^\n\158\n\214\n\222\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\n\230\002\141\002\141\000\000\000\000\002\141\002\141\002\141\000\000\000\000\000\000\002a\002\141\002\141\002\141\002\141\002a\000\000\000\000\002a\000\000\000\000\000\000\002a\000\000\002a\000\000\000\000\nV\000\000\002a\002a\002a\000\000\002a\002a\002a\000\000\000\000\000\000\000\000\000\000\002a\002a\002a\n\150\002a\000\000\002a\000\000\000\000\000\000\000\000\000\000\002a\002a\002a\002a\002a\000\000\000\000\000\000\000\000\002a\000\000\002a\000\000\002a\002a\000\000\000\000\000\000\000\000\002a\002a\002a\000\000\000\000\000\000\000\000\000\000\000\000\002a\002a\n^\n\158\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\000\000\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\002]\002a\002a\002a\002a\002]\000\000\000\000\002]\000\000\000\000\000\000\002]\000\000\002]\000\000\000\000\nV\000\000\002]\002]\002]\000\000\002]\002]\002]\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\002]\000\000\002]\000\000\000\000\000\000\000\000\000\000\002]\002]\n\190\n\198\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]\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002]\002]\n^\n\158\n\214\n\222\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]\n\230\002]\002]\000\000\000\000\002]\002]\002]\000\000\000\000\000\000\002\185\002]\002]\002]\002]\002\185\000\000\000\000\002\185\000\000\000\000\000\000\002\185\000\000\002\185\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\002\185\000\000\002\185\000\000\000\000\000\000\000\000\000\000\002\185\002\185\n\190\n\198\002\185\000\000\000\000\000\000\000\000\002\185\000\000\002\185\000\000\002\185\002\185\000\000\000\000\000\000\000\000\002\185\002\185\002\185\000\000\000\000\000\000\000\000\000\000\000\000\002\185\002\185\n^\n\158\n\214\002\185\002\185\002\185\002\185\000\000\000\000\002\185\000\000\002\185\002\185\002\185\000\000\000\000\000\000\000\000\000\000\000\000\002\185\000\000\002\185\002\185\002\185\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\002\185\002\185\002\185\n\230\002\185\002\185\000\000\000\000\002\185\002\185\002\185\000\000\000\000\000\000\002Y\002\185\002\185\002\185\002\185\002Y\000\000\000\000\002Y\000\000\000\000\000\000\002Y\000\000\002Y\000\000\000\000\nV\000\000\002Y\002Y\002Y\000\000\002Y\002Y\002Y\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\002Y\000\000\002Y\000\000\000\000\000\000\000\000\000\000\002Y\002Y\n\190\n\198\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\n^\n\158\n\214\n\222\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\n\230\002Y\002Y\000\000\000\000\002Y\002Y\002Y\000\000\000\000\000\000\002\145\002Y\002Y\002Y\002Y\002\145\000\000\000\000\002\145\000\000\000\000\000\000\002\145\000\000\002\145\000\000\000\000\nV\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\002\145\000\000\002\145\000\000\000\000\000\000\000\000\000\000\002\145\002\145\n\190\n\198\002\145\000\000\000\000\000\000\000\000\002\145\000\000\002\145\000\000\002\145\002\145\000\000\000\000\000\000\000\000\002\145\002\145\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\145\n^\n\158\n\214\n\222\002\145\002\145\002\145\000\000\000\000\002\145\000\000\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\000\000\002\145\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\002\145\000\000\002\145\002\145\000\000\002\145\002\145\002\145\n\230\002\145\002\145\000\000\000\000\002\145\002\145\002\145\000\000\000\000\000\000\002\137\002\145\002\145\002\145\002\145\002\137\000\000\000\000\002\137\000\000\000\000\000\000\002\137\000\000\002\137\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\002\137\000\000\002\137\000\000\000\000\000\000\000\000\000\000\002\137\002\137\n\190\n\198\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\n^\n\158\n\214\n\222\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\n\230\002\137\002\137\000\000\000\000\002\137\002\137\002\137\000\000\000\000\000\000\002\153\002\137\002\137\002\137\002\137\002\153\000\000\000\000\002\153\000\000\000\000\000\000\002\153\000\000\002\153\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\153\000\000\000\000\000\000\000\000\000\000\002\153\002\153\n\190\n\198\002\153\000\000\000\000\000\000\000\000\002\153\000\000\002\153\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\153\002\153\000\000\000\000\002\153\000\000\002\153\002\153\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\153\000\000\002\153\002\153\n\254\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\n\230\002\153\002\153\000\000\000\000\002\153\011\006\002\153\000\000\000\000\000\000\002\157\002\153\002\153\011\014\011\022\002\157\000\000\000\000\002\157\000\000\000\000\000\000\002\157\000\000\002\157\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\002\157\000\000\002\157\000\000\000\000\000\000\000\000\000\000\002\157\002\157\n\190\n\198\002\157\000\000\000\000\000\000\000\000\002\157\000\000\002\157\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\157\002\157\000\000\000\000\002\157\000\000\002\157\002\157\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\157\000\000\002\157\002\157\n\254\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\n\230\002\157\002\157\000\000\000\000\002\157\002\157\002\157\000\000\000\000\000\000\002\161\002\157\002\157\011\014\011\022\002\161\000\000\000\000\002\161\000\000\000\000\000\000\002\161\000\000\002\161\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\002\161\000\000\002\161\000\000\000\000\000\000\000\000\000\000\002\161\002\161\n\190\n\198\002\161\000\000\000\000\000\000\000\000\002\161\000\000\002\161\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\161\002\161\000\000\000\000\002\161\000\000\002\161\002\161\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\161\000\000\002\161\002\161\n\254\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\002\161\002\161\002\161\n\230\002\161\002\161\000\000\000\000\002\161\002\161\002\161\000\000\000\000\000\000\b\225\002\161\002\161\011\014\011\022\b\225\000\000\000\000\b\225\000\000\000\000\000\000\b\225\000\000\b\225\000\000\000\000\nV\000\000\b\225\b\225\b\225\000\000\b\225\b\225\b\225\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\n\182\000\000\b\225\000\000\000\000\000\000\000\000\000\000\b\225\b\225\n\190\n\198\b\225\000\000\000\000\000\000\000\000\b\225\000\000\b\225\000\000\n\206\b\225\000\000\000\000\000\000\000\000\b\225\b\225\000\238\000\000\000\000\000\000\000\000\000\000\000\000\b\225\b\225\n^\n\158\n\214\n\222\n\238\b\225\b\225\000\000\000\000\b\225\000\000\b\225\b\225\n\246\000\000\000\000\000\000\000\000\000\000\000\000\b\225\000\000\b\225\b\225\n\254\000\000\b\225\b\225\b\225\b\225\000\000\000\000\000\000\000\000\000\000\b\225\000\000\b\225\b\225\000\000\b\225\b\225\b\225\n\230\b\225\b\225\000\000\000\000\b\225\011\006\b\225\000\000\000\000\000\000\002\165\b\225\b\225\011\014\011\022\002\165\000\000\000\000\002\165\000\000\000\000\000\000\002\165\000\000\002\165\000\000\000\000\nV\000\000\002\165\002\165\002\165\000\000\002\165\002\165\002\165\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\n\182\000\000\002\165\000\000\000\000\000\000\000\000\000\000\002\165\002\165\n\190\n\198\002\165\000\000\000\000\000\000\000\000\002\165\000\000\002\165\000\000\n\206\002\165\000\000\000\000\000\000\000\000\002\165\002\165\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\165\002\165\n^\n\158\n\214\n\222\n\238\002\165\002\165\000\000\000\000\002\165\000\000\002\165\002\165\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\165\000\000\002\165\002\165\n\254\000\000\002\165\002\165\002\165\002\165\000\000\000\000\000\000\000\000\000\000\002\165\000\000\002\165\002\165\000\000\011\030\002\165\011&\n\230\002\165\002\165\000\000\000\000\002\165\011\006\002\165\000\000\000\000\000\000\b\221\002\165\002\165\011\014\011\022\b\221\000\000\000\000\b\221\000\000\000\000\000\000\b\221\000\000\b\221\000\000\000\000\nV\000\000\b\221\b\221\b\221\000\000\b\221\b\221\b\221\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\n\182\000\000\b\221\000\000\000\000\000\000\000\000\000\000\b\221\b\221\n\190\n\198\b\221\000\000\000\000\000\000\000\000\b\221\000\000\b\221\000\000\n\206\b\221\000\000\000\000\000\000\000\000\b\221\b\221\000\238\000\000\000\000\000\000\000\000\000\000\000\000\b\221\b\221\n^\n\158\n\214\n\222\n\238\b\221\b\221\000\000\000\000\b\221\000\000\b\221\b\221\n\246\000\000\000\000\000\000\000\000\000\000\000\000\b\221\000\000\b\221\b\221\n\254\000\000\b\221\b\221\b\221\b\221\000\000\000\000\000\000\000\000\000\000\b\221\000\000\b\221\b\221\000\000\b\221\b\221\b\221\n\230\b\221\b\221\000\000\000\000\b\221\011\006\b\221\000\000\000\000\000\000\002\209\b\221\b\221\011\014\011\022\002\209\000\000\000\000\002\209\000\000\000\000\000\000\002\209\000\000\002\209\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\209\000\000\000\000\000\000\000\000\000\000\002\209\002\209\n\190\n\198\002\209\000\000\000\000\000\000\000\000\002\209\000\000\002\209\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\209\002\209\000\000\000\000\002\209\000\000\002\209\002\209\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\209\000\000\002\209\002\209\n\254\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\011\030\002\209\011&\n\230\002\209\002\209\000\000\000\000\002\209\011\006\002\209\000\000\000\000\000\000\002\225\002\209\002\209\011\014\011\022\002\225\000\000\000\000\002\225\000\000\000\000\000\000\002\225\000\000\002\225\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\225\000\000\000\000\000\000\000\000\000\000\002\225\002\225\n\190\n\198\002\225\000\000\000\000\000\000\000\000\002\225\000\000\002\225\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\225\002\225\000\000\000\000\002\225\000\000\002\225\002\225\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\225\000\000\002\225\002\225\n\254\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\011\030\002\225\011&\n\230\002\225\002\225\000\000\000\000\002\225\011\006\002\225\000\000\000\000\000\000\002\217\002\225\002\225\011\014\011\022\002\217\000\000\000\000\002\217\000\000\000\000\000\000\002\217\000\000\002\217\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\217\000\000\000\000\000\000\000\000\000\000\002\217\002\217\n\190\n\198\002\217\000\000\000\000\000\000\000\000\002\217\000\000\002\217\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\217\002\217\000\000\000\000\002\217\000\000\002\217\002\217\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\217\000\000\002\217\002\217\n\254\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\011\030\002\217\011&\n\230\002\217\002\217\000\000\000\000\002\217\011\006\002\217\000\000\000\000\000\000\002\197\002\217\002\217\011\014\011\022\002\197\000\000\000\000\002\197\000\000\000\000\000\000\002\197\000\000\002\197\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\197\000\000\000\000\000\000\000\000\000\000\002\197\002\197\n\190\n\198\002\197\000\000\000\000\000\000\000\000\002\197\000\000\002\197\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\197\002\197\000\000\000\000\002\197\000\000\002\197\002\197\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\197\000\000\002\197\002\197\n\254\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\011\030\002\197\011&\n\230\002\197\002\197\000\000\000\000\002\197\011\006\002\197\000\000\000\000\000\000\002\205\002\197\002\197\011\014\011\022\002\205\000\000\000\000\002\205\000\000\000\000\000\000\002\205\000\000\002\205\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\205\000\000\000\000\000\000\000\000\000\000\002\205\002\205\n\190\n\198\002\205\000\000\000\000\000\000\000\000\002\205\000\000\002\205\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\205\002\205\000\000\000\000\002\205\000\000\002\205\002\205\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\205\000\000\002\205\002\205\n\254\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\011\030\002\205\011&\n\230\002\205\002\205\000\000\000\000\002\205\011\006\002\205\000\000\000\000\000\000\002\201\002\205\002\205\011\014\011\022\002\201\000\000\000\000\002\201\000\000\000\000\000\000\002\201\000\000\002\201\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\201\000\000\000\000\000\000\000\000\000\000\002\201\002\201\n\190\n\198\002\201\000\000\000\000\000\000\000\000\002\201\000\000\002\201\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\201\002\201\000\000\000\000\002\201\000\000\002\201\002\201\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\201\000\000\002\201\002\201\n\254\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\011\030\002\201\011&\n\230\002\201\002\201\000\000\000\000\002\201\011\006\002\201\000\000\000\000\000\000\002\213\002\201\002\201\011\014\011\022\002\213\000\000\000\000\002\213\000\000\000\000\000\000\002\213\000\000\002\213\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\213\000\000\000\000\000\000\000\000\000\000\002\213\002\213\n\190\n\198\002\213\000\000\000\000\000\000\000\000\002\213\000\000\002\213\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\213\002\213\000\000\000\000\002\213\000\000\002\213\002\213\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\213\000\000\002\213\002\213\n\254\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\011\030\002\213\011&\n\230\002\213\002\213\000\000\000\000\002\213\011\006\002\213\000\000\000\000\000\000\002\229\002\213\002\213\011\014\011\022\002\229\000\000\000\000\002\229\000\000\000\000\000\000\002\229\000\000\002\229\000\000\000\000\nV\000\000\002\229\002\229\002\229\000\000\002\229\002\229\002\229\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\n\182\000\000\002\229\000\000\000\000\000\000\000\000\000\000\002\229\002\229\n\190\n\198\002\229\000\000\000\000\000\000\000\000\002\229\000\000\002\229\000\000\n\206\002\229\000\000\000\000\000\000\000\000\002\229\002\229\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\229\002\229\n^\n\158\n\214\n\222\n\238\002\229\002\229\000\000\000\000\002\229\000\000\002\229\002\229\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\229\000\000\002\229\002\229\n\254\000\000\002\229\002\229\002\229\002\229\000\000\000\000\000\000\000\000\000\000\002\229\000\000\002\229\002\229\000\000\011\030\002\229\011&\n\230\002\229\002\229\000\000\000\000\002\229\011\006\002\229\000\000\000\000\000\000\002\221\002\229\002\229\011\014\011\022\002\221\000\000\000\000\002\221\000\000\000\000\000\000\002\221\000\000\002\221\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\221\000\000\000\000\000\000\000\000\000\000\002\221\002\221\n\190\n\198\002\221\000\000\000\000\000\000\000\000\002\221\000\000\002\221\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\221\002\221\000\000\000\000\002\221\000\000\002\221\002\221\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\221\000\000\002\221\002\221\n\254\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\011\030\002\221\011&\n\230\002\221\002\221\000\000\000\000\002\221\011\006\002\221\000\000\000\000\000\000\002\193\002\221\002\221\011\014\011\022\002\193\000\000\000\000\002\193\000\000\000\000\000\000\002\193\000\000\002\193\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\193\000\000\000\000\000\000\000\000\000\000\002\193\002\193\n\190\n\198\002\193\000\000\000\000\000\000\000\000\002\193\000\000\002\193\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\193\002\193\000\000\000\000\002\193\000\000\002\193\002\193\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\193\000\000\002\193\002\193\n\254\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\011\030\002\193\011&\n\230\002\193\002\193\000\000\000\000\002\193\011\006\002\193\000\000\000\000\000\000\002\029\002\193\002\193\011\014\011\022\002\029\000\000\000\000\002\029\000\000\000\000\000\000\002\029\000\000\002\029\000\000\000\000\002\029\000\000\002\029\002\029\002\029\000\000\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\000\000\002\029\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\000\000\000\000\000\000\000\000\002\029\000\000\002\029\000\000\002\029\002\029\000\000\000\000\000\000\000\000\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\002\029\002\029\002\029\002\029\000\000\000\000\002\029\000\000\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\000\000\002\029\000\000\002\029\002\029\002\029\000\000\002\029\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\002\029\000\000\002\029\002\029\000\000\002\029\002\029\002\029\002\029\002\029\002\029\000\000\000\000\002\029\002\029\024\014\000\000\000\000\000\000\0025\002\029\002\029\002\029\002\029\0025\000\000\000\000\0025\000\000\000\000\000\000\0025\000\000\0025\000\000\000\000\nV\000\000\0025\0025\0025\000\000\0025\0025\0025\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\n\182\000\000\0025\000\000\000\000\000\000\000\000\000\000\0025\0025\n\190\n\198\0025\000\000\000\000\000\000\000\000\0025\000\000\0025\000\000\n\206\0025\000\000\000\000\000\000\000\000\0025\0025\000\238\000\000\000\000\000\000\000\000\000\000\000\000\0025\0025\n^\n\158\n\214\n\222\n\238\0025\0025\000\000\000\000\0025\000\000\0025\0025\n\246\000\000\000\000\000\000\000\000\000\000\000\000\0025\000\000\0025\0025\n\254\000\000\0025\0025\024&\0025\000\000\000\000\000\000\000\000\000\000\0025\000\000\0025\0025\000\000\011\030\0025\011&\n\230\0025\0025\000\000\000\000\0025\011\006\0025\000\000\000\000\000\000\0021\0025\0025\011\014\011\022\0021\000\000\000\000\0021\000\000\000\000\000\000\0021\000\000\0021\000\000\000\000\nV\000\000\0021\0021\0021\000\000\0021\0021\0021\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\n\182\000\000\0021\000\000\000\000\000\000\000\000\000\000\0021\0021\n\190\n\198\0021\000\000\000\000\000\000\000\000\0021\000\000\0021\000\000\n\206\0021\000\000\000\000\000\000\000\000\0021\0021\000\238\000\000\000\000\000\000\000\000\000\000\000\000\0021\0021\n^\n\158\n\214\n\222\n\238\0021\0021\000\000\000\000\0021\000\000\0021\0021\n\246\000\000\000\000\000\000\000\000\000\000\000\000\0021\000\000\0021\0021\n\254\000\000\0021\0021\0021\0021\000\000\000\000\000\000\000\000\000\000\0021\000\000\0021\0021\000\000\011\030\0021\011&\n\230\0021\0021\000\000\000\000\0021\011\006\0021\000\000\000\000\000\000\002\189\0021\0021\011\014\011\022\002\189\000\000\000\000\002\189\000\000\000\000\000\000\002\189\000\000\002\189\000\000\000\000\nV\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\n\142\n\166\n\174\n\150\n\182\000\000\002\189\000\000\000\000\000\000\000\000\000\000\002\189\002\189\n\190\n\198\002\189\000\000\000\000\000\000\000\000\002\189\000\000\002\189\000\000\n\206\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\n^\n\158\n\214\n\222\n\238\002\189\002\189\000\000\000\000\002\189\000\000\002\189\002\189\n\246\000\000\000\000\000\000\000\000\000\000\000\000\002\189\000\000\002\189\002\189\n\254\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\011\030\002\189\011&\n\230\002\189\002\189\000\000\000\000\002\189\011\006\002\189\000\000\000\000\000\000\002)\002\189\002\189\011\014\011\022\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)\024\014\000\000\000\000\000\000\001\233\002)\002)\002)\002)\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\001\233\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\024\014\000\000\000\000\000\000\002-\001\233\001\233\001\233\001\233\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-\024\014\000\000\000\000\000\000\0272\002-\002-\002-\002-\001\237\000\000\000\000\001\237\000\000\000\000\000\000\001\237\000\000\001\237\000\000\000\000\001\237\000\000\001\237\001\237\001\237\000\000\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\001\237\001\237\001\237\001\237\001\237\000\000\001\237\000\000\000\000\000\000\000\000\000\000\001\237\001\237\001\237\001\237\001\237\000\000\000\000\000\000\000\000\001\237\000\000\001\237\000\000\001\237\001\237\000\000\000\000\000\000\000\000\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\000\000\001\237\001\237\001\237\001\237\001\237\001\237\001\237\001\237\001\237\000\000\000\000\001\237\000\000\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\000\000\027B\000\000\001\237\001\237\001\237\000\000\001\237\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\001\237\000\000\001\237\001\237\000\000\001\237\001\237\001\237\001\237\001\237\001\237\000\000\000\000\001\237\001\237\001\237\000\000\000\000\000\000\001\241\001\237\001\237\001\237\001\237\001\241\000\000\000\000\001\241\000\000\000\000\000\000\001\241\000\000\001\241\000\000\000\000\001\241\000\000\001\241\001\241\001\241\000\000\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\001\241\000\000\001\241\000\000\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\001\241\000\000\000\000\000\000\000\000\001\241\000\000\001\241\000\000\001\241\001\241\000\000\000\000\000\000\000\000\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\000\000\000\000\001\241\000\000\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\000\000\027:\000\000\001\241\001\241\001\241\000\000\001\241\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\001\241\000\000\001\241\001\241\000\000\001\241\001\241\001\241\001\241\001\241\001\241\000\000\000\000\001\241\001\241\024\014\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\000\006\000\246\000\000\000\000\007\005\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\007\005\001*\000\000\000\000\000\000\003\210\001n\tV\tZ\001z\001~\000\000\000\000\000\000\0012\000\000\003z\000\000\025B\000\000\tz\t~\007\005\003\182\003\194\003\206\003\218\003\226\t\130\007:\000\000\001\206\007\005\003F\000\000\000\000\003\214\007\005\007\005\000\238\b\142\b\146\b\158\b\174\000\000\005n\007\005\007\005\001\210\001\214\001\218\001\222\001\226\000\000\000\000\b\198\001\230\000\000\000\000\000\000\000\000\001\234\000\000\b\210\b\234\t\n\t\030\005z\000\000\005~\000\000\000\000\001\238\000\000\000\000\007\005\000\000\000\000\b\166\001\242\b\170\000\000\000\000\000\000\000\000\000\000\007\005\000\000\000\000\000\000\002.\006\"\000\000\000\000\005\130\b\186\000\000\0022\000\000\022\234\004j\t\150\020F\002:\000\000\002>\002B\000\006\000\246\000\000\000\000\001\189\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\tR\000\000\000\000\000\000\001\189\001*\000\000\000\000\000\000\003\210\001n\tV\tZ\001z\001~\000\000\000\000\b\230\0012\000\000\003z\000\000\t^\000\000\tz\t~\001\189\003\182\003\194\003\206\003\218\003\226\t\130\007:\007)\001\206\001\189\003F\007)\000\000\003\214\001\189\001\189\000\238\b\142\b\146\b\158\b\174\000\000\005n\001\189\001\189\001\210\001\214\001\218\001\222\001\226\000\000\023\250\b\198\001\230\000\000\000\000\000\000\000\000\001\234\000\000\b\210\b\234\t\n\t\030\005z\000\000\005~\000\000\000\000\001\238\000\000\000\238\001\189\000\000\000\000\b\166\001\242\b\170\000\000\002\237\002\237\011\174\000\000\001\189\000\000\000\000\000\000\002.\006^\000\000\000\000\005\130\b\186\000\000\0022\002\237\022\234\004j\t\150\000\000\002:\000\000\002>\002B\000\006\000\246\000\000\000\n\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\0062\000\000\003N\005\222\000\000\000\000\004\149\000\000\003R\001*\006F\011\154\000\000\001.\006N\003V\003Z\002\237\002\237\002\237\003^\000\000\0012\000\000\003z\000\000\011\170\002\237\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\006\234\007:\002\237\000\000\0126\003F\000\000\000\000\003\214\012>\000\n\000\000\b\142\b\146\b\158\b\174\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012F\002\237\b\198\002\237\002\237\014\190\000\000\000\000\000\000\002\237\b\210\b\234\t\n\t\030\005z\002\237\005~\012Z\012\158\002\237\000\000\004\149\004\149\000\000\000\000\b\166\000\000\b\170\000\000\000\000\000\000\000\n\000\000\000\000\000\000\000\000\000\000\000\000\002\237\r~\018\002\005\130\b\186\0252\000\000\000\000\t2\004j\t\150\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\002\237\000\000\000\000\001&\000\000\000\000\004\181\000\000\b\249\000\000\b\249\b\249\003R\001*\003b\001\006\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\003^\000\000\0012\000\000\003z\000\000\011\170\000\000\003\174\003\178\001*\003\182\003\194\003\206\003\218\003\226\006\234\007:\000\000\000\000\0126\003F\000\000\018\030\003\214\012>\002Z\002^\b\142\b\146\b\158\b\174\000\000\005n\019r\003\134\000\000\000\000\019v\000\000\000\000\012F\003F\b\198\000\000\028\134\001*\002\134\002r\019\166\000\000\b\210\b\234\t\n\t\030\005z\002~\005~\012Z\012\158\000\000\000\000\028\167\024.\000\000\000\000\b\166\000\000\b\170\000\000\002\130\003.\000\000\019\182\000\000\000\000\003:\000\000\003F\004\026\004&\018\002\005\130\b\186\b\249\0042\000\000\t2\004j\t\150\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\0046\000\000\000\000\001&\002\237\000\000\028\214\000\000\002\237\000\000\003\254\000\000\003R\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\003^\000\000\0012\000\000\003z\000\000\011\170\000\n\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\006\234\007:\000\000\004j\0126\003F\000\000\002\237\003\214\012>\002Z\002^\b\142\b\146\b\158\b\174\000\000\005n\000\000\000\000\000\000\002\237\002\237\000\000\000\000\012F\000\000\b\198\000\000\028\134\001*\002\134\002r\000\000\000\000\b\210\b\234\t\n\t\030\005z\002~\005~\012Z\012\158\000\000\000\000\004\189\002\142\000\000\000\000\b\166\002\237\b\170\000\000\002\130\003.\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\018\002\005\130\b\186\022\250\0042\000\000\t2\004j\t\150\000\181\001\002\001\006\000\181\012}\000\000\001\"\000\000\t\190\000\000\000\000\001&\0046\000\000\000\181\000\000\000\181\000\000\000\181\000\000\000\181\001*\000\000\t\238\005a\001.\000\000\000\000\005a\000\000\000\000\t\246\000\181\000\000\0012\000\000\003z\000\000\000\181\000\000\000\000\000\000\000\181\000\000\000\000\003\206\002N\000\181\012I\000\181\000\000\000\000\000\181\003F\000\000\000\000\003\214\000\181\000\181\000\181\b\142\b\146\b\158\000\000\019\214\005n\000\181\000\181\000\000\012I\000\000\000\000\002\194\000\181\000\000\002\198\000\000\000\181\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012}\012}\005z\002\210\005~\000\181\000\181\002\218\0125\000\181\000\181\000\000\000\000\b\166\000\000\b\170\005a\000\000\000\000\000\000\000\000\000\181\000\000\012}\000\000\000\000\012}\000\181\000\181\005\130\b\186\000\000\002\222\005a\t2\004j\005a\000\181\000\000\000\181\000\205\001\002\001\006\000\205\000\000\000\000\001\"\000\000\t\190\000\000\000\000\001&\000\000\000\000\000\205\000\000\000\205\000\000\000\205\000\000\000\205\001*\000\000\t\238\000\000\001.\000\000\000\000\000\000\000\000\000\000\t\246\000\205\000\000\0012\000\000\003z\000\000\000\205\000\000\000\000\002\226\000\205\000\000\000\000\003\206\002N\000\205\000\000\000\205\000\000\002\237\000\205\003F\000\000\000\000\003\214\000\205\000\205\000\205\b\142\b\146\b\158\000\000\019\214\005n\000\205\000\205\011\162\000\000\000\000\002\237\000\000\000\205\000\000\000\000\000\000\000\205\000\000\000\000\000\n\000\000\000\000\000\000\000\000\000\000\000\000\005z\007\245\005~\000\205\000\205\000\000\002\237\000\205\000\205\002\237\000\000\b\166\000\000\b\170\000\000\000\000\002\237\000\000\000\000\000\205\000\000\002\237\000\000\002\237\000\000\000\205\000\205\005\130\b\186\000\000\002\237\002\237\t2\004j\000\000\000\205\000\014\000\205\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\237\000\000\000\000\000\000\000\000\000\000\000F\000\000\000\000\000\000\000\000\002\237\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\0062\000\000\000\000\005\222\000\000\000\000\000\000\002Z\002^\000\000\006F\000\000\000\000\000z\006N\000\000\000~\000\130\000\000\000\000\000\000\000\000\001f\000\134\000\138\000\142\000\000\001*\002\134\002r\000\000\000\000\000\146\000\150\000\154\000\000\000\158\002~\000\000\000\162\000\166\000\170\000\000\000\000\002\142\000\174\000\178\000\182\000\000\000\000\000\000\002\130\003.\000\186\000\000\000\190\000\194\003:\000\000\003F\004\026\004&\000\000\000\198\000\000\000\202\0042\003\241\001B\001\006\003\241\000\206\000\210\001\"\000\214\006\186\012\137\000\000\001&\000\000\000\000\003\241\000\000\0046\000\000\003\241\000\000\003\241\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\012\137\000\000\006\242\003\241\000\000\000\000\000\000\000\000\000\000\003\241\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\003\241\000\000\003\241\012\178\012\137\003\241\003F\000\000\000\000\003\246\003\241\003\241\na\003\250\012\137\004\002\000\000\007.\005n\012\137\012\137\000\238\000\000\000\000\000\000\000\000\003\241\003\241\012\137\012\137\005r\000\000\002\237\002\237\000\000\000\000\000\000\000\000\000\000\000\000\005z\002\237\005~\003\241\003\241\0076\000\000\003\241\003\241\000\000\000\000\000\000\002\237\000\000\000\000\000\000\000\000\012\137\000\000\000\000\000\n\na\t\202\000\000\na\024\230\003\241\005\130\012\137\000\000\000\000\na\000\000\004j\000\000\na\002\237\003\241\001B\001\006\005\254\000\000\000\000\001\"\002\237\000\000\000\000\000\000\001&\001b\002\237\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\000\000\002\237\000\000\001j\001n\001r\001v\001z\001~\000\000\000\000\000\000\002\237\000\000\002\237\000\000\001\130\000\000\001\194\006\030\002\237\000\000\000\000\001^\002N\000\000\001\202\000\000\000\n\001\206\000\000\003F\000\000\001\021\003\246\000\000\000\000\002\237\003\250\000\000\004\002\005b\000\000\005n\002\237\002\237\001\210\001\214\001\218\001\222\001\226\007B\002\237\001\021\001\230\005r\000\000\000\000\002\237\001\234\000\000\000\000\000\000\000\000\000\000\005z\000\000\005~\000\000\005\190\001\238\000\000\000\000\000\000\000\000\001\021\000\000\001\242\001>\000\000\000\000\002\237\000\000\000\000\000\000\001\021\000\000\000\000\002.\006\"\001\021\006\130\005\130\000\000\t\r\0022\000\000\0026\004j\001\021\001\021\002:\000\000\002>\002B\001B\001\006\007\"\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\000\000\001\162\001\021\001j\001n\001r\001v\001z\001~\000\238\000\000\000\000\001\166\001\021\000\000\000\000\001\130\000\000\001\194\006\030\001*\000\000\000\000\001^\002N\000\000\001\202\000\000\000\000\001\206\000\000\003F\000\000\004\129\003\246\000\000\000\000\002\154\003\250\000\000\004\002\005b\000\000\005n\007f\002j\001\210\001\214\001\218\001\222\001\226\000\000\003F\004\129\001\230\005r\000\000\000\000\0062\001\234\000\000\005\222\000\000\000\000\000\000\005z\t\r\005~\006F\005\190\001\238\000\000\006N\000\000\000\000\004\129\000\000\001\242\000\000\000\000\000\000\007j\000\000\000\000\000\000\004\129\000\000\000\000\002.\006\"\004\129\011\146\005\130\000\000\015\186\0022\000\000\0026\004j\004\129\004\129\002:\012}\002>\002B\001B\001\006\b\250\000\000\000\000\001\"\000\000\000\000\000\000\003R\001&\001b\000\000\000\000\000\000\001f\000\000\005e\000\000\000\000\001*\005e\000\000\004\129\001j\001n\001r\001v\001z\001~\000\000\015\230\000\000\000\000\004\129\000\000\000\000\001\130\000\000\001\194\006\030\0126\000\000\000\000\001^\002N\012>\001\202\000\000\000\000\001\206\000\000\003F\000\000\000\000\003\246\016\018\000\000\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\005r\000\000\012}\012}\001\234\000\000\000\000\000\000\004\165\000\000\005z\000\000\005~\000\000\005\190\001\238\000\000\000\000\005e\016v\000\000\000\000\001\242\000\000\000\000\012}\000\000\000\000\012}\000\000\000\000\000\000\000\000\002.\006\"\005e\000\000\005\130\005e\000\000\0022\000\000\0026\004j\000\000\000\000\002:\000\000\002>\002B\001B\001\006\023\186\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\000\000\000\000\000\000\001j\001n\001r\001v\001z\001~\000\000\000\000\003r\002\170\001\006\000\000\000\000\001\130\000\000\001\194\006\030\000\000\002\174\000\000\001^\002N\000\000\001\202\b^\000\000\001\206\000\000\003F\001*\000\000\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\005r\003n\000\000\000\000\001\234\000\000\000\000\000\000\000\000\003F\005z\000\000\005~\000\000\005\190\001\238\000\000\000\000\000\000\000\000\000\000\000\000\001\242\000\000\000\000\000\000\002\237\002\237\000\000\000\000\000\000\000\000\000\000\002.\006\"\000\000\000\000\005\130\007N\000\000\0022\000\000\0026\004j\000\000\000\000\002:\002\237\002>\002B\002\237\002\237\000\000\002\237\000\n\002\237\002\237\002\237\002\237\002\237\002\237\000\000\000\000\000\000\000\000\002\237\002\237\000\000\000\000\000\000\002\237\002\237\002\237\000\000\000\000\002\237\000\000\002\237\000\n\002\237\002\237\002\237\002\237\000\n\002\237\000\000\007>\000\000\002\237\000\000\002\237\000\000\024\142\000\000\002\237\002\237\000\000\002\237\002\237\002\237\002\237\002\237\002\237\002\237\000\000\002\237\000\000\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\000\000\002\237\000\000\000\000\000\000\000\000\000\000\000\000\002\237\000\000\000\000\002\237\000\000\002\237\000\000\000\000\000\000\000\000\002\237\002\237\002\237\002\237\002\237\002\237\000\000\002\237\002\237\024\170\000\000\000\000\000\000\002\237\000\000\000\000\002\237\000\000\002\237\000\000\000A\000A\000\000\000\000\004\129\000A\000A\002\237\000A\000A\000A\002\237\002\237\002\237\000\000\000A\000\000\002\237\002\237\002\237\006\181\000\000\000\000\000\000\004\129\000A\000\000\000\000\000\000\000A\000\000\000A\000A\000\000\000\000\000\000\000\000\000\000\000A\000\000\000A\000\000\000\000\000\000\000A\000A\004\129\000A\000A\000A\000A\000A\000A\000A\000\000\000\000\004\129\000A\000\000\000\000\000A\004\129\011\146\000\238\000A\000A\000A\000A\000\000\000A\000\000\004\129\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000A\000A\000A\000A\000\000\000A\000\000\000\000\000\000\000\000\000\000\004\129\000\000\000\000\000A\000\000\000A\000\000\000=\000=\000\000\000\000\004\129\000=\000=\000\000\000=\000=\000=\000\000\000A\000A\000\000\000=\000\000\000A\000A\000A\006\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\000\000\000\000\000=\000\000\000=\000\000\000\000\000\000\000=\000=\000\000\000=\000=\000=\000=\000=\000=\000=\000\000\000\000\000\000\000=\000\000\000\000\000=\000\000\000\000\000\000\000=\000=\000=\000=\000\000\000=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000=\000=\000=\000=\000=\000\000\000=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000=\000\000\000=\000\000\011\217\011\217\000\000\000\000\018*\011\217\011\217\000\000\011\217\011\217\011\217\000\000\000=\000=\000\000\011\217\000\000\000=\000=\000=\006\193\000\000\000\000\000\000\003R\011\217\000\000\000\000\000\000\011\217\000\000\011\217\011\217\000\000\000\000\000\000\000\000\000\000\011\217\000\000\011\217\000\000\000\000\000\000\011\217\011\217\018\154\011\217\011\217\011\217\011\217\011\217\011\217\011\217\000\000\000\000\0126\011\217\000\000\000\000\011\217\012>\000\000\000\000\011\217\011\217\011\217\011\217\000\000\011\217\019V\019f\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\217\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\217\011\217\011\217\011\217\011\217\000\000\011\217\000\000\000\000\000\000\000\000\000\000\004\173\000\000\000\000\011\217\000\000\011\217\000\000\011\213\011\213\000\000\000\000\020f\011\213\011\213\000\000\011\213\011\213\011\213\000\000\011\217\011\217\000\000\011\213\000\000\011\217\011\217\011\217\006\189\000\000\000\000\000\000\000\000\011\213\000\000\000\000\000\000\011\213\000\000\011\213\011\213\000\000\000\000\000\000\000\000\000\000\011\213\000\000\011\213\000\000\000\000\000\000\011\213\011\213\000\000\011\213\011\213\011\213\011\213\011\213\011\213\011\213\000\000\000\000\000\000\011\213\000\000\000\000\011\213\000\000\000\000\000\000\011\213\011\213\011\213\011\213\000\000\011\213\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\213\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\213\011\213\011\213\011\213\011\213\000\000\011\213\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\213\000\000\011\213\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\213\011\213\001&\000\000\000\000\011\213\011\213\011\213\000\000\023\n\000\000\000\000\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\006\234\007:\000\000\000\000\000\000\003F\000\000\000\000\003\214\000\000\000\000\000\000\b\142\b\146\b\158\b\174\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\198\000\000\000\000\000\000\0051\000\000\0051\0051\b\210\b\234\t\n\t\030\005z\0051\005~\000\000\0051\000\000\0051\000\000\0051\0051\0051\b\166\0051\b\170\000\000\000\000\012I\0125\0051\000\000\0051\0051\0051\000\000\0051\0051\0051\005\130\b\186\000\000\0051\0051\t2\004j\t\150\000\000\000\000\012I\0051\000\000\002\194\000\000\000\000\002\198\0051\0051\000\000\000\000\0051\0051\0051\0051\0051\0051\000\000\0051\002\210\000\000\0051\000\000\002\218\0125\000\000\0051\0051\0051\000\000\000\000\000\000\0051\000\000\000\000\0051\0051\000\000\000\000\000\000\000\000\000\000\0051\000\000\000\000\0051\0051\0051\002\222\0051\0051\004a\000\000\000\000\004a\000\000\000\000\000\000\000\000\0051\0051\0051\000\000\0051\0051\004a\000\000\016\250\0051\004a\000\000\004a\000\000\000\000\000\000\0051\000\000\0051\0051\0051\000\000\0032\0051\004a\000\000\000\000\000\000\0051\000\000\004a\000\000\0051\n}\0051\0051\n}\n}\002\226\000\000\000\000\n}\000\000\n}\004a\000\000\n}\000\000\000\000\004a\n}\n}\000\000\n}\n}\000\000\n}\000\000\n}\000\000\000\000\000\000\000\000\n}\000\000\004a\n}\000\000\000\000\000\000\000\000\000\000\007\153\000\000\n}\000\000\n}\000\000\000\000\000\000\n}\n}\004a\004a\000\000\000\000\004a\004a\n}\007\153\007\153\n}\007\153\007\153\n}\n}\000\000\n}\000\000\n}\n}\000\000\000\000\000\000\000\000\004a\000\000\000\000\000\000\n}\000\000\000\000\n}\007\153\000\000\000\000\015\006\000\000\000\000\000\000\000\000\000\000\n}\000\000\n}\000\000\000\000\n}\000\000\n}\000\000\000\000\000\000\007\153\000\000\000\000\005\158\000\000\000\000\000\000\000\000\000\000\000\000\n}\n}\000\000\n}\n}\007\153\n}\000\000\n}\000\000\n}\b\229\n}\000\000\n}\000\000\b\229\000\000\002^\b\229\000\000\000\000\000\000\007\153\001\029\007\153\000\000\000\000\b\229\000\000\b\229\b\229\b\229\000\000\b\229\b\229\b\229\000\000\000\000\005\214\000\000\000\000\007\153\007\153\001\029\000\000\000\000\007\153\b\229\007\153\006\245\006\245\000\000\007\153\b\229\b\229\000\000\000\000\b\229\000\000\000\000\000\000\0036\b\229\000\000\b\229\001\029\004*\b\229\015\170\006\245\006\245\006\245\b\229\b\229\b\229\001\029\000\000\000\000\000\000\006\245\001\029\b\229\b\229\000\000\000\000\000\000\000\000\000\000\b\229\000\000\001\029\000\000\004\146\006\245\006\245\000\000\b\229\000\000\000\000\006\245\000\000\006\245\006\245\006\245\000\000\b\229\b\229\b\229\006\245\b\229\b\229\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\b\229\000\000\b\229\b\229\006\245\000\000\012\017\b\229\001\029\000\000\000\000\012\017\b\229\002^\012\017\000\000\b\229\000\000\b\229\b\229\000\000\000\000\000\000\004\178\000\000\012\017\012\017\012\017\000\000\012\017\012\017\012\017\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\017\000\000\004\030\000\000\006\245\000\000\012\017\012\017\000\000\000\000\012\017\000\000\000\000\000\000\0036\012\017\001\174\012\017\000\000\r\130\012\017\000\000\000\000\000\000\000\000\012\017\012\017\012\017\000\000\000\000\014\142\000\000\000\000\000\000\012\017\012\017\003R\000\000\000\000\000\000\000\000\012\017\000\000\000\000\000\000\004\146\000\000\000\000\014\146\012\017\000\000\000\000\000\000\000\000\014\186\000\000\000\000\000\000\012\017\012\017\012\017\000\000\012\017\012\017\000\000\000\000\000\000\000\000\0126\000\000\000\000\000\000\000\000\012>\012\017\000\000\012\017\012\017\000\000\000\000\b\233\012\017\000\000\000\000\000\000\b\233\012\017\002^\b\233\015N\012\017\000\000\012\017\012\017\000\000\000\000\000\000\b\233\000\000\b\233\b\233\b\233\000\000\b\233\b\233\b\233\012Z\015b\000\000\000\000\004\137\004\137\000\000\000\000\000\000\000\000\000\000\b\233\000\000\002Z\002^\018\178\000\000\b\233\b\233\000\000\000\000\b\233\000\000\015r\000\000\0036\b\233\000\000\b\233\000\000\000\000\b\233\000\000\001*\002b\002r\b\233\b\233\b\233\000\000\000\000\000\000\000\000\002~\000\000\b\233\b\233\000\000\000\000\000\000\000\000\000\000\b\233\000\000\000\000\000\000\004\146\002\130\003.\000\000\b\233\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\b\233\b\233\b\233\0042\b\233\b\233\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\233\000\000\b\233\b\233\0046\000\000\000\000\b\233\000a\000\000\000a\000a\b\233\000\000\000\000\000\000\b\233\000\000\b\233\b\233\000a\000\000\000a\000a\000\000\000\000\000a\000a\000a\000\000\b\145\000\000\001B\001\006\000\000\000\000\000\000\001\"\000\000\000\000\000a\000\000\001&\000\000\000\000\000\000\000a\000a\000\000\t\017\000a\000\000\001*\000\000\000a\000a\000\000\000a\000\000\001F\000a\000\000\000\000\000\000\000\000\000a\000a\000a\000\000\000\000\000\000\000\000\001R\000\000\000a\000a\001^\002N\000\000\000\000\000\000\000a\000a\000\000\003F\000a\000\000\003\246\000\000\000a\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000a\000a\000a\000\000\000a\000a\000\000\000\000\000\000\000\000\005r\000\000\b\145\000\000\000\000\000\000\000a\000\000\000\000\000a\005z\012\021\005~\000a\005\190\000\000\012\021\000\000\000a\012\021\000\000\000\000\000a\000\000\000a\000\000\000\000\000\000\004\130\000\000\012\021\012\021\012\021\000\000\012\021\012\021\012\021\005\130\000\000\t\017\000\000\b\222\000\000\004j\000\000\000\000\000\000\000\000\012\021\000\000\002Z\002^\019.\000\000\012\021\012\021\000\000\000\000\012\021\000\000\000\000\000\000\000\000\012\021\000\000\012\021\000\000\000\000\012\021\000\000\001*\002b\002r\012\021\012\021\012\021\000\000\000\000\000\000\000\000\002~\000\000\012\021\012\021\000\000\000\000\000\000\000\000\000\000\012\021\000\000\000\000\000\000\012\021\002\130\003.\000\000\012\021\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\012\021\012\021\012\021\0042\012\021\012\021\003)\000\000\000\000\000\000\000\000\003)\012I\0125\003)\000\000\012\021\000\000\012\021\012\021\0046\002Z\002^\012\021\000\000\003)\003)\003)\012\021\003)\003)\003)\012\021\012I\012\021\012\021\002\194\000\000\000\000\002\198\000\000\001*\002\134\003)\000\000\000\000\002\206\000\000\000\000\003)\004z\000\000\002\210\003)\000\000\000\000\002\218\0125\003)\000\000\003)\000\000\000\000\003)\000\000\002\130\0036\000\000\003)\003)\003)\003:\000\000\003F\004\026\004&\000\000\003)\003)\000\000\0042\002\222\012\198\000\000\003)\000\000\000\000\000\000\003)\000\000\000\000\n\137\003)\000\000\001B\001\006\000\000\0046\000\000\001\"\000\000\003)\003)\003)\001&\003)\003)\000\000\n\137\n\137\000\000\n\137\n\137\000\000\001*\000\000\000\000\003)\000\000\003)\003)\001F\000\000\000\000\003)\000\000\000\000\000\000\000\000\003)\002\226\000\000\n\137\003)\001R\003)\003)\000\000\001^\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\n\137\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\137\000\000\000\000\005r\000\000\000\000\n\133\000\000\000\000\001B\001\006\000\000\000\000\005z\001\"\005~\000\000\005\190\n\137\001&\n\137\000\000\000\000\n\133\n\133\000\000\n\133\n\133\000\000\001*\000\000\000\000\000\000\000\000\n\137\000\000\001F\n\137\n\137\000\000\005\130\000\000\n\137\000\000\n\137\000\000\004j\n\133\n\137\001R\000\000\000\000\000\000\005\250\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\n\133\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\133\000\000\000\000\005r\000\000\000\000\001\213\000\000\000\000\000\000\000\000\001\213\000\000\005z\001\213\005~\000\000\005\190\n\133\000\000\n\133\000\000\000\000\000\000\000\000\001\213\001\213\001\213\000\000\001\213\001\213\001\213\000\000\000\000\n\133\000\000\000\000\n\133\n\133\000\000\005\130\000\000\n\133\001\213\n\133\000\000\004j\000\000\n\133\001\213\001\213\000\000\000\000\001\213\000\000\000\000\000\000\000\000\001\213\000\000\001\213\000\000\000\000\001\213\000\000\000\000\000\000\000\000\001\213\001\213\001\213\000\000\000\000\000\000\000\000\000\000\000\000\001\213\001\213\000\000\001i\000\000\000\000\001i\001\213\000\000\000\000\000\000\001\213\000\000\000\000\000\000\001\213\000\000\001i\000\000\001i\000\000\001i\000\000\001i\001\213\001\213\001\213\000\000\001\213\001\213\000\000\000\000\000\000\000\000\000\000\001i\000\000\000\000\000\000\000\000\001\213\001i\001\213\001\213\001B\001\006\000\000\001\213\000\000\001\"\000\000\006\186\001\213\000\000\001&\001i\004\246\000\000\001\213\000\000\001i\001i\000\238\000\000\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\000\000\000\000\006\242\000\000\001i\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\000\000\000\000\000\000\001i\001i\001i\003F\001i\001i\003\246\000\000\000\000\na\003\250\000\000\004\002\000\000\007.\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001i\004-\000\000\000\000\005r\000\000\000\000\000\000\000\000\000\000\000\000\001i\000\000\000\000\005z\000\000\005~\000\000\000\000\0076\000\000\005\169\000\000\000\000\000\000\000\000\005\169\000\000\000\000\005\169\000\000\000\000\000\000\000\000\000\000\na\000\000\000\000\na\na\005\169\005\130\005\169\000\000\005\169\na\005\169\004j\000\000\na\004-\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\169\000\000\000\000\000\000\000\000\000\000\005\169\005\169\000\000\000\000\000\000\000\000\000\000\005\169\000\000\005\169\000\000\005\169\000\000\000\000\005\169\000\000\000\000\000\000\000\000\005\169\005\169\005\169\000\000\000\000\000\000\000\000\003u\000\000\000\000\000\000\000\000\003u\000\000\000\000\003u\005\169\005\169\000\000\000\000\005\169\000\000\000\000\000\000\000\000\000\000\003u\000\000\003u\000\000\003u\000\000\003u\005\169\005\169\005\169\000\000\005\169\005\169\000\000\000\000\003u\000\000\000\000\003u\b\026\003u\000\000\000\000\003u\003u\003u\005\169\000\000\000\000\005\169\005\169\0059\000\000\003u\003u\003u\003u\000\000\003u\000\000\003u\005\169\000\000\003u\003u\003u\000\000\000\000\000\000\000\000\000\000\000\000\003u\000\000\000\000\000\000\000\000\000\000\003u\003u\000\000\000\000\000\000\003u\000\000\005=\000\000\003u\000\000\003u\000\000\000\000\003u\000\000\000\000\000\000\003u\003u\003u\003u\003u\003u\000\000\000\000\005\157\000\000\000\000\000\000\0059\005\157\000\000\000\000\005\157\003u\000\000\003u\003u\003u\000\000\003u\000\000\000\000\000\000\005\157\000\000\005\157\000\000\005\157\000\000\005\157\003u\003u\003u\000\000\003u\003u\000\000\000\000\000\000\000\000\000\000\005\157\005=\000\000\000\000\000\000\000\000\005\157\005\157\003u\003u\000\000\000\000\003u\bZ\000\000\005\157\000\000\005\157\000\000\000\000\005\157\000\000\000\000\003u\000\000\005\157\005\157\000\238\000\000\000\000\000\000\bq\000\000\000\000\000\000\000\000\bq\000\000\000\000\bq\000\000\005\157\005\157\000\000\000\000\005\157\000\000\000\000\000\000\000\000\bq\000\000\bq\000\000\bq\000\000\bq\000\000\005\157\005\157\005\157\000\000\005\157\005\157\000\000\000\000\000\000\000\000\bq\000\000\000\000\000\000\000\000\000\000\bq\bq\000\000\005\157\000\000\000\000\005\157\005\157\000\000\bq\000\000\bq\000\000\000\000\bq\000\000\000\000\000\000\005\157\bq\bq\bq\000\000\000\000\000\000\000\000\012\201\000\000\000\000\000\000\000\000\012\201\000\000\000\000\012\201\bq\000\000\000\000\000\000\bq\000\000\000\000\000\000\000\000\000\000\012\201\000\000\012\201\000\000\012\201\000\000\012\201\bq\bq\bq\000\000\bq\bq\000\000\000\000\000\000\000\000\000\000\012\201\000\000\000\000\000\000\000\000\bq\012\201\012\201\bq\000\000\000\000\000\000\bq\004>\000\000\012\201\000\000\012\201\000\000\000\000\012\201\004\246\000\000\bq\000\000\012\201\012\201\012\201\000\000\000\000\000\000\000\000\012\205\000\000\000\000\000\000\000\000\012\205\000\000\000\000\012\205\012\201\000\000\000\000\000\000\012\201\000\000\000\000\000\000\000\000\000\000\012\205\000\000\012\205\000\000\012\205\000\000\012\205\012\201\012\201\012\201\000\000\012\201\012\201\000\000\000\000\000\000\000\000\000\000\012\205\004J\000\000\000\000\000\000\000\000\012\205\012\205\012\201\000\000\000\000\000\000\012\201\004>\000\000\012\205\000\000\012\205\000\000\000\000\012\205\000\000\000\000\012\201\000\000\012\205\012\205\012\205\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\197\000\000\002^\001\197\000\000\012\205\000\000\000\000\000\000\012\205\000\000\000\000\b\209\000\000\001\197\000\000\000\000\000\000\001\197\000\000\001\197\000\000\012\205\012\205\012\205\000\000\012\205\012\205\000\000\000\000\000\000\000\000\001\197\000\000\004J\000\000\000\000\000\000\001\197\001\197\000\000\012\205\000\000\000\000\000\000\012\205\0036\001\197\000\000\001\197\000\000\000\000\001\197\000\000\000\000\000\000\012\205\001\197\001\197\001\197\000\000\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\001\197\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\000\000\000\003Y\000\000\002^\003Y\000\000\000\000\001\197\001\197\000\000\000\000\001\197\001\197\b\205\000\000\003Y\000\000\000\000\000\000\003Y\000\000\003Y\000\000\001\197\000\000\000\000\000\000\000\000\000\000\000\000\001\197\000\000\000\000\003Y\000\000\001\197\000\000\000\000\000\000\003Y\001\193\001\197\000\000\000\000\000\000\000\000\000\000\0036\003Y\000\000\003Y\000\000\000\000\003Y\000\000\000\000\000\000\000\000\003Y\003Y\003Y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Y\003Y\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\000\000\000\003U\000\000\002^\003U\000\000\000\000\003Y\003Y\000\000\000\000\003Y\003Y\b\205\000\000\003U\000\000\000\000\000\000\003U\000\000\003U\000\000\003Y\000\000\000\000\000\000\000\000\000\000\000\000\003Y\000\000\000\000\003U\000\000\003Y\000\000\000\000\000\000\003U\001\193\003Y\000\000\000\000\000\000\000\000\000\000\0036\003U\000\000\003U\000\189\000\000\003U\000\189\000\000\000\000\000\000\003U\003U\003U\000\000\000\000\000\000\000\000\000\189\000\000\000\189\000\000\000\189\000\000\000\189\000\000\000\000\003U\003U\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\189\000\000\000\000\000\000\000\000\000\000\000\189\000\000\003U\003U\000\189\000\000\003U\003U\000\000\000\189\000\000\000\189\000\000\000\000\000\189\000\000\000\000\000\000\003U\000\189\000\189\000\238\000\000\000\000\000\000\003U\000\000\000\000\000\189\000\189\003U\001\001\000\000\000\000\001\001\000\189\003U\000\000\000\000\000\189\000\000\000\000\000\000\000\000\000\000\001\001\000\000\001\001\000\000\001\001\000\000\001\001\000\189\000\189\000\000\000\000\000\189\000\189\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\189\001\001\000\000\000\000\000\000\001\001\000\189\000\189\000\000\000\000\001\001\000\000\001\001\000\000\000\000\001\001\000\189\000\000\000\189\000\000\001\001\001\001\000\238\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\000\000\000\197\000\000\000\000\000\197\001\001\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\000\000\197\000\000\000\197\000\000\000\197\000\000\000\197\001\001\001\001\000\000\000\000\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\197\000\000\000\000\000\000\000\000\001\001\000\197\000\000\000\000\000\000\000\197\001\001\001\001\000\000\000\000\000\197\000\000\000\197\000\000\000\000\000\197\001\001\000\000\001\001\000\000\000\197\000\197\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\197\000\197\000\000\000\193\000\000\000\000\000\193\000\197\000\000\000\000\000\000\000\197\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\193\000\000\000\193\000\000\000\193\000\197\000\197\000\000\000\000\000\197\000\197\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\000\000\197\000\193\000\000\000\000\000\000\000\193\000\197\000\197\000\000\000\000\000\193\000\000\000\193\000\000\000\000\000\193\000\197\000\000\000\197\000\000\000\193\000\193\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\193\000\193\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\000\nV\000\000\000\000\021\166\b\245\000\000\b\245\b\245\000\193\000\193\000\000\000\000\000\193\000\193\n\142\n\166\n\174\n\150\n\182\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\000\000\000\n\190\n\198\000\193\000\193\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\206\000\193\000\000\000\193\000\000\000\000\000\000\000\000\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n^\n\158\n\214\n\222\n\238\001b\000\000\000\000\000\000\001f\000\000\000\000\024B\n\246\000\000\000\000\000\000\000\000\001j\001n\001r\001\190\001z\001~\n\254\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\194\001\198\000\000\000\000\000\000\000\000\000\000\011\030\001\202\011&\n\230\001\206\000\000\000\000\000\000\b\245\011\006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\014\011\022\000\000\000\000\001\210\001\214\001\218\001\222\001\226\000\000\000\000\001\161\001\230\000\000\001\161\000\000\000\000\001\234\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\161\000\000\000\000\001\238\001\161\000\000\001\161\000\000\000\000\000\000\001\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\161\001\161\000\000\002.\027\154\000\000\001\161\000\000\012I\0125\0022\000\000\0026\0059\000\000\001\161\002:\001\161\002>\002B\001\161\000\000\000\000\000\000\000\000\001\161\001\161\001\161\000\000\012I\000\000\000\000\002\194\000\000\000\000\002\198\000\000\000\000\000\000\000\000\000\000\001\161\r\142\000\000\000\000\001\161\012\197\000\000\002\210\000\000\000\000\012\197\002\218\0125\012\197\000\000\000\000\000\000\001\161\001\161\000\000\000\000\001\161\001\161\000\000\012\197\000\000\012\197\000\000\012\197\0059\012\197\000\000\000\000\001\161\000\000\000\000\002\222\000\000\000\000\001\161\001\161\000\000\012\197\000\000\000\000\001\161\000\000\000\000\012\197\012\197\000\000\001\161\000\000\000\000\000\000\000\000\000\000\012\197\000\000\012\197\000\000\000\000\012\197\000\000\000\000\000\000\000\000\012\197\012\197\012\197\000\000\000\000\000\000\012\193\000\000\000\000\000\000\000\000\012\193\000\000\000\000\012\193\000\000\012\197\000\000\002\226\000\000\012\197\000\000\000\000\000\000\000\000\012\193\000\000\012\193\000\000\012\193\000\000\012\193\000\000\012\197\012\197\012\197\000\000\012\197\012\197\000\000\000\000\000\000\000\000\012\193\000\000\000\000\000\000\000\000\000\000\012\193\012\193\000\000\012\197\000\000\000\000\000\000\012\197\000\000\012\193\000\000\012\193\000\000\000\000\012\193\000\000\004\246\000\000\012\197\012\193\012\193\012\193\000\000\000\000\000\000\000\000\bu\000\000\000\000\000\000\000\000\bu\000\000\000\000\bu\012\193\000\000\000\000\000\000\012\193\000\000\000\000\000\000\000\000\000\000\bu\000\000\bu\000\000\bu\000\000\bu\012\193\012\193\012\193\000\000\012\193\012\193\000\000\000\000\000\000\000\000\000\000\bu\000\000\000\000\000\000\000\000\007\182\bu\bu\012\193\000\000\000\000\000\000\012\193\000\000\000\000\bu\000\000\bu\000\000\000\000\bu\000\000\000\000\012\193\000\000\bu\bu\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\193\000\000\002^\001\193\bu\000\000\000\000\000\000\bu\000\000\012%\000\000\b\205\012%\001\193\000\000\000\000\000\000\001\193\000\000\001\193\bu\bu\bu\012%\bu\bu\000\000\012%\000\000\012%\000\000\001\193\000\000\000\000\000\000\0051\bu\001\193\000\000\bu\000\000\012%\000\000\bu\000\000\0036\001\193\012%\001\193\000\000\000\000\001\193\000\000\000\000\bu\000\000\001\193\001\193\001\193\000\000\000\000\012%\000\000\000\000\000\000\000\000\012%\012%\000\000\000\000\000\000\000\000\001\193\001\193\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\000\012%\000\000\000\000\000\000\000\000\000\000\000\000\001\193\001\193\000\000\000\000\001\193\001\193\000\000\000\000\000\000\000\000\012%\012%\003\030\000\000\012%\012%\001\193\001\174\002Z\002^\r\130\000\000\000\000\001\193\000\000\000\000\012%\000\000\001\193\000\000\r\154\014\142\000\000\012%\001\193\004\137\000\000\003R\001*\002\134\002r\000\000\000\000\000\000\012%\000\000\000\000\000\000\002~\014\146\000\000\000\000\000\000\000\000\000\000\014\186\000\000\000\000\000\000\005\209\000\000\000\000\002\130\003.\005\209\000\000\000\000\005\209\003:\0126\003F\004\026\004&\000\000\012>\000\000\000\000\0042\005\209\000\000\005\209\000\000\005\209\000\000\005\209\000\000\000\000\000\000\000\000\000\000\015N\000\000\000\000\000\000\0046\000\000\005\209\000\000\000\000\000\000\000\000\000\000\005\209\005\209\000\000\000\000\000\000\012Z\015b\bZ\000\000\005\209\000\000\005\209\000\000\000\000\005\209\000\000\000\000\000\000\000\000\005\209\005\209\000\238\000\000\000\000\000\000\000\000\000\000\000\000\015r\000\000\000\000\001b\000\000\000\000\000\000\005\209\000\000\000\000\000\000\005\209\000\000\000\000\000\000\000\000\001j\001n\001r\001\190\001z\001~\000\000\000\000\005\209\005\209\005\209\000\000\005\209\005\209\000\000\001\194\001\198\000\000\000\000\000\000\000\000\000\000\000\000\001\202\000\000\000\000\001\206\005\209\000\000\000\000\000\000\005\209\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\209\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\000\000\000\000\000\000\000\000\001\234\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\238\000\000\000\000\000\000\000\000\000\000\000\000\001\242\000\000\000\000\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\002.\027\182\001&\000\000\000\000\000\000\000\000\0022\000\000\0026\000\000\000\000\001*\002:\006\218\002>\002B\000\000\000\000\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\000\000\003\250\007\138\004\002\000\000\007.\005n\005\205\000\000\000\000\005\205\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005r\000\000\000\000\005\205\000\000\005\205\000\000\005\205\000\000\005\205\005z\000\000\005~\000\000\000\000\0076\000\000\000\000\000\000\000\000\000\000\005\205\000\000\000\000\000\000\000\000\000\000\005\205\b\006\000\000\000\000\000\000\t\202\000\000\000\000\t\210\005\205\005\130\005\205\000\000\000\000\005\205\000\000\004j\000\000\000\000\005\205\005\205\000\238\000\000\000\000\000\000\012\209\000\000\000\000\000\000\000\000\012\209\000\000\000\000\012\209\000\000\005\205\000\000\000\000\000\000\005\205\000\000\000\000\000\000\000\000\012\209\000\000\012\209\000\000\012\209\000\000\012\209\000\000\005\205\005\205\005\205\000\000\005\205\005\205\000\000\000\000\000\000\000\000\012\209\000\000\000\000\000\000\000\000\000\000\012\209\012\209\000\000\005\205\000\000\000\000\000\000\005\205\000\000\012\209\000\000\012\209\000\000\000\000\012\209\000\000\000\000\000\000\005\205\012\209\012\209\000\238\000\000\000\000\000\000\012\213\000\000\000\000\000\000\000\000\012\213\000\000\000\000\012\213\000\000\012\209\000\000\000\000\000\000\012\209\000\000\000\000\000\000\000\000\012\213\000\000\012\213\000\000\012\213\000\000\012\213\000\000\012\209\012\209\012\209\000\000\012\209\012\209\000\000\000\000\000\000\000\000\012\213\000\000\000\000\000\000\000\000\000\000\012\213\b\006\000\000\012\209\000\000\000\000\000\000\012\209\000\000\012\213\000\000\012\213\000\000\000\000\012\213\000\000\000\000\000\000\012\209\012\213\012\213\000\238\000\000\000\000\000\000\007\138\000\000\000\000\000\000\000\000\005\225\000\000\000\000\005\225\000\000\012\213\000\000\000\000\000\000\012\213\000\000\000\000\000\000\000\000\005\225\000\000\005\225\000\000\005\225\000\000\005\225\000\000\012\213\012\213\012\213\000\000\012\213\012\213\000\000\000\000\000\000\000\000\005\225\000\000\000\000\000\000\000\000\000\000\005\225\b\006\000\000\012\213\000\000\000\000\000\000\012\213\000\000\005\225\000\000\005\225\000\000\000\000\005\225\000\000\000\000\000\000\012\213\005\225\005\225\000\238\000\000\000\000\000\000\005\229\000\000\000\000\000\000\000\000\005\229\000\000\000\000\005\229\000\000\005\225\000\000\000\000\000\000\005\225\000\000\000\000\000\000\000\000\005\229\000\000\005\229\000\000\005\229\000\000\005\229\000\000\005\225\005\225\005\225\000\000\005\225\005\225\000\000\000\000\000\000\000\000\005\229\000\000\000\000\000\000\000\000\000\000\005\229\005\229\000\000\005\225\000\000\000\000\000\000\005\225\000\000\005\229\000\000\005\229\000\000\000\000\005\229\000\000\000\000\000\000\005\225\005\229\005\229\005\229\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Q\000\000\002^\003Q\000\000\005\229\000\000\000\000\000\000\005\229\000\000\000\000\000\000\000\000\003Q\000\000\002Z\002^\003Q\000\000\003Q\000\000\005\229\005\229\005\229\000\000\005\229\005\229\000\000\000\000\000\000\000\000\003Q\000\000\000\000\000\000\001*\002\134\003Q\000\000\000\000\005\229\000\000\000\000\000\000\005\229\0036\003Q\000\000\003Q\000\000\000\000\003Q\000\000\000\000\000\000\b.\003Q\003Q\003Q\002\130\003>\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\003Q\003Q\0042\000\000\004\146\000\000\003M\000\000\002^\003M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Q\003Q\0046\003M\003Q\003Q\026\n\003M\000\000\003M\000\000\000\000\000\000\000\000\000\000\000\000\003Q\000\000\000\000\000\000\000\000\003M\000\000\003Q\000\000\000\000\025\246\003M\003Q\000\000\000\000\000\000\000\000\000\000\003Q\0036\003M\000\000\003M\000\000\000\000\003M\000\000\000\000\000\000\000\000\003M\003M\003M\000\000\000\000\000\000\000\000\000\000\001\205\000\000\012\170\001\205\000\000\000\000\001\"\000\000\003M\003M\000\000\000\000\004\146\000\000\001\205\000\000\000\000\000\000\001\205\000\000\001\205\000\000\002Z\002^\000\000\003M\003M\000\000\000\000\003M\003M\000\000\001\205\000\000\000\000\000\000\000\000\000\000\001\205\000\000\000\000\003M\001*\002\134\000\000\012\174\000\000\001\205\003M\001\205\000\000\000\000\001\205\003M\000\000\000\000\000\000\001\205\001\205\003M\012\186\000\000\000\000\000\000\000\000\000\000\002\130\003>\000\000\000\000\000\000\000\000\003:\001\205\003F\004\026\004&\001\205\000\000\000\000\000\000\0042\000\000\001Q\000\000\000\000\001Q\000\000\000\000\005~\001\205\001\205\000\000\000\000\001\205\001\205\000\000\001Q\0046\001Q\000\000\001Q\005\001\001Q\000\000\000\000\001\205\000\000\000\000\000\000\000\000\000\000\000\000\001\205\000\000\001Q\000\000\000\000\000\000\000\000\000\000\001Q\025\246\000\000\001\205\001Q\000\000\000\000\000\000\000\000\001Q\000\000\001Q\000\000\000\000\001Q\000\000\000\000\000\000\000\000\001Q\001Q\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001Q\000\000\001M\000\000\000\000\001M\001Q\000\000\000\000\000\000\001Q\000\000\000\000\000\000\000\000\000\000\001M\000\000\001M\000\000\001M\000\000\001M\001Q\001Q\001Q\000\000\001Q\001Q\000\000\000\000\000\000\000\000\000\000\001M\000\000\000\000\000\000\000\000\001Q\001M\000\000\000\000\000\000\001M\000\000\001Q\000\000\000\000\001M\000\000\001M\000\000\000\000\001M\000\000\000\000\001Q\000\000\001M\001M\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\000\000\nV\000\000\000\000\007\025\001M\000\000\000\000\007\025\001M\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\n\182\000\000\000\000\001M\001M\001M\000\000\001M\001M\000\000\n\190\n\198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\000\000\n\206\000\000\000\000\000\000\000\000\001M\000\000\000\000\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\n^\n\158\n\214\n\222\n\238\nV\000\000\000\000\000\000\025\142\000\000\007\025\000\000\n\246\000\000\000\000\000\000\000\000\000\000\n\142\n\166\n\174\n\150\n\182\n\254\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\190\n\198\000\000\001\002\001\006\000\000\000\000\011\030\001\"\011&\n\230\n\206\000\000\001&\000\000\000\000\011\006\000\000\006q\000\238\000\000\000\000\000\000\001*\011\014\011\022\000\000\001.\n^\n\158\n\214\n\222\n\238\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\n\246\000\000\000\000\000\000\000\000\000\000\003\206\002N\000\000\000\000\000\000\n\254\000\000\000\000\003F\000\000\000\000\003\214\000\000\000\000\000\000\b\142\b\146\b\158\000\000\000\000\005n\011\030\025\146\011&\n\230\025\158\000\000\001B\001\006\000\000\011\006\000\000\001\"\000\000\006\186\000\000\000\000\001&\011\014\011\022\000\000\000\000\005z\000\000\005~\000\000\000\000\001*\000\000\006\218\000\000\000\000\000\000\b\166\001F\b\170\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\006\000\000\001R\000\000\005\130\b\186\023\182\002N\007\138\t2\004j\000\000\000\000\004\129\003F\000\000\004\129\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007.\005n\004\129\000\000\000\000\000\000\004\129\000\000\004\129\000\000\000\000\000\000\000\000\005r\000\000\000\000\000\000\000\000\000\000\000\000\004\129\000\000\000\000\005z\000\000\005~\004\129\b\006\000\000\000\000\004\129\000\000\000\000\bZ\000\000\004\129\000\000\004\129\000\000\000\000\004\129\000\000\000\000\000\000\000\000\004\129\011\146\000\238\023\198\000\000\005\130\000\000\000\000\000\000\004\129\004\129\004j\b\001\000\000\000\000\b\001\004\129\004\129\000\000\000\000\004\129\000\000\000\000\000\000\000\000\000\000\b\001\000\000\000\000\000\000\b\001\000\000\b\001\004\129\004\129\000\000\000\000\004\129\004\129\000\000\000\000\000\000\000\000\000\000\b\001\b\026\000\000\000\000\000\000\004\129\b\001\000\000\000\000\000\000\b\001\000\000\004\129\000\000\000\000\b\001\000\000\b\001\000\000\007\253\b\001\000\000\007\253\004\129\000\000\b\001\b\001\000\238\000\000\000\000\000\000\000\000\000\000\007\253\b\001\b\001\000\000\007\253\000\000\007\253\000\000\b\001\000\000\000\000\000\000\b\001\000\000\000\000\000\000\000\000\000\000\007\253\000\000\000\000\000\000\000\000\000\000\007\253\b\001\b\001\b\001\007\253\b\001\b\001\000\000\000\000\007\253\000\000\007\253\003E\000\000\007\253\003E\000\000\b\001\000\000\007\253\007\253\000\238\000\000\000\000\b\001\000\000\003E\000\000\007\253\007\253\003E\000\000\003E\000\000\000\000\007\253\000\000\000\000\000\000\007\253\000\000\000\000\000\000\000\000\003E\012\194\000\000\000\000\000\000\000\000\003E\000\000\007\253\007\253\007\253\000\000\007\253\007\253\000\000\003E\000\000\003E\000\000\000\000\003E\000\000\000\000\000\000\007\253\003E\003E\003E\000\000\000\000\000\000\007\253\001}\000\000\012-\001}\000\000\000\000\000\000\000\000\000\000\003E\000\000\000\000\012-\003E\001}\000\000\001}\000\000\001}\000\000\001}\000\000\000\000\000\000\000\000\000\000\003E\003E\026~\000\000\003E\003E\001}\000\000\000\000\000\000\000\000\000\000\001}\012-\000\000\000\000\003E\000\000\000\000\000\000\012-\000\000\rB\003E\000\000\000\000\001}\000\000\003E\000\000\000\000\001}\001}\001}\003E\000\000\000\000\000\000\001A\000\000\000\165\001A\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\165\012-\001A\000\000\001A\000\000\001A\000\000\001A\000\000\000\000\000\000\000\000\000\000\001}\001}\001}\000\000\001}\001}\001A\000\000\000\000\000\000\000\000\000\000\001A\000\165\000\000\000\000\000\000\000\000\000\000\000\000\000\165\000\000\000\000\001}\000\000\000\000\001A\000\000\000\000\000\000\000\000\001A\001A\001A\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\001A\000\000\000\000\000\000\000\165\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\000\000\000\000\001&\000\000\001A\001A\001A\006u\001A\001A\000\000\000\000\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\001A\000\000\000\000\019\194\000\000\001R\000\000\000\000\000\000\001^\002N\001A\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005b\007.\005n\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\000\000\000\000\001&\005r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\005z\006\218\005~\000\000\005\190\018\026\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\020\150\000\000\005\130\000\000\006\170\000\000\003F\000\000\004j\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007.\005n\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\000\000\000\000\001&\005r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\005z\006\218\005~\000\000\000\000\0076\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\018\174\000\000\005\130\000\000\000\000\000\000\003F\000\000\004j\003\246\000\000\001\002\001\006\003\250\000\000\004\002\001\"\007.\005n\000\000\000\000\001&\000\000\000\000\000\000\000\000\006\153\000\000\000\000\000\000\005r\001*\000\000\000\000\000\000\001.\000\000\000\000\000\000\000\000\005z\000\000\005~\000\000\0012\0076\003z\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\206\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\019*\003\214\005\130\000\000\000\000\b\142\b\146\b\158\004j\000\000\005n\004i\004i\000\000\000\000\000\000\004i\000\000\000\000\000\000\000\000\004i\000\000\000\000\000\000\000\000\000\000\004i\000\000\000\000\000\000\004i\005z\000\000\005~\000\000\000\000\000\000\004i\019z\000\000\000\000\019\146\b\166\000\000\b\170\000\000\000\000\000\000\000\000\000\000\004i\000\000\000\000\000\000\004i\004i\000\000\000\000\005\130\b\186\000\000\000\000\004i\t2\004j\004i\000\000\003E\000\238\004i\003E\004i\004i\000\000\004i\000\000\000\000\000\000\000\000\000\000\000\000\003E\000\000\000\000\000\000\003E\004i\003E\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004i\000\000\004i\003E\012\194\000\000\000\000\000\000\000\000\003E\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003E\000\000\003E\012%\000\000\003E\012%\000\000\000\000\004i\003E\003E\003E\000\000\000\000\004i\000\000\012%\000\000\000\000\000\000\012%\000\000\012%\000\000\000\000\003E\000\000\000\000\0051\003E\000\000\000\000\000\000\000\000\012%\000\000\000\000\000\000\000\000\000\000\012%\000\000\003E\003E\026\174\000\000\003E\003E\000\000\012%\000\000\012%\000\000\000\000\012%\000\000\000\000\000\000\000\000\012%\012%\001B\001\006\000\000\rB\003E\001\"\000\000\000\000\000\000\003E\001&\000\000\000\000\000\000\012%\005\186\000\000\003\254\012%\000\000\001*\000\000\000\000\000\000\000\000\000\000\000\000\001F\000\000\000\000\000\000\012%\012%\003\030\000\000\012%\012%\000\000\000\000\000\000\001R\000\000\000\000\000\000\001^\002N\000\000\012%\000\000\000\000\000\000\014^\003F\000\000\012%\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005b\000\000\005n\012%\000\000\000\000\000\000\000\000\000\000\000\000\001B\001\006\000\000\000\000\005r\001\"\000\000\006\186\000\000\000\000\001&\000\000\000\000\000\000\005z\000\000\005~\000\000\005\190\000\000\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006^\000\000\001R\005\130\000\000\000\000\b\246\002N\000\000\004j\000\000\000\000\000\000\005\133\003F\000\000\005\133\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007.\005n\005\133\000\000\000\000\000\000\005\133\000\000\005\133\000\000\000\000\000\000\000\000\005r\000\000\000\000\000\000\000\000\000\000\000\000\005\133\000\000\000\000\005z\000\000\005~\005\133\000\000\000\000\000\000\000\000\000\000\000\000\bZ\000\000\005\133\000\000\005\133\000\000\000\000\005\133\000\000\000\000\000\000\000\000\005\133\005\133\000\238\000\000\000\000\005\130\000\000\000\000\000\000\000\000\000\000\004j\005\137\000\000\000\000\005\137\005\133\005\133\000\000\000\000\005\133\000\000\000\000\000\000\000\000\000\000\005\137\000\000\000\000\000\000\005\137\000\000\005\137\005\133\005\133\000\000\000\000\005\133\005\133\000\000\000\000\000\000\000\000\000\000\005\137\000\000\000\000\000\000\000\000\000\000\005\137\000\000\000\000\000\000\000\000\000\000\005\133\bZ\000\000\005\137\000\000\005\137\003E\000\000\005\137\003E\000\000\005\133\000\000\005\137\005\137\000\238\000\000\000\000\000\000\000\000\003E\000\000\000\000\000\000\003E\000\000\003E\000\000\000\000\005\137\005\137\000\000\000\000\005\137\000\000\000\000\000\000\000\000\003E\012\194\000\000\000\000\000\000\000\000\003E\000\000\005\137\005\137\000\000\000\000\005\137\005\137\000\000\003E\000\000\003E\006)\000\000\003E\006)\000\000\000\000\000\000\003E\003E\003E\000\000\000\000\000\000\005\137\006)\000\000\000\000\000\000\006)\000\000\006)\000\000\000\000\003E\005\137\000\000\000\000\003E\000\000\000\000\000\000\000\000\006)\000\000\000\000\000\000\000\000\000\000\006)\000\000\003E\003E\r\"\000\000\003E\003E\000\000\006)\000\000\006)\000\000\000\000\006)\000\000\000\000\000\000\000\000\006)\006)\000\238\000\000\000\000\rB\003E\000\000\011\229\000\000\001\006\011\229\000\000\000\000\028\142\000\000\006)\000\000\000\000\028\146\006)\000\000\011\229\000\000\000\000\000\000\000\000\000\000\011\229\000\000\000\000\000\000\000\000\006)\006)\r\230\000\000\006)\006)\000\000\011\229\000\000\000\000\000\000\000\000\000\000\011\229\000\000\000\000\006)\000\000\000\000\000\000\001\186\002N\011\229\006)\011\229\001\174\000\000\011\229\002\182\000\000\000\000\000\000\011\229\000\000\006)\000\000\000\000\000\000\000\000\003N\028\150\001B\001\006\004\149\000\000\003R\001\"\000\000\011\229\000\000\000\000\001&\011\229\000\000\000\000\000\000\000\000\003^\006r\000\000\000\000\001*\000\000\011\170\028\154\011\229\011\229\000\000\001F\011\229\000\000\000\000\003\226\000\000\020\226\000\000\000\000\0126\000\000\000\000\000\000\001R\012>\000\000\000\000\001^\002N\000\000\011\229\007\138\000\000\000\000\000\000\003F\007!\000\000\003\246\007!\012F\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\007!\000\000\000\000\000\000\007!\000\000\007!\012Z\012\158\005r\000\000\004\149\004\149\000\000\000\000\000\000\000\000\000\000\007!\005z\000\000\005~\000\000\005\190\007!\b\006\000\000\000\000\000\000\000\000\018\002\000\000\000\000\007!\000\000\007!\001\209\000\000\007!\001\209\000\000\000\000\000\000\007!\007!\000\238\005\130\000\000\000\000\000\000\001\209\000\000\004j\000\000\001\209\000\000\001\209\000\000\000\000\007!\000\000\000\000\000\000\007!\000\000\000\000\000\000\000\000\001\209\000\000\000\000\000\000\000\000\000\000\001\209\000\000\007!\007!\000\000\000\000\007!\007!\000\000\001\209\000\000\001\209\006-\000\000\001\209\006-\000\000\000\000\000\000\001\209\001\209\000\000\000\000\000\000\000\000\007!\006-\000\000\000\000\000\000\006-\000\000\006-\000\000\000\000\001\209\000\000\000\000\000\000\001\209\000\000\000\000\000\000\000\000\006-\000\000\000\000\000\000\000\000\000\000\006-\000\000\001\209\001\209\000\000\000\000\001\209\001\209\000\000\006-\000\000\006-\000\000\000\000\006-\000\000\000\000\000\000\001\209\006-\006-\000\238\000\000\000\000\000\000\001\209\000\000\000\000\000\000\000\000\r\198\000\000\000\000\000\000\000\000\006-\001\209\000\000\000\000\006-\000\000\000\000\000\000\000\000\b1\b1\000\000\000\000\000\000\b1\000\000\000\000\006-\006-\b1\000\000\006-\006-\000\000\000\000\003\238\000\000\000\000\000\000\b1\000\000\000\000\000\000\006-\000\000\000\000\b1\000\000\000\000\000\000\006-\000\000\004\129\000\000\000\000\004\129\000\000\000\000\000\000\b1\000\000\006-\000\000\b1\b1\000\000\004\129\000\000\000\000\000\000\004\129\b1\004\129\004\129\b1\000\000\000\000\000\000\b1\000\000\b1\b1\000\000\b1\004\129\000\000\000\000\000\000\004\129\000\000\004\129\000\000\000\000\000\000\000\000\b1\000\000\004>\000\000\004\129\000\000\004\129\004\129\000\000\004\129\b1\000\000\b1\004\129\004\129\011\146\000\000\000\000\000\000\000\000\000\000\000\000\004\129\000\000\004\129\000\000\000\245\004\129\000\000\000\245\004\129\000\000\004\129\011\146\004\129\000\000\000\000\b1\000\000\000\000\000\245\000\000\000\000\b1\000\245\000\000\000\245\004\129\004\129\000\000\000\000\004\129\004\129\000\000\000\000\000\000\000\000\000\000\000\245\004J\000\000\000\000\000\000\007\182\000\245\004\129\004\129\000\000\000\000\004\129\004\129\000\000\000\000\000\245\000\000\000\245\000\249\000\000\000\245\000\249\000\000\004\129\000\000\000\245\000\245\000\238\000\000\000\000\004\129\000\000\000\249\000\000\000\000\026v\000\249\000\000\000\249\000\000\000\000\000\245\000\000\000\000\000\000\000\245\000\000\000\000\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\000\000\249\000\000\000\245\000\245\000\000\000\000\000\245\000\245\000\000\000\249\000\000\000\249\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\249\000\249\000\238\000\000\000\000\000\000\000\245\000\000\000\000\002Z\003\"\000\000\000\000\000\000\001\"\000\000\000\249\000\245\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\002\134\002r\003&\000\249\000\249\000\000\000\000\000\249\000\249\002~\000\000\000\000\000\000\000\000\000\000\000\000\007\029\000\000\000\000\007\029\000\000\000\000\000\000\003*\003.\000\000\000\249\000\000\000\000\003:\007\029\003F\004\026\004&\007\029\000\000\007\029\000\249\r\158\000\000\r\162\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007\029\000\000\000\000\000\000\000\000\000\000\007\029\0046\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007\029\000\000\007\029\006!\005~\007\029\006!\000\000\000\000\000\000\007\029\007\029\000\000\000\000\012\138\000\000\r\174\006!\000\000\000\000\000\000\006!\000\000\006!\000\000\000\000\007\029\000\000\000\000\000\000\007\029\000\000\000\000\r\178\000\000\006!\000\000\000\000\000\000\000\000\000\000\006!\000\000\007\029\007\029\011\190\000\000\007\029\007\029\000\000\006!\000\000\006!\011\145\000\000\006!\011\145\000\000\000\000\000\000\006!\006!\000\000\014\206\000\000\000\000\007\029\011\145\000\000\000\000\000\000\011\145\000\000\011\145\000\000\000\000\006!\000\000\000\000\000\000\006!\000\000\000\000\000\000\000\000\011\145\000\000\000\000\000\000\000\000\000\000\011\145\000\000\006!\006!\000\000\000\000\006!\006!\000\000\011\145\000\000\011\145\000\000\000\000\011\145\000\000\000\000\000\000\000\000\011\145\000\000\000\000\000\000\000\000\000\000\006!\000\000\011\149\000\000\000\000\011\149\000\000\000\000\000\000\000\000\011\145\n:\000\000\000\000\011\145\000\000\011\149\000\000\000\000\000\000\011\149\000\000\011\149\000\000\000\000\000\000\000\000\011\145\011\145\000\000\000\000\011\145\011\145\000\000\011\149\000\000\000\000\000\000\000\000\000\000\011\149\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\149\011\145\011\149\000\000\000\000\011\149\000\000\000\000\000\000\000\000\011\149\000\000\011.\000\000\000\000\002Z\003\"\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\011\149\nJ\000\000\000\000\011\149\000\000\000\000\000\000\000\000\001*\002\134\002r\000\000\000\000\000\000\000\000\000\000\011\149\011\149\002~\000\000\011\149\011\149\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003*\003.\004Y\000\000\000\000\004Y\003:\011\149\003F\004\026\004&\000\000\000\000\000\000\000\000\r\158\004Y\026N\011.\000\000\004Y\000\000\004Y\007\138\000\000\000\000\000\000\000\000\005\145\000\000\000\000\005\145\0046\000\000\004Y\000\000\000\000\000\000\000\000\000\000\004Y\000\000\005\145\000\000\005~\000\000\005\145\000\000\005\145\004Y\000\000\004Y\000\000\000\000\004Y\000\000\026Z\000\000\000\000\004Y\005\145\000\000\000\000\000\000\000\000\000\000\005\145\b\006\000\000\000\000\000\000\000\000\000\000\r\178\000\000\004Y\000\000\000\000\000\000\004Y\005\145\000\000\000\000\000\000\000\000\005\145\005\145\000\238\000\000\000\000\000\000\000\000\004Y\004Y\000\000\000\000\004Y\004Y\000\000\000\000\000\000\005\145\000\000\000\000\000\000\000\000\000\000\004Q\000\000\000\000\004Q\000\000\000\000\000\000\004q\004Y\000\000\004q\005\145\005\145\000\000\004Q\005\145\005\145\000\000\004Q\012\006\004Q\004q\000\000\000\000\000\000\004q\000\000\004q\000\000\000\000\000\000\000\000\004Q\000\000\005\145\000\000\000\000\000\000\004Q\004q\000\000\000\000\000\000\000\000\000\000\004q\000\000\004Q\000\000\004Q\000\000\000\000\004Q\000\000\004q\000\000\004q\004Q\000\000\004q\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\000\000\000\000\000\000\004Q\000\000\000\000\004q\000\000\000\000\000\000\004q\004A\000\000\000\000\004A\000\000\004Q\004Q\000\000\000\000\004Q\004Q\000\000\004q\004q\004A\000\000\004q\004q\004A\000\000\004A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004Q\000\000\000\000\000\000\004A\000\000\000\000\004q\000\000\000\000\004A\016\182\000\000\000\000\000\000\000\000\000\000\000\000\017\154\004A\000\000\004A\000\000\000\000\004A\000\000\000\000\000\000\000\000\004A\002Z\002^\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\129\000\000\000\000\004\129\004A\000\000\003\254\000\000\004A\001*\002\134\002r\000\000\000\000\004\129\000\000\000\000\000\000\004\129\002~\004\129\004A\004A\000\000\000\000\004A\004A\000\000\000\000\000\000\000\000\000\000\004\129\002\130\003.\000\000\000\000\000\000\004\129\003:\000\000\003F\004\026\004&\004A\000\000\000\000\000\000\0042\000\000\011\245\000\000\004\129\011\245\000\000\020\182\000\000\004\129\011\146\007\165\000\000\000\000\000\000\000\000\011\245\0046\000\000\000\000\000\000\000\000\011\245\000\000\000\000\004\129\000\000\000\000\007\165\007\165\000\000\007\165\007\165\000\000\011\245\000\000\000\000\000\000\000\000\000\000\011\245\000\000\004\129\004\129\000\000\000\000\004\129\004\129\000\000\011\245\000\000\011\245\007\165\000\000\011\245\000\000\007\137\000\000\004f\011\245\004j\000\000\000\000\000\000\000\000\004\129\000\000\000\000\000\000\000\000\r\198\000\000\000\238\007\137\007\137\011\245\007\137\007\137\000\000\011\245\000\000\007\169\000\000\000\000\000\000\000\000\000\000\007\165\000\000\000\000\000\000\000\000\011\245\011\245\000\000\000\000\011\245\007\137\007\169\007\169\000\000\007\169\007\169\000\000\028~\007\165\000\000\007\165\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\245\000\000\007\137\000\000\000\000\007\157\007\165\007\169\000\000\005\222\007\165\000\000\000\000\000\000\007\165\000\000\007\165\007\137\004I\000\000\007\165\004I\007\157\007\157\000\000\007\157\007\157\000\238\000\000\000\000\000\000\000\000\004I\000\000\000\000\007\137\004I\007\137\004I\000\000\000\000\000\000\007\169\000\000\000\000\000\000\007\157\000\000\000\000\000\000\004I\007\137\002Z\002^\005\222\007\137\004I\000\000\000\000\007\137\007\169\007\137\007\169\000\000\000\000\007\137\000\238\000\000\000\000\000\000\004I\000\000\001*\002\134\002r\004I\007\169\000\000\000\000\005\222\007\169\007\157\002~\000\000\007\169\015\162\007\169\000\000\000\000\000\000\007\169\004I\000\000\000\000\000\000\000\000\002\130\016\246\000\000\007\157\016\026\007\157\003:\000\000\003F\004\026\004&\000\000\004I\004I\000\000\017\006\004I\004I\000\000\0062\000\000\000\000\005\222\007\157\000\000\004y\000\000\007\157\004y\007\157\000\000\000\000\0046\007\157\001\174\004I\000\000\002\182\000\000\004y\000\000\000\000\000\000\004y\000\000\004y\017B\000\000\028\214\000\000\002Z\002^\000\000\000\000\003R\000\000\000\000\004y\000\000\000\000\000\000\000\000\000\000\004y\000\000\000\000\003^\000\000\000\000\000\000\001*\002\134\011\170\000\000\000\000\000\000\000\000\004y\000\000\000\000\000\000\003\226\004y\020\226\000\000\000\000\0126\000\000\000\000\000\000\000\000\012>\006\241\006\241\002\130\003>\000\000\000\000\004y\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\012F\000\000\0042\000\000\028\134\006\241\006\241\006\241\004y\004y\000\000\000\000\004y\004y\000\000\006\241\000\000\012Z\012\158\0046\000\000\004\189\000\000\005\005\000\000\012\217\012\217\000\000\000\000\006\241\006\241\004y\000\000\000\000\000\000\006\241\000\000\006\241\006\241\006\241\018\002\000\000\017\194\025\246\006\241\012\217\012\217\012\217\007\158\000\000\000\000\000\000\000\000\001\174\000\000\012\217\r\130\000\000\000\000\000\000\000\000\006\241\000\000\000\000\000\000\000\000\000\000\014\142\000\000\012\217\012\217\004\137\000\000\003R\000\000\012\217\000\000\012\217\012\217\012\217\001\174\000\000\000\000\002\182\012\217\014\146\002Z\002^\024\234\000\000\000\000\014\186\000\000\000\000\004\181\000\000\000\000\000\000\000\000\000\000\003R\012\217\000\000\000\000\000\000\0126\001*\002b\002r\004\222\012>\000\000\003^\000\000\000\000\000\000\002~\000\000\011\170\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015N\003\226\000\000\020\226\002\130\003.\0126\000\000\000\000\000\000\003:\012>\003F\004\026\004&\000\000\000\000\012Z\015b\0042\000\000\004\137\004\137\000\000\000\000\000\000\000\000\012F\002Z\002^\000\000\000\000\000\000\000\000\000\000\000\000\0046\000\000\000\000\000\000\015r\000\000\000\000\000\000\012Z\012\158\000\000\000\000\001*\002b\000\000\000\000\000\000\000\000\000\000\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\002\000\000\000\000\000\000\000\000\002\130\0036\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\000\000\000\000\0042\000\000\012\198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0046")) + ((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\022N\006\021\218P\240^0\000\000\000\025\000\000\000\000\001\030\000\000\000\000P\130\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\002\248\002\160\000\t\000\000\000\000\002\236\000\000Q\168c\208\022\022\\\148\022|\003\168\0001k\026\000\000\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\234\001\132\000\157\000\000\000\168\004B\000\000\000\242\000\226\004J\000\000\005L\002\000\n\\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\000\000\002\160]`\000\000\000\000\000h\000\000\000\000^\002\003<\002\200\000\000\000\000L$\000h\000\000P\172\022\022Q\168\004\130\004\242\003\168\004\176\000\000\022\022I\186TB\022\022_\180\000\000\001<\000\000Yj\004\250\000\000\028x\000\000\000\016\000\000\000\000\001\166\000\000\000h\000\000\000\000\000\000\001\206\000\000\028x\000\000\004\004~Z\133\166k\176\135\182O\016YX_\198\000\000t4\026\018]`N\160I\186I\186\000\000\000\000\000\000I\244I\244\003\168\004\176\004\176\022\022\000\003\025\174\000\208\005\182\000\000\004v\005\186\000\000\000\000\000\000\000\000\000\000\022\022\000\000\000\000\000\000T|\022\022\000\003T|\022\022\000\003G\174w\166I\186\000\252\000\003Tr\022\022\131\242\000\000^0{\138~\206\000\000\005\182\000\000\0056\000\000\023\164K([\140\000\000K([\140\000\000K(\138\002\007\028\006\194\004\004\002\164\000\000\005\164\000\000\000\000\b0\000\000\000\000\000\000K(\000h\000\000\000\000_\180K(^\234_\198\000\000\000\000[J\007\028\000\000\000\000_\198\005\252K(\000\000\\4_\198]\030\000\000\000\000\000\000\003(\000\000K(\000\000\021\024\140\214\000\000K(\007VK(\000\000\030.\006\148\000h\000\000\000\000\031,\000\000\bT\000\000a\166\0040\000\000\006\204K(\004|\000\000\004\146\000\000\003\138\000\000\000\003\006b\000\000\000\000\000\000$@\tX^0Tr\022\022^0\000\000\007\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000ZR\030\140\000\000\000\000\000\000\001\254\026\002~\206\000\000Tr\022\022^0\000\000\000\000Z\160^0\138\148^0\138\238\000\000`X\000\000\000\000`\252P\130\004\180\004\180\000\000\b,^0\000\000\000\000\000\000\bB\b~\000\000\027\138\000\000^0\139 K(\003~\000\000^0\139n\0001\000\000\000\000\000\000\b\186\000\000\022Z\000\000\130\028\000\000\b\198\000\000QF^0\000\000\000\000H\250\tB\005\182\t\156\000\000\000\000\000\000\000\000\b\180\000\000O\138\006\022\th\007\174K(\016\186\t\200\000\000\000\000\007l\th\t\018\000\003^0b\128\002\254\000\000^0\024\144K(\017\138\t\018\n\152\000\000\000\000\000\000Q~\004\180\n\168pb^0\000\000\000\003T|P&I\244\003\168\004\176\003~\002\004\000\t\000\000\n\132Q\168Q\168\011bQ\168\003~\002\004\002\004\000\000\011xQ\168\000\000p\230\001LYj\005\182\005\248\141&\000\000K(lVK(e&l\222K(\005lK(mh\000\000\t\134\n\150\006\140Q\168qn\000\000\006\196\011\148d\020\000\000\000\000\000\000\000\000Q\168q\246Q\168r~\000\218\004\004e\176\005\186\004\004f:\000\000s\006\001L\000\000\000\000s\142\023f\000\000\025\228\000\000\011\250\004\176\000\000d\158S\184\000\000\000$\000\000Q\168\026P\000\000\000\000\000\000cF\000\000\000$\000\003K\178\005\234\t\170\000\003\024\006L\184\018\022\000\003T|\022\022\018\022T|\022\022J\182T|\022\022\000\003Tr\022\022^0^0H\250\000\003Tr\022\022\127^Rz\004\180\012Bx4\000\003Tr\022\022^0\028N\000\003Tr\022\022^0\027\138\000\003\018\022\000\000\000\000\000\000\000\000\001\250\023rH\180\000\000UPV$I\244\003\168\004\176\006\192Q\168\026b\000\000V\248W\204{\138\029LK(\t\174\000\003T|\022\022\018\022\024\006\018\022\003\002\017\254\000\003\000\003\018\022\n\200\012\020\007\220K(#|K(\028\nK(#\154\012v\000\000\000\000\012b\000\000\018\022\004\n\012\206\000\000$\236\000\003\r\024\000\000\027\254\000\003\019\020\025\004\000\000\000\000\000\000\000\000\b\224\000\003\000\000\000\000\t\202\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^0\029\134K(\n\208\000\003\000\000\031\130\000\003\000\000^0 F^0 \128^0!D\0001\000\000\000\000\000\000!~^0\"B\000\000x\156N\160I\186^0N,\000\003\000\000I~\025\174\000\208\000h\133\242Q\168\130\136x\156x\156\000\000\000\000\004\002\005\n\000\t\006\n\004\176\127\198Q\168\005\198\004\176\128Px\156\136\020\002\160\000\t\006\nx\156\136\020\000\000\006\n\000\000\000\000\006\nx\156\000\000N\160I\186N\160I\186I\244\003\168\004\176x\156\000\000\022|\003\168\0001\012f]`\n\n\000h\000\000K(y&\012\182\r\186\134V\000\000x\156\000\000y\140K\198\022\022\005\170\000\000\t\148\014$\000\000\014F\128\180_\198\000=\000\000\014&\r\178]`\011\030K(#\250\022\022\011\152\021\220\000\000$\248\014\132\000\000\000\248\000\000\000\000\014\160_\198f\194\000\000m\242\006\178\n\146\002\004\b&\r\220\022\022x\156\000\000\142(\011\184_\198\014p_\198t\022gj\014\128_\198t\180h\018\022\022x\156\000\000\000\000n\200TB\022\022k\254Yj\011\208n\006\133\166\138\002\000=\014\224\000\000\000\000u6y\240\022\022\000\000\130\236\005\170\000\000\000\000\1326\000\000\000\000\000\000\129\024\025z\026x\000=\015\006\000\000\000\000\000\000y\240\022\022\000\000\000=\015\014\000\000\000\000\000\000\000\000\000\000\1326\000\000\015\014\027\226\000\000\022\232\138\026\000\000\000\000\000\000\000\000\012\028~Z\133\166\000\000\1326\000\000\000\000\1326\000\000\015 \027\226\022\232\138\026\000\000\141`\023\152\002\248\000\208\004\004\1326\000\000\000\208\004\004\1326\000\000JP\025\174\000\208\000h\133\242Q\168x\156\000\000\004\002\006\194\bn\004\004\1326\000\000\000\t\014xQ\168x\156Y\252\002\160\000\t\014\138Q\168x\156Y\252\000\000\000\000\007\018\000\003x\156\000\000Q\168\136Hx\156\000\000\007\018\000\000P\172\022\022Q\168x\156\000\000K\198\022\022\005\170y\240#\242\029j\021\220\017\184\000\000\012v\028x\011b\000\000\015\"\014\240\0312\021\218[ZK(\012N\000\000Rf\003\218\006\242\011\232\000\000\011\198\000\000\015R\014\214K(UP\000\000\003\168\017\180\012*\000\000\012`\000\000\015\\\014\218]`Q\236\000\000\022\022\0312\015|\004j\000\208\000\003\002X\0312K(\012\158\007\028\000\000K(\b\238\n\234\000\000\000\000u\220\000\000\000\003\005\204\0312vfUP\000\000\022\022K(\012\168K(H\180Q\236\000\000\015\000\000\000Q\236\000\000\000\000Rf\000\000x\156\136\230\021\220\017\184\012v\015\128\015*\0312x\156\136\230\000\000\000\000\021\220\017\184\012v\015\168\0158\139\198Y<_\198\015\204\139\198\138\002\028\202\015\220\139\198_\198\015\228\139\198zpz\240\000\000b0\000\000\000\000x\156\139\132\021\220\017\184\012v\015\224\015`\139\198x\156\139\132\000\000\000\000\000\000\141`\000\000\000\000\000\000\000\000\000\000\000\000\000\000x\156\000\000\136\244\022\022M\004\015\246~Z\000\000\1326\136\244\000\000\000\000\140R\022\022M\004\015\250\015~\133\166\000\000\1326\140R\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\026#\242\021\220\017\184\012v\016\n{\138J\224\021\218P\240V\248\022f\002\210\000=\016\012\n\012\000\003\000\000\015\184\000\003\000\000Q\236\000\000\007\222\012\230\000\000\r^\000\000\016 \015\158K(O\156\0162\012\b\000\003\000\000\015\238\000\003\000\000\022\138\003\168\r(\016P|\012]`\004\180\015\232K(\rp\000\003\000\000\015\254\000\003\000\000\000\000\000\000pb\016\000\000\003\000\000\000\000\000\000Q\236\000\000\021\182\rd\000\000\r\132\000\000\016^\015\220]`\000\000\016n|\142_,\004\180\016\020K(\rv\000\003\000\000\016.\000\003\000\000\000\000\022\022\000\003Q\236\000\000\022<\022\022J\224J\224}\130N\160\022\022\131\242^0\n\200\000\000\021\178\000\208\000\003\tZJ\224K(\r\228\005\182\000\000\022\022{\138{\138J\224\r\136J\224\000\000L\166\018\022\005\018\006\026M\160\000\000\000\000\000\000hv\000\000\000\000i\000\000\000\000\000i\138\000\003\r\138J\224j\020\131\242^0\n\200\000\000\007\012\000\000\139\198\016\226\000\000G\174\016\186\000\000Q\236\000\000J\224G\174Q\236\000\000\022\022K(Q\236\000\000\016Z\000\000Q\236\000\000\000\000V\248\000\000\132\192\139\198\016jJ\224\133${\138\000\000x\156\137\144\021\220\017\184\012v\016\204{\138x\156\137\144\000\000\000\000\000\000\129\254Tr\022\022\131\242^0x\156\000\000\000\000\000\000\000\000\000\000\000\000\134\186\000\000\000\000\135<\000\000x\156\000\000\136\244\000\000\000\000\000\000\000\000x\156\129\254\000\000\017\022\000\000\134\186\000\000\135<\017\026\000\000\017,\000\000\000\0003\206\000\003\0170\000\000\000\003\0172\000\000\012\230\018\252\000\003\017D\000\000j\160J\182\000\000\000\003\017B\000\000\000\003\017H\000\000\000\000\019\250\000\003\017Z\007\"\000\0034\204\000\003\017X\b \000\0035\202\000\003\017f\t\030\000\0036\200%\234\000\003\017\132\n\028\000\0037\198\000\003\017\144\011\026\000\0038\196\000\003\017\146\012\024\000\0039\194\012\246\020\248\000\003\017\154\r\022\000\003:\192\000\003\017\180\014\020\000\003;\190\000\003\017\184\015\018\000\003<\188\016\016\000\003=\186\021\016\000\000\017\238\000\000\000\003\017\238\000\000\000\003\018\004\000\000\000\000\"|\000\003\000\000\007\214\000\003\000\000^0\000\000\000\000}\000\018\024\000\000K\178\000\000\017^\000\000X\158\000\000\0188\000\000\005\234\017\194\000\000\024\006\031r\005\182\000\000\031\192\000\000\011T\014N\023|\000\000\000\000\018F\000\000\001t\027\000R\128\000\000\014(\000\000\000\000\000\003\017\156\000\003\017\180\000\000\017\178\000\003\017\198\000\000\000\003\014(\000\003\017\218\000\003\017\228\000\000\000\000Sv\004\180\018\154x4_\198\t\240\000\003\000\000x4\000\000\000\000\000\000x4\000\000\018n\000\003\000\000\000\003\000\000\000\000\000\000>\184^0\000\000\000\000\018\172\000\003?\182\000\003@\180\000\000\018\002\000\000\027\000j\160\000\000\017\014\018\156\000\000v\216\014\"\014\136\000\000\000\000\0182\000\000\018\188\000\000\000\000\003\168\004\176\023\160\000\003\000\000\002\248\002\160\000\t\006\n\018R\000\003\000\000K\198\022\022\005\170\000\230\003~\018X\000\003\000\000\000\000\000\000\000\000\000\000\018\232\000\000\000\000\141\160\004\180\018PK(\014\164\000\003\000\000\r\146K(\014\200\000\003\000\000\018f\000\003\000\000\000\000x\156\000\000A\178\000\000\018@\000\000\000\000I\244\003\168\004\176\024\232\000\000Q\168\027N\000\000\nT\000\000\019\014\000\000\019@^0B\176\019J^0C\174wR\000\000Q\168\027`\000\000Q\168\027\210\000\000Q\168\028\208\000\000x\156\000\000\003\168\004\176x\156\000\000x\156\129\254\000\000\000\000\019 \000\000\021\006\014<\022\022u`\000\000\000\000!\004\140\130\000\000\000\000\018\184\000\000\019\016K(\000\000\014\144\n,\007\028\000\000\000\000K(\005V\007\158\000\000K(\012\148\000=\019D\000\000\000\000\131P\000\000\000\000\0198\027\226\029P\005\170y\240\006\178\022\022\000\000\132Z\000\000\000\000\000\000\000\000\000\000\000\000\000\000}\246\006\178\022\022\000\000\015\140~Z\019L\027\226\029P\132Z\000\000\018\196\000\000o&\028\246\000\000x\156\000\000\018\212\000\000\029\206\000\000\028N\000\000K(\014\252\000\000V\248\018\236\000\000\019\186^0D\172E\170^0F\168\000\003\000\000\000\003\000\000\018\230\000\003\018\236\000\000\019\152\000\000\000\003\018\236\000\003\018\242\000\000\019\018\000\000\000\000\\\148\019\"\000\000\000\000\028\252k\026\019\196\000\000\000\000\000\000\012T\017\196o\152\019\202\000\000\000\000\000\000\000\000\000\000\000\000\019J\000\000\006\178\000\000\019^\000\000K(\000\000\003~\000\000\000\003\019`\000\000\000\000\004\004\000\000\bl\000\000\000\003\000\000\001\212\000\000\004\176\000\000\005\190\000\000Q\168\000\000\026P\000\000\n\150\000\000\019j\000\000^0\024\144\000\000\000\000\024\216\019p\000\000\000\000\019h\025\178J\182\000h\129\154\000\000\000\000\000\000\000\000\000\000\138~\000\000\000\000\020\"\000\000\141\150\000\000\015\176\020&\000\000\020<\000\000K\178K\178\140d\140d\000\000\000\000x\156\140d\000\000\000\000\000\000x\156\140d\019\160\000\000\019\172\000\000"), (16, "\t-\000\006\000\246\001\142\001\146\t-\001\002\001\006\t-\001\n\001\022\001\"\t-\012\214\t-\012Y\001&\t-\007Z\t-\t-\t-\005\253\t-\t-\t-\001*\001\186\002N\001\254\001.\t-\003V\003Z\n\138\t-\012Y\t-\006\181\0012\br\003z\002\230\t-\t-\003\174\003\178\t-\003\182\003\194\003\206\003\218\003\226\006\234\007:\002\234\t-\t-\003F\001J\002f\003\214\t-\t-\t-\b\154\b\158\b\170\b\186\bf\005n\t-\t-\t-\t-\t-\t-\t-\t-\t-\b\210\001N\t-\000\238\t-\t-\t-\001J\b\222\b\246\t\022\t*\005z\t-\005~\t-\t-\t-\b\150\t-\t-\t-\t-\b\178\002j\b\182\002\006\024\n\t-\001N\t-\t-\004i\t-\t-\t-\t-\t-\t-\005\130\b\198\t-\t-\t-\t>\004j\t\162\012\129\t-\t-\t-\t-\012\129\012\129\012\129\012\129\bv\002\022\012\129\012\129\012\129\012\129\001\250\012\129\012\129\003\129\012\129\012\129\012\129\003\161\012\129\012\129\012\129\012\129\012\206\012\129\004i\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012Q\012\129\012\214\012\129\000\238\012\129\012\129\012\129\012\129\012\129\007\150\005\253\012\129\012\129\012\129\003E\012\129\003\222\012\129\012\129\012\129\012Q\001\173\012\129\012\129\012\129\012\129\012\129\012\129\012\129\003E\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\b\026\012\129\012\129\007\210\012\129\012\129\012\129\001V\001\250\003\129\b\"\002\242\012\129\012\129\012\129\012\129\012\129\012\129\b&\012\129\012\129\012\129\012\129\012\129\012\129\012\129\rN\012\129\012\129\001Z\012\129\012\129\002\246\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\003\n\001\173\012\129\012\129\012\129\012\129\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\002&\001\173\002\202\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\023f\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\003A\001\173\001\173\001\173\001\173\001\173\007V\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\0283\001\173\001\173\001\173\001\173\001\173\001\173\001\173\b\"\004i\004i\003\014\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\004F\tV\001\173\005\178\001\173\001\173\r:\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\016:\001\173\001\173\001\173\001\173\001\173\n-\002\237\002\237\004>\006\246\n-\n-\n-\n-\002J\001\154\n-\n-\n-\n-\000\238\n-\n-\004i\n-\n-\n-\b\"\n-\n-\n-\n-\004i\n-\000\n\n-\n-\n-\n-\n-\n-\n-\n-\001\246\n-\000\238\n-\004\202\n-\n-\n-\n-\n-\006\250\007\022\n-\n-\n-\002\014\n-\002\030\n-\n-\n-\002\237\004J\n-\n-\n-\n-\n-\n-\n-\002V\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\002v\n-\n-\006B\n-\n-\n-\004i\002z\004i\004i\005>\n-\n-\n-\n-\n-\n-\004i\n-\n-\n-\n-\n-\t\186\n-\001\158\n\018\n-\004i\n-\n-\004i\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\000\238\n-\n-\n-\n-\n-\003\201\004i\004i\004i\002^\003\201\003\201\003\201\003\201\004i\004\206\003\201\003\201\003\201\003\201\000\238\003\201\003\201\004i\003\201\003\201\003\201\005B\003\201\003\201\003\201\003\201\004i\003\201\028\003\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\004i\003\201\000\238\003\201\005\030\003\201\003\201\003\201\003\201\003\201\003\026\006\129\003\201\003\201\003\201\006\137\003\201\004i\003\201\003\201\003\201\004\206\000\238\003\201\003\201\003\201\003\201\003\201\003\201\003\201\002\158\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\005.\t\178\n\n\002\n\003\201\003\201\003\201\002\026\003r\002\170\001\006\0056\003\201\003\201\003\201\003\201\003\201\003\201\002\174\003\201\003\201\003\201\003\201\003\201\t\186\003\201\006\029\n\018\003\201\001*\003\201\003\201\000\238\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\012U\003\201\003\201\003\201\003\201\003\201\003\185\003n\001\142\001\146\006\002\003\185\003\185\003\185\003\185\003F\b\241\003\185\003\185\003\185\003\185\012U\003\185\003\185\011\234\003\185\003\185\003\185\002\162\003\185\003\185\003\185\003\185\007\245\003\185\003\142\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\007N\003\185\016.\003\185\004\014\003\185\003\185\003\185\003\185\003\185\004\206\001\250\003\185\003\185\003\185\003\129\003\185\b\217\003\185\003\185\003\185\004\206\006\029\003\185\003\185\003\185\003\185\003\185\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\004N\t\178\n\n\012\182\003\185\003\185\003\185\001\"\006\154\001\006\007\146\003\146\003\185\003\185\003\185\003\185\003\185\003\185\000\238\003\185\003\185\003\185\003\185\003\185\t\186\003\185\004\213\n\018\003\185\000\238\003\185\003\185\002\214\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\012\186\003\185\003\185\003\185\003\185\003\185\003\181\003\134\b\014\003\150\bf\003\181\003\181\003\181\003\181\012\198\007\198\003\181\003\181\003\181\003\181\b\217\003\181\003\181\000\238\003\181\003\181\003\181\000\238\003\181\003\181\003\181\003\181\b\162\003\181\004\166\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\005~\003\181\016r\003\181\007V\003\181\003\181\003\181\003\181\003\181\006\190\006\214\003\181\003\181\003\181\028C\003\181\012\002\003\181\003\181\003\181\005J\024n\003\181\003\181\003\181\003\181\003\181\003\181\003\181\b\"\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\007\162\t\178\n\n\001\006\003\181\003\181\003\181\001\"\004\250\011\242\001\142\014\238\003\181\003\181\003\181\003\181\003\181\003\181\007\170\003\181\003\181\003\181\003\181\003\181\t\186\003\181\014\254\n\018\003\181\011\250\003\181\003\181\015\206\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\r2\003\181\003\181\003\181\003\181\003\181\t\205\bf\004>\004>\002^\t\205\t\205\t\205\t\205\012\198\020>\t\205\t\205\t\205\t\205\000\238\t\205\t\205\015\214\t\205\t\205\t\205\007\222\t\205\t\205\t\205\t\205\006\005\t\205\004j\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\005~\t\205\b\006\t\205\007V\t\205\t\205\t\205\t\205\t\205\0036\004i\t\205\t\205\t\205\000\238\t\205\021\230\t\205\t\205\t\205\004V\007\238\t\205\t\205\t\205\t\205\t\205\t\205\t\205\tz\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\005&\t\205\t\205\026N\t\205\t\205\t\205\006\222\024\238\0156\000\238\003\169\t\205\t\205\t\205\t\205\t\205\t\205\018j\t\205\t\205\t\205\t\205\t\205\t\205\t\205\020B\t\205\t\205\015B\t\205\t\205\004i\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\000\238\t\221\t\205\t\205\t\205\t\205\t\221\t\221\t\221\t\221\018r\003\146\t\221\t\221\t\221\t\221\004N\t\221\t\221\005\253\t\221\t\221\t\221\004i\t\221\t\221\t\221\t\221\006\014\t\221\004\234\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\006\193\t\221\003\169\t\221\022\226\t\221\t\221\t\221\t\221\t\221\026R\b\245\t\221\t\221\t\221\r>\t\221\021\250\t\221\t\221\t\221\004Z\006\198\t\221\t\221\t\221\t\221\t\221\t\221\t\221\006&\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\214\t\221\t\221\t\222\t\221\t\221\t\221\001V\004>\005\189\000\238\022\234\t\221\t\221\t\221\t\221\t\221\t\221\006b\t\221\t\221\t\221\t\221\t\221\t\221\t\221\006z\t\221\t\221\001Z\t\221\t\221\b\245\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\b\197\t\213\t\221\t\221\t\221\t\221\t\213\t\213\t\213\t\213\005\189\028#\t\213\t\213\t\213\t\213\0071\t\213\t\213\004J\t\213\t\213\t\213\b\245\t\213\t\213\t\213\t\213\014\242\t\213\005\189\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\006\150\t\213\000\238\t\213\004\209\t\213\t\213\t\213\t\213\t\213\nF\007)\t\213\t\213\t\213\007)\t\213\022\014\t\213\t\213\t\213\001\006\007\214\t\213\t\213\t\213\t\213\t\213\t\213\t\213\006\178\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\001f\t\213\t\213\006\158\t\213\t\213\t\213\007\001\006\194\b\197\007\025\006\230\t\213\t\213\t\213\t\213\t\213\t\213\011:\t\213\t\213\t\213\t\213\t\213\t\213\t\213\006\210\t\213\t\213\019\174\t\213\t\213\002^\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\005^\t\193\t\213\t\213\t\213\t\213\t\193\t\193\t\193\t\193\000\238\b\"\t\193\t\193\t\193\t\193\002^\t\193\t\193\012~\t\193\t\193\t\193\023\218\t\193\t\193\t\193\t\193\007\025\t\193\0036\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\nV\t\193\b\166\t\193\t\158\t\193\t\193\t\193\t\193\t\193\012\190\025r\t\193\t\193\t\193\006\145\t\193\022&\t\193\t\193\t\193\0036\004\146\t\193\t\193\t\193\t\193\t\193\t\193\t\193\001\162\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\001f\t\193\t\193\007\018\t\193\t\193\t\193\002*\011:\018J\0266\007*\t\193\t\193\t\193\t\193\t\193\t\193\012\134\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\214\t\193\t\193\t\222\t\193\t\193\002j\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\b\193\t\201\t\193\t\193\t\193\t\193\t\201\t\201\t\201\t\201\t\206\t\246\t\201\t\201\t\201\t\201\t\214\t\201\t\201\t\222\t\201\t\201\t\201\011\158\t\201\t\201\t\201\t\201\000\238\t\201\012~\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\004\129\t\201\000\238\t\201\007b\t\201\t\201\t\201\t\201\t\201\006\"\007\025\t\201\t\201\t\201\007\025\t\201\022:\t\201\t\201\t\201\015\158\011N\t\201\t\201\t\201\t\201\t\201\t\201\t\201\007\242\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\007n\t\201\t\201\012\250\t\201\t\201\t\201\003\149\004\129\b\193\015\218\007\134\t\201\t\201\t\201\t\201\t\201\t\201\002^\t\201\t\201\t\201\t\201\t\201\t\201\t\201\012~\t\201\t\201\012\234\t\201\t\201\002j\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\b\166\t\197\t\201\t\201\t\201\t\201\t\197\t\197\t\197\t\197\002^\006\t\t\197\t\197\t\197\t\197\r\162\t\197\t\197\015\210\t\197\t\197\t\197\003\014\t\197\t\197\t\197\t\197\006\r\t\197\bZ\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\015\254\t\197\016\006\t\197\t\014\t\197\t\197\t\197\t\197\t\197\015\190\t\210\t\197\t\197\t\197\014f\t\197\022N\t\197\t\197\t\197\rV\b)\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\242\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\004>\t\197\t\197\b\221\t\197\t\197\t\197\b%\t\254\018\146\016F\000\238\t\197\t\197\t\197\t\197\t\197\t\197\003\t\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\214\t\197\t\197\t\222\t\197\t\197\015\150\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\000\238\t\209\t\197\t\197\t\197\t\197\t\209\t\209\t\209\t\209\000\238\027\186\t\209\t\209\t\209\t\209\n\014\t\209\t\209\018n\t\209\t\209\t\209\n\030\t\209\t\209\t\209\t\209\012\173\t\209\012v\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\014F\t\209\018v\t\209\016\142\t\209\t\209\t\209\t\209\t\209\b\221\012\146\t\209\t\209\t\209\016N\t\209\022j\t\209\t\209\t\209\019\026\b\025\t\209\t\209\t\209\t\209\t\209\t\209\t\209\019\018\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\021\158\t\209\t\209\003\142\t\209\t\209\t\209\006\001\022Z\012~\012\185\003\142\t\209\t\209\t\209\t\209\t\209\t\209\012\150\t\209\t\209\t\209\t\209\t\209\t\209\t\209\b\029\t\209\t\209\000\238\t\209\t\209\000\238\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\019\186\t\225\t\209\t\209\t\209\t\209\t\225\t\225\t\225\t\225\019\214\020\"\t\225\t\225\t\225\t\225\018\206\t\225\t\225\019J\t\225\t\225\t\225\023v\t\225\t\225\t\225\t\225\024f\t\225\012\194\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\b\"\t\225\025\250\t\225\025\018\t\225\t\225\t\225\t\225\t\225\003\254\023N\t\225\t\225\t\225\t\029\t\225\022~\t\225\t\225\t\225\011:\012\222\t\225\t\225\t\225\t\225\t\225\t\225\t\225\012\226\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\r\n\t\225\t\225\0262\t\225\t\225\t\225\r\030\006^\016N\r^\t\005\t\225\t\225\t\225\t\225\t\225\t\225\rn\t\225\t\225\t\225\t\225\t\225\t\225\t\225\005\t\t\225\t\225\b\162\t\225\t\225\023z\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\r\182\t\217\t\225\t\225\t\225\t\225\t\217\t\217\t\217\t\217\000\238\027\030\t\217\t\217\t\217\t\217\t\t\t\217\t\217\014\002\t\217\t\217\t\217\014\"\t\217\t\217\t\217\t\217\000\238\t\217\014B\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\014\138\t\217\015\006\t\217\025\006\t\217\t\217\t\217\t\217\t\217\026B\015\030\t\217\t\217\t\217\000\238\t\217\022\146\t\217\t\217\t\217\015\166\025\026\t\217\t\217\t\217\t\217\t\217\t\217\t\217\002^\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\015\170\t\217\t\217\015\226\t\217\t\217\t\217\015\230\016\014\016\018\016*\016\162\t\217\t\217\t\217\t\217\t\217\t\217\004\129\t\217\t\217\t\217\t\217\t\217\t\217\t\217\016\210\t\217\t\217\016\214\t\217\t\217\026\202\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\016\250\n\029\t\217\t\217\t\217\t\217\n\029\n\029\n\029\n\029\016\254\017\014\n\029\n\029\n\029\n\029\011\158\n\029\n\029\017\030\n\029\n\029\n\029\017*\n\029\n\029\n\029\n\029\017^\n\029\017b\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\017\178\n\029\017\218\n\029\017\222\n\029\n\029\n\029\n\029\n\029\018\"\018F\n\029\n\029\n\029\018V\n\029\022\158\n\029\n\029\n\029\018~\018\130\n\029\n\029\n\029\n\029\n\029\n\029\n\029\018\142\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\018\158\n\029\n\029\018\182\n\029\n\029\n\029\018\198\018\218\018\242\019\"\019&\n\029\n\029\n\029\n\029\n\029\n\029\0192\n\029\n\029\n\029\n\029\n\029\n\029\n\029\003\173\n\029\n\029\019B\n\029\n\029\019V\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\020J\t\181\n\029\n\029\n\029\n\029\t\181\t\181\t\181\t\181\020V\020\134\t\181\t\181\t\181\t\181\020\170\t\181\t\181\020\210\t\181\t\181\t\181\000\238\t\181\t\181\t\181\t\181\021Z\t\181\021n\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\021v\t\181\021\138\t\181\021\150\t\181\t\181\t\181\t\181\t\181\021\170\021\194\t\181\t\181\t\181\021\206\t\181\003\173\t\181\t\181\t\181\021\226\021\246\t\181\t\181\t\181\t\181\t\181\t\181\t\181\022\n\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\022\"\t\178\n\n\004%\t\181\t\181\t\181\015\250\0226\015\142\022J\022f\t\181\t\181\t\181\t\181\t\181\t\181\007\242\t\181\t\181\t\181\t\181\t\181\t\186\t\181\022z\n\018\t\181\022\142\t\181\t\181\016\002\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\000\238\t\181\t\181\t\181\t\181\t\181\002\t\022\178\b!\022\190\012\165\002\t\001\002\001\006\002\t\027\190\002j\001\"\002\t\t\202\002\t\022\202\001&\002\t\012\165\002\t\002\t\002\t\022\254\002\t\002\t\002\t\001*\004%\t\250\023\014\001.\002\t\002\t\002\t\002\t\002\t\n\002\002\t\t\190\0012\023\030\003z\023*\002\t\002\t\002\t\002\t\002\t\023^\023\134\003\206\002N\002\t\022\182\002\t\022\194\002\t\002\t\003F\023\142\023\150\003\214\002\t\002\t\002\t\b\154\b\158\b\170\023\158\019\226\005n\002\t\002\t\002\t\002\t\002\t\002\t\002\t\002\t\002\t\023\178\t\178\n\n\023\186\002\t\002\t\002\t\023\206\023\254\024*\024B\024Z\005z\002\t\005~\002\t\002\t\002\t\024v\002\t\002\t\002\t\002\t\b\178\021\214\b\182\024~\022\022\002\t\024\174\002\t\002\t\024\206\002\t\002\t\002\t\002\t\002\t\002\t\005\130\b\198\002\t\002\t\002\t\t>\004j\024\234\n\t\002\t\002\t\002\t\002\t\n\t\001\002\001\006\n\t\024\254\025&\001\"\n\t\n\t\n\t\025F\001&\n\t\025z\n\t\n\t\n\t\025\130\n\t\n\t\n\t\001*\025\142\n\t\025\238\001.\n\t\n\t\n\t\n\t\n\t\n\t\n\t\021\162\0012\026\030\003z\026&\n\t\n\t\n\t\n\t\n\t\026b\026z\003\206\002N\n\t\021\186\n\t\021\198\n\t\n\t\003F\026\210\026\230\003\214\n\t\n\t\n\t\b\154\b\158\b\170\027\002\n\t\005n\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\027*\n\t\n\t\0272\n\t\n\t\n\t\027Z\027b\027j\027v\027~\005z\n\t\005~\n\t\n\t\n\t\027\135\n\t\n\t\n\t\n\t\b\178\n\t\b\182\027\151\n\t\n\t\027\170\n\t\n\t\027\198\n\t\n\t\n\t\n\t\n\t\n\t\005\130\b\198\n\t\n\t\n\t\t>\004j\027\227\n\005\n\t\n\t\n\t\n\t\n\005\001\002\001\006\n\005\027\243\028\015\001\"\n\005\n\005\n\005\028c\001&\n\005\028\127\n\005\n\005\n\005\028\138\n\005\n\005\n\005\001*\028\191\n\005\028\211\001.\n\005\n\005\n\005\n\005\n\005\n\005\n\005\021\218\0012\028\219\003z\029\023\n\005\n\005\n\005\n\005\n\005\029\031\000\000\003\206\002N\n\005\021\238\n\005\022\002\n\005\n\005\003F\000\000\000\000\003\214\n\005\n\005\n\005\b\154\b\158\b\170\000\000\n\005\005n\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\000\000\n\005\n\005\000\000\n\005\n\005\n\005\000\000\000\000\000\000\000\000\000\000\005z\n\005\005~\n\005\n\005\n\005\000\000\n\005\n\005\n\005\n\005\b\178\n\005\b\182\000\000\n\005\n\005\000\000\n\005\n\005\000\000\n\005\n\005\n\005\n\005\n\005\n\005\005\130\b\198\n\005\n\005\n\005\t>\004j\000\000\002I\n\005\n\005\n\005\n\005\002I\001\002\001\006\002I\000\000\000\000\001\"\002I\t\202\002I\004i\001&\002I\000\000\002I\002I\002I\000\000\002I\002I\002I\001*\004i\t\250\000\000\001.\002I\002I\002I\002I\002I\n\002\002I\022^\0012\000\000\003z\004\218\002I\002I\002I\002I\002I\000\000\000\000\003\206\002N\002I\022r\002I\022\134\002I\002I\003F\000\238\000\000\003\214\002I\002I\002I\b\154\b\158\b\170\000\238\019\226\005n\002I\002I\002I\002I\002I\002I\002I\002I\002I\000\000\004i\002I\000\000\002I\002I\002I\019\014\004i\000\000\004i\000\000\005z\002I\005~\002I\002I\002I\000\000\002I\002I\002I\002I\b\178\000\000\b\182\004i\000\000\002I\000\000\002I\002I\019\022\002I\002I\002I\002I\002I\002I\005\130\b\198\002I\002I\002I\t>\004j\004i\004i\002I\002I\002I\002I\004i\004i\b\025\004i\004i\004i\004i\004i\004i\004i\004i\000\000\004i\000\238\004i\004i\004i\004i\004i\004i\000\000\004i\004i\004i\004i\004i\004i\004i\004i\004i\000\000\004i\004i\000\238\000\238\004i\004i\000\000\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\006j\004i\004i\004i\004i\004i\004i\004i\004i\000\238\004i\004i\004i\004i\004i\004i\004i\004i\004i\019\162\004i\000\000\004i\004i\004i\004i\004i\004i\000\238\004i\000\n\004i\004i\004i\004i\004i\004i\004i\000\000\004i\004i\004i\000\000\000\238\004i\004i\002\237\002\237\004i\000\238\004i\004i\000\000\004i\004i\000\000\004i\012\182\000\000\000\000\002\237\001\"\000\000\004i\004i\004i\000\000\000\238\004i\004i\004i\004i\000\169\000\169\004i\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\000\000\169\000\000\000\169\000\169\019v\000\169\000\169\000\000\0062\000\169\000\169\005\222\000\169\000\169\000\169\000\169\012\186\000\169\006F\000\169\000\169\000\000\006N\000\169\000\169\018:\000\169\000\169\000\169\007\146\000\169\012\198\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\003\146\018\170\000\169\000\169\000\000\001\006\000\169\000\169\bJ\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\005~\002\237\000\169\000\000\t!\000\169\000\000\000\169\000\000\000\169\000\000\000\000\000\000\b\014\000\169\000\169\000\169\000\169\000\169\000\169\007\017\000\169\000\169\000\169\007\017\tZ\002N\000\169\000\n\r\210\000\169\003\134\000\169\000\238\000\222\000\000\023\002\000\000\000\169\000\000\023\018\023\"\023.\000\000\000\169\000\169\000\169\000\169\bf\002A\000\169\000\169\000\169\000\169\002A\001\002\001\006\002A\002\237\000\000\001\"\002A\000\238\002A\000\000\001&\002A\000\000\002A\002A\002A\000\000\002A\002A\002A\001*\000\000\024\146\000\000\001.\002A\002A\002A\002A\002A\000\000\002A\000\000\0012\000\000\003z\000\000\002A\002A\002A\002A\002A\007\017\000\000\003\206\b\174\002A\000\000\002A\000\000\002A\002A\003F\000\000\000\000\003\214\002A\002A\002A\b\154\b\158\b\170\004\022\014\162\005n\002A\002A\002A\002A\002A\002A\002A\002A\002A\000\000\t\178\n\n\000\000\002A\002A\002A\000\000\000\000\000\000\004!\000\000\005z\002A\005~\002A\002A\002A\000\000\002A\002A\002A\002A\b\178\t\186\b\182\000\000\n\018\002A\000\000\002A\002A\001\006\002A\002A\002A\002A\002A\002A\005\130\b\198\002A\002A\002A\t>\004j\000\000\002U\002A\002A\002A\002A\002U\000\238\025^\002U\000\000\000\000\000\000\002U\000\000\002U\000\000\000\000\002U\000\000\002U\002U\002U\000\000\002U\002U\002U\000\000\000\000\001\186\002N\000\000\002U\002U\002U\002U\002U\bf\002U\000\000\004!\000\000\028o\000\000\002U\002U\002U\002U\002U\000\000\000\000\000\238\000\000\002U\000\000\002U\0062\002U\002U\005\222\007\002\000\000\000\000\002U\002U\002U\006F\012\182\000\000\000\000\006N\001\"\002U\002U\002U\002U\002U\002U\002U\002U\002U\000\000\t\178\n\n\000\000\002U\002U\002U\000\000\r\246\000\000\000\000\000\000\002\237\002U\003\146\002U\002U\002U\000\000\002U\002U\002U\002U\025b\t\186\000\000\000\000\n\018\002U\012\186\002U\002U\007\146\002U\002U\002U\002U\002U\002U\000\n\000\000\002U\002U\002U\012\198\000\000\014\026\002Q\002U\002U\002U\002U\002Q\bR\003\146\002Q\002\237\001\186\002N\002Q\000\000\002Q\0051\000\000\002Q\000\000\002Q\002Q\002Q\002\237\002Q\002Q\002Q\005~\000\000\0051\b\014\000\000\002Q\002Q\002Q\002Q\002Q\000\000\002Q\014&\007\146\000\000\000\000\000\000\002Q\002Q\002Q\002Q\002Q\007\146\000\238\005\182\000\000\002Q\000\000\002Q\r\190\002Q\002Q\000\000\0051\b~\003\246\002Q\002Q\002Q\006n\012\182\004\002\000\000\t\130\001\"\002Q\002Q\002Q\002Q\002Q\002Q\002Q\002Q\002Q\000\000\t\178\n\n\b\014\002Q\002Q\002Q\000\000\000\000\000\000\0051\000\000\b\014\002Q\0051\002Q\002Q\002Q\000\000\002Q\002Q\002Q\002Q\000\238\t\186\000\000\000\000\n\018\002Q\012\186\002Q\002Q\000\238\002Q\002Q\002Q\002Q\002Q\002Q\000\000\000\000\002Q\002Q\002Q\012\198\003B\r\250\002E\002Q\002Q\002Q\002Q\002E\000\000\003\146\002E\000\000\000\000\028S\002E\000\000\002E\000\000\000\000\002E\000\000\002E\002E\002E\000\000\002E\002E\002E\005~\000\000\000\000\000\000\000\000\002E\002E\002E\002E\002E\000\000\002E\014\006\007\146\000\000\000\000\000\000\002E\002E\002E\002E\002E\007\146\000\000\tZ\023j\002E\000\000\002E\r\190\002E\002E\000\000\000\000\025j\023\002\002E\002E\002E\023\018\023\"\023.\000\000\025\166\000\000\002E\002E\002E\002E\002E\002E\002E\002E\002E\000\000\t\178\n\n\b\014\002E\002E\002E\000\000\000\000\000\000\006.\000\000\b\014\002E\000\000\002E\002E\002E\000\000\002E\002E\002E\002E\000\238\t\186\007\146\000\000\n\018\002E\000\000\002E\002E\000\238\002E\002E\002E\002E\002E\002E\000\000\b\025\002E\002E\002E\b\025\000\000\025\178\002M\002E\002E\002E\002E\002M\000\238\000\000\002M\000\000\000\000\000\000\002M\000\000\002M\014F\000\000\002M\000\000\002M\002M\002M\b\014\002M\002M\002M\012\029\012\029\000\000\000\000\012\029\002M\002M\002M\002M\002M\b\025\002M\000\000\t:\000\000\000\000\000\238\002M\002M\002M\002M\002M\000\000\000\000\000\000\b\025\002M\000\000\002M\0062\002M\002M\005\222\006:\000\000\027\018\002M\002M\002M\006F\000\000\012M\000\000\006N\000\238\002M\002M\002M\002M\002M\002M\002M\002M\002M\b\025\000\000\002M\000\000\002M\002M\002M\000\000\012M\000\000\000\000\002\194\025\182\002M\002\198\002M\002M\002M\000\000\002M\002M\002M\002M\012\029\000\238\007\146\000\000\002\210\002M\b\025\002M\002M\000\000\n&\002M\002M\002M\002M\002M\t&\t\230\002M\002M\002M\007\146\b\193\025\190\t)\002M\002M\002M\002M\t)\000\000\001\162\t)\002\222\023\162\001\"\t)\000\000\t)\000\000\000\000\nb\026\242\t)\n\134\t)\b\014\t)\t)\t)\0062\000\000\000\000\005\222\027\022\n\154\n\178\n\186\n\162\n\194\006F\t)\000\000\000\238\006N\b\014\000\238\t)\t)\n\202\n\210\t)\000\000\012\182\027\162\002j\t)\001\"\t)\000\000\n\218\t)\002\226\002\237\000\000\000\238\t)\t)\000\238\012\198\000\000\000\000\000\000\000\000\000\000\t)\t)\nj\n\170\n\226\n\234\n\250\t)\t)\000\000\000\000\t)\000\000\t)\t)\011\002\000\000\b\193\000\n\000\000\000\000\012\186\t)\005~\t)\t)\011\n\b\245\t)\t)\t)\t)\000\000\007\185\007\146\002\237\012\198\t)\000\000\t)\t)\000\000\011*\t)\0112\n\242\t)\t)\002\237\002\237\t)\011\018\t)\000\000\000\000\027\n\002\129\t)\t)\011\026\011\"\002\129\ni\000\000\002\129\005~\007\185\000\000\002\129\000\000\002\129\000\000\000\000\002\129\000\000\002\129\002\129\002\129\b\014\002\129\002\129\002\129\007\185\000\000\000\000\007\185\t\150\002\129\002\129\002\129\002\129\002\129\007\185\002\129\026\130\ni\007\185\000\000\000\238\002\129\002\129\002\129\002\129\002\129\000\000\b\173\000\000\000\000\002\129\000\000\002\129\ni\002\129\002\129\ni\011F\000\000\000\000\002\129\002\129\002\129\ni\000\000\000\000\000\000\ni\000\000\002\129\002\129\nj\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\001&\b\173\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\000\000\000\000\001F\000\000\002\129\000\000\002\129\002\129\b\173\002\129\002\129\002\129\002\129\002\129\002\129\001R\000\000\002\129\002\129\002\129\000\000\000\000\000\000\002i\002\129\002\129\002\129\002\129\002i\000\000\000\000\002i\000\000\000\000\000\000\002i\000\000\002i\000\000\005n\002i\000\000\002i\002i\002i\b\173\002i\002i\002i\004\246\000\000\000\000\b\173\000\000\002i\002i\002i\002i\002i\002^\002i\005z\000\000\000\000\000\000\000\000\002i\002i\002i\002i\002i\000\000\b\169\000\000\000\000\002i\000\000\002i\001*\002i\002i\000\000\000\000\000\000\0236\002i\002i\002i\005\130\000\000\000\000\015\174\000\000\000\000\002i\002i\nj\002i\002i\002i\002i\002i\002i\0036\000\000\002i\016&\002i\002i\002i\003F\000\000\000\000\b\169\000\000\000\000\002i\016>\002i\002i\002i\000\000\002i\002i\002i\002i\000\000\000\000\000\000\000\000\000\000\002i\000\000\002i\002i\b\169\002i\002i\002i\002i\002i\002i\000\000\0079\002i\002i\002i\0079\000\000\000\000\002u\002i\002i\002i\002i\002u\000\238\000\000\002u\000\000\000\000\000\000\002u\000\000\002u\t\178\n\n\nb\000\000\002u\002u\002u\b\169\002u\002u\002u\004\246\000\000\000\000\b\169\000\000\002u\002u\002u\n\162\002u\000\000\002u\t\186\011Z\000\000\n\018\000\000\002u\002u\002u\002u\002u\000\000\000\000\000\000\000\000\002u\000\000\002u\011b\002u\002u\011j\000\000\000\000\000\000\002u\002u\002u\011r\000\000\000\000\000\000\011z\0079\002u\002u\nj\n\170\002u\002u\002u\002u\002u\000\000\000\000\002u\000\000\002u\002u\002u\t\214\000\000\000\000\t\222\000\000\000\000\002u\000\000\002u\002u\002u\000\000\002u\002u\002u\002u\000\000\000\238\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\133\002u\002u\002u\002u\002\133\007\205\000\000\002\133\000\000\007\181\000\000\002\133\000\000\002\133\002^\000\000\002\133\000\000\002\133\002\133\002\133\000\000\002\133\002\133\002\133\007\181\000\000\026\014\005\222\000\000\002\133\002\133\002\133\002\133\002\133\007\181\002\133\000\000\007\205\007\181\000\000\000\000\002\133\002\133\002\133\002\133\002\133\000\000\000\000\000\000\000\000\002\133\000\000\002\133\007\205\002\133\002\133\005\222\0036\000\000\000\000\002\133\002\133\002\133\007\205\000\000\000\000\000\000\007\205\000\000\002\133\002\133\nj\002\133\002\133\002\133\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\004\146\000\000\000\000\002\133\005\r\002\133\002\133\002\133\000\000\002\133\002\133\002\133\002\133\000\000\000\238\000\000\000\000\000\000\002\133\000\000\002\133\002\133\000\000\002\133\002\133\002\133\002\133\002\133\002\133\000\000\000\000\002\133\002\133\002\133\000\000\000\000\000\000\002e\002\133\002\133\002\133\002\133\002e\007\221\000\000\002e\000\000\007\225\000\000\002e\000\000\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\0062\000\000\000\000\005\222\000\000\002e\002e\002e\002e\002e\007\225\002e\000\000\007\221\007\225\000\000\000\000\002e\002e\002e\002e\002e\000\000\000\000\000\000\000\000\002e\000\000\002e\011\142\002e\002e\007\221\000\000\000\000\000\000\002e\002e\002e\007\221\000\000\000\000\000\000\007\221\000\000\002e\002e\nj\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\002e\000\000\000\238\000\000\000\000\000\000\002e\000\000\002e\002e\000\000\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\002e\002e\000\000\000\000\000\000\002q\002e\002e\002e\002e\002q\000\238\000\000\002q\000\000\007\177\000\000\002q\000\000\002q\000\000\000\000\nb\000\000\002q\002q\002q\000\000\002q\002q\002q\007\177\000\000\000\000\005\222\000\000\002q\002q\002q\n\162\002q\007\177\002q\000\000\022\214\007\177\000\000\000\000\002q\002q\002q\002q\002q\000\000\000\000\000\000\000\000\002q\000\000\002q\011b\002q\002q\011j\000\000\000\000\000\000\002q\002q\002q\011r\000\000\000\000\000\000\011z\000\000\002q\002q\nj\n\170\002q\002q\002q\002q\002q\000\000\000\000\002q\000\000\002q\002q\002q\000\000\000\000\000\000\012%\012%\000\000\002q\012%\002q\002q\002q\000\000\002q\002q\002q\002q\000\000\000\000\012!\012!\000\000\002q\012!\002q\002q\000\000\002q\002q\002q\002q\002q\002q\000\000\000\000\002q\002q\002q\000\000\000\000\000\000\002m\002q\002q\002q\002q\002m\002\237\000\238\002m\000\000\015\130\000\000\002m\000\000\002m\000\000\000\000\nb\000\000\002m\002m\002m\000\238\002m\002m\002m\b\r\000\000\000\000\000\000\b\r\002m\002m\002m\n\162\002m\000\n\002m\000\000\000\000\012%\000\000\000\000\002m\002m\002m\002m\002m\000\000\000\000\000\000\000\000\002m\002\237\002m\012!\002m\002m\000\000\000\000\000\000\007\021\002m\002m\002m\007\021\002\237\002\237\000\000\000\000\b\r\002m\002m\nj\n\170\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\b\r\002m\000\000\002m\002m\002m\000\000\002m\002m\002m\002m\000\000\000\000\000\238\000\000\000\000\002m\000\000\002m\002m\000\000\002m\002m\002m\002m\002m\002m\000\000\000\000\002m\002m\002m\000\000\000\000\000\000\002\149\002m\002m\002m\002m\002\149\004\246\001\006\002\149\000\000\000\000\007\021\002\149\000\000\002\149\000\000\000\000\nb\000\000\002\149\002\149\002\149\000\000\002\149\002\149\002\149\b\t\000\000\000\000\000\000\b\t\n\154\n\178\n\186\n\162\n\194\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002\149\002\149\n\202\n\210\002\149\000\000\000\000\n\022\003\134\002\149\000\000\002\149\000\000\n\218\002\149\000\000\000\000\000\000\000\000\002\149\002\149\000\238\021\130\000\000\021\142\000\000\000\000\b\t\002\149\002\149\nj\n\170\n\226\n\234\n\250\002\149\002\149\000\000\000\000\002\149\000\000\002\149\002\149\011\002\000\000\000\000\000\000\000\000\000\000\b\t\002\149\000\000\002\149\002\149\011\n\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\n\242\002\149\002\149\000\000\000\000\002\149\011\018\002\149\000\000\000\000\000\000\002}\002\149\002\149\011\026\011\"\002}\004\246\001\006\002}\000\000\000\000\000\000\002}\000\000\002}\000\000\000\000\nb\000\000\002}\002}\002}\000\000\002}\002}\002}\000\000\000\000\000\000\000\000\000\000\002}\002}\002}\n\162\002}\000\000\002}\000\000\000\000\000\000\000\000\000\000\002}\002}\002}\002}\002}\000\000\000\000\022\026\003\134\002}\000\000\002}\000\000\002}\002}\000\000\000\000\000\000\000\000\002}\002}\002}\022.\000\000\022B\000\000\000\000\000\000\002}\002}\nj\n\170\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\nb\000\000\002y\002y\002y\000\000\002y\002y\002y\000\000\000\000\000\000\000\000\000\000\002y\002y\002y\n\162\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\000\000\002y\002y\nj\n\170\002y\002y\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\002y\002y\002y\000\000\000\000\002y\002y\002y\000\000\000\000\000\000\002\141\002y\002y\002y\002y\002\141\000\000\000\000\002\141\000\000\000\000\000\000\002\141\000\000\002\141\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\002\141\000\000\002\141\000\000\000\000\000\000\000\000\000\000\002\141\002\141\n\202\n\210\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\nj\n\170\n\226\n\234\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\n\242\002\141\002\141\000\000\000\000\002\141\002\141\002\141\000\000\000\000\000\000\002a\002\141\002\141\002\141\002\141\002a\000\000\000\000\002a\000\000\000\000\000\000\002a\000\000\002a\000\000\000\000\nb\000\000\002a\002a\002a\000\000\002a\002a\002a\000\000\000\000\000\000\000\000\000\000\002a\002a\002a\n\162\002a\000\000\002a\000\000\000\000\000\000\000\000\000\000\002a\002a\002a\002a\002a\000\000\000\000\000\000\000\000\002a\000\000\002a\000\000\002a\002a\000\000\000\000\000\000\000\000\002a\002a\002a\000\000\000\000\000\000\000\000\000\000\000\000\002a\002a\nj\n\170\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\000\000\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\002]\002a\002a\002a\002a\002]\000\000\000\000\002]\000\000\000\000\000\000\002]\000\000\002]\000\000\000\000\nb\000\000\002]\002]\002]\000\000\002]\002]\002]\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\002]\000\000\002]\000\000\000\000\000\000\000\000\000\000\002]\002]\n\202\n\210\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]\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002]\002]\nj\n\170\n\226\n\234\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]\n\242\002]\002]\000\000\000\000\002]\002]\002]\000\000\000\000\000\000\002\185\002]\002]\002]\002]\002\185\000\000\000\000\002\185\000\000\000\000\000\000\002\185\000\000\002\185\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\002\185\000\000\002\185\000\000\000\000\000\000\000\000\000\000\002\185\002\185\n\202\n\210\002\185\000\000\000\000\000\000\000\000\002\185\000\000\002\185\000\000\002\185\002\185\000\000\000\000\000\000\000\000\002\185\002\185\002\185\000\000\000\000\000\000\000\000\000\000\000\000\002\185\002\185\nj\n\170\n\226\002\185\002\185\002\185\002\185\000\000\000\000\002\185\000\000\002\185\002\185\002\185\000\000\000\000\000\000\000\000\000\000\000\000\002\185\000\000\002\185\002\185\002\185\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\002\185\002\185\002\185\n\242\002\185\002\185\000\000\000\000\002\185\002\185\002\185\000\000\000\000\000\000\002Y\002\185\002\185\002\185\002\185\002Y\000\000\000\000\002Y\000\000\000\000\000\000\002Y\000\000\002Y\000\000\000\000\nb\000\000\002Y\002Y\002Y\000\000\002Y\002Y\002Y\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\002Y\000\000\002Y\000\000\000\000\000\000\000\000\000\000\002Y\002Y\n\202\n\210\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\nj\n\170\n\226\n\234\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\n\242\002Y\002Y\000\000\000\000\002Y\002Y\002Y\000\000\000\000\000\000\002\145\002Y\002Y\002Y\002Y\002\145\000\000\000\000\002\145\000\000\000\000\000\000\002\145\000\000\002\145\000\000\000\000\nb\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\002\145\000\000\002\145\000\000\000\000\000\000\000\000\000\000\002\145\002\145\n\202\n\210\002\145\000\000\000\000\000\000\000\000\002\145\000\000\002\145\000\000\002\145\002\145\000\000\000\000\000\000\000\000\002\145\002\145\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\145\nj\n\170\n\226\n\234\002\145\002\145\002\145\000\000\000\000\002\145\000\000\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\000\000\002\145\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\002\145\000\000\002\145\002\145\000\000\002\145\002\145\002\145\n\242\002\145\002\145\000\000\000\000\002\145\002\145\002\145\000\000\000\000\000\000\002\137\002\145\002\145\002\145\002\145\002\137\000\000\000\000\002\137\000\000\000\000\000\000\002\137\000\000\002\137\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\002\137\000\000\002\137\000\000\000\000\000\000\000\000\000\000\002\137\002\137\n\202\n\210\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\nj\n\170\n\226\n\234\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\n\242\002\137\002\137\000\000\000\000\002\137\002\137\002\137\000\000\000\000\000\000\002\153\002\137\002\137\002\137\002\137\002\153\000\000\000\000\002\153\000\000\000\000\000\000\002\153\000\000\002\153\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\153\000\000\000\000\000\000\000\000\000\000\002\153\002\153\n\202\n\210\002\153\000\000\000\000\000\000\000\000\002\153\000\000\002\153\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\153\002\153\000\000\000\000\002\153\000\000\002\153\002\153\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\153\000\000\002\153\002\153\011\n\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\n\242\002\153\002\153\000\000\000\000\002\153\011\018\002\153\000\000\000\000\000\000\002\157\002\153\002\153\011\026\011\"\002\157\000\000\000\000\002\157\000\000\000\000\000\000\002\157\000\000\002\157\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\002\157\000\000\002\157\000\000\000\000\000\000\000\000\000\000\002\157\002\157\n\202\n\210\002\157\000\000\000\000\000\000\000\000\002\157\000\000\002\157\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\157\002\157\000\000\000\000\002\157\000\000\002\157\002\157\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\157\000\000\002\157\002\157\011\n\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\n\242\002\157\002\157\000\000\000\000\002\157\002\157\002\157\000\000\000\000\000\000\002\161\002\157\002\157\011\026\011\"\002\161\000\000\000\000\002\161\000\000\000\000\000\000\002\161\000\000\002\161\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\002\161\000\000\002\161\000\000\000\000\000\000\000\000\000\000\002\161\002\161\n\202\n\210\002\161\000\000\000\000\000\000\000\000\002\161\000\000\002\161\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\161\002\161\000\000\000\000\002\161\000\000\002\161\002\161\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\161\000\000\002\161\002\161\011\n\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\002\161\002\161\002\161\n\242\002\161\002\161\000\000\000\000\002\161\002\161\002\161\000\000\000\000\000\000\b\229\002\161\002\161\011\026\011\"\b\229\000\000\000\000\b\229\000\000\000\000\000\000\b\229\000\000\b\229\000\000\000\000\nb\000\000\b\229\b\229\b\229\000\000\b\229\b\229\b\229\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\b\229\000\000\000\000\000\000\000\000\000\000\b\229\b\229\n\202\n\210\b\229\000\000\000\000\000\000\000\000\b\229\000\000\b\229\000\000\n\218\b\229\000\000\000\000\000\000\000\000\b\229\b\229\000\238\000\000\000\000\000\000\000\000\000\000\000\000\b\229\b\229\nj\n\170\n\226\n\234\n\250\b\229\b\229\000\000\000\000\b\229\000\000\b\229\b\229\011\002\000\000\000\000\000\000\000\000\000\000\000\000\b\229\000\000\b\229\b\229\011\n\000\000\b\229\b\229\b\229\b\229\000\000\000\000\000\000\000\000\000\000\b\229\000\000\b\229\b\229\000\000\b\229\b\229\b\229\n\242\b\229\b\229\000\000\000\000\b\229\011\018\b\229\000\000\000\000\000\000\002\165\b\229\b\229\011\026\011\"\002\165\000\000\000\000\002\165\000\000\000\000\000\000\002\165\000\000\002\165\000\000\000\000\nb\000\000\002\165\002\165\002\165\000\000\002\165\002\165\002\165\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\002\165\000\000\000\000\000\000\000\000\000\000\002\165\002\165\n\202\n\210\002\165\000\000\000\000\000\000\000\000\002\165\000\000\002\165\000\000\n\218\002\165\000\000\000\000\000\000\000\000\002\165\002\165\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\165\002\165\nj\n\170\n\226\n\234\n\250\002\165\002\165\000\000\000\000\002\165\000\000\002\165\002\165\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\165\000\000\002\165\002\165\011\n\000\000\002\165\002\165\002\165\002\165\000\000\000\000\000\000\000\000\000\000\002\165\000\000\002\165\002\165\000\000\011*\002\165\0112\n\242\002\165\002\165\000\000\000\000\002\165\011\018\002\165\000\000\000\000\000\000\b\225\002\165\002\165\011\026\011\"\b\225\000\000\000\000\b\225\000\000\000\000\000\000\b\225\000\000\b\225\000\000\000\000\nb\000\000\b\225\b\225\b\225\000\000\b\225\b\225\b\225\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\b\225\000\000\000\000\000\000\000\000\000\000\b\225\b\225\n\202\n\210\b\225\000\000\000\000\000\000\000\000\b\225\000\000\b\225\000\000\n\218\b\225\000\000\000\000\000\000\000\000\b\225\b\225\000\238\000\000\000\000\000\000\000\000\000\000\000\000\b\225\b\225\nj\n\170\n\226\n\234\n\250\b\225\b\225\000\000\000\000\b\225\000\000\b\225\b\225\011\002\000\000\000\000\000\000\000\000\000\000\000\000\b\225\000\000\b\225\b\225\011\n\000\000\b\225\b\225\b\225\b\225\000\000\000\000\000\000\000\000\000\000\b\225\000\000\b\225\b\225\000\000\b\225\b\225\b\225\n\242\b\225\b\225\000\000\000\000\b\225\011\018\b\225\000\000\000\000\000\000\002\209\b\225\b\225\011\026\011\"\002\209\000\000\000\000\002\209\000\000\000\000\000\000\002\209\000\000\002\209\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\209\000\000\000\000\000\000\000\000\000\000\002\209\002\209\n\202\n\210\002\209\000\000\000\000\000\000\000\000\002\209\000\000\002\209\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\209\002\209\000\000\000\000\002\209\000\000\002\209\002\209\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\209\000\000\002\209\002\209\011\n\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\011*\002\209\0112\n\242\002\209\002\209\000\000\000\000\002\209\011\018\002\209\000\000\000\000\000\000\002\225\002\209\002\209\011\026\011\"\002\225\000\000\000\000\002\225\000\000\000\000\000\000\002\225\000\000\002\225\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\225\000\000\000\000\000\000\000\000\000\000\002\225\002\225\n\202\n\210\002\225\000\000\000\000\000\000\000\000\002\225\000\000\002\225\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\225\002\225\000\000\000\000\002\225\000\000\002\225\002\225\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\225\000\000\002\225\002\225\011\n\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\011*\002\225\0112\n\242\002\225\002\225\000\000\000\000\002\225\011\018\002\225\000\000\000\000\000\000\002\217\002\225\002\225\011\026\011\"\002\217\000\000\000\000\002\217\000\000\000\000\000\000\002\217\000\000\002\217\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\217\000\000\000\000\000\000\000\000\000\000\002\217\002\217\n\202\n\210\002\217\000\000\000\000\000\000\000\000\002\217\000\000\002\217\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\217\002\217\000\000\000\000\002\217\000\000\002\217\002\217\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\217\000\000\002\217\002\217\011\n\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\011*\002\217\0112\n\242\002\217\002\217\000\000\000\000\002\217\011\018\002\217\000\000\000\000\000\000\002\197\002\217\002\217\011\026\011\"\002\197\000\000\000\000\002\197\000\000\000\000\000\000\002\197\000\000\002\197\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\197\000\000\000\000\000\000\000\000\000\000\002\197\002\197\n\202\n\210\002\197\000\000\000\000\000\000\000\000\002\197\000\000\002\197\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\197\002\197\000\000\000\000\002\197\000\000\002\197\002\197\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\197\000\000\002\197\002\197\011\n\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\011*\002\197\0112\n\242\002\197\002\197\000\000\000\000\002\197\011\018\002\197\000\000\000\000\000\000\002\205\002\197\002\197\011\026\011\"\002\205\000\000\000\000\002\205\000\000\000\000\000\000\002\205\000\000\002\205\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\205\000\000\000\000\000\000\000\000\000\000\002\205\002\205\n\202\n\210\002\205\000\000\000\000\000\000\000\000\002\205\000\000\002\205\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\205\002\205\000\000\000\000\002\205\000\000\002\205\002\205\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\205\000\000\002\205\002\205\011\n\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\011*\002\205\0112\n\242\002\205\002\205\000\000\000\000\002\205\011\018\002\205\000\000\000\000\000\000\002\201\002\205\002\205\011\026\011\"\002\201\000\000\000\000\002\201\000\000\000\000\000\000\002\201\000\000\002\201\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\201\000\000\000\000\000\000\000\000\000\000\002\201\002\201\n\202\n\210\002\201\000\000\000\000\000\000\000\000\002\201\000\000\002\201\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\201\002\201\000\000\000\000\002\201\000\000\002\201\002\201\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\201\000\000\002\201\002\201\011\n\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\011*\002\201\0112\n\242\002\201\002\201\000\000\000\000\002\201\011\018\002\201\000\000\000\000\000\000\002\213\002\201\002\201\011\026\011\"\002\213\000\000\000\000\002\213\000\000\000\000\000\000\002\213\000\000\002\213\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\213\000\000\000\000\000\000\000\000\000\000\002\213\002\213\n\202\n\210\002\213\000\000\000\000\000\000\000\000\002\213\000\000\002\213\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\213\002\213\000\000\000\000\002\213\000\000\002\213\002\213\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\213\000\000\002\213\002\213\011\n\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\011*\002\213\0112\n\242\002\213\002\213\000\000\000\000\002\213\011\018\002\213\000\000\000\000\000\000\002\229\002\213\002\213\011\026\011\"\002\229\000\000\000\000\002\229\000\000\000\000\000\000\002\229\000\000\002\229\000\000\000\000\nb\000\000\002\229\002\229\002\229\000\000\002\229\002\229\002\229\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\002\229\000\000\000\000\000\000\000\000\000\000\002\229\002\229\n\202\n\210\002\229\000\000\000\000\000\000\000\000\002\229\000\000\002\229\000\000\n\218\002\229\000\000\000\000\000\000\000\000\002\229\002\229\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\229\002\229\nj\n\170\n\226\n\234\n\250\002\229\002\229\000\000\000\000\002\229\000\000\002\229\002\229\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\229\000\000\002\229\002\229\011\n\000\000\002\229\002\229\002\229\002\229\000\000\000\000\000\000\000\000\000\000\002\229\000\000\002\229\002\229\000\000\011*\002\229\0112\n\242\002\229\002\229\000\000\000\000\002\229\011\018\002\229\000\000\000\000\000\000\002\221\002\229\002\229\011\026\011\"\002\221\000\000\000\000\002\221\000\000\000\000\000\000\002\221\000\000\002\221\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\221\000\000\000\000\000\000\000\000\000\000\002\221\002\221\n\202\n\210\002\221\000\000\000\000\000\000\000\000\002\221\000\000\002\221\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\221\002\221\000\000\000\000\002\221\000\000\002\221\002\221\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\221\000\000\002\221\002\221\011\n\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\011*\002\221\0112\n\242\002\221\002\221\000\000\000\000\002\221\011\018\002\221\000\000\000\000\000\000\002\193\002\221\002\221\011\026\011\"\002\193\000\000\000\000\002\193\000\000\000\000\000\000\002\193\000\000\002\193\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\193\000\000\000\000\000\000\000\000\000\000\002\193\002\193\n\202\n\210\002\193\000\000\000\000\000\000\000\000\002\193\000\000\002\193\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\193\002\193\000\000\000\000\002\193\000\000\002\193\002\193\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\193\000\000\002\193\002\193\011\n\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\011*\002\193\0112\n\242\002\193\002\193\000\000\000\000\002\193\011\018\002\193\000\000\000\000\000\000\002\029\002\193\002\193\011\026\011\"\002\029\000\000\000\000\002\029\000\000\000\000\000\000\002\029\000\000\002\029\000\000\000\000\002\029\000\000\002\029\002\029\002\029\000\000\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\000\000\002\029\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\000\000\000\000\000\000\000\000\002\029\000\000\002\029\000\000\002\029\002\029\000\000\000\000\000\000\000\000\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\002\029\002\029\002\029\002\029\000\000\000\000\002\029\000\000\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\000\000\002\029\000\000\002\029\002\029\002\029\000\000\002\029\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\002\029\000\000\002\029\002\029\000\000\002\029\002\029\002\029\002\029\002\029\002\029\000\000\000\000\002\029\002\029\024\026\000\000\000\000\000\000\0025\002\029\002\029\002\029\002\029\0025\000\000\000\000\0025\000\000\000\000\000\000\0025\000\000\0025\000\000\000\000\nb\000\000\0025\0025\0025\000\000\0025\0025\0025\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\0025\000\000\000\000\000\000\000\000\000\000\0025\0025\n\202\n\210\0025\000\000\000\000\000\000\000\000\0025\000\000\0025\000\000\n\218\0025\000\000\000\000\000\000\000\000\0025\0025\000\238\000\000\000\000\000\000\000\000\000\000\000\000\0025\0025\nj\n\170\n\226\n\234\n\250\0025\0025\000\000\000\000\0025\000\000\0025\0025\011\002\000\000\000\000\000\000\000\000\000\000\000\000\0025\000\000\0025\0025\011\n\000\000\0025\0025\0242\0025\000\000\000\000\000\000\000\000\000\000\0025\000\000\0025\0025\000\000\011*\0025\0112\n\242\0025\0025\000\000\000\000\0025\011\018\0025\000\000\000\000\000\000\0021\0025\0025\011\026\011\"\0021\000\000\000\000\0021\000\000\000\000\000\000\0021\000\000\0021\000\000\000\000\nb\000\000\0021\0021\0021\000\000\0021\0021\0021\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\0021\000\000\000\000\000\000\000\000\000\000\0021\0021\n\202\n\210\0021\000\000\000\000\000\000\000\000\0021\000\000\0021\000\000\n\218\0021\000\000\000\000\000\000\000\000\0021\0021\000\238\000\000\000\000\000\000\000\000\000\000\000\000\0021\0021\nj\n\170\n\226\n\234\n\250\0021\0021\000\000\000\000\0021\000\000\0021\0021\011\002\000\000\000\000\000\000\000\000\000\000\000\000\0021\000\000\0021\0021\011\n\000\000\0021\0021\0021\0021\000\000\000\000\000\000\000\000\000\000\0021\000\000\0021\0021\000\000\011*\0021\0112\n\242\0021\0021\000\000\000\000\0021\011\018\0021\000\000\000\000\000\000\002\189\0021\0021\011\026\011\"\002\189\000\000\000\000\002\189\000\000\000\000\000\000\002\189\000\000\002\189\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\189\000\000\000\000\000\000\000\000\000\000\002\189\002\189\n\202\n\210\002\189\000\000\000\000\000\000\000\000\002\189\000\000\002\189\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\189\002\189\000\000\000\000\002\189\000\000\002\189\002\189\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\189\000\000\002\189\002\189\011\n\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\011*\002\189\0112\n\242\002\189\002\189\000\000\000\000\002\189\011\018\002\189\000\000\000\000\000\000\002)\002\189\002\189\011\026\011\"\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)\024\026\000\000\000\000\000\000\001\233\002)\002)\002)\002)\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\001\233\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\024\026\000\000\000\000\000\000\002-\001\233\001\233\001\233\001\233\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-\024\026\000\000\000\000\000\000\027>\002-\002-\002-\002-\001\237\000\000\000\000\001\237\000\000\000\000\000\000\001\237\000\000\001\237\000\000\000\000\001\237\000\000\001\237\001\237\001\237\000\000\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\001\237\001\237\001\237\001\237\001\237\000\000\001\237\000\000\000\000\000\000\000\000\000\000\001\237\001\237\001\237\001\237\001\237\000\000\000\000\000\000\000\000\001\237\000\000\001\237\000\000\001\237\001\237\000\000\000\000\000\000\000\000\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\000\000\001\237\001\237\001\237\001\237\001\237\001\237\001\237\001\237\001\237\000\000\000\000\001\237\000\000\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\000\000\027N\000\000\001\237\001\237\001\237\000\000\001\237\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\001\237\000\000\001\237\001\237\000\000\001\237\001\237\001\237\001\237\001\237\001\237\000\000\000\000\001\237\001\237\001\237\000\000\000\000\000\000\001\241\001\237\001\237\001\237\001\237\001\241\000\000\000\000\001\241\000\000\000\000\000\000\001\241\000\000\001\241\000\000\000\000\001\241\000\000\001\241\001\241\001\241\000\000\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\001\241\000\000\001\241\000\000\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\001\241\000\000\000\000\000\000\000\000\001\241\000\000\001\241\000\000\001\241\001\241\000\000\000\000\000\000\000\000\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\000\000\000\000\001\241\000\000\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\000\000\027F\000\000\001\241\001\241\001\241\000\000\001\241\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\001\241\000\000\001\241\001\241\000\000\001\241\001\241\001\241\001\241\001\241\001\241\000\000\000\000\001\241\001\241\024\026\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\000\006\000\246\000\000\000\000\007\t\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\007\t\001*\000\000\000\000\000\000\003\210\001n\tb\tf\001z\001~\000\000\000\000\000\000\0012\000\000\003z\000\000\025N\000\000\t\134\t\138\007\t\003\182\003\194\003\206\003\218\003\226\t\142\007:\000\000\001\206\007\t\003F\000\000\000\000\003\214\007\t\007\t\000\238\b\154\b\158\b\170\b\186\000\000\005n\007\t\007\t\001\210\001\214\001\218\001\222\001\226\000\000\000\000\b\210\001\230\000\000\000\000\000\000\000\000\001\234\000\000\b\222\b\246\t\022\t*\005z\000\000\005~\000\000\000\000\001\238\000\000\000\000\007\t\000\000\000\000\b\178\001\242\b\182\000\000\000\000\000\000\000\000\000\000\007\t\000\000\000\000\000\000\002.\006\"\000\000\000\000\005\130\b\198\000\000\0022\000\000\022\246\004j\t\162\020R\002:\000\000\002>\002B\000\006\000\246\000\000\000\000\001\189\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\t^\000\000\000\000\000\000\001\189\001*\000\000\000\000\000\000\003\210\001n\tb\tf\001z\001~\000\000\000\000\b\242\0012\000\000\003z\000\000\tj\000\000\t\134\t\138\001\189\003\182\003\194\003\206\003\218\003\226\t\142\007:\007-\001\206\001\189\003F\007-\000\000\003\214\001\189\001\189\000\238\b\154\b\158\b\170\b\186\000\000\005n\001\189\001\189\001\210\001\214\001\218\001\222\001\226\000\000\024\006\b\210\001\230\000\000\000\000\000\000\000\000\001\234\000\000\b\222\b\246\t\022\t*\005z\000\000\005~\000\000\000\000\001\238\000\000\000\238\001\189\000\000\000\000\b\178\001\242\b\182\000\000\002\237\002\237\011\186\000\000\001\189\000\000\000\000\000\000\002.\006^\000\000\000\000\005\130\b\198\000\000\0022\002\237\022\246\004j\t\162\000\000\002:\000\000\002>\002B\000\006\000\246\000\000\000\n\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\0062\000\000\003N\005\222\000\000\000\000\004\149\000\000\003R\001*\006F\011\166\000\000\001.\006N\003V\003Z\002\237\002\237\002\237\003^\000\000\0012\000\000\003z\000\000\011\182\002\237\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\006\234\007:\002\237\000\000\012B\003F\000\000\000\000\003\214\012J\000\n\000\000\b\154\b\158\b\170\b\186\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012R\002\237\b\210\002\237\002\237\014\202\000\000\000\000\000\000\002\237\b\222\b\246\t\022\t*\005z\002\237\005~\012f\012\170\002\237\000\000\004\149\004\149\000\000\000\000\b\178\000\000\b\182\000\000\000\000\000\000\000\n\000\000\000\000\000\000\000\000\000\000\000\000\002\237\r\138\018\014\005\130\b\198\025>\000\000\000\000\t>\004j\t\162\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\002\237\000\000\000\000\001&\000\000\000\000\004\181\000\000\b\253\000\000\b\253\b\253\003R\001*\003b\001\006\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\003^\000\000\0012\000\000\003z\000\000\011\182\000\000\003\174\003\178\001*\003\182\003\194\003\206\003\218\003\226\006\234\007:\000\000\000\000\012B\003F\000\000\018*\003\214\012J\002Z\002^\b\154\b\158\b\170\b\186\000\000\005n\019~\003\134\000\000\000\000\019\130\000\000\000\000\012R\003F\b\210\000\000\028\146\001*\002\134\002r\019\178\000\000\b\222\b\246\t\022\t*\005z\002~\005~\012f\012\170\000\000\000\000\028\179\024:\000\000\000\000\b\178\000\000\b\182\000\000\002\130\003.\000\000\019\194\000\000\000\000\003:\000\000\003F\004\026\004&\018\014\005\130\b\198\b\253\0042\000\000\t>\004j\t\162\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\0046\000\000\000\000\001&\002\237\000\000\028\226\000\000\002\237\000\000\003\254\000\000\003R\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\003^\000\000\0012\000\000\003z\000\000\011\182\000\n\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\006\234\007:\000\000\004j\012B\003F\000\000\002\237\003\214\012J\002Z\002^\b\154\b\158\b\170\b\186\000\000\005n\000\000\000\000\000\000\002\237\002\237\000\000\000\000\012R\000\000\b\210\000\000\028\146\001*\002\134\002r\000\000\000\000\b\222\b\246\t\022\t*\005z\002~\005~\012f\012\170\000\000\000\000\004\189\002\142\000\000\000\000\b\178\002\237\b\182\000\000\002\130\003.\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\018\014\005\130\b\198\023\006\0042\000\000\t>\004j\t\162\000\181\001\002\001\006\000\181\012\129\000\000\001\"\000\000\t\202\000\000\000\000\001&\0046\000\000\000\181\000\000\000\181\000\000\000\181\000\000\000\181\001*\000\000\t\250\005a\001.\000\000\000\000\005a\000\000\000\000\n\002\000\181\000\000\0012\000\000\003z\000\000\000\181\000\000\000\000\000\000\000\181\000\000\000\000\003\206\002N\000\181\012M\000\181\000\000\000\000\000\181\003F\000\000\000\000\003\214\000\181\000\181\000\181\b\154\b\158\b\170\000\000\019\226\005n\000\181\000\181\000\000\012M\000\000\000\000\002\194\000\181\000\000\002\198\000\000\000\181\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\129\012\129\005z\002\210\005~\000\181\000\181\002\218\0129\000\181\000\181\000\000\000\000\b\178\000\000\b\182\005a\000\000\000\000\000\000\000\000\000\181\000\000\012\129\000\000\000\000\012\129\000\181\000\181\005\130\b\198\000\000\002\222\005a\t>\004j\005a\000\181\000\000\000\181\000\205\001\002\001\006\000\205\000\000\000\000\001\"\000\000\t\202\000\000\000\000\001&\000\000\000\000\000\205\000\000\000\205\000\000\000\205\000\000\000\205\001*\000\000\t\250\000\000\001.\000\000\000\000\000\000\000\000\000\000\n\002\000\205\000\000\0012\000\000\003z\000\000\000\205\000\000\000\000\002\226\000\205\000\000\000\000\003\206\002N\000\205\000\000\000\205\000\000\002\237\000\205\003F\000\000\000\000\003\214\000\205\000\205\000\205\b\154\b\158\b\170\000\000\019\226\005n\000\205\000\205\011\174\000\000\000\000\002\237\000\000\000\205\000\000\000\000\000\000\000\205\000\000\000\000\000\n\000\000\000\000\000\000\000\000\000\000\000\000\005z\007\249\005~\000\205\000\205\000\000\002\237\000\205\000\205\002\237\000\000\b\178\000\000\b\182\000\000\000\000\002\237\000\000\000\000\000\205\000\000\002\237\000\000\002\237\000\000\000\205\000\205\005\130\b\198\000\000\002\237\002\237\t>\004j\000\000\000\205\000\014\000\205\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\237\000\000\000\000\000\000\000\000\000\000\000F\000\000\000\000\000\000\000\000\002\237\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\0062\000\000\000\000\005\222\000\000\000\000\000\000\002Z\002^\000\000\006F\000\000\000\000\000z\006N\000\000\000~\000\130\000\000\000\000\000\000\000\000\001f\000\134\000\138\000\142\000\000\001*\002\134\002r\000\000\000\000\000\146\000\150\000\154\000\000\000\158\002~\000\000\000\162\000\166\000\170\000\000\000\000\002\142\000\174\000\178\000\182\000\000\000\000\000\000\002\130\003.\000\186\000\000\000\190\000\194\003:\000\000\003F\004\026\004&\000\000\000\198\000\000\000\202\0042\003\241\001B\001\006\003\241\000\206\000\210\001\"\000\214\006\186\012\141\000\000\001&\000\000\000\000\003\241\000\000\0046\000\000\003\241\000\000\003\241\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\012\141\000\000\006\242\003\241\000\000\000\000\000\000\000\000\000\000\003\241\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\003\241\000\000\003\241\012\190\012\141\003\241\003F\000\000\000\000\003\246\003\241\003\241\ne\003\250\012\141\004\002\000\000\007.\005n\012\141\012\141\000\238\000\000\000\000\000\000\000\000\003\241\003\241\012\141\012\141\005r\000\000\002\237\002\237\000\000\000\000\000\000\000\000\000\000\000\000\005z\002\237\005~\003\241\003\241\0076\000\000\003\241\003\241\000\000\000\000\000\000\002\237\000\000\000\000\000\000\000\000\012\141\000\000\000\000\000\n\ne\t\214\000\000\ne\024\242\003\241\005\130\012\141\000\000\000\000\ne\000\000\004j\000\000\ne\002\237\003\241\001B\001\006\005\254\000\000\000\000\001\"\002\237\000\000\000\000\000\000\001&\001b\002\237\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\000\000\002\237\000\000\001j\001n\001r\001v\001z\001~\000\000\000\000\000\000\002\237\000\000\002\237\000\000\001\130\000\000\001\194\006\030\002\237\000\000\000\000\001^\002N\000\000\001\202\000\000\000\n\001\206\000\000\003F\000\000\001\021\003\246\000\000\000\000\002\237\003\250\000\000\004\002\005b\000\000\005n\002\237\002\237\001\210\001\214\001\218\001\222\001\226\007B\002\237\001\021\001\230\005r\000\000\000\000\002\237\001\234\000\000\000\000\000\000\000\000\000\000\005z\000\000\005~\000\000\005\190\001\238\000\000\000\000\000\000\000\000\001\021\000\000\001\242\001>\000\000\000\000\002\237\000\000\000\000\000\000\001\021\000\000\000\000\002.\006\"\001\021\006\130\005\130\000\000\t\017\0022\000\000\0026\004j\001\021\001\021\002:\000\000\002>\002B\001B\001\006\007\"\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\000\000\001\162\001\021\001j\001n\001r\001v\001z\001~\000\238\000\000\000\000\001\166\001\021\000\000\007j\001\130\000\000\001\194\006\030\001*\000\000\000\000\001^\002N\000\000\001\202\000\000\000\000\001\206\000\000\003F\000\000\004\129\003\246\000\000\000\000\002\154\003\250\000\000\004\002\005b\000\000\005n\007f\002j\001\210\001\214\001\218\001\222\001\226\000\000\003F\004\129\001\230\005r\000\000\000\000\0062\001\234\000\000\005\222\000\000\000\000\000\000\005z\t\017\005~\006F\005\190\001\238\000\000\006N\000\000\000\000\004\129\000\000\001\242\000\000\000\000\000\000\007r\000\000\000\000\000\000\004\129\000\000\000\000\002.\006\"\004\129\011\158\005\130\000\000\015\198\0022\000\000\0026\004j\004\129\004\129\002:\012\129\002>\002B\001B\001\006\t\006\000\000\000\000\001\"\000\000\000\000\000\000\003R\001&\001b\000\000\000\000\000\000\001f\000\000\005e\000\000\000\000\001*\005e\000\000\004\129\001j\001n\001r\001v\001z\001~\000\000\015\242\000\000\000\000\004\129\000\000\000\000\001\130\000\000\001\194\006\030\012B\000\000\000\000\001^\002N\012J\001\202\000\000\000\000\001\206\000\000\003F\000\000\000\000\003\246\016\030\000\000\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\005r\000\000\012\129\012\129\001\234\000\000\000\000\000\000\004\165\000\000\005z\000\000\005~\000\000\005\190\001\238\000\000\000\000\005e\016\130\000\000\000\000\001\242\000\000\000\000\012\129\000\000\000\000\012\129\000\000\000\000\000\000\000\000\002.\006\"\005e\000\000\005\130\005e\000\000\0022\000\000\0026\004j\000\000\000\000\002:\000\000\002>\002B\001B\001\006\023\198\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\000\000\000\000\000\000\001j\001n\001r\001v\001z\001~\000\000\000\000\003r\002\170\001\006\000\000\000\000\001\130\000\000\001\194\006\030\000\000\002\174\000\000\001^\002N\000\000\001\202\bj\000\000\001\206\000\000\003F\001*\000\000\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\005r\003n\000\000\000\000\001\234\000\000\000\000\000\000\000\000\003F\005z\000\000\005~\000\000\005\190\001\238\000\000\000\000\000\000\000\000\000\000\000\000\001\242\000\000\000\000\000\000\002\237\002\237\000\000\000\000\000\000\000\000\000\000\002.\006\"\000\000\000\000\005\130\007N\000\000\0022\000\000\0026\004j\000\000\000\000\002:\002\237\002>\002B\002\237\002\237\000\000\002\237\000\n\002\237\002\237\002\237\002\237\002\237\002\237\000\000\000\000\000\000\000\000\002\237\002\237\000\000\000\000\000\000\002\237\002\237\002\237\000\000\000\000\002\237\000\000\002\237\000\n\002\237\002\237\002\237\002\237\000\n\002\237\000\000\007>\000\000\002\237\000\000\002\237\000\000\024\154\000\000\002\237\002\237\000\000\002\237\002\237\002\237\002\237\002\237\002\237\002\237\000\000\002\237\000\000\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\000\000\002\237\000\000\000\000\000\000\000\000\000\000\000\000\002\237\000\000\000\000\002\237\000\000\002\237\000\000\000\000\000\000\000\000\002\237\002\237\002\237\002\237\002\237\002\237\000\000\002\237\002\237\024\182\000\000\000\000\000\000\002\237\000\000\000\000\002\237\000\000\002\237\000\000\000A\000A\000\000\000\000\004\129\000A\000A\002\237\000A\000A\000A\002\237\002\237\002\237\000\000\000A\000\000\002\237\002\237\002\237\006\185\000\000\000\000\000\000\004\129\000A\000\000\000\000\000\000\000A\000\000\000A\000A\000\000\000\000\000\000\000\000\000\000\000A\000\000\000A\000\000\000\000\000\000\000A\000A\004\129\000A\000A\000A\000A\000A\000A\000A\000\000\000\000\004\129\000A\000\000\000\000\000A\004\129\011\158\000\238\000A\000A\000A\000A\000\000\000A\000\000\004\129\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000A\000A\000A\000A\000\000\000A\000\000\000\000\000\000\000\000\000\000\004\129\000\000\000\000\000A\000\000\000A\000\000\000=\000=\000\000\000\000\004\129\000=\000=\000\000\000=\000=\000=\000\000\000A\000A\000\000\000=\000\000\000A\000A\000A\006\181\000\000\000\000\000\000\000\000\000=\000\000\000\000\000\000\000=\000\000\000=\000=\000\000\000\000\000\000\000\000\000\000\000=\000\000\000=\000\000\000\000\000\000\000=\000=\000\000\000=\000=\000=\000=\000=\000=\000=\000\000\000\000\000\000\000=\000\000\000\000\000=\000\000\000\000\000\000\000=\000=\000=\000=\000\000\000=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000=\000=\000=\000=\000=\000\000\000=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000=\000\000\000=\000\000\011\221\011\221\000\000\000\000\0186\011\221\011\221\000\000\011\221\011\221\011\221\000\000\000=\000=\000\000\011\221\000\000\000=\000=\000=\006\197\000\000\000\000\000\000\003R\011\221\000\000\000\000\000\000\011\221\000\000\011\221\011\221\000\000\000\000\000\000\000\000\000\000\011\221\000\000\011\221\000\000\000\000\000\000\011\221\011\221\018\166\011\221\011\221\011\221\011\221\011\221\011\221\011\221\000\000\000\000\012B\011\221\000\000\000\000\011\221\012J\000\000\000\000\011\221\011\221\011\221\011\221\000\000\011\221\019b\019r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\221\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\221\011\221\011\221\011\221\011\221\000\000\011\221\000\000\000\000\000\000\000\000\000\000\004\173\000\000\000\000\011\221\000\000\011\221\000\000\011\217\011\217\000\000\000\000\020r\011\217\011\217\000\000\011\217\011\217\011\217\000\000\011\221\011\221\000\000\011\217\000\000\011\221\011\221\011\221\006\193\000\000\000\000\000\000\000\000\011\217\000\000\000\000\000\000\011\217\000\000\011\217\011\217\000\000\000\000\000\000\000\000\000\000\011\217\000\000\011\217\000\000\000\000\000\000\011\217\011\217\000\000\011\217\011\217\011\217\011\217\011\217\011\217\011\217\000\000\000\000\000\000\011\217\000\000\000\000\011\217\000\000\000\000\000\000\011\217\011\217\011\217\011\217\000\000\011\217\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\217\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\217\011\217\011\217\011\217\011\217\000\000\011\217\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\217\000\000\011\217\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\217\011\217\001&\000\000\000\000\011\217\011\217\011\217\000\000\023\022\000\000\000\000\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\006\234\007:\000\000\000\000\000\000\003F\000\000\000\000\003\214\000\000\000\000\000\000\b\154\b\158\b\170\b\186\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\210\000\000\000\000\000\000\0051\000\000\0051\0051\b\222\b\246\t\022\t*\005z\0051\005~\000\000\0051\000\000\0051\000\000\0051\0051\0051\b\178\0051\b\182\000\000\000\000\012M\0129\0051\000\000\0051\0051\0051\000\000\0051\0051\0051\005\130\b\198\000\000\0051\0051\t>\004j\t\162\000\000\000\000\012M\0051\000\000\002\194\000\000\000\000\002\198\0051\0051\000\000\000\000\0051\0051\0051\0051\0051\0051\000\000\0051\002\210\000\000\0051\000\000\002\218\0129\000\000\0051\0051\0051\000\000\000\000\000\000\0051\000\000\000\000\0051\0051\000\000\000\000\000\000\000\000\000\000\0051\000\000\000\000\0051\0051\0051\002\222\0051\0051\004a\000\000\000\000\004a\000\000\000\000\000\000\000\000\0051\0051\0051\000\000\0051\0051\004a\000\000\017\006\0051\004a\000\000\004a\000\000\000\000\000\000\0051\000\000\0051\0051\0051\000\000\0032\0051\004a\000\000\000\000\000\000\0051\000\000\004a\000\000\0051\n\129\0051\0051\n\129\n\129\002\226\000\000\000\000\n\129\000\000\n\129\004a\000\000\n\129\000\000\000\000\004a\n\129\n\129\000\000\n\129\n\129\000\000\n\129\000\000\n\129\000\000\000\000\000\000\000\000\n\129\000\000\004a\n\129\000\000\000\000\000\000\000\000\000\000\007\157\000\000\n\129\000\000\n\129\000\000\000\000\000\000\n\129\n\129\004a\004a\000\000\000\000\004a\004a\n\129\007\157\007\157\n\129\007\157\007\157\n\129\n\129\000\000\n\129\000\000\n\129\n\129\000\000\000\000\000\000\000\000\004a\000\000\000\000\000\000\n\129\000\000\000\000\n\129\007\157\000\000\000\000\015\018\000\000\000\000\000\000\000\000\000\000\n\129\000\000\n\129\000\000\000\000\n\129\000\000\n\129\000\000\000\000\000\000\007\157\000\000\000\000\005\158\000\000\000\000\000\000\000\000\000\000\000\000\n\129\n\129\000\000\n\129\n\129\007\157\n\129\000\000\n\129\000\000\n\129\b\233\n\129\000\000\n\129\000\000\b\233\000\000\002^\b\233\000\000\000\000\000\000\007\157\001\029\007\157\000\000\000\000\b\233\000\000\b\233\b\233\b\233\000\000\b\233\b\233\b\233\000\000\000\000\005\214\000\000\000\000\007\157\007\157\001\029\000\000\000\000\007\157\b\233\007\157\006\249\006\249\000\000\007\157\b\233\b\233\000\000\000\000\b\233\000\000\000\000\000\000\0036\b\233\000\000\b\233\001\029\004*\b\233\015\182\006\249\006\249\006\249\b\233\b\233\b\233\001\029\000\000\000\000\000\000\006\249\001\029\b\233\b\233\000\000\000\000\000\000\000\000\000\000\b\233\000\000\001\029\000\000\004\146\006\249\006\249\000\000\b\233\000\000\000\000\006\249\000\000\006\249\006\249\006\249\000\000\b\233\b\233\b\233\006\249\b\233\b\233\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\b\233\000\000\b\233\b\233\006\249\000\000\012\021\b\233\001\029\000\000\000\000\012\021\b\233\002^\012\021\000\000\b\233\000\000\b\233\b\233\000\000\000\000\000\000\004\178\000\000\012\021\012\021\012\021\000\000\012\021\012\021\012\021\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\021\000\000\004\030\000\000\006\249\000\000\012\021\012\021\000\000\000\000\012\021\000\000\000\000\000\000\0036\012\021\001\174\012\021\000\000\r\142\012\021\000\000\000\000\000\000\000\000\012\021\012\021\012\021\000\000\000\000\014\154\000\000\000\000\000\000\012\021\012\021\003R\000\000\000\000\000\000\000\000\012\021\000\000\000\000\000\000\004\146\000\000\000\000\014\158\012\021\000\000\000\000\000\000\000\000\014\198\000\000\000\000\000\000\012\021\012\021\012\021\000\000\012\021\012\021\000\000\000\000\000\000\000\000\012B\000\000\000\000\000\000\000\000\012J\012\021\000\000\012\021\012\021\000\000\000\000\b\237\012\021\000\000\000\000\000\000\b\237\012\021\002^\b\237\015Z\012\021\000\000\012\021\012\021\000\000\000\000\000\000\b\237\000\000\b\237\b\237\b\237\000\000\b\237\b\237\b\237\012f\015n\000\000\000\000\004\137\004\137\000\000\000\000\000\000\000\000\000\000\b\237\000\000\002Z\002^\018\190\000\000\b\237\b\237\000\000\000\000\b\237\000\000\015~\000\000\0036\b\237\000\000\b\237\000\000\000\000\b\237\000\000\001*\002b\002r\b\237\b\237\b\237\000\000\000\000\000\000\000\000\002~\000\000\b\237\b\237\000\000\000\000\000\000\000\000\000\000\b\237\000\000\000\000\000\000\004\146\002\130\003.\000\000\b\237\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\b\237\b\237\b\237\0042\b\237\b\237\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\237\000\000\b\237\b\237\0046\000\000\000\000\b\237\000a\000\000\000a\000a\b\237\000\000\000\000\000\000\b\237\000\000\b\237\b\237\000a\000\000\000a\000a\000\000\000\000\000a\000a\000a\000\000\b\149\000\000\001B\001\006\000\000\000\000\000\000\001\"\000\000\000\000\000a\000\000\001&\000\000\000\000\000\000\000a\000a\000\000\t\021\000a\000\000\001*\000\000\000a\000a\000\000\000a\000\000\001F\000a\000\000\000\000\000\000\000\000\000a\000a\000a\000\000\000\000\000\000\000\000\001R\000\000\000a\000a\001^\002N\000\000\000\000\000\000\000a\000a\000\000\003F\000a\000\000\003\246\000\000\000a\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000a\000a\000a\000\000\000a\000a\000\000\000\000\000\000\000\000\005r\000\000\b\149\000\000\000\000\000\000\000a\000\000\000\000\000a\005z\012\025\005~\000a\005\190\000\000\012\025\000\000\000a\012\025\000\000\000\000\000a\000\000\000a\000\000\000\000\000\000\004\130\000\000\012\025\012\025\012\025\000\000\012\025\012\025\012\025\005\130\000\000\t\021\000\000\b\234\000\000\004j\000\000\000\000\000\000\000\000\012\025\000\000\002Z\002^\019:\000\000\012\025\012\025\000\000\000\000\012\025\000\000\000\000\000\000\000\000\012\025\000\000\012\025\000\000\000\000\012\025\000\000\001*\002b\002r\012\025\012\025\012\025\000\000\000\000\000\000\000\000\002~\000\000\012\025\012\025\000\000\000\000\000\000\000\000\000\000\012\025\000\000\000\000\000\000\012\025\002\130\003.\000\000\012\025\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\012\025\012\025\012\025\0042\012\025\012\025\003)\000\000\000\000\000\000\000\000\003)\012M\0129\003)\000\000\012\025\000\000\012\025\012\025\0046\002Z\002^\012\025\000\000\003)\003)\003)\012\025\003)\003)\003)\012\025\012M\012\025\012\025\002\194\000\000\000\000\002\198\000\000\001*\002\134\003)\000\000\000\000\002\206\000\000\000\000\003)\004z\000\000\002\210\003)\000\000\000\000\002\218\0129\003)\000\000\003)\000\000\000\000\003)\000\000\002\130\0036\000\000\003)\003)\003)\003:\000\000\003F\004\026\004&\000\000\003)\003)\000\000\0042\002\222\012\210\000\000\003)\000\000\000\000\000\000\003)\000\000\000\000\n\141\003)\000\000\001B\001\006\000\000\0046\000\000\001\"\000\000\003)\003)\003)\001&\003)\003)\000\000\n\141\n\141\000\000\n\141\n\141\000\000\001*\000\000\000\000\003)\000\000\003)\003)\001F\000\000\000\000\003)\000\000\000\000\000\000\000\000\003)\002\226\000\000\n\141\003)\001R\003)\003)\000\000\001^\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\n\141\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\141\000\000\000\000\005r\000\000\000\000\n\137\000\000\000\000\001B\001\006\000\000\000\000\005z\001\"\005~\000\000\005\190\n\141\001&\n\141\000\000\000\000\n\137\n\137\000\000\n\137\n\137\000\000\001*\000\000\000\000\000\000\000\000\n\141\000\000\001F\n\141\n\141\000\000\005\130\000\000\n\141\000\000\n\141\000\000\004j\n\137\n\141\001R\000\000\000\000\000\000\005\250\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\n\137\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\137\000\000\000\000\005r\000\000\000\000\001\213\000\000\000\000\000\000\000\000\001\213\000\000\005z\001\213\005~\000\000\005\190\n\137\000\000\n\137\000\000\000\000\000\000\000\000\001\213\001\213\001\213\000\000\001\213\001\213\001\213\000\000\000\000\n\137\000\000\000\000\n\137\n\137\000\000\005\130\000\000\n\137\001\213\n\137\000\000\004j\000\000\n\137\001\213\001\213\000\000\000\000\001\213\000\000\000\000\000\000\000\000\001\213\000\000\001\213\000\000\000\000\001\213\000\000\000\000\000\000\000\000\001\213\001\213\001\213\000\000\000\000\000\000\000\000\000\000\000\000\001\213\001\213\000\000\001i\000\000\000\000\001i\001\213\000\000\000\000\000\000\001\213\000\000\000\000\000\000\001\213\000\000\001i\000\000\001i\000\000\001i\000\000\001i\001\213\001\213\001\213\000\000\001\213\001\213\000\000\000\000\000\000\000\000\000\000\001i\000\000\000\000\000\000\000\000\001\213\001i\001\213\001\213\001B\001\006\000\000\001\213\000\000\001\"\000\000\006\186\001\213\000\000\001&\001i\004\246\000\000\001\213\000\000\001i\001i\000\238\000\000\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\000\000\000\000\006\242\000\000\001i\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\000\000\000\000\000\000\001i\001i\001i\003F\001i\001i\003\246\000\000\000\000\ne\003\250\000\000\004\002\000\000\007.\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001i\004-\000\000\000\000\005r\000\000\000\000\000\000\000\000\000\000\000\000\001i\000\000\000\000\005z\000\000\005~\000\000\000\000\0076\000\000\005\169\000\000\000\000\000\000\000\000\005\169\000\000\000\000\005\169\000\000\000\000\000\000\000\000\000\000\ne\000\000\000\000\ne\ne\005\169\005\130\005\169\000\000\005\169\ne\005\169\004j\000\000\ne\004-\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\169\000\000\000\000\000\000\000\000\000\000\005\169\005\169\000\000\000\000\000\000\000\000\000\000\005\169\000\000\005\169\000\000\005\169\000\000\000\000\005\169\000\000\000\000\000\000\000\000\005\169\005\169\005\169\000\000\000\000\000\000\000\000\003u\000\000\000\000\000\000\000\000\003u\000\000\000\000\003u\005\169\005\169\000\000\000\000\005\169\000\000\000\000\000\000\000\000\000\000\003u\000\000\003u\000\000\003u\000\000\003u\005\169\005\169\005\169\000\000\005\169\005\169\000\000\000\000\003u\000\000\000\000\003u\b\"\003u\000\000\000\000\003u\003u\003u\005\169\000\000\000\000\005\169\005\169\0059\000\000\003u\003u\003u\003u\000\000\003u\000\000\003u\005\169\000\000\003u\003u\003u\000\000\000\000\000\000\000\000\000\000\000\000\003u\000\000\000\000\000\000\000\000\000\000\003u\003u\000\000\000\000\000\000\003u\000\000\005=\000\000\003u\000\000\003u\000\000\000\000\003u\000\000\000\000\000\000\003u\003u\003u\003u\003u\003u\000\000\000\000\005\157\000\000\000\000\000\000\0059\005\157\000\000\000\000\005\157\003u\000\000\003u\003u\003u\000\000\003u\000\000\000\000\000\000\005\157\000\000\005\157\000\000\005\157\000\000\005\157\003u\003u\003u\000\000\003u\003u\000\000\000\000\000\000\000\000\000\000\005\157\005=\000\000\000\000\000\000\000\000\005\157\005\157\003u\003u\000\000\000\000\003u\bf\000\000\005\157\000\000\005\157\000\000\000\000\005\157\000\000\000\000\003u\000\000\005\157\005\157\000\238\000\000\000\000\000\000\bu\000\000\000\000\000\000\000\000\bu\000\000\000\000\bu\000\000\005\157\005\157\000\000\000\000\005\157\000\000\000\000\000\000\000\000\bu\000\000\bu\000\000\bu\000\000\bu\000\000\005\157\005\157\005\157\000\000\005\157\005\157\000\000\000\000\000\000\000\000\bu\000\000\000\000\000\000\000\000\000\000\bu\bu\000\000\005\157\000\000\000\000\005\157\005\157\000\000\bu\000\000\bu\000\000\000\000\bu\000\000\000\000\000\000\005\157\bu\bu\bu\000\000\000\000\000\000\000\000\012\205\000\000\000\000\000\000\000\000\012\205\000\000\000\000\012\205\bu\000\000\000\000\000\000\bu\000\000\000\000\000\000\000\000\000\000\012\205\000\000\012\205\000\000\012\205\000\000\012\205\bu\bu\bu\000\000\bu\bu\000\000\000\000\000\000\000\000\000\000\012\205\000\000\000\000\000\000\000\000\bu\012\205\012\205\bu\000\000\000\000\000\000\bu\004>\000\000\012\205\000\000\012\205\000\000\000\000\012\205\004\246\000\000\bu\000\000\012\205\012\205\012\205\000\000\000\000\000\000\000\000\012\209\000\000\000\000\000\000\000\000\012\209\000\000\000\000\012\209\012\205\000\000\000\000\000\000\012\205\000\000\000\000\000\000\000\000\000\000\012\209\000\000\012\209\000\000\012\209\000\000\012\209\012\205\012\205\012\205\000\000\012\205\012\205\000\000\000\000\000\000\000\000\000\000\012\209\004J\000\000\000\000\000\000\000\000\012\209\012\209\012\205\000\000\000\000\000\000\012\205\004>\000\000\012\209\000\000\012\209\000\000\000\000\012\209\000\000\000\000\012\205\000\000\012\209\012\209\012\209\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\197\000\000\002^\001\197\000\000\012\209\000\000\000\000\000\000\012\209\000\000\000\000\b\213\000\000\001\197\000\000\000\000\000\000\001\197\000\000\001\197\000\000\012\209\012\209\012\209\000\000\012\209\012\209\000\000\000\000\000\000\000\000\001\197\000\000\004J\000\000\000\000\000\000\001\197\001\197\000\000\012\209\000\000\000\000\000\000\012\209\0036\001\197\000\000\001\197\000\000\000\000\001\197\000\000\000\000\000\000\012\209\001\197\001\197\001\197\000\000\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\001\197\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\000\000\000\003Y\000\000\002^\003Y\000\000\000\000\001\197\001\197\000\000\000\000\001\197\001\197\b\209\000\000\003Y\000\000\000\000\000\000\003Y\000\000\003Y\000\000\001\197\000\000\000\000\000\000\000\000\000\000\000\000\001\197\000\000\000\000\003Y\000\000\001\197\000\000\000\000\000\000\003Y\001\193\001\197\000\000\000\000\000\000\000\000\000\000\0036\003Y\000\000\003Y\000\000\000\000\003Y\000\000\000\000\000\000\000\000\003Y\003Y\003Y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Y\003Y\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\000\000\000\003U\000\000\002^\003U\000\000\000\000\003Y\003Y\000\000\000\000\003Y\003Y\b\209\000\000\003U\000\000\000\000\000\000\003U\000\000\003U\000\000\003Y\000\000\000\000\000\000\000\000\000\000\000\000\003Y\000\000\000\000\003U\000\000\003Y\000\000\000\000\000\000\003U\001\193\003Y\000\000\000\000\000\000\000\000\000\000\0036\003U\000\000\003U\000\189\000\000\003U\000\189\000\000\000\000\000\000\003U\003U\003U\000\000\000\000\000\000\000\000\000\189\000\000\000\189\000\000\000\189\000\000\000\189\000\000\000\000\003U\003U\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\189\000\000\000\000\000\000\000\000\000\000\000\189\000\000\003U\003U\000\189\000\000\003U\003U\000\000\000\189\000\000\000\189\000\000\000\000\000\189\000\000\000\000\000\000\003U\000\189\000\189\000\238\000\000\000\000\000\000\003U\000\000\000\000\000\189\000\189\003U\001\001\000\000\000\000\001\001\000\189\003U\000\000\000\000\000\189\000\000\000\000\000\000\000\000\000\000\001\001\000\000\001\001\000\000\001\001\000\000\001\001\000\189\000\189\000\000\000\000\000\189\000\189\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\189\001\001\000\000\000\000\000\000\001\001\000\189\000\189\000\000\000\000\001\001\000\000\001\001\000\000\000\000\001\001\000\189\000\000\000\189\000\000\001\001\001\001\000\238\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\000\000\000\197\000\000\000\000\000\197\001\001\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\000\000\197\000\000\000\197\000\000\000\197\000\000\000\197\001\001\001\001\000\000\000\000\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\197\000\000\000\000\000\000\000\000\001\001\000\197\000\000\000\000\000\000\000\197\001\001\001\001\000\000\000\000\000\197\000\000\000\197\000\000\000\000\000\197\001\001\000\000\001\001\000\000\000\197\000\197\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\197\000\197\000\000\000\193\000\000\000\000\000\193\000\197\000\000\000\000\000\000\000\197\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\193\000\000\000\193\000\000\000\193\000\197\000\197\000\000\000\000\000\197\000\197\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\000\000\197\000\193\000\000\000\000\000\000\000\193\000\197\000\197\000\000\000\000\000\193\000\000\000\193\000\000\000\000\000\193\000\197\000\000\000\197\000\000\000\193\000\193\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\193\000\193\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\000\nb\000\000\000\000\021\178\b\249\000\000\b\249\b\249\000\193\000\193\000\000\000\000\000\193\000\193\n\154\n\178\n\186\n\162\n\194\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\000\000\000\n\202\n\210\000\193\000\193\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\218\000\193\000\000\000\193\000\000\000\000\000\000\000\000\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\nj\n\170\n\226\n\234\n\250\001b\000\000\000\000\000\000\001f\000\000\000\000\024N\011\002\000\000\000\000\000\000\000\000\001j\001n\001r\001\190\001z\001~\011\n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\194\001\198\000\000\000\000\000\000\000\000\000\000\011*\001\202\0112\n\242\001\206\000\000\000\000\000\000\b\249\011\018\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\026\011\"\000\000\000\000\001\210\001\214\001\218\001\222\001\226\000\000\000\000\001\161\001\230\000\000\001\161\000\000\000\000\001\234\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\161\000\000\000\000\001\238\001\161\000\000\001\161\000\000\000\000\000\000\001\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\161\001\161\000\000\002.\027\166\000\000\001\161\000\000\012M\0129\0022\000\000\0026\0059\000\000\001\161\002:\001\161\002>\002B\001\161\000\000\000\000\000\000\000\000\001\161\001\161\001\161\000\000\012M\000\000\000\000\002\194\000\000\000\000\002\198\000\000\000\000\000\000\000\000\000\000\001\161\r\154\000\000\000\000\001\161\012\201\000\000\002\210\000\000\000\000\012\201\002\218\0129\012\201\000\000\000\000\000\000\001\161\001\161\000\000\000\000\001\161\001\161\000\000\012\201\000\000\012\201\000\000\012\201\0059\012\201\000\000\000\000\001\161\000\000\000\000\002\222\000\000\000\000\001\161\001\161\000\000\012\201\000\000\000\000\001\161\000\000\000\000\012\201\012\201\000\000\001\161\000\000\000\000\000\000\000\000\000\000\012\201\000\000\012\201\000\000\000\000\012\201\000\000\000\000\000\000\000\000\012\201\012\201\012\201\000\000\000\000\000\000\012\197\000\000\000\000\000\000\000\000\012\197\000\000\000\000\012\197\000\000\012\201\000\000\002\226\000\000\012\201\000\000\000\000\000\000\000\000\012\197\000\000\012\197\000\000\012\197\000\000\012\197\000\000\012\201\012\201\012\201\000\000\012\201\012\201\000\000\000\000\000\000\000\000\012\197\000\000\000\000\000\000\000\000\000\000\012\197\012\197\000\000\012\201\000\000\000\000\000\000\012\201\000\000\012\197\000\000\012\197\000\000\000\000\012\197\000\000\004\246\000\000\012\201\012\197\012\197\012\197\000\000\000\000\000\000\000\000\by\000\000\000\000\000\000\000\000\by\000\000\000\000\by\012\197\000\000\000\000\000\000\012\197\000\000\000\000\000\000\000\000\000\000\by\000\000\by\000\000\by\000\000\by\012\197\012\197\012\197\000\000\012\197\012\197\000\000\000\000\000\000\000\000\000\000\by\000\000\000\000\000\000\000\000\007\190\by\by\012\197\000\000\000\000\000\000\012\197\000\000\000\000\by\000\000\by\000\000\000\000\by\000\000\000\000\012\197\000\000\by\by\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\193\000\000\002^\001\193\by\000\000\000\000\000\000\by\000\000\012)\000\000\b\209\012)\001\193\000\000\000\000\000\000\001\193\000\000\001\193\by\by\by\012)\by\by\000\000\012)\000\000\012)\000\000\001\193\000\000\000\000\000\000\0051\by\001\193\000\000\by\000\000\012)\000\000\by\000\000\0036\001\193\012)\001\193\000\000\000\000\001\193\000\000\000\000\by\000\000\001\193\001\193\001\193\000\000\000\000\012)\000\000\000\000\000\000\000\000\012)\012)\000\000\000\000\000\000\000\000\001\193\001\193\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\000\012)\000\000\000\000\000\000\000\000\000\000\000\000\001\193\001\193\000\000\000\000\001\193\001\193\000\000\000\000\000\000\000\000\012)\012)\003\030\000\000\012)\012)\001\193\001\174\002Z\002^\r\142\000\000\000\000\001\193\000\000\000\000\012)\000\000\001\193\000\000\r\166\014\154\000\000\012)\001\193\004\137\000\000\003R\001*\002\134\002r\000\000\000\000\000\000\012)\000\000\000\000\000\000\002~\014\158\000\000\000\000\000\000\000\000\000\000\014\198\000\000\000\000\000\000\005\209\000\000\000\000\002\130\003.\005\209\000\000\000\000\005\209\003:\012B\003F\004\026\004&\000\000\012J\000\000\000\000\0042\005\209\000\000\005\209\000\000\005\209\000\000\005\209\000\000\000\000\000\000\000\000\000\000\015Z\000\000\000\000\000\000\0046\000\000\005\209\000\000\000\000\000\000\000\000\000\000\005\209\005\209\000\000\000\000\000\000\012f\015n\bf\000\000\005\209\000\000\005\209\000\000\000\000\005\209\000\000\000\000\000\000\000\000\005\209\005\209\000\238\000\000\000\000\000\000\000\000\000\000\000\000\015~\000\000\000\000\001b\000\000\000\000\000\000\005\209\000\000\000\000\000\000\005\209\000\000\000\000\000\000\000\000\001j\001n\001r\001\190\001z\001~\000\000\000\000\005\209\005\209\005\209\000\000\005\209\005\209\000\000\001\194\001\198\000\000\000\000\000\000\000\000\000\000\000\000\001\202\000\000\000\000\001\206\005\209\000\000\000\000\000\000\005\209\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\209\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\000\000\000\000\000\000\000\000\001\234\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\238\000\000\000\000\000\000\000\000\000\000\000\000\001\242\000\000\000\000\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\002.\027\194\001&\000\000\000\000\000\000\000\000\0022\000\000\0026\000\000\000\000\001*\002:\006\218\002>\002B\000\000\000\000\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\000\000\003\250\007\146\004\002\000\000\007.\005n\005\205\000\000\000\000\005\205\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005r\000\000\000\000\005\205\000\000\005\205\000\000\005\205\000\000\005\205\005z\000\000\005~\000\000\000\000\0076\000\000\000\000\000\000\000\000\000\000\005\205\000\000\000\000\000\000\000\000\000\000\005\205\b\014\000\000\000\000\000\000\t\214\000\000\000\000\t\222\005\205\005\130\005\205\000\000\000\000\005\205\000\000\004j\000\000\000\000\005\205\005\205\000\238\000\000\000\000\000\000\012\213\000\000\000\000\000\000\000\000\012\213\000\000\000\000\012\213\000\000\005\205\000\000\000\000\000\000\005\205\000\000\000\000\000\000\000\000\012\213\000\000\012\213\000\000\012\213\000\000\012\213\000\000\005\205\005\205\005\205\000\000\005\205\005\205\000\000\000\000\000\000\000\000\012\213\000\000\000\000\000\000\000\000\000\000\012\213\012\213\000\000\005\205\000\000\000\000\000\000\005\205\000\000\012\213\000\000\012\213\000\000\000\000\012\213\000\000\000\000\000\000\005\205\012\213\012\213\000\238\000\000\000\000\000\000\012\217\000\000\000\000\000\000\000\000\012\217\000\000\000\000\012\217\000\000\012\213\000\000\000\000\000\000\012\213\000\000\000\000\000\000\000\000\012\217\000\000\012\217\000\000\012\217\000\000\012\217\000\000\012\213\012\213\012\213\000\000\012\213\012\213\000\000\000\000\000\000\000\000\012\217\000\000\000\000\000\000\000\000\000\000\012\217\b\014\000\000\012\213\000\000\000\000\000\000\012\213\000\000\012\217\000\000\012\217\000\000\000\000\012\217\000\000\000\000\000\000\012\213\012\217\012\217\000\238\000\000\000\000\000\000\007\146\000\000\000\000\000\000\000\000\005\229\000\000\000\000\005\229\000\000\012\217\000\000\000\000\000\000\012\217\000\000\000\000\000\000\000\000\005\229\000\000\005\229\000\000\005\229\000\000\005\229\000\000\012\217\012\217\012\217\000\000\012\217\012\217\000\000\000\000\000\000\000\000\005\229\000\000\000\000\000\000\000\000\000\000\005\229\b\014\000\000\012\217\000\000\000\000\000\000\012\217\000\000\005\229\000\000\005\229\000\000\000\000\005\229\000\000\000\000\000\000\012\217\005\229\005\229\000\238\000\000\000\000\000\000\005\233\000\000\000\000\000\000\000\000\005\233\000\000\000\000\005\233\000\000\005\229\000\000\000\000\000\000\005\229\000\000\000\000\000\000\000\000\005\233\000\000\005\233\000\000\005\233\000\000\005\233\000\000\005\229\005\229\005\229\000\000\005\229\005\229\000\000\000\000\000\000\000\000\005\233\000\000\000\000\000\000\000\000\000\000\005\233\005\233\000\000\005\229\000\000\000\000\000\000\005\229\000\000\005\233\000\000\005\233\000\000\000\000\005\233\000\000\000\000\000\000\005\229\005\233\005\233\005\233\000\000\000\000\000\000\005\225\000\000\000\000\000\000\000\000\005\225\000\000\000\000\005\225\000\000\005\233\000\000\000\000\000\000\005\233\000\000\000\000\000\000\000\000\005\225\000\000\005\225\000\000\005\225\000\000\005\225\000\000\005\233\005\233\005\233\000\000\005\233\005\233\000\000\000\000\000\000\000\000\005\225\000\000\000\000\000\000\000\000\000\000\005\225\b\014\000\000\005\233\000\000\000\000\000\000\005\233\000\000\005\225\000\000\005\225\000\000\000\000\005\225\000\000\000\000\000\000\b6\005\225\005\225\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Q\000\000\002^\003Q\000\000\005\225\000\000\000\000\000\000\005\225\000\000\000\000\000\000\000\000\003Q\000\000\002Z\002^\003Q\000\000\003Q\000\000\005\225\005\225\005\225\000\000\005\225\005\225\000\000\000\000\000\000\000\000\003Q\000\000\000\000\000\000\001*\002\134\003Q\000\000\000\000\005\225\000\000\000\000\000\000\005\225\0036\003Q\000\000\003Q\000\000\000\000\003Q\000\000\000\000\000\000\005\225\003Q\003Q\003Q\002\130\003>\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\003Q\003Q\0042\000\000\004\146\000\000\003M\000\000\002^\003M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Q\003Q\0046\003M\003Q\003Q\026\022\003M\000\000\003M\000\000\000\000\000\000\000\000\000\000\000\000\003Q\000\000\000\000\000\000\000\000\003M\000\000\003Q\000\000\000\000\026\002\003M\003Q\000\000\000\000\000\000\000\000\000\000\003Q\0036\003M\000\000\003M\000\000\000\000\003M\000\000\000\000\000\000\000\000\003M\003M\003M\000\000\000\000\000\000\000\000\000\000\001\205\000\000\012\182\001\205\000\000\000\000\001\"\000\000\003M\003M\000\000\000\000\004\146\000\000\001\205\000\000\000\000\000\000\001\205\000\000\001\205\000\000\002Z\002^\000\000\003M\003M\000\000\000\000\003M\003M\000\000\001\205\000\000\000\000\000\000\000\000\000\000\001\205\000\000\000\000\003M\001*\002\134\000\000\012\186\000\000\001\205\003M\001\205\000\000\000\000\001\205\003M\000\000\000\000\000\000\001\205\001\205\003M\012\198\000\000\000\000\000\000\000\000\000\000\002\130\003>\000\000\000\000\000\000\000\000\003:\001\205\003F\004\026\004&\001\205\000\000\000\000\000\000\0042\000\000\001Q\000\000\000\000\001Q\000\000\000\000\005~\001\205\001\205\000\000\000\000\001\205\001\205\000\000\001Q\0046\001Q\000\000\001Q\005\001\001Q\000\000\000\000\001\205\000\000\000\000\000\000\000\000\000\000\000\000\001\205\000\000\001Q\000\000\000\000\000\000\000\000\000\000\001Q\026\002\000\000\001\205\001Q\000\000\000\000\000\000\000\000\001Q\000\000\001Q\000\000\000\000\001Q\000\000\000\000\000\000\000\000\001Q\001Q\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001Q\000\000\001M\000\000\000\000\001M\001Q\000\000\000\000\000\000\001Q\000\000\000\000\000\000\000\000\000\000\001M\000\000\001M\000\000\001M\000\000\001M\001Q\001Q\001Q\000\000\001Q\001Q\000\000\000\000\000\000\000\000\000\000\001M\000\000\000\000\000\000\000\000\001Q\001M\000\000\000\000\000\000\001M\000\000\001Q\000\000\000\000\001M\000\000\001M\000\000\000\000\001M\000\000\000\000\001Q\000\000\001M\001M\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\000\000\nb\000\000\000\000\007\029\001M\000\000\000\000\007\029\001M\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\000\000\001M\001M\001M\000\000\001M\001M\000\000\n\202\n\210\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\000\000\n\218\000\000\000\000\000\000\000\000\001M\000\000\000\000\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\nj\n\170\n\226\n\234\n\250\nb\000\000\000\000\000\000\025\154\000\000\007\029\000\000\011\002\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\011\n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\202\n\210\000\000\001\002\001\006\000\000\000\000\011*\001\"\0112\n\242\n\218\000\000\001&\000\000\000\000\011\018\000\000\006u\000\238\000\000\000\000\000\000\001*\011\026\011\"\000\000\001.\nj\n\170\n\226\n\234\n\250\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\011\002\000\000\000\000\000\000\000\000\000\000\003\206\002N\000\000\000\000\000\000\011\n\000\000\000\000\003F\000\000\000\000\003\214\000\000\000\000\000\000\b\154\b\158\b\170\000\000\000\000\005n\011*\025\158\0112\n\242\025\170\000\000\001B\001\006\000\000\011\018\000\000\001\"\000\000\006\186\000\000\000\000\001&\011\026\011\"\000\000\000\000\005z\000\000\005~\000\000\000\000\001*\000\000\006\218\000\000\000\000\000\000\b\178\001F\b\182\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\018\000\000\001R\000\000\005\130\b\198\023\194\002N\007\146\t>\004j\000\000\000\000\004\129\003F\000\000\004\129\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007.\005n\004\129\000\000\000\000\000\000\004\129\000\000\004\129\000\000\000\000\000\000\000\000\005r\000\000\000\000\000\000\000\000\000\000\000\000\004\129\000\000\000\000\005z\000\000\005~\004\129\b\014\000\000\000\000\004\129\000\000\000\000\bf\000\000\004\129\000\000\004\129\000\000\000\000\004\129\000\000\000\000\000\000\000\000\004\129\011\158\000\238\023\210\000\000\005\130\000\000\000\000\000\000\004\129\004\129\004j\b\005\000\000\000\000\b\005\004\129\004\129\000\000\000\000\004\129\000\000\000\000\000\000\000\000\000\000\b\005\000\000\000\000\000\000\b\005\000\000\b\005\004\129\004\129\000\000\000\000\004\129\004\129\000\000\000\000\000\000\000\000\000\000\b\005\b\"\000\000\000\000\000\000\004\129\b\005\000\000\000\000\000\000\b\005\000\000\004\129\000\000\000\000\b\005\000\000\b\005\000\000\b\001\b\005\000\000\b\001\004\129\000\000\b\005\b\005\000\238\000\000\000\000\000\000\000\000\000\000\b\001\b\005\b\005\000\000\b\001\000\000\b\001\000\000\b\005\000\000\000\000\000\000\b\005\000\000\000\000\000\000\000\000\000\000\b\001\000\000\000\000\000\000\000\000\000\000\b\001\b\005\b\005\b\005\b\001\b\005\b\005\000\000\000\000\b\001\000\000\b\001\003E\000\000\b\001\003E\000\000\b\005\000\000\b\001\b\001\000\238\000\000\000\000\b\005\000\000\003E\000\000\b\001\b\001\003E\000\000\003E\000\000\000\000\b\001\000\000\000\000\000\000\b\001\000\000\000\000\000\000\000\000\003E\012\206\000\000\000\000\000\000\000\000\003E\000\000\b\001\b\001\b\001\000\000\b\001\b\001\000\000\003E\000\000\003E\000\000\000\000\003E\000\000\000\000\000\000\b\001\003E\003E\003E\000\000\000\000\000\000\b\001\001}\000\000\0121\001}\000\000\000\000\000\000\000\000\000\000\003E\000\000\000\000\0121\003E\001}\000\000\001}\000\000\001}\000\000\001}\000\000\000\000\000\000\000\000\000\000\003E\003E\026\138\000\000\003E\003E\001}\000\000\000\000\000\000\000\000\000\000\001}\0121\000\000\000\000\003E\000\000\000\000\000\000\0121\000\000\rN\003E\000\000\000\000\001}\000\000\003E\000\000\000\000\001}\001}\001}\003E\000\000\000\000\000\000\001A\000\000\000\165\001A\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\165\0121\001A\000\000\001A\000\000\001A\000\000\001A\000\000\000\000\000\000\000\000\000\000\001}\001}\001}\000\000\001}\001}\001A\000\000\000\000\000\000\000\000\000\000\001A\000\165\000\000\000\000\000\000\000\000\000\000\000\000\000\165\000\000\000\000\001}\000\000\000\000\001A\000\000\000\000\000\000\000\000\001A\001A\001A\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\001A\000\000\000\000\000\000\000\165\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\000\000\000\000\001&\000\000\001A\001A\001A\006y\001A\001A\000\000\000\000\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\001A\000\000\000\000\019\206\000\000\001R\000\000\000\000\000\000\001^\002N\001A\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005b\007.\005n\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\000\000\000\000\001&\005r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\005z\006\218\005~\000\000\005\190\018&\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\020\162\000\000\005\130\000\000\006\170\000\000\003F\000\000\004j\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007.\005n\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\000\000\000\000\001&\005r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\005z\006\218\005~\000\000\000\000\0076\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\018\186\000\000\005\130\000\000\000\000\000\000\003F\000\000\004j\003\246\000\000\001\002\001\006\003\250\000\000\004\002\001\"\007.\005n\000\000\000\000\001&\000\000\000\000\000\000\000\000\006\157\000\000\000\000\000\000\005r\001*\000\000\000\000\000\000\001.\000\000\000\000\000\000\000\000\005z\000\000\005~\000\000\0012\0076\003z\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\206\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\0196\003\214\005\130\000\000\000\000\b\154\b\158\b\170\004j\000\000\005n\004i\004i\000\000\000\000\000\000\004i\000\000\000\000\000\000\000\000\004i\000\000\000\000\000\000\000\000\000\000\004i\000\000\000\000\000\000\004i\005z\000\000\005~\000\000\000\000\000\000\004i\019\134\000\000\000\000\019\158\b\178\000\000\b\182\000\000\000\000\000\000\000\000\000\000\004i\000\000\000\000\000\000\004i\004i\000\000\000\000\005\130\b\198\000\000\000\000\004i\t>\004j\004i\000\000\003E\000\238\004i\003E\004i\004i\000\000\004i\000\000\000\000\000\000\000\000\000\000\000\000\003E\000\000\000\000\000\000\003E\004i\003E\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004i\000\000\004i\003E\012\206\000\000\000\000\000\000\000\000\003E\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003E\000\000\003E\012)\000\000\003E\012)\000\000\000\000\004i\003E\003E\003E\000\000\000\000\004i\000\000\012)\000\000\000\000\000\000\012)\000\000\012)\000\000\000\000\003E\000\000\000\000\0051\003E\000\000\000\000\000\000\000\000\012)\000\000\000\000\000\000\000\000\000\000\012)\000\000\003E\003E\026\186\000\000\003E\003E\000\000\012)\000\000\012)\000\000\000\000\012)\000\000\000\000\000\000\000\000\012)\012)\001B\001\006\000\000\rN\003E\001\"\000\000\000\000\000\000\003E\001&\000\000\000\000\000\000\012)\005\186\000\000\003\254\012)\000\000\001*\000\000\000\000\000\000\000\000\000\000\000\000\001F\000\000\000\000\000\000\012)\012)\003\030\000\000\012)\012)\000\000\000\000\000\000\001R\000\000\000\000\000\000\001^\002N\000\000\012)\000\000\000\000\000\000\014j\003F\000\000\012)\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005b\000\000\005n\012)\000\000\000\000\000\000\000\000\000\000\000\000\001B\001\006\000\000\000\000\005r\001\"\000\000\006\186\000\000\000\000\001&\000\000\000\000\000\000\005z\000\000\005~\000\000\005\190\000\000\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006^\000\000\001R\005\130\000\000\000\000\t\002\002N\000\000\004j\000\000\000\000\000\000\005\133\003F\000\000\005\133\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007.\005n\005\133\000\000\000\000\000\000\005\133\000\000\005\133\000\000\000\000\000\000\000\000\005r\000\000\000\000\000\000\000\000\000\000\000\000\005\133\000\000\000\000\005z\000\000\005~\005\133\000\000\000\000\000\000\000\000\000\000\000\000\bf\000\000\005\133\000\000\005\133\000\000\000\000\005\133\000\000\000\000\000\000\000\000\005\133\005\133\000\238\000\000\000\000\005\130\000\000\000\000\000\000\000\000\000\000\004j\005\137\000\000\000\000\005\137\005\133\005\133\000\000\000\000\005\133\000\000\000\000\000\000\000\000\000\000\005\137\000\000\000\000\000\000\005\137\000\000\005\137\005\133\005\133\000\000\000\000\005\133\005\133\000\000\000\000\000\000\000\000\000\000\005\137\000\000\000\000\000\000\000\000\000\000\005\137\000\000\000\000\000\000\000\000\000\000\005\133\bf\000\000\005\137\000\000\005\137\003E\000\000\005\137\003E\000\000\005\133\000\000\005\137\005\137\000\238\000\000\000\000\000\000\000\000\003E\000\000\000\000\000\000\003E\000\000\003E\000\000\000\000\005\137\005\137\000\000\000\000\005\137\000\000\000\000\000\000\000\000\003E\012\206\000\000\000\000\000\000\000\000\003E\000\000\005\137\005\137\000\000\000\000\005\137\005\137\000\000\003E\000\000\003E\006-\000\000\003E\006-\000\000\000\000\000\000\003E\003E\003E\000\000\000\000\000\000\005\137\006-\000\000\000\000\000\000\006-\000\000\006-\000\000\000\000\003E\005\137\000\000\000\000\003E\000\000\000\000\000\000\000\000\006-\000\000\000\000\000\000\000\000\000\000\006-\000\000\003E\003E\r.\000\000\003E\003E\000\000\006-\000\000\006-\000\000\000\000\006-\000\000\000\000\000\000\000\000\006-\006-\000\238\000\000\000\000\rN\003E\000\000\011\233\000\000\001\006\011\233\000\000\000\000\028\154\000\000\006-\000\000\000\000\028\158\006-\000\000\011\233\000\000\000\000\000\000\000\000\000\000\011\233\000\000\000\000\000\000\000\000\006-\006-\r\242\000\000\006-\006-\000\000\011\233\000\000\000\000\000\000\000\000\000\000\011\233\000\000\000\000\006-\000\000\000\000\000\000\001\186\002N\011\233\006-\011\233\001\174\000\000\011\233\002\182\000\000\000\000\000\000\011\233\000\000\006-\000\000\000\000\000\000\000\000\003N\028\162\001B\001\006\004\149\000\000\003R\001\"\000\000\011\233\000\000\000\000\001&\011\233\000\000\000\000\000\000\000\000\003^\006r\000\000\000\000\001*\000\000\011\182\028\166\011\233\011\233\000\000\001F\011\233\000\000\000\000\003\226\000\000\020\238\000\000\000\000\012B\000\000\000\000\000\000\001R\012J\000\000\000\000\001^\002N\000\000\011\233\007\146\000\000\000\000\000\000\003F\007%\000\000\003\246\007%\012R\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\007%\000\000\000\000\000\000\007%\000\000\007%\012f\012\170\005r\000\000\004\149\004\149\000\000\000\000\000\000\000\000\000\000\007%\005z\000\000\005~\000\000\005\190\007%\b\014\000\000\000\000\000\000\000\000\018\014\000\000\000\000\007%\000\000\007%\001\209\000\000\007%\001\209\000\000\000\000\000\000\007%\007%\000\238\005\130\000\000\000\000\000\000\001\209\000\000\004j\000\000\001\209\000\000\001\209\000\000\000\000\007%\000\000\000\000\000\000\007%\000\000\000\000\000\000\000\000\001\209\000\000\000\000\000\000\000\000\000\000\001\209\000\000\007%\007%\000\000\000\000\007%\007%\000\000\001\209\000\000\001\209\0061\000\000\001\209\0061\000\000\000\000\000\000\001\209\001\209\000\000\000\000\000\000\000\000\007%\0061\000\000\000\000\000\000\0061\000\000\0061\000\000\000\000\001\209\000\000\000\000\000\000\001\209\000\000\000\000\000\000\000\000\0061\000\000\000\000\000\000\000\000\000\000\0061\000\000\001\209\001\209\000\000\000\000\001\209\001\209\000\000\0061\000\000\0061\000\000\000\000\0061\000\000\000\000\000\000\001\209\0061\0061\000\238\000\000\000\000\000\000\001\209\000\000\000\000\000\000\000\000\r\210\000\000\000\000\000\000\000\000\0061\001\209\000\000\000\000\0061\000\000\000\000\000\000\000\000\b5\b5\000\000\000\000\000\000\b5\000\000\000\000\0061\0061\b5\000\000\0061\0061\000\000\000\000\003\238\000\000\000\000\000\000\b5\000\000\000\000\000\000\0061\000\000\000\000\b5\000\000\000\000\000\000\0061\000\000\004\129\000\000\000\000\004\129\000\000\000\000\000\000\b5\000\000\0061\000\000\b5\b5\000\000\004\129\000\000\000\000\000\000\004\129\b5\004\129\004\129\b5\000\000\000\000\000\000\b5\000\000\b5\b5\000\000\b5\004\129\000\000\000\000\000\000\004\129\000\000\004\129\000\000\000\000\000\000\000\000\b5\000\000\004>\000\000\004\129\000\000\004\129\004\129\000\000\004\129\b5\000\000\b5\004\129\004\129\011\158\000\000\000\000\000\000\000\000\000\000\000\000\004\129\000\000\004\129\000\000\000\245\004\129\000\000\000\245\004\129\000\000\004\129\011\158\004\129\000\000\000\000\b5\000\000\000\000\000\245\000\000\000\000\b5\000\245\000\000\000\245\004\129\004\129\000\000\000\000\004\129\004\129\000\000\000\000\000\000\000\000\000\000\000\245\004J\000\000\000\000\000\000\007\190\000\245\004\129\004\129\000\000\000\000\004\129\004\129\000\000\000\000\000\245\000\000\000\245\000\249\000\000\000\245\000\249\000\000\004\129\000\000\000\245\000\245\000\238\000\000\000\000\004\129\000\000\000\249\000\000\000\000\026\130\000\249\000\000\000\249\000\000\000\000\000\245\000\000\000\000\000\000\000\245\000\000\000\000\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\000\000\249\000\000\000\245\000\245\000\000\000\000\000\245\000\245\000\000\000\249\000\000\000\249\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\249\000\249\000\238\000\000\000\000\000\000\000\245\000\000\000\000\002Z\003\"\000\000\000\000\000\000\001\"\000\000\000\249\000\245\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\002\134\002r\003&\000\249\000\249\000\000\000\000\000\249\000\249\002~\000\000\000\000\000\000\000\000\000\000\000\000\007!\000\000\000\000\007!\000\000\000\000\000\000\003*\003.\000\000\000\249\000\000\000\000\003:\007!\003F\004\026\004&\007!\000\000\007!\000\249\r\170\000\000\r\174\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007!\000\000\000\000\000\000\000\000\000\000\007!\0046\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007!\000\000\007!\006%\005~\007!\006%\000\000\000\000\000\000\007!\007!\000\000\000\000\012\150\000\000\r\186\006%\000\000\000\000\000\000\006%\000\000\006%\000\000\000\000\007!\000\000\000\000\000\000\007!\000\000\000\000\r\190\000\000\006%\000\000\000\000\000\000\000\000\000\000\006%\000\000\007!\007!\011\202\000\000\007!\007!\000\000\006%\000\000\006%\011\149\000\000\006%\011\149\000\000\000\000\000\000\006%\006%\000\000\014\218\000\000\000\000\007!\011\149\000\000\000\000\000\000\011\149\000\000\011\149\000\000\000\000\006%\000\000\000\000\000\000\006%\000\000\000\000\000\000\000\000\011\149\000\000\000\000\000\000\000\000\000\000\011\149\000\000\006%\006%\000\000\000\000\006%\006%\000\000\011\149\000\000\011\149\000\000\000\000\011\149\000\000\000\000\000\000\000\000\011\149\000\000\000\000\000\000\000\000\000\000\006%\000\000\011\153\000\000\000\000\011\153\000\000\000\000\000\000\000\000\011\149\nF\000\000\000\000\011\149\000\000\011\153\000\000\000\000\000\000\011\153\000\000\011\153\000\000\000\000\000\000\000\000\011\149\011\149\000\000\000\000\011\149\011\149\000\000\011\153\000\000\000\000\000\000\000\000\000\000\011\153\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\153\011\149\011\153\000\000\000\000\011\153\000\000\000\000\000\000\000\000\011\153\000\000\011:\000\000\000\000\002Z\003\"\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\011\153\nV\000\000\000\000\011\153\000\000\000\000\000\000\000\000\001*\002\134\002r\000\000\000\000\000\000\000\000\000\000\011\153\011\153\002~\000\000\011\153\011\153\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003*\003.\004Y\000\000\000\000\004Y\003:\011\153\003F\004\026\004&\000\000\000\000\000\000\000\000\r\170\004Y\026Z\011:\000\000\004Y\000\000\004Y\007\146\000\000\000\000\000\000\000\000\005\145\000\000\000\000\005\145\0046\000\000\004Y\000\000\000\000\000\000\000\000\000\000\004Y\000\000\005\145\000\000\005~\000\000\005\145\000\000\005\145\004Y\000\000\004Y\000\000\000\000\004Y\000\000\026f\000\000\000\000\004Y\005\145\000\000\000\000\000\000\000\000\000\000\005\145\b\014\000\000\000\000\000\000\000\000\000\000\r\190\000\000\004Y\000\000\000\000\000\000\004Y\005\145\000\000\000\000\000\000\000\000\005\145\005\145\000\238\000\000\000\000\000\000\000\000\004Y\004Y\000\000\000\000\004Y\004Y\000\000\000\000\000\000\005\145\000\000\000\000\000\000\000\000\000\000\004Q\000\000\000\000\004Q\000\000\000\000\000\000\004q\004Y\000\000\004q\005\145\005\145\000\000\004Q\005\145\005\145\000\000\004Q\012\018\004Q\004q\000\000\000\000\000\000\004q\000\000\004q\000\000\000\000\000\000\000\000\004Q\000\000\005\145\000\000\000\000\000\000\004Q\004q\000\000\000\000\000\000\000\000\000\000\004q\000\000\004Q\000\000\004Q\000\000\000\000\004Q\000\000\004q\000\000\004q\004Q\000\000\004q\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\000\000\000\000\000\000\004Q\000\000\000\000\004q\000\000\000\000\000\000\004q\004A\000\000\000\000\004A\000\000\004Q\004Q\000\000\000\000\004Q\004Q\000\000\004q\004q\004A\000\000\004q\004q\004A\000\000\004A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004Q\000\000\000\000\000\000\004A\000\000\000\000\004q\000\000\000\000\004A\016\194\000\000\000\000\000\000\000\000\000\000\000\000\017\166\004A\000\000\004A\000\000\000\000\004A\000\000\000\000\000\000\000\000\004A\002Z\002^\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\129\000\000\000\000\004\129\004A\000\000\003\254\000\000\004A\001*\002\134\002r\000\000\000\000\004\129\000\000\000\000\000\000\004\129\002~\004\129\004A\004A\000\000\000\000\004A\004A\000\000\000\000\000\000\000\000\000\000\004\129\002\130\003.\000\000\000\000\000\000\004\129\003:\000\000\003F\004\026\004&\004A\000\000\000\000\000\000\0042\000\000\011\249\000\000\004\129\011\249\000\000\020\194\000\000\004\129\011\158\007\169\000\000\000\000\000\000\000\000\011\249\0046\000\000\000\000\000\000\000\000\011\249\000\000\000\000\004\129\000\000\000\000\007\169\007\169\000\000\007\169\007\169\000\000\011\249\000\000\000\000\000\000\000\000\000\000\011\249\000\000\004\129\004\129\000\000\000\000\004\129\004\129\000\000\011\249\000\000\011\249\007\169\000\000\011\249\000\000\007\141\000\000\004f\011\249\004j\000\000\000\000\000\000\000\000\004\129\000\000\000\000\000\000\000\000\r\210\000\000\000\238\007\141\007\141\011\249\007\141\007\141\000\000\011\249\000\000\007\173\000\000\000\000\000\000\000\000\000\000\007\169\000\000\000\000\000\000\000\000\011\249\011\249\000\000\000\000\011\249\007\141\007\173\007\173\000\000\007\173\007\173\000\000\028\138\007\169\000\000\007\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\249\000\000\007\141\000\000\000\000\007\161\007\169\007\173\000\000\005\222\007\169\000\000\000\000\000\000\007\169\000\000\007\169\007\141\004I\000\000\007\169\004I\007\161\007\161\000\000\007\161\007\161\000\238\000\000\000\000\000\000\000\000\004I\000\000\000\000\007\141\004I\007\141\004I\000\000\000\000\000\000\007\173\000\000\000\000\000\000\007\161\000\000\000\000\000\000\004I\007\141\002Z\002^\005\222\007\141\004I\000\000\000\000\007\141\007\173\007\141\007\173\000\000\000\000\007\141\000\238\000\000\000\000\000\000\004I\000\000\001*\002\134\002r\004I\007\173\000\000\000\000\005\222\007\173\007\161\002~\000\000\007\173\015\174\007\173\000\000\000\000\000\000\007\173\004I\000\000\000\000\000\000\000\000\002\130\017\002\000\000\007\161\016&\007\161\003:\000\000\003F\004\026\004&\000\000\004I\004I\000\000\017\018\004I\004I\000\000\0062\000\000\000\000\005\222\007\161\000\000\004y\000\000\007\161\004y\007\161\000\000\000\000\0046\007\161\001\174\004I\000\000\002\182\000\000\004y\000\000\000\000\000\000\004y\000\000\004y\017N\000\000\028\226\000\000\002Z\002^\000\000\000\000\003R\000\000\000\000\004y\000\000\000\000\000\000\000\000\000\000\004y\000\000\000\000\003^\000\000\000\000\000\000\001*\002\134\011\182\000\000\000\000\000\000\000\000\004y\000\000\000\000\000\000\003\226\004y\020\238\000\000\000\000\012B\000\000\000\000\000\000\000\000\012J\006\245\006\245\002\130\003>\000\000\000\000\004y\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\012R\000\000\0042\000\000\028\146\006\245\006\245\006\245\004y\004y\000\000\000\000\004y\004y\000\000\006\245\000\000\012f\012\170\0046\000\000\004\189\000\000\005\005\000\000\012\221\012\221\000\000\000\000\006\245\006\245\004y\000\000\000\000\000\000\006\245\000\000\006\245\006\245\006\245\018\014\000\000\017\206\026\002\006\245\012\221\012\221\012\221\007\166\000\000\000\000\000\000\000\000\001\174\000\000\012\221\r\142\000\000\000\000\000\000\000\000\006\245\000\000\000\000\000\000\000\000\000\000\014\154\000\000\012\221\012\221\004\137\000\000\003R\000\000\012\221\000\000\012\221\012\221\012\221\001\174\000\000\000\000\002\182\012\221\014\158\002Z\002^\024\246\000\000\000\000\014\198\000\000\000\000\004\181\000\000\000\000\000\000\000\000\000\000\003R\012\221\000\000\000\000\000\000\012B\001*\002b\002r\004\222\012J\000\000\003^\000\000\000\000\000\000\002~\000\000\011\182\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015Z\003\226\000\000\020\238\002\130\003.\012B\000\000\000\000\000\000\003:\012J\003F\004\026\004&\000\000\000\000\012f\015n\0042\000\000\004\137\004\137\000\000\000\000\000\000\000\000\012R\002Z\002^\000\000\000\000\000\000\000\000\000\000\000\000\0046\000\000\000\000\000\000\015~\000\000\000\000\000\000\012f\012\170\000\000\000\000\001*\002b\000\000\000\000\000\000\000\000\000\000\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\014\000\000\000\000\000\000\000\000\002\130\0036\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\000\000\000\000\0042\000\000\012\210\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0046")) and lhs = - (8, "\014\r\012\011\n\t\b\007\006\005\004\003\002\001\000\225\225\224\224\223\222\222\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\220\220\219\218\218\218\218\218\218\218\218\217\217\217\217\217\217\217\217\216\216\216\215\215\214\213\213\213\212\212\211\211\211\211\211\211\210\210\210\210\210\210\210\209\209\209\209\209\208\208\208\208\207\206\205\205\205\205\204\204\204\204\203\203\203\202\202\202\202\201\200\200\200\199\199\198\198\197\197\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\195\195\194\194\193\192\191\190\190\189\189\188\188\188\188\187\187\187\187\186\186\185\184\184\184\184\184\184\183\182\181\181\180\180\179\179\178\177\177\176\175\175\174\173\172\172\172\171\171\170\169\169\169\169\169\169\168\168\168\168\168\168\168\168\167\167\166\166\166\166\166\166\165\165\164\164\164\163\163\162\162\162\162\161\161\160\160\159\159\158\158\157\157\156\156\155\155\154\154\153\153\152\152\151\151\151\150\150\150\150\149\149\148\148\147\147\146\146\146\146\146\145\145\145\145\144\143\143\142\142\142\141\141\141\141\141\141\141\140\140\140\140\140\140\140\139\139\138\138\137\137\137\137\137\137\136\136\135\135\134\134\133\133\132\132\131\130\130\130\129\129\128\128\128\128\128\128\128\128\128\127\127~}}}}}}}}}|{zyyxxxxxwvvuuttttttttttttttssrrqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqppoonnmmllkkjjiihhggffeeeeeedcba`_^]\\[ZYYYYYYYXXWWVVVVVUUUUUUTTSSSSSRRQQPONNMMMMMLLKKJJJIIIIIIHHHGGFFEEDDCCBBBAA@@??>>==<<;;::99887776665554443333210000000000000000000/////....---------------------------------------------,,++++++++++++++++***************************************************))(((''&&&&&&&&&&&&&&&&&%%$$#######\"\"\"\"!! \031\031\030\029\028\028\028\027\027\026\026\026\026\026\026\026\026\026\026\025\025\024\023\023\022\021\021\021\021\021\020\019\019\018\018\018\017\017\017\016\016\016\016\016\016\015\015") + (8, "\014\r\012\011\n\t\b\007\006\005\004\003\002\001\000\225\225\224\224\223\222\222\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\220\220\219\218\218\218\218\218\218\218\218\217\217\217\217\217\217\217\217\216\216\216\215\215\214\213\213\213\212\212\211\211\211\211\211\211\210\210\210\210\210\210\210\209\209\209\209\209\208\208\208\208\207\206\205\205\205\205\204\204\204\204\203\203\203\202\202\202\202\201\200\200\200\199\199\198\198\197\197\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\195\195\194\194\193\192\191\190\190\189\189\188\188\188\188\187\187\187\187\186\186\185\184\184\184\184\184\184\183\182\181\181\180\180\179\179\178\177\177\176\175\175\174\173\172\172\172\171\171\170\169\169\169\169\169\169\168\168\168\168\168\168\168\168\167\167\166\166\166\166\166\166\165\165\164\164\164\163\163\162\162\162\162\161\161\160\160\159\159\158\158\157\157\156\156\155\155\154\154\153\153\152\152\151\151\151\150\150\150\150\149\149\148\148\147\147\146\146\146\146\146\145\145\145\145\144\143\143\142\142\142\141\141\141\141\141\141\141\140\140\140\140\140\140\140\139\139\138\138\137\137\137\137\137\137\136\136\135\135\134\134\133\133\132\132\131\130\130\130\129\129\128\128\128\128\128\128\128\128\128\127\127~}}}}}}}}}}|{zyyxxxxxwvvuuttttttttttttttssrrqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqppoonnmmllkkjjiihhggffeeeeeedcba`_^]\\[ZYYYYYYYXXWWVVVVVUUUUUUTTSSSSSRRQQPONNMMMMMLLKKJJJIIIIIIHHHGGFFEEDDCCBBBAA@@??>>==<<;;::99887776665554443333210000000000000000000/////....---------------------------------------------,,++++++++++++++++***************************************************))(((''&&&&&&&&&&&&&&&&&%%$$#######\"\"\"\"!! \031\031\030\029\028\028\028\027\027\026\026\026\026\026\026\026\026\026\026\025\025\024\023\023\022\021\021\021\021\021\020\019\019\018\018\018\017\017\017\016\016\016\016\016\016\015\015") and goto = - ((16, "\000)\001Q\000S\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\000\000\000\000\000_\000<\000\026\000\251\0001\t\152\000\000\000\000\000\233\000-\t\248\000\181\001\204\nj\000\000\000\000\000\000E\006\000=\003\012\000\025:>\000\000\000\000\000\000\000\000\000\000\000\000\000\00072\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\003<\000\210\000\000\000\000\000\000\000\000\000\221\000\000\004\1581\226\000d\004\178\000@\001H\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\244\000\000\000\000\000\000\000\000\000\000\001@\000\000\000\000\000\000\001\146\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\018\000\000\000\000\002>\000\000\000\000\000\000\000\000\000\000\000\000\000\000/\022\002B\000\000\002V\004\180\001H\000\000\000\000\005t\000k\000\000\005\168\0060\002\166\005\174\000 \000\000\000\000\000\000\000\228\000\000\000\000\002p\000\000\000\000\000\000\000\000\004\016\000\000\003<\000\000\000\000\000\000\000\000\000\000\000>\000\000\003\236\004|\000\128\000\000\003\242/\022\000\000\006\204\000\000\001\188\000\0000\\\000\194\001|\007\174\000\000\000\000\000\000\003B\003\132\005\252\001(\003\138\006\140$\146\003\222\006\144\000\243\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007n\000\000\000\000\000\000\004H\007x\n\166\004\154\007z\n\200\b\154E\006\011v\000\000$\232\004\250\b6\005\246\000\0004\2207\1588$\000\000\000u\000\000\000\000\000\000\005\208>,\006\b\000\000:\138\006t\000\000:\222A\218\000\143\000\000\000\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000;\016\005\244\000\000\000\000\000\000\b\194\000\000\001\216\000\000\000\000\004\020\001j\000\000\000\000\011\b\000\000\t\244\000\000\004\020\002\206\004\020\000\000\000\000\000\000\000\000\000\000B \000\000\bf\007\152\000\000:r\t\b\002\246\000\000\000\000\000\000\007B\000\000\000\000\000\000\000\000\007<\000\000\000\000\000\000\000\000\000\000;\146\000\000\000\000\000\000\000\000\000\000\000\000\001\024\b\012\000\000\000\000\000\000\007<\bH;\216\007\248\t.\012\026\000\000\005*\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\236\000\000\000\000\000\000\000\000\t0f\007\232\000T\000\000\007\232\007\232\000\000\000\000\007\232\000\0008$\000\000\000\000\000\000\007\2328>\000\000\000\000\007\232\000\000\006\004\t\014\000\000\000\000\000\000\000\000\000\000\000\000>\\\000\000\b\162\000\000J2\007<\000\000\000\000\000\000\000\000\b\188\tF\011\1744\238B\254\t\132\000\000\004n\007\232Jt\007<\tl\000\000\000\000\000\000\000\00072\t\222\000\0008bH\206\000\000\012b\tV\t\138\t\158\t<\007\214\t\170\001\132\nR\000\000\000\000\001J\002\184\t\182\002\160\t\234\000\000\000\000\002\228\000\000\0024\000$\002\212\000\019\011T\000\000\000\0009\000\000\000P\138\n\248\000\000J\154\007\154\000\000KD%\156\n\190\t\184KR\n\204\t\232\rf\n\208\t\242\r\196\n\224\t\244\00268\170\007\232\014\026\n\248\n\002F\25472\011\156\000\000C\024\014r\011\028\n\018?f\007\232\014\200\011$\n\022?\172\007\232\015&K\140\000\000\000\000\000\000\000\000\000\000\001N\b\240\000\000\000\000\000\000\011D\n \t\194\001\172\014\"\0024\000\000\000\000\000\0004\238\000\000K\150\007<\015|\011R\nXK\154\000\000K\180\000\000\000\000\015\212%\244\000\"\000\000\000\000\012\172K\186\007<3\028\007\007L\014\148\000\000\000\000\000(\0046\n\198\000\000\017\168\0024\n\246\000\000\005`\000\000\014J\011\238\017\216\007\190\000\000\014T\011\242\tB\r&\014h\014r\012\028\016\000\000\000\014\174\004\178\000\000\000\000\000\000\000\000\002\n\012B\014\142M\022\007<\000\000\004X\012T\015J\000\000\000\000\000\000\000\000\000\000\000\000M&\b\218\000\000\012Z\015\164\000\000\000\000\000\000\000\000\000\000\000\000G4\011\030\000\000\012j\005\168\000\000\012\128\012\132\004\180\000\000\006\026Hl\000\000\006\140\000\000M6\007<\007<\000\000\000\000\tP\000\000\005\146\000\000\007\254\tP\tP\000\000\012\152I\n\007\022\000\000\012\216\000\000M\244A \007<\000\000N4\014:\000\000ND\000\000\000\000\000\000\tP\000\000\000\000\012\180\015t\012\214\016\170\015Z\000\000\000\000NV\012\248\015\154\000\000\000\000\000\0003V\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\002\000\000\015\168\r\b\006\162\000\000\016\178\016j\r&\015\202\000\000\000\000\015\208\r\014\006\186\000\000\000\000/&\016\132\r0\015\232\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007<\015\150\rL\016\250\015\166\000\000-@\000\223\rT\015z\007D\000\178\rZ\0168\000\000\016\236\018\238\000\000\000\000\019L\000\000\r\134\000\000\003l\000\000\000\000\000\000\000\000\000\000\000\000Nl\007<\000\000\016\238\019\162\000\000\000\000\019\250\000\000\000c\rd\016\150\000\000C4GX\016P\000\000N\184\007<\020P\000\000\000\000\020\174\000\000\000\000\000\0009$\000\000\021\004\000\000\000\000\000\000\r\184\000\000\004\136\000\000\000\000\000\000\000\000\000\000\000\000Gt\000\000\000\000CrH.\016Z\000\000N\254\007<\021\\\000\000\000\000\021\178\000\000\000\000\r~\022\016\r\194\000\000\r\138\r\144\002~\005\180\r\164\bJ\r\206\016\1845x\r\232\000\000\r\222\014\014\n.\000\000\007\nI0\000\000\000]\000\000\014\020C\128C\184\011\152\015\150\012\128\000\000H\002N\158\000\000\000\000I\212\000\000\000\000\000\000\006p\000\000\000\000\006p\000\000\000\000\006p\nH\000\000\012\250\006p\016\1985\170\014>\000\000\006p\000\000OL\000\000\000\000\006p\000\000\000\000\014f\000\000\014\\\n\164\014l\000\000\014XIB\014\234\000\000\000\000\000\000\014\248\000\000\000\000\b\150\000\000\006pO\154\000\000\015\190\006pD\134\000\000\015\016\0160\014j\017R\015\254\000\000D\204\015\026\016>\000\000\000\000\000\000C\240\tV\014\130\016\2345\228\015\"\000\000\000\000\000\000\000\000\000\000\000\000\0116\000\000\000\000\011B\000\000\0158\000\000\016R\000\000\000\000\000\000\000\000\015>D\000\000\000\000\000\000\000\0116\000\000\011B\000\000\000\000\000\000\000\000\000\000\011N\022f\000\000\000\000\022\190\000\000\000\000\000\000\000\000\023\020\000\000\000\000\011N\023r\000\000\023\200\000\000\000\000\024 \000\000\000\000\000\000\000\000\024v\000\000\000\000/\190\011N\024\212\000\000\000\0000,\011N\025*\000\000\000\0000x\011N\007\138\025\130\000\000\000\0000\202\011N\025\216\000\000\000\0001r\011N\0266\000\000\000\0001\174\011N\000\000\000\000\026\140\000\000\000\0002\016\011N\026\228\000\000\000\0002h\011N\027:\000\000\000\0003\"\011N\000\0003n\011NI\212\011N\000\000\000\000\027\152\000\000\000\000\027\238\000\000\000\000\000\000\011`\028F\000\000\000\000\028\156\000\0009r\000\000\000\000K\140\000\000\000\000\028\250\000\000\000\000\000\000\029P\000\000\000\000\000\000\017\028\000\000\000\000A|\000\000\004\136\000\000\003:\000\000\016\182\000\000\b2\000\000\000\000\000\000\000\000\000\000\001N\000\000\000\000\016\016\000\000\000\000\029\168\000\000\029\254\000\000\000\000\000\000\030\\\000\000\000\000\030\178\016\020\031\n\000\000\031`\000\000\000\000\000\00072\016\182\000\000EL\007&\004\020\031\190\000\000EV\000\000\000\000\000\000E\136\000\000\000\000 \020\000\000 l\000\000\000\000\000\000\000\0009\220\000\000\000\000\000\0003\144\011N3\220\011N\000\000\000\000\000\000\000\000\011N\000\000\000\000\000\000\000\000\011N\000\000\017D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014\174\012X\001\172 \194\000\000\016.\014\182\016\184\011\236\000\000! \000\000\016:\014\188\t\236\016V\014\198\000\000!v\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0003\028\016\220\000\000O\204\007\003\006\005M\003\169\000\234\002\139\004\021\002\149\002\243\001\021\004\022\003\173\000\222\002\155\000\225\001\135\002\141\001\021\005N\005W\002\243\001\015\0057\001{\002N\002O\001c\001\021\001\"\005I\003j\003A\003C\002\243\005K\001l\002\157\001#\000\231\002n\0058\002\030\006\161\005?\001\135\005M\006\006\002o\002\139\0034\002\149\000\227\005@\006t\000\231\000\232\002\155\004[\001\135\002\141\002\134\005N\004\254\004\016\006\128\005d\001\015\001\029\000\231\001\002\001\030\003\r\001\021\001\"\003w\003x\000\234\002\243\000\234\002\157\003&\005A\001\015\001#\004\242\004\\\004~\004]\001\021\001\"\002\243\003\128\006s\003\187\001 \003\129\003_\005\030\001}\001\021\003}\003A\003C\0019\005r\003\199\001~\002\243\001\135\001j\001,\007(\002O\001c\004\244\005\147\004^\005B\000\231\001\002\005\210\002\136\0007\002\021\005 \000\235\005C\001@\001#\004\245\000\240\000\243\006\241\002R\004\252\002\138\000\231\006\180\005\003\001(\005\"\001\015\002N\002O\001c\005U\002\145\001\021\001\024\003P\002\"\004_\006w\002 \005\164\005\243\000\231\002n\002\243\002\031\004`\004a\003\216\004b\001E\002o\005#\005W\001T\001\015\001\029\006Y\001\248\001\030\001\015\001\021\001\"\005I\002\134\003^\001\021\001\024\005K\002\243\001\165\002N\002O\001c\004\127\000\234\002N\002O\001c\005M\000\234\000\234\002\139\001 \002\149\000\227\002n\002\243\000\231\001\002\002\155\002n\001\135\002\141\002o\005N\002\021\002\243\004d\002o\005\188\006\140\002!\004f\004p\007\000\007)\002\134\002\138\000\231\001<\000\251\002\134\002\157\004{\001\248\003v\001#\002\243\000\146\001Z\004\128\004\020\002\022\005\205\002\136\002 \001\163\001(\000\231\004|\001q\006\167\006\168\004\021\001C\001z\002R\004\027\002\138\000\231\003\140\006\169\006\170\001,\002\243\001\131\001F\001\130\002\142\002\145\007\002\005$\006\171\003_\002N\002O\001c\001\015\003\155\001\015\003\159\000\146\006\141\001\021\001\"\001\021\001\024\002\136\003\158\002n\002\146\0034\002\136\001\169\000\234\0034\002\243\002o\005 \002R\001\180\002\138\000\231\006\211\002R\004\224\002\138\000\231\002!\003\249\002\134\002\142\002\145\001\185\005\"\0067\002\142\002\145\000\234\002\139\002\243\002\149\002N\002O\001c\002\243\001\199\002\155\001\029\001\135\002\141\001\030\001/\002\146\001\196\001A\003\170\002n\002\146\001#\005#\004\020\003\133\003A\003C\002o\006\149\003A\003C\001\225\002\157\006\204\002\003\004\021\001[\001 \001r\0044\002\134\001\249\006\199\001\211\002\139\001\253\002\149\001\021\001,\002\139\004\029\002\149\002\155\002\136\001\135\002\141\002\021\002\155\001E\001\135\002\141\002N\002O\001c\001\015\002R\001\015\002\138\000\231\005 \001\021\001\"\001\021\001\"\004-\002\157\002n\002\142\002\145\0045\002\157\000\234\001(\002[\002o\005\"\002 \001\202\001\254\000\231\006\201\002N\002O\001c\003\220\003_\005:\002\134\001\213\002\146\000\234\002\136\000\234\001\255\001\220\002.\002n\000\234\002N\002O\001c\005#\001\015\002R\002o\002\138\000\231\004\023\001\021\001\"\006`\003K\006\031\002n\000\231\002\142\002\145\002\134\002\139\0021\002\149\002o\001\210\002\021\0024\0027\002\155\006]\001\135\002\141\004\232\004\023\002=\000\231\002\134\006\177\004\023\002\146\001\029\002!\002E\001)\002J\005\005\001\216\002\243\000\231\002Z\002\136\002\157\002\251\001\222\000\234\002 \002\243\002\243\000\231\001+\000\234\000\234\002R\001\235\002\138\000\231\001#\001 \002\139\005\024\002\149\006.\003_\001\237\002\142\002\145\002\155\002h\001\135\002\141\002\136\002\243\001\252\002\205\006\173\000\234\001\135\002N\002O\001c\000\234\000\234\002R\001,\002\138\000\231\002\146\002\136\000\234\002\157\002\238\002\243\002n\002\247\002\142\002\145\000\234\002\021\000\234\002R\002o\002\138\000\231\000\234\003\003\002N\002O\001c\002!\003\174\006N\002\142\002\145\002\134\003\020\002\139\002\146\002\149\003\188\003\205\002n\006\159\003_\002\155\002\255\001\135\002\141\002 \002o\001\015\000\231\000\234\001\015\002\146\0066\001\021\001\"\000\234\001\021\001\"\002\r\002\134\006\026\003\209\003\025\002\139\002\157\002\149\003*\003;\006\022\003=\002\021\002\155\000\234\001\135\002\141\000\234\002-\003O\001b\001c\002\139\004\004\002\149\0020\003]\0023\000\234\004\254\002\155\002\243\001\135\002\141\002\136\0026\002\157\003c\000\234\003\021\001d\001e\002 \001f\001g\000\231\002R\002<\002\138\000\231\002!\003p\002@\002\157\001#\002N\002O\001c\002\142\002\145\003\131\001\029\002\136\000\227\001\030\002D\000\231\000\232\000\234\002I\002n\003\168\000\234\000\234\002R\000\234\002\138\000\231\002o\001\225\002\146\001,\002\028\000\234\0063\002Y\002\142\002\145\001 \001\249\000\234\002\134\002g\001\253\003\172\001\021\004\242\003\178\002N\002O\001c\000\234\002y\004$\006(\002!\005E\003\184\002\146\002\139\003\195\005i\005H\002n\002\154\000\234\001k\002\155\002\243\001\135\002\141\002o\001\029\002\222\000\234\004@\004\244\006\030\001l\002\021\003\214\000\231\003\219\001(\002\134\000\234\001\254\002\139\002\246\002\149\002\157\004\245\002N\002O\001c\002\155\004\252\001\135\002\141\001 \005\000\001\255\002\136\003\224\002\243\002\237\006!\002n\000\234\002 \003\b\000\234\000\231\001\015\002R\002o\002\138\000\231\002\157\001\021\001\"\000\234\003\234\002\239\000\234\006\028\002\142\002\145\002\134\000\227\002\242\003\240\000\231\000\232\003\251\002N\002O\001c\002\243\003\011\004(\001}\004\006\002\243\000\234\002\136\000\234\002\249\002\146\001\134\002n\001\135\001j\004\024\003\n\004\n\003\004\002R\002o\002\138\000\231\002\243\004\242\003\007\006\r\004\031\002\243\000\234\006\136\002\142\002\145\002\134\002!\004/\001\015\001#\004P\002\139\0049\002\149\001\021\001\"\002N\002O\001c\002\155\000\234\001\135\002\141\002\136\000\227\002\146\004\244\000\231\000\232\000\234\004R\002n\000\234\003\019\003\024\002R\001,\002\138\000\231\002o\000\234\004\245\002\157\002\243\004X\006\007\004\252\002\142\002\145\004e\004\253\000\234\002\134\000\234\002\139\004h\002\149\004\242\004r\002N\002O\001c\002\155\000\234\001\135\002\141\002\136\004m\002\243\002\146\001#\000\234\004x\002\243\002n\003\030\000\234\003%\002R\003$\002\138\000\231\002o\001\029\003)\002\157\004G\004\244\005\252\004\131\002\142\002\145\002\243\004\137\000\234\002\134\004\141\001,\002\139\003\\\005i\004\169\004\245\002N\002O\001c\002\155\004\252\001\135\002\141\001 \005\007\002\146\002\136\004\215\004\150\003b\003o\002n\000\234\005\022\003s\000\234\004\220\003u\002R\002o\002\138\000\231\002\157\003\130\003\139\005\237\005\b\003\144\002\243\003\156\002\142\002\145\002\134\004\191\002\139\003\154\002\149\003\157\004\217\002N\002O\001c\002\155\003\161\001\135\002\141\000\234\004\225\002\243\002\136\000\234\002\243\002\146\000\234\002n\005\004\001\225\004\228\000\234\002]\003\171\002R\002o\002\138\000\231\002\157\001\249\003\167\005\226\002\021\001\253\000\234\001\021\002\142\002\145\002\134\003\183\000\234\001\015\004\231\000\234\002\139\004\239\002\149\001\021\001\"\002N\002O\001c\002\155\000\234\001\135\002\141\002\136\000\227\002\146\006T\000\231\000\232\002 \005\011\002n\000\231\003\177\003\179\002R\003\202\002\138\000\231\002o\003\190\000\234\002\157\001\254\002\243\005\218\005\027\002\142\002\145\000\234\005\021\002\243\002\134\005\025\002\139\005/\002\149\004\242\001\255\002N\002O\001c\002\155\002\243\001\135\002\141\002\136\005;\002\243\002\146\001#\003\201\002\243\000\234\002n\003\196\000\234\003\200\002R\003\213\002\138\000\231\002o\002\243\003\218\002\157\002\243\004\244\005\177\006 \002\142\002\145\002!\006&\0048\002\134\006-\001,\002\139\003\223\002\149\0060\004\245\002N\002O\001c\002\155\004\252\001\135\002\141\000\234\005\023\002\146\002\136\002\243\002\243\005\029\002\243\002n\000\234\006S\006q\003\226\005!\003\230\002R\002o\002\138\000\231\002\157\003\238\000\234\003\245\006{\004\000\005-\005\169\002\142\002\145\002\134\0054\002\139\0047\002\149\005>\002\243\002N\002O\001c\002\155\0040\001\135\002\141\000\234\006}\005J\002\136\000\234\005Q\002\146\000\234\002n\006\162\001\225\006\174\000\234\002\241\0041\002R\002o\002\138\000\231\002\157\001\249\0046\002\132\002\021\001\253\002\243\001\021\002\142\002\145\002\134\004:\000\234\000\234\006K\006u\002\139\006\188\002\149\004;\004Z\002N\002O\001c\002\155\000\234\001\135\002\141\002\136\000\227\002\146\006r\000\231\000\232\002 \004S\002n\000\231\004T\004Y\002R\004o\002\138\000\231\002o\0071\000\234\002\157\001\254\002\243\002\144\004k\002\142\002\145\000\234\004l\000\234\002\134\004n\002\139\004z\002\149\004\242\001\255\002N\002O\001c\002\155\004w\001\135\002\141\002\136\004y\004\130\002\146\004\132\004\133\004\138\007<\002n\004\142\004\146\004\164\002R\004\170\002\138\000\231\002o\001\225\004\174\002\157\002\253\004\244\002\148\004\205\002\142\002\145\002!\001\249\004\226\002\134\004\255\001\253\002\139\001\021\005i\005\t\004\245\002N\002O\001c\002\155\004\252\001\135\002\141\0056\005)\002\146\002\136\0050\0051\007A\0055\002n\005<\001\225\005L\005\199\003\181\005\208\002R\002o\002\138\000\231\002\157\001\249\005\221\002\163\005\232\001\253\005\240\001\021\002\142\002\145\002\134\001\254\002\139\006\024\002\149\006%\006'\002N\002O\001c\002\155\006,\001\135\002\141\006/\006<\001\255\002\136\006R\006[\002\146\006\157\002n\006\179\007#\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\001\225\000\000\002\162\003\192\001\254\000\000\000\000\002\142\002\145\002\134\001\249\000\000\000\000\000\000\001\253\002\139\001\021\002\149\000\000\001\255\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\001\225\002n\000\000\003\198\000\000\002R\000\000\002\138\000\231\002o\001\249\000\000\002\157\000\000\001\253\002\210\001\021\002\142\002\145\000\000\000\000\000\000\002\134\001\254\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\001\255\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\001\225\000\000\002\157\003\207\001\254\002\213\000\000\002\142\002\145\000\000\001\249\000\000\002\134\000\000\001\253\002\139\001\021\002\149\000\000\001\255\002N\002O\001c\002\155\001\225\001\135\002\141\003\215\000\000\002\146\002\136\000\000\000\000\000\000\001\249\002n\000\000\000\000\001\253\000\000\001\021\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\002\234\000\000\000\000\000\000\000\000\002\142\002\145\002\134\001\254\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\001\255\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\001\254\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\001\225\000\000\004\145\006W\000\000\000\000\001\255\002\142\002\145\002\134\001\249\000\000\000\000\000\000\001\253\002\139\001\021\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\001\225\002n\000\000\006f\000\000\002R\000\000\002\138\000\231\002o\001\249\000\000\002\157\000\000\001\253\004\148\001\021\002\142\002\145\000\000\000\000\000\000\002\134\001\254\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\001\255\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\001\225\000\000\002\157\006i\001\254\004\163\000\000\002\142\002\145\000\000\001\249\000\000\002\134\000\000\001\253\002\139\001\021\002\149\000\000\001\255\002N\002O\001c\002\155\001\225\001\135\002\141\006l\000\000\002\146\002\136\000\000\000\000\000\000\001\249\002n\000\000\000\000\001\253\000\000\001\021\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\004\166\000\000\000\000\000\000\000\000\002\142\002\145\002\134\001\254\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\001\255\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\001\254\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\004\178\000\000\000\000\000\000\001\255\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\004\181\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\004\187\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\004\209\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\004\212\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\004\216\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\005_\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\005b\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\005g\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\005k\000\000\000\000\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\005m\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\005p\002\142\002\145\002\134\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\005u\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\005z\000\000\000\000\002\134\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\005\127\000\000\000\000\002\134\000\000\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\005\133\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\005\138\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\005\143\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\005\150\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\005\155\002\142\002\145\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\005\160\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\005\172\000\000\000\000\002\134\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\005\175\000\000\000\000\002\134\000\000\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\005\180\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\005\183\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\005\192\000\000\000\000\002\134\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\005\196\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\005\222\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\005\224\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\005\228\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\005i\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\005\231\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\005\233\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\005\235\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\005\245\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\005\254\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\006\001\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\006#\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\006*\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\0062\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\006@\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\006E\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\006H\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\006\208\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\006\210\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\006\213\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\006\218\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\006\220\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\149\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\006c\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\006L\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\006\021\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\006\016\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\005\168\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\005]\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\151\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\153\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\158\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\165\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\167\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\169\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\171\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\173\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\175\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\177\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\179\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\181\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\183\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\185\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\187\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\189\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\001b\001c\000\000\002\136\000\000\000\000\002\146\000\000\002n\000\000\000\000\000\000\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\001d\004\183\000\000\001f\001g\000\000\000\000\002\142\002\145\002\134\000\000\000\000\000\000\000\000\000\000\002\139\000\000\002\191\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\000\000\002\157\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\000\000\002\134\000\000\002\139\000\000\002\193\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\002\136\000\000\000\000\002\146\000\000\000\000\001k\000\000\002n\000\000\000\000\000\000\002R\000\000\002\138\000\231\002o\000\000\001l\002\157\000\000\000\231\000\000\004[\002\142\002\145\000\000\000\000\000\000\002\134\000\000\000\000\002\139\000\000\002\195\000\000\000\000\002N\002O\001c\002\155\000\000\001\135\002\141\000\000\000\000\002\146\002\136\000\000\000\000\000\000\004\\\002n\004]\000\000\005*\000\000\000\000\000\000\002R\002o\002\138\000\231\002\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\134\000\000\002\139\000\000\002\197\000\000\000\000\000\000\001}\004^\002\155\001\029\001\135\002\141\001\030\000\000\001\134\002\136\001\135\001j\002\146\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002R\005,\002\138\000\231\002\157\000\000\000\000\000\000\000\000\001 \000\000\001\029\002\142\002\145\001\030\004_\000\000\000\000\000\000\000\000\002\139\000\000\002\199\000\000\004`\004a\003q\004b\002\155\000\000\001\135\002\141\002\136\000\000\002\146\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\000\000\002R\000\000\002\138\000\231\000\000\000\000\001\029\002\157\004}\001\030\001(\003q\002\142\002\145\001\029\000\000\000\000\001\030\000\000\002\139\000\000\002\201\000\000\000\000\003t\000\000\000\000\002\155\000\000\001\135\002\141\000\000\004d\001 \002\146\006\137\000\000\004f\004p\001(\001\015\001 \000\000\000\000\000\000\000\000\001\021\001\"\004{\000\000\002\157\000\000\000\000\003\153\000\000\000\000\000\000\000\000\003q\000\000\000\000\000\000\000\000\002\139\004|\002\203\000\000\000\000\000\000\001\015\000\000\002\155\000\000\001\135\002\141\001\021\001\"\000\000\001(\000\000\000\000\000\000\002N\002O\001c\000\000\001(\000\000\000\000\000\000\003w\003x\000\000\000\000\002\157\001<\000\000\002n\000\000\000\000\004v\000\000\001#\000\000\000\000\002o\003y\003\137\001\015\000\000\000\000\003\129\003_\000\000\001\021\001\"\001\015\000\000\002\134\003w\003x\000\000\001\021\001\"\001<\000\000\000\000\000\000\000\000\001,\000\000\001#\001F\000\000\000\000\003y\003\137\002N\002O\001c\003\129\003_\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\000\000\000\000\000\000\001,\000\000\002o\001F\000\000\001<\000\000\000\000\003w\003x\000\000\001\029\001#\001<\001\030\002\134\006\144\002N\002O\001c\001#\002\136\000\000\000\000\003y\003\137\000\000\000\000\000\000\003\129\003_\000\000\002n\002R\000\000\002\138\000\231\000\000\001 \001,\002o\000\000\001F\000\000\000\000\002\142\002\145\001,\0037\000\000\001F\000\000\000\000\002\134\000\000\000\000\000\000\000\000\002N\002O\001c\000\000\006z\000\000\000\000\000\000\000\000\002\146\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\002\136\000\000\000\000\000\000\000\000\002o\000\000\001(\000\000\000\000\000\000\000\000\002R\000\000\002\138\000\231\000\000\000\000\002\134\000\000\002\139\000\000\005x\000\000\002\142\002\145\000\000\000\000\002\155\000\000\001\135\002\141\000\000\000\000\000\000\000\000\000\000\001\015\002\136\000\000\000\000\000\000\000\000\001\021\001\"\000\000\002\146\000\000\000\000\000\000\002R\002\157\002\138\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\000\000\000\000\002N\002O\001c\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\005}\000\000\002\136\000\000\002n\000\000\002\155\002\146\001\135\002\141\000\000\000\000\002o\000\000\002R\001<\002\138\000\231\000\000\002N\002O\001c\001#\000\000\000\000\002\134\002\142\002\145\000\000\002\157\000\000\000\000\000\000\000\000\002n\000\000\002\139\000\000\005\130\000\000\000\000\000\000\002o\004[\002\155\000\000\001\135\002\141\002\146\001,\000\000\000\000\003>\000\000\000\000\002\134\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\157\002N\002O\001c\004\\\006\189\004]\000\000\000\000\000\000\002\139\000\000\005\136\000\000\000\000\000\000\002n\000\000\002\155\002\136\001\135\002\141\000\000\000\000\002o\000\000\000\000\000\000\000\000\000\000\000\000\002R\000\000\002\138\000\231\004^\000\000\002\134\000\000\000\000\000\000\002\157\000\000\002\142\002\145\002N\002O\001c\000\000\002\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002n\002R\000\000\002\138\000\231\002\146\000\000\000\000\002o\000\000\004_\000\000\000\000\002\142\002\145\000\000\000\000\000\000\000\000\004`\004a\002\134\004b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\002\146\005\141\000\000\002\136\000\000\000\000\000\000\002\155\000\000\001\135\002\141\000\000\004\127\000\000\000\000\002R\000\000\002\138\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\145\002\139\002\157\005\146\000\000\000\000\000\000\000\000\004d\002\155\000\000\001\135\002\141\004f\004p\002N\002O\001c\000\000\002\136\001\029\002\146\000\000\001\030\004{\000\000\000\000\000\000\000\000\000\000\002n\002R\002\157\002\138\000\231\000\000\000\000\000\000\002o\004[\004|\000\000\000\000\002\142\002\145\000\000\000\000\001 \000\000\000\000\002\139\002\134\005\153\002N\002O\001c\000\000\006A\002\155\000\000\001\135\002\141\000\000\000\000\000\000\002\146\000\000\004\\\002n\004]\002N\002O\001c\000\000\000\000\000\000\002o\000\000\000\000\000\000\000\000\002\157\000\000\000\000\000\000\002n\000\000\000\000\000\000\002\134\000\000\000\000\001(\002o\002\139\000\000\005\158\000\000\004^\000\000\000\000\000\000\002\155\000\000\001\135\002\141\002\134\000\000\002N\002O\001c\000\000\002\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\015\002n\002R\002\157\002\138\000\231\001\021\001\"\000\000\002o\000\000\004_\000\000\000\000\002\142\002\145\000\000\000\000\000\000\000\000\004`\004a\002\134\004b\000\000\000\000\000\000\000\000\002\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\146\000\000\000\000\000\000\002R\000\000\002\138\000\231\000\000\002\136\000\000\000\000\004c\000\000\000\000\000\000\002\142\002\145\000\000\001<\000\000\002R\000\000\002\138\000\231\000\000\001#\000\000\000\000\002\139\002v\005\163\000\000\002\142\002\145\000\000\004d\002\155\002\146\001\135\002\141\004f\004p\000\000\000\000\000\000\000\000\002\136\000\000\000\000\000\000\000\000\004{\001,\000\000\002\146\001F\000\000\000\000\002R\002\157\002\138\000\231\000\000\000\000\000\000\000\000\002\139\004|\005\166\000\000\002\142\002\145\000\000\000\000\002\155\000\000\001\135\002\141\001\174\001c\000\000\000\000\000\000\002\139\000\000\006\t\000\000\001\188\001c\000\000\000\000\002\155\002\146\001\135\002\141\000\000\000\000\002\157\002\206\001s\000\000\001f\001g\000\000\001\174\001c\000\000\001d\002b\000\000\001f\001g\000\000\000\000\002\157\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\006\011\002\206\001s\000\000\001f\001g\002\155\000\000\001\135\002\141\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\211\002\223\002\224\000\000\000\000\000\000\000\000\000\000\000\000\005\178\002\223\002\224\002\157\000\000\000\000\000\000\001\174\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\211\002\223\002\224\000\000\000\000\000\000\000\000\000\000\001{\000\000\002\206\001s\000\000\001f\001g\001\174\001c\001{\000\000\000\000\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001{\002\206\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001\174\001c\001l\000\000\000\000\000\231\000\000\000\000\002\211\002\223\002\224\002\227\006J\000\000\000\000\005\181\005\186\000\000\000\000\000\000\002\206\001s\000\000\001f\001g\0057\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\211\002\223\002\224\000\000\002\227\002\228\001}\0077\000\000\001{\0078\000\000\000\000\005?\001~\001}\001\135\001j\000\000\000\000\000\000\001l\005@\001~\000\231\001\135\001j\000\000\000\000\002\211\002\223\002\224\001}\000\000\001{\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\135\001j\000\000\000\000\001l\000\000\000\000\000\231\000\000\005A\000\000\000\000\000\000\000\000\002\227\004\227\000\000\000\000\000\000\000\000\000\000\001{\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\001b\001c\002\227\005\n\000\000\001}\001d\001s\005B\001f\001g\000\000\000\000\001~\000\000\001\135\001j\005C\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\006\203\001}\002\227\005=\000\000\000\000\000\000\005D\002\145\001~\007:\001\135\001j\000\000\006\206\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\0029\000\000\000\000\001b\001c\000\000\005G\001}\000\000\000\000\000\000\001t\000\000\001u\0029\001~\005I\001\135\001j\000\000\000\000\005K\000\000\001d\001s\000\000\001f\001g\000\000\000\000\001{\000\000\005M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\001{\000\231\000\000\000\000\005N\000\000\000\000\000\000\000\000\006\006\000\000\000\000\001l\001b\001c\000\231\000\000\000\000\000\000\000\000\000\000\000\000\001t\006\006\001u\001\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\001\172\000\000\000\000\000\000\000\000\000\000\000\146\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\001l\000\000\001~\000\231\001\135\001j\000\000\000\000\001}\001t\000\000\001u\001\160\001b\001c\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001{\001\158\001b\001c\001d\001s\000\000\001f\001g\000\000\000\000\004\185\001l\000\000\001\162\000\231\000\000\000\000\000\000\004\188\000\000\001}\001d\004\183\000\000\001f\001g\000\000\000\000\001~\000\000\001\135\001j\000\000\001t\000\000\001u\001\160\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\001\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\001l\001{\000\000\000\231\001~\000\000\001\135\001j\000\000\001\029\000\000\000\000\001\030\001l\000\000\000\000\000\231\000\000\000\000\001k\001b\001c\001t\000\000\001u\0029\000\000\000\000\000\000\004\185\000\000\001l\000\000\000\000\000\231\000\000\001 \004\188\000\000\000\000\001d\004\183\000\000\001f\001g\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\001\188\001c\000\000\000\000\001}\000\000\000\000\000\000\001l\004\184\000\000\000\231\001~\000\000\001\135\001j\000\000\001}\000\000\006\002\001d\002b\001(\001f\001g\001~\000\000\001\135\001j\000\000\0064\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\001\015\001b\001c\000\000\000\000\001k\001\021\001\"\000\000\000\000\005\178\002\223\002\224\000\000\000\000\000\000\000\000\001l\000\000\001}\000\231\001d\001s\000\000\001f\001g\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\001b\001c\000\000\000\000\004\184\001<\001l\001d\001s\000\231\001f\001g\001#\000\000\001t\000\000\001u\0029\000\000\000\000\001d\001s\000\000\001f\001g\004\189\000\000\000\000\000\000\000\000\001}\000\000\000\000\001\029\000\000\000\000\001\030\005\185\001\134\001,\001\135\001j\001\234\000\000\000\000\001\029\000\000\001{\001\030\000\000\001t\0010\001u\007\024\000\000\007\026\000\000\000\000\000\000\001l\001 \000\000\000\231\001t\000\000\001u\006\193\000\000\001:\001}\006\005\0011\001 \000\000\000\000\000\000\000\000\001~\001O\001\135\001j\000\000\000\000\001{\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\0010\000\000\001l\001{\000\000\000\231\000\000\000\000\000\000\000\000\000\000\000\000\001(\000\000\000\000\001l\000\000\000\000\000\231\001\029\0011\001 \001\030\000\000\001(\0010\000\000\001M\000\000\001}\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\135\001j\0016\001\015\000\000\000\000\0011\001 \000\000\001\021\001\"\000\000\000\000\0012\000\000\001\015\000\000\000\000\000\000\000\000\000\000\001\021\001\"\000\000\000\000\000\000\001}\001(\000\000\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\135\001j\000\000\001}\000\000\000\000\000\000\000\000\0016\001\029\000\000\001~\001\030\001\135\001j\0010\001(\000\000\000\000\000\000\000\000\001\015\001<\000\000\000\000\000\000\000\000\001\021\001\"\001#\000\000\000\000\000\000\0016\001<\0011\001 \001b\001c\000\000\000\000\001#\001K\000\000\000\000\001D\001\015\000\000\000\000\000\000\004[\000\000\001\021\001\"\000\000\000\000\001,\001d\001s\001B\001f\001g\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\001F\000\000\000\000\000\000\000\000\001<\000\000\004\\\006\226\004]\001(\000\000\001#\000\000\000\000\000\000\001D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0016\000\000\001t\001<\001u\001\164\000\000\000\000\001b\001c\001#\004^\001,\001\015\001D\001F\000\000\000\000\000\000\001\021\001\"\001b\001c\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\001{\000\000\001,\000\000\000\000\001F\001d\001s\000\000\001f\001g\004_\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\004`\004a\000\000\004b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001<\000\000\000\000\001t\000\000\001u\001\154\001#\000\000\001b\001c\001D\000\000\000\000\000\000\004\127\001t\000\000\001u\001\151\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\001,\000\000\001{\001F\000\000\004d\006\228\000\000\001}\000\000\004f\004p\000\000\000\000\001l\001{\001~\000\231\001\135\001j\000\000\004{\000\000\000\000\000\000\000\000\000\000\001l\001b\001c\000\231\000\000\000\000\000\000\000\000\000\000\000\000\004|\001t\000\000\001u\001w\001b\001c\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\001d\001s\001}\001f\001g\000\000\000\000\000\000\001l\000\000\001~\000\231\001\135\001j\000\000\001}\001t\000\000\001u\001y\000\000\000\000\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\001t\000\000\001u\001|\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\001\150\000\000\000\000\001{\000\000\000\000\000\000\000\000\001d\001s\001\029\001f\001g\004D\000\000\001l\000\000\001{\000\231\000\000\000\000\001\029\000\000\000\000\001\030\001}\000\000\000\000\000\000\001l\001{\000\000\000\231\001~\000\000\001\135\001j\001 \001b\001c\000\000\000\000\001l\001b\001c\000\231\000\000\006F\001 \000\000\000\000\001t\000\000\001u\001\142\006I\000\000\000\000\001d\004\183\000\000\001f\001g\001d\001s\000\000\001f\001g\002N\002O\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\004F\000\000\001{\000\000\001~\000\000\001\135\001j\000\000\005\202\001}\001(\000\000\000\000\001l\000\000\005\211\000\231\001~\000\000\001\135\001j\000\000\001}\001t\000\000\001u\001\147\000\000\000\000\001\015\001~\000\000\001\135\001j\000\000\001\021\004I\000\000\006\019\000\000\001\015\000\000\000\000\000\000\000\000\000\000\001\021\001\"\000\000\000\000\000\000\001k\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\002Q\000\000\001~\000\000\001\135\001j\001b\001c\000\000\004J\000\000\000\000\005\214\001<\002\138\000\231\001\002\000\000\004\184\000\000\001#\004\021\000\000\004O\001V\004L\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\000\000\000\000\001b\001c\000\000\001}\000\000\000\000\001,\000\000\001}\001F\005\205\001\134\000\000\001\135\001j\000\000\001~\000\000\001\135\001j\001d\001s\000\000\001f\001g\000\000\001b\001c\001t\000\000\001u\002F\001b\001c\002\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\140\000\000\001\135\002\141\001d\001s\000\000\001f\001g\000\000\001d\001s\000\000\001f\001g\000\000\001b\001c\000\000\001{\000\000\001t\000\000\001u\002K\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\002\215\001b\001c\001t\001{\001u\002\217\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\001t\001{\001u\002\219\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\001l\000\000\001}\000\231\000\000\000\000\001l\000\000\000\000\000\231\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\001b\001c\001{\000\000\001t\000\000\001u\002\226\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001}\001d\001s\000\000\001f\001g\000\000\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\001\029\000\000\000\000\001\030\001}\000\000\001G\000\000\001l\000\000\001}\000\231\001~\000\000\001\135\001j\000\000\000\000\001~\000\000\001\135\001j\001t\000\000\001u\002\232\001I\001 \000\000\000\000\000\000\000\000\004\014\000\000\000\000\000\000\001}\000\000\002N\002O\001c\000\000\000\000\000\000\001~\000\000\001\135\001j\0057\000\000\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\005\202\000\000\0077\000\000\000\000\0078\001l\005\211\005?\000\231\001}\001(\000\000\000\000\000\000\000\000\000\000\005@\001~\000\000\001\135\001j\0057\000\000\000\000\000\000\000\000\000\000\0016\000\000\005\212\000\000\001\029\000\000\000\000\001\030\000\000\0077\001G\000\000\0078\001\015\000\000\005?\000\000\000\000\005A\001\021\001\"\000\000\000\000\000\000\005@\000\000\000\000\000\000\000\000\0057\001I\001 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\001}\001\030\000\000\0077\0010\002Q\0078\000\000\001~\005?\001\135\001j\005A\005B\000\000\000\000\000\000\005\214\005@\002\138\000\231\001\002\005C\000\000\0015\001 \000\000\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\001(\000\000\000\000\004C\000\000\000\000\005D\002\145\000\000\0079\000\000\000\000\005A\005B\000\000\000\000\000\000\0016\000\000\000\000\000\000\005\205\005C\000\000\000\000\000\000\001,\000\000\005G\001F\001\015\000\000\000\000\000\000\000\000\001(\001\021\001\"\005I\000\000\000\000\005D\002\145\005K\007=\002\139\000\000\000\000\005B\000\000\000\000\000\000\0016\002\140\005M\001\135\002\141\005C\000\000\000\000\000\000\000\000\000\000\005G\000\000\001\015\000\000\001b\001c\000\000\005N\001\021\001\"\005I\000\000\000\000\005D\002\145\005K\007B\001b\001c\000\000\000\000\0065\001<\000\000\001d\004\183\005M\001f\001g\001#\000\000\001b\001c\001D\000\000\005G\000\000\001d\004\183\000\000\001f\001g\005N\000\000\000\000\005I\000\000\000\000\004\182\000\000\005K\001d\004\183\000\000\001f\001g\001,\001<\000\000\001F\000\000\005M\001b\001c\001#\000\000\000\000\000\000\001D\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\005N\000\000\004\213\000\000\000\000\001d\004\183\000\000\001f\001g\000\000\000\000\001d\004\183\001,\001f\001g\001F\000\000\000\000\001b\001c\000\000\001k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001k\000\000\000\231\000\000\001d\004\183\000\000\001f\001g\0057\000\000\000\000\001l\000\000\001k\000\231\000\000\0057\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\0058\000\000\000\231\005?\000\000\000\000\000\000\000\000\0058\004\184\000\000\005?\005@\000\000\000\000\000\000\000\000\000\000\001k\000\000\005@\000\000\005\246\000\000\000\000\001k\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001}\004\184\001l\000\000\000\000\000\231\005A\005\249\001\134\000\000\001\135\001j\000\000\001}\005A\000\000\000\000\000\000\001k\000\000\000\000\001\134\000\000\001\135\001j\001b\001c\001}\000\000\000\000\001l\000\000\004\184\000\231\000\000\001\134\000\000\001\135\001j\004\240\000\000\000\000\005B\000\000\000\000\001d\004\183\000\000\001f\001g\005B\005C\000\000\000\000\000\000\000\000\000\000\000\000\001}\005C\001b\001c\000\000\000\000\000\000\001}\001\134\004\240\001\135\001j\005D\002\145\000\000\001\134\000\000\001\135\001j\005F\005D\002\145\001d\004\183\000\000\001f\001g\005R\005\002\000\000\002N\002O\001c\000\000\005G\001}\000\000\000\000\000\000\000\000\000\000\000\000\005G\001\134\005I\001\135\001j\000\000\000\000\005K\000\000\000\000\005I\006P\000\000\000\000\005\001\005K\000\000\000\000\005M\000\000\000\000\001k\000\000\000\000\001b\001c\005M\000\000\000\000\001b\001c\000\000\000\000\001l\005N\000\000\000\231\000\000\000\000\000\000\000\000\000\000\005N\000\000\001d\004\183\000\000\001f\001g\001d\004\183\000\000\001f\001g\001b\001c\001k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\005*\000\231\000\000\000\000\001d\004\183\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\000\000\002Q\000\000\000\000\000\000\000\000\000\000\000\000\0057\000\000\000\000\000\000\001}\002R\000\000\002\138\000\231\000\000\000\000\000\000\001\134\005*\001\135\001j\000\000\000\000\0058\000\000\000\000\005?\000\000\000\000\000\000\000\000\005+\000\000\001k\000\000\005@\000\000\000\000\001k\0057\000\000\000\000\000\000\001\029\001}\001l\001\030\000\000\000\231\000\000\001l\000\000\001\134\000\231\001\135\001j\000\000\007.\000\000\000\000\005?\000\000\000\000\001k\005A\000\000\0053\000\000\000\000\005@\001 \000\000\000\000\002\139\000\000\001l\000\000\000\000\000\231\000\000\003\028\002\140\005\246\001\135\002\141\000\000\000\000\005\246\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\187\000\000\000\000\005A\000\000\005B\000\000\005\248\000\000\000\000\000\000\000\000\005\247\001}\005C\000\000\000\000\005\246\001}\000\000\001(\001\134\000\000\001\135\001j\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\005D\002\145\001\029\000\000\005\251\001\030\005B\006v\000\000\000\000\001}\000\000\000\000\000\000\000\000\005C\000\000\001\015\001\134\000\000\001\135\001j\005G\001\021\001\"\000\000\001b\001c\000\000\001 \000\000\000\000\005I\000\000\005D\002\145\000\000\005K\007/\003\028\000\000\000\000\000\000\000\000\000\000\000\000\001d\004\183\005M\001f\001g\000\000\000\000\000\000\003!\000\000\005G\000\000\000\000\000\000\001\029\000\000\000\000\001\030\005N\000\000\005I\000\000\000\000\000\000\000\000\005K\001<\000\000\001(\000\000\000\000\000\000\001\029\001#\000\000\001\030\005M\003'\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\003\028\005N\000\000\000\000\000\000\000\000\000\000\001\015\001 \001,\000\000\000\000\001F\001\021\001\"\004\003\000\000\000\000\003\028\000\000\000\000\000\000\001 \000\000\000\000\001k\000\000\000\000\001b\001c\000\000\000\000\003\028\004\179\000\000\001(\000\000\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\000\000\004\200\001d\001\133\000\000\001f\001g\001(\000\000\000\000\000\000\000\000\002N\002O\001c\000\000\001<\000\000\000\000\001\015\000\000\001(\000\000\001#\000\000\001\021\001\"\003'\005\250\000\000\000\000\000\000\000\000\000\000\000\000\004\248\000\000\001\015\000\000\000\000\000\000\000\000\001\029\001\021\001\"\001\030\000\000\000\000\000\000\000\000\001,\001\015\000\000\001F\001}\000\000\000\000\001\021\001\"\004\249\000\000\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\001 \000\000\000\000\000\000\001\029\001<\000\000\001\030\000\000\001k\003\028\000\000\001#\000\000\000\000\000\000\003'\000\000\000\000\000\000\000\000\001l\000\000\001<\000\231\004\210\000\000\000\000\000\000\000\000\001#\001 \000\000\000\000\003'\000\000\004\014\001<\000\000\001,\002Q\000\000\001F\000\000\001#\001(\001b\001c\003'\000\000\001\029\000\000\002R\001\030\002\138\000\231\000\000\001,\000\000\000\000\001F\000\000\000\000\000\000\000\000\000\000\001d\001\205\000\000\001f\001g\001,\000\000\000\000\001F\001\015\001(\001 \000\000\000\000\000\000\001\021\001\"\001\029\001}\000\000\001\030\0037\000\000\000\000\004\251\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\003:\001\029\000\000\000\000\001\030\001\015\000\000\000\000\000\000\001 \001\029\001\021\001\"\001\030\002\139\000\000\000\000\000\000\000\000\000\000\000\000\001(\002\140\000\000\001\135\002\141\000\000\000\000\001 \001<\000\000\000\000\000\000\004\235\000\000\000\000\001#\001 \000\000\000\000\003'\001k\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\000\000\001\015\000\000\001l\001(\000\000\000\231\001\021\001\"\000\000\001<\000\000\001\029\001,\000\000\001\030\001F\001#\000\000\000\000\001 \004\019\000\000\001(\000\000\002N\002O\001c\000\000\000\000\000\000\000\000\001(\000\000\001\015\000\000\000\000\000\000\000\000\001 \001\021\001\"\000\000\000\000\001,\000\000\000\000\001F\004\248\000\000\000\000\000\000\000\000\001\015\000\000\000\000\001<\000\000\000\000\001\021\001\"\006\252\001\015\001#\000\000\001(\001}\000\000\001\021\001\"\000\000\000\000\000\000\000\000\001\134\000\000\001\135\001j\000\000\000\000\001\029\000\000\000\000\001\030\001(\000\000\000\000\000\000\000\000\001<\001,\000\000\000\000\003>\000\000\001\015\001#\000\000\000\000\000\000\004 \001\021\001\"\004#\000\000\000\000\000\000\001 \001<\000\000\000\000\000\000\000\000\001\029\001\015\001#\001\030\001<\000\000\004\019\001\021\001\"\002Q\001,\001#\000\000\001F\000\000\004 \000\000\000\000\005\028\001\029\000\000\002R\001\030\002\138\000\231\000\000\000\000\001 \001\029\001,\000\000\001\030\001F\000\000\000\000\000\000\000\000\001<\001,\001(\000\000\001F\000\000\000\000\001#\000\000\001 \000\000\006\253\000\000\000\000\000\000\000\000\000\000\000\000\001 \001<\000\000\000\000\004\250\000\000\000\000\000\000\001#\000\000\000\000\000\000\001\144\000\000\001\015\000\000\001,\001(\000\000\001F\001\021\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\001,\001(\002\140\001F\001\135\002\141\002N\002O\001c\000\000\001(\000\000\001\015\002N\002O\001c\000\000\000\000\001\021\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\018\000\000\001\015\000\000\000\000\001<\000\000\006\015\001\021\001\"\000\000\001\015\001#\002N\002O\001c\001\179\001\021\001\"\000\000\002N\002O\001c\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\002N\002O\001c\002P\000\000\001<\001,\000\000\000\000\001F\002i\001\029\001#\000\000\001\030\000\000\001\194\000\000\000\000\000\000\001 \000\000\000\000\002k\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\001<\000\000\001\239\000\000\000\000\001 \001,\001#\002Q\001F\000\000\001\241\000\000\001\029\000\000\002Q\001\030\000\000\000\000\000\000\002R\000\000\002\138\000\231\000\000\001,\000\000\002R\001F\002\138\000\231\000\000\001(\000\000\001,\000\000\000\000\001F\000\000\000\000\001 \000\000\000\000\000\000\002Q\000\000\000\000\002N\002O\001c\001(\002Q\000\000\000\000\000\000\000\000\002R\000\000\002\138\000\231\000\000\000\000\001\015\002R\002Q\002\138\000\231\000\000\001\021\001\"\002\127\000\000\000\000\000\000\000\000\000\000\002R\000\000\002\138\000\231\001\015\001\029\000\000\002\139\001\030\001(\001\021\001\"\000\000\001\029\002\139\002\140\001\030\001\135\002\141\000\000\000\000\000\000\002\140\000\000\001\135\002\141\002N\002O\001c\000\000\000\000\000\000\001 \002N\002O\001c\000\000\000\000\000\000\001\015\001 \001<\000\000\002\139\000\000\001\021\001\"\000\000\001#\002\137\002\139\002\140\002d\001\135\002\141\000\000\002\156\000\000\002\140\001<\001\135\002\141\000\000\002\139\000\000\000\000\001#\000\000\002Q\000\000\002t\002\140\000\000\001\135\002\141\001,\001\029\001(\001F\001\030\002R\000\000\002\138\000\231\001\029\001(\000\000\001\030\000\000\000\000\000\000\000\000\001\029\001,\001<\001\030\001F\000\000\000\000\000\000\000\000\001#\000\000\001 \000\000\002x\000\000\001\015\000\000\000\000\000\000\001 \000\000\001\021\001\"\001\015\000\000\000\000\000\000\001 \000\000\001\021\001\"\002Q\000\000\000\000\000\000\000\000\001,\000\000\002Q\001F\000\000\000\000\000\000\002R\000\000\002\138\000\231\000\000\000\000\000\000\002R\002\139\002\138\000\231\000\000\000\000\001(\001\029\000\000\002\140\001\030\001\135\002\141\000\000\001(\000\000\000\000\000\000\000\000\000\000\001<\000\000\001(\000\000\000\000\000\000\000\000\001#\001<\000\000\000\000\002\208\000\000\000\000\001 \001#\001\015\000\000\000\000\003 \000\000\000\000\001\021\001\"\001\015\001\029\000\000\000\000\004D\000\000\001\021\001\"\001\015\000\000\001,\000\000\002\139\001F\001\021\001\"\000\000\000\000\001,\002\139\002\140\001F\001\135\002\141\000\000\000\000\000\000\002\140\001 \001\135\002\141\000\000\000\000\001\029\000\000\001(\004D\000\000\000\000\000\000\000\000\001\029\000\000\000\000\004D\000\000\000\000\001<\000\000\000\000\001\029\000\000\000\000\004D\001#\001<\000\000\000\000\003\236\000\000\001 \001\029\001#\001<\001\030\001\015\003\248\000\000\001 \000\000\001#\001\021\001\"\004F\004\018\000\000\000\000\001 \002N\002O\001c\001,\000\000\000\000\001F\000\000\000\000\000\000\001 \001,\000\000\000\000\001F\000\000\000\000\000\000\000\000\001,\000\000\001\029\001F\004\247\001\030\001\015\000\000\004F\000\000\000\000\000\000\001\021\004I\000\000\000\000\004F\000\000\000\000\000\000\000\000\000\000\000\000\001<\000\000\004F\000\000\000\000\000\000\001 \001#\000\000\000\000\000\000\004\"\000\000\001(\001\029\001\015\000\000\001\030\000\000\000\000\000\000\001\021\004I\001\015\000\000\000\000\000\000\000\000\000\000\001\021\004I\000\000\001\015\000\000\001,\000\000\000\000\001F\001\021\004I\000\000\001 \000\000\001\015\000\000\004J\000\000\000\000\000\000\001\021\001\"\001(\000\000\001\029\000\000\002Q\004D\004\021\000\000\004N\000\000\004L\000\000\000\000\000\000\000\000\000\000\002R\000\000\002\138\000\231\000\000\001,\000\000\000\000\000\000\000\000\004J\000\000\000\000\001 \001\015\000\000\000\000\000\000\004J\001(\001\021\001\"\004\021\000\000\004M\001\029\004L\004J\004D\000\000\004\021\001<\004K\000\000\004L\000\000\000\000\001,\001#\004\021\000\000\004W\004\159\004L\000\000\001,\000\000\000\000\000\000\001\015\001\029\000\000\001 \001\030\001,\001\021\001\"\000\000\004F\000\000\000\000\000\000\000\000\002\139\000\000\001,\000\000\000\000\001F\001<\000\000\002\140\001\029\001\135\002\141\001\030\001#\001 \000\000\000\000\004\176\000\000\001\029\000\000\000\000\001\030\000\000\000\000\001\015\000\000\000\000\000\000\000\000\000\000\001\021\004I\000\000\004F\000\000\001 \000\000\000\000\000\000\001,\001<\000\000\001F\000\000\000\000\001 \000\000\001#\000\000\001\029\000\000\004\207\001\030\000\000\000\000\000\000\000\000\000\000\001(\000\000\000\000\000\000\001\029\001\015\000\000\001\030\000\000\000\000\000\000\001\021\004I\000\000\000\000\000\000\001,\000\000\001 \001F\000\000\000\000\001(\001\029\000\000\000\000\001\030\000\000\004J\000\000\001\015\001 \001(\000\000\000\000\000\000\001\021\001\"\000\000\000\000\004\021\000\000\005\015\000\000\004L\000\000\000\000\000\000\001\029\000\000\001 \001\030\001\015\000\000\000\000\001,\000\000\000\000\001\021\001\"\000\000\000\000\001\015\001(\000\000\000\000\000\000\004J\001\021\001\"\000\000\000\000\000\000\000\000\000\000\001 \001(\000\000\000\000\004\021\000\000\005'\000\000\004L\000\000\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\001\015\001,\001(\006>\000\000\000\000\001\021\001\"\000\000\000\000\000\000\000\000\000\000\001\015\001<\000\000\000\000\000\000\000\000\001\021\001\"\001#\000\000\000\000\001<\006C\001,\001(\000\000\001F\000\000\001#\001\015\000\000\000\000\006\143\000\000\000\000\001\021\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\001F\000\000\000\000\000\000\001<\000\000\001\015\001,\000\000\000\000\001F\001#\001\021\001\"\000\000\006\147\000\000\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\006\196\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001<\000\000\001,\000\000\000\000\001F\000\000\001#\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\001F\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\001#\000\000\001,\000\000\000\000\001\236\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\0039")) + ((16, "\000)\001Q\000S\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\000\000\000\000\000_\000<\000\026\000\251\0001\t\152\000\000\000\000\000\233\000-\t\248\000\181\001\204\nj\000\000\000\000\000\000E\006\000=\003\012\000\025:>\000\000\000\000\000\000\000\000\000\000\000\000\000\00072\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\003<\000\210\000\000\000\000\000\000\000\000\000\221\000\000\004\1581\226\000d\004\178\000@\001H\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\244\000\000\000\000\000\000\000\000\000\000\001@\000\000\000\000\000\000\001\146\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\018\000\000\000\000\002>\000\000\000\000\000\000\000\000\000\000\000\000\000\000/\022\002B\000\000\002V\004\180\001H\000\000\000\000\005t\000k\000\000\005\168\0060\002\166\005\174\000 \000\000\000\000\000\000\000\228\000\000\000\000\002p\000\000\000\000\000\000\000\000\004\016\000\000\003<\000\000\000\000\000\000\000\000\000\000\000>\000\000\003\236\004|\000\128\000\000\003\242/\022\000\000\006\204\000\000\001\188\000\0000\\\000\194\001|\007\174\000\000\000\000\000\000\003B\003\132\005\252\001(\003\138\006\140$\146\003\222\006\144\000\243\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007n\000\000\000\000\000\000\004H\007x\n\166\004\154\007z\n\200\b\154E\006\011v\000\000$\232\004\250\b6\005\246\000\0004\2207\1588$\000\000\000u\000\000\000\000\000\000\005\208>,\006\b\000\000:\138\006t\000\000:\222A\218\000\143\000\000\000\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000;\016\005\244\000\000\000\000\000\000\b\194\000\000\001\216\000\000\000\000\004\020\001j\000\000\000\000\011\b\000\000\t\244\000\000\004\020\002\206\004\020\000\000\000\000\000\000\000\000\000\000B \000\000\bf\007\152\000\000:r\t\b\002\246\000\000\000\000\000\000\007B\000\000\000\000\000\000\000\000\007<\000\000\000\000\000\000\000\000\000\000;\146\000\000\000\000\000\000\000\000\000\000\000\000\001\024\b\012\000\000\000\000\000\000\007<\bH;\216\007\248\t.\012\026\000\000\005*\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\236\000\000\000\000\000\000\000\000\t0f\007\232\000T\000\000\007\232\007\232\000\000\000\000\007\232\000\0008$\000\000\000\000\000\000\007\2328>\000\000\000\000\007\232\000\000\006\004\t\014\000\000\000\000\000\000\000\000\000\000\000\000>\\\000\000\b\162\000\000J2\007<\000\000\000\000\000\000\000\000\b\188\tF\011\1744\238B\254\t\132\000\000\004n\007\232Jt\007<\tl\000\000\000\000\000\000\000\00072\t\222\000\0008bH\206\000\000\012b\tV\t\138\t\158\t<\007\214\t\170\001\132\nR\000\000\000\000\001J\002\184\000\000\002\228\t\182\002\160\t\234\000\000\000\000\004\210\000\000\0024\000$\002\212\000\019\011T\000\000\000\0009\000\000\000P\138\n\248\000\000J\154\007\154\000\000KD%\156\n\190\t\184KR\n\204\t\232\rf\n\208\t\242\r\196\n\224\t\244\00268\170\007\232\014\026\n\248\n\002F\25472\011\156\000\000C\024\014r\011\028\n\018?f\007\232\014\200\011$\n\022?\172\007\232\015&K\140\000\000\000\000\000\000\000\000\000\000\001N\b\240\000\000\000\000\000\000\011D\n \t\194\001\172\015\132\0024\000\000\000\000\000\0004\238\000\000K\150\007<\015|\011R\nXK\154\000\000K\180\000\000\000\000\015\212%\244\000\"\000\000\000\000\012\172K\186\007<3\028\007\003\160\014\136\011\198\014\202\000\000\017\168\007L\014\148\000\000\000\000\000(\0046\n\198\000\000\017\216\0024\n\246\000\000\005`\000\000\014J\011\238\018\\\007\190\000\000\014T\011\242\tB\r&\014h\014r\012\028\016\000\000\000\014\174\004\178\000\000\000\000\000\000\000\000\002\n\012B\014\142M\022\007<\000\000\004X\012T\015J\000\000\000\000\000\000\000\000\000\000\000\000M&\b\218\000\000\012Z\015\164\000\000\000\000\000\000\000\000\000\000\000\000G4\011\030\000\000\012j\005\168\000\000\012\128\012\132\004\180\000\000\006\026Hl\000\000\006\140\000\000M6\007<\007<\000\000\000\000\tP\000\000\005\146\000\000\007\254\tP\tP\000\000\012\152I\n\007\022\000\000\012\216\000\000M\244A \007<\000\000N4\014:\000\000ND\000\000\000\000\000\000\tP\000\000\000\000\012\180\015t\012\214\016\170\015Z\000\000\000\000NV\012\248\015\154\000\000\000\000\000\0003V\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\002\000\000\015\168\r\b\006\162\000\000\016\178\016j\r&\015\202\000\000\000\000\015\208\r\014\006\186\000\000\000\000/&\016\132\r0\015\232\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007<\015\150\rL\016\250\015\166\000\000-@\000\223\rT\015z\007D\000\178\rZ\0168\000\000\016\236\018\238\000\000\000\000\019L\000\000\r\134\000\000\003l\000\000\000\000\000\000\000\000\000\000\000\000Nl\007<\000\000\016\238\019\162\000\000\000\000\019\250\000\000\000c\rd\016\150\000\000C4GX\016P\000\000N\184\007<\020P\000\000\000\000\020\174\000\000\000\000\000\0009$\000\000\021\004\000\000\000\000\000\000\r\184\000\000\004\136\000\000\000\000\000\000\000\000\000\000\000\000Gt\000\000\000\000CrH.\016Z\000\000N\254\007<\021\\\000\000\000\000\021\178\000\000\000\000\r~\022\016\r\194\000\000\r\138\r\144\002~\005\180\r\164\bJ\r\206\016\1845x\r\232\000\000\r\222\014\014\n.\000\000\007\nI0\000\000\000]\000\000\014\020C\128C\184\011\152\015\150\012\128\000\000H\002N\158\000\000\000\000I\212\000\000\000\000\000\000\006p\000\000\000\000\006p\000\000\000\000\006p\nH\000\000\012\250\006p\016\1985\170\014>\000\000\006p\000\000OL\000\000\000\000\006p\000\000\000\000\014f\000\000\014\\\n\164\014l\000\000\014XIB\014\234\000\000\000\000\000\000\014\248\000\000\000\000\b\150\000\000\006pO\154\000\000\015\190\006pD\134\000\000\015\016\0160\014j\017R\015\254\000\000D\204\015\026\016>\000\000\000\000\000\000C\240\tV\014\130\016\2345\228\015\"\000\000\000\000\000\000\000\000\000\000\000\000\0116\000\000\000\000\011B\000\000\0158\000\000\016R\000\000\000\000\000\000\000\000\015>D\000\000\000\000\000\000\000\0116\000\000\011B\000\000\000\000\000\000\000\000\000\000\011N\022f\000\000\000\000\022\190\000\000\000\000\000\000\000\000\023\020\000\000\000\000\011N\023r\000\000\023\200\000\000\000\000\024 \000\000\000\000\000\000\000\000\024v\000\000\000\000/\190\011N\024\212\000\000\000\0000,\011N\025*\000\000\000\0000x\011N\007\138\025\130\000\000\000\0000\202\011N\025\216\000\000\000\0001r\011N\0266\000\000\000\0001\174\011N\000\000\000\000\026\140\000\000\000\0002\016\011N\026\228\000\000\000\0002h\011N\027:\000\000\000\0003\"\011N\000\0003n\011NI\212\011N\000\000\000\000\027\152\000\000\000\000\027\238\000\000\000\000\000\000\011`\028F\000\000\000\000\028\156\000\0009r\000\000\000\000K\140\000\000\000\000\028\250\000\000\000\000\000\000\029P\000\000\000\000\000\000\017\028\000\000\000\000A|\000\000\004\136\000\000\003:\000\000\016\182\000\000\b2\000\000\000\000\000\000\000\000\000\000\001N\000\000\000\000\016\016\000\000\000\000\029\168\000\000\029\254\000\000\000\000\000\000\030\\\000\000\000\000\030\178\016\020\031\n\000\000\031`\000\000\000\000\000\00072\016\182\000\000EL\007&\004\020\031\190\000\000EV\000\000\000\000\000\000E\136\000\000\000\000 \020\000\000 l\000\000\000\000\000\000\000\0009\220\000\000\000\000\000\0003\144\011N3\220\011N\000\000\000\000\000\000\000\000\011N\000\000\000\000\000\000\000\000\011N\000\000\017D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014\174\012X\001\172 \194\000\000\016.\014\182\016\184\011\236\000\000! \000\000\016:\014\188\t\236\016V\014\198\000\000!v\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0003\028\016\220\000\000O\204\007\000\188\001}\004v\001\244\001\251\002\246\002\137\004\245\001\255\001~\001\021\001\135\001j\001\029\000\227\003\020\006\137\000\231\001\002\002\247\005E\001b\001c\002\246\002\139\002\"\001\015\005D\001\170\005F\000\234\004\023\001\021\001\024\000\219\001#\002U\004\247\002\141\000\231\001 \001d\001s\004\024\001f\001g\005\023\004\031\005X\002\148\001\012\002\000\004\248\001\005\001\028\005Y\000\234\004\255\001\029\000\234\003t\005\015\003]\005E\006e\003N\002\001\002\139\000\231\001\015\005Z\006\243\005F\0037\003\144\001\021\001\"\003\004\006\133\002U\005L\002\141\000\231\001\015\001t\005N\001u\002<\004\023\001\021\001\024\005X\002\148\002\246\007A\003\t\005P\003\172\000\234\002\142\004\024\002\152\002\246\001\021\004\025\003\176\000\222\002\158\000\225\001\135\002\144\001\021\005Q\005Z\002\246\001\015\005:\001{\002Q\002R\001c\001\021\001\"\005L\003m\003D\003F\002\246\005N\001l\002\160\001#\000\231\002q\005;\002!\006\164\005B\001\135\005P\006\t\002r\002\142\0037\002\152\000\227\005C\006w\000\231\000\232\002\158\004^\001\135\002\144\002\137\005Q\005\001\004\019\006\131\005g\001\015\001\029\000\231\001\002\001\030\003\016\001\021\001\"\003z\003{\000\234\002\246\000\234\002\160\003)\005D\001\015\001#\004\245\004_\004\129\004`\001\021\001\"\002\246\003\131\006v\003\190\001 \003\132\003b\005!\001}\001\021\003\128\003D\003F\0019\005u\003\202\001~\002\246\001\135\001j\001,\007+\002R\001c\004\247\005\150\004a\005E\000\231\001\002\005\213\002\139\0007\002\024\005#\000\235\005F\001@\001#\004\248\000\240\000\243\006\244\002U\004\255\002\141\000\231\006\183\005\006\001(\005%\001\015\002Q\002R\001c\005X\002\148\001\021\001\024\003S\002%\004b\006z\002#\005\167\005\246\000\231\002q\002\246\002\"\004c\004d\003\219\004e\001E\002r\005&\005Z\001T\001\015\001\029\006\\\001\250\001\030\001\015\001\021\001\"\005L\002\137\003a\001\021\001\024\005N\002\246\001\165\002Q\002R\001c\004\130\000\234\002Q\002R\001c\005P\000\234\000\234\002\142\001 \002\152\000\227\002q\002\246\000\231\001\002\002\158\002q\001\135\002\144\002r\005Q\002\024\002\246\004g\002r\005\191\006\143\002$\004i\004s\007\003\007,\002\137\002\141\000\231\001<\000\251\002\137\002\160\004~\001\250\003y\001#\002\246\000\146\001Z\004\131\004\023\002\025\005\208\002\139\002#\001\163\001(\000\231\004\127\001q\006\170\006\171\004\024\001C\001z\002U\004\030\002\141\000\231\003\143\006\172\006\173\001,\002\246\001\131\001F\001\130\002\145\002\148\007\005\005'\006\174\003b\002Q\002R\001c\001\015\003\158\001\015\003\162\000\146\006\144\001\021\001\"\001\021\001\024\002\139\003\161\002q\002\149\0037\002\139\001\169\000\234\0037\002\246\002r\005#\002U\001\180\002\141\000\231\006\214\002U\004\227\002\141\000\231\002$\003\252\002\137\002\145\002\148\001\185\005%\006:\002\145\002\148\000\234\002\142\002\246\002\152\002Q\002R\001c\002\246\001\199\002\158\001\029\001\135\002\144\001\030\001/\002\149\001\196\001A\003\173\002q\002\149\001#\005&\004\023\003\136\003D\003F\002r\006\152\003D\003F\001\227\002\160\006\207\002\003\004\024\001[\001 \001r\0047\002\137\001\251\006\202\001\211\002\142\001\255\002\152\001\021\001,\002\142\004 \002\152\002\158\002\139\001\135\002\144\002\024\002\158\001E\001\135\002\144\002Q\002R\001c\001\015\002U\001\015\002\141\000\231\005#\001\021\001\"\001\021\001\"\0040\002\160\002q\002\145\002\148\0048\002\160\000\234\001(\002^\002r\005%\002#\001\202\002\000\000\231\006\204\002Q\002R\001c\003\223\003b\005=\002\137\001\213\002\149\000\234\002\139\000\234\002\001\001\222\0021\002q\000\234\002Q\002R\001c\005&\001\015\002U\002r\002\141\000\231\004\026\001\021\001\"\006c\003N\006\"\002q\000\231\002\145\002\148\002\137\002\142\0024\002\152\002r\001\210\002\024\0027\002:\002\158\006`\001\135\002\144\004\235\004\026\002@\000\231\002\137\006\180\004\026\002\149\001\029\002$\002H\001)\002M\005\b\001\216\002\246\000\231\002]\002\139\002\160\002\254\001\224\000\234\002#\002\246\002\246\000\231\001+\000\234\000\234\002U\001\237\002\141\000\231\001#\001 \002\142\005\027\002\152\0061\003b\001\239\002\145\002\148\002\158\002k\001\135\002\144\002\139\002\246\001\254\002\208\006\176\000\234\001\135\002Q\002R\001c\000\234\000\234\002U\001,\002\141\000\231\002\149\002\139\000\234\002\160\002\241\002\246\002q\002\250\002\145\002\148\000\234\002\024\000\234\002U\002r\002\141\000\231\000\234\003\006\002Q\002R\001c\002$\003\177\006Q\002\145\002\148\002\137\003\023\002\142\002\149\002\152\003\191\003\208\002q\006\162\003b\002\158\003\002\001\135\002\144\002#\002r\001\015\000\231\000\234\001\015\002\149\0069\001\021\001\"\000\234\001\021\001\"\002\015\002\137\006\029\003\212\003\028\002\142\002\160\002\152\003-\003>\006\025\003@\002\024\002\158\000\234\001\135\002\144\000\234\0020\003R\001b\001c\002\142\004\007\002\152\0023\003`\0026\000\234\005\001\002\158\002\246\001\135\002\144\002\139\0029\002\160\003f\000\234\003\024\001d\001e\002#\001f\001g\000\231\002U\002?\002\141\000\231\002$\003s\002C\002\160\001#\002Q\002R\001c\002\145\002\148\003\134\001\029\002\139\000\227\001\030\002G\000\231\000\232\000\234\002L\002q\003\171\000\234\000\234\002U\000\234\002\141\000\231\002r\001\227\002\149\001,\002\005\000\234\0066\002\\\002\145\002\148\001 \001\251\000\234\002\137\002j\001\255\003\175\001\021\004\245\003\181\002Q\002R\001c\000\234\002|\004'\006+\002$\005H\003\187\002\149\002\142\003\198\005l\005K\002q\002\157\000\234\001k\002\158\002\246\001\135\002\144\002r\001\029\002\225\000\234\004C\004\247\006!\001l\002\024\003\217\000\231\003\222\001(\002\137\000\234\002\000\002\142\002\249\002\152\002\160\004\248\002Q\002R\001c\002\158\004\255\001\135\002\144\001 \005\003\002\001\002\139\003\227\002\246\002\240\006$\002q\000\234\002#\003\011\000\234\000\231\001\015\002U\002r\002\141\000\231\002\160\001\021\001\"\000\234\003\237\002\242\000\234\006\031\002\145\002\148\002\137\000\227\002\245\003\243\000\231\000\232\003\254\002Q\002R\001c\002\246\003\014\004+\001}\004\t\002\246\000\234\002\139\000\234\002\252\002\149\001\134\002q\001\135\001j\004\027\003\r\004\r\003\007\002U\002r\002\141\000\231\002\246\004\245\003\n\006\016\004\"\002\246\000\234\006\139\002\145\002\148\002\137\002$\0042\001\015\001#\004S\002\142\004<\002\152\001\021\001\"\002Q\002R\001c\002\158\000\234\001\135\002\144\002\139\000\227\002\149\004\247\000\231\000\232\000\234\004U\002q\000\234\003\022\003\027\002U\001,\002\141\000\231\002r\000\234\004\248\002\160\002\246\004[\006\n\004\255\002\145\002\148\004h\005\000\000\234\002\137\000\234\002\142\004k\002\152\004\245\004u\002Q\002R\001c\002\158\000\234\001\135\002\144\002\139\004p\002\246\002\149\001#\000\234\004{\002\246\002q\003!\000\234\003(\002U\003'\002\141\000\231\002r\001\029\003,\002\160\004J\004\247\005\255\004\134\002\145\002\148\002\246\004\140\000\234\002\137\004\144\001,\002\142\003_\005l\004\172\004\248\002Q\002R\001c\002\158\004\255\001\135\002\144\001 \005\n\002\149\002\139\004\218\004\153\003e\003r\002q\000\234\005\025\003v\000\234\004\223\003x\002U\002r\002\141\000\231\002\160\003\133\003\142\005\240\005\011\003\147\002\246\003\159\002\145\002\148\002\137\004\194\002\142\003\157\002\152\003\160\004\220\002Q\002R\001c\002\158\003\164\001\135\002\144\000\234\004\228\002\246\002\139\000\234\002\246\002\149\000\234\002q\005\007\001\227\004\231\000\234\002\031\003\174\002U\002r\002\141\000\231\002\160\001\251\003\170\005\229\002\024\001\255\000\234\001\021\002\145\002\148\002\137\003\186\000\234\001\015\004\234\000\234\002\142\004\242\002\152\001\021\001\"\002Q\002R\001c\002\158\000\234\001\135\002\144\002\139\000\227\002\149\006W\000\231\000\232\002#\005\014\002q\000\231\003\180\003\182\002U\003\205\002\141\000\231\002r\003\193\000\234\002\160\002\000\002\246\005\221\005\030\002\145\002\148\000\234\005\024\002\246\002\137\005\028\002\142\0052\002\152\004\245\002\001\002Q\002R\001c\002\158\002\246\001\135\002\144\002\139\005>\002\246\002\149\001#\003\204\002\246\000\234\002q\003\199\000\234\003\203\002U\003\216\002\141\000\231\002r\002\246\003\221\002\160\002\246\004\247\005\180\006#\002\145\002\148\002$\006)\004;\002\137\0060\001,\002\142\003\226\002\152\0063\004\248\002Q\002R\001c\002\158\004\255\001\135\002\144\000\234\005\026\002\149\002\139\002\246\002\246\005 \002\246\002q\000\234\006V\006t\003\229\005$\003\233\002U\002r\002\141\000\231\002\160\003\241\000\234\003\248\006~\004\003\0050\005\172\002\145\002\148\002\137\0057\002\142\004:\002\152\005A\002\246\002Q\002R\001c\002\158\0043\001\135\002\144\000\234\006\128\005M\002\139\000\234\005T\002\149\000\234\002q\006\165\001\227\006\177\000\234\002`\0044\002U\002r\002\141\000\231\002\160\001\251\0049\002\135\002\024\001\255\002\246\001\021\002\145\002\148\002\137\004=\000\234\000\234\006N\006x\002\142\006\191\002\152\004>\004]\002Q\002R\001c\002\158\000\234\001\135\002\144\002\139\000\227\002\149\006u\000\231\000\232\002#\004V\002q\000\231\004W\004\\\002U\004r\002\141\000\231\002r\0074\000\234\002\160\002\000\002\246\002\147\004n\002\145\002\148\000\234\004o\000\234\002\137\004q\002\142\004}\002\152\004\245\002\001\002Q\002R\001c\002\158\004z\001\135\002\144\002\139\004|\004\133\002\149\004\135\004\136\004\141\007?\002q\004\145\004\149\004\167\002U\004\173\002\141\000\231\002r\001\227\004\177\002\160\002\244\004\247\002\151\004\208\002\145\002\148\002$\001\251\004\229\002\137\005\002\001\255\002\142\001\021\005l\005\012\004\248\002Q\002R\001c\002\158\004\255\001\135\002\144\0059\005,\002\149\002\139\0053\0054\007D\0058\002q\005?\001\227\005O\005\202\003\000\005\211\002U\002r\002\141\000\231\002\160\001\251\005\224\002\166\005\235\001\255\005\243\001\021\002\145\002\148\002\137\002\000\002\142\006\027\002\152\006(\006*\002Q\002R\001c\002\158\006/\001\135\002\144\0062\006?\002\001\002\139\006U\006^\002\149\006\160\002q\006\182\007&\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\001\227\000\000\002\165\003\184\002\000\000\000\000\000\002\145\002\148\002\137\001\251\000\000\000\000\000\000\001\255\002\142\001\021\002\152\000\000\002\001\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\001\227\002q\000\000\003\195\000\000\002U\000\000\002\141\000\231\002r\001\251\000\000\002\160\000\000\001\255\002\213\001\021\002\145\002\148\000\000\000\000\000\000\002\137\002\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\001\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\001\227\000\000\002\160\003\201\002\000\002\216\000\000\002\145\002\148\000\000\001\251\000\000\002\137\000\000\001\255\002\142\001\021\002\152\000\000\002\001\002Q\002R\001c\002\158\001\227\001\135\002\144\003\210\000\000\002\149\002\139\000\000\000\000\000\000\001\251\002q\000\000\000\000\001\255\000\000\001\021\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\002\237\000\000\000\000\000\000\000\000\002\145\002\148\002\137\002\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\001\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\002\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\001\227\000\000\004\148\003\218\000\000\000\000\002\001\002\145\002\148\002\137\001\251\000\000\000\000\000\000\001\255\002\142\001\021\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\001\227\002q\000\000\006Z\000\000\002U\000\000\002\141\000\231\002r\001\251\000\000\002\160\000\000\001\255\004\151\001\021\002\145\002\148\000\000\000\000\000\000\002\137\002\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\001\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\001\227\000\000\002\160\006i\002\000\004\166\000\000\002\145\002\148\000\000\001\251\000\000\002\137\000\000\001\255\002\142\001\021\002\152\000\000\002\001\002Q\002R\001c\002\158\001\227\001\135\002\144\006l\000\000\002\149\002\139\000\000\000\000\000\000\001\251\002q\000\000\000\000\001\255\000\000\001\021\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\004\169\000\000\000\000\000\000\000\000\002\145\002\148\002\137\002\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\001\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\002\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\001\227\000\000\004\181\006o\000\000\000\000\002\001\002\145\002\148\002\137\001\251\000\000\000\000\000\000\001\255\002\142\001\021\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\004\184\000\000\002\145\002\148\000\000\000\000\000\000\002\137\002\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\001\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\004\190\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\004\212\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\004\215\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\004\219\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\005b\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005e\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\005j\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005n\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005p\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\005s\002\145\002\148\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\005x\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005}\000\000\000\000\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\130\000\000\000\000\002\137\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\136\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\141\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\005\146\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\153\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\005\158\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\005\163\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\175\000\000\000\000\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\178\000\000\000\000\002\137\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\183\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\186\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\195\000\000\000\000\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\199\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\225\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\227\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\005\231\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\005\234\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\236\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\238\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\005\248\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006\001\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006\004\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006&\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006-\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\0065\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006C\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006H\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006K\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006\211\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006\213\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006\216\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006\221\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006\223\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\006f\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\006O\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\006\024\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\006\019\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\005\171\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\005`\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\154\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\156\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\161\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\168\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\170\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\172\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\174\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\176\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\178\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\180\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\182\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\184\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\186\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\188\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\190\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\192\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\001b\001c\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\001d\004\186\000\000\001f\001g\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\194\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\196\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\001k\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\001l\002\160\000\000\000\231\000\000\004^\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\198\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\004_\002q\004`\000\000\005-\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\200\000\000\000\000\000\000\001}\004a\002\158\001\029\001\135\002\144\001\030\000\000\001\134\002\139\001\135\001j\002\149\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002U\005/\002\141\000\231\002\160\000\000\000\000\000\000\000\000\001 \000\000\001\029\002\145\002\148\001\030\004b\000\000\000\000\000\000\000\000\002\142\000\000\002\202\000\000\004c\004d\003t\004e\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\000\000\001\029\002\160\004\128\001\030\001(\003t\002\145\002\148\001\029\000\000\000\000\001\030\000\000\002\142\000\000\002\204\000\000\000\000\003w\000\000\000\000\002\158\000\000\001\135\002\144\000\000\004g\001 \002\149\006\140\000\000\004i\004s\001(\001\015\001 \000\000\000\000\000\000\000\000\001\021\001\"\004~\000\000\002\160\000\000\000\000\003\156\000\000\000\000\000\000\000\000\003t\000\000\000\000\000\000\000\000\002\142\004\127\002\206\000\000\000\000\000\000\001\015\000\000\002\158\000\000\001\135\002\144\001\021\001\"\000\000\001(\000\000\000\000\000\000\002Q\002R\001c\000\000\001(\000\000\000\000\000\000\003z\003{\000\000\000\000\002\160\001<\000\000\002q\000\000\000\000\004y\000\000\001#\000\000\000\000\002r\003|\003\140\001\015\000\000\000\000\003\132\003b\000\000\001\021\001\"\001\015\000\000\002\137\003z\003{\000\000\001\021\001\"\001<\000\000\000\000\000\000\000\000\001,\000\000\001#\001F\000\000\000\000\003|\003\140\002Q\002R\001c\003\132\003b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\001,\000\000\002r\001F\000\000\001<\000\000\000\000\003z\003{\000\000\001\029\001#\001<\001\030\002\137\006\147\002Q\002R\001c\001#\002\139\000\000\000\000\003|\003\140\000\000\000\000\000\000\003\132\003b\000\000\002q\002U\000\000\002\141\000\231\000\000\001 \001,\002r\000\000\001F\000\000\000\000\002\145\002\148\001,\003:\000\000\001F\000\000\000\000\002\137\000\000\000\000\000\000\000\000\002Q\002R\001c\000\000\006}\000\000\000\000\000\000\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\002\139\000\000\000\000\000\000\000\000\002r\000\000\001(\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\000\000\002\137\000\000\002\142\000\000\005{\000\000\002\145\002\148\000\000\000\000\002\158\000\000\001\135\002\144\000\000\000\000\000\000\000\000\000\000\001\015\002\139\000\000\000\000\000\000\000\000\001\021\001\"\000\000\002\149\000\000\000\000\000\000\002U\002\160\002\141\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\002Q\002R\001c\000\000\000\000\000\000\000\000\000\000\000\000\002\142\000\000\005\128\000\000\002\139\000\000\002q\000\000\002\158\002\149\001\135\002\144\000\000\000\000\002r\000\000\002U\001<\002\141\000\231\000\000\002Q\002R\001c\001#\000\000\000\000\002\137\002\145\002\148\000\000\002\160\000\000\000\000\000\000\000\000\002q\000\000\002\142\000\000\005\133\000\000\000\000\000\000\002r\004^\002\158\000\000\001\135\002\144\002\149\001,\000\000\000\000\003A\000\000\000\000\002\137\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\160\002Q\002R\001c\004_\006\192\004`\000\000\000\000\000\000\002\142\000\000\005\139\000\000\000\000\000\000\002q\000\000\002\158\002\139\001\135\002\144\000\000\000\000\002r\000\000\000\000\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\004a\000\000\002\137\000\000\000\000\000\000\002\160\000\000\002\145\002\148\002Q\002R\001c\000\000\002\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002q\002U\000\000\002\141\000\231\002\149\000\000\000\000\002r\000\000\004b\000\000\000\000\002\145\002\148\000\000\000\000\000\000\000\000\004c\004d\002\137\004e\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\149\005\144\000\000\002\139\000\000\000\000\000\000\002\158\000\000\001\135\002\144\000\000\004\130\000\000\000\000\002U\000\000\002\141\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\142\002\160\005\149\000\000\000\000\000\000\000\000\004g\002\158\000\000\001\135\002\144\004i\004s\002Q\002R\001c\000\000\002\139\001\029\002\149\000\000\001\030\004~\000\000\000\000\000\000\000\000\000\000\002q\002U\002\160\002\141\000\231\000\000\000\000\000\000\002r\004^\004\127\000\000\000\000\002\145\002\148\000\000\000\000\001 \000\000\000\000\002\142\002\137\005\156\002Q\002R\001c\000\000\006D\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\149\000\000\004_\002q\004`\002Q\002R\001c\000\000\000\000\000\000\002r\000\000\000\000\000\000\000\000\002\160\000\000\000\000\000\000\002q\000\000\000\000\000\000\002\137\000\000\000\000\001(\002r\002\142\000\000\005\161\000\000\004a\000\000\000\000\000\000\002\158\000\000\001\135\002\144\002\137\000\000\002Q\002R\001c\000\000\002\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\015\002q\002U\002\160\002\141\000\231\001\021\001\"\000\000\002r\000\000\004b\000\000\000\000\002\145\002\148\000\000\000\000\000\000\000\000\004c\004d\002\137\004e\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\149\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\002\139\000\000\000\000\004f\000\000\000\000\000\000\002\145\002\148\000\000\001<\000\000\002U\000\000\002\141\000\231\000\000\001#\000\000\000\000\002\142\002y\005\166\000\000\002\145\002\148\000\000\004g\002\158\002\149\001\135\002\144\004i\004s\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\000\000\004~\001,\000\000\002\149\001F\000\000\000\000\002U\002\160\002\141\000\231\000\000\000\000\000\000\000\000\002\142\004\127\005\169\000\000\002\145\002\148\000\000\000\000\002\158\000\000\001\135\002\144\001\174\001c\000\000\000\000\000\000\002\142\000\000\006\012\000\000\001\188\001c\000\000\000\000\002\158\002\149\001\135\002\144\000\000\000\000\002\160\002\209\001s\000\000\001f\001g\000\000\001\174\001c\000\000\001d\002e\000\000\001f\001g\000\000\000\000\002\160\000\000\000\000\000\000\000\000\000\000\000\000\002\142\000\000\006\014\002\209\001s\000\000\001f\001g\002\158\000\000\001\135\002\144\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\214\002\226\002\227\000\000\000\000\000\000\000\000\000\000\000\000\005\181\002\226\002\227\002\160\000\000\000\000\000\000\001\174\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\214\002\226\002\227\000\000\000\000\000\000\000\000\000\000\001{\000\000\002\209\001s\000\000\001f\001g\001\174\001c\001{\000\000\000\000\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001{\002\209\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001\174\001c\001l\000\000\000\000\000\231\000\000\000\000\002\214\002\226\002\227\002\230\006M\000\000\000\000\005\184\005\189\000\000\000\000\000\000\002\209\001s\000\000\001f\001g\005:\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\214\002\226\002\227\000\000\002\230\002\231\001}\007:\000\000\001{\007;\000\000\000\000\005B\001~\001}\001\135\001j\000\000\000\000\000\000\001l\005C\001~\000\231\001\135\001j\000\000\000\000\002\214\002\226\002\227\001}\000\000\001{\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\135\001j\000\000\000\000\001l\000\000\000\000\000\231\000\000\005D\000\000\000\000\000\000\000\000\002\230\004\230\000\000\000\000\000\000\000\000\000\000\001{\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\001b\001c\002\230\005\r\000\000\001}\001d\001s\005E\001f\001g\000\000\000\000\001~\000\000\001\135\001j\005F\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\006\206\001}\002\230\005@\000\000\000\000\000\000\005G\002\148\001~\007=\001\135\001j\000\000\006\209\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\002<\000\000\000\000\001b\001c\000\000\005J\001}\000\000\000\000\000\000\001t\000\000\001u\002<\001~\005L\001\135\001j\000\000\000\000\005N\000\000\001d\001s\000\000\001f\001g\000\000\000\000\001{\000\000\005P\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\001{\000\231\000\000\000\000\005Q\000\000\000\000\000\000\000\000\006\t\000\000\000\000\001l\001b\001c\000\231\000\000\000\000\000\000\000\000\000\000\000\000\001t\006\t\001u\001\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\001\172\000\000\000\000\000\000\000\000\000\000\000\146\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\001l\000\000\001~\000\231\001\135\001j\000\000\000\000\001}\001t\000\000\001u\001\160\001b\001c\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001{\001\158\001b\001c\001d\001s\000\000\001f\001g\000\000\000\000\004\188\001l\000\000\001\162\000\231\000\000\000\000\000\000\004\191\000\000\001}\001d\004\186\000\000\001f\001g\000\000\000\000\001~\000\000\001\135\001j\000\000\001t\000\000\001u\001\160\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\001\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\001l\001{\000\000\000\231\001~\000\000\001\135\001j\000\000\001\029\000\000\000\000\001\030\001l\000\000\000\000\000\231\000\000\000\000\001k\001b\001c\001t\000\000\001u\002<\000\000\000\000\000\000\004\188\000\000\001l\000\000\000\000\000\231\000\000\001 \004\191\000\000\000\000\001d\004\186\000\000\001f\001g\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\001\188\001c\000\000\000\000\001}\000\000\000\000\000\000\001l\004\187\000\000\000\231\001~\000\000\001\135\001j\000\000\001}\000\000\006\005\001d\002e\001(\001f\001g\001~\000\000\001\135\001j\000\000\0067\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\001\015\001b\001c\000\000\000\000\001k\001\021\001\"\000\000\000\000\005\181\002\226\002\227\000\000\000\000\000\000\000\000\001l\000\000\001}\000\231\001d\001s\000\000\001f\001g\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\001b\001c\000\000\000\000\004\187\001<\001l\001d\001s\000\231\001f\001g\001#\000\000\001t\000\000\001u\002<\000\000\000\000\001d\001s\000\000\001f\001g\004\192\000\000\000\000\000\000\000\000\001}\000\000\000\000\001\029\000\000\000\000\001\030\005\188\001\134\001,\001\135\001j\001\236\000\000\000\000\001\029\000\000\001{\001\030\000\000\001t\0010\001u\007\027\000\000\007\029\000\000\000\000\000\000\001l\001 \000\000\000\231\001t\000\000\001u\006\196\000\000\001:\001}\006\b\0011\001 \000\000\000\000\000\000\000\000\001~\001O\001\135\001j\000\000\000\000\001{\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\0010\000\000\001l\001{\000\000\000\231\000\000\000\000\000\000\000\000\000\000\000\000\001(\000\000\000\000\001l\000\000\000\000\000\231\001\029\0011\001 \001\030\000\000\001(\0010\000\000\001M\000\000\001}\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\135\001j\0016\001\015\000\000\000\000\0011\001 \000\000\001\021\001\"\000\000\000\000\0012\000\000\001\015\000\000\000\000\000\000\000\000\000\000\001\021\001\"\000\000\000\000\000\000\001}\001(\000\000\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\135\001j\000\000\001}\000\000\000\000\000\000\000\000\0016\001\029\000\000\001~\001\030\001\135\001j\0010\001(\000\000\000\000\000\000\000\000\001\015\001<\000\000\000\000\000\000\000\000\001\021\001\"\001#\000\000\000\000\000\000\0016\001<\0011\001 \001b\001c\000\000\000\000\001#\001K\000\000\000\000\001D\001\015\000\000\000\000\000\000\004^\000\000\001\021\001\"\000\000\000\000\001,\001d\001s\001B\001f\001g\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\001F\000\000\000\000\000\000\000\000\001<\000\000\004_\006\229\004`\001(\000\000\001#\000\000\000\000\000\000\001D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0016\000\000\001t\001<\001u\001\164\000\000\000\000\001b\001c\001#\004a\001,\001\015\001D\001F\000\000\000\000\000\000\001\021\001\"\001b\001c\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\001{\000\000\001,\000\000\000\000\001F\001d\001s\000\000\001f\001g\004b\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\004c\004d\000\000\004e\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001<\000\000\000\000\001t\000\000\001u\001\154\001#\000\000\001b\001c\001D\000\000\000\000\000\000\004\130\001t\000\000\001u\001\151\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\001,\000\000\001{\001F\000\000\004g\006\231\000\000\001}\000\000\004i\004s\000\000\000\000\001l\001{\001~\000\231\001\135\001j\000\000\004~\000\000\000\000\000\000\000\000\000\000\001l\001b\001c\000\231\000\000\000\000\000\000\000\000\000\000\000\000\004\127\001t\000\000\001u\001w\001b\001c\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\001d\001s\001}\001f\001g\000\000\000\000\000\000\001l\000\000\001~\000\231\001\135\001j\000\000\001}\001t\000\000\001u\001y\000\000\000\000\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\001t\000\000\001u\001|\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\001\150\000\000\000\000\001{\000\000\000\000\000\000\000\000\001d\001s\001\029\001f\001g\004G\000\000\001l\000\000\001{\000\231\000\000\000\000\001\029\000\000\000\000\001\030\001}\000\000\000\000\000\000\001l\001{\000\000\000\231\001~\000\000\001\135\001j\001 \001b\001c\000\000\000\000\001l\001b\001c\000\231\000\000\006I\001 \000\000\000\000\001t\000\000\001u\001\142\006L\000\000\000\000\001d\004\186\000\000\001f\001g\001d\001s\000\000\001f\001g\002Q\002R\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\004I\000\000\001{\000\000\001~\000\000\001\135\001j\000\000\005\205\001}\001(\000\000\000\000\001l\000\000\005\214\000\231\001~\000\000\001\135\001j\000\000\001}\001t\000\000\001u\001\147\000\000\000\000\001\015\001~\000\000\001\135\001j\000\000\001\021\004L\000\000\006\022\000\000\001\015\000\000\000\000\000\000\000\000\000\000\001\021\001\"\000\000\000\000\000\000\001k\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\002T\000\000\001~\000\000\001\135\001j\001b\001c\000\000\004M\000\000\000\000\005\217\001<\002\141\000\231\001\002\000\000\004\187\000\000\001#\004\024\000\000\004R\001V\004O\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\000\000\000\000\001b\001c\000\000\001}\000\000\000\000\001,\000\000\001}\001F\005\208\001\134\000\000\001\135\001j\000\000\001~\000\000\001\135\001j\001d\001s\000\000\001f\001g\000\000\001b\001c\001t\000\000\001u\002I\001b\001c\002\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\143\000\000\001\135\002\144\001d\001s\000\000\001f\001g\000\000\001d\001s\000\000\001f\001g\000\000\001b\001c\000\000\001{\000\000\001t\000\000\001u\002N\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\002\218\001b\001c\001t\001{\001u\002\220\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\001t\001{\001u\002\222\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\001l\000\000\001}\000\231\000\000\000\000\001l\000\000\000\000\000\231\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\001b\001c\001{\000\000\001t\000\000\001u\002\229\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001}\001d\001s\000\000\001f\001g\000\000\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\001\029\000\000\000\000\001\030\001}\000\000\001G\000\000\001l\000\000\001}\000\231\001~\000\000\001\135\001j\000\000\000\000\001~\000\000\001\135\001j\001t\000\000\001u\002\235\001I\001 \000\000\000\000\000\000\000\000\004\017\000\000\000\000\000\000\001}\000\000\002Q\002R\001c\000\000\000\000\000\000\001~\000\000\001\135\001j\005:\000\000\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\005\205\000\000\007:\000\000\000\000\007;\001l\005\214\005B\000\231\001}\001(\000\000\000\000\000\000\000\000\000\000\005C\001~\000\000\001\135\001j\005:\000\000\000\000\000\000\000\000\000\000\0016\000\000\005\215\000\000\001\029\000\000\000\000\001\030\000\000\007:\001G\000\000\007;\001\015\000\000\005B\000\000\000\000\005D\001\021\001\"\000\000\000\000\000\000\005C\000\000\000\000\000\000\000\000\005:\001I\001 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\001}\001\030\000\000\007:\0010\002T\007;\000\000\001~\005B\001\135\001j\005D\005E\000\000\000\000\000\000\005\217\005C\002\141\000\231\001\002\005F\000\000\0015\001 \000\000\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\001(\000\000\000\000\004F\000\000\000\000\005G\002\148\000\000\007<\000\000\000\000\005D\005E\000\000\000\000\000\000\0016\000\000\000\000\000\000\005\208\005F\000\000\000\000\000\000\001,\000\000\005J\001F\001\015\000\000\000\000\000\000\000\000\001(\001\021\001\"\005L\000\000\000\000\005G\002\148\005N\007@\002\142\000\000\000\000\005E\000\000\000\000\000\000\0016\002\143\005P\001\135\002\144\005F\000\000\000\000\000\000\000\000\000\000\005J\000\000\001\015\000\000\001b\001c\000\000\005Q\001\021\001\"\005L\000\000\000\000\005G\002\148\005N\007E\001b\001c\000\000\000\000\0068\001<\000\000\001d\004\186\005P\001f\001g\001#\000\000\001b\001c\001D\000\000\005J\000\000\001d\004\186\000\000\001f\001g\005Q\000\000\000\000\005L\000\000\000\000\004\185\000\000\005N\001d\004\186\000\000\001f\001g\001,\001<\000\000\001F\000\000\005P\001b\001c\001#\000\000\000\000\000\000\001D\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\005Q\000\000\004\216\000\000\000\000\001d\004\186\000\000\001f\001g\000\000\000\000\001d\004\186\001,\001f\001g\001F\000\000\000\000\001b\001c\000\000\001k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001k\000\000\000\231\000\000\001d\004\186\000\000\001f\001g\005:\000\000\000\000\001l\000\000\001k\000\231\000\000\005:\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\005;\000\000\000\231\005B\000\000\000\000\000\000\000\000\005;\004\187\000\000\005B\005C\000\000\000\000\000\000\000\000\000\000\001k\000\000\005C\000\000\005\249\000\000\000\000\001k\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001}\004\187\001l\000\000\000\000\000\231\005D\005\252\001\134\000\000\001\135\001j\000\000\001}\005D\000\000\000\000\000\000\001k\000\000\000\000\001\134\000\000\001\135\001j\001b\001c\001}\000\000\000\000\001l\000\000\004\187\000\231\000\000\001\134\000\000\001\135\001j\004\243\000\000\000\000\005E\000\000\000\000\001d\004\186\000\000\001f\001g\005E\005F\000\000\000\000\000\000\000\000\000\000\000\000\001}\005F\001b\001c\000\000\000\000\000\000\001}\001\134\004\243\001\135\001j\005G\002\148\000\000\001\134\000\000\001\135\001j\005I\005G\002\148\001d\004\186\000\000\001f\001g\005U\005\005\000\000\002Q\002R\001c\000\000\005J\001}\000\000\000\000\000\000\000\000\000\000\000\000\005J\001\134\005L\001\135\001j\000\000\000\000\005N\000\000\000\000\005L\006S\000\000\000\000\005\004\005N\000\000\000\000\005P\000\000\000\000\001k\000\000\000\000\001b\001c\005P\000\000\000\000\001b\001c\000\000\000\000\001l\005Q\000\000\000\231\000\000\000\000\000\000\000\000\000\000\005Q\000\000\001d\004\186\000\000\001f\001g\001d\004\186\000\000\001f\001g\001b\001c\001k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\005-\000\231\000\000\000\000\001d\004\186\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\000\000\002T\000\000\000\000\000\000\000\000\000\000\000\000\005:\000\000\000\000\000\000\001}\002U\000\000\002\141\000\231\000\000\000\000\000\000\001\134\005-\001\135\001j\000\000\000\000\005;\000\000\000\000\005B\000\000\000\000\000\000\000\000\005.\000\000\001k\000\000\005C\000\000\000\000\001k\005:\000\000\000\000\000\000\001\029\001}\001l\001\030\000\000\000\231\000\000\001l\000\000\001\134\000\231\001\135\001j\000\000\0071\000\000\000\000\005B\000\000\000\000\001k\005D\000\000\0056\000\000\000\000\005C\001 \000\000\000\000\002\142\000\000\001l\000\000\000\000\000\231\000\000\003\031\002\143\005\249\001\135\002\144\000\000\000\000\005\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\190\000\000\000\000\005D\000\000\005E\000\000\005\251\000\000\000\000\000\000\000\000\005\250\001}\005F\000\000\000\000\005\249\001}\000\000\001(\001\134\000\000\001\135\001j\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\005G\002\148\001\029\000\000\005\254\001\030\005E\006y\000\000\000\000\001}\000\000\000\000\000\000\000\000\005F\000\000\001\015\001\134\000\000\001\135\001j\005J\001\021\001\"\000\000\001b\001c\000\000\001 \000\000\000\000\005L\000\000\005G\002\148\000\000\005N\0072\003\031\000\000\000\000\000\000\000\000\000\000\000\000\001d\004\186\005P\001f\001g\000\000\000\000\000\000\003$\000\000\005J\000\000\000\000\000\000\001\029\000\000\000\000\001\030\005Q\000\000\005L\000\000\000\000\000\000\000\000\005N\001<\000\000\001(\000\000\000\000\000\000\001\029\001#\000\000\001\030\005P\003*\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\003\031\005Q\000\000\000\000\000\000\000\000\000\000\001\015\001 \001,\000\000\000\000\001F\001\021\001\"\004\006\000\000\000\000\003\031\000\000\000\000\000\000\001 \000\000\000\000\001k\000\000\000\000\001b\001c\000\000\000\000\003\031\004\182\000\000\001(\000\000\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\000\000\004\203\001d\001\133\000\000\001f\001g\001(\000\000\000\000\000\000\000\000\002Q\002R\001c\000\000\001<\000\000\000\000\001\015\000\000\001(\000\000\001#\000\000\001\021\001\"\003*\005\253\000\000\000\000\000\000\000\000\000\000\000\000\004\251\000\000\001\015\000\000\000\000\000\000\000\000\001\029\001\021\001\"\001\030\000\000\000\000\000\000\000\000\001,\001\015\000\000\001F\001}\000\000\000\000\001\021\001\"\004\252\000\000\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\001 \000\000\000\000\000\000\001\029\001<\000\000\001\030\000\000\001k\003\031\000\000\001#\000\000\000\000\000\000\003*\000\000\000\000\000\000\000\000\001l\000\000\001<\000\231\004\213\000\000\000\000\000\000\000\000\001#\001 \000\000\000\000\003*\000\000\004\017\001<\000\000\001,\002T\000\000\001F\000\000\001#\001(\001b\001c\003*\000\000\001\029\000\000\002U\001\030\002\141\000\231\000\000\001,\000\000\000\000\001F\000\000\000\000\000\000\000\000\000\000\001d\001\205\000\000\001f\001g\001,\000\000\000\000\001F\001\015\001(\001 \000\000\000\000\000\000\001\021\001\"\001\029\001}\000\000\001\030\003:\000\000\000\000\004\254\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\003=\001\029\000\000\000\000\001\030\001\015\000\000\000\000\000\000\001 \001\029\001\021\001\"\001\030\002\142\000\000\000\000\000\000\000\000\000\000\000\000\001(\002\143\000\000\001\135\002\144\000\000\000\000\001 \001<\000\000\000\000\000\000\004\238\000\000\000\000\001#\001 \000\000\000\000\003*\001k\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\000\000\001\015\000\000\001l\001(\000\000\000\231\001\021\001\"\000\000\001<\000\000\001\029\001,\000\000\001\030\001F\001#\000\000\000\000\001 \004\022\000\000\001(\000\000\002Q\002R\001c\000\000\000\000\000\000\000\000\001(\000\000\001\015\000\000\000\000\000\000\000\000\001 \001\021\001\"\000\000\000\000\001,\000\000\000\000\001F\004\251\000\000\000\000\000\000\000\000\001\015\000\000\000\000\001<\000\000\000\000\001\021\001\"\006\255\001\015\001#\000\000\001(\001}\000\000\001\021\001\"\000\000\000\000\000\000\000\000\001\134\000\000\001\135\001j\000\000\000\000\001\029\000\000\000\000\001\030\001(\000\000\000\000\000\000\000\000\001<\001,\000\000\000\000\003A\000\000\001\015\001#\000\000\000\000\000\000\004#\001\021\001\"\004&\000\000\000\000\000\000\001 \001<\000\000\000\000\000\000\000\000\001\029\001\015\001#\001\030\001<\000\000\004\022\001\021\001\"\002T\001,\001#\000\000\001F\000\000\004#\000\000\000\000\005\031\001\029\000\000\002U\001\030\002\141\000\231\000\000\000\000\001 \001\029\001,\000\000\001\030\001F\000\000\000\000\000\000\000\000\001<\001,\001(\000\000\001F\000\000\000\000\001#\000\000\001 \000\000\007\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \001<\000\000\000\000\004\253\000\000\000\000\000\000\001#\000\000\000\000\000\000\001\144\000\000\001\015\000\000\001,\001(\000\000\001F\001\021\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\000\000\000\000\000\000\000\000\000\000\001,\001(\002\143\001F\001\135\002\144\002Q\002R\001c\000\000\001(\000\000\001\015\002Q\002R\001c\000\000\000\000\001\021\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\021\000\000\001\015\000\000\000\000\001<\000\000\006\018\001\021\001\"\000\000\001\015\001#\002Q\002R\001c\001\179\001\021\001\"\000\000\002Q\002R\001c\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\002Q\002R\001c\002S\000\000\001<\001,\000\000\000\000\001F\002l\001\029\001#\000\000\001\030\000\000\001\194\000\000\000\000\000\000\001 \000\000\000\000\002n\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\001<\000\000\001\241\000\000\000\000\001 \001,\001#\002T\001F\000\000\001\243\000\000\001\029\000\000\002T\001\030\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\001,\000\000\002U\001F\002\141\000\231\000\000\001(\000\000\001,\000\000\000\000\001F\000\000\000\000\001 \000\000\000\000\000\000\002T\000\000\000\000\002Q\002R\001c\001(\002T\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\000\000\001\015\002U\002T\002\141\000\231\000\000\001\021\001\"\002\130\000\000\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\001\015\001\029\000\000\002\142\001\030\001(\001\021\001\"\000\000\001\029\002\142\002\143\001\030\001\135\002\144\000\000\000\000\000\000\002\143\000\000\001\135\002\144\002Q\002R\001c\000\000\000\000\000\000\001 \002Q\002R\001c\000\000\000\000\000\000\001\015\001 \001<\000\000\002\142\000\000\001\021\001\"\000\000\001#\002\140\002\142\002\143\002g\001\135\002\144\000\000\002\159\000\000\002\143\001<\001\135\002\144\000\000\002\142\000\000\000\000\001#\000\000\002T\000\000\002w\002\143\000\000\001\135\002\144\001,\001\029\001(\001F\001\030\002U\000\000\002\141\000\231\001\029\001(\000\000\001\030\000\000\000\000\000\000\000\000\001\029\001,\001<\001\030\001F\000\000\000\000\000\000\000\000\001#\000\000\001 \000\000\002{\000\000\001\015\000\000\000\000\000\000\001 \000\000\001\021\001\"\001\015\000\000\000\000\000\000\001 \000\000\001\021\001\"\002T\000\000\000\000\000\000\000\000\001,\000\000\002T\001F\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\000\000\000\000\002U\002\142\002\141\000\231\000\000\000\000\001(\001\029\000\000\002\143\001\030\001\135\002\144\000\000\001(\000\000\000\000\000\000\000\000\000\000\001<\000\000\001(\000\000\000\000\000\000\000\000\001#\001<\000\000\000\000\002\211\000\000\000\000\001 \001#\001\015\000\000\000\000\003#\000\000\000\000\001\021\001\"\001\015\001\029\000\000\000\000\004G\000\000\001\021\001\"\001\015\000\000\001,\000\000\002\142\001F\001\021\001\"\000\000\000\000\001,\002\142\002\143\001F\001\135\002\144\000\000\000\000\000\000\002\143\001 \001\135\002\144\000\000\000\000\001\029\000\000\001(\004G\000\000\000\000\000\000\000\000\001\029\000\000\000\000\004G\000\000\000\000\001<\000\000\000\000\001\029\000\000\000\000\004G\001#\001<\000\000\000\000\003\239\000\000\001 \001\029\001#\001<\001\030\001\015\003\251\000\000\001 \000\000\001#\001\021\001\"\004I\004\021\000\000\000\000\001 \002Q\002R\001c\001,\000\000\000\000\001F\000\000\000\000\000\000\001 \001,\000\000\000\000\001F\000\000\000\000\000\000\000\000\001,\000\000\001\029\001F\004\250\001\030\001\015\000\000\004I\000\000\000\000\000\000\001\021\004L\000\000\000\000\004I\000\000\000\000\000\000\000\000\000\000\000\000\001<\000\000\004I\000\000\000\000\000\000\001 \001#\000\000\000\000\000\000\004%\000\000\001(\001\029\001\015\000\000\001\030\000\000\000\000\000\000\001\021\004L\001\015\000\000\000\000\000\000\000\000\000\000\001\021\004L\000\000\001\015\000\000\001,\000\000\000\000\001F\001\021\004L\000\000\001 \000\000\001\015\000\000\004M\000\000\000\000\000\000\001\021\001\"\001(\000\000\001\029\000\000\002T\004G\004\024\000\000\004Q\000\000\004O\000\000\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\001,\000\000\000\000\000\000\000\000\004M\000\000\000\000\001 \001\015\000\000\000\000\000\000\004M\001(\001\021\001\"\004\024\000\000\004P\001\029\004O\004M\004G\000\000\004\024\001<\004N\000\000\004O\000\000\000\000\001,\001#\004\024\000\000\004Z\004\162\004O\000\000\001,\000\000\000\000\000\000\001\015\001\029\000\000\001 \001\030\001,\001\021\001\"\000\000\004I\000\000\000\000\000\000\000\000\002\142\000\000\001,\000\000\000\000\001F\001<\000\000\002\143\001\029\001\135\002\144\001\030\001#\001 \000\000\000\000\004\179\000\000\001\029\000\000\000\000\001\030\000\000\000\000\001\015\000\000\000\000\000\000\000\000\000\000\001\021\004L\000\000\004I\000\000\001 \000\000\000\000\000\000\001,\001<\000\000\001F\000\000\000\000\001 \000\000\001#\000\000\001\029\000\000\004\210\001\030\000\000\000\000\000\000\000\000\000\000\001(\000\000\000\000\000\000\001\029\001\015\000\000\001\030\000\000\000\000\000\000\001\021\004L\000\000\000\000\000\000\001,\000\000\001 \001F\000\000\000\000\001(\001\029\000\000\000\000\001\030\000\000\004M\000\000\001\015\001 \001(\000\000\000\000\000\000\001\021\001\"\000\000\000\000\004\024\000\000\005\018\000\000\004O\000\000\000\000\000\000\001\029\000\000\001 \001\030\001\015\000\000\000\000\001,\000\000\000\000\001\021\001\"\000\000\000\000\001\015\001(\000\000\000\000\000\000\004M\001\021\001\"\000\000\000\000\000\000\000\000\000\000\001 \001(\000\000\000\000\004\024\000\000\005*\000\000\004O\000\000\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\001\015\001,\001(\006A\000\000\000\000\001\021\001\"\000\000\000\000\000\000\000\000\000\000\001\015\001<\000\000\000\000\000\000\000\000\001\021\001\"\001#\000\000\000\000\001<\006F\001,\001(\000\000\001F\000\000\001#\001\015\000\000\000\000\006\146\000\000\000\000\001\021\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\001F\000\000\000\000\000\000\001<\000\000\001\015\001,\000\000\000\000\001F\001#\001\021\001\"\000\000\006\150\000\000\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\006\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001<\000\000\001,\000\000\000\000\001F\000\000\001#\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\001F\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\001#\000\000\001,\000\000\000\000\001\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\003<")) and semantic_action = [| @@ -1477,9 +1479,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3945 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( "+" ) -# 1483 "src/ocaml/preprocess/parser_raw.ml" +# 1485 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1502,9 +1504,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3946 "src/ocaml/preprocess/parser_raw.mly" +# 3966 "src/ocaml/preprocess/parser_raw.mly" ( "+." ) -# 1508 "src/ocaml/preprocess/parser_raw.ml" +# 1510 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1527,9 +1529,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3494 "src/ocaml/preprocess/parser_raw.mly" +# 3514 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1533 "src/ocaml/preprocess/parser_raw.ml" +# 1535 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1574,24 +1576,24 @@ module Tables = struct let _endpos = _endpos_tyvar_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3497 "src/ocaml/preprocess/parser_raw.mly" +# 3517 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_alias(ty, tyvar) ) -# 1580 "src/ocaml/preprocess/parser_raw.ml" +# 1582 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1589 "src/ocaml/preprocess/parser_raw.ml" +# 1591 "src/ocaml/preprocess/parser_raw.ml" in -# 3499 "src/ocaml/preprocess/parser_raw.mly" +# 3519 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1595 "src/ocaml/preprocess/parser_raw.ml" +# 1597 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1628,7 +1630,8 @@ module Tables = struct }; } = _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 body : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option * 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 @@ -1637,30 +1640,30 @@ module Tables = struct let _v : (Ast_helper.let_binding) = let attrs2 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1643 "src/ocaml/preprocess/parser_raw.ml" +# 1646 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1652 "src/ocaml/preprocess/parser_raw.ml" +# 1655 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2738 "src/ocaml/preprocess/parser_raw.mly" +# 2758 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklb ~loc:_sloc false body attrs ) -# 1664 "src/ocaml/preprocess/parser_raw.ml" +# 1667 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1683,9 +1686,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3829 "src/ocaml/preprocess/parser_raw.mly" +# 3849 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1689 "src/ocaml/preprocess/parser_raw.ml" +# 1692 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1708,9 +1711,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3830 "src/ocaml/preprocess/parser_raw.mly" +# 3850 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 1714 "src/ocaml/preprocess/parser_raw.ml" +# 1717 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1747,9 +1750,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = -# 3555 "src/ocaml/preprocess/parser_raw.mly" +# 3575 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 1753 "src/ocaml/preprocess/parser_raw.ml" +# 1756 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1812,11 +1815,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3615 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "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 ) -# 1820 "src/ocaml/preprocess/parser_raw.ml" +# 1823 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -1824,24 +1827,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1830 "src/ocaml/preprocess/parser_raw.ml" +# 1833 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 1836 "src/ocaml/preprocess/parser_raw.ml" +# 1839 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3557 "src/ocaml/preprocess/parser_raw.mly" +# 3577 "src/ocaml/preprocess/parser_raw.mly" ( wrap_typ_attrs ~loc:_sloc (reloc_typ ~loc:_sloc _4) _3 ) -# 1845 "src/ocaml/preprocess/parser_raw.ml" +# 1848 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1872,24 +1875,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3560 "src/ocaml/preprocess/parser_raw.mly" +# 3580 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_var _2 ) -# 1878 "src/ocaml/preprocess/parser_raw.ml" +# 1881 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1887 "src/ocaml/preprocess/parser_raw.ml" +# 1890 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1893 "src/ocaml/preprocess/parser_raw.ml" +# 1896 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1913,23 +1916,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3562 "src/ocaml/preprocess/parser_raw.mly" +# 3582 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 1919 "src/ocaml/preprocess/parser_raw.ml" +# 1922 "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" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1927 "src/ocaml/preprocess/parser_raw.ml" +# 1930 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1933 "src/ocaml/preprocess/parser_raw.ml" +# 1936 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1958,35 +1961,35 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 1964 "src/ocaml/preprocess/parser_raw.ml" +# 1967 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3607 "src/ocaml/preprocess/parser_raw.mly" +# 3627 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 1970 "src/ocaml/preprocess/parser_raw.ml" +# 1973 "src/ocaml/preprocess/parser_raw.ml" in -# 3565 "src/ocaml/preprocess/parser_raw.mly" +# 3585 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr(tid, tys) ) -# 1975 "src/ocaml/preprocess/parser_raw.ml" +# 1978 "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" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1984 "src/ocaml/preprocess/parser_raw.ml" +# 1987 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1990 "src/ocaml/preprocess/parser_raw.ml" +# 1993 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2022,20 +2025,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2028 "src/ocaml/preprocess/parser_raw.ml" +# 2031 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3609 "src/ocaml/preprocess/parser_raw.mly" +# 3629 "src/ocaml/preprocess/parser_raw.mly" ( [ty] ) -# 2034 "src/ocaml/preprocess/parser_raw.ml" +# 2037 "src/ocaml/preprocess/parser_raw.ml" in -# 3565 "src/ocaml/preprocess/parser_raw.mly" +# 3585 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr(tid, tys) ) -# 2039 "src/ocaml/preprocess/parser_raw.ml" +# 2042 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_ty_ in @@ -2043,15 +2046,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2049 "src/ocaml/preprocess/parser_raw.ml" +# 2052 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2055 "src/ocaml/preprocess/parser_raw.ml" +# 2058 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2102,9 +2105,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2108 "src/ocaml/preprocess/parser_raw.ml" +# 2111 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -2112,24 +2115,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2116 "src/ocaml/preprocess/parser_raw.ml" +# 2119 "src/ocaml/preprocess/parser_raw.ml" in -# 1156 "src/ocaml/preprocess/parser_raw.mly" +# 1158 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2121 "src/ocaml/preprocess/parser_raw.ml" +# 2124 "src/ocaml/preprocess/parser_raw.ml" in -# 3611 "src/ocaml/preprocess/parser_raw.mly" +# 3631 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 2127 "src/ocaml/preprocess/parser_raw.ml" +# 2130 "src/ocaml/preprocess/parser_raw.ml" in -# 3565 "src/ocaml/preprocess/parser_raw.mly" +# 3585 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr(tid, tys) ) -# 2133 "src/ocaml/preprocess/parser_raw.ml" +# 2136 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -2137,15 +2140,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2143 "src/ocaml/preprocess/parser_raw.ml" +# 2146 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2149 "src/ocaml/preprocess/parser_raw.ml" +# 2152 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2183,24 +2186,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3567 "src/ocaml/preprocess/parser_raw.mly" +# 3587 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = _2 in Ptyp_object (f, c) ) -# 2189 "src/ocaml/preprocess/parser_raw.ml" +# 2192 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2198 "src/ocaml/preprocess/parser_raw.ml" +# 2201 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2204 "src/ocaml/preprocess/parser_raw.ml" +# 2207 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2231,24 +2234,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3569 "src/ocaml/preprocess/parser_raw.mly" +# 3589 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_object ([], Closed) ) -# 2237 "src/ocaml/preprocess/parser_raw.ml" +# 2240 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2246 "src/ocaml/preprocess/parser_raw.ml" +# 2249 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2252 "src/ocaml/preprocess/parser_raw.ml" +# 2255 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2284,20 +2287,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2290 "src/ocaml/preprocess/parser_raw.ml" +# 2293 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3607 "src/ocaml/preprocess/parser_raw.mly" +# 3627 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 2296 "src/ocaml/preprocess/parser_raw.ml" +# 2299 "src/ocaml/preprocess/parser_raw.ml" in -# 3573 "src/ocaml/preprocess/parser_raw.mly" +# 3593 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_class(cid, tys) ) -# 2301 "src/ocaml/preprocess/parser_raw.ml" +# 2304 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos__2_ in @@ -2305,15 +2308,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2311 "src/ocaml/preprocess/parser_raw.ml" +# 2314 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2317 "src/ocaml/preprocess/parser_raw.ml" +# 2320 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2356,20 +2359,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2362 "src/ocaml/preprocess/parser_raw.ml" +# 2365 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3609 "src/ocaml/preprocess/parser_raw.mly" +# 3629 "src/ocaml/preprocess/parser_raw.mly" ( [ty] ) -# 2368 "src/ocaml/preprocess/parser_raw.ml" +# 2371 "src/ocaml/preprocess/parser_raw.ml" in -# 3573 "src/ocaml/preprocess/parser_raw.mly" +# 3593 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_class(cid, tys) ) -# 2373 "src/ocaml/preprocess/parser_raw.ml" +# 2376 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_ty_ in @@ -2377,15 +2380,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2383 "src/ocaml/preprocess/parser_raw.ml" +# 2386 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2389 "src/ocaml/preprocess/parser_raw.ml" +# 2392 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2443,9 +2446,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2449 "src/ocaml/preprocess/parser_raw.ml" +# 2452 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -2453,24 +2456,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2457 "src/ocaml/preprocess/parser_raw.ml" +# 2460 "src/ocaml/preprocess/parser_raw.ml" in -# 1156 "src/ocaml/preprocess/parser_raw.mly" +# 1158 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2462 "src/ocaml/preprocess/parser_raw.ml" +# 2465 "src/ocaml/preprocess/parser_raw.ml" in -# 3611 "src/ocaml/preprocess/parser_raw.mly" +# 3631 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 2468 "src/ocaml/preprocess/parser_raw.ml" +# 2471 "src/ocaml/preprocess/parser_raw.ml" in -# 3573 "src/ocaml/preprocess/parser_raw.mly" +# 3593 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_class(cid, tys) ) -# 2474 "src/ocaml/preprocess/parser_raw.ml" +# 2477 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -2478,15 +2481,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2484 "src/ocaml/preprocess/parser_raw.ml" +# 2487 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2490 "src/ocaml/preprocess/parser_raw.ml" +# 2493 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2524,24 +2527,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3576 "src/ocaml/preprocess/parser_raw.mly" +# 3596 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant([_2], Closed, None) ) -# 2530 "src/ocaml/preprocess/parser_raw.ml" +# 2533 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2539 "src/ocaml/preprocess/parser_raw.ml" +# 2542 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2545 "src/ocaml/preprocess/parser_raw.ml" +# 2548 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2591,24 +2594,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2595 "src/ocaml/preprocess/parser_raw.ml" +# 2598 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2600 "src/ocaml/preprocess/parser_raw.ml" +# 2603 "src/ocaml/preprocess/parser_raw.ml" in -# 3621 "src/ocaml/preprocess/parser_raw.mly" +# 3641 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2606 "src/ocaml/preprocess/parser_raw.ml" +# 2609 "src/ocaml/preprocess/parser_raw.ml" in -# 3578 "src/ocaml/preprocess/parser_raw.mly" +# 3598 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Closed, None) ) -# 2612 "src/ocaml/preprocess/parser_raw.ml" +# 2615 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -2616,15 +2619,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2622 "src/ocaml/preprocess/parser_raw.ml" +# 2625 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2628 "src/ocaml/preprocess/parser_raw.ml" +# 2631 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2681,24 +2684,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2685 "src/ocaml/preprocess/parser_raw.ml" +# 2688 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2690 "src/ocaml/preprocess/parser_raw.ml" +# 2693 "src/ocaml/preprocess/parser_raw.ml" in -# 3621 "src/ocaml/preprocess/parser_raw.mly" +# 3641 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2696 "src/ocaml/preprocess/parser_raw.ml" +# 2699 "src/ocaml/preprocess/parser_raw.ml" in -# 3580 "src/ocaml/preprocess/parser_raw.mly" +# 3600 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_2 :: _4, Closed, None) ) -# 2702 "src/ocaml/preprocess/parser_raw.ml" +# 2705 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -2706,15 +2709,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2712 "src/ocaml/preprocess/parser_raw.ml" +# 2715 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2718 "src/ocaml/preprocess/parser_raw.ml" +# 2721 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2764,24 +2767,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2768 "src/ocaml/preprocess/parser_raw.ml" +# 2771 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2773 "src/ocaml/preprocess/parser_raw.ml" +# 2776 "src/ocaml/preprocess/parser_raw.ml" in -# 3621 "src/ocaml/preprocess/parser_raw.mly" +# 3641 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2779 "src/ocaml/preprocess/parser_raw.ml" +# 2782 "src/ocaml/preprocess/parser_raw.ml" in -# 3582 "src/ocaml/preprocess/parser_raw.mly" +# 3602 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Open, None) ) -# 2785 "src/ocaml/preprocess/parser_raw.ml" +# 2788 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -2789,15 +2792,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2795 "src/ocaml/preprocess/parser_raw.ml" +# 2798 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2801 "src/ocaml/preprocess/parser_raw.ml" +# 2804 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2828,24 +2831,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3584 "src/ocaml/preprocess/parser_raw.mly" +# 3604 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant([], Open, None) ) -# 2834 "src/ocaml/preprocess/parser_raw.ml" +# 2837 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2843 "src/ocaml/preprocess/parser_raw.ml" +# 2846 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2849 "src/ocaml/preprocess/parser_raw.ml" +# 2852 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2895,24 +2898,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2899 "src/ocaml/preprocess/parser_raw.ml" +# 2902 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2904 "src/ocaml/preprocess/parser_raw.ml" +# 2907 "src/ocaml/preprocess/parser_raw.ml" in -# 3621 "src/ocaml/preprocess/parser_raw.mly" +# 3641 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2910 "src/ocaml/preprocess/parser_raw.ml" +# 2913 "src/ocaml/preprocess/parser_raw.ml" in -# 3586 "src/ocaml/preprocess/parser_raw.mly" +# 3606 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Closed, Some []) ) -# 2916 "src/ocaml/preprocess/parser_raw.ml" +# 2919 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -2920,15 +2923,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2926 "src/ocaml/preprocess/parser_raw.ml" +# 2929 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2932 "src/ocaml/preprocess/parser_raw.ml" +# 2935 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2993,18 +2996,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2997 "src/ocaml/preprocess/parser_raw.ml" +# 3000 "src/ocaml/preprocess/parser_raw.ml" in -# 1096 "src/ocaml/preprocess/parser_raw.mly" +# 1098 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 3002 "src/ocaml/preprocess/parser_raw.ml" +# 3005 "src/ocaml/preprocess/parser_raw.ml" in -# 3649 "src/ocaml/preprocess/parser_raw.mly" +# 3669 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3008 "src/ocaml/preprocess/parser_raw.ml" +# 3011 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -3012,24 +3015,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 3016 "src/ocaml/preprocess/parser_raw.ml" +# 3019 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 3021 "src/ocaml/preprocess/parser_raw.ml" +# 3024 "src/ocaml/preprocess/parser_raw.ml" in -# 3621 "src/ocaml/preprocess/parser_raw.mly" +# 3641 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3027 "src/ocaml/preprocess/parser_raw.ml" +# 3030 "src/ocaml/preprocess/parser_raw.ml" in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3608 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(_3, Closed, Some _5) ) -# 3033 "src/ocaml/preprocess/parser_raw.ml" +# 3036 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -3037,15 +3040,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 3043 "src/ocaml/preprocess/parser_raw.ml" +# 3046 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3049 "src/ocaml/preprocess/parser_raw.ml" +# 3052 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3069,23 +3072,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3590 "src/ocaml/preprocess/parser_raw.mly" +# 3610 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_extension _1 ) -# 3075 "src/ocaml/preprocess/parser_raw.ml" +# 3078 "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" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 3083 "src/ocaml/preprocess/parser_raw.ml" +# 3086 "src/ocaml/preprocess/parser_raw.ml" in -# 3592 "src/ocaml/preprocess/parser_raw.mly" +# 3612 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3089 "src/ocaml/preprocess/parser_raw.ml" +# 3092 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3109,23 +3112,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (string Location.loc) = let _1 = let _1 = -# 4012 "src/ocaml/preprocess/parser_raw.mly" +# 4032 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3115 "src/ocaml/preprocess/parser_raw.ml" +# 3118 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1024 "src/ocaml/preprocess/parser_raw.mly" +# 1026 "src/ocaml/preprocess/parser_raw.mly" ( mkloc _1 (make_loc _sloc) ) -# 3123 "src/ocaml/preprocess/parser_raw.ml" +# 3126 "src/ocaml/preprocess/parser_raw.ml" in -# 4014 "src/ocaml/preprocess/parser_raw.mly" +# 4034 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3129 "src/ocaml/preprocess/parser_raw.ml" +# 3132 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3163,24 +3166,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (string Location.loc) = let _1 = let _1 = -# 4013 "src/ocaml/preprocess/parser_raw.mly" +# 4033 "src/ocaml/preprocess/parser_raw.mly" ( _1 ^ "." ^ _3.txt ) -# 3169 "src/ocaml/preprocess/parser_raw.ml" +# 3172 "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 -# 1024 "src/ocaml/preprocess/parser_raw.mly" +# 1026 "src/ocaml/preprocess/parser_raw.mly" ( mkloc _1 (make_loc _sloc) ) -# 3178 "src/ocaml/preprocess/parser_raw.ml" +# 3181 "src/ocaml/preprocess/parser_raw.ml" in -# 4014 "src/ocaml/preprocess/parser_raw.mly" +# 4034 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3184 "src/ocaml/preprocess/parser_raw.ml" +# 3187 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3227,9 +3230,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4018 "src/ocaml/preprocess/parser_raw.mly" +# 4038 "src/ocaml/preprocess/parser_raw.mly" ( Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 3233 "src/ocaml/preprocess/parser_raw.ml" +# 3236 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3252,9 +3255,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.class_expr) = -# 1998 "src/ocaml/preprocess/parser_raw.mly" +# 2017 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3258 "src/ocaml/preprocess/parser_raw.ml" +# 3261 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3293,18 +3296,18 @@ module Tables = struct let _v : (Parsetree.class_expr) = let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3299 "src/ocaml/preprocess/parser_raw.ml" +# 3302 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2000 "src/ocaml/preprocess/parser_raw.mly" +# 2019 "src/ocaml/preprocess/parser_raw.mly" ( wrap_class_attrs ~loc:_sloc _3 _2 ) -# 3308 "src/ocaml/preprocess/parser_raw.ml" +# 3311 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3344,9 +3347,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2002 "src/ocaml/preprocess/parser_raw.mly" +# 2021 "src/ocaml/preprocess/parser_raw.mly" ( class_of_let_bindings ~loc:_sloc _1 _3 ) -# 3350 "src/ocaml/preprocess/parser_raw.ml" +# 3353 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3409,34 +3412,34 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 3415 "src/ocaml/preprocess/parser_raw.ml" +# 3418 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in let _4 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3424 "src/ocaml/preprocess/parser_raw.ml" +# 3427 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 3430 "src/ocaml/preprocess/parser_raw.ml" +# 3433 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2004 "src/ocaml/preprocess/parser_raw.mly" +# 2023 "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)) ) -# 3440 "src/ocaml/preprocess/parser_raw.ml" +# 3443 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3506,37 +3509,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 3512 "src/ocaml/preprocess/parser_raw.ml" +# 3515 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3521 "src/ocaml/preprocess/parser_raw.ml" +# 3524 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 3529 "src/ocaml/preprocess/parser_raw.ml" +# 3532 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2004 "src/ocaml/preprocess/parser_raw.mly" +# 2023 "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)) ) -# 3540 "src/ocaml/preprocess/parser_raw.ml" +# 3543 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3566,9 +3569,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = -# 2008 "src/ocaml/preprocess/parser_raw.mly" +# 2027 "src/ocaml/preprocess/parser_raw.mly" ( Cl.attr _1 _2 ) -# 3572 "src/ocaml/preprocess/parser_raw.ml" +# 3575 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3603,18 +3606,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 3607 "src/ocaml/preprocess/parser_raw.ml" +# 3610 "src/ocaml/preprocess/parser_raw.ml" in -# 1096 "src/ocaml/preprocess/parser_raw.mly" +# 1098 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 3612 "src/ocaml/preprocess/parser_raw.ml" +# 3615 "src/ocaml/preprocess/parser_raw.ml" in -# 2011 "src/ocaml/preprocess/parser_raw.mly" +# 2030 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_apply(_1, _2) ) -# 3618 "src/ocaml/preprocess/parser_raw.ml" +# 3621 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -3622,15 +3625,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "src/ocaml/preprocess/parser_raw.mly" +# 1049 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3628 "src/ocaml/preprocess/parser_raw.ml" +# 3631 "src/ocaml/preprocess/parser_raw.ml" in -# 2014 "src/ocaml/preprocess/parser_raw.mly" +# 2033 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3634 "src/ocaml/preprocess/parser_raw.ml" +# 3637 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3654,23 +3657,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2013 "src/ocaml/preprocess/parser_raw.mly" +# 2032 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_extension _1 ) -# 3660 "src/ocaml/preprocess/parser_raw.ml" +# 3663 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "src/ocaml/preprocess/parser_raw.mly" +# 1049 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3668 "src/ocaml/preprocess/parser_raw.ml" +# 3671 "src/ocaml/preprocess/parser_raw.ml" in -# 2014 "src/ocaml/preprocess/parser_raw.mly" +# 2033 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3674 "src/ocaml/preprocess/parser_raw.ml" +# 3677 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3723,33 +3726,33 @@ module Tables = struct let _v : (Parsetree.class_field) = let _6 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3729 "src/ocaml/preprocess/parser_raw.ml" +# 3732 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3738 "src/ocaml/preprocess/parser_raw.ml" +# 3741 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 3744 "src/ocaml/preprocess/parser_raw.ml" +# 3747 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2069 "src/ocaml/preprocess/parser_raw.mly" +# 2088 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3753 "src/ocaml/preprocess/parser_raw.ml" +# 3756 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3809,36 +3812,36 @@ module Tables = struct let _v : (Parsetree.class_field) = let _6 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3815 "src/ocaml/preprocess/parser_raw.ml" +# 3818 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _3 = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3824 "src/ocaml/preprocess/parser_raw.ml" +# 3827 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 3832 "src/ocaml/preprocess/parser_raw.ml" +# 3835 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2069 "src/ocaml/preprocess/parser_raw.mly" +# 2088 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3842 "src/ocaml/preprocess/parser_raw.ml" +# 3845 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3878,9 +3881,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _3 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3884 "src/ocaml/preprocess/parser_raw.ml" +# 3887 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3888,11 +3891,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2072 "src/ocaml/preprocess/parser_raw.mly" +# 2091 "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 ) -# 3896 "src/ocaml/preprocess/parser_raw.ml" +# 3899 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3932,9 +3935,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _3 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3938 "src/ocaml/preprocess/parser_raw.ml" +# 3941 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3942,11 +3945,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2076 "src/ocaml/preprocess/parser_raw.mly" +# 2095 "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 ) -# 3950 "src/ocaml/preprocess/parser_raw.ml" +# 3953 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3992,28 +3995,28 @@ module Tables = struct let _v : (Parsetree.class_field) = let _4 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3998 "src/ocaml/preprocess/parser_raw.ml" +# 4001 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4007 "src/ocaml/preprocess/parser_raw.ml" +# 4010 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2080 "src/ocaml/preprocess/parser_raw.mly" +# 2099 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 4017 "src/ocaml/preprocess/parser_raw.ml" +# 4020 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4059,28 +4062,28 @@ module Tables = struct let _v : (Parsetree.class_field) = let _4 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4065 "src/ocaml/preprocess/parser_raw.ml" +# 4068 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4074 "src/ocaml/preprocess/parser_raw.ml" +# 4077 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2083 "src/ocaml/preprocess/parser_raw.mly" +# 2102 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_initializer _3) ~attrs:(_2@_4) ~docs ) -# 4084 "src/ocaml/preprocess/parser_raw.ml" +# 4087 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4112,9 +4115,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4118 "src/ocaml/preprocess/parser_raw.ml" +# 4121 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -4122,10 +4125,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2086 "src/ocaml/preprocess/parser_raw.mly" +# 2105 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_extension _1) ~attrs:_2 ~docs ) -# 4129 "src/ocaml/preprocess/parser_raw.ml" +# 4132 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4149,23 +4152,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_field) = let _1 = let _1 = -# 2089 "src/ocaml/preprocess/parser_raw.mly" +# 2108 "src/ocaml/preprocess/parser_raw.mly" ( Pcf_attribute _1 ) -# 4155 "src/ocaml/preprocess/parser_raw.ml" +# 4158 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1045 "src/ocaml/preprocess/parser_raw.mly" +# 1047 "src/ocaml/preprocess/parser_raw.mly" ( mkcf ~loc:_sloc _1 ) -# 4163 "src/ocaml/preprocess/parser_raw.ml" +# 4166 "src/ocaml/preprocess/parser_raw.ml" in -# 2090 "src/ocaml/preprocess/parser_raw.mly" +# 2109 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4169 "src/ocaml/preprocess/parser_raw.ml" +# 4172 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4195,9 +4198,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = -# 1978 "src/ocaml/preprocess/parser_raw.mly" +# 1997 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 4201 "src/ocaml/preprocess/parser_raw.ml" +# 4204 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4242,24 +4245,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 1981 "src/ocaml/preprocess/parser_raw.mly" +# 2000 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constraint(_4, _2) ) -# 4248 "src/ocaml/preprocess/parser_raw.ml" +# 4251 "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 -# 1047 "src/ocaml/preprocess/parser_raw.mly" +# 1049 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4257 "src/ocaml/preprocess/parser_raw.ml" +# 4260 "src/ocaml/preprocess/parser_raw.ml" in -# 1984 "src/ocaml/preprocess/parser_raw.mly" +# 2003 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4263 "src/ocaml/preprocess/parser_raw.ml" +# 4266 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4290,24 +4293,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 1983 "src/ocaml/preprocess/parser_raw.mly" +# 2002 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, _2) ) -# 4296 "src/ocaml/preprocess/parser_raw.ml" +# 4299 "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 -# 1047 "src/ocaml/preprocess/parser_raw.mly" +# 1049 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4305 "src/ocaml/preprocess/parser_raw.ml" +# 4308 "src/ocaml/preprocess/parser_raw.ml" in -# 1984 "src/ocaml/preprocess/parser_raw.mly" +# 2003 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4311 "src/ocaml/preprocess/parser_raw.ml" +# 4314 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4345,24 +4348,24 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2045 "src/ocaml/preprocess/parser_raw.mly" +# 2064 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 4351 "src/ocaml/preprocess/parser_raw.ml" +# 4354 "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 -# 1047 "src/ocaml/preprocess/parser_raw.mly" +# 1049 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4360 "src/ocaml/preprocess/parser_raw.ml" +# 4363 "src/ocaml/preprocess/parser_raw.ml" in -# 2046 "src/ocaml/preprocess/parser_raw.mly" +# 2065 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4366 "src/ocaml/preprocess/parser_raw.ml" +# 4369 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4393,24 +4396,24 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2045 "src/ocaml/preprocess/parser_raw.mly" +# 2064 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 4399 "src/ocaml/preprocess/parser_raw.ml" +# 4402 "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 -# 1047 "src/ocaml/preprocess/parser_raw.mly" +# 1049 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4408 "src/ocaml/preprocess/parser_raw.ml" +# 4411 "src/ocaml/preprocess/parser_raw.ml" in -# 2046 "src/ocaml/preprocess/parser_raw.mly" +# 2065 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4414 "src/ocaml/preprocess/parser_raw.ml" +# 4417 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4433,9 +4436,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3819 "src/ocaml/preprocess/parser_raw.mly" +# 3839 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4439 "src/ocaml/preprocess/parser_raw.ml" +# 4442 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4475,9 +4478,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2054 "src/ocaml/preprocess/parser_raw.mly" +# 2073 "src/ocaml/preprocess/parser_raw.mly" ( reloc_pat ~loc:_sloc _2 ) -# 4481 "src/ocaml/preprocess/parser_raw.ml" +# 4484 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4529,24 +4532,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2056 "src/ocaml/preprocess/parser_raw.mly" +# 2075 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_2, _4) ) -# 4535 "src/ocaml/preprocess/parser_raw.ml" +# 4538 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 4544 "src/ocaml/preprocess/parser_raw.ml" +# 4547 "src/ocaml/preprocess/parser_raw.ml" in -# 2057 "src/ocaml/preprocess/parser_raw.mly" +# 2076 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4550 "src/ocaml/preprocess/parser_raw.ml" +# 4553 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4565,9 +4568,9 @@ module Tables = struct let _symbolstartpos = _endpos in let _sloc = (_symbolstartpos, _endpos) in -# 2059 "src/ocaml/preprocess/parser_raw.mly" +# 2078 "src/ocaml/preprocess/parser_raw.mly" ( ghpat ~loc:_sloc Ppat_any ) -# 4571 "src/ocaml/preprocess/parser_raw.ml" +# 4574 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4604,9 +4607,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = -# 2186 "src/ocaml/preprocess/parser_raw.mly" +# 2205 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 4610 "src/ocaml/preprocess/parser_raw.ml" +# 4613 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4623,24 +4626,24 @@ module Tables = struct let _endpos = _startpos in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 2187 "src/ocaml/preprocess/parser_raw.mly" +# 2206 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 4629 "src/ocaml/preprocess/parser_raw.ml" +# 4632 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 4638 "src/ocaml/preprocess/parser_raw.ml" +# 4641 "src/ocaml/preprocess/parser_raw.ml" in -# 2188 "src/ocaml/preprocess/parser_raw.mly" +# 2207 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4644 "src/ocaml/preprocess/parser_raw.ml" +# 4647 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4686,28 +4689,28 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4692 "src/ocaml/preprocess/parser_raw.ml" +# 4695 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4701 "src/ocaml/preprocess/parser_raw.ml" +# 4704 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2196 "src/ocaml/preprocess/parser_raw.mly" +# 2215 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_inherit _3) ~attrs:(_2@_4) ~docs ) -# 4711 "src/ocaml/preprocess/parser_raw.ml" +# 4714 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4765,9 +4768,9 @@ module Tables = struct let ty : (Parsetree.core_type) = Obj.magic ty in let _3 : unit = Obj.magic _3 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 4771 "src/ocaml/preprocess/parser_raw.ml" +# 4774 "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 @@ -4778,9 +4781,9 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4784 "src/ocaml/preprocess/parser_raw.ml" +# 4787 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined3_ in @@ -4788,44 +4791,44 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let label = let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4794 "src/ocaml/preprocess/parser_raw.ml" +# 4797 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4802 "src/ocaml/preprocess/parser_raw.ml" +# 4805 "src/ocaml/preprocess/parser_raw.ml" in -# 2221 "src/ocaml/preprocess/parser_raw.mly" +# 2240 "src/ocaml/preprocess/parser_raw.mly" ( let mut, virt = flags in label, mut, virt, ty ) -# 4811 "src/ocaml/preprocess/parser_raw.ml" +# 4814 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4819 "src/ocaml/preprocess/parser_raw.ml" +# 4822 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2199 "src/ocaml/preprocess/parser_raw.mly" +# 2218 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_val _3) ~attrs:(_2@_4) ~docs ) -# 4829 "src/ocaml/preprocess/parser_raw.ml" +# 4832 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4883,9 +4886,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 4889 "src/ocaml/preprocess/parser_raw.ml" +# 4892 "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 @@ -4896,53 +4899,53 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _7 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4902 "src/ocaml/preprocess/parser_raw.ml" +# 4905 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__7_ = _endpos__1_inlined4_ in let _6 = let _1 = _1_inlined3 in -# 3460 "src/ocaml/preprocess/parser_raw.mly" +# 3480 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4911 "src/ocaml/preprocess/parser_raw.ml" +# 4914 "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 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4919 "src/ocaml/preprocess/parser_raw.ml" +# 4922 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4927 "src/ocaml/preprocess/parser_raw.ml" +# 4930 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4935 "src/ocaml/preprocess/parser_raw.ml" +# 4938 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2203 "src/ocaml/preprocess/parser_raw.mly" +# 2222 "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 ) -# 4946 "src/ocaml/preprocess/parser_raw.ml" +# 4949 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4988,28 +4991,28 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4994 "src/ocaml/preprocess/parser_raw.ml" +# 4997 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5003 "src/ocaml/preprocess/parser_raw.ml" +# 5006 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2207 "src/ocaml/preprocess/parser_raw.mly" +# 2226 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 5013 "src/ocaml/preprocess/parser_raw.ml" +# 5016 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5041,9 +5044,9 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5047 "src/ocaml/preprocess/parser_raw.ml" +# 5050 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -5051,10 +5054,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2210 "src/ocaml/preprocess/parser_raw.mly" +# 2229 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_extension _1) ~attrs:_2 ~docs ) -# 5058 "src/ocaml/preprocess/parser_raw.ml" +# 5061 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5078,23 +5081,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_type_field) = let _1 = let _1 = -# 2213 "src/ocaml/preprocess/parser_raw.mly" +# 2232 "src/ocaml/preprocess/parser_raw.mly" ( Pctf_attribute _1 ) -# 5084 "src/ocaml/preprocess/parser_raw.ml" +# 5087 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1045 "src/ocaml/preprocess/parser_raw.mly" ( mkctf ~loc:_sloc _1 ) -# 5092 "src/ocaml/preprocess/parser_raw.ml" +# 5095 "src/ocaml/preprocess/parser_raw.ml" in -# 2214 "src/ocaml/preprocess/parser_raw.mly" +# 2233 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5098 "src/ocaml/preprocess/parser_raw.ml" +# 5101 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5123,42 +5126,42 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5129 "src/ocaml/preprocess/parser_raw.ml" +# 5132 "src/ocaml/preprocess/parser_raw.ml" in let tys = let tys = -# 2172 "src/ocaml/preprocess/parser_raw.mly" +# 2191 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 5136 "src/ocaml/preprocess/parser_raw.ml" +# 5139 "src/ocaml/preprocess/parser_raw.ml" in -# 2178 "src/ocaml/preprocess/parser_raw.mly" +# 2197 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5141 "src/ocaml/preprocess/parser_raw.ml" +# 5144 "src/ocaml/preprocess/parser_raw.ml" in -# 2153 "src/ocaml/preprocess/parser_raw.mly" +# 2172 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_constr (cid, tys) ) -# 5147 "src/ocaml/preprocess/parser_raw.ml" +# 5150 "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" +# 1043 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5156 "src/ocaml/preprocess/parser_raw.ml" +# 5159 "src/ocaml/preprocess/parser_raw.ml" in -# 2156 "src/ocaml/preprocess/parser_raw.mly" +# 2175 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5162 "src/ocaml/preprocess/parser_raw.ml" +# 5165 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5209,9 +5212,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5215 "src/ocaml/preprocess/parser_raw.ml" +# 5218 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -5220,30 +5223,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5224 "src/ocaml/preprocess/parser_raw.ml" +# 5227 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 5229 "src/ocaml/preprocess/parser_raw.ml" +# 5232 "src/ocaml/preprocess/parser_raw.ml" in -# 2174 "src/ocaml/preprocess/parser_raw.mly" +# 2193 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 5235 "src/ocaml/preprocess/parser_raw.ml" +# 5238 "src/ocaml/preprocess/parser_raw.ml" in -# 2178 "src/ocaml/preprocess/parser_raw.mly" +# 2197 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5241 "src/ocaml/preprocess/parser_raw.ml" +# 5244 "src/ocaml/preprocess/parser_raw.ml" in -# 2153 "src/ocaml/preprocess/parser_raw.mly" +# 2172 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_constr (cid, tys) ) -# 5247 "src/ocaml/preprocess/parser_raw.ml" +# 5250 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5251,15 +5254,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "src/ocaml/preprocess/parser_raw.mly" +# 1043 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5257 "src/ocaml/preprocess/parser_raw.ml" +# 5260 "src/ocaml/preprocess/parser_raw.ml" in -# 2156 "src/ocaml/preprocess/parser_raw.mly" +# 2175 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5263 "src/ocaml/preprocess/parser_raw.ml" +# 5266 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5283,23 +5286,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_type) = let _1 = let _1 = -# 2155 "src/ocaml/preprocess/parser_raw.mly" +# 2174 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_extension _1 ) -# 5289 "src/ocaml/preprocess/parser_raw.ml" +# 5292 "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" +# 1043 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5297 "src/ocaml/preprocess/parser_raw.ml" +# 5300 "src/ocaml/preprocess/parser_raw.ml" in -# 2156 "src/ocaml/preprocess/parser_raw.mly" +# 2175 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5303 "src/ocaml/preprocess/parser_raw.ml" +# 5306 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5356,44 +5359,44 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5360 "src/ocaml/preprocess/parser_raw.ml" +# 5363 "src/ocaml/preprocess/parser_raw.ml" in -# 2192 "src/ocaml/preprocess/parser_raw.mly" +# 2211 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5365 "src/ocaml/preprocess/parser_raw.ml" +# 5368 "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 -# 989 "src/ocaml/preprocess/parser_raw.mly" +# 991 "src/ocaml/preprocess/parser_raw.mly" ( extra_csig _startpos _endpos _1 ) -# 5374 "src/ocaml/preprocess/parser_raw.ml" +# 5377 "src/ocaml/preprocess/parser_raw.ml" in -# 2182 "src/ocaml/preprocess/parser_raw.mly" +# 2201 "src/ocaml/preprocess/parser_raw.mly" ( Csig.mk _1 _2 ) -# 5380 "src/ocaml/preprocess/parser_raw.ml" +# 5383 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5388 "src/ocaml/preprocess/parser_raw.ml" +# 5391 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2158 "src/ocaml/preprocess/parser_raw.mly" +# 2177 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc ~attrs:_2 (Pcty_signature _3) ) -# 5397 "src/ocaml/preprocess/parser_raw.ml" +# 5400 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5423,9 +5426,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_type) = -# 2164 "src/ocaml/preprocess/parser_raw.mly" +# 2183 "src/ocaml/preprocess/parser_raw.mly" ( Cty.attr _1 _2 ) -# 5429 "src/ocaml/preprocess/parser_raw.ml" +# 5432 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5488,34 +5491,34 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5494 "src/ocaml/preprocess/parser_raw.ml" +# 5497 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in let _4 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5503 "src/ocaml/preprocess/parser_raw.ml" +# 5506 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 5509 "src/ocaml/preprocess/parser_raw.ml" +# 5512 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2166 "src/ocaml/preprocess/parser_raw.mly" +# 2185 "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)) ) -# 5519 "src/ocaml/preprocess/parser_raw.ml" +# 5522 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5585,37 +5588,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5591 "src/ocaml/preprocess/parser_raw.ml" +# 5594 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5600 "src/ocaml/preprocess/parser_raw.ml" +# 5603 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 5608 "src/ocaml/preprocess/parser_raw.ml" +# 5611 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2166 "src/ocaml/preprocess/parser_raw.mly" +# 2185 "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)) ) -# 5619 "src/ocaml/preprocess/parser_raw.ml" +# 5622 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5652,9 +5655,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.class_expr) = -# 2018 "src/ocaml/preprocess/parser_raw.mly" +# 2037 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 5658 "src/ocaml/preprocess/parser_raw.ml" +# 5661 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5683,42 +5686,42 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5689 "src/ocaml/preprocess/parser_raw.ml" +# 5692 "src/ocaml/preprocess/parser_raw.ml" in let tys = let tys = -# 2172 "src/ocaml/preprocess/parser_raw.mly" +# 2191 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 5696 "src/ocaml/preprocess/parser_raw.ml" +# 5699 "src/ocaml/preprocess/parser_raw.ml" in -# 2178 "src/ocaml/preprocess/parser_raw.mly" +# 2197 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5701 "src/ocaml/preprocess/parser_raw.ml" +# 5704 "src/ocaml/preprocess/parser_raw.ml" in -# 2025 "src/ocaml/preprocess/parser_raw.mly" +# 2044 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constr(cid, tys) ) -# 5707 "src/ocaml/preprocess/parser_raw.ml" +# 5710 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "src/ocaml/preprocess/parser_raw.mly" +# 1049 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5716 "src/ocaml/preprocess/parser_raw.ml" +# 5719 "src/ocaml/preprocess/parser_raw.ml" in -# 2036 "src/ocaml/preprocess/parser_raw.mly" +# 2055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5722 "src/ocaml/preprocess/parser_raw.ml" +# 5725 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5769,9 +5772,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5775 "src/ocaml/preprocess/parser_raw.ml" +# 5778 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -5780,30 +5783,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5784 "src/ocaml/preprocess/parser_raw.ml" +# 5787 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 5789 "src/ocaml/preprocess/parser_raw.ml" +# 5792 "src/ocaml/preprocess/parser_raw.ml" in -# 2174 "src/ocaml/preprocess/parser_raw.mly" +# 2193 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 5795 "src/ocaml/preprocess/parser_raw.ml" +# 5798 "src/ocaml/preprocess/parser_raw.ml" in -# 2178 "src/ocaml/preprocess/parser_raw.mly" +# 2197 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5801 "src/ocaml/preprocess/parser_raw.ml" +# 5804 "src/ocaml/preprocess/parser_raw.ml" in -# 2025 "src/ocaml/preprocess/parser_raw.mly" +# 2044 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constr(cid, tys) ) -# 5807 "src/ocaml/preprocess/parser_raw.ml" +# 5810 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5811,15 +5814,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "src/ocaml/preprocess/parser_raw.mly" +# 1049 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5817 "src/ocaml/preprocess/parser_raw.ml" +# 5820 "src/ocaml/preprocess/parser_raw.ml" in -# 2036 "src/ocaml/preprocess/parser_raw.mly" +# 2055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5823 "src/ocaml/preprocess/parser_raw.ml" +# 5826 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5871,24 +5874,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2031 "src/ocaml/preprocess/parser_raw.mly" +# 2050 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constraint(_2, _4) ) -# 5877 "src/ocaml/preprocess/parser_raw.ml" +# 5880 "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 -# 1047 "src/ocaml/preprocess/parser_raw.mly" +# 1049 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5886 "src/ocaml/preprocess/parser_raw.ml" +# 5889 "src/ocaml/preprocess/parser_raw.ml" in -# 2036 "src/ocaml/preprocess/parser_raw.mly" +# 2055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5892 "src/ocaml/preprocess/parser_raw.ml" +# 5895 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5945,44 +5948,44 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5949 "src/ocaml/preprocess/parser_raw.ml" +# 5952 "src/ocaml/preprocess/parser_raw.ml" in -# 2063 "src/ocaml/preprocess/parser_raw.mly" +# 2082 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5954 "src/ocaml/preprocess/parser_raw.ml" +# 5957 "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 -# 988 "src/ocaml/preprocess/parser_raw.mly" +# 990 "src/ocaml/preprocess/parser_raw.mly" ( extra_cstr _startpos _endpos _1 ) -# 5963 "src/ocaml/preprocess/parser_raw.ml" +# 5966 "src/ocaml/preprocess/parser_raw.ml" in -# 2050 "src/ocaml/preprocess/parser_raw.mly" +# 2069 "src/ocaml/preprocess/parser_raw.mly" ( Cstr.mk _1 _2 ) -# 5969 "src/ocaml/preprocess/parser_raw.ml" +# 5972 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5977 "src/ocaml/preprocess/parser_raw.ml" +# 5980 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2038 "src/ocaml/preprocess/parser_raw.mly" +# 2057 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc ~attrs:_2 (Pcl_structure _3) ) -# 5986 "src/ocaml/preprocess/parser_raw.ml" +# 5989 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6005,9 +6008,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.class_type) = -# 2141 "src/ocaml/preprocess/parser_raw.mly" +# 2160 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6011 "src/ocaml/preprocess/parser_raw.ml" +# 6014 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6053,14 +6056,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3523 "src/ocaml/preprocess/parser_raw.mly" +# 3543 "src/ocaml/preprocess/parser_raw.mly" ( Optional label ) -# 6059 "src/ocaml/preprocess/parser_raw.ml" +# 6062 "src/ocaml/preprocess/parser_raw.ml" in -# 2147 "src/ocaml/preprocess/parser_raw.mly" +# 2166 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6064 "src/ocaml/preprocess/parser_raw.ml" +# 6067 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -6068,15 +6071,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "src/ocaml/preprocess/parser_raw.mly" +# 1043 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6074 "src/ocaml/preprocess/parser_raw.ml" +# 6077 "src/ocaml/preprocess/parser_raw.ml" in -# 2148 "src/ocaml/preprocess/parser_raw.mly" +# 2167 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6080 "src/ocaml/preprocess/parser_raw.ml" +# 6083 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6123,9 +6126,9 @@ module Tables = struct let domain : (Parsetree.core_type) = Obj.magic domain in let _2 : unit = Obj.magic _2 in let label : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 6129 "src/ocaml/preprocess/parser_raw.ml" +# 6132 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -6133,14 +6136,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3525 "src/ocaml/preprocess/parser_raw.mly" +# 3545 "src/ocaml/preprocess/parser_raw.mly" ( Labelled label ) -# 6139 "src/ocaml/preprocess/parser_raw.ml" +# 6142 "src/ocaml/preprocess/parser_raw.ml" in -# 2147 "src/ocaml/preprocess/parser_raw.mly" +# 2166 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6144 "src/ocaml/preprocess/parser_raw.ml" +# 6147 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -6148,15 +6151,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "src/ocaml/preprocess/parser_raw.mly" +# 1043 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6154 "src/ocaml/preprocess/parser_raw.ml" +# 6157 "src/ocaml/preprocess/parser_raw.ml" in -# 2148 "src/ocaml/preprocess/parser_raw.mly" +# 2167 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6160 "src/ocaml/preprocess/parser_raw.ml" +# 6163 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6195,14 +6198,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3527 "src/ocaml/preprocess/parser_raw.mly" +# 3547 "src/ocaml/preprocess/parser_raw.mly" ( Nolabel ) -# 6201 "src/ocaml/preprocess/parser_raw.ml" +# 6204 "src/ocaml/preprocess/parser_raw.ml" in -# 2147 "src/ocaml/preprocess/parser_raw.mly" +# 2166 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6206 "src/ocaml/preprocess/parser_raw.ml" +# 6209 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_domain_) in @@ -6210,15 +6213,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "src/ocaml/preprocess/parser_raw.mly" +# 1043 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6216 "src/ocaml/preprocess/parser_raw.ml" +# 6219 "src/ocaml/preprocess/parser_raw.ml" in -# 2148 "src/ocaml/preprocess/parser_raw.mly" +# 2167 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6222 "src/ocaml/preprocess/parser_raw.ml" +# 6225 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6301,9 +6304,9 @@ module Tables = struct let csig : (Parsetree.class_type) = Obj.magic csig in let _8 : unit = Obj.magic _8 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 6307 "src/ocaml/preprocess/parser_raw.ml" +# 6310 "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 @@ -6319,9 +6322,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6325 "src/ocaml/preprocess/parser_raw.ml" +# 6328 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -6331,24 +6334,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 6337 "src/ocaml/preprocess/parser_raw.ml" +# 6340 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6345 "src/ocaml/preprocess/parser_raw.ml" +# 6348 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2288 "src/ocaml/preprocess/parser_raw.mly" +# 2307 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -6356,19 +6359,19 @@ module Tables = struct ext, Ci.mk id csig ~virt ~params ~attrs ~loc ~docs ) -# 6360 "src/ocaml/preprocess/parser_raw.ml" +# 6363 "src/ocaml/preprocess/parser_raw.ml" in -# 1225 "src/ocaml/preprocess/parser_raw.mly" +# 1227 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 6366 "src/ocaml/preprocess/parser_raw.ml" +# 6369 "src/ocaml/preprocess/parser_raw.ml" in -# 2276 "src/ocaml/preprocess/parser_raw.mly" +# 2295 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6372 "src/ocaml/preprocess/parser_raw.ml" +# 6375 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6391,9 +6394,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3816 "src/ocaml/preprocess/parser_raw.mly" +# 3836 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6397 "src/ocaml/preprocess/parser_raw.ml" +# 6400 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6412,17 +6415,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 783 "src/ocaml/preprocess/parser_raw.mly" +# 785 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 6418 "src/ocaml/preprocess/parser_raw.ml" +# 6421 "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) = -# 3695 "src/ocaml/preprocess/parser_raw.mly" +# 3715 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _1 in Pconst_integer (n, m) ) -# 6426 "src/ocaml/preprocess/parser_raw.ml" +# 6429 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6441,17 +6444,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 742 "src/ocaml/preprocess/parser_raw.mly" +# 744 "src/ocaml/preprocess/parser_raw.mly" (char) -# 6447 "src/ocaml/preprocess/parser_raw.ml" +# 6450 "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) = -# 3696 "src/ocaml/preprocess/parser_raw.mly" +# 3716 "src/ocaml/preprocess/parser_raw.mly" ( Pconst_char _1 ) -# 6455 "src/ocaml/preprocess/parser_raw.ml" +# 6458 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6470,17 +6473,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 835 "src/ocaml/preprocess/parser_raw.mly" +# 837 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 6476 "src/ocaml/preprocess/parser_raw.ml" +# 6479 "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) = -# 3697 "src/ocaml/preprocess/parser_raw.mly" +# 3717 "src/ocaml/preprocess/parser_raw.mly" ( let (s, strloc, d) = _1 in Pconst_string (s, strloc, d) ) -# 6484 "src/ocaml/preprocess/parser_raw.ml" +# 6487 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6499,17 +6502,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 762 "src/ocaml/preprocess/parser_raw.mly" +# 764 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 6505 "src/ocaml/preprocess/parser_raw.ml" +# 6508 "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) = -# 3698 "src/ocaml/preprocess/parser_raw.mly" +# 3718 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _1 in Pconst_float (f, m) ) -# 6513 "src/ocaml/preprocess/parser_raw.ml" +# 6516 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6539,9 +6542,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3771 "src/ocaml/preprocess/parser_raw.mly" +# 3791 "src/ocaml/preprocess/parser_raw.mly" ( "[]" ) -# 6545 "src/ocaml/preprocess/parser_raw.ml" +# 6548 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6571,9 +6574,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3772 "src/ocaml/preprocess/parser_raw.mly" +# 3792 "src/ocaml/preprocess/parser_raw.mly" ( "()" ) -# 6577 "src/ocaml/preprocess/parser_raw.ml" +# 6580 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6596,9 +6599,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3773 "src/ocaml/preprocess/parser_raw.mly" +# 3793 "src/ocaml/preprocess/parser_raw.mly" ( "false" ) -# 6602 "src/ocaml/preprocess/parser_raw.ml" +# 6605 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6621,9 +6624,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3774 "src/ocaml/preprocess/parser_raw.mly" +# 3794 "src/ocaml/preprocess/parser_raw.mly" ( "true" ) -# 6627 "src/ocaml/preprocess/parser_raw.ml" +# 6630 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6642,17 +6645,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) -# 6648 "src/ocaml/preprocess/parser_raw.ml" +# 6651 "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) = -# 3777 "src/ocaml/preprocess/parser_raw.mly" +# 3797 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6656 "src/ocaml/preprocess/parser_raw.ml" +# 6659 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6689,14 +6692,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = let _1 = -# 3768 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6695 "src/ocaml/preprocess/parser_raw.ml" +# 6698 "src/ocaml/preprocess/parser_raw.ml" in -# 3778 "src/ocaml/preprocess/parser_raw.mly" +# 3798 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6700 "src/ocaml/preprocess/parser_raw.ml" +# 6703 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6719,9 +6722,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3779 "src/ocaml/preprocess/parser_raw.mly" +# 3799 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6725 "src/ocaml/preprocess/parser_raw.ml" +# 6728 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6744,9 +6747,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3782 "src/ocaml/preprocess/parser_raw.mly" +# 3802 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6750 "src/ocaml/preprocess/parser_raw.ml" +# 6753 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6799,15 +6802,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let (_2, _1) = (_2_inlined1, _1_inlined1) in -# 3768 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6805 "src/ocaml/preprocess/parser_raw.ml" +# 6808 "src/ocaml/preprocess/parser_raw.ml" in -# 3783 "src/ocaml/preprocess/parser_raw.mly" +# 3803 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 6811 "src/ocaml/preprocess/parser_raw.ml" +# 6814 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6844,14 +6847,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = let _1 = -# 3768 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6850 "src/ocaml/preprocess/parser_raw.ml" +# 6853 "src/ocaml/preprocess/parser_raw.ml" in -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3804 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 6855 "src/ocaml/preprocess/parser_raw.ml" +# 6858 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6874,9 +6877,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3785 "src/ocaml/preprocess/parser_raw.mly" +# 3805 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 6880 "src/ocaml/preprocess/parser_raw.ml" +# 6883 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6913,9 +6916,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type * Parsetree.core_type) = -# 2232 "src/ocaml/preprocess/parser_raw.mly" +# 2251 "src/ocaml/preprocess/parser_raw.mly" ( _1, _3 ) -# 6919 "src/ocaml/preprocess/parser_raw.ml" +# 6922 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6940,26 +6943,26 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = let tys = let xs = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1114 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 6946 "src/ocaml/preprocess/parser_raw.ml" +# 6949 "src/ocaml/preprocess/parser_raw.ml" in # 253 "" ( List.rev xs ) -# 6951 "src/ocaml/preprocess/parser_raw.ml" +# 6954 "src/ocaml/preprocess/parser_raw.ml" in -# 1132 "src/ocaml/preprocess/parser_raw.mly" +# 1134 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 6957 "src/ocaml/preprocess/parser_raw.ml" +# 6960 "src/ocaml/preprocess/parser_raw.ml" in -# 3326 "src/ocaml/preprocess/parser_raw.mly" +# 3346 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_tuple tys ) -# 6963 "src/ocaml/preprocess/parser_raw.ml" +# 6966 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6998,26 +7001,26 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = let tys = let xs = let xs = -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 7004 "src/ocaml/preprocess/parser_raw.ml" +# 7007 "src/ocaml/preprocess/parser_raw.ml" in # 253 "" ( List.rev xs ) -# 7009 "src/ocaml/preprocess/parser_raw.ml" +# 7012 "src/ocaml/preprocess/parser_raw.ml" in -# 1132 "src/ocaml/preprocess/parser_raw.mly" +# 1134 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7015 "src/ocaml/preprocess/parser_raw.ml" +# 7018 "src/ocaml/preprocess/parser_raw.ml" in -# 3326 "src/ocaml/preprocess/parser_raw.mly" +# 3346 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_tuple tys ) -# 7021 "src/ocaml/preprocess/parser_raw.ml" +# 7024 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7054,9 +7057,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.constructor_arguments) = -# 3328 "src/ocaml/preprocess/parser_raw.mly" +# 3348 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_record _2 ) -# 7060 "src/ocaml/preprocess/parser_raw.ml" +# 7063 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7079,9 +7082,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constructor_declaration list) = -# 3242 "src/ocaml/preprocess/parser_raw.mly" +# 3262 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 7085 "src/ocaml/preprocess/parser_raw.ml" +# 7088 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7104,14 +7107,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.constructor_declaration list) = let cs = -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1219 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 7110 "src/ocaml/preprocess/parser_raw.ml" +# 7113 "src/ocaml/preprocess/parser_raw.ml" in -# 3244 "src/ocaml/preprocess/parser_raw.mly" +# 3264 "src/ocaml/preprocess/parser_raw.mly" ( cs ) -# 7115 "src/ocaml/preprocess/parser_raw.ml" +# 7118 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7134,14 +7137,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = -# 3485 "src/ocaml/preprocess/parser_raw.mly" +# 3505 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7140 "src/ocaml/preprocess/parser_raw.ml" +# 7143 "src/ocaml/preprocess/parser_raw.ml" in -# 3475 "src/ocaml/preprocess/parser_raw.mly" +# 3495 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7145 "src/ocaml/preprocess/parser_raw.ml" +# 7148 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7171,9 +7174,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = -# 3477 "src/ocaml/preprocess/parser_raw.mly" +# 3497 "src/ocaml/preprocess/parser_raw.mly" ( Typ.attr _1 _2 ) -# 7177 "src/ocaml/preprocess/parser_raw.ml" +# 7180 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7196,9 +7199,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.direction_flag) = -# 3882 "src/ocaml/preprocess/parser_raw.mly" +# 3902 "src/ocaml/preprocess/parser_raw.mly" ( Upto ) -# 7202 "src/ocaml/preprocess/parser_raw.ml" +# 7205 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7221,9 +7224,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.direction_flag) = -# 3883 "src/ocaml/preprocess/parser_raw.mly" +# 3903 "src/ocaml/preprocess/parser_raw.mly" ( Downto ) -# 7227 "src/ocaml/preprocess/parser_raw.ml" +# 7230 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7263,9 +7266,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4092 "src/ocaml/preprocess/parser_raw.mly" +# 4112 "src/ocaml/preprocess/parser_raw.mly" ( expr_of_lwt_bindings ~loc:_loc _1 (merloc _endpos__2_ _3) ) -# 7269 "src/ocaml/preprocess/parser_raw.ml" +# 7272 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7327,18 +7330,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7331 "src/ocaml/preprocess/parser_raw.ml" +# 7334 "src/ocaml/preprocess/parser_raw.ml" in -# 1189 "src/ocaml/preprocess/parser_raw.mly" +# 1191 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7336 "src/ocaml/preprocess/parser_raw.ml" +# 7339 "src/ocaml/preprocess/parser_raw.ml" in -# 2782 "src/ocaml/preprocess/parser_raw.mly" +# 2802 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7342 "src/ocaml/preprocess/parser_raw.ml" +# 7345 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos_xs_ in @@ -7347,26 +7350,26 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7353 "src/ocaml/preprocess/parser_raw.ml" +# 7356 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7359 "src/ocaml/preprocess/parser_raw.ml" +# 7362 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4094 "src/ocaml/preprocess/parser_raw.mly" +# 4114 "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 ) -# 7370 "src/ocaml/preprocess/parser_raw.ml" +# 7373 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7414,24 +7417,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7420 "src/ocaml/preprocess/parser_raw.ml" +# 7423 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7426 "src/ocaml/preprocess/parser_raw.ml" +# 7429 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4098 "src/ocaml/preprocess/parser_raw.mly" +# 4118 "src/ocaml/preprocess/parser_raw.mly" ( reloc_exp ~loc:_loc (Fake.app Fake.Lwt.in_lwt _3) ) -# 7435 "src/ocaml/preprocess/parser_raw.ml" +# 7438 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7493,18 +7496,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7497 "src/ocaml/preprocess/parser_raw.ml" +# 7500 "src/ocaml/preprocess/parser_raw.ml" in -# 1189 "src/ocaml/preprocess/parser_raw.mly" +# 1191 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7502 "src/ocaml/preprocess/parser_raw.ml" +# 7505 "src/ocaml/preprocess/parser_raw.ml" in -# 2782 "src/ocaml/preprocess/parser_raw.mly" +# 2802 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7508 "src/ocaml/preprocess/parser_raw.ml" +# 7511 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos_xs_ in @@ -7513,25 +7516,25 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7519 "src/ocaml/preprocess/parser_raw.ml" +# 7522 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7525 "src/ocaml/preprocess/parser_raw.ml" +# 7528 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4100 "src/ocaml/preprocess/parser_raw.mly" +# 4120 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_attrs ~loc:_loc (Pexp_try(Fake.app Fake.Lwt.in_lwt _3, List.rev _5)) _2 ) -# 7535 "src/ocaml/preprocess/parser_raw.ml" +# 7538 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7593,21 +7596,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7599 "src/ocaml/preprocess/parser_raw.ml" +# 7602 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7605 "src/ocaml/preprocess/parser_raw.ml" +# 7608 "src/ocaml/preprocess/parser_raw.ml" in -# 4103 "src/ocaml/preprocess/parser_raw.mly" +# 4123 "src/ocaml/preprocess/parser_raw.mly" ( Fake.app (Fake.app Fake.Lwt.finally_ _3) _5 ) -# 7611 "src/ocaml/preprocess/parser_raw.ml" +# 7614 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7683,18 +7686,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7687 "src/ocaml/preprocess/parser_raw.ml" +# 7690 "src/ocaml/preprocess/parser_raw.ml" in -# 1189 "src/ocaml/preprocess/parser_raw.mly" +# 1191 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7692 "src/ocaml/preprocess/parser_raw.ml" +# 7695 "src/ocaml/preprocess/parser_raw.ml" in -# 2782 "src/ocaml/preprocess/parser_raw.mly" +# 2802 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7698 "src/ocaml/preprocess/parser_raw.ml" +# 7701 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -7702,26 +7705,26 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7708 "src/ocaml/preprocess/parser_raw.ml" +# 7711 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7714 "src/ocaml/preprocess/parser_raw.ml" +# 7717 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4105 "src/ocaml/preprocess/parser_raw.mly" +# 4125 "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 ) -# 7725 "src/ocaml/preprocess/parser_raw.ml" +# 7728 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7790,25 +7793,25 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7796 "src/ocaml/preprocess/parser_raw.ml" +# 7799 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7802 "src/ocaml/preprocess/parser_raw.ml" +# 7805 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4109 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "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)) ) -# 7812 "src/ocaml/preprocess/parser_raw.ml" +# 7815 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7905,25 +7908,25 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7911 "src/ocaml/preprocess/parser_raw.ml" +# 7914 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7917 "src/ocaml/preprocess/parser_raw.ml" +# 7920 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__10_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4112 "src/ocaml/preprocess/parser_raw.mly" +# 4132 "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)) ) -# 7927 "src/ocaml/preprocess/parser_raw.ml" +# 7930 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8006,28 +8009,28 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8012 "src/ocaml/preprocess/parser_raw.ml" +# 8015 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8018 "src/ocaml/preprocess/parser_raw.ml" +# 8021 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__8_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4115 "src/ocaml/preprocess/parser_raw.mly" +# 4135 "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 ) -# 8031 "src/ocaml/preprocess/parser_raw.ml" +# 8034 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8050,9 +8053,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2399 "src/ocaml/preprocess/parser_raw.mly" +# 2418 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8056 "src/ocaml/preprocess/parser_raw.ml" +# 8059 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8130,9 +8133,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 8136 "src/ocaml/preprocess/parser_raw.ml" +# 8139 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -8140,21 +8143,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8146 "src/ocaml/preprocess/parser_raw.ml" +# 8149 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8152 "src/ocaml/preprocess/parser_raw.ml" +# 8155 "src/ocaml/preprocess/parser_raw.ml" in -# 2434 "src/ocaml/preprocess/parser_raw.mly" +# 2453 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_letmodule(_4, _5, (merloc _endpos__6_ _7)), _3 ) -# 8158 "src/ocaml/preprocess/parser_raw.ml" +# 8161 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8162,10 +8165,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8169 "src/ocaml/preprocess/parser_raw.ml" +# 8172 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8250,9 +8253,9 @@ module Tables = struct let _3 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8256 "src/ocaml/preprocess/parser_raw.ml" +# 8259 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -8261,19 +8264,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 8267 "src/ocaml/preprocess/parser_raw.ml" +# 8270 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3306 "src/ocaml/preprocess/parser_raw.mly" +# 3326 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = _2 in Te.decl _1 ~vars ~args ?res ~attrs:_3 ~loc:(make_loc _sloc) ) -# 8277 "src/ocaml/preprocess/parser_raw.ml" +# 8280 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -8281,21 +8284,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8287 "src/ocaml/preprocess/parser_raw.ml" +# 8290 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8293 "src/ocaml/preprocess/parser_raw.ml" +# 8296 "src/ocaml/preprocess/parser_raw.ml" in -# 2436 "src/ocaml/preprocess/parser_raw.mly" +# 2455 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_letexception(_4, _6), _3 ) -# 8299 "src/ocaml/preprocess/parser_raw.ml" +# 8302 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -8303,10 +8306,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8310 "src/ocaml/preprocess/parser_raw.ml" +# 8313 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8376,28 +8379,28 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8382 "src/ocaml/preprocess/parser_raw.ml" +# 8385 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8388 "src/ocaml/preprocess/parser_raw.ml" +# 8391 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 8394 "src/ocaml/preprocess/parser_raw.ml" +# 8397 "src/ocaml/preprocess/parser_raw.ml" in -# 2438 "src/ocaml/preprocess/parser_raw.mly" +# 2457 "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 ) -# 8401 "src/ocaml/preprocess/parser_raw.ml" +# 8404 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8405,10 +8408,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8412 "src/ocaml/preprocess/parser_raw.ml" +# 8415 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8485,31 +8488,31 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8491 "src/ocaml/preprocess/parser_raw.ml" +# 8494 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8497 "src/ocaml/preprocess/parser_raw.ml" +# 8500 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 8505 "src/ocaml/preprocess/parser_raw.ml" +# 8508 "src/ocaml/preprocess/parser_raw.ml" in -# 2438 "src/ocaml/preprocess/parser_raw.mly" +# 2457 "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 ) -# 8513 "src/ocaml/preprocess/parser_raw.ml" +# 8516 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8517,10 +8520,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8524 "src/ocaml/preprocess/parser_raw.ml" +# 8527 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8569,18 +8572,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8573 "src/ocaml/preprocess/parser_raw.ml" +# 8576 "src/ocaml/preprocess/parser_raw.ml" in -# 1189 "src/ocaml/preprocess/parser_raw.mly" +# 1191 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8578 "src/ocaml/preprocess/parser_raw.ml" +# 8581 "src/ocaml/preprocess/parser_raw.ml" in -# 2782 "src/ocaml/preprocess/parser_raw.mly" +# 2802 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8584 "src/ocaml/preprocess/parser_raw.ml" +# 8587 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -8588,21 +8591,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8594 "src/ocaml/preprocess/parser_raw.ml" +# 8597 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8600 "src/ocaml/preprocess/parser_raw.ml" +# 8603 "src/ocaml/preprocess/parser_raw.ml" in -# 2442 "src/ocaml/preprocess/parser_raw.mly" +# 2461 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_function _3, _2 ) -# 8606 "src/ocaml/preprocess/parser_raw.ml" +# 8609 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -8610,10 +8613,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8617 "src/ocaml/preprocess/parser_raw.ml" +# 8620 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8669,22 +8672,22 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8675 "src/ocaml/preprocess/parser_raw.ml" +# 8678 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8681 "src/ocaml/preprocess/parser_raw.ml" +# 8684 "src/ocaml/preprocess/parser_raw.ml" in -# 2444 "src/ocaml/preprocess/parser_raw.mly" +# 2463 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _3 in Pexp_fun(l, o, p, _4), _2 ) -# 8688 "src/ocaml/preprocess/parser_raw.ml" +# 8691 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -8692,10 +8695,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8699 "src/ocaml/preprocess/parser_raw.ml" +# 8702 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8768,33 +8771,33 @@ module Tables = struct let _endpos = _endpos__7_ in let _v : (Parsetree.expression) = let _1 = let _5 = -# 2666 "src/ocaml/preprocess/parser_raw.mly" +# 2689 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8774 "src/ocaml/preprocess/parser_raw.ml" +# 8777 "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 -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8783 "src/ocaml/preprocess/parser_raw.ml" +# 8786 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8789 "src/ocaml/preprocess/parser_raw.ml" +# 8792 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2447 "src/ocaml/preprocess/parser_raw.mly" +# 2466 "src/ocaml/preprocess/parser_raw.mly" ( (mk_newtypes ~loc:_sloc _5 _7).pexp_desc, _2 ) -# 8798 "src/ocaml/preprocess/parser_raw.ml" +# 8801 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8802,10 +8805,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8809 "src/ocaml/preprocess/parser_raw.ml" +# 8812 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8868,18 +8871,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8872 "src/ocaml/preprocess/parser_raw.ml" +# 8875 "src/ocaml/preprocess/parser_raw.ml" in -# 1189 "src/ocaml/preprocess/parser_raw.mly" +# 1191 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8877 "src/ocaml/preprocess/parser_raw.ml" +# 8880 "src/ocaml/preprocess/parser_raw.ml" in -# 2782 "src/ocaml/preprocess/parser_raw.mly" +# 2802 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8883 "src/ocaml/preprocess/parser_raw.ml" +# 8886 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -8887,21 +8890,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8893 "src/ocaml/preprocess/parser_raw.ml" +# 8896 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8899 "src/ocaml/preprocess/parser_raw.ml" +# 8902 "src/ocaml/preprocess/parser_raw.ml" in -# 2449 "src/ocaml/preprocess/parser_raw.mly" +# 2468 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_match(_3, _5), _2 ) -# 8905 "src/ocaml/preprocess/parser_raw.ml" +# 8908 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -8909,10 +8912,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8916 "src/ocaml/preprocess/parser_raw.ml" +# 8919 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8975,18 +8978,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8979 "src/ocaml/preprocess/parser_raw.ml" +# 8982 "src/ocaml/preprocess/parser_raw.ml" in -# 1189 "src/ocaml/preprocess/parser_raw.mly" +# 1191 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8984 "src/ocaml/preprocess/parser_raw.ml" +# 8987 "src/ocaml/preprocess/parser_raw.ml" in -# 2782 "src/ocaml/preprocess/parser_raw.mly" +# 2802 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8990 "src/ocaml/preprocess/parser_raw.ml" +# 8993 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -8994,21 +8997,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9000 "src/ocaml/preprocess/parser_raw.ml" +# 9003 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9006 "src/ocaml/preprocess/parser_raw.ml" +# 9009 "src/ocaml/preprocess/parser_raw.ml" in -# 2451 "src/ocaml/preprocess/parser_raw.mly" +# 2470 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_try(_3, _5), _2 ) -# 9012 "src/ocaml/preprocess/parser_raw.ml" +# 9015 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -9016,10 +9019,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9023 "src/ocaml/preprocess/parser_raw.ml" +# 9026 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9096,21 +9099,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9102 "src/ocaml/preprocess/parser_raw.ml" +# 9105 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9108 "src/ocaml/preprocess/parser_raw.ml" +# 9111 "src/ocaml/preprocess/parser_raw.ml" in -# 2457 "src/ocaml/preprocess/parser_raw.mly" +# 2476 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), Some (merloc _endpos__6_ _7)), _2 ) -# 9114 "src/ocaml/preprocess/parser_raw.ml" +# 9117 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -9118,10 +9121,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9125 "src/ocaml/preprocess/parser_raw.ml" +# 9128 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9184,21 +9187,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9190 "src/ocaml/preprocess/parser_raw.ml" +# 9193 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9196 "src/ocaml/preprocess/parser_raw.ml" +# 9199 "src/ocaml/preprocess/parser_raw.ml" in -# 2459 "src/ocaml/preprocess/parser_raw.mly" +# 2478 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), None), _2 ) -# 9202 "src/ocaml/preprocess/parser_raw.ml" +# 9205 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -9206,10 +9209,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9213 "src/ocaml/preprocess/parser_raw.ml" +# 9216 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9279,21 +9282,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9285 "src/ocaml/preprocess/parser_raw.ml" +# 9288 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9291 "src/ocaml/preprocess/parser_raw.ml" +# 9294 "src/ocaml/preprocess/parser_raw.ml" in -# 2461 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_while(_3, (merloc _endpos__4_ _5)), _2 ) -# 9297 "src/ocaml/preprocess/parser_raw.ml" +# 9300 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -9301,10 +9304,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9308 "src/ocaml/preprocess/parser_raw.ml" +# 9311 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9402,21 +9405,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9408 "src/ocaml/preprocess/parser_raw.ml" +# 9411 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9414 "src/ocaml/preprocess/parser_raw.ml" +# 9417 "src/ocaml/preprocess/parser_raw.ml" in -# 2464 "src/ocaml/preprocess/parser_raw.mly" +# 2487 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_for(_3, (merloc _endpos__4_ _5), (merloc _endpos__6_ _7), _6, (merloc _endpos__8_ _9)), _2 ) -# 9420 "src/ocaml/preprocess/parser_raw.ml" +# 9423 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__10_ in @@ -9424,10 +9427,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9431 "src/ocaml/preprocess/parser_raw.ml" +# 9434 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9476,21 +9479,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9482 "src/ocaml/preprocess/parser_raw.ml" +# 9485 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9488 "src/ocaml/preprocess/parser_raw.ml" +# 9491 "src/ocaml/preprocess/parser_raw.ml" in -# 2466 "src/ocaml/preprocess/parser_raw.mly" +# 2489 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_assert _3, _2 ) -# 9494 "src/ocaml/preprocess/parser_raw.ml" +# 9497 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -9498,10 +9501,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9505 "src/ocaml/preprocess/parser_raw.ml" +# 9508 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9550,21 +9553,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9556 "src/ocaml/preprocess/parser_raw.ml" +# 9559 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9562 "src/ocaml/preprocess/parser_raw.ml" +# 9565 "src/ocaml/preprocess/parser_raw.ml" in -# 2468 "src/ocaml/preprocess/parser_raw.mly" +# 2491 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_lazy _3, _2 ) -# 9568 "src/ocaml/preprocess/parser_raw.ml" +# 9571 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -9572,10 +9575,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2401 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9579 "src/ocaml/preprocess/parser_raw.ml" +# 9582 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9610,18 +9613,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9614 "src/ocaml/preprocess/parser_raw.ml" +# 9617 "src/ocaml/preprocess/parser_raw.ml" in -# 1096 "src/ocaml/preprocess/parser_raw.mly" +# 1098 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 9619 "src/ocaml/preprocess/parser_raw.ml" +# 9622 "src/ocaml/preprocess/parser_raw.ml" in -# 2472 "src/ocaml/preprocess/parser_raw.mly" +# 2495 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, _2) ) -# 9625 "src/ocaml/preprocess/parser_raw.ml" +# 9628 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -9629,15 +9632,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9635 "src/ocaml/preprocess/parser_raw.ml" +# 9638 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9641 "src/ocaml/preprocess/parser_raw.ml" +# 9644 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9666,24 +9669,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9670 "src/ocaml/preprocess/parser_raw.ml" +# 9673 "src/ocaml/preprocess/parser_raw.ml" in -# 1156 "src/ocaml/preprocess/parser_raw.mly" +# 1158 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 9675 "src/ocaml/preprocess/parser_raw.ml" +# 9678 "src/ocaml/preprocess/parser_raw.ml" in -# 2810 "src/ocaml/preprocess/parser_raw.mly" +# 2830 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 9681 "src/ocaml/preprocess/parser_raw.ml" +# 9684 "src/ocaml/preprocess/parser_raw.ml" in -# 2474 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_tuple(_1) ) -# 9687 "src/ocaml/preprocess/parser_raw.ml" +# 9690 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -9691,15 +9694,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9697 "src/ocaml/preprocess/parser_raw.ml" +# 9700 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9703 "src/ocaml/preprocess/parser_raw.ml" +# 9706 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9735,15 +9738,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 9741 "src/ocaml/preprocess/parser_raw.ml" +# 9744 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2499 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct(_1, Some _2) ) -# 9747 "src/ocaml/preprocess/parser_raw.ml" +# 9750 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -9751,15 +9754,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9757 "src/ocaml/preprocess/parser_raw.ml" +# 9760 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9763 "src/ocaml/preprocess/parser_raw.ml" +# 9766 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9790,24 +9793,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2478 "src/ocaml/preprocess/parser_raw.mly" +# 2501 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_variant(_1, Some _2) ) -# 9796 "src/ocaml/preprocess/parser_raw.ml" +# 9799 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9805 "src/ocaml/preprocess/parser_raw.ml" +# 9808 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9811 "src/ocaml/preprocess/parser_raw.ml" +# 9814 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9839,9 +9842,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 773 "src/ocaml/preprocess/parser_raw.mly" +# 775 "src/ocaml/preprocess/parser_raw.mly" (string) -# 9845 "src/ocaml/preprocess/parser_raw.ml" +# 9848 "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 @@ -9851,24 +9854,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3741 "src/ocaml/preprocess/parser_raw.mly" +# 3761 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 9857 "src/ocaml/preprocess/parser_raw.ml" +# 9860 "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 -# 1021 "src/ocaml/preprocess/parser_raw.mly" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 9866 "src/ocaml/preprocess/parser_raw.ml" +# 9869 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 9872 "src/ocaml/preprocess/parser_raw.ml" +# 9875 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9876,15 +9879,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9882 "src/ocaml/preprocess/parser_raw.ml" +# 9885 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9888 "src/ocaml/preprocess/parser_raw.ml" +# 9891 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9916,9 +9919,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 776 "src/ocaml/preprocess/parser_raw.mly" (string) -# 9922 "src/ocaml/preprocess/parser_raw.ml" +# 9925 "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 @@ -9928,24 +9931,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3742 "src/ocaml/preprocess/parser_raw.mly" +# 3762 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 9934 "src/ocaml/preprocess/parser_raw.ml" +# 9937 "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 -# 1021 "src/ocaml/preprocess/parser_raw.mly" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 9943 "src/ocaml/preprocess/parser_raw.ml" +# 9946 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 9949 "src/ocaml/preprocess/parser_raw.ml" +# 9952 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9953,15 +9956,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9959 "src/ocaml/preprocess/parser_raw.ml" +# 9962 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9965 "src/ocaml/preprocess/parser_raw.ml" +# 9968 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9993,9 +9996,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 777 "src/ocaml/preprocess/parser_raw.mly" (string) -# 9999 "src/ocaml/preprocess/parser_raw.ml" +# 10002 "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 @@ -10005,24 +10008,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3743 "src/ocaml/preprocess/parser_raw.mly" +# 3763 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10011 "src/ocaml/preprocess/parser_raw.ml" +# 10014 "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 -# 1021 "src/ocaml/preprocess/parser_raw.mly" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10020 "src/ocaml/preprocess/parser_raw.ml" +# 10023 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10026 "src/ocaml/preprocess/parser_raw.ml" +# 10029 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10030,15 +10033,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10036 "src/ocaml/preprocess/parser_raw.ml" +# 10039 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10042 "src/ocaml/preprocess/parser_raw.ml" +# 10045 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10070,9 +10073,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10076 "src/ocaml/preprocess/parser_raw.ml" +# 10079 "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 @@ -10082,24 +10085,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3744 "src/ocaml/preprocess/parser_raw.mly" +# 3764 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10088 "src/ocaml/preprocess/parser_raw.ml" +# 10091 "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 -# 1021 "src/ocaml/preprocess/parser_raw.mly" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10097 "src/ocaml/preprocess/parser_raw.ml" +# 10100 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10103 "src/ocaml/preprocess/parser_raw.ml" +# 10106 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10107,15 +10110,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10113 "src/ocaml/preprocess/parser_raw.ml" +# 10116 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10119 "src/ocaml/preprocess/parser_raw.ml" +# 10122 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10147,9 +10150,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 777 "src/ocaml/preprocess/parser_raw.mly" +# 779 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10153 "src/ocaml/preprocess/parser_raw.ml" +# 10156 "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 @@ -10159,24 +10162,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3745 "src/ocaml/preprocess/parser_raw.mly" +# 3765 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10165 "src/ocaml/preprocess/parser_raw.ml" +# 10168 "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 -# 1021 "src/ocaml/preprocess/parser_raw.mly" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10174 "src/ocaml/preprocess/parser_raw.ml" +# 10177 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10180 "src/ocaml/preprocess/parser_raw.ml" +# 10183 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10184,15 +10187,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10190 "src/ocaml/preprocess/parser_raw.ml" +# 10193 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10196 "src/ocaml/preprocess/parser_raw.ml" +# 10199 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10232,23 +10235,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3746 "src/ocaml/preprocess/parser_raw.mly" +# 3766 "src/ocaml/preprocess/parser_raw.mly" ("+") -# 10238 "src/ocaml/preprocess/parser_raw.ml" +# 10241 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10246 "src/ocaml/preprocess/parser_raw.ml" +# 10249 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10252 "src/ocaml/preprocess/parser_raw.ml" +# 10255 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10256,15 +10259,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10262 "src/ocaml/preprocess/parser_raw.ml" +# 10265 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10268 "src/ocaml/preprocess/parser_raw.ml" +# 10271 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10304,23 +10307,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3747 "src/ocaml/preprocess/parser_raw.mly" +# 3767 "src/ocaml/preprocess/parser_raw.mly" ("+.") -# 10310 "src/ocaml/preprocess/parser_raw.ml" +# 10313 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10318 "src/ocaml/preprocess/parser_raw.ml" +# 10321 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10324 "src/ocaml/preprocess/parser_raw.ml" +# 10327 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10328,15 +10331,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10334 "src/ocaml/preprocess/parser_raw.ml" +# 10337 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10340 "src/ocaml/preprocess/parser_raw.ml" +# 10343 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10376,23 +10379,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3748 "src/ocaml/preprocess/parser_raw.mly" +# 3768 "src/ocaml/preprocess/parser_raw.mly" ("+=") -# 10382 "src/ocaml/preprocess/parser_raw.ml" +# 10385 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10390 "src/ocaml/preprocess/parser_raw.ml" +# 10393 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10396 "src/ocaml/preprocess/parser_raw.ml" +# 10399 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10400,15 +10403,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10406 "src/ocaml/preprocess/parser_raw.ml" +# 10409 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10412 "src/ocaml/preprocess/parser_raw.ml" +# 10415 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10448,23 +10451,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3749 "src/ocaml/preprocess/parser_raw.mly" +# 3769 "src/ocaml/preprocess/parser_raw.mly" ("-") -# 10454 "src/ocaml/preprocess/parser_raw.ml" +# 10457 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10462 "src/ocaml/preprocess/parser_raw.ml" +# 10465 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10468 "src/ocaml/preprocess/parser_raw.ml" +# 10471 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10472,15 +10475,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10478 "src/ocaml/preprocess/parser_raw.ml" +# 10481 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10484 "src/ocaml/preprocess/parser_raw.ml" +# 10487 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10520,23 +10523,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3750 "src/ocaml/preprocess/parser_raw.mly" +# 3770 "src/ocaml/preprocess/parser_raw.mly" ("-.") -# 10526 "src/ocaml/preprocess/parser_raw.ml" +# 10529 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10534 "src/ocaml/preprocess/parser_raw.ml" +# 10537 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10540 "src/ocaml/preprocess/parser_raw.ml" +# 10543 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10544,15 +10547,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10550 "src/ocaml/preprocess/parser_raw.ml" +# 10553 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10556 "src/ocaml/preprocess/parser_raw.ml" +# 10559 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10592,23 +10595,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3751 "src/ocaml/preprocess/parser_raw.mly" +# 3771 "src/ocaml/preprocess/parser_raw.mly" ("*") -# 10598 "src/ocaml/preprocess/parser_raw.ml" +# 10601 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10606 "src/ocaml/preprocess/parser_raw.ml" +# 10609 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10612 "src/ocaml/preprocess/parser_raw.ml" +# 10615 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10616,15 +10619,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10622 "src/ocaml/preprocess/parser_raw.ml" +# 10625 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10628 "src/ocaml/preprocess/parser_raw.ml" +# 10631 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10664,23 +10667,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3752 "src/ocaml/preprocess/parser_raw.mly" +# 3772 "src/ocaml/preprocess/parser_raw.mly" ("%") -# 10670 "src/ocaml/preprocess/parser_raw.ml" +# 10673 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10678 "src/ocaml/preprocess/parser_raw.ml" +# 10681 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10684 "src/ocaml/preprocess/parser_raw.ml" +# 10687 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10688,15 +10691,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10694 "src/ocaml/preprocess/parser_raw.ml" +# 10697 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10700 "src/ocaml/preprocess/parser_raw.ml" +# 10703 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10736,23 +10739,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3753 "src/ocaml/preprocess/parser_raw.mly" +# 3773 "src/ocaml/preprocess/parser_raw.mly" ("=") -# 10742 "src/ocaml/preprocess/parser_raw.ml" +# 10745 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10750 "src/ocaml/preprocess/parser_raw.ml" +# 10753 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10756 "src/ocaml/preprocess/parser_raw.ml" +# 10759 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10760,15 +10763,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10766 "src/ocaml/preprocess/parser_raw.ml" +# 10769 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10772 "src/ocaml/preprocess/parser_raw.ml" +# 10775 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10808,23 +10811,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3754 "src/ocaml/preprocess/parser_raw.mly" +# 3774 "src/ocaml/preprocess/parser_raw.mly" ("<") -# 10814 "src/ocaml/preprocess/parser_raw.ml" +# 10817 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10822 "src/ocaml/preprocess/parser_raw.ml" +# 10825 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10828 "src/ocaml/preprocess/parser_raw.ml" +# 10831 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10832,15 +10835,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10838 "src/ocaml/preprocess/parser_raw.ml" +# 10841 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10844 "src/ocaml/preprocess/parser_raw.ml" +# 10847 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10880,23 +10883,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3755 "src/ocaml/preprocess/parser_raw.mly" +# 3775 "src/ocaml/preprocess/parser_raw.mly" (">") -# 10886 "src/ocaml/preprocess/parser_raw.ml" +# 10889 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10894 "src/ocaml/preprocess/parser_raw.ml" +# 10897 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10900 "src/ocaml/preprocess/parser_raw.ml" +# 10903 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10904,15 +10907,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10910 "src/ocaml/preprocess/parser_raw.ml" +# 10913 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10916 "src/ocaml/preprocess/parser_raw.ml" +# 10919 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10952,23 +10955,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3756 "src/ocaml/preprocess/parser_raw.mly" +# 3776 "src/ocaml/preprocess/parser_raw.mly" ("or") -# 10958 "src/ocaml/preprocess/parser_raw.ml" +# 10961 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10966 "src/ocaml/preprocess/parser_raw.ml" +# 10969 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10972 "src/ocaml/preprocess/parser_raw.ml" +# 10975 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10976,15 +10979,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10982 "src/ocaml/preprocess/parser_raw.ml" +# 10985 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10988 "src/ocaml/preprocess/parser_raw.ml" +# 10991 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11024,23 +11027,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3757 "src/ocaml/preprocess/parser_raw.mly" +# 3777 "src/ocaml/preprocess/parser_raw.mly" ("||") -# 11030 "src/ocaml/preprocess/parser_raw.ml" +# 11033 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11038 "src/ocaml/preprocess/parser_raw.ml" +# 11041 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11044 "src/ocaml/preprocess/parser_raw.ml" +# 11047 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11048,15 +11051,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11054 "src/ocaml/preprocess/parser_raw.ml" +# 11057 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11060 "src/ocaml/preprocess/parser_raw.ml" +# 11063 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11096,23 +11099,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3778 "src/ocaml/preprocess/parser_raw.mly" ("&") -# 11102 "src/ocaml/preprocess/parser_raw.ml" +# 11105 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11110 "src/ocaml/preprocess/parser_raw.ml" +# 11113 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11116 "src/ocaml/preprocess/parser_raw.ml" +# 11119 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11120,15 +11123,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11126 "src/ocaml/preprocess/parser_raw.ml" +# 11129 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11132 "src/ocaml/preprocess/parser_raw.ml" +# 11135 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11168,23 +11171,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3759 "src/ocaml/preprocess/parser_raw.mly" +# 3779 "src/ocaml/preprocess/parser_raw.mly" ("&&") -# 11174 "src/ocaml/preprocess/parser_raw.ml" +# 11177 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11182 "src/ocaml/preprocess/parser_raw.ml" +# 11185 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11188 "src/ocaml/preprocess/parser_raw.ml" +# 11191 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11192,15 +11195,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11198 "src/ocaml/preprocess/parser_raw.ml" +# 11201 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11204 "src/ocaml/preprocess/parser_raw.ml" +# 11207 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11240,23 +11243,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3760 "src/ocaml/preprocess/parser_raw.mly" +# 3780 "src/ocaml/preprocess/parser_raw.mly" (":=") -# 11246 "src/ocaml/preprocess/parser_raw.ml" +# 11249 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11254 "src/ocaml/preprocess/parser_raw.ml" +# 11257 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11260 "src/ocaml/preprocess/parser_raw.ml" +# 11263 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11264,15 +11267,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11270 "src/ocaml/preprocess/parser_raw.ml" +# 11273 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11276 "src/ocaml/preprocess/parser_raw.ml" +# 11279 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11305,9 +11308,9 @@ module Tables = struct let _1 = let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 2482 "src/ocaml/preprocess/parser_raw.mly" +# 2505 "src/ocaml/preprocess/parser_raw.mly" ( mkuminus ~oploc:_loc__1_ _1 _2 ) -# 11311 "src/ocaml/preprocess/parser_raw.ml" +# 11314 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -11315,15 +11318,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11321 "src/ocaml/preprocess/parser_raw.ml" +# 11324 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11327 "src/ocaml/preprocess/parser_raw.ml" +# 11330 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11356,9 +11359,9 @@ module Tables = struct let _1 = let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 2484 "src/ocaml/preprocess/parser_raw.mly" +# 2507 "src/ocaml/preprocess/parser_raw.mly" ( mkuplus ~oploc:_loc__1_ _1 _2 ) -# 11362 "src/ocaml/preprocess/parser_raw.ml" +# 11365 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -11366,15 +11369,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11372 "src/ocaml/preprocess/parser_raw.ml" +# 11375 "src/ocaml/preprocess/parser_raw.ml" in -# 2404 "src/ocaml/preprocess/parser_raw.mly" +# 2423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11378 "src/ocaml/preprocess/parser_raw.ml" +# 11381 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11414,9 +11417,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2406 "src/ocaml/preprocess/parser_raw.mly" +# 2425 "src/ocaml/preprocess/parser_raw.mly" ( expr_of_let_bindings ~loc:_sloc _1 (merloc _endpos__2_ _3) ) -# 11420 "src/ocaml/preprocess/parser_raw.ml" +# 11423 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11456,9 +11459,9 @@ module Tables = struct let _3 : unit = Obj.magic _3 in let bindings : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = Obj.magic bindings in let _1 : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 781 "src/ocaml/preprocess/parser_raw.mly" (string) -# 11462 "src/ocaml/preprocess/parser_raw.ml" +# 11465 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -11468,9 +11471,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11474 "src/ocaml/preprocess/parser_raw.ml" +# 11477 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_pbop_op_ = _startpos__1_ in @@ -11478,13 +11481,13 @@ module Tables = struct let _symbolstartpos = _startpos_pbop_op_ in let _sloc = (_symbolstartpos, _endpos) in -# 2408 "src/ocaml/preprocess/parser_raw.mly" +# 2427 "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}) ) -# 11488 "src/ocaml/preprocess/parser_raw.ml" +# 11491 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11525,9 +11528,9 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2433 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_cons ~loc:_sloc _loc__2_ (ghexp ~loc:_sloc (Pexp_tuple[_1;(merloc _endpos__2_ _3)])) ) -# 11531 "src/ocaml/preprocess/parser_raw.ml" +# 11534 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11560,35 +11563,35 @@ module Tables = struct let _3 : (Parsetree.expression) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 11566 "src/ocaml/preprocess/parser_raw.ml" +# 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__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11575 "src/ocaml/preprocess/parser_raw.ml" +# 11578 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11583 "src/ocaml/preprocess/parser_raw.ml" +# 11586 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2416 "src/ocaml/preprocess/parser_raw.mly" +# 2435 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc (Pexp_setinstvar(_1, _3)) ) -# 11592 "src/ocaml/preprocess/parser_raw.ml" +# 11595 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11644,18 +11647,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11650 "src/ocaml/preprocess/parser_raw.ml" +# 11653 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2418 "src/ocaml/preprocess/parser_raw.mly" +# 2437 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc (Pexp_setfield(_1, _3, _5)) ) -# 11659 "src/ocaml/preprocess/parser_raw.ml" +# 11662 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11721,14 +11724,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2419 "src/ocaml/preprocess/parser_raw.mly" +# 2438 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11727 "src/ocaml/preprocess/parser_raw.ml" +# 11730 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2398 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 11732 "src/ocaml/preprocess/parser_raw.ml" +# 11735 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11736,9 +11739,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2439 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11742 "src/ocaml/preprocess/parser_raw.ml" +# 11745 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11804,14 +11807,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2419 "src/ocaml/preprocess/parser_raw.mly" +# 2438 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11810 "src/ocaml/preprocess/parser_raw.ml" +# 11813 "src/ocaml/preprocess/parser_raw.ml" in -# 2381 "src/ocaml/preprocess/parser_raw.mly" +# 2400 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 11815 "src/ocaml/preprocess/parser_raw.ml" +# 11818 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11819,9 +11822,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2439 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11825 "src/ocaml/preprocess/parser_raw.ml" +# 11828 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11887,14 +11890,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2419 "src/ocaml/preprocess/parser_raw.mly" +# 2438 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11893 "src/ocaml/preprocess/parser_raw.ml" +# 11896 "src/ocaml/preprocess/parser_raw.ml" in -# 2383 "src/ocaml/preprocess/parser_raw.mly" +# 2402 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 11898 "src/ocaml/preprocess/parser_raw.ml" +# 11901 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11902,9 +11905,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2439 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11908 "src/ocaml/preprocess/parser_raw.ml" +# 11911 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11964,9 +11967,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 11970 "src/ocaml/preprocess/parser_raw.ml" +# 11973 "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 @@ -11974,31 +11977,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2421 "src/ocaml/preprocess/parser_raw.mly" +# 2440 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11980 "src/ocaml/preprocess/parser_raw.ml" +# 11983 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 11985 "src/ocaml/preprocess/parser_raw.ml" +# 11988 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 11991 "src/ocaml/preprocess/parser_raw.ml" +# 11994 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 11996 "src/ocaml/preprocess/parser_raw.ml" +# 11999 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2398 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 12002 "src/ocaml/preprocess/parser_raw.ml" +# 12005 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12006,9 +12009,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2422 "src/ocaml/preprocess/parser_raw.mly" +# 2441 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12012 "src/ocaml/preprocess/parser_raw.ml" +# 12015 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12080,9 +12083,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12086 "src/ocaml/preprocess/parser_raw.ml" +# 12089 "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 @@ -12094,40 +12097,40 @@ module Tables = struct let r = let _1 = _1_inlined1 in -# 2421 "src/ocaml/preprocess/parser_raw.mly" +# 2440 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12100 "src/ocaml/preprocess/parser_raw.ml" +# 12103 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12106 "src/ocaml/preprocess/parser_raw.ml" +# 12109 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 12114 "src/ocaml/preprocess/parser_raw.ml" +# 12117 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12119 "src/ocaml/preprocess/parser_raw.ml" +# 12122 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12125 "src/ocaml/preprocess/parser_raw.ml" +# 12128 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2398 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 12131 "src/ocaml/preprocess/parser_raw.ml" +# 12134 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12135,9 +12138,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2422 "src/ocaml/preprocess/parser_raw.mly" +# 2441 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12141 "src/ocaml/preprocess/parser_raw.ml" +# 12144 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12197,9 +12200,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12203 "src/ocaml/preprocess/parser_raw.ml" +# 12206 "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 @@ -12207,31 +12210,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2421 "src/ocaml/preprocess/parser_raw.mly" +# 2440 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12213 "src/ocaml/preprocess/parser_raw.ml" +# 12216 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12218 "src/ocaml/preprocess/parser_raw.ml" +# 12221 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12224 "src/ocaml/preprocess/parser_raw.ml" +# 12227 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12229 "src/ocaml/preprocess/parser_raw.ml" +# 12232 "src/ocaml/preprocess/parser_raw.ml" in -# 2381 "src/ocaml/preprocess/parser_raw.mly" +# 2400 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 12235 "src/ocaml/preprocess/parser_raw.ml" +# 12238 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12239,9 +12242,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2422 "src/ocaml/preprocess/parser_raw.mly" +# 2441 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12245 "src/ocaml/preprocess/parser_raw.ml" +# 12248 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12313,9 +12316,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12319 "src/ocaml/preprocess/parser_raw.ml" +# 12322 "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 @@ -12327,40 +12330,40 @@ module Tables = struct let r = let _1 = _1_inlined1 in -# 2421 "src/ocaml/preprocess/parser_raw.mly" +# 2440 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12333 "src/ocaml/preprocess/parser_raw.ml" +# 12336 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12339 "src/ocaml/preprocess/parser_raw.ml" +# 12342 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 12347 "src/ocaml/preprocess/parser_raw.ml" +# 12350 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12352 "src/ocaml/preprocess/parser_raw.ml" +# 12355 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12358 "src/ocaml/preprocess/parser_raw.ml" +# 12361 "src/ocaml/preprocess/parser_raw.ml" in -# 2381 "src/ocaml/preprocess/parser_raw.mly" +# 2400 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 12364 "src/ocaml/preprocess/parser_raw.ml" +# 12367 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12368,9 +12371,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2422 "src/ocaml/preprocess/parser_raw.mly" +# 2441 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12374 "src/ocaml/preprocess/parser_raw.ml" +# 12377 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12430,9 +12433,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12436 "src/ocaml/preprocess/parser_raw.ml" +# 12439 "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 @@ -12440,31 +12443,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2421 "src/ocaml/preprocess/parser_raw.mly" +# 2440 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12446 "src/ocaml/preprocess/parser_raw.ml" +# 12449 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12451 "src/ocaml/preprocess/parser_raw.ml" +# 12454 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12457 "src/ocaml/preprocess/parser_raw.ml" +# 12460 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12462 "src/ocaml/preprocess/parser_raw.ml" +# 12465 "src/ocaml/preprocess/parser_raw.ml" in -# 2383 "src/ocaml/preprocess/parser_raw.mly" +# 2402 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 12468 "src/ocaml/preprocess/parser_raw.ml" +# 12471 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12472,9 +12475,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2422 "src/ocaml/preprocess/parser_raw.mly" +# 2441 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12478 "src/ocaml/preprocess/parser_raw.ml" +# 12481 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12546,9 +12549,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12552 "src/ocaml/preprocess/parser_raw.ml" +# 12555 "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 @@ -12560,40 +12563,40 @@ module Tables = struct let r = let _1 = _1_inlined1 in -# 2421 "src/ocaml/preprocess/parser_raw.mly" +# 2440 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12566 "src/ocaml/preprocess/parser_raw.ml" +# 12569 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12572 "src/ocaml/preprocess/parser_raw.ml" +# 12575 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 12580 "src/ocaml/preprocess/parser_raw.ml" +# 12583 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12585 "src/ocaml/preprocess/parser_raw.ml" +# 12588 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12591 "src/ocaml/preprocess/parser_raw.ml" +# 12594 "src/ocaml/preprocess/parser_raw.ml" in -# 2383 "src/ocaml/preprocess/parser_raw.mly" +# 2402 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 12597 "src/ocaml/preprocess/parser_raw.ml" +# 12600 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12601,9 +12604,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2422 "src/ocaml/preprocess/parser_raw.mly" +# 2441 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12607 "src/ocaml/preprocess/parser_raw.ml" +# 12610 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12633,9 +12636,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2424 "src/ocaml/preprocess/parser_raw.mly" +# 2443 "src/ocaml/preprocess/parser_raw.mly" ( Exp.attr _1 _2 ) -# 12639 "src/ocaml/preprocess/parser_raw.ml" +# 12642 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12651,9 +12654,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (string Location.loc option) = -# 4038 "src/ocaml/preprocess/parser_raw.mly" +# 4058 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 12657 "src/ocaml/preprocess/parser_raw.ml" +# 12660 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12683,9 +12686,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string Location.loc option) = -# 4039 "src/ocaml/preprocess/parser_raw.mly" +# 4059 "src/ocaml/preprocess/parser_raw.mly" ( Some _2 ) -# 12689 "src/ocaml/preprocess/parser_raw.ml" +# 12692 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12729,9 +12732,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.extension) = -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4071 "src/ocaml/preprocess/parser_raw.mly" ( (_2, _3) ) -# 12735 "src/ocaml/preprocess/parser_raw.ml" +# 12738 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12750,9 +12753,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 837 "src/ocaml/preprocess/parser_raw.mly" +# 839 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 12756 "src/ocaml/preprocess/parser_raw.ml" +# 12759 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -12761,9 +12764,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4053 "src/ocaml/preprocess/parser_raw.mly" +# 4073 "src/ocaml/preprocess/parser_raw.mly" ( mk_quotedext ~loc:_sloc _1 ) -# 12767 "src/ocaml/preprocess/parser_raw.ml" +# 12770 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12816,9 +12819,9 @@ module Tables = struct let _v : (Parsetree.extension_constructor) = let attrs = let _1 = _1_inlined3 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 12822 "src/ocaml/preprocess/parser_raw.ml" +# 12825 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined3_ in @@ -12828,9 +12831,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12834 "src/ocaml/preprocess/parser_raw.ml" +# 12837 "src/ocaml/preprocess/parser_raw.ml" in let cid = @@ -12839,19 +12842,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12845 "src/ocaml/preprocess/parser_raw.ml" +# 12848 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3395 "src/ocaml/preprocess/parser_raw.mly" +# 3415 "src/ocaml/preprocess/parser_raw.mly" ( let info = symbol_info _endpos in Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 12855 "src/ocaml/preprocess/parser_raw.ml" +# 12858 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12897,9 +12900,9 @@ module Tables = struct let _v : (Parsetree.extension_constructor) = let attrs = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 12903 "src/ocaml/preprocess/parser_raw.ml" +# 12906 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined2_ in @@ -12909,9 +12912,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12915 "src/ocaml/preprocess/parser_raw.ml" +# 12918 "src/ocaml/preprocess/parser_raw.ml" in let cid = @@ -12919,25 +12922,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 12925 "src/ocaml/preprocess/parser_raw.ml" +# 12928 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_cid_ = _startpos__1_ in let _1 = -# 3856 "src/ocaml/preprocess/parser_raw.mly" +# 3876 "src/ocaml/preprocess/parser_raw.mly" ( () ) -# 12932 "src/ocaml/preprocess/parser_raw.ml" +# 12935 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos_cid_ in let _sloc = (_symbolstartpos, _endpos) in -# 3395 "src/ocaml/preprocess/parser_raw.mly" +# 3415 "src/ocaml/preprocess/parser_raw.mly" ( let info = symbol_info _endpos in Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 12941 "src/ocaml/preprocess/parser_raw.ml" +# 12944 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12984,10 +12987,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4026 "src/ocaml/preprocess/parser_raw.mly" +# 4046 "src/ocaml/preprocess/parser_raw.mly" ( mark_symbol_docs _sloc; Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 12991 "src/ocaml/preprocess/parser_raw.ml" +# 12994 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13003,14 +13006,14 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let params = -# 2172 "src/ocaml/preprocess/parser_raw.mly" +# 2191 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 13009 "src/ocaml/preprocess/parser_raw.ml" +# 13012 "src/ocaml/preprocess/parser_raw.ml" in -# 1989 "src/ocaml/preprocess/parser_raw.mly" +# 2008 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 13014 "src/ocaml/preprocess/parser_raw.ml" +# 13017 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13051,24 +13054,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 13055 "src/ocaml/preprocess/parser_raw.ml" +# 13058 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13060 "src/ocaml/preprocess/parser_raw.ml" +# 13063 "src/ocaml/preprocess/parser_raw.ml" in -# 2174 "src/ocaml/preprocess/parser_raw.mly" +# 2193 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 13066 "src/ocaml/preprocess/parser_raw.ml" +# 13069 "src/ocaml/preprocess/parser_raw.ml" in -# 1989 "src/ocaml/preprocess/parser_raw.mly" +# 2008 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 13072 "src/ocaml/preprocess/parser_raw.ml" +# 13075 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13091,9 +13094,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2768 "src/ocaml/preprocess/parser_raw.mly" +# 2788 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13097 "src/ocaml/preprocess/parser_raw.ml" +# 13100 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13133,9 +13136,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2770 "src/ocaml/preprocess/parser_raw.mly" +# 2790 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_constraint ~loc:_sloc _3 _1 ) -# 13139 "src/ocaml/preprocess/parser_raw.ml" +# 13142 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13165,9 +13168,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2795 "src/ocaml/preprocess/parser_raw.mly" +# 2815 "src/ocaml/preprocess/parser_raw.mly" ( (merloc _endpos__1_ _2) ) -# 13171 "src/ocaml/preprocess/parser_raw.ml" +# 13174 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13212,24 +13215,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2797 "src/ocaml/preprocess/parser_raw.mly" +# 2817 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_constraint ((merloc _endpos__3_ _4), _2) ) -# 13218 "src/ocaml/preprocess/parser_raw.ml" +# 13221 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 13227 "src/ocaml/preprocess/parser_raw.ml" +# 13230 "src/ocaml/preprocess/parser_raw.ml" in -# 2798 "src/ocaml/preprocess/parser_raw.mly" +# 2818 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13233 "src/ocaml/preprocess/parser_raw.ml" +# 13236 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13262,12 +13265,12 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2801 "src/ocaml/preprocess/parser_raw.mly" +# 2821 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) ) -# 13271 "src/ocaml/preprocess/parser_raw.ml" +# 13274 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13318,17 +13321,17 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _3 = -# 2666 "src/ocaml/preprocess/parser_raw.mly" +# 2689 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13324 "src/ocaml/preprocess/parser_raw.ml" +# 13327 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2806 "src/ocaml/preprocess/parser_raw.mly" +# 2826 "src/ocaml/preprocess/parser_raw.mly" ( mk_newtypes ~loc:_sloc _3 _5 ) -# 13332 "src/ocaml/preprocess/parser_raw.ml" +# 13335 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13351,9 +13354,9 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.core_type) = -# 3511 "src/ocaml/preprocess/parser_raw.mly" +# 3531 "src/ocaml/preprocess/parser_raw.mly" ( ty ) -# 13357 "src/ocaml/preprocess/parser_raw.ml" +# 13360 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13399,19 +13402,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 992 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13405 "src/ocaml/preprocess/parser_raw.ml" +# 13408 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3523 "src/ocaml/preprocess/parser_raw.mly" +# 3543 "src/ocaml/preprocess/parser_raw.mly" ( Optional label ) -# 13410 "src/ocaml/preprocess/parser_raw.ml" +# 13413 "src/ocaml/preprocess/parser_raw.ml" in -# 3517 "src/ocaml/preprocess/parser_raw.mly" +# 3537 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13415 "src/ocaml/preprocess/parser_raw.ml" +# 13418 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13419,15 +13422,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13425 "src/ocaml/preprocess/parser_raw.ml" +# 13428 "src/ocaml/preprocess/parser_raw.ml" in -# 3519 "src/ocaml/preprocess/parser_raw.mly" +# 3539 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13431 "src/ocaml/preprocess/parser_raw.ml" +# 13434 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13474,9 +13477,9 @@ module Tables = struct let _1 : (Parsetree.core_type) = Obj.magic _1 in let _2 : unit = Obj.magic _2 in let label : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 13480 "src/ocaml/preprocess/parser_raw.ml" +# 13483 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -13484,19 +13487,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 992 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13490 "src/ocaml/preprocess/parser_raw.ml" +# 13493 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3525 "src/ocaml/preprocess/parser_raw.mly" +# 3545 "src/ocaml/preprocess/parser_raw.mly" ( Labelled label ) -# 13495 "src/ocaml/preprocess/parser_raw.ml" +# 13498 "src/ocaml/preprocess/parser_raw.ml" in -# 3517 "src/ocaml/preprocess/parser_raw.mly" +# 3537 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13500 "src/ocaml/preprocess/parser_raw.ml" +# 13503 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13504,15 +13507,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13510 "src/ocaml/preprocess/parser_raw.ml" +# 13513 "src/ocaml/preprocess/parser_raw.ml" in -# 3519 "src/ocaml/preprocess/parser_raw.mly" +# 3539 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13516 "src/ocaml/preprocess/parser_raw.ml" +# 13519 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13551,19 +13554,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 992 "src/ocaml/preprocess/parser_raw.mly" +# 994 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13557 "src/ocaml/preprocess/parser_raw.ml" +# 13560 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3527 "src/ocaml/preprocess/parser_raw.mly" +# 3547 "src/ocaml/preprocess/parser_raw.mly" ( Nolabel ) -# 13562 "src/ocaml/preprocess/parser_raw.ml" +# 13565 "src/ocaml/preprocess/parser_raw.ml" in -# 3517 "src/ocaml/preprocess/parser_raw.mly" +# 3537 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13567 "src/ocaml/preprocess/parser_raw.ml" +# 13570 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_codomain_ in @@ -13571,15 +13574,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13577 "src/ocaml/preprocess/parser_raw.ml" +# 13580 "src/ocaml/preprocess/parser_raw.ml" in -# 3519 "src/ocaml/preprocess/parser_raw.mly" +# 3539 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13583 "src/ocaml/preprocess/parser_raw.ml" +# 13586 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13610,9 +13613,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Lexing.position * Parsetree.functor_parameter) = let _startpos = _startpos__1_ in -# 1383 "src/ocaml/preprocess/parser_raw.mly" +# 1385 "src/ocaml/preprocess/parser_raw.mly" ( _startpos, Unit ) -# 13616 "src/ocaml/preprocess/parser_raw.ml" +# 13619 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13668,16 +13671,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 13674 "src/ocaml/preprocess/parser_raw.ml" +# 13677 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1386 "src/ocaml/preprocess/parser_raw.mly" +# 1388 "src/ocaml/preprocess/parser_raw.mly" ( _startpos, Named (x, mty) ) -# 13681 "src/ocaml/preprocess/parser_raw.ml" +# 13684 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13700,9 +13703,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1375 "src/ocaml/preprocess/parser_raw.mly" +# 1377 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13706 "src/ocaml/preprocess/parser_raw.ml" +# 13709 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13719,9 +13722,9 @@ module Tables = struct let _endpos = _startpos in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3310 "src/ocaml/preprocess/parser_raw.mly" +# 3330 "src/ocaml/preprocess/parser_raw.mly" ( ([],Pcstr_tuple [],None) ) -# 13725 "src/ocaml/preprocess/parser_raw.ml" +# 13728 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13752,9 +13755,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3311 "src/ocaml/preprocess/parser_raw.mly" +# 3331 "src/ocaml/preprocess/parser_raw.mly" ( ([],_2,None) ) -# 13758 "src/ocaml/preprocess/parser_raw.ml" +# 13761 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13799,9 +13802,9 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3313 "src/ocaml/preprocess/parser_raw.mly" +# 3333 "src/ocaml/preprocess/parser_raw.mly" ( ([],_2,Some _4) ) -# 13805 "src/ocaml/preprocess/parser_raw.ml" +# 13808 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13864,24 +13867,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 13868 "src/ocaml/preprocess/parser_raw.ml" +# 13871 "src/ocaml/preprocess/parser_raw.ml" in -# 1096 "src/ocaml/preprocess/parser_raw.mly" +# 1098 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13873 "src/ocaml/preprocess/parser_raw.ml" +# 13876 "src/ocaml/preprocess/parser_raw.ml" in -# 3446 "src/ocaml/preprocess/parser_raw.mly" +# 3466 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13879 "src/ocaml/preprocess/parser_raw.ml" +# 13882 "src/ocaml/preprocess/parser_raw.ml" in -# 3316 "src/ocaml/preprocess/parser_raw.mly" +# 3336 "src/ocaml/preprocess/parser_raw.mly" ( (_2,_4,Some _6) ) -# 13885 "src/ocaml/preprocess/parser_raw.ml" +# 13888 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13912,9 +13915,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3318 "src/ocaml/preprocess/parser_raw.mly" +# 3338 "src/ocaml/preprocess/parser_raw.mly" ( ([],Pcstr_tuple [],Some _2) ) -# 13918 "src/ocaml/preprocess/parser_raw.ml" +# 13921 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13963,24 +13966,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 13967 "src/ocaml/preprocess/parser_raw.ml" +# 13970 "src/ocaml/preprocess/parser_raw.ml" in -# 1096 "src/ocaml/preprocess/parser_raw.mly" +# 1098 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13972 "src/ocaml/preprocess/parser_raw.ml" +# 13975 "src/ocaml/preprocess/parser_raw.ml" in -# 3446 "src/ocaml/preprocess/parser_raw.mly" +# 3466 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13978 "src/ocaml/preprocess/parser_raw.ml" +# 13981 "src/ocaml/preprocess/parser_raw.ml" in -# 3320 "src/ocaml/preprocess/parser_raw.mly" +# 3340 "src/ocaml/preprocess/parser_raw.mly" ( (_2,Pcstr_tuple [],Some _4) ) -# 13984 "src/ocaml/preprocess/parser_raw.ml" +# 13987 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14029,9 +14032,9 @@ module Tables = struct Parsetree.attributes * Location.t * Ocaml_parsing.Docstrings.info) = let attrs = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14035 "src/ocaml/preprocess/parser_raw.ml" +# 14038 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined2_ in @@ -14041,23 +14044,23 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14047 "src/ocaml/preprocess/parser_raw.ml" +# 14050 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3258 "src/ocaml/preprocess/parser_raw.mly" +# 3278 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let info = symbol_info _endpos in let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 14061 "src/ocaml/preprocess/parser_raw.ml" +# 14064 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14099,9 +14102,9 @@ module Tables = struct Parsetree.attributes * Location.t * Ocaml_parsing.Docstrings.info) = let attrs = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14105 "src/ocaml/preprocess/parser_raw.ml" +# 14108 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined1_ in @@ -14110,29 +14113,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14116 "src/ocaml/preprocess/parser_raw.ml" +# 14119 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_cid_ = _startpos__1_ in let _1 = -# 3856 "src/ocaml/preprocess/parser_raw.mly" +# 3876 "src/ocaml/preprocess/parser_raw.mly" ( () ) -# 14123 "src/ocaml/preprocess/parser_raw.ml" +# 14126 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos_cid_ in let _sloc = (_symbolstartpos, _endpos) in -# 3258 "src/ocaml/preprocess/parser_raw.mly" +# 3278 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let info = symbol_info _endpos in let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 14136 "src/ocaml/preprocess/parser_raw.ml" +# 14139 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14203,9 +14206,9 @@ module Tables = struct 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 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14209 "src/ocaml/preprocess/parser_raw.ml" +# 14212 "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 @@ -14218,9 +14221,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14224 "src/ocaml/preprocess/parser_raw.ml" +# 14227 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14229,26 +14232,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14233 "src/ocaml/preprocess/parser_raw.ml" +# 14236 "src/ocaml/preprocess/parser_raw.ml" in -# 1078 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14238 "src/ocaml/preprocess/parser_raw.ml" +# 14241 "src/ocaml/preprocess/parser_raw.ml" in -# 3161 "src/ocaml/preprocess/parser_raw.mly" +# 3181 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14244 "src/ocaml/preprocess/parser_raw.ml" +# 14247 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined3 in -# 3196 "src/ocaml/preprocess/parser_raw.mly" +# 3216 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 14252 "src/ocaml/preprocess/parser_raw.ml" +# 14255 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14257,29 +14260,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14263 "src/ocaml/preprocess/parser_raw.ml" +# 14266 "src/ocaml/preprocess/parser_raw.ml" in let flag = -# 3876 "src/ocaml/preprocess/parser_raw.mly" +# 3896 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 14269 "src/ocaml/preprocess/parser_raw.ml" +# 14272 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14276 "src/ocaml/preprocess/parser_raw.ml" +# 14279 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3133 "src/ocaml/preprocess/parser_raw.mly" +# 3153 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14288,7 +14291,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14292 "src/ocaml/preprocess/parser_raw.ml" +# 14295 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14365,9 +14368,9 @@ module Tables = struct 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 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14371 "src/ocaml/preprocess/parser_raw.ml" +# 14374 "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 @@ -14381,9 +14384,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined5 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14387 "src/ocaml/preprocess/parser_raw.ml" +# 14390 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined5_ in @@ -14392,26 +14395,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14396 "src/ocaml/preprocess/parser_raw.ml" +# 14399 "src/ocaml/preprocess/parser_raw.ml" in -# 1078 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14401 "src/ocaml/preprocess/parser_raw.ml" +# 14404 "src/ocaml/preprocess/parser_raw.ml" in -# 3161 "src/ocaml/preprocess/parser_raw.mly" +# 3181 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14407 "src/ocaml/preprocess/parser_raw.ml" +# 14410 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined4 in -# 3196 "src/ocaml/preprocess/parser_raw.mly" +# 3216 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 14415 "src/ocaml/preprocess/parser_raw.ml" +# 14418 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14420,9 +14423,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14426 "src/ocaml/preprocess/parser_raw.ml" +# 14429 "src/ocaml/preprocess/parser_raw.ml" in let flag = @@ -14431,24 +14434,24 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3878 "src/ocaml/preprocess/parser_raw.mly" +# 3898 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 14437 "src/ocaml/preprocess/parser_raw.ml" +# 14440 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14445 "src/ocaml/preprocess/parser_raw.ml" +# 14448 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3133 "src/ocaml/preprocess/parser_raw.mly" +# 3153 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14457,7 +14460,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14461 "src/ocaml/preprocess/parser_raw.ml" +# 14464 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14521,9 +14524,9 @@ module Tables = struct 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 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14527 "src/ocaml/preprocess/parser_raw.ml" +# 14530 "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 @@ -14536,9 +14539,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14542 "src/ocaml/preprocess/parser_raw.ml" +# 14545 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -14547,18 +14550,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14551 "src/ocaml/preprocess/parser_raw.ml" +# 14554 "src/ocaml/preprocess/parser_raw.ml" in -# 1078 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14556 "src/ocaml/preprocess/parser_raw.ml" +# 14559 "src/ocaml/preprocess/parser_raw.ml" in -# 3161 "src/ocaml/preprocess/parser_raw.mly" +# 3181 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14562 "src/ocaml/preprocess/parser_raw.ml" +# 14565 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14567,29 +14570,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14573 "src/ocaml/preprocess/parser_raw.ml" +# 14576 "src/ocaml/preprocess/parser_raw.ml" in let flag = -# 3872 "src/ocaml/preprocess/parser_raw.mly" +# 3892 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 14579 "src/ocaml/preprocess/parser_raw.ml" +# 14582 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14586 "src/ocaml/preprocess/parser_raw.ml" +# 14589 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3133 "src/ocaml/preprocess/parser_raw.mly" +# 3153 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14598,7 +14601,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14602 "src/ocaml/preprocess/parser_raw.ml" +# 14605 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14668,9 +14671,9 @@ module Tables = struct 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 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14674 "src/ocaml/preprocess/parser_raw.ml" +# 14677 "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 @@ -14684,9 +14687,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14690 "src/ocaml/preprocess/parser_raw.ml" +# 14693 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14695,18 +14698,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14699 "src/ocaml/preprocess/parser_raw.ml" +# 14702 "src/ocaml/preprocess/parser_raw.ml" in -# 1078 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14704 "src/ocaml/preprocess/parser_raw.ml" +# 14707 "src/ocaml/preprocess/parser_raw.ml" in -# 3161 "src/ocaml/preprocess/parser_raw.mly" +# 3181 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14710 "src/ocaml/preprocess/parser_raw.ml" +# 14713 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14715,32 +14718,32 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14721 "src/ocaml/preprocess/parser_raw.ml" +# 14724 "src/ocaml/preprocess/parser_raw.ml" in let flag = let _1 = _1_inlined2 in -# 3873 "src/ocaml/preprocess/parser_raw.mly" +# 3893 "src/ocaml/preprocess/parser_raw.mly" ( Nonrecursive ) -# 14729 "src/ocaml/preprocess/parser_raw.ml" +# 14732 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14737 "src/ocaml/preprocess/parser_raw.ml" +# 14740 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3133 "src/ocaml/preprocess/parser_raw.mly" +# 3153 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14749,7 +14752,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14753 "src/ocaml/preprocess/parser_raw.ml" +# 14756 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14768,17 +14771,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14774 "src/ocaml/preprocess/parser_raw.ml" +# 14777 "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) = -# 3711 "src/ocaml/preprocess/parser_raw.mly" +# 3731 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14782 "src/ocaml/preprocess/parser_raw.ml" +# 14785 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14797,17 +14800,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14803 "src/ocaml/preprocess/parser_raw.ml" +# 14806 "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) = -# 3712 "src/ocaml/preprocess/parser_raw.mly" +# 3732 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14811 "src/ocaml/preprocess/parser_raw.ml" +# 14814 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14837,9 +14840,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.structure) = -# 1249 "src/ocaml/preprocess/parser_raw.mly" +# 1251 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14843 "src/ocaml/preprocess/parser_raw.ml" +# 14846 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14855,9 +14858,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (string) = -# 3763 "src/ocaml/preprocess/parser_raw.mly" +# 3783 "src/ocaml/preprocess/parser_raw.mly" ( "" ) -# 14861 "src/ocaml/preprocess/parser_raw.ml" +# 14864 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14887,9 +14890,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3764 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( ";.." ) -# 14893 "src/ocaml/preprocess/parser_raw.ml" +# 14896 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14919,9 +14922,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.signature) = -# 1256 "src/ocaml/preprocess/parser_raw.mly" +# 1258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14925 "src/ocaml/preprocess/parser_raw.ml" +# 14928 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14965,9 +14968,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.extension) = -# 4056 "src/ocaml/preprocess/parser_raw.mly" +# 4076 "src/ocaml/preprocess/parser_raw.mly" ( (_2, _3) ) -# 14971 "src/ocaml/preprocess/parser_raw.ml" +# 14974 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14986,9 +14989,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 840 "src/ocaml/preprocess/parser_raw.mly" +# 842 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 14992 "src/ocaml/preprocess/parser_raw.ml" +# 14995 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -14997,9 +15000,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4058 "src/ocaml/preprocess/parser_raw.mly" +# 4078 "src/ocaml/preprocess/parser_raw.mly" ( mk_quotedext ~loc:_sloc _1 ) -# 15003 "src/ocaml/preprocess/parser_raw.ml" +# 15006 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15045,9 +15048,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _3 : unit = Obj.magic _3 in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15051 "src/ocaml/preprocess/parser_raw.ml" +# 15054 "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 @@ -15056,34 +15059,34 @@ module Tables = struct let _v : (Parsetree.label_declaration) = let _5 = let _1 = _1_inlined3 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15062 "src/ocaml/preprocess/parser_raw.ml" +# 15065 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 3464 "src/ocaml/preprocess/parser_raw.mly" +# 3484 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15071 "src/ocaml/preprocess/parser_raw.ml" +# 15074 "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 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15079 "src/ocaml/preprocess/parser_raw.ml" +# 15082 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15087 "src/ocaml/preprocess/parser_raw.ml" +# 15090 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15094,10 +15097,10 @@ module Tables = struct _startpos__2_ in let _sloc = (_symbolstartpos, _endpos) in -# 3337 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "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 ) -# 15101 "src/ocaml/preprocess/parser_raw.ml" +# 15104 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15157,9 +15160,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _3 : unit = Obj.magic _3 in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15163 "src/ocaml/preprocess/parser_raw.ml" +# 15166 "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 @@ -15168,43 +15171,43 @@ module Tables = struct let _v : (Parsetree.label_declaration) = let _7 = let _1 = _1_inlined4 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15174 "src/ocaml/preprocess/parser_raw.ml" +# 15177 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__7_ = _endpos__1_inlined4_ in let _5 = let _1 = _1_inlined3 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15183 "src/ocaml/preprocess/parser_raw.ml" +# 15186 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 3464 "src/ocaml/preprocess/parser_raw.mly" +# 3484 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15192 "src/ocaml/preprocess/parser_raw.ml" +# 15195 "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 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15200 "src/ocaml/preprocess/parser_raw.ml" +# 15203 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15208 "src/ocaml/preprocess/parser_raw.ml" +# 15211 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15215,14 +15218,14 @@ module Tables = struct _startpos__2_ in let _sloc = (_symbolstartpos, _endpos) in -# 3342 "src/ocaml/preprocess/parser_raw.mly" +# 3362 "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 ) -# 15226 "src/ocaml/preprocess/parser_raw.ml" +# 15229 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15245,9 +15248,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.label_declaration list) = -# 3331 "src/ocaml/preprocess/parser_raw.mly" +# 3351 "src/ocaml/preprocess/parser_raw.mly" ( [_1] ) -# 15251 "src/ocaml/preprocess/parser_raw.ml" +# 15254 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15270,9 +15273,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.label_declaration list) = -# 3332 "src/ocaml/preprocess/parser_raw.mly" +# 3352 "src/ocaml/preprocess/parser_raw.mly" ( [_1] ) -# 15276 "src/ocaml/preprocess/parser_raw.ml" +# 15279 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15302,9 +15305,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.label_declaration list) = -# 3333 "src/ocaml/preprocess/parser_raw.mly" +# 3353 "src/ocaml/preprocess/parser_raw.mly" ( _1 :: _2 ) -# 15308 "src/ocaml/preprocess/parser_raw.ml" +# 15311 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15323,9 +15326,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15329 "src/ocaml/preprocess/parser_raw.ml" +# 15332 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15336,24 +15339,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15342 "src/ocaml/preprocess/parser_raw.ml" +# 15345 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2367 "src/ocaml/preprocess/parser_raw.mly" +# 2386 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15351 "src/ocaml/preprocess/parser_raw.ml" +# 15354 "src/ocaml/preprocess/parser_raw.ml" in -# 2359 "src/ocaml/preprocess/parser_raw.mly" +# 2378 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 15357 "src/ocaml/preprocess/parser_raw.ml" +# 15360 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15386,9 +15389,9 @@ module Tables = struct let cty : (Parsetree.core_type) = Obj.magic cty in let _2 : unit = Obj.magic _2 in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15392 "src/ocaml/preprocess/parser_raw.ml" +# 15395 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15399,18 +15402,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15405 "src/ocaml/preprocess/parser_raw.ml" +# 15408 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2367 "src/ocaml/preprocess/parser_raw.mly" +# 2386 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15414 "src/ocaml/preprocess/parser_raw.ml" +# 15417 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_x_ = _startpos__1_ in @@ -15418,11 +15421,11 @@ module Tables = struct let _symbolstartpos = _startpos_x_ in let _sloc = (_symbolstartpos, _endpos) in -# 2361 "src/ocaml/preprocess/parser_raw.mly" +# 2380 "src/ocaml/preprocess/parser_raw.mly" ( let lab, pat = x in lab, mkpat ~loc:_sloc (Ppat_constraint (pat, cty)) ) -# 15426 "src/ocaml/preprocess/parser_raw.ml" +# 15429 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15445,9 +15448,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3795 "src/ocaml/preprocess/parser_raw.mly" +# 3815 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15451 "src/ocaml/preprocess/parser_raw.ml" +# 15454 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15470,9 +15473,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.arg_label * Parsetree.expression) = -# 2649 "src/ocaml/preprocess/parser_raw.mly" +# 2672 "src/ocaml/preprocess/parser_raw.mly" ( (Nolabel, _1) ) -# 15476 "src/ocaml/preprocess/parser_raw.ml" +# 15479 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15498,17 +15501,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 784 "src/ocaml/preprocess/parser_raw.mly" +# 786 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15504 "src/ocaml/preprocess/parser_raw.ml" +# 15507 "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) = -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2674 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled _1, _2) ) -# 15512 "src/ocaml/preprocess/parser_raw.ml" +# 15515 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15533,9 +15536,9 @@ module Tables = struct }; } = _menhir_stack in let label : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15539 "src/ocaml/preprocess/parser_raw.ml" +# 15542 "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 @@ -15543,10 +15546,10 @@ module Tables = struct let _endpos = _endpos_label_ in let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2653 "src/ocaml/preprocess/parser_raw.mly" +# 2676 "src/ocaml/preprocess/parser_raw.mly" ( let loc = _loc_label_ in (Labelled label, mkexpvar ~loc label) ) -# 15550 "src/ocaml/preprocess/parser_raw.ml" +# 15553 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15591,9 +15594,9 @@ module Tables = struct let _5 : unit = Obj.magic _5 in let ty : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic ty in let label : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15597 "src/ocaml/preprocess/parser_raw.ml" +# 15600 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _2 : unit = Obj.magic _2 in let _1 : unit = Obj.magic _1 in @@ -15603,10 +15606,10 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression) = let _endpos = _endpos__5_ in let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2656 "src/ocaml/preprocess/parser_raw.mly" +# 2679 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled label, mkexp_constraint ~loc:(_startpos__2_, _endpos) (mkexpvar ~loc:_loc_label_ label) ty) ) -# 15610 "src/ocaml/preprocess/parser_raw.ml" +# 15613 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15631,9 +15634,9 @@ module Tables = struct }; } = _menhir_stack in let label : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15637 "src/ocaml/preprocess/parser_raw.ml" +# 15640 "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 @@ -15641,10 +15644,10 @@ module Tables = struct let _endpos = _endpos_label_ in let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2659 "src/ocaml/preprocess/parser_raw.mly" +# 2682 "src/ocaml/preprocess/parser_raw.mly" ( let loc = _loc_label_ in (Optional label, mkexpvar ~loc label) ) -# 15648 "src/ocaml/preprocess/parser_raw.ml" +# 15651 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15670,17 +15673,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 814 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15676 "src/ocaml/preprocess/parser_raw.ml" +# 15679 "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) = -# 2662 "src/ocaml/preprocess/parser_raw.mly" +# 2685 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, _2) ) -# 15684 "src/ocaml/preprocess/parser_raw.ml" +# 15687 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15733,15 +15736,15 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 = let _1 = _1_inlined1 in -# 2355 "src/ocaml/preprocess/parser_raw.mly" +# 2374 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15739 "src/ocaml/preprocess/parser_raw.ml" +# 15742 "src/ocaml/preprocess/parser_raw.ml" in -# 2329 "src/ocaml/preprocess/parser_raw.mly" +# 2348 "src/ocaml/preprocess/parser_raw.mly" ( (Optional (fst _3), _4, snd _3) ) -# 15745 "src/ocaml/preprocess/parser_raw.ml" +# 15748 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15766,9 +15769,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15772 "src/ocaml/preprocess/parser_raw.ml" +# 15775 "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 @@ -15781,24 +15784,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15787 "src/ocaml/preprocess/parser_raw.ml" +# 15790 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2367 "src/ocaml/preprocess/parser_raw.mly" +# 2386 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15796 "src/ocaml/preprocess/parser_raw.ml" +# 15799 "src/ocaml/preprocess/parser_raw.ml" in -# 2331 "src/ocaml/preprocess/parser_raw.mly" +# 2350 "src/ocaml/preprocess/parser_raw.mly" ( (Optional (fst _2), None, snd _2) ) -# 15802 "src/ocaml/preprocess/parser_raw.ml" +# 15805 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15845,9 +15848,9 @@ module Tables = struct let _3 : (Parsetree.pattern) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 814 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15851 "src/ocaml/preprocess/parser_raw.ml" +# 15854 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15855,15 +15858,15 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 = let _1 = _1_inlined1 in -# 2355 "src/ocaml/preprocess/parser_raw.mly" +# 2374 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15861 "src/ocaml/preprocess/parser_raw.ml" +# 15864 "src/ocaml/preprocess/parser_raw.ml" in -# 2333 "src/ocaml/preprocess/parser_raw.mly" +# 2352 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, _4, _3) ) -# 15867 "src/ocaml/preprocess/parser_raw.ml" +# 15870 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15889,17 +15892,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.pattern) = Obj.magic _2 in let _1 : ( -# 814 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15895 "src/ocaml/preprocess/parser_raw.ml" +# 15898 "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) = -# 2335 "src/ocaml/preprocess/parser_raw.mly" +# 2354 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, None, _2) ) -# 15903 "src/ocaml/preprocess/parser_raw.ml" +# 15906 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15943,9 +15946,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2337 "src/ocaml/preprocess/parser_raw.mly" +# 2356 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled (fst _3), None, snd _3) ) -# 15949 "src/ocaml/preprocess/parser_raw.ml" +# 15952 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15970,9 +15973,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15976 "src/ocaml/preprocess/parser_raw.ml" +# 15979 "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 @@ -15985,24 +15988,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15991 "src/ocaml/preprocess/parser_raw.ml" +# 15994 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2367 "src/ocaml/preprocess/parser_raw.mly" +# 2386 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 16000 "src/ocaml/preprocess/parser_raw.ml" +# 16003 "src/ocaml/preprocess/parser_raw.ml" in -# 2339 "src/ocaml/preprocess/parser_raw.mly" +# 2358 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled (fst _2), None, snd _2) ) -# 16006 "src/ocaml/preprocess/parser_raw.ml" +# 16009 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16028,17 +16031,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.pattern) = Obj.magic _2 in let _1 : ( -# 784 "src/ocaml/preprocess/parser_raw.mly" +# 786 "src/ocaml/preprocess/parser_raw.mly" (string) -# 16034 "src/ocaml/preprocess/parser_raw.ml" +# 16037 "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) = -# 2341 "src/ocaml/preprocess/parser_raw.mly" +# 2360 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled _1, None, _2) ) -# 16042 "src/ocaml/preprocess/parser_raw.ml" +# 16045 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16061,9 +16064,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2343 "src/ocaml/preprocess/parser_raw.mly" +# 2362 "src/ocaml/preprocess/parser_raw.mly" ( (Nolabel, None, _1) ) -# 16067 "src/ocaml/preprocess/parser_raw.ml" +# 16070 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16081,14 +16084,16 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let _1 : (Parsetree.pattern * Parsetree.expression) = Obj.magic _1 in + let _1 : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint 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.pattern * Parsetree.expression * bool) = -# 2705 "src/ocaml/preprocess/parser_raw.mly" - ( let p,e = _1 in (p,e,false) ) -# 16092 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option * bool) = +# 2725 "src/ocaml/preprocess/parser_raw.mly" + ( let p,e,c = _1 in (p,e,c,false) ) +# 16097 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16110,13 +16115,14 @@ module Tables = struct 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 _v : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option * bool) = let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2708 "src/ocaml/preprocess/parser_raw.mly" - ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1, true) ) -# 16120 "src/ocaml/preprocess/parser_raw.ml" +# 2728 "src/ocaml/preprocess/parser_raw.mly" + ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1, None, true) ) +# 16126 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16145,20 +16151,21 @@ module Tables = struct 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 _v : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option) = let _1 = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2669 "src/ocaml/preprocess/parser_raw.mly" +# 2692 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16156 "src/ocaml/preprocess/parser_raw.ml" +# 16163 "src/ocaml/preprocess/parser_raw.ml" in -# 2673 "src/ocaml/preprocess/parser_raw.mly" - ( (_1, _2) ) -# 16162 "src/ocaml/preprocess/parser_raw.ml" +# 2696 "src/ocaml/preprocess/parser_raw.mly" + ( (_1, _2, None) ) +# 16169 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16201,34 +16208,30 @@ module Tables = struct 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 _v : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option) = let _1 = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2669 "src/ocaml/preprocess/parser_raw.mly" +# 2692 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16212 "src/ocaml/preprocess/parser_raw.ml" +# 16220 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__4_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in -# 2675 "src/ocaml/preprocess/parser_raw.mly" +# 2698 "src/ocaml/preprocess/parser_raw.mly" ( let v = _1 in (* PR#7344 *) let t = match _2 with - Some t, None -> t - | _, Some t -> t + Some t, None -> + Pvc_constraint { locally_abstract_univars = []; typ=t } + | ground, Some coercion -> Pvc_coercion { ground; coercion} | _ -> 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) ) -# 16232 "src/ocaml/preprocess/parser_raw.ml" + (v, _4, Some t) + ) +# 16235 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16292,31 +16295,32 @@ module Tables = struct 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) = let _3 = + let _v : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option) = let _3 = let _2 = _2_inlined1 in let _1 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 16303 "src/ocaml/preprocess/parser_raw.ml" +# 16307 "src/ocaml/preprocess/parser_raw.ml" in -# 1096 "src/ocaml/preprocess/parser_raw.mly" +# 1098 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 16308 "src/ocaml/preprocess/parser_raw.ml" +# 16312 "src/ocaml/preprocess/parser_raw.ml" in -# 3446 "src/ocaml/preprocess/parser_raw.mly" +# 3466 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16314 "src/ocaml/preprocess/parser_raw.ml" +# 16318 "src/ocaml/preprocess/parser_raw.ml" in -# 3450 "src/ocaml/preprocess/parser_raw.mly" +# 3470 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 16320 "src/ocaml/preprocess/parser_raw.ml" +# 16324 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__3_ = _startpos_xs_ in @@ -16325,19 +16329,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2669 "src/ocaml/preprocess/parser_raw.mly" +# 2692 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16331 "src/ocaml/preprocess/parser_raw.ml" +# 16335 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2688 "src/ocaml/preprocess/parser_raw.mly" - ( let patloc = (_startpos__1_, _endpos__3_) in - (ghpat ~loc:patloc - (Ppat_constraint(_1, ghtyp ~loc:(_loc__3_) _3)), - _5) ) -# 16341 "src/ocaml/preprocess/parser_raw.ml" +# 2709 "src/ocaml/preprocess/parser_raw.mly" + ( + let t = ghtyp ~loc:(_loc__3_) _3 in + (_1, _5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) + ) +# 16345 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16408,31 +16412,29 @@ module Tables = struct 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 = -# 2666 "src/ocaml/preprocess/parser_raw.mly" + let _v : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option) = let _4 = +# 2689 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 16415 "src/ocaml/preprocess/parser_raw.ml" +# 16420 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2669 "src/ocaml/preprocess/parser_raw.mly" +# 2692 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16424 "src/ocaml/preprocess/parser_raw.ml" +# 16429 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__8_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in -# 2693 "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) ) -# 16436 "src/ocaml/preprocess/parser_raw.ml" +# 2714 "src/ocaml/preprocess/parser_raw.mly" + ( let constraint' = + Pvc_constraint { locally_abstract_univars=_4; typ = _6} + in + (_1, _8, Some constraint') ) +# 16438 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16468,10 +16470,11 @@ module Tables = struct 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) = -# 2698 "src/ocaml/preprocess/parser_raw.mly" - ( (_1, _3) ) -# 16475 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option) = +# 2719 "src/ocaml/preprocess/parser_raw.mly" + ( (_1, _3, None) ) +# 16478 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16521,11 +16524,11 @@ module Tables = struct 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) = -# 2700 "src/ocaml/preprocess/parser_raw.mly" - ( let loc = (_startpos__1_, _endpos__3_) in - (ghpat ~loc (Ppat_constraint(_1, _3)), _5) ) -# 16529 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option) = +# 2721 "src/ocaml/preprocess/parser_raw.mly" + ( (_1, _5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=_3 })) ) +# 16532 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16574,7 +16577,8 @@ module Tables = struct }; } = _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 body : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option * 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 @@ -16586,36 +16590,36 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16592 "src/ocaml/preprocess/parser_raw.ml" +# 16596 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16601 "src/ocaml/preprocess/parser_raw.ml" +# 16605 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2728 "src/ocaml/preprocess/parser_raw.mly" +# 2748 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 16613 "src/ocaml/preprocess/parser_raw.ml" +# 16617 "src/ocaml/preprocess/parser_raw.ml" in -# 2718 "src/ocaml/preprocess/parser_raw.mly" +# 2738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16619 "src/ocaml/preprocess/parser_raw.ml" +# 16623 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16645,9 +16649,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 2719 "src/ocaml/preprocess/parser_raw.mly" +# 2739 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 16651 "src/ocaml/preprocess/parser_raw.ml" +# 16655 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16690,7 +16694,8 @@ module Tables = struct }; } = _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 body : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option * 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 @@ -16701,41 +16706,41 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16707 "src/ocaml/preprocess/parser_raw.ml" +# 16712 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16716 "src/ocaml/preprocess/parser_raw.ml" +# 16721 "src/ocaml/preprocess/parser_raw.ml" in let ext = -# 4042 "src/ocaml/preprocess/parser_raw.mly" +# 4062 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 16722 "src/ocaml/preprocess/parser_raw.ml" +# 16727 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2728 "src/ocaml/preprocess/parser_raw.mly" +# 2748 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 16733 "src/ocaml/preprocess/parser_raw.ml" +# 16738 "src/ocaml/preprocess/parser_raw.ml" in -# 2718 "src/ocaml/preprocess/parser_raw.mly" +# 2738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16739 "src/ocaml/preprocess/parser_raw.ml" +# 16744 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16790,7 +16795,8 @@ module Tables = struct }; } = _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 body : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option * 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 @@ -16803,18 +16809,18 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16809 "src/ocaml/preprocess/parser_raw.ml" +# 16815 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let attrs1 = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16818 "src/ocaml/preprocess/parser_raw.ml" +# 16824 "src/ocaml/preprocess/parser_raw.ml" in let ext = @@ -16823,27 +16829,27 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4044 "src/ocaml/preprocess/parser_raw.mly" +# 4064 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "extension"; None ) -# 16829 "src/ocaml/preprocess/parser_raw.ml" +# 16835 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2728 "src/ocaml/preprocess/parser_raw.mly" +# 2748 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 16841 "src/ocaml/preprocess/parser_raw.ml" +# 16847 "src/ocaml/preprocess/parser_raw.ml" in -# 2718 "src/ocaml/preprocess/parser_raw.mly" +# 2738 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16847 "src/ocaml/preprocess/parser_raw.ml" +# 16853 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16873,9 +16879,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 2719 "src/ocaml/preprocess/parser_raw.mly" +# 2739 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 16879 "src/ocaml/preprocess/parser_raw.ml" +# 16885 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16898,9 +16904,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2371 "src/ocaml/preprocess/parser_raw.mly" +# 2390 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16904 "src/ocaml/preprocess/parser_raw.ml" +# 16910 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16938,24 +16944,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2373 "src/ocaml/preprocess/parser_raw.mly" +# 2392 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_1, _3) ) -# 16944 "src/ocaml/preprocess/parser_raw.ml" +# 16950 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 16953 "src/ocaml/preprocess/parser_raw.ml" +# 16959 "src/ocaml/preprocess/parser_raw.ml" in -# 2374 "src/ocaml/preprocess/parser_raw.mly" +# 2393 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16959 "src/ocaml/preprocess/parser_raw.ml" +# 16965 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16989,15 +16995,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2669 "src/ocaml/preprocess/parser_raw.mly" +# 2692 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16995 "src/ocaml/preprocess/parser_raw.ml" +# 17001 "src/ocaml/preprocess/parser_raw.ml" in -# 2745 "src/ocaml/preprocess/parser_raw.mly" +# 2765 "src/ocaml/preprocess/parser_raw.mly" ( (pat, exp) ) -# 17001 "src/ocaml/preprocess/parser_raw.ml" +# 17007 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17023,9 +17029,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2748 "src/ocaml/preprocess/parser_raw.mly" +# 2768 "src/ocaml/preprocess/parser_raw.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1) ) -# 17029 "src/ocaml/preprocess/parser_raw.ml" +# 17035 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17076,10 +17082,10 @@ module Tables = struct let _startpos = _startpos_pat_ in let _endpos = _endpos_exp_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2750 "src/ocaml/preprocess/parser_raw.mly" +# 2770 "src/ocaml/preprocess/parser_raw.mly" ( let loc = (_startpos_pat_, _endpos_typ_) in (ghpat ~loc (Ppat_constraint(pat, typ)), exp) ) -# 17083 "src/ocaml/preprocess/parser_raw.ml" +# 17089 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17116,9 +17122,9 @@ module Tables = struct let _startpos = _startpos_pat_ in let _endpos = _endpos_exp_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2753 "src/ocaml/preprocess/parser_raw.mly" +# 2773 "src/ocaml/preprocess/parser_raw.mly" ( (pat, exp) ) -# 17122 "src/ocaml/preprocess/parser_raw.ml" +# 17128 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17141,10 +17147,10 @@ module Tables = struct let _startpos = _startpos_body_ in let _endpos = _endpos_body_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = -# 2757 "src/ocaml/preprocess/parser_raw.mly" +# 2777 "src/ocaml/preprocess/parser_raw.mly" ( let let_pat, let_exp = body in let_pat, let_exp, [] ) -# 17148 "src/ocaml/preprocess/parser_raw.ml" +# 17154 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17176,9 +17182,9 @@ module Tables = struct } = _menhir_stack in let body : (Parsetree.pattern * Parsetree.expression) = Obj.magic body in let _1 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 782 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17182 "src/ocaml/preprocess/parser_raw.ml" +# 17188 "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 @@ -17189,22 +17195,22 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17195 "src/ocaml/preprocess/parser_raw.ml" +# 17201 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_body_ in let _symbolstartpos = _startpos_bindings_ in let _sloc = (_symbolstartpos, _endpos) in -# 2760 "src/ocaml/preprocess/parser_raw.mly" +# 2780 "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 ) -# 17208 "src/ocaml/preprocess/parser_raw.ml" +# 17214 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17222,7 +17228,7 @@ module Tables = struct let _v : (Parsetree.class_expr Parsetree.class_infos list) = # 211 "" ( [] ) -# 17226 "src/ocaml/preprocess/parser_raw.ml" +# 17232 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17286,9 +17292,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17292 "src/ocaml/preprocess/parser_raw.ml" +# 17298 "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 @@ -17301,9 +17307,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17307 "src/ocaml/preprocess/parser_raw.ml" +# 17313 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17313,24 +17319,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17319 "src/ocaml/preprocess/parser_raw.ml" +# 17325 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17327 "src/ocaml/preprocess/parser_raw.ml" +# 17333 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1967 "src/ocaml/preprocess/parser_raw.mly" +# 1986 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17338,13 +17344,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs ) -# 17342 "src/ocaml/preprocess/parser_raw.ml" +# 17348 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17348 "src/ocaml/preprocess/parser_raw.ml" +# 17354 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17362,7 +17368,7 @@ module Tables = struct let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 17366 "src/ocaml/preprocess/parser_raw.ml" +# 17372 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17433,9 +17439,9 @@ module Tables = struct let cty : (Parsetree.class_type) = Obj.magic cty in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17439 "src/ocaml/preprocess/parser_raw.ml" +# 17445 "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 @@ -17448,9 +17454,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17454 "src/ocaml/preprocess/parser_raw.ml" +# 17460 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17460,24 +17466,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17466 "src/ocaml/preprocess/parser_raw.ml" +# 17472 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17474 "src/ocaml/preprocess/parser_raw.ml" +# 17480 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2266 "src/ocaml/preprocess/parser_raw.mly" +# 2285 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17485,13 +17491,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs ) -# 17489 "src/ocaml/preprocess/parser_raw.ml" +# 17495 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17495 "src/ocaml/preprocess/parser_raw.ml" +# 17501 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17509,7 +17515,7 @@ module Tables = struct let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 17513 "src/ocaml/preprocess/parser_raw.ml" +# 17519 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17580,9 +17586,9 @@ module Tables = struct let csig : (Parsetree.class_type) = Obj.magic csig in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17586 "src/ocaml/preprocess/parser_raw.ml" +# 17592 "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 @@ -17595,9 +17601,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17601 "src/ocaml/preprocess/parser_raw.ml" +# 17607 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17607,24 +17613,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17613 "src/ocaml/preprocess/parser_raw.ml" +# 17619 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17621 "src/ocaml/preprocess/parser_raw.ml" +# 17627 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2305 "src/ocaml/preprocess/parser_raw.mly" +# 2324 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17632,13 +17638,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs ) -# 17636 "src/ocaml/preprocess/parser_raw.ml" +# 17642 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17642 "src/ocaml/preprocess/parser_raw.ml" +# 17648 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17656,7 +17662,7 @@ module Tables = struct let _v : (Parsetree.module_binding list) = # 211 "" ( [] ) -# 17660 "src/ocaml/preprocess/parser_raw.ml" +# 17666 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17717,9 +17723,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17723 "src/ocaml/preprocess/parser_raw.ml" +# 17729 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17729,24 +17735,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17735 "src/ocaml/preprocess/parser_raw.ml" +# 17741 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17743 "src/ocaml/preprocess/parser_raw.ml" +# 17749 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1623 "src/ocaml/preprocess/parser_raw.mly" +# 1632 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in @@ -17754,13 +17760,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Mb.mk name body ~attrs ~loc ~text ~docs ) -# 17758 "src/ocaml/preprocess/parser_raw.ml" +# 17764 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17764 "src/ocaml/preprocess/parser_raw.ml" +# 17770 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17778,7 +17784,7 @@ module Tables = struct let _v : (Parsetree.module_declaration list) = # 211 "" ( [] ) -# 17782 "src/ocaml/preprocess/parser_raw.ml" +# 17788 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17846,9 +17852,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17852 "src/ocaml/preprocess/parser_raw.ml" +# 17858 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17858,24 +17864,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17864 "src/ocaml/preprocess/parser_raw.ml" +# 17870 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17872 "src/ocaml/preprocess/parser_raw.ml" +# 17878 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1908 "src/ocaml/preprocess/parser_raw.mly" +# 1927 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let docs = symbol_docs _sloc in @@ -17883,13 +17889,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Md.mk name mty ~attrs ~loc ~text ~docs ) -# 17887 "src/ocaml/preprocess/parser_raw.ml" +# 17893 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17893 "src/ocaml/preprocess/parser_raw.ml" +# 17899 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17907,7 +17913,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 17911 "src/ocaml/preprocess/parser_raw.ml" +# 17917 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17939,7 +17945,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 17943 "src/ocaml/preprocess/parser_raw.ml" +# 17949 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17957,7 +17963,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 17961 "src/ocaml/preprocess/parser_raw.ml" +# 17967 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18022,9 +18028,9 @@ module Tables = struct 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 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 18028 "src/ocaml/preprocess/parser_raw.ml" +# 18034 "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 @@ -18037,9 +18043,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18043 "src/ocaml/preprocess/parser_raw.ml" +# 18049 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18048,18 +18054,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18052 "src/ocaml/preprocess/parser_raw.ml" +# 18058 "src/ocaml/preprocess/parser_raw.ml" in -# 1078 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 18057 "src/ocaml/preprocess/parser_raw.ml" +# 18063 "src/ocaml/preprocess/parser_raw.ml" in -# 3161 "src/ocaml/preprocess/parser_raw.mly" +# 3181 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18063 "src/ocaml/preprocess/parser_raw.ml" +# 18069 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -18068,24 +18074,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18074 "src/ocaml/preprocess/parser_raw.ml" +# 18080 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18082 "src/ocaml/preprocess/parser_raw.ml" +# 18088 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3150 "src/ocaml/preprocess/parser_raw.mly" +# 3170 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -18094,13 +18100,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18098 "src/ocaml/preprocess/parser_raw.ml" +# 18104 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18104 "src/ocaml/preprocess/parser_raw.ml" +# 18110 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18118,7 +18124,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 18122 "src/ocaml/preprocess/parser_raw.ml" +# 18128 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18190,9 +18196,9 @@ module Tables = struct 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 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 18196 "src/ocaml/preprocess/parser_raw.ml" +# 18202 "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 @@ -18205,9 +18211,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18211 "src/ocaml/preprocess/parser_raw.ml" +# 18217 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -18216,26 +18222,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18220 "src/ocaml/preprocess/parser_raw.ml" +# 18226 "src/ocaml/preprocess/parser_raw.ml" in -# 1078 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 18225 "src/ocaml/preprocess/parser_raw.ml" +# 18231 "src/ocaml/preprocess/parser_raw.ml" in -# 3161 "src/ocaml/preprocess/parser_raw.mly" +# 3181 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18231 "src/ocaml/preprocess/parser_raw.ml" +# 18237 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined3 in -# 3196 "src/ocaml/preprocess/parser_raw.mly" +# 3216 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 18239 "src/ocaml/preprocess/parser_raw.ml" +# 18245 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -18244,24 +18250,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18250 "src/ocaml/preprocess/parser_raw.ml" +# 18256 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18258 "src/ocaml/preprocess/parser_raw.ml" +# 18264 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3150 "src/ocaml/preprocess/parser_raw.mly" +# 3170 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -18270,13 +18276,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18274 "src/ocaml/preprocess/parser_raw.ml" +# 18280 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18280 "src/ocaml/preprocess/parser_raw.ml" +# 18286 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18294,7 +18300,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 18298 "src/ocaml/preprocess/parser_raw.ml" +# 18304 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18326,7 +18332,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 18330 "src/ocaml/preprocess/parser_raw.ml" +# 18336 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18344,7 +18350,7 @@ module Tables = struct let _v : (Parsetree.signature_item list list) = # 211 "" ( [] ) -# 18348 "src/ocaml/preprocess/parser_raw.ml" +# 18354 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18377,21 +18383,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1004 "src/ocaml/preprocess/parser_raw.mly" +# 1006 "src/ocaml/preprocess/parser_raw.mly" ( text_sig _startpos ) -# 18383 "src/ocaml/preprocess/parser_raw.ml" +# 18389 "src/ocaml/preprocess/parser_raw.ml" in -# 1765 "src/ocaml/preprocess/parser_raw.mly" +# 1780 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18389 "src/ocaml/preprocess/parser_raw.ml" +# 18395 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18395 "src/ocaml/preprocess/parser_raw.ml" +# 18401 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18424,21 +18430,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1002 "src/ocaml/preprocess/parser_raw.mly" +# 1004 "src/ocaml/preprocess/parser_raw.mly" ( text_sig _startpos @ [_1] ) -# 18430 "src/ocaml/preprocess/parser_raw.ml" +# 18436 "src/ocaml/preprocess/parser_raw.ml" in -# 1765 "src/ocaml/preprocess/parser_raw.mly" +# 1780 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18436 "src/ocaml/preprocess/parser_raw.ml" +# 18442 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18442 "src/ocaml/preprocess/parser_raw.ml" +# 18448 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18456,7 +18462,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 18460 "src/ocaml/preprocess/parser_raw.ml" +# 18466 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18489,40 +18495,40 @@ module Tables = struct let _1 = let ys = let items = -# 1064 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 18495 "src/ocaml/preprocess/parser_raw.ml" +# 18501 "src/ocaml/preprocess/parser_raw.ml" in -# 1506 "src/ocaml/preprocess/parser_raw.mly" +# 1511 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 18500 "src/ocaml/preprocess/parser_raw.ml" +# 18506 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _startpos = _startpos__1_ in -# 1000 "src/ocaml/preprocess/parser_raw.mly" +# 1002 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos ) -# 18508 "src/ocaml/preprocess/parser_raw.ml" +# 18514 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 18514 "src/ocaml/preprocess/parser_raw.ml" +# 18520 "src/ocaml/preprocess/parser_raw.ml" in -# 1522 "src/ocaml/preprocess/parser_raw.mly" +# 1527 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18520 "src/ocaml/preprocess/parser_raw.ml" +# 18526 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18526 "src/ocaml/preprocess/parser_raw.ml" +# 18532 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18574,70 +18580,70 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18580 "src/ocaml/preprocess/parser_raw.ml" +# 18586 "src/ocaml/preprocess/parser_raw.ml" in -# 1513 "src/ocaml/preprocess/parser_raw.mly" +# 1518 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 18585 "src/ocaml/preprocess/parser_raw.ml" +# 18591 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 998 "src/ocaml/preprocess/parser_raw.mly" +# 1000 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18593 "src/ocaml/preprocess/parser_raw.ml" +# 18599 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1017 "src/ocaml/preprocess/parser_raw.mly" +# 1019 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 18603 "src/ocaml/preprocess/parser_raw.ml" +# 18609 "src/ocaml/preprocess/parser_raw.ml" in -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1068 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 18609 "src/ocaml/preprocess/parser_raw.ml" +# 18615 "src/ocaml/preprocess/parser_raw.ml" in -# 1506 "src/ocaml/preprocess/parser_raw.mly" +# 1511 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 18615 "src/ocaml/preprocess/parser_raw.ml" +# 18621 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _startpos = _startpos__1_ in -# 1000 "src/ocaml/preprocess/parser_raw.mly" +# 1002 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos ) -# 18623 "src/ocaml/preprocess/parser_raw.ml" +# 18629 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 18629 "src/ocaml/preprocess/parser_raw.ml" +# 18635 "src/ocaml/preprocess/parser_raw.ml" in -# 1522 "src/ocaml/preprocess/parser_raw.mly" +# 1527 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18635 "src/ocaml/preprocess/parser_raw.ml" +# 18641 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18641 "src/ocaml/preprocess/parser_raw.ml" +# 18647 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18670,21 +18676,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 998 "src/ocaml/preprocess/parser_raw.mly" +# 1000 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18676 "src/ocaml/preprocess/parser_raw.ml" +# 18682 "src/ocaml/preprocess/parser_raw.ml" in -# 1522 "src/ocaml/preprocess/parser_raw.mly" +# 1527 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18682 "src/ocaml/preprocess/parser_raw.ml" +# 18688 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18688 "src/ocaml/preprocess/parser_raw.ml" +# 18694 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18702,7 +18708,7 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = # 211 "" ( [] ) -# 18706 "src/ocaml/preprocess/parser_raw.ml" +# 18712 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18734,15 +18740,15 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = let x = let _startpos = _startpos__1_ in -# 1012 "src/ocaml/preprocess/parser_raw.mly" +# 1014 "src/ocaml/preprocess/parser_raw.mly" ( text_csig _startpos @ [_1] ) -# 18740 "src/ocaml/preprocess/parser_raw.ml" +# 18746 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18746 "src/ocaml/preprocess/parser_raw.ml" +# 18752 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18760,7 +18766,7 @@ module Tables = struct let _v : (Parsetree.class_field list list) = # 211 "" ( [] ) -# 18764 "src/ocaml/preprocess/parser_raw.ml" +# 18770 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18792,15 +18798,15 @@ module Tables = struct let _v : (Parsetree.class_field list list) = let x = let _startpos = _startpos__1_ in -# 1010 "src/ocaml/preprocess/parser_raw.mly" +# 1012 "src/ocaml/preprocess/parser_raw.mly" ( text_cstr _startpos @ [_1] ) -# 18798 "src/ocaml/preprocess/parser_raw.ml" +# 18804 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18804 "src/ocaml/preprocess/parser_raw.ml" +# 18810 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18818,7 +18824,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 18822 "src/ocaml/preprocess/parser_raw.ml" +# 18828 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18850,15 +18856,15 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = let x = let _startpos = _startpos__1_ in -# 998 "src/ocaml/preprocess/parser_raw.mly" +# 1000 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18856 "src/ocaml/preprocess/parser_raw.ml" +# 18862 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18862 "src/ocaml/preprocess/parser_raw.ml" +# 18868 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18876,7 +18882,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = # 211 "" ( [] ) -# 18880 "src/ocaml/preprocess/parser_raw.ml" +# 18886 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18909,32 +18915,32 @@ module Tables = struct let _1 = let x = let _1 = -# 1064 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 18915 "src/ocaml/preprocess/parser_raw.ml" +# 18921 "src/ocaml/preprocess/parser_raw.ml" in -# 1296 "src/ocaml/preprocess/parser_raw.mly" +# 1298 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18920 "src/ocaml/preprocess/parser_raw.ml" +# 18926 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 18926 "src/ocaml/preprocess/parser_raw.ml" +# 18932 "src/ocaml/preprocess/parser_raw.ml" in -# 1308 "src/ocaml/preprocess/parser_raw.mly" +# 1310 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18932 "src/ocaml/preprocess/parser_raw.ml" +# 18938 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18938 "src/ocaml/preprocess/parser_raw.ml" +# 18944 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18986,58 +18992,58 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18992 "src/ocaml/preprocess/parser_raw.ml" +# 18998 "src/ocaml/preprocess/parser_raw.ml" in -# 1513 "src/ocaml/preprocess/parser_raw.mly" +# 1518 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 18997 "src/ocaml/preprocess/parser_raw.ml" +# 19003 "src/ocaml/preprocess/parser_raw.ml" in -# 1008 "src/ocaml/preprocess/parser_raw.mly" +# 1010 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 19003 "src/ocaml/preprocess/parser_raw.ml" +# 19009 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1006 "src/ocaml/preprocess/parser_raw.mly" +# 1008 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19011 "src/ocaml/preprocess/parser_raw.ml" +# 19017 "src/ocaml/preprocess/parser_raw.ml" in -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1068 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 19017 "src/ocaml/preprocess/parser_raw.ml" +# 19023 "src/ocaml/preprocess/parser_raw.ml" in -# 1296 "src/ocaml/preprocess/parser_raw.mly" +# 1298 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19023 "src/ocaml/preprocess/parser_raw.ml" +# 19029 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 19029 "src/ocaml/preprocess/parser_raw.ml" +# 19035 "src/ocaml/preprocess/parser_raw.ml" in -# 1308 "src/ocaml/preprocess/parser_raw.mly" +# 1310 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19035 "src/ocaml/preprocess/parser_raw.ml" +# 19041 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19041 "src/ocaml/preprocess/parser_raw.ml" +# 19047 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19069,27 +19075,27 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = let x = let _1 = let _1 = -# 1008 "src/ocaml/preprocess/parser_raw.mly" +# 1010 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 19075 "src/ocaml/preprocess/parser_raw.ml" +# 19081 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1006 "src/ocaml/preprocess/parser_raw.mly" +# 1008 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19081 "src/ocaml/preprocess/parser_raw.ml" +# 19087 "src/ocaml/preprocess/parser_raw.ml" in -# 1308 "src/ocaml/preprocess/parser_raw.mly" +# 1310 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19087 "src/ocaml/preprocess/parser_raw.ml" +# 19093 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19093 "src/ocaml/preprocess/parser_raw.ml" +# 19099 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19124,29 +19130,29 @@ module Tables = struct let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1017 "src/ocaml/preprocess/parser_raw.mly" +# 1019 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 19131 "src/ocaml/preprocess/parser_raw.ml" +# 19137 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1006 "src/ocaml/preprocess/parser_raw.mly" +# 1008 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19138 "src/ocaml/preprocess/parser_raw.ml" +# 19144 "src/ocaml/preprocess/parser_raw.ml" in -# 1308 "src/ocaml/preprocess/parser_raw.mly" +# 1310 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19144 "src/ocaml/preprocess/parser_raw.ml" +# 19150 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19150 "src/ocaml/preprocess/parser_raw.ml" +# 19156 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19185,7 +19191,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 124 "" ( None ) -# 19189 "src/ocaml/preprocess/parser_raw.ml" +# 19195 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -19193,9 +19199,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19199 "src/ocaml/preprocess/parser_raw.ml" +# 19205 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19203,7 +19209,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3036 "src/ocaml/preprocess/parser_raw.mly" +# 3056 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19217,13 +19223,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19221 "src/ocaml/preprocess/parser_raw.ml" +# 19227 "src/ocaml/preprocess/parser_raw.ml" in -# 1233 "src/ocaml/preprocess/parser_raw.mly" +# 1235 "src/ocaml/preprocess/parser_raw.mly" ( [x], None ) -# 19227 "src/ocaml/preprocess/parser_raw.ml" +# 19233 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19269,7 +19275,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 126 "" ( Some x ) -# 19273 "src/ocaml/preprocess/parser_raw.ml" +# 19279 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -19277,9 +19283,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19283 "src/ocaml/preprocess/parser_raw.ml" +# 19289 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19287,7 +19293,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3036 "src/ocaml/preprocess/parser_raw.mly" +# 3056 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19301,13 +19307,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19305 "src/ocaml/preprocess/parser_raw.ml" +# 19311 "src/ocaml/preprocess/parser_raw.ml" in -# 1233 "src/ocaml/preprocess/parser_raw.mly" +# 1235 "src/ocaml/preprocess/parser_raw.mly" ( [x], None ) -# 19311 "src/ocaml/preprocess/parser_raw.ml" +# 19317 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19370,9 +19376,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19376 "src/ocaml/preprocess/parser_raw.ml" +# 19382 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19380,7 +19386,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3036 "src/ocaml/preprocess/parser_raw.mly" +# 3056 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19394,13 +19400,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19398 "src/ocaml/preprocess/parser_raw.ml" +# 19404 "src/ocaml/preprocess/parser_raw.ml" in -# 1235 "src/ocaml/preprocess/parser_raw.mly" +# 1237 "src/ocaml/preprocess/parser_raw.mly" ( [x], Some y ) -# 19404 "src/ocaml/preprocess/parser_raw.ml" +# 19410 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19456,9 +19462,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19462 "src/ocaml/preprocess/parser_raw.ml" +# 19468 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19466,7 +19472,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3036 "src/ocaml/preprocess/parser_raw.mly" +# 3056 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19480,14 +19486,14 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19484 "src/ocaml/preprocess/parser_raw.ml" +# 19490 "src/ocaml/preprocess/parser_raw.ml" in -# 1239 "src/ocaml/preprocess/parser_raw.mly" +# 1241 "src/ocaml/preprocess/parser_raw.mly" ( let xs, y = tail in x :: xs, y ) -# 19491 "src/ocaml/preprocess/parser_raw.ml" +# 19497 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19536,7 +19542,8 @@ module Tables = struct }; } = _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 _4 : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option * 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 @@ -19547,9 +19554,9 @@ module Tables = struct let _v : (Ast_helper.let_bindings) = let _5 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19553 "src/ocaml/preprocess/parser_raw.ml" +# 19560 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -19557,23 +19564,23 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19563 "src/ocaml/preprocess/parser_raw.ml" +# 19570 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 19569 "src/ocaml/preprocess/parser_raw.ml" +# 19576 "src/ocaml/preprocess/parser_raw.ml" in let _loc__4_ = (_startpos__4_, _endpos__4_) in -# 4082 "src/ocaml/preprocess/parser_raw.mly" +# 4102 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, attr) = _2 in mklbs ext _3 (mklb ~loc:_loc__4_ true _4 (attr@_5)) ) -# 19577 "src/ocaml/preprocess/parser_raw.ml" +# 19584 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19596,9 +19603,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Ast_helper.let_bindings) = -# 4086 "src/ocaml/preprocess/parser_raw.mly" +# 4106 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19602 "src/ocaml/preprocess/parser_raw.ml" +# 19609 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19628,9 +19635,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 4087 "src/ocaml/preprocess/parser_raw.mly" +# 4107 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 19634 "src/ocaml/preprocess/parser_raw.ml" +# 19641 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19667,9 +19674,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.case) = -# 2786 "src/ocaml/preprocess/parser_raw.mly" +# 2806 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 (merloc _endpos__2_ _3) ) -# 19673 "src/ocaml/preprocess/parser_raw.ml" +# 19680 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19720,9 +19727,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.case) = -# 2788 "src/ocaml/preprocess/parser_raw.mly" +# 2808 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 ~guard:(merloc _endpos__2_ _3) (merloc _endpos__4_ _5) ) -# 19726 "src/ocaml/preprocess/parser_raw.ml" +# 19733 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19760,10 +19767,10 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.case) = let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2790 "src/ocaml/preprocess/parser_raw.mly" +# 2810 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 (merloc _endpos__2_ (Exp.unreachable ~loc:(make_loc _loc__3_) ())) ) -# 19767 "src/ocaml/preprocess/parser_raw.ml" +# 19774 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19824,9 +19831,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 19830 "src/ocaml/preprocess/parser_raw.ml" +# 19837 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -19835,49 +19842,49 @@ module Tables = struct let _6 = let _1 = _1_inlined3 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19841 "src/ocaml/preprocess/parser_raw.ml" +# 19848 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19850 "src/ocaml/preprocess/parser_raw.ml" +# 19857 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3464 "src/ocaml/preprocess/parser_raw.mly" +# 3484 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19859 "src/ocaml/preprocess/parser_raw.ml" +# 19866 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19866 "src/ocaml/preprocess/parser_raw.ml" +# 19873 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19874 "src/ocaml/preprocess/parser_raw.ml" +# 19881 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3674 "src/ocaml/preprocess/parser_raw.mly" +# 3694 "src/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__4_ with | Some _ as info_before_semi -> info_before_semi @@ -19885,13 +19892,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 19889 "src/ocaml/preprocess/parser_raw.ml" +# 19896 "src/ocaml/preprocess/parser_raw.ml" in -# 3655 "src/ocaml/preprocess/parser_raw.mly" +# 3675 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = tail in (head :: f, c) ) -# 19895 "src/ocaml/preprocess/parser_raw.ml" +# 19902 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19932,15 +19939,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3705 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 19938 "src/ocaml/preprocess/parser_raw.ml" +# 19945 "src/ocaml/preprocess/parser_raw.ml" in -# 3655 "src/ocaml/preprocess/parser_raw.mly" +# 3675 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = tail in (head :: f, c) ) -# 19944 "src/ocaml/preprocess/parser_raw.ml" +# 19951 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19994,9 +20001,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20000 "src/ocaml/preprocess/parser_raw.ml" +# 20007 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20005,49 +20012,49 @@ module Tables = struct let _6 = let _1 = _1_inlined3 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20011 "src/ocaml/preprocess/parser_raw.ml" +# 20018 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20020 "src/ocaml/preprocess/parser_raw.ml" +# 20027 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3464 "src/ocaml/preprocess/parser_raw.mly" +# 3484 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20029 "src/ocaml/preprocess/parser_raw.ml" +# 20036 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20036 "src/ocaml/preprocess/parser_raw.ml" +# 20043 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20044 "src/ocaml/preprocess/parser_raw.ml" +# 20051 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3674 "src/ocaml/preprocess/parser_raw.mly" +# 3694 "src/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__4_ with | Some _ as info_before_semi -> info_before_semi @@ -20055,13 +20062,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20059 "src/ocaml/preprocess/parser_raw.ml" +# 20066 "src/ocaml/preprocess/parser_raw.ml" in -# 3658 "src/ocaml/preprocess/parser_raw.mly" +# 3678 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20065 "src/ocaml/preprocess/parser_raw.ml" +# 20072 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20095,15 +20102,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3705 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20101 "src/ocaml/preprocess/parser_raw.ml" +# 20108 "src/ocaml/preprocess/parser_raw.ml" in -# 3658 "src/ocaml/preprocess/parser_raw.mly" +# 3678 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20107 "src/ocaml/preprocess/parser_raw.ml" +# 20114 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20143,9 +20150,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20149 "src/ocaml/preprocess/parser_raw.ml" +# 20156 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20154,50 +20161,50 @@ module Tables = struct let _4 = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20160 "src/ocaml/preprocess/parser_raw.ml" +# 20167 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3464 "src/ocaml/preprocess/parser_raw.mly" +# 3484 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20169 "src/ocaml/preprocess/parser_raw.ml" +# 20176 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20176 "src/ocaml/preprocess/parser_raw.ml" +# 20183 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20184 "src/ocaml/preprocess/parser_raw.ml" +# 20191 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3667 "src/ocaml/preprocess/parser_raw.mly" +# 3687 "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 ) -# 20195 "src/ocaml/preprocess/parser_raw.ml" +# 20202 "src/ocaml/preprocess/parser_raw.ml" in -# 3661 "src/ocaml/preprocess/parser_raw.mly" +# 3681 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20201 "src/ocaml/preprocess/parser_raw.ml" +# 20208 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20224,15 +20231,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3685 "src/ocaml/preprocess/parser_raw.mly" +# 3705 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20230 "src/ocaml/preprocess/parser_raw.ml" +# 20237 "src/ocaml/preprocess/parser_raw.ml" in -# 3661 "src/ocaml/preprocess/parser_raw.mly" +# 3681 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20236 "src/ocaml/preprocess/parser_raw.ml" +# 20243 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20255,9 +20262,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.object_field list * Asttypes.closed_flag) = -# 3663 "src/ocaml/preprocess/parser_raw.mly" +# 3683 "src/ocaml/preprocess/parser_raw.mly" ( [], Open ) -# 20261 "src/ocaml/preprocess/parser_raw.ml" +# 20268 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20302,9 +20309,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20308 "src/ocaml/preprocess/parser_raw.ml" +# 20315 "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 @@ -20315,41 +20322,41 @@ module Tables = struct Parsetree.attributes) = let ty = let _1 = _1_inlined2 in -# 3460 "src/ocaml/preprocess/parser_raw.mly" +# 3480 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20321 "src/ocaml/preprocess/parser_raw.ml" +# 20328 "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 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20329 "src/ocaml/preprocess/parser_raw.ml" +# 20336 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20337 "src/ocaml/preprocess/parser_raw.ml" +# 20344 "src/ocaml/preprocess/parser_raw.ml" in let attrs = -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20343 "src/ocaml/preprocess/parser_raw.ml" +# 20350 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3954 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20348 "src/ocaml/preprocess/parser_raw.ml" +# 20355 "src/ocaml/preprocess/parser_raw.ml" in -# 2111 "src/ocaml/preprocess/parser_raw.mly" +# 2130 "src/ocaml/preprocess/parser_raw.mly" ( (label, private_, Cfk_virtual ty), attrs ) -# 20353 "src/ocaml/preprocess/parser_raw.ml" +# 20360 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20387,9 +20394,9 @@ module Tables = struct } = _menhir_stack in let _5 : (Parsetree.expression) = Obj.magic _5 in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20393 "src/ocaml/preprocess/parser_raw.ml" +# 20400 "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 @@ -20400,36 +20407,36 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20406 "src/ocaml/preprocess/parser_raw.ml" +# 20413 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20414 "src/ocaml/preprocess/parser_raw.ml" +# 20421 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20420 "src/ocaml/preprocess/parser_raw.ml" +# 20427 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20425 "src/ocaml/preprocess/parser_raw.ml" +# 20432 "src/ocaml/preprocess/parser_raw.ml" in -# 2113 "src/ocaml/preprocess/parser_raw.mly" +# 2132 "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 ) -# 20433 "src/ocaml/preprocess/parser_raw.ml" +# 20440 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20473,9 +20480,9 @@ module Tables = struct } = _menhir_stack in let _5 : (Parsetree.expression) = Obj.magic _5 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20479 "src/ocaml/preprocess/parser_raw.ml" +# 20486 "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 @@ -20487,39 +20494,39 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20493 "src/ocaml/preprocess/parser_raw.ml" +# 20500 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20501 "src/ocaml/preprocess/parser_raw.ml" +# 20508 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20509 "src/ocaml/preprocess/parser_raw.ml" +# 20516 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 20515 "src/ocaml/preprocess/parser_raw.ml" +# 20522 "src/ocaml/preprocess/parser_raw.ml" in -# 2113 "src/ocaml/preprocess/parser_raw.mly" +# 2132 "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 ) -# 20523 "src/ocaml/preprocess/parser_raw.ml" +# 20530 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20578,9 +20585,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20584 "src/ocaml/preprocess/parser_raw.ml" +# 20591 "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 @@ -20591,45 +20598,45 @@ module Tables = struct Parsetree.attributes) = let _6 = let _1 = _1_inlined2 in -# 3460 "src/ocaml/preprocess/parser_raw.mly" +# 3480 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20597 "src/ocaml/preprocess/parser_raw.ml" +# 20604 "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 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20606 "src/ocaml/preprocess/parser_raw.ml" +# 20613 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20614 "src/ocaml/preprocess/parser_raw.ml" +# 20621 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20620 "src/ocaml/preprocess/parser_raw.ml" +# 20627 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20625 "src/ocaml/preprocess/parser_raw.ml" +# 20632 "src/ocaml/preprocess/parser_raw.ml" in -# 2119 "src/ocaml/preprocess/parser_raw.mly" +# 2138 "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 ) -# 20633 "src/ocaml/preprocess/parser_raw.ml" +# 20640 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20694,9 +20701,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20700 "src/ocaml/preprocess/parser_raw.ml" +# 20707 "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 @@ -20708,48 +20715,48 @@ module Tables = struct Parsetree.attributes) = let _6 = let _1 = _1_inlined3 in -# 3460 "src/ocaml/preprocess/parser_raw.mly" +# 3480 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20714 "src/ocaml/preprocess/parser_raw.ml" +# 20721 "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 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20723 "src/ocaml/preprocess/parser_raw.ml" +# 20730 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20731 "src/ocaml/preprocess/parser_raw.ml" +# 20738 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20739 "src/ocaml/preprocess/parser_raw.ml" +# 20746 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 20745 "src/ocaml/preprocess/parser_raw.ml" +# 20752 "src/ocaml/preprocess/parser_raw.ml" in -# 2119 "src/ocaml/preprocess/parser_raw.mly" +# 2138 "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 ) -# 20753 "src/ocaml/preprocess/parser_raw.ml" +# 20760 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20829,9 +20836,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20835 "src/ocaml/preprocess/parser_raw.ml" +# 20842 "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 @@ -20840,38 +20847,38 @@ module Tables = struct let _endpos = _endpos__11_ in let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) * Parsetree.attributes) = let _7 = -# 2666 "src/ocaml/preprocess/parser_raw.mly" +# 2689 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 20846 "src/ocaml/preprocess/parser_raw.ml" +# 20853 "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 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20854 "src/ocaml/preprocess/parser_raw.ml" +# 20861 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20862 "src/ocaml/preprocess/parser_raw.ml" +# 20869 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20869 "src/ocaml/preprocess/parser_raw.ml" +# 20876 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20875 "src/ocaml/preprocess/parser_raw.ml" +# 20882 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__11_ in @@ -20887,7 +20894,7 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2125 "src/ocaml/preprocess/parser_raw.mly" +# 2144 "src/ocaml/preprocess/parser_raw.mly" ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in let poly_exp = let exp, poly = @@ -20898,7 +20905,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 20902 "src/ocaml/preprocess/parser_raw.ml" +# 20909 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20984,9 +20991,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20990 "src/ocaml/preprocess/parser_raw.ml" +# 20997 "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 @@ -20996,41 +21003,41 @@ module Tables = struct let _endpos = _endpos__11_ in let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) * Parsetree.attributes) = let _7 = -# 2666 "src/ocaml/preprocess/parser_raw.mly" +# 2689 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 21002 "src/ocaml/preprocess/parser_raw.ml" +# 21009 "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 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21010 "src/ocaml/preprocess/parser_raw.ml" +# 21017 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21018 "src/ocaml/preprocess/parser_raw.ml" +# 21025 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21027 "src/ocaml/preprocess/parser_raw.ml" +# 21034 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 21034 "src/ocaml/preprocess/parser_raw.ml" +# 21041 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__11_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -21045,7 +21052,7 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2125 "src/ocaml/preprocess/parser_raw.mly" +# 2144 "src/ocaml/preprocess/parser_raw.mly" ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in let poly_exp = let exp, poly = @@ -21056,7 +21063,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21060 "src/ocaml/preprocess/parser_raw.ml" +# 21067 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21075,17 +21082,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21081 "src/ocaml/preprocess/parser_raw.ml" +# 21088 "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) = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3808 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21089 "src/ocaml/preprocess/parser_raw.ml" +# 21096 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21116,9 +21123,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21122 "src/ocaml/preprocess/parser_raw.ml" +# 21129 "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 @@ -21126,9 +21133,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3789 "src/ocaml/preprocess/parser_raw.mly" +# 3809 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21132 "src/ocaml/preprocess/parser_raw.ml" +# 21139 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21147,17 +21154,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21153 "src/ocaml/preprocess/parser_raw.ml" +# 21160 "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) = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3808 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21161 "src/ocaml/preprocess/parser_raw.ml" +# 21168 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21188,9 +21195,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21194 "src/ocaml/preprocess/parser_raw.ml" +# 21201 "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 @@ -21198,9 +21205,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3789 "src/ocaml/preprocess/parser_raw.mly" +# 3809 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21204 "src/ocaml/preprocess/parser_raw.ml" +# 21211 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21223,14 +21230,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = let _1 = -# 3828 "src/ocaml/preprocess/parser_raw.mly" +# 3848 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21229 "src/ocaml/preprocess/parser_raw.ml" +# 21236 "src/ocaml/preprocess/parser_raw.ml" in -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3808 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21234 "src/ocaml/preprocess/parser_raw.ml" +# 21241 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21268,20 +21275,20 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Longident.t) = let _1 = let _1 = -# 3768 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 21274 "src/ocaml/preprocess/parser_raw.ml" +# 21281 "src/ocaml/preprocess/parser_raw.ml" in -# 3828 "src/ocaml/preprocess/parser_raw.mly" +# 3848 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21279 "src/ocaml/preprocess/parser_raw.ml" +# 21286 "src/ocaml/preprocess/parser_raw.ml" in -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3808 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21285 "src/ocaml/preprocess/parser_raw.ml" +# 21292 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21304,14 +21311,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = let _1 = -# 3828 "src/ocaml/preprocess/parser_raw.mly" +# 3848 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21310 "src/ocaml/preprocess/parser_raw.ml" +# 21317 "src/ocaml/preprocess/parser_raw.ml" in -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3808 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21315 "src/ocaml/preprocess/parser_raw.ml" +# 21322 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21350,15 +21357,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let _1 = _1_inlined1 in -# 3828 "src/ocaml/preprocess/parser_raw.mly" +# 3848 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21356 "src/ocaml/preprocess/parser_raw.ml" +# 21363 "src/ocaml/preprocess/parser_raw.ml" in -# 3789 "src/ocaml/preprocess/parser_raw.mly" +# 3809 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21362 "src/ocaml/preprocess/parser_raw.ml" +# 21369 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21411,20 +21418,20 @@ module Tables = struct let _v : (Longident.t) = let _3 = let (_2, _1) = (_2_inlined1, _1_inlined1) in let _1 = -# 3768 "src/ocaml/preprocess/parser_raw.mly" +# 3788 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 21417 "src/ocaml/preprocess/parser_raw.ml" +# 21424 "src/ocaml/preprocess/parser_raw.ml" in -# 3828 "src/ocaml/preprocess/parser_raw.mly" +# 3848 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21422 "src/ocaml/preprocess/parser_raw.ml" +# 21429 "src/ocaml/preprocess/parser_raw.ml" in -# 3789 "src/ocaml/preprocess/parser_raw.mly" +# 3809 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21428 "src/ocaml/preprocess/parser_raw.ml" +# 21435 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21463,15 +21470,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let _1 = _1_inlined1 in -# 3828 "src/ocaml/preprocess/parser_raw.mly" +# 3848 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21469 "src/ocaml/preprocess/parser_raw.ml" +# 21476 "src/ocaml/preprocess/parser_raw.ml" in -# 3789 "src/ocaml/preprocess/parser_raw.mly" +# 3809 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21475 "src/ocaml/preprocess/parser_raw.ml" +# 21482 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21494,9 +21501,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3808 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21500 "src/ocaml/preprocess/parser_raw.ml" +# 21507 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21533,9 +21540,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3789 "src/ocaml/preprocess/parser_raw.mly" +# 3809 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21539 "src/ocaml/preprocess/parser_raw.ml" +# 21546 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21554,17 +21561,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21560 "src/ocaml/preprocess/parser_raw.ml" +# 21567 "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) = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3808 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21568 "src/ocaml/preprocess/parser_raw.ml" +# 21575 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21595,9 +21602,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21601 "src/ocaml/preprocess/parser_raw.ml" +# 21608 "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 @@ -21605,9 +21612,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3789 "src/ocaml/preprocess/parser_raw.mly" +# 3809 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21611 "src/ocaml/preprocess/parser_raw.ml" +# 21618 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21626,17 +21633,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21632 "src/ocaml/preprocess/parser_raw.ml" +# 21639 "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) = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3808 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21640 "src/ocaml/preprocess/parser_raw.ml" +# 21647 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21667,9 +21674,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21673 "src/ocaml/preprocess/parser_raw.ml" +# 21680 "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 @@ -21677,9 +21684,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3789 "src/ocaml/preprocess/parser_raw.mly" +# 3809 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21683 "src/ocaml/preprocess/parser_raw.ml" +# 21690 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21702,9 +21709,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3808 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21708 "src/ocaml/preprocess/parser_raw.ml" +# 21715 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21741,9 +21748,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3789 "src/ocaml/preprocess/parser_raw.mly" +# 3809 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21747 "src/ocaml/preprocess/parser_raw.ml" +# 21754 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21766,9 +21773,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3804 "src/ocaml/preprocess/parser_raw.mly" +# 3824 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21772 "src/ocaml/preprocess/parser_raw.ml" +# 21779 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21815,9 +21822,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3806 "src/ocaml/preprocess/parser_raw.mly" +# 3826 "src/ocaml/preprocess/parser_raw.mly" ( lapply ~loc:_sloc _1 _3 ) -# 21821 "src/ocaml/preprocess/parser_raw.ml" +# 21828 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21840,9 +21847,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3801 "src/ocaml/preprocess/parser_raw.mly" +# 3821 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21846 "src/ocaml/preprocess/parser_raw.ml" +# 21853 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21872,9 +21879,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = -# 1582 "src/ocaml/preprocess/parser_raw.mly" +# 1587 "src/ocaml/preprocess/parser_raw.mly" ( me ) -# 21878 "src/ocaml/preprocess/parser_raw.ml" +# 21885 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21919,24 +21926,24 @@ module Tables = struct let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1585 "src/ocaml/preprocess/parser_raw.mly" +# 1594 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_constraint(me, mty) ) -# 21925 "src/ocaml/preprocess/parser_raw.ml" +# 21932 "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 -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 21934 "src/ocaml/preprocess/parser_raw.ml" +# 21941 "src/ocaml/preprocess/parser_raw.ml" in -# 1589 "src/ocaml/preprocess/parser_raw.mly" +# 1598 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21940 "src/ocaml/preprocess/parser_raw.ml" +# 21947 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21967,25 +21974,25 @@ module Tables = struct let _endpos = _endpos_body_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1587 "src/ocaml/preprocess/parser_raw.mly" +# 1596 "src/ocaml/preprocess/parser_raw.mly" ( let (_, arg) = arg_and_pos in Pmod_functor(arg, body) ) -# 21974 "src/ocaml/preprocess/parser_raw.ml" +# 21981 "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 -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 21983 "src/ocaml/preprocess/parser_raw.ml" +# 21990 "src/ocaml/preprocess/parser_raw.ml" in -# 1589 "src/ocaml/preprocess/parser_raw.mly" +# 1598 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21989 "src/ocaml/preprocess/parser_raw.ml" +# 21996 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22015,9 +22022,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_mty_ in let _v : (Parsetree.module_type) = -# 1832 "src/ocaml/preprocess/parser_raw.mly" +# 1847 "src/ocaml/preprocess/parser_raw.mly" ( mty ) -# 22021 "src/ocaml/preprocess/parser_raw.ml" +# 22028 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22048,25 +22055,25 @@ module Tables = struct let _endpos = _endpos_body_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1835 "src/ocaml/preprocess/parser_raw.mly" +# 1854 "src/ocaml/preprocess/parser_raw.mly" ( let (_, arg) = arg_and_pos in Pmty_functor(arg, body) ) -# 22055 "src/ocaml/preprocess/parser_raw.ml" +# 22062 "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 -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 22064 "src/ocaml/preprocess/parser_raw.ml" +# 22071 "src/ocaml/preprocess/parser_raw.ml" in -# 1838 "src/ocaml/preprocess/parser_raw.mly" +# 1857 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22070 "src/ocaml/preprocess/parser_raw.ml" +# 22077 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22112,18 +22119,18 @@ module Tables = struct let _v : (Parsetree.module_expr) = let attrs = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22118 "src/ocaml/preprocess/parser_raw.ml" +# 22125 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1409 "src/ocaml/preprocess/parser_raw.mly" +# 1411 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_structure s) ) -# 22127 "src/ocaml/preprocess/parser_raw.ml" +# 22134 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22176,22 +22183,22 @@ module Tables = struct let _v : (Parsetree.module_expr) = let attrs = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22182 "src/ocaml/preprocess/parser_raw.ml" +# 22189 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_me_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1415 "src/ocaml/preprocess/parser_raw.mly" +# 1421 "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 ) ) -# 22195 "src/ocaml/preprocess/parser_raw.ml" +# 22202 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22214,9 +22221,9 @@ module Tables = struct let _startpos = _startpos_me_ in let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = -# 1421 "src/ocaml/preprocess/parser_raw.mly" +# 1427 "src/ocaml/preprocess/parser_raw.mly" ( me ) -# 22220 "src/ocaml/preprocess/parser_raw.ml" +# 22227 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22246,9 +22253,9 @@ module Tables = struct let _startpos = _startpos_me_ in let _endpos = _endpos_attr_ in let _v : (Parsetree.module_expr) = -# 1423 "src/ocaml/preprocess/parser_raw.mly" +# 1429 "src/ocaml/preprocess/parser_raw.mly" ( Mod.attr me attr ) -# 22252 "src/ocaml/preprocess/parser_raw.ml" +# 22259 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22277,30 +22284,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22283 "src/ocaml/preprocess/parser_raw.ml" +# 22290 "src/ocaml/preprocess/parser_raw.ml" in -# 1427 "src/ocaml/preprocess/parser_raw.mly" +# 1433 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_ident x ) -# 22289 "src/ocaml/preprocess/parser_raw.ml" +# 22296 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22298 "src/ocaml/preprocess/parser_raw.ml" +# 22305 "src/ocaml/preprocess/parser_raw.ml" in -# 1443 "src/ocaml/preprocess/parser_raw.mly" +# 1448 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22304 "src/ocaml/preprocess/parser_raw.ml" +# 22311 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22331,24 +22338,24 @@ module Tables = struct let _endpos = _endpos_me2_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1430 "src/ocaml/preprocess/parser_raw.mly" +# 1436 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_apply(me1, me2) ) -# 22337 "src/ocaml/preprocess/parser_raw.ml" +# 22344 "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 -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22346 "src/ocaml/preprocess/parser_raw.ml" +# 22353 "src/ocaml/preprocess/parser_raw.ml" in -# 1443 "src/ocaml/preprocess/parser_raw.mly" +# 1448 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22352 "src/ocaml/preprocess/parser_raw.ml" +# 22359 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22371,45 +22378,39 @@ module Tables = struct 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.semv = me; + MenhirLib.EngineTypes.startp = _startpos_me_; + MenhirLib.EngineTypes.endp = _endpos_me_; 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 me : (Parsetree.module_expr) = Obj.magic me in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in - let _startpos = _startpos_me1_ in + let _startpos = _startpos_me_ 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 - -# 1433 "src/ocaml/preprocess/parser_raw.mly" - ( (* TODO review mkmod location *) - Pmod_apply(me1, mkmod ~loc:_sloc (Pmod_structure [])) ) -# 22397 "src/ocaml/preprocess/parser_raw.ml" - - in - let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_me1_) in + let _1 = +# 1439 "src/ocaml/preprocess/parser_raw.mly" + ( Pmod_apply_unit me ) +# 22399 "src/ocaml/preprocess/parser_raw.ml" + in + let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_me_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22407 "src/ocaml/preprocess/parser_raw.ml" +# 22408 "src/ocaml/preprocess/parser_raw.ml" in -# 1443 "src/ocaml/preprocess/parser_raw.mly" +# 1448 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22413 "src/ocaml/preprocess/parser_raw.ml" +# 22414 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22433,24 +22434,24 @@ module Tables = struct let _endpos = _endpos_ex_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1437 "src/ocaml/preprocess/parser_raw.mly" +# 1442 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_extension ex ) -# 22439 "src/ocaml/preprocess/parser_raw.ml" +# 22440 "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 -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22448 "src/ocaml/preprocess/parser_raw.ml" +# 22449 "src/ocaml/preprocess/parser_raw.ml" in -# 1443 "src/ocaml/preprocess/parser_raw.mly" +# 1448 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22454 "src/ocaml/preprocess/parser_raw.ml" +# 22455 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22478,25 +22479,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 1440 "src/ocaml/preprocess/parser_raw.mly" +# 1445 "src/ocaml/preprocess/parser_raw.mly" ( let id = mkrhs Ast_helper.hole_txt _loc in Pmod_extension (id, PStr []) ) -# 22485 "src/ocaml/preprocess/parser_raw.ml" +# 22486 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22494 "src/ocaml/preprocess/parser_raw.ml" +# 22495 "src/ocaml/preprocess/parser_raw.ml" in -# 1443 "src/ocaml/preprocess/parser_raw.mly" +# 1448 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22500 "src/ocaml/preprocess/parser_raw.ml" +# 22501 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22515,17 +22516,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let x : ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) -# 22521 "src/ocaml/preprocess/parser_raw.ml" +# 22522 "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) = -# 1392 "src/ocaml/preprocess/parser_raw.mly" +# 1394 "src/ocaml/preprocess/parser_raw.mly" ( Some x ) -# 22529 "src/ocaml/preprocess/parser_raw.ml" +# 22530 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22548,9 +22549,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string option) = -# 1395 "src/ocaml/preprocess/parser_raw.mly" +# 1397 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 22554 "src/ocaml/preprocess/parser_raw.ml" +# 22555 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22608,9 +22609,9 @@ module Tables = struct let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) -# 22614 "src/ocaml/preprocess/parser_raw.ml" +# 22615 "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 @@ -22621,9 +22622,9 @@ module Tables = struct let _v : (Parsetree.module_substitution * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22627 "src/ocaml/preprocess/parser_raw.ml" +# 22628 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -22633,9 +22634,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22639 "src/ocaml/preprocess/parser_raw.ml" +# 22640 "src/ocaml/preprocess/parser_raw.ml" in let uid = @@ -22644,31 +22645,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22650 "src/ocaml/preprocess/parser_raw.ml" +# 22651 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22658 "src/ocaml/preprocess/parser_raw.ml" +# 22659 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1868 "src/ocaml/preprocess/parser_raw.mly" +# 1887 "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 ) -# 22672 "src/ocaml/preprocess/parser_raw.ml" +# 22673 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22714,18 +22715,18 @@ module Tables = struct let _v : (Parsetree.module_type) = let attrs = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22720 "src/ocaml/preprocess/parser_raw.ml" +# 22721 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1714 "src/ocaml/preprocess/parser_raw.mly" +# 1723 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc ~attrs (Pmty_signature s) ) -# 22729 "src/ocaml/preprocess/parser_raw.ml" +# 22730 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22778,22 +22779,22 @@ module Tables = struct let _v : (Parsetree.module_type) = let attrs = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22784 "src/ocaml/preprocess/parser_raw.ml" +# 22785 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_mty_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1722 "src/ocaml/preprocess/parser_raw.mly" +# 1735 "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 ) ) -# 22797 "src/ocaml/preprocess/parser_raw.ml" +# 22798 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22846,18 +22847,18 @@ module Tables = struct let _v : (Parsetree.module_type) = let _4 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22852 "src/ocaml/preprocess/parser_raw.ml" +# 22853 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1728 "src/ocaml/preprocess/parser_raw.mly" +# 1741 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc ~attrs:_4 (Pmty_typeof _5) ) -# 22861 "src/ocaml/preprocess/parser_raw.ml" +# 22862 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22894,9 +22895,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.module_type) = -# 1730 "src/ocaml/preprocess/parser_raw.mly" +# 1743 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 22900 "src/ocaml/preprocess/parser_raw.ml" +# 22901 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22926,9 +22927,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_type) = -# 1736 "src/ocaml/preprocess/parser_raw.mly" +# 1749 "src/ocaml/preprocess/parser_raw.mly" ( Mty.attr _1 _2 ) -# 22932 "src/ocaml/preprocess/parser_raw.ml" +# 22933 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22957,30 +22958,92 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22963 "src/ocaml/preprocess/parser_raw.ml" +# 22964 "src/ocaml/preprocess/parser_raw.ml" in -# 1739 "src/ocaml/preprocess/parser_raw.mly" +# 1752 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_ident _1 ) -# 22969 "src/ocaml/preprocess/parser_raw.ml" +# 22970 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 22978 "src/ocaml/preprocess/parser_raw.ml" +# 22979 "src/ocaml/preprocess/parser_raw.ml" in -# 1750 "src/ocaml/preprocess/parser_raw.mly" +# 1765 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22984 "src/ocaml/preprocess/parser_raw.ml" +# 22985 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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.module_type) = Obj.magic _4 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__4_ in + let _v : (Parsetree.module_type) = let _1 = + let _1 = +# 1754 "src/ocaml/preprocess/parser_raw.mly" + ( Pmty_functor(Unit, _4) ) +# 23032 "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 + +# 1041 "src/ocaml/preprocess/parser_raw.mly" + ( mkmty ~loc:_sloc _1 ) +# 23041 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1765 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 23047 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23018,24 +23081,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1742 "src/ocaml/preprocess/parser_raw.mly" +# 1757 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_functor(Named (mknoloc None, _1), _3) ) -# 23024 "src/ocaml/preprocess/parser_raw.ml" +# 23087 "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 -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23033 "src/ocaml/preprocess/parser_raw.ml" +# 23096 "src/ocaml/preprocess/parser_raw.ml" in -# 1750 "src/ocaml/preprocess/parser_raw.mly" +# 1765 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23039 "src/ocaml/preprocess/parser_raw.ml" +# 23102 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23077,18 +23140,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 23081 "src/ocaml/preprocess/parser_raw.ml" +# 23144 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 23086 "src/ocaml/preprocess/parser_raw.ml" +# 23149 "src/ocaml/preprocess/parser_raw.ml" in -# 1744 "src/ocaml/preprocess/parser_raw.mly" +# 1759 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_with(_1, _3) ) -# 23092 "src/ocaml/preprocess/parser_raw.ml" +# 23155 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -23096,15 +23159,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23102 "src/ocaml/preprocess/parser_raw.ml" +# 23165 "src/ocaml/preprocess/parser_raw.ml" in -# 1750 "src/ocaml/preprocess/parser_raw.mly" +# 1765 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23108 "src/ocaml/preprocess/parser_raw.ml" +# 23171 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23128,23 +23191,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1748 "src/ocaml/preprocess/parser_raw.mly" +# 1763 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_extension _1 ) -# 23134 "src/ocaml/preprocess/parser_raw.ml" +# 23197 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23142 "src/ocaml/preprocess/parser_raw.ml" +# 23205 "src/ocaml/preprocess/parser_raw.ml" in -# 1750 "src/ocaml/preprocess/parser_raw.mly" +# 1765 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23148 "src/ocaml/preprocess/parser_raw.ml" +# 23211 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23211,9 +23274,9 @@ module Tables = struct let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23217 "src/ocaml/preprocess/parser_raw.ml" +# 23280 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -23223,31 +23286,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23229 "src/ocaml/preprocess/parser_raw.ml" +# 23292 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23237 "src/ocaml/preprocess/parser_raw.ml" +# 23300 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1660 "src/ocaml/preprocess/parser_raw.mly" +# 1669 "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 ) -# 23251 "src/ocaml/preprocess/parser_raw.ml" +# 23314 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23321,9 +23384,9 @@ module Tables = struct let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23327 "src/ocaml/preprocess/parser_raw.ml" +# 23390 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -23333,31 +23396,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23339 "src/ocaml/preprocess/parser_raw.ml" +# 23402 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23347 "src/ocaml/preprocess/parser_raw.ml" +# 23410 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1926 "src/ocaml/preprocess/parser_raw.mly" +# 1945 "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 ) -# 23361 "src/ocaml/preprocess/parser_raw.ml" +# 23424 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23380,9 +23443,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3813 "src/ocaml/preprocess/parser_raw.mly" +# 3833 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23386 "src/ocaml/preprocess/parser_raw.ml" +# 23449 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23398,9 +23461,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.mutable_flag) = -# 3894 "src/ocaml/preprocess/parser_raw.mly" +# 3914 "src/ocaml/preprocess/parser_raw.mly" ( Immutable ) -# 23404 "src/ocaml/preprocess/parser_raw.ml" +# 23467 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23423,9 +23486,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag) = -# 3895 "src/ocaml/preprocess/parser_raw.mly" +# 3915 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 23429 "src/ocaml/preprocess/parser_raw.ml" +# 23492 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23441,9 +23504,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3903 "src/ocaml/preprocess/parser_raw.mly" +# 3923 "src/ocaml/preprocess/parser_raw.mly" ( Immutable, Concrete ) -# 23447 "src/ocaml/preprocess/parser_raw.ml" +# 23510 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23466,9 +23529,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3905 "src/ocaml/preprocess/parser_raw.mly" +# 3925 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Concrete ) -# 23472 "src/ocaml/preprocess/parser_raw.ml" +# 23535 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23491,9 +23554,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3907 "src/ocaml/preprocess/parser_raw.mly" +# 3927 "src/ocaml/preprocess/parser_raw.mly" ( Immutable, Virtual ) -# 23497 "src/ocaml/preprocess/parser_raw.ml" +# 23560 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23523,9 +23586,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Virtual ) -# 23529 "src/ocaml/preprocess/parser_raw.ml" +# 23592 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23555,9 +23618,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Virtual ) -# 23561 "src/ocaml/preprocess/parser_raw.ml" +# 23624 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23587,9 +23650,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3865 "src/ocaml/preprocess/parser_raw.mly" +# 3885 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 23593 "src/ocaml/preprocess/parser_raw.ml" +# 23656 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23608,9 +23671,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 23614 "src/ocaml/preprocess/parser_raw.ml" +# 23677 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -23620,15 +23683,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23626 "src/ocaml/preprocess/parser_raw.ml" +# 23689 "src/ocaml/preprocess/parser_raw.ml" in # 221 "" ( [ x ] ) -# 23632 "src/ocaml/preprocess/parser_raw.ml" +# 23695 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23654,9 +23717,9 @@ module Tables = struct } = _menhir_stack in let xs : (string Location.loc list) = Obj.magic xs in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 23660 "src/ocaml/preprocess/parser_raw.ml" +# 23723 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -23666,15 +23729,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23672 "src/ocaml/preprocess/parser_raw.ml" +# 23735 "src/ocaml/preprocess/parser_raw.ml" in # 223 "" ( x :: xs ) -# 23678 "src/ocaml/preprocess/parser_raw.ml" +# 23741 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23693,22 +23756,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let s : ( -# 835 "src/ocaml/preprocess/parser_raw.mly" +# 837 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 23699 "src/ocaml/preprocess/parser_raw.ml" +# 23762 "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 = -# 3861 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( let body, _, _ = s in body ) -# 23707 "src/ocaml/preprocess/parser_raw.ml" +# 23770 "src/ocaml/preprocess/parser_raw.ml" in # 221 "" ( [ x ] ) -# 23712 "src/ocaml/preprocess/parser_raw.ml" +# 23775 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23734,22 +23797,22 @@ module Tables = struct } = _menhir_stack in let xs : (string list) = Obj.magic xs in let s : ( -# 835 "src/ocaml/preprocess/parser_raw.mly" +# 837 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 23740 "src/ocaml/preprocess/parser_raw.ml" +# 23803 "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 = -# 3861 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( let body, _, _ = s in body ) -# 23748 "src/ocaml/preprocess/parser_raw.ml" +# 23811 "src/ocaml/preprocess/parser_raw.ml" in # 223 "" ( x :: xs ) -# 23753 "src/ocaml/preprocess/parser_raw.ml" +# 23816 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23772,14 +23835,14 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3890 "src/ocaml/preprocess/parser_raw.mly" +# 3910 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 23778 "src/ocaml/preprocess/parser_raw.ml" +# 23841 "src/ocaml/preprocess/parser_raw.ml" in -# 3170 "src/ocaml/preprocess/parser_raw.mly" +# 3190 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, priv, Some ty) ) -# 23783 "src/ocaml/preprocess/parser_raw.ml" +# 23846 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23809,14 +23872,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3891 "src/ocaml/preprocess/parser_raw.mly" +# 3911 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 23815 "src/ocaml/preprocess/parser_raw.ml" +# 23878 "src/ocaml/preprocess/parser_raw.ml" in -# 3170 "src/ocaml/preprocess/parser_raw.mly" +# 3190 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, priv, Some ty) ) -# 23820 "src/ocaml/preprocess/parser_raw.ml" +# 23883 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23839,26 +23902,26 @@ module Tables = struct let _startpos = _startpos_cs_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3890 "src/ocaml/preprocess/parser_raw.mly" +# 3910 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 23845 "src/ocaml/preprocess/parser_raw.ml" +# 23908 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 23851 "src/ocaml/preprocess/parser_raw.ml" +# 23914 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23856 "src/ocaml/preprocess/parser_raw.ml" +# 23919 "src/ocaml/preprocess/parser_raw.ml" in -# 3174 "src/ocaml/preprocess/parser_raw.mly" +# 3194 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 23862 "src/ocaml/preprocess/parser_raw.ml" +# 23925 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23888,26 +23951,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3891 "src/ocaml/preprocess/parser_raw.mly" +# 3911 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 23894 "src/ocaml/preprocess/parser_raw.ml" +# 23957 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 23900 "src/ocaml/preprocess/parser_raw.ml" +# 23963 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23905 "src/ocaml/preprocess/parser_raw.ml" +# 23968 "src/ocaml/preprocess/parser_raw.ml" in -# 3174 "src/ocaml/preprocess/parser_raw.mly" +# 3194 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 23911 "src/ocaml/preprocess/parser_raw.ml" +# 23974 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23944,33 +24007,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3890 "src/ocaml/preprocess/parser_raw.mly" +# 3910 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 23950 "src/ocaml/preprocess/parser_raw.ml" +# 24013 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 23957 "src/ocaml/preprocess/parser_raw.ml" +# 24020 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 23962 "src/ocaml/preprocess/parser_raw.ml" +# 24025 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23968 "src/ocaml/preprocess/parser_raw.ml" +# 24031 "src/ocaml/preprocess/parser_raw.ml" in -# 3174 "src/ocaml/preprocess/parser_raw.mly" +# 3194 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 23974 "src/ocaml/preprocess/parser_raw.ml" +# 24037 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24014,33 +24077,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3891 "src/ocaml/preprocess/parser_raw.mly" +# 3911 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24020 "src/ocaml/preprocess/parser_raw.ml" +# 24083 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24027 "src/ocaml/preprocess/parser_raw.ml" +# 24090 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24032 "src/ocaml/preprocess/parser_raw.ml" +# 24095 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24038 "src/ocaml/preprocess/parser_raw.ml" +# 24101 "src/ocaml/preprocess/parser_raw.ml" in -# 3174 "src/ocaml/preprocess/parser_raw.mly" +# 3194 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24044 "src/ocaml/preprocess/parser_raw.ml" +# 24107 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24063,26 +24126,26 @@ module Tables = struct let _startpos = _startpos__3_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3890 "src/ocaml/preprocess/parser_raw.mly" +# 3910 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24069 "src/ocaml/preprocess/parser_raw.ml" +# 24132 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24075 "src/ocaml/preprocess/parser_raw.ml" +# 24138 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24080 "src/ocaml/preprocess/parser_raw.ml" +# 24143 "src/ocaml/preprocess/parser_raw.ml" in -# 3178 "src/ocaml/preprocess/parser_raw.mly" +# 3198 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24086 "src/ocaml/preprocess/parser_raw.ml" +# 24149 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24112,26 +24175,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3891 "src/ocaml/preprocess/parser_raw.mly" +# 3911 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24118 "src/ocaml/preprocess/parser_raw.ml" +# 24181 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24124 "src/ocaml/preprocess/parser_raw.ml" +# 24187 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24129 "src/ocaml/preprocess/parser_raw.ml" +# 24192 "src/ocaml/preprocess/parser_raw.ml" in -# 3178 "src/ocaml/preprocess/parser_raw.mly" +# 3198 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24135 "src/ocaml/preprocess/parser_raw.ml" +# 24198 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24168,33 +24231,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3890 "src/ocaml/preprocess/parser_raw.mly" +# 3910 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24174 "src/ocaml/preprocess/parser_raw.ml" +# 24237 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24181 "src/ocaml/preprocess/parser_raw.ml" +# 24244 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24186 "src/ocaml/preprocess/parser_raw.ml" +# 24249 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24192 "src/ocaml/preprocess/parser_raw.ml" +# 24255 "src/ocaml/preprocess/parser_raw.ml" in -# 3178 "src/ocaml/preprocess/parser_raw.mly" +# 3198 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24198 "src/ocaml/preprocess/parser_raw.ml" +# 24261 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24238,33 +24301,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3891 "src/ocaml/preprocess/parser_raw.mly" +# 3911 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24244 "src/ocaml/preprocess/parser_raw.ml" +# 24307 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24251 "src/ocaml/preprocess/parser_raw.ml" +# 24314 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24256 "src/ocaml/preprocess/parser_raw.ml" +# 24319 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24262 "src/ocaml/preprocess/parser_raw.ml" +# 24325 "src/ocaml/preprocess/parser_raw.ml" in -# 3178 "src/ocaml/preprocess/parser_raw.mly" +# 3198 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24268 "src/ocaml/preprocess/parser_raw.ml" +# 24331 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24301,26 +24364,26 @@ module Tables = struct let _startpos = _startpos__3_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3890 "src/ocaml/preprocess/parser_raw.mly" +# 3910 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24307 "src/ocaml/preprocess/parser_raw.ml" +# 24370 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24313 "src/ocaml/preprocess/parser_raw.ml" +# 24376 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24318 "src/ocaml/preprocess/parser_raw.ml" +# 24381 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3202 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24324 "src/ocaml/preprocess/parser_raw.ml" +# 24387 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24364,26 +24427,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3891 "src/ocaml/preprocess/parser_raw.mly" +# 3911 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24370 "src/ocaml/preprocess/parser_raw.ml" +# 24433 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24376 "src/ocaml/preprocess/parser_raw.ml" +# 24439 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24381 "src/ocaml/preprocess/parser_raw.ml" +# 24444 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3202 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24387 "src/ocaml/preprocess/parser_raw.ml" +# 24450 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24434,33 +24497,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3890 "src/ocaml/preprocess/parser_raw.mly" +# 3910 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24440 "src/ocaml/preprocess/parser_raw.ml" +# 24503 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24447 "src/ocaml/preprocess/parser_raw.ml" +# 24510 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24452 "src/ocaml/preprocess/parser_raw.ml" +# 24515 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24458 "src/ocaml/preprocess/parser_raw.ml" +# 24521 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3202 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24464 "src/ocaml/preprocess/parser_raw.ml" +# 24527 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24518,33 +24581,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3891 "src/ocaml/preprocess/parser_raw.mly" +# 3911 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24524 "src/ocaml/preprocess/parser_raw.ml" +# 24587 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24531 "src/ocaml/preprocess/parser_raw.ml" +# 24594 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24536 "src/ocaml/preprocess/parser_raw.ml" +# 24599 "src/ocaml/preprocess/parser_raw.ml" in -# 3186 "src/ocaml/preprocess/parser_raw.mly" +# 3206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24542 "src/ocaml/preprocess/parser_raw.ml" +# 24605 "src/ocaml/preprocess/parser_raw.ml" in -# 3182 "src/ocaml/preprocess/parser_raw.mly" +# 3202 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24548 "src/ocaml/preprocess/parser_raw.ml" +# 24611 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24597,37 +24660,37 @@ module Tables = struct let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24603 "src/ocaml/preprocess/parser_raw.ml" +# 24666 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24612 "src/ocaml/preprocess/parser_raw.ml" +# 24675 "src/ocaml/preprocess/parser_raw.ml" in let override = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 24618 "src/ocaml/preprocess/parser_raw.ml" +# 24681 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1679 "src/ocaml/preprocess/parser_raw.mly" +# 1688 "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 ) -# 24631 "src/ocaml/preprocess/parser_raw.ml" +# 24694 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24687,40 +24750,40 @@ module Tables = struct let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24693 "src/ocaml/preprocess/parser_raw.ml" +# 24756 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let attrs1 = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24702 "src/ocaml/preprocess/parser_raw.ml" +# 24765 "src/ocaml/preprocess/parser_raw.ml" in let override = let _1 = _1_inlined1 in -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 24710 "src/ocaml/preprocess/parser_raw.ml" +# 24773 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1679 "src/ocaml/preprocess/parser_raw.mly" +# 1688 "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 ) -# 24724 "src/ocaml/preprocess/parser_raw.ml" +# 24787 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24773,9 +24836,9 @@ module Tables = struct let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24779 "src/ocaml/preprocess/parser_raw.ml" +# 24842 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -24785,36 +24848,36 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 24791 "src/ocaml/preprocess/parser_raw.ml" +# 24854 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24799 "src/ocaml/preprocess/parser_raw.ml" +# 24862 "src/ocaml/preprocess/parser_raw.ml" in let override = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 24805 "src/ocaml/preprocess/parser_raw.ml" +# 24868 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1694 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "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 ) -# 24818 "src/ocaml/preprocess/parser_raw.ml" +# 24881 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24874,9 +24937,9 @@ module Tables = struct let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24880 "src/ocaml/preprocess/parser_raw.ml" +# 24943 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -24886,39 +24949,39 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 24892 "src/ocaml/preprocess/parser_raw.ml" +# 24955 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined2 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24900 "src/ocaml/preprocess/parser_raw.ml" +# 24963 "src/ocaml/preprocess/parser_raw.ml" in let override = let _1 = _1_inlined1 in -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 24908 "src/ocaml/preprocess/parser_raw.ml" +# 24971 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1694 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "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 ) -# 24922 "src/ocaml/preprocess/parser_raw.ml" +# 24985 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24937,17 +25000,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 821 "src/ocaml/preprocess/parser_raw.mly" +# 823 "src/ocaml/preprocess/parser_raw.mly" (string) -# 24943 "src/ocaml/preprocess/parser_raw.ml" +# 25006 "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) = -# 3727 "src/ocaml/preprocess/parser_raw.mly" +# 3747 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24951 "src/ocaml/preprocess/parser_raw.ml" +# 25014 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24966,17 +25029,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 781 "src/ocaml/preprocess/parser_raw.mly" (string) -# 24972 "src/ocaml/preprocess/parser_raw.ml" +# 25035 "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) = -# 3728 "src/ocaml/preprocess/parser_raw.mly" +# 3748 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24980 "src/ocaml/preprocess/parser_raw.ml" +# 25043 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24995,17 +25058,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 782 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25001 "src/ocaml/preprocess/parser_raw.ml" +# 25064 "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) = -# 3729 "src/ocaml/preprocess/parser_raw.mly" +# 3749 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25009 "src/ocaml/preprocess/parser_raw.ml" +# 25072 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25045,17 +25108,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25051 "src/ocaml/preprocess/parser_raw.ml" +# 25114 "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) = -# 3730 "src/ocaml/preprocess/parser_raw.mly" +# 3750 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"(" ^ _3 ^ ")" ) -# 25059 "src/ocaml/preprocess/parser_raw.ml" +# 25122 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25102,17 +25165,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25108 "src/ocaml/preprocess/parser_raw.ml" +# 25171 "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) = -# 3731 "src/ocaml/preprocess/parser_raw.mly" +# 3751 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "(" ^ _3 ^ ")<-" ) -# 25116 "src/ocaml/preprocess/parser_raw.ml" +# 25179 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25152,17 +25215,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25158 "src/ocaml/preprocess/parser_raw.ml" +# 25221 "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) = -# 3732 "src/ocaml/preprocess/parser_raw.mly" +# 3752 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"[" ^ _3 ^ "]" ) -# 25166 "src/ocaml/preprocess/parser_raw.ml" +# 25229 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25209,17 +25272,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25215 "src/ocaml/preprocess/parser_raw.ml" +# 25278 "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) = -# 3733 "src/ocaml/preprocess/parser_raw.mly" +# 3753 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "[" ^ _3 ^ "]<-" ) -# 25223 "src/ocaml/preprocess/parser_raw.ml" +# 25286 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25259,17 +25322,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25265 "src/ocaml/preprocess/parser_raw.ml" +# 25328 "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) = -# 3734 "src/ocaml/preprocess/parser_raw.mly" +# 3754 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"{" ^ _3 ^ "}" ) -# 25273 "src/ocaml/preprocess/parser_raw.ml" +# 25336 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25316,17 +25379,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25322 "src/ocaml/preprocess/parser_raw.ml" +# 25385 "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) = -# 3735 "src/ocaml/preprocess/parser_raw.mly" +# 3755 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "{" ^ _3 ^ "}<-" ) -# 25330 "src/ocaml/preprocess/parser_raw.ml" +# 25393 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25345,17 +25408,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 832 "src/ocaml/preprocess/parser_raw.mly" +# 834 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25351 "src/ocaml/preprocess/parser_raw.ml" +# 25414 "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) = -# 3736 "src/ocaml/preprocess/parser_raw.mly" +# 3756 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25359 "src/ocaml/preprocess/parser_raw.ml" +# 25422 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25378,9 +25441,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3737 "src/ocaml/preprocess/parser_raw.mly" +# 3757 "src/ocaml/preprocess/parser_raw.mly" ( "!" ) -# 25384 "src/ocaml/preprocess/parser_raw.ml" +# 25447 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25399,22 +25462,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 773 "src/ocaml/preprocess/parser_raw.mly" +# 775 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25405 "src/ocaml/preprocess/parser_raw.ml" +# 25468 "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 = -# 3741 "src/ocaml/preprocess/parser_raw.mly" +# 3761 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25413 "src/ocaml/preprocess/parser_raw.ml" +# 25476 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25418 "src/ocaml/preprocess/parser_raw.ml" +# 25481 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25433,22 +25496,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 776 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25439 "src/ocaml/preprocess/parser_raw.ml" +# 25502 "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 = -# 3742 "src/ocaml/preprocess/parser_raw.mly" +# 3762 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25447 "src/ocaml/preprocess/parser_raw.ml" +# 25510 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25452 "src/ocaml/preprocess/parser_raw.ml" +# 25515 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25467,22 +25530,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 777 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25473 "src/ocaml/preprocess/parser_raw.ml" +# 25536 "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 = -# 3743 "src/ocaml/preprocess/parser_raw.mly" +# 3763 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25481 "src/ocaml/preprocess/parser_raw.ml" +# 25544 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25486 "src/ocaml/preprocess/parser_raw.ml" +# 25549 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25501,22 +25564,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25507 "src/ocaml/preprocess/parser_raw.ml" +# 25570 "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 = -# 3744 "src/ocaml/preprocess/parser_raw.mly" +# 3764 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25515 "src/ocaml/preprocess/parser_raw.ml" +# 25578 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25520 "src/ocaml/preprocess/parser_raw.ml" +# 25583 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25535,22 +25598,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 777 "src/ocaml/preprocess/parser_raw.mly" +# 779 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25541 "src/ocaml/preprocess/parser_raw.ml" +# 25604 "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 = -# 3745 "src/ocaml/preprocess/parser_raw.mly" +# 3765 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25549 "src/ocaml/preprocess/parser_raw.ml" +# 25612 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25554 "src/ocaml/preprocess/parser_raw.ml" +# 25617 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25573,14 +25636,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3746 "src/ocaml/preprocess/parser_raw.mly" +# 3766 "src/ocaml/preprocess/parser_raw.mly" ("+") -# 25579 "src/ocaml/preprocess/parser_raw.ml" +# 25642 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25584 "src/ocaml/preprocess/parser_raw.ml" +# 25647 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25603,14 +25666,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3747 "src/ocaml/preprocess/parser_raw.mly" +# 3767 "src/ocaml/preprocess/parser_raw.mly" ("+.") -# 25609 "src/ocaml/preprocess/parser_raw.ml" +# 25672 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25614 "src/ocaml/preprocess/parser_raw.ml" +# 25677 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25633,14 +25696,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3748 "src/ocaml/preprocess/parser_raw.mly" +# 3768 "src/ocaml/preprocess/parser_raw.mly" ("+=") -# 25639 "src/ocaml/preprocess/parser_raw.ml" +# 25702 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25644 "src/ocaml/preprocess/parser_raw.ml" +# 25707 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25663,14 +25726,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3749 "src/ocaml/preprocess/parser_raw.mly" +# 3769 "src/ocaml/preprocess/parser_raw.mly" ("-") -# 25669 "src/ocaml/preprocess/parser_raw.ml" +# 25732 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25674 "src/ocaml/preprocess/parser_raw.ml" +# 25737 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25693,14 +25756,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3750 "src/ocaml/preprocess/parser_raw.mly" +# 3770 "src/ocaml/preprocess/parser_raw.mly" ("-.") -# 25699 "src/ocaml/preprocess/parser_raw.ml" +# 25762 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25704 "src/ocaml/preprocess/parser_raw.ml" +# 25767 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25723,14 +25786,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3751 "src/ocaml/preprocess/parser_raw.mly" +# 3771 "src/ocaml/preprocess/parser_raw.mly" ("*") -# 25729 "src/ocaml/preprocess/parser_raw.ml" +# 25792 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25734 "src/ocaml/preprocess/parser_raw.ml" +# 25797 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25753,14 +25816,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3752 "src/ocaml/preprocess/parser_raw.mly" +# 3772 "src/ocaml/preprocess/parser_raw.mly" ("%") -# 25759 "src/ocaml/preprocess/parser_raw.ml" +# 25822 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25764 "src/ocaml/preprocess/parser_raw.ml" +# 25827 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25783,14 +25846,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3753 "src/ocaml/preprocess/parser_raw.mly" +# 3773 "src/ocaml/preprocess/parser_raw.mly" ("=") -# 25789 "src/ocaml/preprocess/parser_raw.ml" +# 25852 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25794 "src/ocaml/preprocess/parser_raw.ml" +# 25857 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25813,14 +25876,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3754 "src/ocaml/preprocess/parser_raw.mly" +# 3774 "src/ocaml/preprocess/parser_raw.mly" ("<") -# 25819 "src/ocaml/preprocess/parser_raw.ml" +# 25882 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25824 "src/ocaml/preprocess/parser_raw.ml" +# 25887 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25843,14 +25906,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3755 "src/ocaml/preprocess/parser_raw.mly" +# 3775 "src/ocaml/preprocess/parser_raw.mly" (">") -# 25849 "src/ocaml/preprocess/parser_raw.ml" +# 25912 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25854 "src/ocaml/preprocess/parser_raw.ml" +# 25917 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25873,14 +25936,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3756 "src/ocaml/preprocess/parser_raw.mly" +# 3776 "src/ocaml/preprocess/parser_raw.mly" ("or") -# 25879 "src/ocaml/preprocess/parser_raw.ml" +# 25942 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25884 "src/ocaml/preprocess/parser_raw.ml" +# 25947 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25903,14 +25966,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3757 "src/ocaml/preprocess/parser_raw.mly" +# 3777 "src/ocaml/preprocess/parser_raw.mly" ("||") -# 25909 "src/ocaml/preprocess/parser_raw.ml" +# 25972 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25914 "src/ocaml/preprocess/parser_raw.ml" +# 25977 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25933,14 +25996,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3778 "src/ocaml/preprocess/parser_raw.mly" ("&") -# 25939 "src/ocaml/preprocess/parser_raw.ml" +# 26002 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25944 "src/ocaml/preprocess/parser_raw.ml" +# 26007 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25963,14 +26026,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3759 "src/ocaml/preprocess/parser_raw.mly" +# 3779 "src/ocaml/preprocess/parser_raw.mly" ("&&") -# 25969 "src/ocaml/preprocess/parser_raw.ml" +# 26032 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25974 "src/ocaml/preprocess/parser_raw.ml" +# 26037 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25993,14 +26056,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3760 "src/ocaml/preprocess/parser_raw.mly" +# 3780 "src/ocaml/preprocess/parser_raw.mly" (":=") -# 25999 "src/ocaml/preprocess/parser_raw.ml" +# 26062 "src/ocaml/preprocess/parser_raw.ml" in -# 3738 "src/ocaml/preprocess/parser_raw.mly" +# 3758 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26004 "src/ocaml/preprocess/parser_raw.ml" +# 26067 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26023,9 +26086,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (bool) = -# 3640 "src/ocaml/preprocess/parser_raw.mly" +# 3660 "src/ocaml/preprocess/parser_raw.mly" ( true ) -# 26029 "src/ocaml/preprocess/parser_raw.ml" +# 26092 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26041,9 +26104,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (bool) = -# 3641 "src/ocaml/preprocess/parser_raw.mly" +# 3661 "src/ocaml/preprocess/parser_raw.mly" ( false ) -# 26047 "src/ocaml/preprocess/parser_raw.ml" +# 26110 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26061,7 +26124,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26065 "src/ocaml/preprocess/parser_raw.ml" +# 26128 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26086,7 +26149,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26090 "src/ocaml/preprocess/parser_raw.ml" +# 26153 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26104,7 +26167,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26108 "src/ocaml/preprocess/parser_raw.ml" +# 26171 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26129,7 +26192,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26133 "src/ocaml/preprocess/parser_raw.ml" +# 26196 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26147,7 +26210,7 @@ module Tables = struct let _v : (string Location.loc option) = # 114 "" ( None ) -# 26151 "src/ocaml/preprocess/parser_raw.ml" +# 26214 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26172,9 +26235,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 26178 "src/ocaml/preprocess/parser_raw.ml" +# 26241 "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 @@ -26187,21 +26250,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 26193 "src/ocaml/preprocess/parser_raw.ml" +# 26256 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 26199 "src/ocaml/preprocess/parser_raw.ml" +# 26262 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26205 "src/ocaml/preprocess/parser_raw.ml" +# 26268 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26219,7 +26282,7 @@ module Tables = struct let _v : (Parsetree.core_type option) = # 114 "" ( None ) -# 26223 "src/ocaml/preprocess/parser_raw.ml" +# 26286 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26251,12 +26314,12 @@ module Tables = struct let _v : (Parsetree.core_type option) = let x = # 183 "" ( x ) -# 26255 "src/ocaml/preprocess/parser_raw.ml" +# 26318 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26260 "src/ocaml/preprocess/parser_raw.ml" +# 26323 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26274,7 +26337,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 26278 "src/ocaml/preprocess/parser_raw.ml" +# 26341 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26306,12 +26369,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 26310 "src/ocaml/preprocess/parser_raw.ml" +# 26373 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26315 "src/ocaml/preprocess/parser_raw.ml" +# 26378 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26329,7 +26392,7 @@ module Tables = struct let _v : (Parsetree.module_type option) = # 114 "" ( None ) -# 26333 "src/ocaml/preprocess/parser_raw.ml" +# 26396 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26361,12 +26424,12 @@ module Tables = struct let _v : (Parsetree.module_type option) = let x = # 183 "" ( x ) -# 26365 "src/ocaml/preprocess/parser_raw.ml" +# 26428 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26370 "src/ocaml/preprocess/parser_raw.ml" +# 26433 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26384,7 +26447,7 @@ module Tables = struct let _v : (Parsetree.pattern option) = # 114 "" ( None ) -# 26388 "src/ocaml/preprocess/parser_raw.ml" +# 26451 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26416,12 +26479,12 @@ module Tables = struct let _v : (Parsetree.pattern option) = let x = # 183 "" ( x ) -# 26420 "src/ocaml/preprocess/parser_raw.ml" +# 26483 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26425 "src/ocaml/preprocess/parser_raw.ml" +# 26488 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26439,7 +26502,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 26443 "src/ocaml/preprocess/parser_raw.ml" +# 26506 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26471,12 +26534,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 26475 "src/ocaml/preprocess/parser_raw.ml" +# 26538 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26480 "src/ocaml/preprocess/parser_raw.ml" +# 26543 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26494,7 +26557,7 @@ module Tables = struct let _v : ((Parsetree.core_type option * Parsetree.core_type option) option) = # 114 "" ( None ) -# 26498 "src/ocaml/preprocess/parser_raw.ml" +# 26561 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26519,7 +26582,7 @@ module Tables = struct let _v : ((Parsetree.core_type option * Parsetree.core_type option) option) = # 116 "" ( Some x ) -# 26523 "src/ocaml/preprocess/parser_raw.ml" +# 26586 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26538,17 +26601,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 814 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) -# 26544 "src/ocaml/preprocess/parser_raw.ml" +# 26607 "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) = -# 3949 "src/ocaml/preprocess/parser_raw.mly" +# 3969 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26552 "src/ocaml/preprocess/parser_raw.ml" +# 26615 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26580,18 +26643,18 @@ module Tables = struct } = _menhir_stack in let _3 : unit = Obj.magic _3 in let _2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 26586 "src/ocaml/preprocess/parser_raw.ml" +# 26649 "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) = -# 3950 "src/ocaml/preprocess/parser_raw.mly" +# 3970 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 26595 "src/ocaml/preprocess/parser_raw.ml" +# 26658 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26645,9 +26708,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1452 "src/ocaml/preprocess/parser_raw.mly" +# 1457 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc (Pmod_constraint(me, mty)) ) -# 26651 "src/ocaml/preprocess/parser_raw.ml" +# 26714 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26684,9 +26747,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.module_expr) = -# 1459 "src/ocaml/preprocess/parser_raw.mly" +# 1464 "src/ocaml/preprocess/parser_raw.mly" ( me (* TODO consider reloc *) ) -# 26690 "src/ocaml/preprocess/parser_raw.ml" +# 26753 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26737,25 +26800,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.module_expr) = let e = -# 1482 "src/ocaml/preprocess/parser_raw.mly" +# 1487 "src/ocaml/preprocess/parser_raw.mly" ( e ) -# 26743 "src/ocaml/preprocess/parser_raw.ml" +# 26806 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26750 "src/ocaml/preprocess/parser_raw.ml" +# 26813 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1467 "src/ocaml/preprocess/parser_raw.mly" +# 1472 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 26759 "src/ocaml/preprocess/parser_raw.ml" +# 26822 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26826,11 +26889,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3615 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "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 ) -# 26834 "src/ocaml/preprocess/parser_raw.ml" +# 26897 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_ty_ = _endpos__1_ in @@ -26838,26 +26901,26 @@ module Tables = struct let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1484 "src/ocaml/preprocess/parser_raw.mly" +# 1489 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_constraint (e, ty)) ) -# 26844 "src/ocaml/preprocess/parser_raw.ml" +# 26907 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26852 "src/ocaml/preprocess/parser_raw.ml" +# 26915 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1467 "src/ocaml/preprocess/parser_raw.mly" +# 1472 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 26861 "src/ocaml/preprocess/parser_raw.ml" +# 26924 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26943,11 +27006,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3615 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "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 ) -# 26951 "src/ocaml/preprocess/parser_raw.ml" +# 27014 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_ty2_ = _endpos__1_inlined1_ in @@ -26956,37 +27019,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3615 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "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 ) -# 26964 "src/ocaml/preprocess/parser_raw.ml" +# 27027 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_ty2_ in let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1486 "src/ocaml/preprocess/parser_raw.mly" +# 1491 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, Some ty1, ty2)) ) -# 26973 "src/ocaml/preprocess/parser_raw.ml" +# 27036 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26981 "src/ocaml/preprocess/parser_raw.ml" +# 27044 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1467 "src/ocaml/preprocess/parser_raw.mly" +# 1472 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 26990 "src/ocaml/preprocess/parser_raw.ml" +# 27053 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27057,11 +27120,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3615 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "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 ) -# 27065 "src/ocaml/preprocess/parser_raw.ml" +# 27128 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_ty2_ = _endpos__1_ in @@ -27069,26 +27132,26 @@ module Tables = struct let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1488 "src/ocaml/preprocess/parser_raw.mly" +# 1493 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, None, ty2)) ) -# 27075 "src/ocaml/preprocess/parser_raw.ml" +# 27138 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27083 "src/ocaml/preprocess/parser_raw.ml" +# 27146 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1467 "src/ocaml/preprocess/parser_raw.mly" +# 1472 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27092 "src/ocaml/preprocess/parser_raw.ml" +# 27155 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27118,9 +27181,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1364 "src/ocaml/preprocess/parser_raw.mly" +# 1366 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27124 "src/ocaml/preprocess/parser_raw.ml" +# 27187 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27150,9 +27213,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1349 "src/ocaml/preprocess/parser_raw.mly" +# 1351 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27156 "src/ocaml/preprocess/parser_raw.ml" +# 27219 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27182,9 +27245,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = -# 1324 "src/ocaml/preprocess/parser_raw.mly" +# 1326 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27188 "src/ocaml/preprocess/parser_raw.ml" +# 27251 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27214,9 +27277,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 1329 "src/ocaml/preprocess/parser_raw.mly" +# 1331 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27220 "src/ocaml/preprocess/parser_raw.ml" +# 27283 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27246,9 +27309,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1354 "src/ocaml/preprocess/parser_raw.mly" +# 1356 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27252 "src/ocaml/preprocess/parser_raw.ml" +# 27315 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27278,9 +27341,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1359 "src/ocaml/preprocess/parser_raw.mly" +# 1361 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27284 "src/ocaml/preprocess/parser_raw.ml" +# 27347 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27310,9 +27373,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_expr) = -# 1319 "src/ocaml/preprocess/parser_raw.mly" +# 1321 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27316 "src/ocaml/preprocess/parser_raw.ml" +# 27379 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27342,9 +27405,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_type) = -# 1314 "src/ocaml/preprocess/parser_raw.mly" +# 1316 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27348 "src/ocaml/preprocess/parser_raw.ml" +# 27411 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27374,9 +27437,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1339 "src/ocaml/preprocess/parser_raw.mly" +# 1341 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27380 "src/ocaml/preprocess/parser_raw.ml" +# 27443 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27406,9 +27469,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = -# 1334 "src/ocaml/preprocess/parser_raw.mly" +# 1336 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27412 "src/ocaml/preprocess/parser_raw.ml" +# 27475 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27438,9 +27501,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1344 "src/ocaml/preprocess/parser_raw.mly" +# 1346 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27444 "src/ocaml/preprocess/parser_raw.ml" +# 27507 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27482,15 +27545,15 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2895 "src/ocaml/preprocess/parser_raw.mly" +# 2915 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 27488 "src/ocaml/preprocess/parser_raw.ml" +# 27551 "src/ocaml/preprocess/parser_raw.ml" in -# 2883 "src/ocaml/preprocess/parser_raw.mly" +# 2903 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27494 "src/ocaml/preprocess/parser_raw.ml" +# 27557 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27520,14 +27583,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = -# 2897 "src/ocaml/preprocess/parser_raw.mly" +# 2917 "src/ocaml/preprocess/parser_raw.mly" ( Pat.attr _1 _2 ) -# 27526 "src/ocaml/preprocess/parser_raw.ml" +# 27589 "src/ocaml/preprocess/parser_raw.ml" in -# 2883 "src/ocaml/preprocess/parser_raw.mly" +# 2903 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27531 "src/ocaml/preprocess/parser_raw.ml" +# 27594 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27550,14 +27613,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = -# 2899 "src/ocaml/preprocess/parser_raw.mly" +# 2919 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27556 "src/ocaml/preprocess/parser_raw.ml" +# 27619 "src/ocaml/preprocess/parser_raw.ml" in -# 2883 "src/ocaml/preprocess/parser_raw.mly" +# 2903 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27561 "src/ocaml/preprocess/parser_raw.ml" +# 27624 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27602,15 +27665,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 27608 "src/ocaml/preprocess/parser_raw.ml" +# 27671 "src/ocaml/preprocess/parser_raw.ml" in -# 2902 "src/ocaml/preprocess/parser_raw.mly" +# 2922 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_alias(_1, _3) ) -# 27614 "src/ocaml/preprocess/parser_raw.ml" +# 27677 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -27618,21 +27681,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 27624 "src/ocaml/preprocess/parser_raw.ml" +# 27687 "src/ocaml/preprocess/parser_raw.ml" in -# 2913 "src/ocaml/preprocess/parser_raw.mly" +# 2933 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27630 "src/ocaml/preprocess/parser_raw.ml" +# 27693 "src/ocaml/preprocess/parser_raw.ml" in -# 2883 "src/ocaml/preprocess/parser_raw.mly" +# 2903 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27636 "src/ocaml/preprocess/parser_raw.ml" +# 27699 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27657,29 +27720,29 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2906 "src/ocaml/preprocess/parser_raw.mly" +# 2926 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_tuple(List.rev _1) ) -# 27663 "src/ocaml/preprocess/parser_raw.ml" +# 27726 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 27671 "src/ocaml/preprocess/parser_raw.ml" +# 27734 "src/ocaml/preprocess/parser_raw.ml" in -# 2913 "src/ocaml/preprocess/parser_raw.mly" +# 2933 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27677 "src/ocaml/preprocess/parser_raw.ml" +# 27740 "src/ocaml/preprocess/parser_raw.ml" in -# 2883 "src/ocaml/preprocess/parser_raw.mly" +# 2903 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27683 "src/ocaml/preprocess/parser_raw.ml" +# 27746 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27718,30 +27781,30 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2910 "src/ocaml/preprocess/parser_raw.mly" +# 2930 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_or(_1, _3) ) -# 27724 "src/ocaml/preprocess/parser_raw.ml" +# 27787 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 27733 "src/ocaml/preprocess/parser_raw.ml" +# 27796 "src/ocaml/preprocess/parser_raw.ml" in -# 2913 "src/ocaml/preprocess/parser_raw.mly" +# 2933 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27739 "src/ocaml/preprocess/parser_raw.ml" +# 27802 "src/ocaml/preprocess/parser_raw.ml" in -# 2883 "src/ocaml/preprocess/parser_raw.mly" +# 2903 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27745 "src/ocaml/preprocess/parser_raw.ml" +# 27808 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27789,24 +27852,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27795 "src/ocaml/preprocess/parser_raw.ml" +# 27858 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 27801 "src/ocaml/preprocess/parser_raw.ml" +# 27864 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2885 "src/ocaml/preprocess/parser_raw.mly" +# 2905 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_exception _3) _2) -# 27810 "src/ocaml/preprocess/parser_raw.ml" +# 27873 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27843,9 +27906,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3016 "src/ocaml/preprocess/parser_raw.mly" +# 3036 "src/ocaml/preprocess/parser_raw.mly" ( _3 :: _1 ) -# 27849 "src/ocaml/preprocess/parser_raw.ml" +# 27912 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27882,9 +27945,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3017 "src/ocaml/preprocess/parser_raw.mly" +# 3037 "src/ocaml/preprocess/parser_raw.mly" ( [_3; _1] ) -# 27888 "src/ocaml/preprocess/parser_raw.ml" +# 27951 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27921,9 +27984,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3016 "src/ocaml/preprocess/parser_raw.mly" +# 3036 "src/ocaml/preprocess/parser_raw.mly" ( _3 :: _1 ) -# 27927 "src/ocaml/preprocess/parser_raw.ml" +# 27990 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27960,9 +28023,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3017 "src/ocaml/preprocess/parser_raw.mly" +# 3037 "src/ocaml/preprocess/parser_raw.mly" ( [_3; _1] ) -# 27966 "src/ocaml/preprocess/parser_raw.ml" +# 28029 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27985,9 +28048,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2918 "src/ocaml/preprocess/parser_raw.mly" +# 2938 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27991 "src/ocaml/preprocess/parser_raw.ml" +# 28054 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28023,15 +28086,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28029 "src/ocaml/preprocess/parser_raw.ml" +# 28092 "src/ocaml/preprocess/parser_raw.ml" in -# 2921 "src/ocaml/preprocess/parser_raw.mly" +# 2941 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(_1, Some ([], _2)) ) -# 28035 "src/ocaml/preprocess/parser_raw.ml" +# 28098 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -28039,15 +28102,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28045 "src/ocaml/preprocess/parser_raw.ml" +# 28108 "src/ocaml/preprocess/parser_raw.ml" in -# 2927 "src/ocaml/preprocess/parser_raw.mly" +# 2947 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28051 "src/ocaml/preprocess/parser_raw.ml" +# 28114 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28107,24 +28170,24 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let newtypes = -# 2666 "src/ocaml/preprocess/parser_raw.mly" +# 2689 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 28113 "src/ocaml/preprocess/parser_raw.ml" +# 28176 "src/ocaml/preprocess/parser_raw.ml" in let constr = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28122 "src/ocaml/preprocess/parser_raw.ml" +# 28185 "src/ocaml/preprocess/parser_raw.ml" in -# 2924 "src/ocaml/preprocess/parser_raw.mly" +# 2944 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(constr, Some (newtypes, pat)) ) -# 28128 "src/ocaml/preprocess/parser_raw.ml" +# 28191 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_pat_ in @@ -28132,15 +28195,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28138 "src/ocaml/preprocess/parser_raw.ml" +# 28201 "src/ocaml/preprocess/parser_raw.ml" in -# 2927 "src/ocaml/preprocess/parser_raw.mly" +# 2947 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28144 "src/ocaml/preprocess/parser_raw.ml" +# 28207 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28171,24 +28234,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2926 "src/ocaml/preprocess/parser_raw.mly" +# 2946 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_variant(_1, Some _2) ) -# 28177 "src/ocaml/preprocess/parser_raw.ml" +# 28240 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28186 "src/ocaml/preprocess/parser_raw.ml" +# 28249 "src/ocaml/preprocess/parser_raw.ml" in -# 2927 "src/ocaml/preprocess/parser_raw.mly" +# 2947 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28192 "src/ocaml/preprocess/parser_raw.ml" +# 28255 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28236,24 +28299,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28242 "src/ocaml/preprocess/parser_raw.ml" +# 28305 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 28248 "src/ocaml/preprocess/parser_raw.ml" +# 28311 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2929 "src/ocaml/preprocess/parser_raw.mly" +# 2949 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_lazy _3) _2) -# 28257 "src/ocaml/preprocess/parser_raw.ml" +# 28320 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28295,15 +28358,15 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2895 "src/ocaml/preprocess/parser_raw.mly" +# 2915 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 28301 "src/ocaml/preprocess/parser_raw.ml" +# 28364 "src/ocaml/preprocess/parser_raw.ml" in -# 2890 "src/ocaml/preprocess/parser_raw.mly" +# 2910 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28307 "src/ocaml/preprocess/parser_raw.ml" +# 28370 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28333,14 +28396,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = -# 2897 "src/ocaml/preprocess/parser_raw.mly" +# 2917 "src/ocaml/preprocess/parser_raw.mly" ( Pat.attr _1 _2 ) -# 28339 "src/ocaml/preprocess/parser_raw.ml" +# 28402 "src/ocaml/preprocess/parser_raw.ml" in -# 2890 "src/ocaml/preprocess/parser_raw.mly" +# 2910 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28344 "src/ocaml/preprocess/parser_raw.ml" +# 28407 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28363,14 +28426,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = -# 2899 "src/ocaml/preprocess/parser_raw.mly" +# 2919 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28369 "src/ocaml/preprocess/parser_raw.ml" +# 28432 "src/ocaml/preprocess/parser_raw.ml" in -# 2890 "src/ocaml/preprocess/parser_raw.mly" +# 2910 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28374 "src/ocaml/preprocess/parser_raw.ml" +# 28437 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28415,15 +28478,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28421 "src/ocaml/preprocess/parser_raw.ml" +# 28484 "src/ocaml/preprocess/parser_raw.ml" in -# 2902 "src/ocaml/preprocess/parser_raw.mly" +# 2922 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_alias(_1, _3) ) -# 28427 "src/ocaml/preprocess/parser_raw.ml" +# 28490 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -28431,21 +28494,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28437 "src/ocaml/preprocess/parser_raw.ml" +# 28500 "src/ocaml/preprocess/parser_raw.ml" in -# 2913 "src/ocaml/preprocess/parser_raw.mly" +# 2933 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28443 "src/ocaml/preprocess/parser_raw.ml" +# 28506 "src/ocaml/preprocess/parser_raw.ml" in -# 2890 "src/ocaml/preprocess/parser_raw.mly" +# 2910 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28449 "src/ocaml/preprocess/parser_raw.ml" +# 28512 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28470,29 +28533,29 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2906 "src/ocaml/preprocess/parser_raw.mly" +# 2926 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_tuple(List.rev _1) ) -# 28476 "src/ocaml/preprocess/parser_raw.ml" +# 28539 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28484 "src/ocaml/preprocess/parser_raw.ml" +# 28547 "src/ocaml/preprocess/parser_raw.ml" in -# 2913 "src/ocaml/preprocess/parser_raw.mly" +# 2933 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28490 "src/ocaml/preprocess/parser_raw.ml" +# 28553 "src/ocaml/preprocess/parser_raw.ml" in -# 2890 "src/ocaml/preprocess/parser_raw.mly" +# 2910 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28496 "src/ocaml/preprocess/parser_raw.ml" +# 28559 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28531,30 +28594,30 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2910 "src/ocaml/preprocess/parser_raw.mly" +# 2930 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_or(_1, _3) ) -# 28537 "src/ocaml/preprocess/parser_raw.ml" +# 28600 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28546 "src/ocaml/preprocess/parser_raw.ml" +# 28609 "src/ocaml/preprocess/parser_raw.ml" in -# 2913 "src/ocaml/preprocess/parser_raw.mly" +# 2933 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28552 "src/ocaml/preprocess/parser_raw.ml" +# 28615 "src/ocaml/preprocess/parser_raw.ml" in -# 2890 "src/ocaml/preprocess/parser_raw.mly" +# 2910 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28558 "src/ocaml/preprocess/parser_raw.ml" +# 28621 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28573,9 +28636,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 28579 "src/ocaml/preprocess/parser_raw.ml" +# 28642 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -28587,30 +28650,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28593 "src/ocaml/preprocess/parser_raw.ml" +# 28656 "src/ocaml/preprocess/parser_raw.ml" in -# 2348 "src/ocaml/preprocess/parser_raw.mly" +# 2367 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_var _1 ) -# 28599 "src/ocaml/preprocess/parser_raw.ml" +# 28662 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28608 "src/ocaml/preprocess/parser_raw.ml" +# 28671 "src/ocaml/preprocess/parser_raw.ml" in -# 2350 "src/ocaml/preprocess/parser_raw.mly" +# 2369 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28614 "src/ocaml/preprocess/parser_raw.ml" +# 28677 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28634,23 +28697,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2349 "src/ocaml/preprocess/parser_raw.mly" +# 2368 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_any ) -# 28640 "src/ocaml/preprocess/parser_raw.ml" +# 28703 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28648 "src/ocaml/preprocess/parser_raw.ml" +# 28711 "src/ocaml/preprocess/parser_raw.ml" in -# 2350 "src/ocaml/preprocess/parser_raw.mly" +# 2369 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28654 "src/ocaml/preprocess/parser_raw.ml" +# 28717 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28673,9 +28736,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.payload) = -# 4061 "src/ocaml/preprocess/parser_raw.mly" +# 4081 "src/ocaml/preprocess/parser_raw.mly" ( PStr _1 ) -# 28679 "src/ocaml/preprocess/parser_raw.ml" +# 28742 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28705,9 +28768,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4062 "src/ocaml/preprocess/parser_raw.mly" +# 4082 "src/ocaml/preprocess/parser_raw.mly" ( PSig _2 ) -# 28711 "src/ocaml/preprocess/parser_raw.ml" +# 28774 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28737,9 +28800,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4063 "src/ocaml/preprocess/parser_raw.mly" +# 4083 "src/ocaml/preprocess/parser_raw.mly" ( PTyp _2 ) -# 28743 "src/ocaml/preprocess/parser_raw.ml" +# 28806 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28769,9 +28832,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4064 "src/ocaml/preprocess/parser_raw.mly" +# 4084 "src/ocaml/preprocess/parser_raw.mly" ( PPat (_2, None) ) -# 28775 "src/ocaml/preprocess/parser_raw.ml" +# 28838 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28815,9 +28878,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.payload) = -# 4065 "src/ocaml/preprocess/parser_raw.mly" +# 4085 "src/ocaml/preprocess/parser_raw.mly" ( PPat (_2, Some _4) ) -# 28821 "src/ocaml/preprocess/parser_raw.ml" +# 28884 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28840,9 +28903,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3454 "src/ocaml/preprocess/parser_raw.mly" +# 3474 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28846 "src/ocaml/preprocess/parser_raw.ml" +# 28909 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28885,24 +28948,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 28889 "src/ocaml/preprocess/parser_raw.ml" +# 28952 "src/ocaml/preprocess/parser_raw.ml" in -# 1096 "src/ocaml/preprocess/parser_raw.mly" +# 1098 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 28894 "src/ocaml/preprocess/parser_raw.ml" +# 28957 "src/ocaml/preprocess/parser_raw.ml" in -# 3446 "src/ocaml/preprocess/parser_raw.mly" +# 3466 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28900 "src/ocaml/preprocess/parser_raw.ml" +# 28963 "src/ocaml/preprocess/parser_raw.ml" in -# 3450 "src/ocaml/preprocess/parser_raw.mly" +# 3470 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 28906 "src/ocaml/preprocess/parser_raw.ml" +# 28969 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_xs_) in @@ -28910,15 +28973,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 28916 "src/ocaml/preprocess/parser_raw.ml" +# 28979 "src/ocaml/preprocess/parser_raw.ml" in -# 3456 "src/ocaml/preprocess/parser_raw.mly" +# 3476 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28922 "src/ocaml/preprocess/parser_raw.ml" +# 28985 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28941,14 +29004,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = -# 3485 "src/ocaml/preprocess/parser_raw.mly" +# 3505 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28947 "src/ocaml/preprocess/parser_raw.ml" +# 29010 "src/ocaml/preprocess/parser_raw.ml" in -# 3454 "src/ocaml/preprocess/parser_raw.mly" +# 3474 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28952 "src/ocaml/preprocess/parser_raw.ml" +# 29015 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28987,33 +29050,33 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let _3 = -# 3485 "src/ocaml/preprocess/parser_raw.mly" +# 3505 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28993 "src/ocaml/preprocess/parser_raw.ml" +# 29056 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 29000 "src/ocaml/preprocess/parser_raw.ml" +# 29063 "src/ocaml/preprocess/parser_raw.ml" in -# 1096 "src/ocaml/preprocess/parser_raw.mly" +# 1098 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 29005 "src/ocaml/preprocess/parser_raw.ml" +# 29068 "src/ocaml/preprocess/parser_raw.ml" in -# 3446 "src/ocaml/preprocess/parser_raw.mly" +# 3466 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29011 "src/ocaml/preprocess/parser_raw.ml" +# 29074 "src/ocaml/preprocess/parser_raw.ml" in -# 3450 "src/ocaml/preprocess/parser_raw.mly" +# 3470 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 29017 "src/ocaml/preprocess/parser_raw.ml" +# 29080 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_xs_ in @@ -29021,15 +29084,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 29027 "src/ocaml/preprocess/parser_raw.ml" +# 29090 "src/ocaml/preprocess/parser_raw.ml" in -# 3456 "src/ocaml/preprocess/parser_raw.mly" +# 3476 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29033 "src/ocaml/preprocess/parser_raw.ml" +# 29096 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29076,9 +29139,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4022 "src/ocaml/preprocess/parser_raw.mly" +# 4042 "src/ocaml/preprocess/parser_raw.mly" ( Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 29082 "src/ocaml/preprocess/parser_raw.ml" +# 29145 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29159,9 +29222,9 @@ module Tables = struct let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29165 "src/ocaml/preprocess/parser_raw.ml" +# 29228 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -29171,30 +29234,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 29177 "src/ocaml/preprocess/parser_raw.ml" +# 29240 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29185 "src/ocaml/preprocess/parser_raw.ml" +# 29248 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3080 "src/ocaml/preprocess/parser_raw.mly" +# 3100 "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 ) -# 29198 "src/ocaml/preprocess/parser_raw.ml" +# 29261 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29210,14 +29273,14 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.private_flag) = let _1 = -# 3890 "src/ocaml/preprocess/parser_raw.mly" +# 3910 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 29216 "src/ocaml/preprocess/parser_raw.ml" +# 29279 "src/ocaml/preprocess/parser_raw.ml" in -# 3887 "src/ocaml/preprocess/parser_raw.mly" +# 3907 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29221 "src/ocaml/preprocess/parser_raw.ml" +# 29284 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29240,14 +29303,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = let _1 = -# 3891 "src/ocaml/preprocess/parser_raw.mly" +# 3911 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 29246 "src/ocaml/preprocess/parser_raw.ml" +# 29309 "src/ocaml/preprocess/parser_raw.ml" in -# 3887 "src/ocaml/preprocess/parser_raw.mly" +# 3907 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29251 "src/ocaml/preprocess/parser_raw.ml" +# 29314 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29263,9 +29326,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3913 "src/ocaml/preprocess/parser_raw.mly" +# 3933 "src/ocaml/preprocess/parser_raw.mly" ( Public, Concrete ) -# 29269 "src/ocaml/preprocess/parser_raw.ml" +# 29332 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29288,9 +29351,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3914 "src/ocaml/preprocess/parser_raw.mly" +# 3934 "src/ocaml/preprocess/parser_raw.mly" ( Private, Concrete ) -# 29294 "src/ocaml/preprocess/parser_raw.ml" +# 29357 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29313,9 +29376,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3915 "src/ocaml/preprocess/parser_raw.mly" +# 3935 "src/ocaml/preprocess/parser_raw.mly" ( Public, Virtual ) -# 29319 "src/ocaml/preprocess/parser_raw.ml" +# 29382 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29345,9 +29408,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3936 "src/ocaml/preprocess/parser_raw.mly" ( Private, Virtual ) -# 29351 "src/ocaml/preprocess/parser_raw.ml" +# 29414 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29377,9 +29440,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3917 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( Private, Virtual ) -# 29383 "src/ocaml/preprocess/parser_raw.ml" +# 29446 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29395,9 +29458,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.rec_flag) = -# 3868 "src/ocaml/preprocess/parser_raw.mly" +# 3888 "src/ocaml/preprocess/parser_raw.mly" ( Nonrecursive ) -# 29401 "src/ocaml/preprocess/parser_raw.ml" +# 29464 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29420,9 +29483,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.rec_flag) = -# 3869 "src/ocaml/preprocess/parser_raw.mly" +# 3889 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 29426 "src/ocaml/preprocess/parser_raw.ml" +# 29489 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29448,12 +29511,12 @@ module Tables = struct (Longident.t Location.loc * Parsetree.expression) list) = let eo = # 124 "" ( None ) -# 29452 "src/ocaml/preprocess/parser_raw.ml" +# 29515 "src/ocaml/preprocess/parser_raw.ml" in -# 2815 "src/ocaml/preprocess/parser_raw.mly" +# 2835 "src/ocaml/preprocess/parser_raw.mly" ( eo, fields ) -# 29457 "src/ocaml/preprocess/parser_raw.ml" +# 29520 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29494,18 +29557,18 @@ module Tables = struct let x = # 191 "" ( x ) -# 29498 "src/ocaml/preprocess/parser_raw.ml" +# 29561 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 29503 "src/ocaml/preprocess/parser_raw.ml" +# 29566 "src/ocaml/preprocess/parser_raw.ml" in -# 2815 "src/ocaml/preprocess/parser_raw.mly" +# 2835 "src/ocaml/preprocess/parser_raw.mly" ( eo, fields ) -# 29509 "src/ocaml/preprocess/parser_raw.ml" +# 29572 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29530,17 +29593,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3267 "src/ocaml/preprocess/parser_raw.mly" +# 3287 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29539 "src/ocaml/preprocess/parser_raw.ml" +# 29602 "src/ocaml/preprocess/parser_raw.ml" in -# 1206 "src/ocaml/preprocess/parser_raw.mly" +# 1208 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29544 "src/ocaml/preprocess/parser_raw.ml" +# 29607 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29565,17 +29628,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3267 "src/ocaml/preprocess/parser_raw.mly" +# 3287 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29574 "src/ocaml/preprocess/parser_raw.ml" +# 29637 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1211 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29579 "src/ocaml/preprocess/parser_raw.ml" +# 29642 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29607,17 +29670,17 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3267 "src/ocaml/preprocess/parser_raw.mly" +# 3287 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29616 "src/ocaml/preprocess/parser_raw.ml" +# 29679 "src/ocaml/preprocess/parser_raw.ml" in -# 1213 "src/ocaml/preprocess/parser_raw.mly" +# 1215 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29621 "src/ocaml/preprocess/parser_raw.ml" +# 29684 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29643,23 +29706,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3384 "src/ocaml/preprocess/parser_raw.mly" +# 3404 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29652 "src/ocaml/preprocess/parser_raw.ml" +# 29715 "src/ocaml/preprocess/parser_raw.ml" in -# 3378 "src/ocaml/preprocess/parser_raw.mly" +# 3398 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29657 "src/ocaml/preprocess/parser_raw.ml" +# 29720 "src/ocaml/preprocess/parser_raw.ml" in -# 1206 "src/ocaml/preprocess/parser_raw.mly" +# 1208 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29663 "src/ocaml/preprocess/parser_raw.ml" +# 29726 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29682,14 +29745,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3380 "src/ocaml/preprocess/parser_raw.mly" +# 3400 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29688 "src/ocaml/preprocess/parser_raw.ml" +# 29751 "src/ocaml/preprocess/parser_raw.ml" in -# 1206 "src/ocaml/preprocess/parser_raw.mly" +# 1208 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29693 "src/ocaml/preprocess/parser_raw.ml" +# 29756 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29715,23 +29778,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3384 "src/ocaml/preprocess/parser_raw.mly" +# 3404 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29724 "src/ocaml/preprocess/parser_raw.ml" +# 29787 "src/ocaml/preprocess/parser_raw.ml" in -# 3378 "src/ocaml/preprocess/parser_raw.mly" +# 3398 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29729 "src/ocaml/preprocess/parser_raw.ml" +# 29792 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1211 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29735 "src/ocaml/preprocess/parser_raw.ml" +# 29798 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29754,14 +29817,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3380 "src/ocaml/preprocess/parser_raw.mly" +# 3400 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29760 "src/ocaml/preprocess/parser_raw.ml" +# 29823 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1211 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29765 "src/ocaml/preprocess/parser_raw.ml" +# 29828 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29794,23 +29857,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3384 "src/ocaml/preprocess/parser_raw.mly" +# 3404 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29803 "src/ocaml/preprocess/parser_raw.ml" +# 29866 "src/ocaml/preprocess/parser_raw.ml" in -# 3378 "src/ocaml/preprocess/parser_raw.mly" +# 3398 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29808 "src/ocaml/preprocess/parser_raw.ml" +# 29871 "src/ocaml/preprocess/parser_raw.ml" in -# 1213 "src/ocaml/preprocess/parser_raw.mly" +# 1215 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29814 "src/ocaml/preprocess/parser_raw.ml" +# 29877 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29840,14 +29903,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3380 "src/ocaml/preprocess/parser_raw.mly" +# 3400 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29846 "src/ocaml/preprocess/parser_raw.ml" +# 29909 "src/ocaml/preprocess/parser_raw.ml" in -# 1213 "src/ocaml/preprocess/parser_raw.mly" +# 1215 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29851 "src/ocaml/preprocess/parser_raw.ml" +# 29914 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29872,17 +29935,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3384 "src/ocaml/preprocess/parser_raw.mly" +# 3404 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29881 "src/ocaml/preprocess/parser_raw.ml" +# 29944 "src/ocaml/preprocess/parser_raw.ml" in -# 1206 "src/ocaml/preprocess/parser_raw.mly" +# 1208 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29886 "src/ocaml/preprocess/parser_raw.ml" +# 29949 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29907,17 +29970,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3384 "src/ocaml/preprocess/parser_raw.mly" +# 3404 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29916 "src/ocaml/preprocess/parser_raw.ml" +# 29979 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1211 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29921 "src/ocaml/preprocess/parser_raw.ml" +# 29984 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29949,17 +30012,17 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3384 "src/ocaml/preprocess/parser_raw.mly" +# 3404 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29958 "src/ocaml/preprocess/parser_raw.ml" +# 30021 "src/ocaml/preprocess/parser_raw.ml" in -# 1213 "src/ocaml/preprocess/parser_raw.mly" +# 1215 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29963 "src/ocaml/preprocess/parser_raw.ml" +# 30026 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29975,9 +30038,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = -# 1072 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 29981 "src/ocaml/preprocess/parser_raw.ml" +# 30044 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30034,21 +30097,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2228 "src/ocaml/preprocess/parser_raw.mly" +# 2247 "src/ocaml/preprocess/parser_raw.mly" ( _1, _3, make_loc _sloc ) -# 30040 "src/ocaml/preprocess/parser_raw.ml" +# 30103 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 30046 "src/ocaml/preprocess/parser_raw.ml" +# 30109 "src/ocaml/preprocess/parser_raw.ml" in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1076 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30052 "src/ocaml/preprocess/parser_raw.ml" +# 30115 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30071,9 +30134,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1086 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30077 "src/ocaml/preprocess/parser_raw.ml" +# 30140 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30103,9 +30166,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1088 "src/ocaml/preprocess/parser_raw.mly" +# 1090 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30109 "src/ocaml/preprocess/parser_raw.ml" +# 30172 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30128,9 +30191,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Asttypes.arg_label * Parsetree.expression) list) = -# 1086 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30134 "src/ocaml/preprocess/parser_raw.ml" +# 30197 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30160,9 +30223,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Asttypes.arg_label * Parsetree.expression) list) = -# 1088 "src/ocaml/preprocess/parser_raw.mly" +# 1090 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30166 "src/ocaml/preprocess/parser_raw.ml" +# 30229 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30185,9 +30248,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (string list) = -# 1086 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30191 "src/ocaml/preprocess/parser_raw.ml" +# 30254 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30217,9 +30280,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (string list) = -# 1088 "src/ocaml/preprocess/parser_raw.mly" +# 1090 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30223 "src/ocaml/preprocess/parser_raw.ml" +# 30286 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30255,21 +30318,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 30261 "src/ocaml/preprocess/parser_raw.ml" +# 30324 "src/ocaml/preprocess/parser_raw.ml" in -# 3442 "src/ocaml/preprocess/parser_raw.mly" +# 3462 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 30267 "src/ocaml/preprocess/parser_raw.ml" +# 30330 "src/ocaml/preprocess/parser_raw.ml" in -# 1086 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30273 "src/ocaml/preprocess/parser_raw.ml" +# 30336 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30312,21 +30375,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 30318 "src/ocaml/preprocess/parser_raw.ml" +# 30381 "src/ocaml/preprocess/parser_raw.ml" in -# 3442 "src/ocaml/preprocess/parser_raw.mly" +# 3462 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 30324 "src/ocaml/preprocess/parser_raw.ml" +# 30387 "src/ocaml/preprocess/parser_raw.ml" in -# 1088 "src/ocaml/preprocess/parser_raw.mly" +# 1090 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30330 "src/ocaml/preprocess/parser_raw.ml" +# 30393 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30351,12 +30414,12 @@ module Tables = struct let _v : (Parsetree.case list) = let _1 = # 124 "" ( None ) -# 30355 "src/ocaml/preprocess/parser_raw.ml" +# 30418 "src/ocaml/preprocess/parser_raw.ml" in -# 1177 "src/ocaml/preprocess/parser_raw.mly" +# 1179 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30360 "src/ocaml/preprocess/parser_raw.ml" +# 30423 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30390,13 +30453,13 @@ module Tables = struct # 126 "" ( Some x ) -# 30394 "src/ocaml/preprocess/parser_raw.ml" +# 30457 "src/ocaml/preprocess/parser_raw.ml" in -# 1177 "src/ocaml/preprocess/parser_raw.mly" +# 1179 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30400 "src/ocaml/preprocess/parser_raw.ml" +# 30463 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30433,9 +30496,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.case list) = -# 1181 "src/ocaml/preprocess/parser_raw.mly" +# 1183 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30439 "src/ocaml/preprocess/parser_raw.ml" +# 30502 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30459,20 +30522,20 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type list) = let xs = let x = -# 3485 "src/ocaml/preprocess/parser_raw.mly" +# 3505 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30465 "src/ocaml/preprocess/parser_raw.ml" +# 30528 "src/ocaml/preprocess/parser_raw.ml" in -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1114 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30470 "src/ocaml/preprocess/parser_raw.ml" +# 30533 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30476 "src/ocaml/preprocess/parser_raw.ml" +# 30539 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30510,20 +30573,20 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type list) = let xs = let x = -# 3485 "src/ocaml/preprocess/parser_raw.mly" +# 3505 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30516 "src/ocaml/preprocess/parser_raw.ml" +# 30579 "src/ocaml/preprocess/parser_raw.ml" in -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30521 "src/ocaml/preprocess/parser_raw.ml" +# 30584 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30527 "src/ocaml/preprocess/parser_raw.ml" +# 30590 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30546,14 +30609,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.with_constraint list) = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1114 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30552 "src/ocaml/preprocess/parser_raw.ml" +# 30615 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30557 "src/ocaml/preprocess/parser_raw.ml" +# 30620 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30590,14 +30653,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.with_constraint list) = let xs = -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30596 "src/ocaml/preprocess/parser_raw.ml" +# 30659 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30601 "src/ocaml/preprocess/parser_raw.ml" +# 30664 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30620,14 +30683,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.row_field list) = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1114 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30626 "src/ocaml/preprocess/parser_raw.ml" +# 30689 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30631 "src/ocaml/preprocess/parser_raw.ml" +# 30694 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30664,14 +30727,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.row_field list) = let xs = -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30670 "src/ocaml/preprocess/parser_raw.ml" +# 30733 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30675 "src/ocaml/preprocess/parser_raw.ml" +# 30738 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30694,14 +30757,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1114 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30700 "src/ocaml/preprocess/parser_raw.ml" +# 30763 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30705 "src/ocaml/preprocess/parser_raw.ml" +# 30768 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30738,14 +30801,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30744 "src/ocaml/preprocess/parser_raw.ml" +# 30807 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30749 "src/ocaml/preprocess/parser_raw.ml" +# 30812 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30768,14 +30831,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1114 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30774 "src/ocaml/preprocess/parser_raw.ml" +# 30837 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30779 "src/ocaml/preprocess/parser_raw.ml" +# 30842 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30812,14 +30875,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30818 "src/ocaml/preprocess/parser_raw.ml" +# 30881 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30823 "src/ocaml/preprocess/parser_raw.ml" +# 30886 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30842,14 +30905,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1112 "src/ocaml/preprocess/parser_raw.mly" +# 1114 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30848 "src/ocaml/preprocess/parser_raw.ml" +# 30911 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30853 "src/ocaml/preprocess/parser_raw.ml" +# 30916 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30886,14 +30949,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1116 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30892 "src/ocaml/preprocess/parser_raw.ml" +# 30955 "src/ocaml/preprocess/parser_raw.ml" in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1122 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30897 "src/ocaml/preprocess/parser_raw.ml" +# 30960 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30930,9 +30993,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = -# 1143 "src/ocaml/preprocess/parser_raw.mly" +# 1145 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30936 "src/ocaml/preprocess/parser_raw.ml" +# 30999 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30969,9 +31032,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.core_type list) = -# 1147 "src/ocaml/preprocess/parser_raw.mly" +# 1149 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 30975 "src/ocaml/preprocess/parser_raw.ml" +# 31038 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31008,9 +31071,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.expression list) = -# 1143 "src/ocaml/preprocess/parser_raw.mly" +# 1145 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31014 "src/ocaml/preprocess/parser_raw.ml" +# 31077 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31047,9 +31110,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.expression list) = -# 1147 "src/ocaml/preprocess/parser_raw.mly" +# 1149 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31053 "src/ocaml/preprocess/parser_raw.ml" +# 31116 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31086,9 +31149,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = -# 1143 "src/ocaml/preprocess/parser_raw.mly" +# 1145 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31092 "src/ocaml/preprocess/parser_raw.ml" +# 31155 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31125,9 +31188,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.core_type list) = -# 1147 "src/ocaml/preprocess/parser_raw.mly" +# 1149 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31131 "src/ocaml/preprocess/parser_raw.ml" +# 31194 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31150,9 +31213,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.row_field) = -# 3625 "src/ocaml/preprocess/parser_raw.mly" +# 3645 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31156 "src/ocaml/preprocess/parser_raw.ml" +# 31219 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31178,9 +31241,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3627 "src/ocaml/preprocess/parser_raw.mly" +# 3647 "src/ocaml/preprocess/parser_raw.mly" ( Rf.inherit_ ~loc:(make_loc _sloc) _1 ) -# 31184 "src/ocaml/preprocess/parser_raw.ml" +# 31247 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31205,12 +31268,12 @@ module Tables = struct let _v : (Parsetree.expression list) = let _2 = # 124 "" ( None ) -# 31209 "src/ocaml/preprocess/parser_raw.ml" +# 31272 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31214 "src/ocaml/preprocess/parser_raw.ml" +# 31277 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31244,13 +31307,13 @@ module Tables = struct # 126 "" ( Some x ) -# 31248 "src/ocaml/preprocess/parser_raw.ml" +# 31311 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31254 "src/ocaml/preprocess/parser_raw.ml" +# 31317 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31287,9 +31350,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.expression list) = -# 1168 "src/ocaml/preprocess/parser_raw.mly" +# 1170 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31293 "src/ocaml/preprocess/parser_raw.ml" +# 31356 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31315,9 +31378,9 @@ module Tables = struct } = _menhir_stack in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31321 "src/ocaml/preprocess/parser_raw.ml" +# 31384 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31325,26 +31388,26 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 31329 "src/ocaml/preprocess/parser_raw.ml" +# 31392 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31336 "src/ocaml/preprocess/parser_raw.ml" +# 31399 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31344 "src/ocaml/preprocess/parser_raw.ml" +# 31407 "src/ocaml/preprocess/parser_raw.ml" in -# 2838 "src/ocaml/preprocess/parser_raw.mly" +# 2858 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31354,13 +31417,13 @@ module Tables = struct label, e in label, e ) -# 31358 "src/ocaml/preprocess/parser_raw.ml" +# 31421 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31364 "src/ocaml/preprocess/parser_raw.ml" +# 31427 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31393,9 +31456,9 @@ module Tables = struct let x : unit = Obj.magic x in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31399 "src/ocaml/preprocess/parser_raw.ml" +# 31462 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31403,26 +31466,26 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 31407 "src/ocaml/preprocess/parser_raw.ml" +# 31470 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31414 "src/ocaml/preprocess/parser_raw.ml" +# 31477 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31422 "src/ocaml/preprocess/parser_raw.ml" +# 31485 "src/ocaml/preprocess/parser_raw.ml" in -# 2838 "src/ocaml/preprocess/parser_raw.mly" +# 2858 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31432,13 +31495,13 @@ module Tables = struct label, e in label, e ) -# 31436 "src/ocaml/preprocess/parser_raw.ml" +# 31499 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31442 "src/ocaml/preprocess/parser_raw.ml" +# 31505 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31478,9 +31541,9 @@ module Tables = struct let _2 : unit = Obj.magic _2 in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31484 "src/ocaml/preprocess/parser_raw.ml" +# 31547 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31488,21 +31551,21 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let x = let label = let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31494 "src/ocaml/preprocess/parser_raw.ml" +# 31557 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31502 "src/ocaml/preprocess/parser_raw.ml" +# 31565 "src/ocaml/preprocess/parser_raw.ml" in -# 2838 "src/ocaml/preprocess/parser_raw.mly" +# 2858 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31512,13 +31575,13 @@ module Tables = struct label, e in label, e ) -# 31516 "src/ocaml/preprocess/parser_raw.ml" +# 31579 "src/ocaml/preprocess/parser_raw.ml" in -# 1168 "src/ocaml/preprocess/parser_raw.mly" +# 1170 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31522 "src/ocaml/preprocess/parser_raw.ml" +# 31585 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31543,12 +31606,12 @@ module Tables = struct let _v : (Parsetree.pattern list) = let _2 = # 124 "" ( None ) -# 31547 "src/ocaml/preprocess/parser_raw.ml" +# 31610 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31552 "src/ocaml/preprocess/parser_raw.ml" +# 31615 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31582,13 +31645,13 @@ module Tables = struct # 126 "" ( Some x ) -# 31586 "src/ocaml/preprocess/parser_raw.ml" +# 31649 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31592 "src/ocaml/preprocess/parser_raw.ml" +# 31655 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31625,9 +31688,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.pattern list) = -# 1168 "src/ocaml/preprocess/parser_raw.mly" +# 1170 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31631 "src/ocaml/preprocess/parser_raw.ml" +# 31694 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31666,7 +31729,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 31670 "src/ocaml/preprocess/parser_raw.ml" +# 31733 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -31674,9 +31737,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31680 "src/ocaml/preprocess/parser_raw.ml" +# 31743 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -31684,7 +31747,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2821 "src/ocaml/preprocess/parser_raw.mly" +# 2841 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -31694,13 +31757,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 31698 "src/ocaml/preprocess/parser_raw.ml" +# 31761 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31704 "src/ocaml/preprocess/parser_raw.ml" +# 31767 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31746,7 +31809,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 31750 "src/ocaml/preprocess/parser_raw.ml" +# 31813 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -31754,9 +31817,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31760 "src/ocaml/preprocess/parser_raw.ml" +# 31823 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -31764,7 +31827,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2821 "src/ocaml/preprocess/parser_raw.mly" +# 2841 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -31774,13 +31837,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 31778 "src/ocaml/preprocess/parser_raw.ml" +# 31841 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31784 "src/ocaml/preprocess/parser_raw.ml" +# 31847 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31836,9 +31899,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31842 "src/ocaml/preprocess/parser_raw.ml" +# 31905 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -31846,7 +31909,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2821 "src/ocaml/preprocess/parser_raw.mly" +# 2841 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -31856,13 +31919,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 31860 "src/ocaml/preprocess/parser_raw.ml" +# 31923 "src/ocaml/preprocess/parser_raw.ml" in -# 1168 "src/ocaml/preprocess/parser_raw.mly" +# 1170 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31866 "src/ocaml/preprocess/parser_raw.ml" +# 31929 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31885,9 +31948,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2317 "src/ocaml/preprocess/parser_raw.mly" +# 2336 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31891 "src/ocaml/preprocess/parser_raw.ml" +# 31954 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31917,9 +31980,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2318 "src/ocaml/preprocess/parser_raw.mly" +# 2337 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31923 "src/ocaml/preprocess/parser_raw.ml" +# 31986 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31957,24 +32020,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2320 "src/ocaml/preprocess/parser_raw.mly" +# 2339 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_sequence(_1, _3) ) -# 31963 "src/ocaml/preprocess/parser_raw.ml" +# 32026 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 31972 "src/ocaml/preprocess/parser_raw.ml" +# 32035 "src/ocaml/preprocess/parser_raw.ml" in -# 2321 "src/ocaml/preprocess/parser_raw.mly" +# 2340 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31978 "src/ocaml/preprocess/parser_raw.ml" +# 32041 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32028,11 +32091,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2323 "src/ocaml/preprocess/parser_raw.mly" +# 2342 "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)) ) -# 32036 "src/ocaml/preprocess/parser_raw.ml" +# 32099 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32100,18 +32163,18 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = let attrs = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32106 "src/ocaml/preprocess/parser_raw.ml" +# 32169 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined4_ in let attrs2 = let _1 = _1_inlined3 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32115 "src/ocaml/preprocess/parser_raw.ml" +# 32178 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -32121,17 +32184,17 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32127 "src/ocaml/preprocess/parser_raw.ml" +# 32190 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32135 "src/ocaml/preprocess/parser_raw.ml" +# 32198 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in @@ -32139,14 +32202,14 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3297 "src/ocaml/preprocess/parser_raw.mly" +# 3317 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let loc = make_loc (_startpos, _endpos_attrs2_) in let docs = symbol_docs _sloc in Te.mk_exception ~attrs (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) , ext ) -# 32150 "src/ocaml/preprocess/parser_raw.ml" +# 32213 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32172,21 +32235,21 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 32176 "src/ocaml/preprocess/parser_raw.ml" +# 32239 "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 -# 987 "src/ocaml/preprocess/parser_raw.mly" +# 989 "src/ocaml/preprocess/parser_raw.mly" ( extra_sig _startpos _endpos _1 ) -# 32184 "src/ocaml/preprocess/parser_raw.ml" +# 32247 "src/ocaml/preprocess/parser_raw.ml" in -# 1756 "src/ocaml/preprocess/parser_raw.mly" +# 1771 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32190 "src/ocaml/preprocess/parser_raw.ml" +# 32253 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32218,9 +32281,9 @@ module Tables = struct let _v : (Parsetree.signature_item) = let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32224 "src/ocaml/preprocess/parser_raw.ml" +# 32287 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -32228,10 +32291,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1771 "src/ocaml/preprocess/parser_raw.mly" +# 1786 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mksig ~loc:_sloc (Psig_extension (_1, (add_docs_attrs docs _2))) ) -# 32235 "src/ocaml/preprocess/parser_raw.ml" +# 32298 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32255,23 +32318,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1775 "src/ocaml/preprocess/parser_raw.mly" +# 1790 "src/ocaml/preprocess/parser_raw.mly" ( Psig_attribute _1 ) -# 32261 "src/ocaml/preprocess/parser_raw.ml" +# 32324 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1035 "src/ocaml/preprocess/parser_raw.mly" +# 1037 "src/ocaml/preprocess/parser_raw.mly" ( mksig ~loc:_sloc _1 ) -# 32269 "src/ocaml/preprocess/parser_raw.ml" +# 32332 "src/ocaml/preprocess/parser_raw.ml" in -# 1777 "src/ocaml/preprocess/parser_raw.mly" +# 1792 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32275 "src/ocaml/preprocess/parser_raw.ml" +# 32338 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32295,23 +32358,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1780 "src/ocaml/preprocess/parser_raw.mly" +# 1795 "src/ocaml/preprocess/parser_raw.mly" ( psig_value _1 ) -# 32301 "src/ocaml/preprocess/parser_raw.ml" +# 32364 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32309 "src/ocaml/preprocess/parser_raw.ml" +# 32372 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32315 "src/ocaml/preprocess/parser_raw.ml" +# 32378 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32335,23 +32398,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1782 "src/ocaml/preprocess/parser_raw.mly" +# 1797 "src/ocaml/preprocess/parser_raw.mly" ( psig_value _1 ) -# 32341 "src/ocaml/preprocess/parser_raw.ml" +# 32404 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32349 "src/ocaml/preprocess/parser_raw.ml" +# 32412 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32355 "src/ocaml/preprocess/parser_raw.ml" +# 32418 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32386,26 +32449,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1225 "src/ocaml/preprocess/parser_raw.mly" +# 1227 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 32392 "src/ocaml/preprocess/parser_raw.ml" +# 32455 "src/ocaml/preprocess/parser_raw.ml" in -# 3116 "src/ocaml/preprocess/parser_raw.mly" +# 3136 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32397 "src/ocaml/preprocess/parser_raw.ml" +# 32460 "src/ocaml/preprocess/parser_raw.ml" in -# 3099 "src/ocaml/preprocess/parser_raw.mly" +# 3119 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32403 "src/ocaml/preprocess/parser_raw.ml" +# 32466 "src/ocaml/preprocess/parser_raw.ml" in -# 1784 "src/ocaml/preprocess/parser_raw.mly" +# 1799 "src/ocaml/preprocess/parser_raw.mly" ( psig_type _1 ) -# 32409 "src/ocaml/preprocess/parser_raw.ml" +# 32472 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -32413,15 +32476,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32419 "src/ocaml/preprocess/parser_raw.ml" +# 32482 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32425 "src/ocaml/preprocess/parser_raw.ml" +# 32488 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32456,26 +32519,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1225 "src/ocaml/preprocess/parser_raw.mly" +# 1227 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 32462 "src/ocaml/preprocess/parser_raw.ml" +# 32525 "src/ocaml/preprocess/parser_raw.ml" in -# 3116 "src/ocaml/preprocess/parser_raw.mly" +# 3136 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32467 "src/ocaml/preprocess/parser_raw.ml" +# 32530 "src/ocaml/preprocess/parser_raw.ml" in -# 3104 "src/ocaml/preprocess/parser_raw.mly" +# 3124 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32473 "src/ocaml/preprocess/parser_raw.ml" +# 32536 "src/ocaml/preprocess/parser_raw.ml" in -# 1786 "src/ocaml/preprocess/parser_raw.mly" +# 1801 "src/ocaml/preprocess/parser_raw.mly" ( psig_typesubst _1 ) -# 32479 "src/ocaml/preprocess/parser_raw.ml" +# 32542 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -32483,15 +32546,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32489 "src/ocaml/preprocess/parser_raw.ml" +# 32552 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32495 "src/ocaml/preprocess/parser_raw.ml" +# 32558 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32576,16 +32639,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32582 "src/ocaml/preprocess/parser_raw.ml" +# 32645 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1219 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 32589 "src/ocaml/preprocess/parser_raw.ml" +# 32652 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -32593,46 +32656,46 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32599 "src/ocaml/preprocess/parser_raw.ml" +# 32662 "src/ocaml/preprocess/parser_raw.ml" in let _4 = -# 3876 "src/ocaml/preprocess/parser_raw.mly" +# 3896 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 32605 "src/ocaml/preprocess/parser_raw.ml" +# 32668 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32612 "src/ocaml/preprocess/parser_raw.ml" +# 32675 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3371 "src/ocaml/preprocess/parser_raw.mly" +# 3391 "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 ) -# 32624 "src/ocaml/preprocess/parser_raw.ml" +# 32687 "src/ocaml/preprocess/parser_raw.ml" in -# 3358 "src/ocaml/preprocess/parser_raw.mly" +# 3378 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32630 "src/ocaml/preprocess/parser_raw.ml" +# 32693 "src/ocaml/preprocess/parser_raw.ml" in -# 1788 "src/ocaml/preprocess/parser_raw.mly" +# 1803 "src/ocaml/preprocess/parser_raw.mly" ( psig_typext _1 ) -# 32636 "src/ocaml/preprocess/parser_raw.ml" +# 32699 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -32640,15 +32703,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32646 "src/ocaml/preprocess/parser_raw.ml" +# 32709 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32652 "src/ocaml/preprocess/parser_raw.ml" +# 32715 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32740,16 +32803,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32746 "src/ocaml/preprocess/parser_raw.ml" +# 32809 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1219 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 32753 "src/ocaml/preprocess/parser_raw.ml" +# 32816 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -32757,9 +32820,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32763 "src/ocaml/preprocess/parser_raw.ml" +# 32826 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -32768,41 +32831,41 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3878 "src/ocaml/preprocess/parser_raw.mly" +# 3898 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 32774 "src/ocaml/preprocess/parser_raw.ml" +# 32837 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32782 "src/ocaml/preprocess/parser_raw.ml" +# 32845 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3371 "src/ocaml/preprocess/parser_raw.mly" +# 3391 "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 ) -# 32794 "src/ocaml/preprocess/parser_raw.ml" +# 32857 "src/ocaml/preprocess/parser_raw.ml" in -# 3358 "src/ocaml/preprocess/parser_raw.mly" +# 3378 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32800 "src/ocaml/preprocess/parser_raw.ml" +# 32863 "src/ocaml/preprocess/parser_raw.ml" in -# 1788 "src/ocaml/preprocess/parser_raw.mly" +# 1803 "src/ocaml/preprocess/parser_raw.mly" ( psig_typext _1 ) -# 32806 "src/ocaml/preprocess/parser_raw.ml" +# 32869 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -32810,15 +32873,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32816 "src/ocaml/preprocess/parser_raw.ml" +# 32879 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32822 "src/ocaml/preprocess/parser_raw.ml" +# 32885 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32842,23 +32905,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1790 "src/ocaml/preprocess/parser_raw.mly" +# 1805 "src/ocaml/preprocess/parser_raw.mly" ( psig_exception _1 ) -# 32848 "src/ocaml/preprocess/parser_raw.ml" +# 32911 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32856 "src/ocaml/preprocess/parser_raw.ml" +# 32919 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32862 "src/ocaml/preprocess/parser_raw.ml" +# 32925 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32921,9 +32984,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32927 "src/ocaml/preprocess/parser_raw.ml" +# 32990 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -32933,37 +32996,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32939 "src/ocaml/preprocess/parser_raw.ml" +# 33002 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32947 "src/ocaml/preprocess/parser_raw.ml" +# 33010 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1821 "src/ocaml/preprocess/parser_raw.mly" +# 1836 "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 ) -# 32961 "src/ocaml/preprocess/parser_raw.ml" +# 33024 "src/ocaml/preprocess/parser_raw.ml" in -# 1792 "src/ocaml/preprocess/parser_raw.mly" +# 1807 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 32967 "src/ocaml/preprocess/parser_raw.ml" +# 33030 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -32971,15 +33034,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32977 "src/ocaml/preprocess/parser_raw.ml" +# 33040 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32983 "src/ocaml/preprocess/parser_raw.ml" +# 33046 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33049,9 +33112,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33055 "src/ocaml/preprocess/parser_raw.ml" +# 33118 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -33062,9 +33125,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33068 "src/ocaml/preprocess/parser_raw.ml" +# 33131 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos_id_, _startpos_id_) = (_endpos__1_, _startpos__1_) in @@ -33072,9 +33135,9 @@ module Tables = struct let _symbolstartpos = _startpos_id_ in let _sloc = (_symbolstartpos, _endpos) in -# 1858 "src/ocaml/preprocess/parser_raw.mly" +# 1877 "src/ocaml/preprocess/parser_raw.mly" ( Mty.alias ~loc:(make_loc _sloc) id ) -# 33078 "src/ocaml/preprocess/parser_raw.ml" +# 33141 "src/ocaml/preprocess/parser_raw.ml" in let name = @@ -33083,37 +33146,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33089 "src/ocaml/preprocess/parser_raw.ml" +# 33152 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33097 "src/ocaml/preprocess/parser_raw.ml" +# 33160 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1849 "src/ocaml/preprocess/parser_raw.mly" +# 1868 "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 ) -# 33111 "src/ocaml/preprocess/parser_raw.ml" +# 33174 "src/ocaml/preprocess/parser_raw.ml" in -# 1794 "src/ocaml/preprocess/parser_raw.mly" +# 1809 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 33117 "src/ocaml/preprocess/parser_raw.ml" +# 33180 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -33121,15 +33184,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33127 "src/ocaml/preprocess/parser_raw.ml" +# 33190 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33133 "src/ocaml/preprocess/parser_raw.ml" +# 33196 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33153,23 +33216,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1796 "src/ocaml/preprocess/parser_raw.mly" +# 1811 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modsubst body, ext) ) -# 33159 "src/ocaml/preprocess/parser_raw.ml" +# 33222 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33167 "src/ocaml/preprocess/parser_raw.ml" +# 33230 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33173 "src/ocaml/preprocess/parser_raw.ml" +# 33236 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33255,9 +33318,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33261 "src/ocaml/preprocess/parser_raw.ml" +# 33324 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -33267,49 +33330,49 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33273 "src/ocaml/preprocess/parser_raw.ml" +# 33336 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33281 "src/ocaml/preprocess/parser_raw.ml" +# 33344 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1894 "src/ocaml/preprocess/parser_raw.mly" +# 1913 "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 ) -# 33295 "src/ocaml/preprocess/parser_raw.ml" +# 33358 "src/ocaml/preprocess/parser_raw.ml" in -# 1225 "src/ocaml/preprocess/parser_raw.mly" +# 1227 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 33301 "src/ocaml/preprocess/parser_raw.ml" +# 33364 "src/ocaml/preprocess/parser_raw.ml" in -# 1883 "src/ocaml/preprocess/parser_raw.mly" +# 1902 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33307 "src/ocaml/preprocess/parser_raw.ml" +# 33370 "src/ocaml/preprocess/parser_raw.ml" in -# 1798 "src/ocaml/preprocess/parser_raw.mly" +# 1813 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_recmodule l, ext) ) -# 33313 "src/ocaml/preprocess/parser_raw.ml" +# 33376 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -33317,15 +33380,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33323 "src/ocaml/preprocess/parser_raw.ml" +# 33386 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33329 "src/ocaml/preprocess/parser_raw.ml" +# 33392 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33349,23 +33412,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1800 "src/ocaml/preprocess/parser_raw.mly" +# 1815 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modtype body, ext) ) -# 33355 "src/ocaml/preprocess/parser_raw.ml" +# 33418 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33363 "src/ocaml/preprocess/parser_raw.ml" +# 33426 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33369 "src/ocaml/preprocess/parser_raw.ml" +# 33432 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33389,23 +33452,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1802 "src/ocaml/preprocess/parser_raw.mly" +# 1817 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modtypesubst body, ext) ) -# 33395 "src/ocaml/preprocess/parser_raw.ml" +# 33458 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33403 "src/ocaml/preprocess/parser_raw.ml" +# 33466 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33409 "src/ocaml/preprocess/parser_raw.ml" +# 33472 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33429,23 +33492,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1804 "src/ocaml/preprocess/parser_raw.mly" +# 1819 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_open body, ext) ) -# 33435 "src/ocaml/preprocess/parser_raw.ml" +# 33498 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33443 "src/ocaml/preprocess/parser_raw.ml" +# 33506 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33449 "src/ocaml/preprocess/parser_raw.ml" +# 33512 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33501,38 +33564,38 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33507 "src/ocaml/preprocess/parser_raw.ml" +# 33570 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33516 "src/ocaml/preprocess/parser_raw.ml" +# 33579 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1644 "src/ocaml/preprocess/parser_raw.mly" +# 1653 "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 ) -# 33530 "src/ocaml/preprocess/parser_raw.ml" +# 33593 "src/ocaml/preprocess/parser_raw.ml" in -# 1806 "src/ocaml/preprocess/parser_raw.mly" +# 1821 "src/ocaml/preprocess/parser_raw.mly" ( psig_include _1 ) -# 33536 "src/ocaml/preprocess/parser_raw.ml" +# 33599 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -33540,15 +33603,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33546 "src/ocaml/preprocess/parser_raw.ml" +# 33609 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33552 "src/ocaml/preprocess/parser_raw.ml" +# 33615 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33625,9 +33688,9 @@ module Tables = struct let cty : (Parsetree.class_type) = Obj.magic cty in let _7 : unit = Obj.magic _7 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 33631 "src/ocaml/preprocess/parser_raw.ml" +# 33694 "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 @@ -33645,9 +33708,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33651 "src/ocaml/preprocess/parser_raw.ml" +# 33714 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -33657,24 +33720,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33663 "src/ocaml/preprocess/parser_raw.ml" +# 33726 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33671 "src/ocaml/preprocess/parser_raw.ml" +# 33734 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2249 "src/ocaml/preprocess/parser_raw.mly" +# 2268 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -33682,25 +33745,25 @@ module Tables = struct ext, Ci.mk id cty ~virt ~params ~attrs ~loc ~docs ) -# 33686 "src/ocaml/preprocess/parser_raw.ml" +# 33749 "src/ocaml/preprocess/parser_raw.ml" in -# 1225 "src/ocaml/preprocess/parser_raw.mly" +# 1227 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 33692 "src/ocaml/preprocess/parser_raw.ml" +# 33755 "src/ocaml/preprocess/parser_raw.ml" in -# 2237 "src/ocaml/preprocess/parser_raw.mly" +# 2256 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33698 "src/ocaml/preprocess/parser_raw.ml" +# 33761 "src/ocaml/preprocess/parser_raw.ml" in -# 1808 "src/ocaml/preprocess/parser_raw.mly" +# 1823 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_class l, ext) ) -# 33704 "src/ocaml/preprocess/parser_raw.ml" +# 33767 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -33708,15 +33771,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33714 "src/ocaml/preprocess/parser_raw.ml" +# 33777 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33720 "src/ocaml/preprocess/parser_raw.ml" +# 33783 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33740,23 +33803,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1810 "src/ocaml/preprocess/parser_raw.mly" +# 1825 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_class_type l, ext) ) -# 33746 "src/ocaml/preprocess/parser_raw.ml" +# 33809 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33754 "src/ocaml/preprocess/parser_raw.ml" +# 33817 "src/ocaml/preprocess/parser_raw.ml" in -# 1812 "src/ocaml/preprocess/parser_raw.mly" +# 1827 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33760 "src/ocaml/preprocess/parser_raw.ml" +# 33823 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33779,9 +33842,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constant) = -# 3701 "src/ocaml/preprocess/parser_raw.mly" +# 3721 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33785 "src/ocaml/preprocess/parser_raw.ml" +# 33848 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33806,18 +33869,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 783 "src/ocaml/preprocess/parser_raw.mly" +# 785 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33812 "src/ocaml/preprocess/parser_raw.ml" +# 33875 "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) = -# 3702 "src/ocaml/preprocess/parser_raw.mly" +# 3722 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _2 in Pconst_integer("-" ^ n, m) ) -# 33821 "src/ocaml/preprocess/parser_raw.ml" +# 33884 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33842,18 +33905,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 762 "src/ocaml/preprocess/parser_raw.mly" +# 764 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33848 "src/ocaml/preprocess/parser_raw.ml" +# 33911 "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) = -# 3703 "src/ocaml/preprocess/parser_raw.mly" +# 3723 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _2 in Pconst_float("-" ^ f, m) ) -# 33857 "src/ocaml/preprocess/parser_raw.ml" +# 33920 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33878,18 +33941,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 783 "src/ocaml/preprocess/parser_raw.mly" +# 785 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33884 "src/ocaml/preprocess/parser_raw.ml" +# 33947 "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) = -# 3704 "src/ocaml/preprocess/parser_raw.mly" +# 3724 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _2 in Pconst_integer (n, m) ) -# 33893 "src/ocaml/preprocess/parser_raw.ml" +# 33956 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33914,18 +33977,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 762 "src/ocaml/preprocess/parser_raw.mly" +# 764 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33920 "src/ocaml/preprocess/parser_raw.ml" +# 33983 "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) = -# 3705 "src/ocaml/preprocess/parser_raw.mly" +# 3725 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _2 in Pconst_float(f, m) ) -# 33929 "src/ocaml/preprocess/parser_raw.ml" +# 33992 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33966,18 +34029,18 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 3028 "src/ocaml/preprocess/parser_raw.mly" +# 3048 "src/ocaml/preprocess/parser_raw.mly" ( let fields, closed = _1 in let closed = match closed with Some () -> Open | None -> Closed in fields, closed ) -# 33974 "src/ocaml/preprocess/parser_raw.ml" +# 34037 "src/ocaml/preprocess/parser_raw.ml" in -# 2999 "src/ocaml/preprocess/parser_raw.mly" +# 3019 "src/ocaml/preprocess/parser_raw.mly" ( let (fields, closed) = _2 in Ppat_record(fields, closed) ) -# 33981 "src/ocaml/preprocess/parser_raw.ml" +# 34044 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -33985,15 +34048,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 33991 "src/ocaml/preprocess/parser_raw.ml" +# 34054 "src/ocaml/preprocess/parser_raw.ml" in -# 3013 "src/ocaml/preprocess/parser_raw.mly" +# 3033 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33997 "src/ocaml/preprocess/parser_raw.ml" +# 34060 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34032,15 +34095,15 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _2 = -# 3022 "src/ocaml/preprocess/parser_raw.mly" +# 3042 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 34038 "src/ocaml/preprocess/parser_raw.ml" +# 34101 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 3004 "src/ocaml/preprocess/parser_raw.mly" +# 3024 "src/ocaml/preprocess/parser_raw.mly" ( fst (mktailpat _loc__3_ _2) ) -# 34044 "src/ocaml/preprocess/parser_raw.ml" +# 34107 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34048,15 +34111,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34054 "src/ocaml/preprocess/parser_raw.ml" +# 34117 "src/ocaml/preprocess/parser_raw.ml" in -# 3013 "src/ocaml/preprocess/parser_raw.mly" +# 3033 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34060 "src/ocaml/preprocess/parser_raw.ml" +# 34123 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34095,14 +34158,14 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _2 = -# 3022 "src/ocaml/preprocess/parser_raw.mly" +# 3042 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 34101 "src/ocaml/preprocess/parser_raw.ml" +# 34164 "src/ocaml/preprocess/parser_raw.ml" in -# 3008 "src/ocaml/preprocess/parser_raw.mly" +# 3028 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_array _2 ) -# 34106 "src/ocaml/preprocess/parser_raw.ml" +# 34169 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34110,15 +34173,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34116 "src/ocaml/preprocess/parser_raw.ml" +# 34179 "src/ocaml/preprocess/parser_raw.ml" in -# 3013 "src/ocaml/preprocess/parser_raw.mly" +# 3033 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34122 "src/ocaml/preprocess/parser_raw.ml" +# 34185 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34149,24 +34212,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3010 "src/ocaml/preprocess/parser_raw.mly" +# 3030 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_array [] ) -# 34155 "src/ocaml/preprocess/parser_raw.ml" +# 34218 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34164 "src/ocaml/preprocess/parser_raw.ml" +# 34227 "src/ocaml/preprocess/parser_raw.ml" in -# 3013 "src/ocaml/preprocess/parser_raw.mly" +# 3033 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34170 "src/ocaml/preprocess/parser_raw.ml" +# 34233 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34205,9 +34268,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in let _startpos = _startpos__1_ in -# 4070 "src/ocaml/preprocess/parser_raw.mly" +# 4090 "src/ocaml/preprocess/parser_raw.mly" ( Fake.Meta.code _startpos _endpos _2 ) -# 34211 "src/ocaml/preprocess/parser_raw.ml" +# 34274 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34239,9 +34302,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _endpos = _endpos__2_ in let _startpos = _startpos__1_ in -# 4072 "src/ocaml/preprocess/parser_raw.mly" +# 4092 "src/ocaml/preprocess/parser_raw.mly" ( Fake.Meta.uncode _startpos _endpos _2 ) -# 34245 "src/ocaml/preprocess/parser_raw.ml" +# 34308 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34281,9 +34344,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2489 "src/ocaml/preprocess/parser_raw.mly" +# 2512 "src/ocaml/preprocess/parser_raw.mly" ( reloc_exp ~loc:_sloc _2 ) -# 34287 "src/ocaml/preprocess/parser_raw.ml" +# 34350 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34330,9 +34393,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2495 "src/ocaml/preprocess/parser_raw.mly" +# 2518 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_constraint ~loc:_sloc _2 _3 ) -# 34336 "src/ocaml/preprocess/parser_raw.ml" +# 34399 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34384,14 +34447,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2496 "src/ocaml/preprocess/parser_raw.mly" +# 2519 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34390 "src/ocaml/preprocess/parser_raw.ml" +# 34453 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2398 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 34395 "src/ocaml/preprocess/parser_raw.ml" +# 34458 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34399,9 +34462,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2497 "src/ocaml/preprocess/parser_raw.mly" +# 2520 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34405 "src/ocaml/preprocess/parser_raw.ml" +# 34468 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34453,14 +34516,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2496 "src/ocaml/preprocess/parser_raw.mly" +# 2519 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34459 "src/ocaml/preprocess/parser_raw.ml" +# 34522 "src/ocaml/preprocess/parser_raw.ml" in -# 2381 "src/ocaml/preprocess/parser_raw.mly" +# 2400 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 34464 "src/ocaml/preprocess/parser_raw.ml" +# 34527 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34468,9 +34531,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2497 "src/ocaml/preprocess/parser_raw.mly" +# 2520 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34474 "src/ocaml/preprocess/parser_raw.ml" +# 34537 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34522,14 +34585,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2496 "src/ocaml/preprocess/parser_raw.mly" +# 2519 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34528 "src/ocaml/preprocess/parser_raw.ml" +# 34591 "src/ocaml/preprocess/parser_raw.ml" in -# 2383 "src/ocaml/preprocess/parser_raw.mly" +# 2402 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 34533 "src/ocaml/preprocess/parser_raw.ml" +# 34596 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34537,9 +34600,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2497 "src/ocaml/preprocess/parser_raw.mly" +# 2520 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34543 "src/ocaml/preprocess/parser_raw.ml" +# 34606 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34585,9 +34648,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34591 "src/ocaml/preprocess/parser_raw.ml" +# 34654 "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 @@ -34595,31 +34658,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2498 "src/ocaml/preprocess/parser_raw.mly" +# 2521 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34601 "src/ocaml/preprocess/parser_raw.ml" +# 34664 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34606 "src/ocaml/preprocess/parser_raw.ml" +# 34669 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 34612 "src/ocaml/preprocess/parser_raw.ml" +# 34675 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34617 "src/ocaml/preprocess/parser_raw.ml" +# 34680 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2398 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 34623 "src/ocaml/preprocess/parser_raw.ml" +# 34686 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34627,9 +34690,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2499 "src/ocaml/preprocess/parser_raw.mly" +# 2522 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34633 "src/ocaml/preprocess/parser_raw.ml" +# 34696 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34687,9 +34750,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34693 "src/ocaml/preprocess/parser_raw.ml" +# 34756 "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 @@ -34699,39 +34762,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2498 "src/ocaml/preprocess/parser_raw.mly" +# 2521 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34705 "src/ocaml/preprocess/parser_raw.ml" +# 34768 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34710 "src/ocaml/preprocess/parser_raw.ml" +# 34773 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 34718 "src/ocaml/preprocess/parser_raw.ml" +# 34781 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 34723 "src/ocaml/preprocess/parser_raw.ml" +# 34786 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34729 "src/ocaml/preprocess/parser_raw.ml" +# 34792 "src/ocaml/preprocess/parser_raw.ml" in -# 2379 "src/ocaml/preprocess/parser_raw.mly" +# 2398 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 34735 "src/ocaml/preprocess/parser_raw.ml" +# 34798 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34739,9 +34802,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2499 "src/ocaml/preprocess/parser_raw.mly" +# 2522 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34745 "src/ocaml/preprocess/parser_raw.ml" +# 34808 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34787,9 +34850,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34793 "src/ocaml/preprocess/parser_raw.ml" +# 34856 "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 @@ -34797,31 +34860,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2498 "src/ocaml/preprocess/parser_raw.mly" +# 2521 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34803 "src/ocaml/preprocess/parser_raw.ml" +# 34866 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34808 "src/ocaml/preprocess/parser_raw.ml" +# 34871 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 34814 "src/ocaml/preprocess/parser_raw.ml" +# 34877 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34819 "src/ocaml/preprocess/parser_raw.ml" +# 34882 "src/ocaml/preprocess/parser_raw.ml" in -# 2381 "src/ocaml/preprocess/parser_raw.mly" +# 2400 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 34825 "src/ocaml/preprocess/parser_raw.ml" +# 34888 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34829,9 +34892,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2499 "src/ocaml/preprocess/parser_raw.mly" +# 2522 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34835 "src/ocaml/preprocess/parser_raw.ml" +# 34898 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34889,9 +34952,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34895 "src/ocaml/preprocess/parser_raw.ml" +# 34958 "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 @@ -34901,39 +34964,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2498 "src/ocaml/preprocess/parser_raw.mly" +# 2521 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34907 "src/ocaml/preprocess/parser_raw.ml" +# 34970 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34912 "src/ocaml/preprocess/parser_raw.ml" +# 34975 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 34920 "src/ocaml/preprocess/parser_raw.ml" +# 34983 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 34925 "src/ocaml/preprocess/parser_raw.ml" +# 34988 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34931 "src/ocaml/preprocess/parser_raw.ml" +# 34994 "src/ocaml/preprocess/parser_raw.ml" in -# 2381 "src/ocaml/preprocess/parser_raw.mly" +# 2400 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 34937 "src/ocaml/preprocess/parser_raw.ml" +# 35000 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34941,9 +35004,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2499 "src/ocaml/preprocess/parser_raw.mly" +# 2522 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34947 "src/ocaml/preprocess/parser_raw.ml" +# 35010 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34989,9 +35052,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34995 "src/ocaml/preprocess/parser_raw.ml" +# 35058 "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 @@ -34999,31 +35062,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2498 "src/ocaml/preprocess/parser_raw.mly" +# 2521 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35005 "src/ocaml/preprocess/parser_raw.ml" +# 35068 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35010 "src/ocaml/preprocess/parser_raw.ml" +# 35073 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 35016 "src/ocaml/preprocess/parser_raw.ml" +# 35079 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35021 "src/ocaml/preprocess/parser_raw.ml" +# 35084 "src/ocaml/preprocess/parser_raw.ml" in -# 2383 "src/ocaml/preprocess/parser_raw.mly" +# 2402 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35027 "src/ocaml/preprocess/parser_raw.ml" +# 35090 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35031,9 +35094,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2499 "src/ocaml/preprocess/parser_raw.mly" +# 2522 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35037 "src/ocaml/preprocess/parser_raw.ml" +# 35100 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35091,9 +35154,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35097 "src/ocaml/preprocess/parser_raw.ml" +# 35160 "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 @@ -35103,39 +35166,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2498 "src/ocaml/preprocess/parser_raw.mly" +# 2521 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35109 "src/ocaml/preprocess/parser_raw.ml" +# 35172 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35114 "src/ocaml/preprocess/parser_raw.ml" +# 35177 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 35122 "src/ocaml/preprocess/parser_raw.ml" +# 35185 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 35127 "src/ocaml/preprocess/parser_raw.ml" +# 35190 "src/ocaml/preprocess/parser_raw.ml" in -# 2395 "src/ocaml/preprocess/parser_raw.mly" +# 2414 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35133 "src/ocaml/preprocess/parser_raw.ml" +# 35196 "src/ocaml/preprocess/parser_raw.ml" in -# 2383 "src/ocaml/preprocess/parser_raw.mly" +# 2402 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35139 "src/ocaml/preprocess/parser_raw.ml" +# 35202 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35143,9 +35206,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2499 "src/ocaml/preprocess/parser_raw.mly" +# 2522 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35149 "src/ocaml/preprocess/parser_raw.ml" +# 35212 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35199,15 +35262,15 @@ module Tables = struct let attrs = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35205 "src/ocaml/preprocess/parser_raw.ml" +# 35268 "src/ocaml/preprocess/parser_raw.ml" in -# 2512 "src/ocaml/preprocess/parser_raw.mly" +# 2535 "src/ocaml/preprocess/parser_raw.mly" ( e.pexp_desc, (ext, attrs @ e.pexp_attributes) ) -# 35211 "src/ocaml/preprocess/parser_raw.ml" +# 35274 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -35215,10 +35278,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2505 "src/ocaml/preprocess/parser_raw.mly" +# 2528 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35222 "src/ocaml/preprocess/parser_raw.ml" +# 35285 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35267,24 +35330,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35273 "src/ocaml/preprocess/parser_raw.ml" +# 35336 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35279 "src/ocaml/preprocess/parser_raw.ml" +# 35342 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2514 "src/ocaml/preprocess/parser_raw.mly" +# 2537 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct (mkloc (Lident "()") (make_loc _sloc), None), _2 ) -# 35288 "src/ocaml/preprocess/parser_raw.ml" +# 35351 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -35292,10 +35355,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2505 "src/ocaml/preprocess/parser_raw.mly" +# 2528 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35299 "src/ocaml/preprocess/parser_raw.ml" +# 35362 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35345,9 +35408,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 35351 "src/ocaml/preprocess/parser_raw.ml" +# 35414 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -35355,21 +35418,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35361 "src/ocaml/preprocess/parser_raw.ml" +# 35424 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35367 "src/ocaml/preprocess/parser_raw.ml" +# 35430 "src/ocaml/preprocess/parser_raw.ml" in -# 2520 "src/ocaml/preprocess/parser_raw.mly" +# 2543 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_new(_3), _2 ) -# 35373 "src/ocaml/preprocess/parser_raw.ml" +# 35436 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -35377,10 +35440,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2505 "src/ocaml/preprocess/parser_raw.mly" +# 2528 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35384 "src/ocaml/preprocess/parser_raw.ml" +# 35447 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35443,21 +35506,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35449 "src/ocaml/preprocess/parser_raw.ml" +# 35512 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35455 "src/ocaml/preprocess/parser_raw.ml" +# 35518 "src/ocaml/preprocess/parser_raw.ml" in -# 2522 "src/ocaml/preprocess/parser_raw.mly" +# 2545 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_pack _4, _3 ) -# 35461 "src/ocaml/preprocess/parser_raw.ml" +# 35524 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -35465,10 +35528,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2505 "src/ocaml/preprocess/parser_raw.mly" +# 2528 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35472 "src/ocaml/preprocess/parser_raw.ml" +# 35535 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35546,11 +35609,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3615 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "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 ) -# 35554 "src/ocaml/preprocess/parser_raw.ml" +# 35617 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -35558,24 +35621,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35564 "src/ocaml/preprocess/parser_raw.ml" +# 35627 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35570 "src/ocaml/preprocess/parser_raw.ml" +# 35633 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2524 "src/ocaml/preprocess/parser_raw.mly" +# 2547 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_constraint (ghexp ~loc:_sloc (Pexp_pack _4), _6), _3 ) -# 35579 "src/ocaml/preprocess/parser_raw.ml" +# 35642 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -35583,10 +35646,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2505 "src/ocaml/preprocess/parser_raw.mly" +# 2528 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35590 "src/ocaml/preprocess/parser_raw.ml" +# 35653 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35651,27 +35714,27 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 35655 "src/ocaml/preprocess/parser_raw.ml" +# 35718 "src/ocaml/preprocess/parser_raw.ml" in -# 2063 "src/ocaml/preprocess/parser_raw.mly" +# 2082 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35660 "src/ocaml/preprocess/parser_raw.ml" +# 35723 "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 -# 988 "src/ocaml/preprocess/parser_raw.mly" +# 990 "src/ocaml/preprocess/parser_raw.mly" ( extra_cstr _startpos _endpos _1 ) -# 35669 "src/ocaml/preprocess/parser_raw.ml" +# 35732 "src/ocaml/preprocess/parser_raw.ml" in -# 2050 "src/ocaml/preprocess/parser_raw.mly" +# 2069 "src/ocaml/preprocess/parser_raw.mly" ( Cstr.mk _1 _2 ) -# 35675 "src/ocaml/preprocess/parser_raw.ml" +# 35738 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -35679,21 +35742,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35685 "src/ocaml/preprocess/parser_raw.ml" +# 35748 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35691 "src/ocaml/preprocess/parser_raw.ml" +# 35754 "src/ocaml/preprocess/parser_raw.ml" in -# 2530 "src/ocaml/preprocess/parser_raw.mly" +# 2553 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_object _3, _2 ) -# 35697 "src/ocaml/preprocess/parser_raw.ml" +# 35760 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -35701,10 +35764,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2505 "src/ocaml/preprocess/parser_raw.mly" +# 2528 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35708 "src/ocaml/preprocess/parser_raw.ml" +# 35771 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35733,30 +35796,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 35739 "src/ocaml/preprocess/parser_raw.ml" +# 35802 "src/ocaml/preprocess/parser_raw.ml" in -# 2538 "src/ocaml/preprocess/parser_raw.mly" +# 2561 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_ident (_1) ) -# 35745 "src/ocaml/preprocess/parser_raw.ml" +# 35808 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35754 "src/ocaml/preprocess/parser_raw.ml" +# 35817 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35760 "src/ocaml/preprocess/parser_raw.ml" +# 35823 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35780,23 +35843,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2540 "src/ocaml/preprocess/parser_raw.mly" +# 2563 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_constant _1 ) -# 35786 "src/ocaml/preprocess/parser_raw.ml" +# 35849 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35794 "src/ocaml/preprocess/parser_raw.ml" +# 35857 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35800 "src/ocaml/preprocess/parser_raw.ml" +# 35863 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35825,30 +35888,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 35831 "src/ocaml/preprocess/parser_raw.ml" +# 35894 "src/ocaml/preprocess/parser_raw.ml" in -# 2542 "src/ocaml/preprocess/parser_raw.mly" +# 2565 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct(_1, None) ) -# 35837 "src/ocaml/preprocess/parser_raw.ml" +# 35900 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35846 "src/ocaml/preprocess/parser_raw.ml" +# 35909 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35852 "src/ocaml/preprocess/parser_raw.ml" +# 35915 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35872,23 +35935,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2544 "src/ocaml/preprocess/parser_raw.mly" +# 2567 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_variant(_1, None) ) -# 35878 "src/ocaml/preprocess/parser_raw.ml" +# 35941 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35886 "src/ocaml/preprocess/parser_raw.ml" +# 35949 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35892 "src/ocaml/preprocess/parser_raw.ml" +# 35955 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35914,9 +35977,9 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 821 "src/ocaml/preprocess/parser_raw.mly" +# 823 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35920 "src/ocaml/preprocess/parser_raw.ml" +# 35983 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -35928,15 +35991,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1021 "src/ocaml/preprocess/parser_raw.mly" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 35934 "src/ocaml/preprocess/parser_raw.ml" +# 35997 "src/ocaml/preprocess/parser_raw.ml" in -# 2546 "src/ocaml/preprocess/parser_raw.mly" +# 2569 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 35940 "src/ocaml/preprocess/parser_raw.ml" +# 36003 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -35944,15 +36007,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35950 "src/ocaml/preprocess/parser_raw.ml" +# 36013 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35956 "src/ocaml/preprocess/parser_raw.ml" +# 36019 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35985,23 +36048,23 @@ module Tables = struct let _1 = let _1 = let _1 = -# 2547 "src/ocaml/preprocess/parser_raw.mly" +# 2570 "src/ocaml/preprocess/parser_raw.mly" ("!") -# 35991 "src/ocaml/preprocess/parser_raw.ml" +# 36054 "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" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 35999 "src/ocaml/preprocess/parser_raw.ml" +# 36062 "src/ocaml/preprocess/parser_raw.ml" in -# 2548 "src/ocaml/preprocess/parser_raw.mly" +# 2571 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 36005 "src/ocaml/preprocess/parser_raw.ml" +# 36068 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -36009,15 +36072,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36015 "src/ocaml/preprocess/parser_raw.ml" +# 36078 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36021 "src/ocaml/preprocess/parser_raw.ml" +# 36084 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36056,14 +36119,14 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2833 "src/ocaml/preprocess/parser_raw.mly" +# 2853 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 36062 "src/ocaml/preprocess/parser_raw.ml" +# 36125 "src/ocaml/preprocess/parser_raw.ml" in -# 2550 "src/ocaml/preprocess/parser_raw.mly" +# 2573 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_override _2 ) -# 36067 "src/ocaml/preprocess/parser_raw.ml" +# 36130 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36071,15 +36134,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36077 "src/ocaml/preprocess/parser_raw.ml" +# 36140 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36083 "src/ocaml/preprocess/parser_raw.ml" +# 36146 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36110,24 +36173,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2556 "src/ocaml/preprocess/parser_raw.mly" +# 2579 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_override [] ) -# 36116 "src/ocaml/preprocess/parser_raw.ml" +# 36179 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36125 "src/ocaml/preprocess/parser_raw.ml" +# 36188 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36131 "src/ocaml/preprocess/parser_raw.ml" +# 36194 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36171,15 +36234,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36177 "src/ocaml/preprocess/parser_raw.ml" +# 36240 "src/ocaml/preprocess/parser_raw.ml" in -# 2558 "src/ocaml/preprocess/parser_raw.mly" +# 2581 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_field(_1, _3) ) -# 36183 "src/ocaml/preprocess/parser_raw.ml" +# 36246 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -36187,15 +36250,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36193 "src/ocaml/preprocess/parser_raw.ml" +# 36256 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36199 "src/ocaml/preprocess/parser_raw.ml" +# 36262 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36253,24 +36316,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36259 "src/ocaml/preprocess/parser_raw.ml" +# 36322 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1712 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36268 "src/ocaml/preprocess/parser_raw.ml" +# 36331 "src/ocaml/preprocess/parser_raw.ml" in -# 2560 "src/ocaml/preprocess/parser_raw.mly" +# 2583 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, _4) ) -# 36274 "src/ocaml/preprocess/parser_raw.ml" +# 36337 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36278,15 +36341,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36284 "src/ocaml/preprocess/parser_raw.ml" +# 36347 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36290 "src/ocaml/preprocess/parser_raw.ml" +# 36353 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36339,9 +36402,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2833 "src/ocaml/preprocess/parser_raw.mly" +# 2853 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 36345 "src/ocaml/preprocess/parser_raw.ml" +# 36408 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -36349,18 +36412,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36355 "src/ocaml/preprocess/parser_raw.ml" +# 36418 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1712 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36364 "src/ocaml/preprocess/parser_raw.ml" +# 36427 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_od_ = _startpos__1_ in @@ -36368,10 +36431,10 @@ module Tables = struct let _symbolstartpos = _startpos_od_ in let _sloc = (_symbolstartpos, _endpos) in -# 2562 "src/ocaml/preprocess/parser_raw.mly" +# 2585 "src/ocaml/preprocess/parser_raw.mly" ( (* TODO: review the location of Pexp_override *) Pexp_open(od, mkexp ~loc:_sloc (Pexp_override _4)) ) -# 36375 "src/ocaml/preprocess/parser_raw.ml" +# 36438 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36379,15 +36442,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36385 "src/ocaml/preprocess/parser_raw.ml" +# 36448 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36391 "src/ocaml/preprocess/parser_raw.ml" +# 36454 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36418,9 +36481,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 36424 "src/ocaml/preprocess/parser_raw.ml" +# 36487 "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 @@ -36432,23 +36495,23 @@ module Tables = struct let _3 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36438 "src/ocaml/preprocess/parser_raw.ml" +# 36501 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36446 "src/ocaml/preprocess/parser_raw.ml" +# 36509 "src/ocaml/preprocess/parser_raw.ml" in -# 2569 "src/ocaml/preprocess/parser_raw.mly" +# 2592 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_send(_1, _3) ) -# 36452 "src/ocaml/preprocess/parser_raw.ml" +# 36515 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -36456,15 +36519,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36462 "src/ocaml/preprocess/parser_raw.ml" +# 36525 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36468 "src/ocaml/preprocess/parser_raw.ml" +# 36531 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36496,9 +36559,9 @@ module Tables = struct } = _menhir_stack in let _3 : (Parsetree.expression) = Obj.magic _3 in let _1_inlined1 : ( -# 832 "src/ocaml/preprocess/parser_raw.mly" +# 834 "src/ocaml/preprocess/parser_raw.mly" (string) -# 36502 "src/ocaml/preprocess/parser_raw.ml" +# 36565 "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 @@ -36512,15 +36575,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1021 "src/ocaml/preprocess/parser_raw.mly" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 36518 "src/ocaml/preprocess/parser_raw.ml" +# 36581 "src/ocaml/preprocess/parser_raw.ml" in -# 2571 "src/ocaml/preprocess/parser_raw.mly" +# 2594 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix _1 _2 _3 ) -# 36524 "src/ocaml/preprocess/parser_raw.ml" +# 36587 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36528,15 +36591,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36534 "src/ocaml/preprocess/parser_raw.ml" +# 36597 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36540 "src/ocaml/preprocess/parser_raw.ml" +# 36603 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36560,23 +36623,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2573 "src/ocaml/preprocess/parser_raw.mly" +# 2596 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_extension _1 ) -# 36566 "src/ocaml/preprocess/parser_raw.ml" +# 36629 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36574 "src/ocaml/preprocess/parser_raw.ml" +# 36637 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36580 "src/ocaml/preprocess/parser_raw.ml" +# 36643 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36604,25 +36667,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2575 "src/ocaml/preprocess/parser_raw.mly" +# 2598 "src/ocaml/preprocess/parser_raw.mly" ( let id = mkrhs Ast_helper.hole_txt _loc in Pexp_extension (id, PStr []) ) -# 36611 "src/ocaml/preprocess/parser_raw.ml" +# 36674 "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" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36620 "src/ocaml/preprocess/parser_raw.ml" +# 36683 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36626 "src/ocaml/preprocess/parser_raw.ml" +# 36689 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36670,18 +36733,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2577 "src/ocaml/preprocess/parser_raw.mly" +# 2600 "src/ocaml/preprocess/parser_raw.mly" (Lident "()") -# 36676 "src/ocaml/preprocess/parser_raw.ml" +# 36739 "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 -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36685 "src/ocaml/preprocess/parser_raw.ml" +# 36748 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -36691,25 +36754,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36697 "src/ocaml/preprocess/parser_raw.ml" +# 36760 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1712 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36706 "src/ocaml/preprocess/parser_raw.ml" +# 36769 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2578 "src/ocaml/preprocess/parser_raw.mly" +# 2601 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:(_loc__3_) (Pexp_construct(_3, None))) ) -# 36713 "src/ocaml/preprocess/parser_raw.ml" +# 36776 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -36717,15 +36780,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36723 "src/ocaml/preprocess/parser_raw.ml" +# 36786 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36729 "src/ocaml/preprocess/parser_raw.ml" +# 36792 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36764,25 +36827,25 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2584 "src/ocaml/preprocess/parser_raw.mly" +# 2607 "src/ocaml/preprocess/parser_raw.mly" ( let (exten, fields) = _2 in Pexp_record(fields, exten) ) -# 36771 "src/ocaml/preprocess/parser_raw.ml" +# 36834 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36780 "src/ocaml/preprocess/parser_raw.ml" +# 36843 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36786 "src/ocaml/preprocess/parser_raw.ml" +# 36849 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36841,27 +36904,27 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36847 "src/ocaml/preprocess/parser_raw.ml" +# 36910 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1712 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36856 "src/ocaml/preprocess/parser_raw.ml" +# 36919 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in -# 2591 "src/ocaml/preprocess/parser_raw.mly" +# 2614 "src/ocaml/preprocess/parser_raw.mly" ( let (exten, fields) = _4 in Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_record(fields, exten))) ) -# 36865 "src/ocaml/preprocess/parser_raw.ml" +# 36928 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36869,15 +36932,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36875 "src/ocaml/preprocess/parser_raw.ml" +# 36938 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36881 "src/ocaml/preprocess/parser_raw.ml" +# 36944 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36916,14 +36979,14 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 36922 "src/ocaml/preprocess/parser_raw.ml" +# 36985 "src/ocaml/preprocess/parser_raw.ml" in -# 2599 "src/ocaml/preprocess/parser_raw.mly" +# 2622 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_array(_2) ) -# 36927 "src/ocaml/preprocess/parser_raw.ml" +# 36990 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36931,15 +36994,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36937 "src/ocaml/preprocess/parser_raw.ml" +# 37000 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36943 "src/ocaml/preprocess/parser_raw.ml" +# 37006 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36970,24 +37033,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2605 "src/ocaml/preprocess/parser_raw.mly" +# 2628 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_array [] ) -# 36976 "src/ocaml/preprocess/parser_raw.ml" +# 37039 "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 -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36985 "src/ocaml/preprocess/parser_raw.ml" +# 37048 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36991 "src/ocaml/preprocess/parser_raw.ml" +# 37054 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37040,9 +37103,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37046 "src/ocaml/preprocess/parser_raw.ml" +# 37109 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -37050,25 +37113,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37056 "src/ocaml/preprocess/parser_raw.ml" +# 37119 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1712 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37065 "src/ocaml/preprocess/parser_raw.ml" +# 37128 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in -# 2607 "src/ocaml/preprocess/parser_raw.mly" +# 2630 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array(_4))) ) -# 37072 "src/ocaml/preprocess/parser_raw.ml" +# 37135 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37076,15 +37139,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37082 "src/ocaml/preprocess/parser_raw.ml" +# 37145 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37088 "src/ocaml/preprocess/parser_raw.ml" +# 37151 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37135,26 +37198,26 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37141 "src/ocaml/preprocess/parser_raw.ml" +# 37204 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1712 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37150 "src/ocaml/preprocess/parser_raw.ml" +# 37213 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in -# 2609 "src/ocaml/preprocess/parser_raw.mly" +# 2632 "src/ocaml/preprocess/parser_raw.mly" ( (* TODO: review the location of Pexp_array *) Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array [])) ) -# 37158 "src/ocaml/preprocess/parser_raw.ml" +# 37221 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -37162,15 +37225,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37168 "src/ocaml/preprocess/parser_raw.ml" +# 37231 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37174 "src/ocaml/preprocess/parser_raw.ml" +# 37237 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37209,15 +37272,15 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37215 "src/ocaml/preprocess/parser_raw.ml" +# 37278 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2617 "src/ocaml/preprocess/parser_raw.mly" +# 2640 "src/ocaml/preprocess/parser_raw.mly" ( fst (mktailexp _loc__3_ _2) ) -# 37221 "src/ocaml/preprocess/parser_raw.ml" +# 37284 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -37225,15 +37288,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37231 "src/ocaml/preprocess/parser_raw.ml" +# 37294 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37237 "src/ocaml/preprocess/parser_raw.ml" +# 37300 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37286,9 +37349,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2850 "src/ocaml/preprocess/parser_raw.mly" +# 2870 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37292 "src/ocaml/preprocess/parser_raw.ml" +# 37355 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -37296,30 +37359,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37302 "src/ocaml/preprocess/parser_raw.ml" +# 37365 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1712 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37311 "src/ocaml/preprocess/parser_raw.ml" +# 37374 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _loc__5_ = (_startpos__5_, _endpos__5_) in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2646 "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) ) -# 37323 "src/ocaml/preprocess/parser_raw.ml" +# 37386 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37327,15 +37390,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37333 "src/ocaml/preprocess/parser_raw.ml" +# 37396 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37339 "src/ocaml/preprocess/parser_raw.ml" +# 37402 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37383,18 +37446,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2628 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" (Lident "[]") -# 37389 "src/ocaml/preprocess/parser_raw.ml" +# 37452 "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 -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37398 "src/ocaml/preprocess/parser_raw.ml" +# 37461 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -37404,25 +37467,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37410 "src/ocaml/preprocess/parser_raw.ml" +# 37473 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1712 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37419 "src/ocaml/preprocess/parser_raw.ml" +# 37482 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2629 "src/ocaml/preprocess/parser_raw.mly" +# 2652 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:_loc__3_ (Pexp_construct(_3, None))) ) -# 37426 "src/ocaml/preprocess/parser_raw.ml" +# 37489 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -37430,15 +37493,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37436 "src/ocaml/preprocess/parser_raw.ml" +# 37499 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37442 "src/ocaml/preprocess/parser_raw.ml" +# 37505 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37531,11 +37594,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3615 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "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 ) -# 37539 "src/ocaml/preprocess/parser_raw.ml" +# 37602 "src/ocaml/preprocess/parser_raw.ml" in let _5 = @@ -37543,15 +37606,15 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37549 "src/ocaml/preprocess/parser_raw.ml" +# 37612 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 37555 "src/ocaml/preprocess/parser_raw.ml" +# 37618 "src/ocaml/preprocess/parser_raw.ml" in let od = @@ -37560,18 +37623,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37566 "src/ocaml/preprocess/parser_raw.ml" +# 37629 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1712 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37575 "src/ocaml/preprocess/parser_raw.ml" +# 37638 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_od_ = _startpos__1_ in @@ -37579,12 +37642,12 @@ module Tables = struct let _symbolstartpos = _startpos_od_ in let _sloc = (_symbolstartpos, _endpos) in -# 2637 "src/ocaml/preprocess/parser_raw.mly" +# 2660 "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) ) -# 37588 "src/ocaml/preprocess/parser_raw.ml" +# 37651 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__9_ in @@ -37592,15 +37655,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1027 "src/ocaml/preprocess/parser_raw.mly" +# 1029 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37598 "src/ocaml/preprocess/parser_raw.ml" +# 37661 "src/ocaml/preprocess/parser_raw.ml" in -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2531 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37604 "src/ocaml/preprocess/parser_raw.ml" +# 37667 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37629,30 +37692,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37635 "src/ocaml/preprocess/parser_raw.ml" +# 37698 "src/ocaml/preprocess/parser_raw.ml" in -# 2933 "src/ocaml/preprocess/parser_raw.mly" +# 2953 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_var (_1) ) -# 37641 "src/ocaml/preprocess/parser_raw.ml" +# 37704 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 37650 "src/ocaml/preprocess/parser_raw.ml" +# 37713 "src/ocaml/preprocess/parser_raw.ml" in -# 2934 "src/ocaml/preprocess/parser_raw.mly" +# 2954 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37656 "src/ocaml/preprocess/parser_raw.ml" +# 37719 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37675,9 +37738,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2935 "src/ocaml/preprocess/parser_raw.mly" +# 2955 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37681 "src/ocaml/preprocess/parser_raw.ml" +# 37744 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37717,9 +37780,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2940 "src/ocaml/preprocess/parser_raw.mly" +# 2960 "src/ocaml/preprocess/parser_raw.mly" ( reloc_pat ~loc:_sloc _2 ) -# 37723 "src/ocaml/preprocess/parser_raw.ml" +# 37786 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37742,9 +37805,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2942 "src/ocaml/preprocess/parser_raw.mly" +# 2962 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37748 "src/ocaml/preprocess/parser_raw.ml" +# 37811 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37807,9 +37870,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37813 "src/ocaml/preprocess/parser_raw.ml" +# 37876 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -37817,24 +37880,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37823 "src/ocaml/preprocess/parser_raw.ml" +# 37886 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 37829 "src/ocaml/preprocess/parser_raw.ml" +# 37892 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2944 "src/ocaml/preprocess/parser_raw.mly" +# 2964 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_unpack _4) _3 ) -# 37838 "src/ocaml/preprocess/parser_raw.ml" +# 37901 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37911,11 +37974,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3615 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "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 ) -# 37919 "src/ocaml/preprocess/parser_raw.ml" +# 37982 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -37924,9 +37987,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37930 "src/ocaml/preprocess/parser_raw.ml" +# 37993 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__4_, _startpos__4_) = (_endpos__1_inlined3_, _startpos__1_inlined3_) in @@ -37935,15 +37998,15 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37941 "src/ocaml/preprocess/parser_raw.ml" +# 38004 "src/ocaml/preprocess/parser_raw.ml" in -# 4048 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 37947 "src/ocaml/preprocess/parser_raw.ml" +# 38010 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in @@ -37951,11 +38014,11 @@ module Tables = struct let _loc__4_ = (_startpos__4_, _endpos__4_) in let _sloc = (_symbolstartpos, _endpos) in -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 2966 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_constraint(mkpat ~loc:_loc__4_ (Ppat_unpack _4), _6)) _3 ) -# 37959 "src/ocaml/preprocess/parser_raw.ml" +# 38022 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37979,23 +38042,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2954 "src/ocaml/preprocess/parser_raw.mly" +# 2974 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_any ) -# 37985 "src/ocaml/preprocess/parser_raw.ml" +# 38048 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 37993 "src/ocaml/preprocess/parser_raw.ml" +# 38056 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37999 "src/ocaml/preprocess/parser_raw.ml" +# 38062 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38019,23 +38082,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2956 "src/ocaml/preprocess/parser_raw.mly" +# 2976 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constant _1 ) -# 38025 "src/ocaml/preprocess/parser_raw.ml" +# 38088 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38033 "src/ocaml/preprocess/parser_raw.ml" +# 38096 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38039 "src/ocaml/preprocess/parser_raw.ml" +# 38102 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38073,24 +38136,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2958 "src/ocaml/preprocess/parser_raw.mly" +# 2978 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_interval (_1, _3) ) -# 38079 "src/ocaml/preprocess/parser_raw.ml" +# 38142 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38088 "src/ocaml/preprocess/parser_raw.ml" +# 38151 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38094 "src/ocaml/preprocess/parser_raw.ml" +# 38157 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38119,30 +38182,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38125 "src/ocaml/preprocess/parser_raw.ml" +# 38188 "src/ocaml/preprocess/parser_raw.ml" in -# 2960 "src/ocaml/preprocess/parser_raw.mly" +# 2980 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(_1, None) ) -# 38131 "src/ocaml/preprocess/parser_raw.ml" +# 38194 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38140 "src/ocaml/preprocess/parser_raw.ml" +# 38203 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38146 "src/ocaml/preprocess/parser_raw.ml" +# 38209 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38166,23 +38229,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2962 "src/ocaml/preprocess/parser_raw.mly" +# 2982 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_variant(_1, None) ) -# 38172 "src/ocaml/preprocess/parser_raw.ml" +# 38235 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38180 "src/ocaml/preprocess/parser_raw.ml" +# 38243 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38186 "src/ocaml/preprocess/parser_raw.ml" +# 38249 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38219,15 +38282,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38225 "src/ocaml/preprocess/parser_raw.ml" +# 38288 "src/ocaml/preprocess/parser_raw.ml" in -# 2964 "src/ocaml/preprocess/parser_raw.mly" +# 2984 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_type (_2) ) -# 38231 "src/ocaml/preprocess/parser_raw.ml" +# 38294 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -38235,15 +38298,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38241 "src/ocaml/preprocess/parser_raw.ml" +# 38304 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38247 "src/ocaml/preprocess/parser_raw.ml" +# 38310 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38286,15 +38349,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38292 "src/ocaml/preprocess/parser_raw.ml" +# 38355 "src/ocaml/preprocess/parser_raw.ml" in -# 2966 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, _3) ) -# 38298 "src/ocaml/preprocess/parser_raw.ml" +# 38361 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -38302,15 +38365,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38308 "src/ocaml/preprocess/parser_raw.ml" +# 38371 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38314 "src/ocaml/preprocess/parser_raw.ml" +# 38377 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38358,18 +38421,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2967 "src/ocaml/preprocess/parser_raw.mly" +# 2987 "src/ocaml/preprocess/parser_raw.mly" (Lident "[]") -# 38364 "src/ocaml/preprocess/parser_raw.ml" +# 38427 "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 -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38373 "src/ocaml/preprocess/parser_raw.ml" +# 38436 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -38378,18 +38441,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38384 "src/ocaml/preprocess/parser_raw.ml" +# 38447 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2968 "src/ocaml/preprocess/parser_raw.mly" +# 2988 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 38393 "src/ocaml/preprocess/parser_raw.ml" +# 38456 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -38397,15 +38460,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38403 "src/ocaml/preprocess/parser_raw.ml" +# 38466 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38409 "src/ocaml/preprocess/parser_raw.ml" +# 38472 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38453,18 +38516,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2969 "src/ocaml/preprocess/parser_raw.mly" +# 2989 "src/ocaml/preprocess/parser_raw.mly" (Lident "()") -# 38459 "src/ocaml/preprocess/parser_raw.ml" +# 38522 "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 -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38468 "src/ocaml/preprocess/parser_raw.ml" +# 38531 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -38473,18 +38536,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38479 "src/ocaml/preprocess/parser_raw.ml" +# 38542 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 2990 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 38488 "src/ocaml/preprocess/parser_raw.ml" +# 38551 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -38492,15 +38555,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38498 "src/ocaml/preprocess/parser_raw.ml" +# 38561 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38504 "src/ocaml/preprocess/parser_raw.ml" +# 38567 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38557,15 +38620,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38563 "src/ocaml/preprocess/parser_raw.ml" +# 38626 "src/ocaml/preprocess/parser_raw.ml" in -# 2972 "src/ocaml/preprocess/parser_raw.mly" +# 2992 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open (_1, _4) ) -# 38569 "src/ocaml/preprocess/parser_raw.ml" +# 38632 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -38573,15 +38636,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38579 "src/ocaml/preprocess/parser_raw.ml" +# 38642 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38585 "src/ocaml/preprocess/parser_raw.ml" +# 38648 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38633,24 +38696,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2982 "src/ocaml/preprocess/parser_raw.mly" +# 3002 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_2, _4) ) -# 38639 "src/ocaml/preprocess/parser_raw.ml" +# 38702 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38648 "src/ocaml/preprocess/parser_raw.ml" +# 38711 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38654 "src/ocaml/preprocess/parser_raw.ml" +# 38717 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38674,23 +38737,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2993 "src/ocaml/preprocess/parser_raw.mly" +# 3013 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_extension _1 ) -# 38680 "src/ocaml/preprocess/parser_raw.ml" +# 38743 "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" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38688 "src/ocaml/preprocess/parser_raw.ml" +# 38751 "src/ocaml/preprocess/parser_raw.ml" in -# 2950 "src/ocaml/preprocess/parser_raw.mly" +# 2970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38694 "src/ocaml/preprocess/parser_raw.ml" +# 38757 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38709,17 +38772,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 38715 "src/ocaml/preprocess/parser_raw.ml" +# 38778 "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) = -# 3956 "src/ocaml/preprocess/parser_raw.mly" +# 3976 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38723 "src/ocaml/preprocess/parser_raw.ml" +# 38786 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38738,17 +38801,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) -# 38744 "src/ocaml/preprocess/parser_raw.ml" +# 38807 "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) = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 3977 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38752 "src/ocaml/preprocess/parser_raw.ml" +# 38815 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38771,9 +38834,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 3978 "src/ocaml/preprocess/parser_raw.mly" ( "and" ) -# 38777 "src/ocaml/preprocess/parser_raw.ml" +# 38840 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38796,9 +38859,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3959 "src/ocaml/preprocess/parser_raw.mly" +# 3979 "src/ocaml/preprocess/parser_raw.mly" ( "as" ) -# 38802 "src/ocaml/preprocess/parser_raw.ml" +# 38865 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38821,9 +38884,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3960 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( "assert" ) -# 38827 "src/ocaml/preprocess/parser_raw.ml" +# 38890 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38846,9 +38909,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3961 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( "begin" ) -# 38852 "src/ocaml/preprocess/parser_raw.ml" +# 38915 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38871,9 +38934,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3962 "src/ocaml/preprocess/parser_raw.mly" +# 3982 "src/ocaml/preprocess/parser_raw.mly" ( "class" ) -# 38877 "src/ocaml/preprocess/parser_raw.ml" +# 38940 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38896,9 +38959,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3963 "src/ocaml/preprocess/parser_raw.mly" +# 3983 "src/ocaml/preprocess/parser_raw.mly" ( "constraint" ) -# 38902 "src/ocaml/preprocess/parser_raw.ml" +# 38965 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38921,9 +38984,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3964 "src/ocaml/preprocess/parser_raw.mly" +# 3984 "src/ocaml/preprocess/parser_raw.mly" ( "do" ) -# 38927 "src/ocaml/preprocess/parser_raw.ml" +# 38990 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38946,9 +39009,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3985 "src/ocaml/preprocess/parser_raw.mly" ( "done" ) -# 38952 "src/ocaml/preprocess/parser_raw.ml" +# 39015 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38971,9 +39034,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3966 "src/ocaml/preprocess/parser_raw.mly" +# 3986 "src/ocaml/preprocess/parser_raw.mly" ( "downto" ) -# 38977 "src/ocaml/preprocess/parser_raw.ml" +# 39040 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38996,9 +39059,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3967 "src/ocaml/preprocess/parser_raw.mly" +# 3987 "src/ocaml/preprocess/parser_raw.mly" ( "else" ) -# 39002 "src/ocaml/preprocess/parser_raw.ml" +# 39065 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39021,9 +39084,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3968 "src/ocaml/preprocess/parser_raw.mly" +# 3988 "src/ocaml/preprocess/parser_raw.mly" ( "end" ) -# 39027 "src/ocaml/preprocess/parser_raw.ml" +# 39090 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39046,9 +39109,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3969 "src/ocaml/preprocess/parser_raw.mly" +# 3989 "src/ocaml/preprocess/parser_raw.mly" ( "exception" ) -# 39052 "src/ocaml/preprocess/parser_raw.ml" +# 39115 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39071,9 +39134,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3970 "src/ocaml/preprocess/parser_raw.mly" +# 3990 "src/ocaml/preprocess/parser_raw.mly" ( "external" ) -# 39077 "src/ocaml/preprocess/parser_raw.ml" +# 39140 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39096,9 +39159,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3971 "src/ocaml/preprocess/parser_raw.mly" +# 3991 "src/ocaml/preprocess/parser_raw.mly" ( "false" ) -# 39102 "src/ocaml/preprocess/parser_raw.ml" +# 39165 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39121,9 +39184,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3972 "src/ocaml/preprocess/parser_raw.mly" +# 3992 "src/ocaml/preprocess/parser_raw.mly" ( "for" ) -# 39127 "src/ocaml/preprocess/parser_raw.ml" +# 39190 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39146,9 +39209,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3973 "src/ocaml/preprocess/parser_raw.mly" +# 3993 "src/ocaml/preprocess/parser_raw.mly" ( "fun" ) -# 39152 "src/ocaml/preprocess/parser_raw.ml" +# 39215 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39171,9 +39234,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3974 "src/ocaml/preprocess/parser_raw.mly" +# 3994 "src/ocaml/preprocess/parser_raw.mly" ( "function" ) -# 39177 "src/ocaml/preprocess/parser_raw.ml" +# 39240 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39196,9 +39259,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3975 "src/ocaml/preprocess/parser_raw.mly" +# 3995 "src/ocaml/preprocess/parser_raw.mly" ( "functor" ) -# 39202 "src/ocaml/preprocess/parser_raw.ml" +# 39265 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39221,9 +39284,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3976 "src/ocaml/preprocess/parser_raw.mly" +# 3996 "src/ocaml/preprocess/parser_raw.mly" ( "if" ) -# 39227 "src/ocaml/preprocess/parser_raw.ml" +# 39290 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39246,9 +39309,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3977 "src/ocaml/preprocess/parser_raw.mly" +# 3997 "src/ocaml/preprocess/parser_raw.mly" ( "in" ) -# 39252 "src/ocaml/preprocess/parser_raw.ml" +# 39315 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39271,9 +39334,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3978 "src/ocaml/preprocess/parser_raw.mly" +# 3998 "src/ocaml/preprocess/parser_raw.mly" ( "include" ) -# 39277 "src/ocaml/preprocess/parser_raw.ml" +# 39340 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39296,9 +39359,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3979 "src/ocaml/preprocess/parser_raw.mly" +# 3999 "src/ocaml/preprocess/parser_raw.mly" ( "inherit" ) -# 39302 "src/ocaml/preprocess/parser_raw.ml" +# 39365 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39321,9 +39384,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3980 "src/ocaml/preprocess/parser_raw.mly" +# 4000 "src/ocaml/preprocess/parser_raw.mly" ( "initializer" ) -# 39327 "src/ocaml/preprocess/parser_raw.ml" +# 39390 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39346,9 +39409,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3981 "src/ocaml/preprocess/parser_raw.mly" +# 4001 "src/ocaml/preprocess/parser_raw.mly" ( "lazy" ) -# 39352 "src/ocaml/preprocess/parser_raw.ml" +# 39415 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39371,9 +39434,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3982 "src/ocaml/preprocess/parser_raw.mly" +# 4002 "src/ocaml/preprocess/parser_raw.mly" ( "let" ) -# 39377 "src/ocaml/preprocess/parser_raw.ml" +# 39440 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39396,9 +39459,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3983 "src/ocaml/preprocess/parser_raw.mly" +# 4003 "src/ocaml/preprocess/parser_raw.mly" ( "match" ) -# 39402 "src/ocaml/preprocess/parser_raw.ml" +# 39465 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39421,9 +39484,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3984 "src/ocaml/preprocess/parser_raw.mly" +# 4004 "src/ocaml/preprocess/parser_raw.mly" ( "method" ) -# 39427 "src/ocaml/preprocess/parser_raw.ml" +# 39490 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39446,9 +39509,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3985 "src/ocaml/preprocess/parser_raw.mly" +# 4005 "src/ocaml/preprocess/parser_raw.mly" ( "module" ) -# 39452 "src/ocaml/preprocess/parser_raw.ml" +# 39515 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39471,9 +39534,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3986 "src/ocaml/preprocess/parser_raw.mly" +# 4006 "src/ocaml/preprocess/parser_raw.mly" ( "mutable" ) -# 39477 "src/ocaml/preprocess/parser_raw.ml" +# 39540 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39496,9 +39559,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3987 "src/ocaml/preprocess/parser_raw.mly" +# 4007 "src/ocaml/preprocess/parser_raw.mly" ( "new" ) -# 39502 "src/ocaml/preprocess/parser_raw.ml" +# 39565 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39521,9 +39584,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3988 "src/ocaml/preprocess/parser_raw.mly" +# 4008 "src/ocaml/preprocess/parser_raw.mly" ( "nonrec" ) -# 39527 "src/ocaml/preprocess/parser_raw.ml" +# 39590 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39546,9 +39609,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3989 "src/ocaml/preprocess/parser_raw.mly" +# 4009 "src/ocaml/preprocess/parser_raw.mly" ( "object" ) -# 39552 "src/ocaml/preprocess/parser_raw.ml" +# 39615 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39571,9 +39634,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3990 "src/ocaml/preprocess/parser_raw.mly" +# 4010 "src/ocaml/preprocess/parser_raw.mly" ( "of" ) -# 39577 "src/ocaml/preprocess/parser_raw.ml" +# 39640 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39596,9 +39659,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3991 "src/ocaml/preprocess/parser_raw.mly" +# 4011 "src/ocaml/preprocess/parser_raw.mly" ( "open" ) -# 39602 "src/ocaml/preprocess/parser_raw.ml" +# 39665 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39621,9 +39684,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3992 "src/ocaml/preprocess/parser_raw.mly" +# 4012 "src/ocaml/preprocess/parser_raw.mly" ( "or" ) -# 39627 "src/ocaml/preprocess/parser_raw.ml" +# 39690 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39646,9 +39709,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3993 "src/ocaml/preprocess/parser_raw.mly" +# 4013 "src/ocaml/preprocess/parser_raw.mly" ( "private" ) -# 39652 "src/ocaml/preprocess/parser_raw.ml" +# 39715 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39671,9 +39734,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3994 "src/ocaml/preprocess/parser_raw.mly" +# 4014 "src/ocaml/preprocess/parser_raw.mly" ( "rec" ) -# 39677 "src/ocaml/preprocess/parser_raw.ml" +# 39740 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39696,9 +39759,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3995 "src/ocaml/preprocess/parser_raw.mly" +# 4015 "src/ocaml/preprocess/parser_raw.mly" ( "sig" ) -# 39702 "src/ocaml/preprocess/parser_raw.ml" +# 39765 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39721,9 +39784,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3996 "src/ocaml/preprocess/parser_raw.mly" +# 4016 "src/ocaml/preprocess/parser_raw.mly" ( "struct" ) -# 39727 "src/ocaml/preprocess/parser_raw.ml" +# 39790 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39746,9 +39809,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3997 "src/ocaml/preprocess/parser_raw.mly" +# 4017 "src/ocaml/preprocess/parser_raw.mly" ( "then" ) -# 39752 "src/ocaml/preprocess/parser_raw.ml" +# 39815 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39771,9 +39834,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3998 "src/ocaml/preprocess/parser_raw.mly" +# 4018 "src/ocaml/preprocess/parser_raw.mly" ( "to" ) -# 39777 "src/ocaml/preprocess/parser_raw.ml" +# 39840 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39796,9 +39859,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3999 "src/ocaml/preprocess/parser_raw.mly" +# 4019 "src/ocaml/preprocess/parser_raw.mly" ( "true" ) -# 39802 "src/ocaml/preprocess/parser_raw.ml" +# 39865 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39821,9 +39884,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4000 "src/ocaml/preprocess/parser_raw.mly" +# 4020 "src/ocaml/preprocess/parser_raw.mly" ( "try" ) -# 39827 "src/ocaml/preprocess/parser_raw.ml" +# 39890 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39846,9 +39909,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4001 "src/ocaml/preprocess/parser_raw.mly" +# 4021 "src/ocaml/preprocess/parser_raw.mly" ( "type" ) -# 39852 "src/ocaml/preprocess/parser_raw.ml" +# 39915 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39871,9 +39934,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4002 "src/ocaml/preprocess/parser_raw.mly" +# 4022 "src/ocaml/preprocess/parser_raw.mly" ( "val" ) -# 39877 "src/ocaml/preprocess/parser_raw.ml" +# 39940 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39896,9 +39959,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4003 "src/ocaml/preprocess/parser_raw.mly" +# 4023 "src/ocaml/preprocess/parser_raw.mly" ( "virtual" ) -# 39902 "src/ocaml/preprocess/parser_raw.ml" +# 39965 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39921,9 +39984,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4004 "src/ocaml/preprocess/parser_raw.mly" +# 4024 "src/ocaml/preprocess/parser_raw.mly" ( "when" ) -# 39927 "src/ocaml/preprocess/parser_raw.ml" +# 39990 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39946,9 +40009,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4005 "src/ocaml/preprocess/parser_raw.mly" +# 4025 "src/ocaml/preprocess/parser_raw.mly" ( "while" ) -# 39952 "src/ocaml/preprocess/parser_raw.ml" +# 40015 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39971,9 +40034,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4006 "src/ocaml/preprocess/parser_raw.mly" +# 4026 "src/ocaml/preprocess/parser_raw.mly" ( "with" ) -# 39977 "src/ocaml/preprocess/parser_raw.ml" +# 40040 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39996,9 +40059,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.type_exception * string Location.loc option) = -# 3274 "src/ocaml/preprocess/parser_raw.mly" +# 3294 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40002 "src/ocaml/preprocess/parser_raw.ml" +# 40065 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40072,18 +40135,18 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = let attrs = let _1 = _1_inlined5 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40078 "src/ocaml/preprocess/parser_raw.ml" +# 40141 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined5_ in let attrs2 = let _1 = _1_inlined4 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40087 "src/ocaml/preprocess/parser_raw.ml" +# 40150 "src/ocaml/preprocess/parser_raw.ml" in let lid = @@ -40092,9 +40155,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40098 "src/ocaml/preprocess/parser_raw.ml" +# 40161 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -40103,30 +40166,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40109 "src/ocaml/preprocess/parser_raw.ml" +# 40172 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40117 "src/ocaml/preprocess/parser_raw.ml" +# 40180 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3283 "src/ocaml/preprocess/parser_raw.mly" +# 3303 "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 ) -# 40130 "src/ocaml/preprocess/parser_raw.ml" +# 40193 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40156,9 +40219,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2774 "src/ocaml/preprocess/parser_raw.mly" +# 2794 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 40162 "src/ocaml/preprocess/parser_raw.ml" +# 40225 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40191,9 +40254,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2776 "src/ocaml/preprocess/parser_raw.mly" +# 2796 "src/ocaml/preprocess/parser_raw.mly" ( let (l, o, p) = _1 in ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) ) -# 40197 "src/ocaml/preprocess/parser_raw.ml" +# 40260 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40244,17 +40307,17 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _3 = -# 2666 "src/ocaml/preprocess/parser_raw.mly" +# 2689 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 40250 "src/ocaml/preprocess/parser_raw.ml" +# 40313 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2778 "src/ocaml/preprocess/parser_raw.mly" +# 2798 "src/ocaml/preprocess/parser_raw.mly" ( mk_newtypes ~loc:_sloc _3 _5 ) -# 40258 "src/ocaml/preprocess/parser_raw.ml" +# 40321 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40281,39 +40344,39 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 40285 "src/ocaml/preprocess/parser_raw.ml" +# 40348 "src/ocaml/preprocess/parser_raw.ml" in let xs = let items = -# 1064 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 40291 "src/ocaml/preprocess/parser_raw.ml" +# 40354 "src/ocaml/preprocess/parser_raw.ml" in -# 1506 "src/ocaml/preprocess/parser_raw.mly" +# 1511 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 40296 "src/ocaml/preprocess/parser_raw.ml" +# 40359 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 40302 "src/ocaml/preprocess/parser_raw.ml" +# 40365 "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 -# 986 "src/ocaml/preprocess/parser_raw.mly" +# 988 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 40311 "src/ocaml/preprocess/parser_raw.ml" +# 40374 "src/ocaml/preprocess/parser_raw.ml" in -# 1499 "src/ocaml/preprocess/parser_raw.mly" +# 1504 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40317 "src/ocaml/preprocess/parser_raw.ml" +# 40380 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40354,7 +40417,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 40358 "src/ocaml/preprocess/parser_raw.ml" +# 40421 "src/ocaml/preprocess/parser_raw.ml" in let xs = let items = @@ -40362,65 +40425,65 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40368 "src/ocaml/preprocess/parser_raw.ml" +# 40431 "src/ocaml/preprocess/parser_raw.ml" in -# 1513 "src/ocaml/preprocess/parser_raw.mly" +# 1518 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 40373 "src/ocaml/preprocess/parser_raw.ml" +# 40436 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 998 "src/ocaml/preprocess/parser_raw.mly" +# 1000 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 40381 "src/ocaml/preprocess/parser_raw.ml" +# 40444 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1017 "src/ocaml/preprocess/parser_raw.mly" +# 1019 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 40391 "src/ocaml/preprocess/parser_raw.ml" +# 40454 "src/ocaml/preprocess/parser_raw.ml" in -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1068 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 40397 "src/ocaml/preprocess/parser_raw.ml" +# 40460 "src/ocaml/preprocess/parser_raw.ml" in -# 1506 "src/ocaml/preprocess/parser_raw.mly" +# 1511 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 40403 "src/ocaml/preprocess/parser_raw.ml" +# 40466 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 40409 "src/ocaml/preprocess/parser_raw.ml" +# 40472 "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 -# 986 "src/ocaml/preprocess/parser_raw.mly" +# 988 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 40418 "src/ocaml/preprocess/parser_raw.ml" +# 40481 "src/ocaml/preprocess/parser_raw.ml" in -# 1499 "src/ocaml/preprocess/parser_raw.mly" +# 1504 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40424 "src/ocaml/preprocess/parser_raw.ml" +# 40487 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40446,9 +40509,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4078 "src/ocaml/preprocess/parser_raw.mly" +# 4098 "src/ocaml/preprocess/parser_raw.mly" ( val_of_lwt_bindings ~loc:_loc _1 ) -# 40452 "src/ocaml/preprocess/parser_raw.ml" +# 40515 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40474,9 +40537,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1528 "src/ocaml/preprocess/parser_raw.mly" +# 1533 "src/ocaml/preprocess/parser_raw.mly" ( val_of_let_bindings ~loc:_sloc _1 ) -# 40480 "src/ocaml/preprocess/parser_raw.ml" +# 40543 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40510,9 +40573,9 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40516 "src/ocaml/preprocess/parser_raw.ml" +# 40579 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -40520,10 +40583,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1531 "src/ocaml/preprocess/parser_raw.mly" +# 1536 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in Pstr_extension (_1, add_docs_attrs docs _2) ) -# 40527 "src/ocaml/preprocess/parser_raw.ml" +# 40590 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -40531,15 +40594,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1035 "src/ocaml/preprocess/parser_raw.mly" ( mkstr ~loc:_sloc _1 ) -# 40537 "src/ocaml/preprocess/parser_raw.ml" +# 40600 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40543 "src/ocaml/preprocess/parser_raw.ml" +# 40606 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40563,23 +40626,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1534 "src/ocaml/preprocess/parser_raw.mly" +# 1539 "src/ocaml/preprocess/parser_raw.mly" ( Pstr_attribute _1 ) -# 40569 "src/ocaml/preprocess/parser_raw.ml" +# 40632 "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" +# 1035 "src/ocaml/preprocess/parser_raw.mly" ( mkstr ~loc:_sloc _1 ) -# 40577 "src/ocaml/preprocess/parser_raw.ml" +# 40640 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40583 "src/ocaml/preprocess/parser_raw.ml" +# 40646 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40603,23 +40666,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1538 "src/ocaml/preprocess/parser_raw.mly" +# 1543 "src/ocaml/preprocess/parser_raw.mly" ( pstr_primitive _1 ) -# 40609 "src/ocaml/preprocess/parser_raw.ml" +# 40672 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40617 "src/ocaml/preprocess/parser_raw.ml" +# 40680 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40623 "src/ocaml/preprocess/parser_raw.ml" +# 40686 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40643,23 +40706,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1540 "src/ocaml/preprocess/parser_raw.mly" +# 1545 "src/ocaml/preprocess/parser_raw.mly" ( pstr_primitive _1 ) -# 40649 "src/ocaml/preprocess/parser_raw.ml" +# 40712 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40657 "src/ocaml/preprocess/parser_raw.ml" +# 40720 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40663 "src/ocaml/preprocess/parser_raw.ml" +# 40726 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40694,26 +40757,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1225 "src/ocaml/preprocess/parser_raw.mly" +# 1227 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 40700 "src/ocaml/preprocess/parser_raw.ml" +# 40763 "src/ocaml/preprocess/parser_raw.ml" in -# 3116 "src/ocaml/preprocess/parser_raw.mly" +# 3136 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40705 "src/ocaml/preprocess/parser_raw.ml" +# 40768 "src/ocaml/preprocess/parser_raw.ml" in -# 3099 "src/ocaml/preprocess/parser_raw.mly" +# 3119 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40711 "src/ocaml/preprocess/parser_raw.ml" +# 40774 "src/ocaml/preprocess/parser_raw.ml" in -# 1542 "src/ocaml/preprocess/parser_raw.mly" +# 1547 "src/ocaml/preprocess/parser_raw.mly" ( pstr_type _1 ) -# 40717 "src/ocaml/preprocess/parser_raw.ml" +# 40780 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -40721,15 +40784,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40727 "src/ocaml/preprocess/parser_raw.ml" +# 40790 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40733 "src/ocaml/preprocess/parser_raw.ml" +# 40796 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40814,16 +40877,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40820 "src/ocaml/preprocess/parser_raw.ml" +# 40883 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1219 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 40827 "src/ocaml/preprocess/parser_raw.ml" +# 40890 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -40831,46 +40894,46 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40837 "src/ocaml/preprocess/parser_raw.ml" +# 40900 "src/ocaml/preprocess/parser_raw.ml" in let _4 = -# 3876 "src/ocaml/preprocess/parser_raw.mly" +# 3896 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 40843 "src/ocaml/preprocess/parser_raw.ml" +# 40906 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40850 "src/ocaml/preprocess/parser_raw.ml" +# 40913 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3371 "src/ocaml/preprocess/parser_raw.mly" +# 3391 "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 ) -# 40862 "src/ocaml/preprocess/parser_raw.ml" +# 40925 "src/ocaml/preprocess/parser_raw.ml" in -# 3354 "src/ocaml/preprocess/parser_raw.mly" +# 3374 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40868 "src/ocaml/preprocess/parser_raw.ml" +# 40931 "src/ocaml/preprocess/parser_raw.ml" in -# 1544 "src/ocaml/preprocess/parser_raw.mly" +# 1549 "src/ocaml/preprocess/parser_raw.mly" ( pstr_typext _1 ) -# 40874 "src/ocaml/preprocess/parser_raw.ml" +# 40937 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -40878,15 +40941,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40884 "src/ocaml/preprocess/parser_raw.ml" +# 40947 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40890 "src/ocaml/preprocess/parser_raw.ml" +# 40953 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40978,16 +41041,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40984 "src/ocaml/preprocess/parser_raw.ml" +# 41047 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1219 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 40991 "src/ocaml/preprocess/parser_raw.ml" +# 41054 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -40995,9 +41058,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41001 "src/ocaml/preprocess/parser_raw.ml" +# 41064 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -41006,41 +41069,41 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3878 "src/ocaml/preprocess/parser_raw.mly" +# 3898 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 41012 "src/ocaml/preprocess/parser_raw.ml" +# 41075 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41020 "src/ocaml/preprocess/parser_raw.ml" +# 41083 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3371 "src/ocaml/preprocess/parser_raw.mly" +# 3391 "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 ) -# 41032 "src/ocaml/preprocess/parser_raw.ml" +# 41095 "src/ocaml/preprocess/parser_raw.ml" in -# 3354 "src/ocaml/preprocess/parser_raw.mly" +# 3374 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41038 "src/ocaml/preprocess/parser_raw.ml" +# 41101 "src/ocaml/preprocess/parser_raw.ml" in -# 1544 "src/ocaml/preprocess/parser_raw.mly" +# 1549 "src/ocaml/preprocess/parser_raw.mly" ( pstr_typext _1 ) -# 41044 "src/ocaml/preprocess/parser_raw.ml" +# 41107 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -41048,15 +41111,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41054 "src/ocaml/preprocess/parser_raw.ml" +# 41117 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41060 "src/ocaml/preprocess/parser_raw.ml" +# 41123 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41080,23 +41143,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1546 "src/ocaml/preprocess/parser_raw.mly" +# 1551 "src/ocaml/preprocess/parser_raw.mly" ( pstr_exception _1 ) -# 41086 "src/ocaml/preprocess/parser_raw.ml" +# 41149 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41094 "src/ocaml/preprocess/parser_raw.ml" +# 41157 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41100 "src/ocaml/preprocess/parser_raw.ml" +# 41163 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41159,9 +41222,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41165 "src/ocaml/preprocess/parser_raw.ml" +# 41228 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41171,36 +41234,36 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41177 "src/ocaml/preprocess/parser_raw.ml" +# 41240 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41185 "src/ocaml/preprocess/parser_raw.ml" +# 41248 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1572 "src/ocaml/preprocess/parser_raw.mly" +# 1577 "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 ) -# 41198 "src/ocaml/preprocess/parser_raw.ml" +# 41261 "src/ocaml/preprocess/parser_raw.ml" in -# 1548 "src/ocaml/preprocess/parser_raw.mly" +# 1553 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41204 "src/ocaml/preprocess/parser_raw.ml" +# 41267 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -41208,15 +41271,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41214 "src/ocaml/preprocess/parser_raw.ml" +# 41277 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41220 "src/ocaml/preprocess/parser_raw.ml" +# 41283 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41295,9 +41358,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41301 "src/ocaml/preprocess/parser_raw.ml" +# 41364 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41307,24 +41370,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41313 "src/ocaml/preprocess/parser_raw.ml" +# 41376 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41321 "src/ocaml/preprocess/parser_raw.ml" +# 41384 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1607 "src/ocaml/preprocess/parser_raw.mly" +# 1616 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in @@ -41332,25 +41395,25 @@ module Tables = struct ext, Mb.mk name body ~attrs ~loc ~docs ) -# 41336 "src/ocaml/preprocess/parser_raw.ml" +# 41399 "src/ocaml/preprocess/parser_raw.ml" in -# 1225 "src/ocaml/preprocess/parser_raw.mly" +# 1227 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 41342 "src/ocaml/preprocess/parser_raw.ml" +# 41405 "src/ocaml/preprocess/parser_raw.ml" in -# 1595 "src/ocaml/preprocess/parser_raw.mly" +# 1604 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41348 "src/ocaml/preprocess/parser_raw.ml" +# 41411 "src/ocaml/preprocess/parser_raw.ml" in -# 1550 "src/ocaml/preprocess/parser_raw.mly" +# 1555 "src/ocaml/preprocess/parser_raw.mly" ( pstr_recmodule _1 ) -# 41354 "src/ocaml/preprocess/parser_raw.ml" +# 41417 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -41358,15 +41421,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41364 "src/ocaml/preprocess/parser_raw.ml" +# 41427 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41370 "src/ocaml/preprocess/parser_raw.ml" +# 41433 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41390,23 +41453,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1552 "src/ocaml/preprocess/parser_raw.mly" +# 1557 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Pstr_modtype body, ext) ) -# 41396 "src/ocaml/preprocess/parser_raw.ml" +# 41459 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41404 "src/ocaml/preprocess/parser_raw.ml" +# 41467 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41410 "src/ocaml/preprocess/parser_raw.ml" +# 41473 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41430,23 +41493,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1554 "src/ocaml/preprocess/parser_raw.mly" +# 1559 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Pstr_open body, ext) ) -# 41436 "src/ocaml/preprocess/parser_raw.ml" +# 41499 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41444 "src/ocaml/preprocess/parser_raw.ml" +# 41507 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41450 "src/ocaml/preprocess/parser_raw.ml" +# 41513 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41516,9 +41579,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 41522 "src/ocaml/preprocess/parser_raw.ml" +# 41585 "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 @@ -41536,9 +41599,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41542 "src/ocaml/preprocess/parser_raw.ml" +# 41605 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41548,24 +41611,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41554 "src/ocaml/preprocess/parser_raw.ml" +# 41617 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41562 "src/ocaml/preprocess/parser_raw.ml" +# 41625 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1951 "src/ocaml/preprocess/parser_raw.mly" +# 1970 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -41573,25 +41636,25 @@ module Tables = struct ext, Ci.mk id body ~virt ~params ~attrs ~loc ~docs ) -# 41577 "src/ocaml/preprocess/parser_raw.ml" +# 41640 "src/ocaml/preprocess/parser_raw.ml" in -# 1225 "src/ocaml/preprocess/parser_raw.mly" +# 1227 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 41583 "src/ocaml/preprocess/parser_raw.ml" +# 41646 "src/ocaml/preprocess/parser_raw.ml" in -# 1940 "src/ocaml/preprocess/parser_raw.mly" +# 1959 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41589 "src/ocaml/preprocess/parser_raw.ml" +# 41652 "src/ocaml/preprocess/parser_raw.ml" in -# 1556 "src/ocaml/preprocess/parser_raw.mly" +# 1561 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Pstr_class l, ext) ) -# 41595 "src/ocaml/preprocess/parser_raw.ml" +# 41658 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -41599,15 +41662,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41605 "src/ocaml/preprocess/parser_raw.ml" +# 41668 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41611 "src/ocaml/preprocess/parser_raw.ml" +# 41674 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41631,23 +41694,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1558 "src/ocaml/preprocess/parser_raw.mly" +# 1563 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Pstr_class_type l, ext) ) -# 41637 "src/ocaml/preprocess/parser_raw.ml" +# 41700 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41645 "src/ocaml/preprocess/parser_raw.ml" +# 41708 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41651 "src/ocaml/preprocess/parser_raw.ml" +# 41714 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41703,38 +41766,38 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41709 "src/ocaml/preprocess/parser_raw.ml" +# 41772 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41718 "src/ocaml/preprocess/parser_raw.ml" +# 41781 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1644 "src/ocaml/preprocess/parser_raw.mly" +# 1653 "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 ) -# 41732 "src/ocaml/preprocess/parser_raw.ml" +# 41795 "src/ocaml/preprocess/parser_raw.ml" in -# 1560 "src/ocaml/preprocess/parser_raw.mly" +# 1565 "src/ocaml/preprocess/parser_raw.mly" ( pstr_include _1 ) -# 41738 "src/ocaml/preprocess/parser_raw.ml" +# 41801 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -41742,15 +41805,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1050 "src/ocaml/preprocess/parser_raw.mly" +# 1052 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41748 "src/ocaml/preprocess/parser_raw.ml" +# 41811 "src/ocaml/preprocess/parser_raw.ml" in -# 1562 "src/ocaml/preprocess/parser_raw.mly" +# 1567 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41754 "src/ocaml/preprocess/parser_raw.ml" +# 41817 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41773,9 +41836,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3941 "src/ocaml/preprocess/parser_raw.mly" +# 3961 "src/ocaml/preprocess/parser_raw.mly" ( "-" ) -# 41779 "src/ocaml/preprocess/parser_raw.ml" +# 41842 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41798,9 +41861,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3942 "src/ocaml/preprocess/parser_raw.mly" +# 3962 "src/ocaml/preprocess/parser_raw.mly" ( "-." ) -# 41804 "src/ocaml/preprocess/parser_raw.ml" +# 41867 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41853,9 +41916,9 @@ module Tables = struct let _v : (Parsetree.row_field) = let _5 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41859 "src/ocaml/preprocess/parser_raw.ml" +# 41922 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined1_ in @@ -41864,18 +41927,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 41868 "src/ocaml/preprocess/parser_raw.ml" +# 41931 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 41873 "src/ocaml/preprocess/parser_raw.ml" +# 41936 "src/ocaml/preprocess/parser_raw.ml" in -# 3645 "src/ocaml/preprocess/parser_raw.mly" +# 3665 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41879 "src/ocaml/preprocess/parser_raw.ml" +# 41942 "src/ocaml/preprocess/parser_raw.ml" in let _1 = @@ -41883,20 +41946,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41889 "src/ocaml/preprocess/parser_raw.ml" +# 41952 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3631 "src/ocaml/preprocess/parser_raw.mly" +# 3651 "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 ) -# 41900 "src/ocaml/preprocess/parser_raw.ml" +# 41963 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41928,9 +41991,9 @@ module Tables = struct let _v : (Parsetree.row_field) = let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41934 "src/ocaml/preprocess/parser_raw.ml" +# 41997 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -41939,20 +42002,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41945 "src/ocaml/preprocess/parser_raw.ml" +# 42008 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3655 "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 [] ) -# 41956 "src/ocaml/preprocess/parser_raw.ml" +# 42019 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41984,7 +42047,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase) = let arg = # 124 "" ( None ) -# 41988 "src/ocaml/preprocess/parser_raw.ml" +# 42051 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined1_ in let dir = @@ -41993,18 +42056,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41999 "src/ocaml/preprocess/parser_raw.ml" +# 42062 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3839 "src/ocaml/preprocess/parser_raw.mly" +# 3859 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42008 "src/ocaml/preprocess/parser_raw.ml" +# 42071 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42035,9 +42098,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : ( -# 835 "src/ocaml/preprocess/parser_raw.mly" +# 837 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 42041 "src/ocaml/preprocess/parser_raw.ml" +# 42104 "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 @@ -42048,23 +42111,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3843 "src/ocaml/preprocess/parser_raw.mly" +# 3863 "src/ocaml/preprocess/parser_raw.mly" ( let (s, _, _) = _1 in Pdir_string s ) -# 42054 "src/ocaml/preprocess/parser_raw.ml" +# 42117 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1055 "src/ocaml/preprocess/parser_raw.mly" +# 1057 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42062 "src/ocaml/preprocess/parser_raw.ml" +# 42125 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42068 "src/ocaml/preprocess/parser_raw.ml" +# 42131 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42074,18 +42137,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42080 "src/ocaml/preprocess/parser_raw.ml" +# 42143 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3839 "src/ocaml/preprocess/parser_raw.mly" +# 3859 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42089 "src/ocaml/preprocess/parser_raw.ml" +# 42152 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42116,9 +42179,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : ( -# 783 "src/ocaml/preprocess/parser_raw.mly" +# 785 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 42122 "src/ocaml/preprocess/parser_raw.ml" +# 42185 "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 @@ -42129,23 +42192,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3844 "src/ocaml/preprocess/parser_raw.mly" +# 3864 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _1 in Pdir_int (n ,m) ) -# 42135 "src/ocaml/preprocess/parser_raw.ml" +# 42198 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1055 "src/ocaml/preprocess/parser_raw.mly" +# 1057 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42143 "src/ocaml/preprocess/parser_raw.ml" +# 42206 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42149 "src/ocaml/preprocess/parser_raw.ml" +# 42212 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42155,18 +42218,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42161 "src/ocaml/preprocess/parser_raw.ml" +# 42224 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3839 "src/ocaml/preprocess/parser_raw.mly" +# 3859 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42170 "src/ocaml/preprocess/parser_raw.ml" +# 42233 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42206,23 +42269,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3845 "src/ocaml/preprocess/parser_raw.mly" +# 3865 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_ident _1 ) -# 42212 "src/ocaml/preprocess/parser_raw.ml" +# 42275 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1055 "src/ocaml/preprocess/parser_raw.mly" +# 1057 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42220 "src/ocaml/preprocess/parser_raw.ml" +# 42283 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42226 "src/ocaml/preprocess/parser_raw.ml" +# 42289 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42232,18 +42295,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42238 "src/ocaml/preprocess/parser_raw.ml" +# 42301 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3839 "src/ocaml/preprocess/parser_raw.mly" +# 3859 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42247 "src/ocaml/preprocess/parser_raw.ml" +# 42310 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42283,23 +42346,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3846 "src/ocaml/preprocess/parser_raw.mly" +# 3866 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_ident _1 ) -# 42289 "src/ocaml/preprocess/parser_raw.ml" +# 42352 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1055 "src/ocaml/preprocess/parser_raw.mly" +# 1057 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42297 "src/ocaml/preprocess/parser_raw.ml" +# 42360 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42303 "src/ocaml/preprocess/parser_raw.ml" +# 42366 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42309,18 +42372,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42315 "src/ocaml/preprocess/parser_raw.ml" +# 42378 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3839 "src/ocaml/preprocess/parser_raw.mly" +# 3859 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42324 "src/ocaml/preprocess/parser_raw.ml" +# 42387 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42360,23 +42423,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3847 "src/ocaml/preprocess/parser_raw.mly" +# 3867 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_bool false ) -# 42366 "src/ocaml/preprocess/parser_raw.ml" +# 42429 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1055 "src/ocaml/preprocess/parser_raw.mly" +# 1057 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42374 "src/ocaml/preprocess/parser_raw.ml" +# 42437 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42380 "src/ocaml/preprocess/parser_raw.ml" +# 42443 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42386,18 +42449,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42392 "src/ocaml/preprocess/parser_raw.ml" +# 42455 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3839 "src/ocaml/preprocess/parser_raw.mly" +# 3859 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42401 "src/ocaml/preprocess/parser_raw.ml" +# 42464 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42437,23 +42500,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 3868 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_bool true ) -# 42443 "src/ocaml/preprocess/parser_raw.ml" +# 42506 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1055 "src/ocaml/preprocess/parser_raw.mly" +# 1057 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42451 "src/ocaml/preprocess/parser_raw.ml" +# 42514 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42457 "src/ocaml/preprocess/parser_raw.ml" +# 42520 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42463,18 +42526,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42469 "src/ocaml/preprocess/parser_raw.ml" +# 42532 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3839 "src/ocaml/preprocess/parser_raw.mly" +# 3859 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42478 "src/ocaml/preprocess/parser_raw.ml" +# 42541 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42514,37 +42577,37 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42520 "src/ocaml/preprocess/parser_raw.ml" +# 42583 "src/ocaml/preprocess/parser_raw.ml" in -# 1513 "src/ocaml/preprocess/parser_raw.mly" +# 1518 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 42525 "src/ocaml/preprocess/parser_raw.ml" +# 42588 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 998 "src/ocaml/preprocess/parser_raw.mly" +# 1000 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 42533 "src/ocaml/preprocess/parser_raw.ml" +# 42596 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 986 "src/ocaml/preprocess/parser_raw.mly" +# 988 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 42542 "src/ocaml/preprocess/parser_raw.ml" +# 42605 "src/ocaml/preprocess/parser_raw.ml" in -# 1265 "src/ocaml/preprocess/parser_raw.mly" +# 1267 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def _1 ) -# 42548 "src/ocaml/preprocess/parser_raw.ml" +# 42611 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42577,21 +42640,21 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 42581 "src/ocaml/preprocess/parser_raw.ml" +# 42644 "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 -# 986 "src/ocaml/preprocess/parser_raw.mly" +# 988 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 42589 "src/ocaml/preprocess/parser_raw.ml" +# 42652 "src/ocaml/preprocess/parser_raw.ml" in -# 1269 "src/ocaml/preprocess/parser_raw.mly" +# 1271 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def _1 ) -# 42595 "src/ocaml/preprocess/parser_raw.ml" +# 42658 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42621,9 +42684,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.toplevel_phrase) = -# 1273 "src/ocaml/preprocess/parser_raw.mly" +# 1275 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42627 "src/ocaml/preprocess/parser_raw.ml" +# 42690 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42646,9 +42709,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.toplevel_phrase) = -# 1276 "src/ocaml/preprocess/parser_raw.mly" +# 1278 "src/ocaml/preprocess/parser_raw.mly" ( raise End_of_file ) -# 42652 "src/ocaml/preprocess/parser_raw.ml" +# 42715 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42671,9 +42734,9 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.core_type) = -# 3537 "src/ocaml/preprocess/parser_raw.mly" +# 3557 "src/ocaml/preprocess/parser_raw.mly" ( ty ) -# 42677 "src/ocaml/preprocess/parser_raw.ml" +# 42740 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42701,18 +42764,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 42705 "src/ocaml/preprocess/parser_raw.ml" +# 42768 "src/ocaml/preprocess/parser_raw.ml" in -# 1156 "src/ocaml/preprocess/parser_raw.mly" +# 1158 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 42710 "src/ocaml/preprocess/parser_raw.ml" +# 42773 "src/ocaml/preprocess/parser_raw.ml" in -# 3540 "src/ocaml/preprocess/parser_raw.mly" +# 3560 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_tuple tys ) -# 42716 "src/ocaml/preprocess/parser_raw.ml" +# 42779 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -42720,15 +42783,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 42726 "src/ocaml/preprocess/parser_raw.ml" +# 42789 "src/ocaml/preprocess/parser_raw.ml" in -# 3542 "src/ocaml/preprocess/parser_raw.mly" +# 3562 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42732 "src/ocaml/preprocess/parser_raw.ml" +# 42795 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42758,9 +42821,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type option * Parsetree.core_type option) = -# 2853 "src/ocaml/preprocess/parser_raw.mly" +# 2873 "src/ocaml/preprocess/parser_raw.mly" ( (Some _2, None) ) -# 42764 "src/ocaml/preprocess/parser_raw.ml" +# 42827 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42804,9 +42867,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.core_type option * Parsetree.core_type option) = -# 2854 "src/ocaml/preprocess/parser_raw.mly" +# 2874 "src/ocaml/preprocess/parser_raw.mly" ( (Some _2, Some _4) ) -# 42810 "src/ocaml/preprocess/parser_raw.ml" +# 42873 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42836,9 +42899,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type option * Parsetree.core_type option) = -# 2855 "src/ocaml/preprocess/parser_raw.mly" +# 2875 "src/ocaml/preprocess/parser_raw.mly" ( (None, Some _2) ) -# 42842 "src/ocaml/preprocess/parser_raw.ml" +# 42905 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42854,9 +42917,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = -# 3190 "src/ocaml/preprocess/parser_raw.mly" +# 3210 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, Public, None) ) -# 42860 "src/ocaml/preprocess/parser_raw.ml" +# 42923 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42886,9 +42949,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = -# 3192 "src/ocaml/preprocess/parser_raw.mly" +# 3212 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 42892 "src/ocaml/preprocess/parser_raw.ml" +# 42955 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42911,9 +42974,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3798 "src/ocaml/preprocess/parser_raw.mly" +# 3818 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42917 "src/ocaml/preprocess/parser_raw.ml" +# 42980 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42943,9 +43006,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) = -# 3207 "src/ocaml/preprocess/parser_raw.mly" +# 3227 "src/ocaml/preprocess/parser_raw.mly" ( _2, _1 ) -# 42949 "src/ocaml/preprocess/parser_raw.ml" +# 43012 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42961,9 +43024,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = -# 3200 "src/ocaml/preprocess/parser_raw.mly" +# 3220 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 42967 "src/ocaml/preprocess/parser_raw.ml" +# 43030 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42986,9 +43049,9 @@ module Tables = struct let _startpos = _startpos_p_ in let _endpos = _endpos_p_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = -# 3202 "src/ocaml/preprocess/parser_raw.mly" +# 3222 "src/ocaml/preprocess/parser_raw.mly" ( [p] ) -# 42992 "src/ocaml/preprocess/parser_raw.ml" +# 43055 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43028,18 +43091,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 43032 "src/ocaml/preprocess/parser_raw.ml" +# 43095 "src/ocaml/preprocess/parser_raw.ml" in -# 1128 "src/ocaml/preprocess/parser_raw.mly" +# 1130 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 43037 "src/ocaml/preprocess/parser_raw.ml" +# 43100 "src/ocaml/preprocess/parser_raw.ml" in -# 3204 "src/ocaml/preprocess/parser_raw.mly" +# 3224 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 43043 "src/ocaml/preprocess/parser_raw.ml" +# 43106 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43070,24 +43133,24 @@ module Tables = struct let _endpos = _endpos_tyvar_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3212 "src/ocaml/preprocess/parser_raw.mly" +# 3232 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_var tyvar ) -# 43076 "src/ocaml/preprocess/parser_raw.ml" +# 43139 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43085 "src/ocaml/preprocess/parser_raw.ml" +# 43148 "src/ocaml/preprocess/parser_raw.ml" in -# 3215 "src/ocaml/preprocess/parser_raw.mly" +# 3235 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43091 "src/ocaml/preprocess/parser_raw.ml" +# 43154 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43111,23 +43174,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3214 "src/ocaml/preprocess/parser_raw.mly" +# 3234 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 43117 "src/ocaml/preprocess/parser_raw.ml" +# 43180 "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" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43125 "src/ocaml/preprocess/parser_raw.ml" +# 43188 "src/ocaml/preprocess/parser_raw.ml" in -# 3215 "src/ocaml/preprocess/parser_raw.mly" +# 3235 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43131 "src/ocaml/preprocess/parser_raw.ml" +# 43194 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43143,9 +43206,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3219 "src/ocaml/preprocess/parser_raw.mly" +# 3239 "src/ocaml/preprocess/parser_raw.mly" ( NoVariance, NoInjectivity ) -# 43149 "src/ocaml/preprocess/parser_raw.ml" +# 43212 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43168,9 +43231,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3220 "src/ocaml/preprocess/parser_raw.mly" +# 3240 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, NoInjectivity ) -# 43174 "src/ocaml/preprocess/parser_raw.ml" +# 43237 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43193,9 +43256,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3221 "src/ocaml/preprocess/parser_raw.mly" +# 3241 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, NoInjectivity ) -# 43199 "src/ocaml/preprocess/parser_raw.ml" +# 43262 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43218,9 +43281,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3222 "src/ocaml/preprocess/parser_raw.mly" +# 3242 "src/ocaml/preprocess/parser_raw.mly" ( NoVariance, Injective ) -# 43224 "src/ocaml/preprocess/parser_raw.ml" +# 43287 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43250,9 +43313,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3223 "src/ocaml/preprocess/parser_raw.mly" +# 3243 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, Injective ) -# 43256 "src/ocaml/preprocess/parser_raw.ml" +# 43319 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43282,9 +43345,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3223 "src/ocaml/preprocess/parser_raw.mly" +# 3243 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, Injective ) -# 43288 "src/ocaml/preprocess/parser_raw.ml" +# 43351 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43314,9 +43377,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3224 "src/ocaml/preprocess/parser_raw.mly" +# 3244 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, Injective ) -# 43320 "src/ocaml/preprocess/parser_raw.ml" +# 43383 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43346,9 +43409,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3224 "src/ocaml/preprocess/parser_raw.mly" +# 3244 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, Injective ) -# 43352 "src/ocaml/preprocess/parser_raw.ml" +# 43415 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43367,21 +43430,21 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 777 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43373 "src/ocaml/preprocess/parser_raw.ml" +# 43436 "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 -# 3226 "src/ocaml/preprocess/parser_raw.mly" +# 3246 "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) ) -# 43385 "src/ocaml/preprocess/parser_raw.ml" +# 43448 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43400,21 +43463,21 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 821 "src/ocaml/preprocess/parser_raw.mly" +# 823 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43406 "src/ocaml/preprocess/parser_raw.ml" +# 43469 "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 -# 3231 "src/ocaml/preprocess/parser_raw.mly" +# 3251 "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) ) -# 43418 "src/ocaml/preprocess/parser_raw.ml" +# 43481 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43448,39 +43511,39 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 43452 "src/ocaml/preprocess/parser_raw.ml" +# 43515 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _1 = -# 1064 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 43458 "src/ocaml/preprocess/parser_raw.ml" +# 43521 "src/ocaml/preprocess/parser_raw.ml" in -# 1296 "src/ocaml/preprocess/parser_raw.mly" +# 1298 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43463 "src/ocaml/preprocess/parser_raw.ml" +# 43526 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 43469 "src/ocaml/preprocess/parser_raw.ml" +# 43532 "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 -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 992 "src/ocaml/preprocess/parser_raw.mly" ( extra_def _startpos _endpos _1 ) -# 43478 "src/ocaml/preprocess/parser_raw.ml" +# 43541 "src/ocaml/preprocess/parser_raw.ml" in -# 1289 "src/ocaml/preprocess/parser_raw.mly" +# 1291 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43484 "src/ocaml/preprocess/parser_raw.ml" +# 43547 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43528,7 +43591,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 43532 "src/ocaml/preprocess/parser_raw.ml" +# 43595 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _1 = @@ -43536,61 +43599,61 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43542 "src/ocaml/preprocess/parser_raw.ml" +# 43605 "src/ocaml/preprocess/parser_raw.ml" in -# 1513 "src/ocaml/preprocess/parser_raw.mly" +# 1518 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 43547 "src/ocaml/preprocess/parser_raw.ml" +# 43610 "src/ocaml/preprocess/parser_raw.ml" in -# 1008 "src/ocaml/preprocess/parser_raw.mly" +# 1010 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 43553 "src/ocaml/preprocess/parser_raw.ml" +# 43616 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1006 "src/ocaml/preprocess/parser_raw.mly" +# 1008 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 43561 "src/ocaml/preprocess/parser_raw.ml" +# 43624 "src/ocaml/preprocess/parser_raw.ml" in -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1068 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 43567 "src/ocaml/preprocess/parser_raw.ml" +# 43630 "src/ocaml/preprocess/parser_raw.ml" in -# 1296 "src/ocaml/preprocess/parser_raw.mly" +# 1298 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43573 "src/ocaml/preprocess/parser_raw.ml" +# 43636 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 43579 "src/ocaml/preprocess/parser_raw.ml" +# 43642 "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 -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 992 "src/ocaml/preprocess/parser_raw.mly" ( extra_def _startpos _endpos _1 ) -# 43588 "src/ocaml/preprocess/parser_raw.ml" +# 43651 "src/ocaml/preprocess/parser_raw.ml" in -# 1289 "src/ocaml/preprocess/parser_raw.mly" +# 1291 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43594 "src/ocaml/preprocess/parser_raw.ml" +# 43657 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43627,9 +43690,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = -# 3715 "src/ocaml/preprocess/parser_raw.mly" +# 3735 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 43633 "src/ocaml/preprocess/parser_raw.ml" +# 43696 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43648,17 +43711,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43654 "src/ocaml/preprocess/parser_raw.ml" +# 43717 "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) = -# 3723 "src/ocaml/preprocess/parser_raw.mly" +# 3743 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43662 "src/ocaml/preprocess/parser_raw.ml" +# 43725 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43681,9 +43744,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3724 "src/ocaml/preprocess/parser_raw.mly" +# 3744 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43687 "src/ocaml/preprocess/parser_raw.ml" +# 43750 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43706,9 +43769,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3792 "src/ocaml/preprocess/parser_raw.mly" +# 3812 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43712 "src/ocaml/preprocess/parser_raw.ml" +# 43775 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43753,9 +43816,9 @@ module Tables = struct let ty : (Parsetree.core_type) = Obj.magic ty in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43759 "src/ocaml/preprocess/parser_raw.ml" +# 43822 "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 @@ -43766,33 +43829,33 @@ module Tables = struct Parsetree.attributes) = let label = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43772 "src/ocaml/preprocess/parser_raw.ml" +# 43835 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43780 "src/ocaml/preprocess/parser_raw.ml" +# 43843 "src/ocaml/preprocess/parser_raw.ml" in let attrs = -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43786 "src/ocaml/preprocess/parser_raw.ml" +# 43849 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 3954 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 43791 "src/ocaml/preprocess/parser_raw.ml" +# 43854 "src/ocaml/preprocess/parser_raw.ml" in -# 2097 "src/ocaml/preprocess/parser_raw.mly" +# 2116 "src/ocaml/preprocess/parser_raw.mly" ( (label, mutable_, Cfk_virtual ty), attrs ) -# 43796 "src/ocaml/preprocess/parser_raw.ml" +# 43859 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43837,9 +43900,9 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43843 "src/ocaml/preprocess/parser_raw.ml" +# 43906 "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 @@ -43850,33 +43913,33 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43856 "src/ocaml/preprocess/parser_raw.ml" +# 43919 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43864 "src/ocaml/preprocess/parser_raw.ml" +# 43927 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43870 "src/ocaml/preprocess/parser_raw.ml" +# 43933 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 43875 "src/ocaml/preprocess/parser_raw.ml" +# 43938 "src/ocaml/preprocess/parser_raw.ml" in -# 2099 "src/ocaml/preprocess/parser_raw.mly" +# 2118 "src/ocaml/preprocess/parser_raw.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 43880 "src/ocaml/preprocess/parser_raw.ml" +# 43943 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43927,9 +43990,9 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43933 "src/ocaml/preprocess/parser_raw.ml" +# 43996 "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 @@ -43941,36 +44004,36 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43947 "src/ocaml/preprocess/parser_raw.ml" +# 44010 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43955 "src/ocaml/preprocess/parser_raw.ml" +# 44018 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43963 "src/ocaml/preprocess/parser_raw.ml" +# 44026 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 43969 "src/ocaml/preprocess/parser_raw.ml" +# 44032 "src/ocaml/preprocess/parser_raw.ml" in -# 2099 "src/ocaml/preprocess/parser_raw.mly" +# 2118 "src/ocaml/preprocess/parser_raw.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 43974 "src/ocaml/preprocess/parser_raw.ml" +# 44037 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44022,9 +44085,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _5 in let _1_inlined1 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44028 "src/ocaml/preprocess/parser_raw.ml" +# 44091 "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 @@ -44035,30 +44098,30 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44041 "src/ocaml/preprocess/parser_raw.ml" +# 44104 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44049 "src/ocaml/preprocess/parser_raw.ml" +# 44112 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44056 "src/ocaml/preprocess/parser_raw.ml" +# 44119 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 44062 "src/ocaml/preprocess/parser_raw.ml" +# 44125 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__7_ in @@ -44074,11 +44137,11 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2102 "src/ocaml/preprocess/parser_raw.mly" +# 2121 "src/ocaml/preprocess/parser_raw.mly" ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 44082 "src/ocaml/preprocess/parser_raw.ml" +# 44145 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44136,9 +44199,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic _5 in let _1_inlined2 : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44142 "src/ocaml/preprocess/parser_raw.ml" +# 44205 "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 @@ -44150,33 +44213,33 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3689 "src/ocaml/preprocess/parser_raw.mly" +# 3709 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44156 "src/ocaml/preprocess/parser_raw.ml" +# 44219 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44164 "src/ocaml/preprocess/parser_raw.ml" +# 44227 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44173 "src/ocaml/preprocess/parser_raw.ml" +# 44236 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 44180 "src/ocaml/preprocess/parser_raw.ml" +# 44243 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -44191,11 +44254,11 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2102 "src/ocaml/preprocess/parser_raw.mly" +# 2121 "src/ocaml/preprocess/parser_raw.mly" ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 44199 "src/ocaml/preprocess/parser_raw.ml" +# 44262 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44262,9 +44325,9 @@ module Tables = struct let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 4051 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44268 "src/ocaml/preprocess/parser_raw.ml" +# 44331 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -44274,30 +44337,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44280 "src/ocaml/preprocess/parser_raw.ml" +# 44343 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4035 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44288 "src/ocaml/preprocess/parser_raw.ml" +# 44351 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3061 "src/ocaml/preprocess/parser_raw.mly" +# 3081 "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 ) -# 44301 "src/ocaml/preprocess/parser_raw.ml" +# 44364 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44313,9 +44376,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.virtual_flag) = -# 3898 "src/ocaml/preprocess/parser_raw.mly" +# 3918 "src/ocaml/preprocess/parser_raw.mly" ( Concrete ) -# 44319 "src/ocaml/preprocess/parser_raw.ml" +# 44382 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44338,9 +44401,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.virtual_flag) = -# 3899 "src/ocaml/preprocess/parser_raw.mly" +# 3919 "src/ocaml/preprocess/parser_raw.mly" ( Virtual ) -# 44344 "src/ocaml/preprocess/parser_raw.ml" +# 44407 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44363,9 +44426,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag) = -# 3922 "src/ocaml/preprocess/parser_raw.mly" +# 3942 "src/ocaml/preprocess/parser_raw.mly" ( Immutable ) -# 44369 "src/ocaml/preprocess/parser_raw.ml" +# 44432 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44395,9 +44458,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag) = -# 3923 "src/ocaml/preprocess/parser_raw.mly" +# 3943 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 44401 "src/ocaml/preprocess/parser_raw.ml" +# 44464 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44427,9 +44490,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag) = -# 3924 "src/ocaml/preprocess/parser_raw.mly" +# 3944 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 44433 "src/ocaml/preprocess/parser_raw.ml" +# 44496 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44452,9 +44515,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = -# 3929 "src/ocaml/preprocess/parser_raw.mly" +# 3949 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 44458 "src/ocaml/preprocess/parser_raw.ml" +# 44521 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44484,9 +44547,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3930 "src/ocaml/preprocess/parser_raw.mly" +# 3950 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 44490 "src/ocaml/preprocess/parser_raw.ml" +# 44553 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44516,9 +44579,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3931 "src/ocaml/preprocess/parser_raw.mly" +# 3951 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 44522 "src/ocaml/preprocess/parser_raw.ml" +# 44585 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44580,27 +44643,27 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 44584 "src/ocaml/preprocess/parser_raw.ml" +# 44647 "src/ocaml/preprocess/parser_raw.ml" in -# 1078 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 44589 "src/ocaml/preprocess/parser_raw.ml" +# 44652 "src/ocaml/preprocess/parser_raw.ml" in -# 3161 "src/ocaml/preprocess/parser_raw.mly" +# 3181 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44595 "src/ocaml/preprocess/parser_raw.ml" +# 44658 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos_xs_ in let _5 = let _1 = _1_inlined2 in -# 3485 "src/ocaml/preprocess/parser_raw.mly" +# 3505 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44604 "src/ocaml/preprocess/parser_raw.ml" +# 44667 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -44609,16 +44672,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44615 "src/ocaml/preprocess/parser_raw.ml" +# 44678 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3404 "src/ocaml/preprocess/parser_raw.mly" +# 3424 "src/ocaml/preprocess/parser_raw.mly" ( let lident = loc_last _3 in Pwith_type (_3, @@ -44628,7 +44691,7 @@ module Tables = struct ~manifest:_5 ~priv:_4 ~loc:(make_loc _sloc))) ) -# 44632 "src/ocaml/preprocess/parser_raw.ml" +# 44695 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44681,9 +44744,9 @@ module Tables = struct let _v : (Parsetree.with_constraint) = let _5 = let _1 = _1_inlined2 in -# 3485 "src/ocaml/preprocess/parser_raw.mly" +# 3505 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44687 "src/ocaml/preprocess/parser_raw.ml" +# 44750 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in @@ -44693,16 +44756,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44699 "src/ocaml/preprocess/parser_raw.ml" +# 44762 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3417 "src/ocaml/preprocess/parser_raw.mly" +# 3437 "src/ocaml/preprocess/parser_raw.mly" ( let lident = loc_last _3 in Pwith_typesubst (_3, @@ -44710,7 +44773,7 @@ module Tables = struct ~params:_2 ~manifest:_5 ~loc:(make_loc _sloc))) ) -# 44714 "src/ocaml/preprocess/parser_raw.ml" +# 44777 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44759,9 +44822,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44765 "src/ocaml/preprocess/parser_raw.ml" +# 44828 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -44770,15 +44833,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44776 "src/ocaml/preprocess/parser_raw.ml" +# 44839 "src/ocaml/preprocess/parser_raw.ml" in -# 3425 "src/ocaml/preprocess/parser_raw.mly" +# 3445 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_module (_2, _4) ) -# 44782 "src/ocaml/preprocess/parser_raw.ml" +# 44845 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44827,9 +44890,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44833 "src/ocaml/preprocess/parser_raw.ml" +# 44896 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -44838,15 +44901,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44844 "src/ocaml/preprocess/parser_raw.ml" +# 44907 "src/ocaml/preprocess/parser_raw.ml" in -# 3427 "src/ocaml/preprocess/parser_raw.mly" +# 3447 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modsubst (_2, _4) ) -# 44850 "src/ocaml/preprocess/parser_raw.ml" +# 44913 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44902,15 +44965,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44908 "src/ocaml/preprocess/parser_raw.ml" +# 44971 "src/ocaml/preprocess/parser_raw.ml" in -# 3429 "src/ocaml/preprocess/parser_raw.mly" +# 3449 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modtype (l, rhs) ) -# 44914 "src/ocaml/preprocess/parser_raw.ml" +# 44977 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44966,15 +45029,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 996 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44972 "src/ocaml/preprocess/parser_raw.ml" +# 45035 "src/ocaml/preprocess/parser_raw.ml" in -# 3431 "src/ocaml/preprocess/parser_raw.mly" +# 3451 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modtypesubst (l, rhs) ) -# 44978 "src/ocaml/preprocess/parser_raw.ml" +# 45041 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44997,9 +45060,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = -# 3434 "src/ocaml/preprocess/parser_raw.mly" +# 3454 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 45003 "src/ocaml/preprocess/parser_raw.ml" +# 45066 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45029,9 +45092,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3435 "src/ocaml/preprocess/parser_raw.mly" +# 3455 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 45035 "src/ocaml/preprocess/parser_raw.ml" +# 45098 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45067,9 +45130,9 @@ module MenhirInterpreter = struct | T_VAL : unit terminal | T_UNDERSCORE : unit terminal | T_UIDENT : ( -# 849 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45073 "src/ocaml/preprocess/parser_raw.ml" +# 45136 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_TYPE : unit terminal | T_TRY_LWT : unit terminal @@ -45080,9 +45143,9 @@ module MenhirInterpreter = struct | T_THEN : unit terminal | T_STRUCT : unit terminal | T_STRING : ( -# 835 "src/ocaml/preprocess/parser_raw.mly" +# 837 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 45086 "src/ocaml/preprocess/parser_raw.ml" +# 45149 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_STAR : unit terminal | T_SIG : unit terminal @@ -45093,22 +45156,22 @@ module MenhirInterpreter = struct | T_RBRACKET : unit terminal | T_RBRACE : unit terminal | T_QUOTED_STRING_ITEM : ( -# 840 "src/ocaml/preprocess/parser_raw.mly" +# 842 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 45099 "src/ocaml/preprocess/parser_raw.ml" +# 45162 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_QUOTED_STRING_EXPR : ( -# 837 "src/ocaml/preprocess/parser_raw.mly" +# 839 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 45104 "src/ocaml/preprocess/parser_raw.ml" +# 45167 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_QUOTE : unit terminal | T_QUESTION : unit terminal | T_PRIVATE : unit terminal | T_PREFIXOP : ( -# 821 "src/ocaml/preprocess/parser_raw.mly" +# 823 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45112 "src/ocaml/preprocess/parser_raw.ml" +# 45175 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_PLUSEQ : unit terminal | T_PLUSDOT : unit terminal @@ -45116,9 +45179,9 @@ module MenhirInterpreter = struct | T_PERCENT : unit terminal | T_OR : unit terminal | T_OPTLABEL : ( -# 814 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45122 "src/ocaml/preprocess/parser_raw.ml" +# 45185 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_OPEN : unit terminal | T_OF : unit terminal @@ -45135,15 +45198,15 @@ module MenhirInterpreter = struct | T_MATCH : unit terminal | T_LPAREN : unit terminal | T_LIDENT : ( -# 797 "src/ocaml/preprocess/parser_raw.mly" +# 799 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45141 "src/ocaml/preprocess/parser_raw.ml" +# 45204 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_LET_LWT : unit terminal | T_LETOP : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 781 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45147 "src/ocaml/preprocess/parser_raw.ml" +# 45210 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_LET : unit terminal | T_LESSMINUS : unit terminal @@ -45161,49 +45224,49 @@ module MenhirInterpreter = struct | T_LBRACE : unit terminal | T_LAZY : unit terminal | T_LABEL : ( -# 784 "src/ocaml/preprocess/parser_raw.mly" +# 786 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45167 "src/ocaml/preprocess/parser_raw.ml" +# 45230 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INT : ( -# 783 "src/ocaml/preprocess/parser_raw.mly" +# 785 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 45172 "src/ocaml/preprocess/parser_raw.ml" +# 45235 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INITIALIZER : unit terminal | T_INHERIT : unit terminal | T_INFIXOP4 : ( -# 777 "src/ocaml/preprocess/parser_raw.mly" +# 779 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45179 "src/ocaml/preprocess/parser_raw.ml" +# 45242 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP3 : ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 778 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45184 "src/ocaml/preprocess/parser_raw.ml" +# 45247 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP2 : ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 777 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45189 "src/ocaml/preprocess/parser_raw.ml" +# 45252 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP1 : ( -# 774 "src/ocaml/preprocess/parser_raw.mly" +# 776 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45194 "src/ocaml/preprocess/parser_raw.ml" +# 45257 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP0 : ( -# 773 "src/ocaml/preprocess/parser_raw.mly" +# 775 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45199 "src/ocaml/preprocess/parser_raw.ml" +# 45262 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INCLUDE : unit terminal | T_IN : unit terminal | T_IF : unit terminal | T_HASHOP : ( -# 832 "src/ocaml/preprocess/parser_raw.mly" +# 834 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45207 "src/ocaml/preprocess/parser_raw.ml" +# 45270 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_HASH : unit terminal | T_GREATERRBRACKET : unit terminal @@ -45216,9 +45279,9 @@ module MenhirInterpreter = struct | T_FOR_LWT : unit terminal | T_FOR : unit terminal | T_FLOAT : ( -# 762 "src/ocaml/preprocess/parser_raw.mly" +# 764 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 45222 "src/ocaml/preprocess/parser_raw.ml" +# 45285 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_FINALLY_LWT : unit terminal | T_FALSE : unit terminal @@ -45232,25 +45295,25 @@ module MenhirInterpreter = struct | T_DOWNTO : unit terminal | T_DOTTILDE : unit terminal | T_DOTOP : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 780 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45238 "src/ocaml/preprocess/parser_raw.ml" +# 45301 "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 : ( -# 857 "src/ocaml/preprocess/parser_raw.mly" +# 859 "src/ocaml/preprocess/parser_raw.mly" (Docstrings.docstring) -# 45247 "src/ocaml/preprocess/parser_raw.ml" +# 45310 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_DO : unit terminal | T_CONSTRAINT : unit terminal | T_COMMENT : ( -# 856 "src/ocaml/preprocess/parser_raw.mly" +# 858 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t) -# 45254 "src/ocaml/preprocess/parser_raw.ml" +# 45317 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_COMMA : unit terminal | T_COLONGREATER : unit terminal @@ -45259,9 +45322,9 @@ module MenhirInterpreter = struct | T_COLON : unit terminal | T_CLASS : unit terminal | T_CHAR : ( -# 742 "src/ocaml/preprocess/parser_raw.mly" +# 744 "src/ocaml/preprocess/parser_raw.mly" (char) -# 45265 "src/ocaml/preprocess/parser_raw.ml" +# 45328 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_BEGIN : unit terminal | T_BARRBRACKET : unit terminal @@ -45272,9 +45335,9 @@ module MenhirInterpreter = struct | T_ASSERT : unit terminal | T_AS : unit terminal | T_ANDOP : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 782 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45278 "src/ocaml/preprocess/parser_raw.ml" +# 45341 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_AND : unit terminal | T_AMPERSAND : unit terminal @@ -45435,8 +45498,10 @@ module MenhirInterpreter = struct | 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_let_binding_body_no_punning : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option) nonterminal + | N_let_binding_body : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option * 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 @@ -46216,16 +46281,16 @@ module MenhirInterpreter = struct 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\000U\000\218\001\185\001\185\001\135\000\132\001\185\000\b\001\135\0017\000\016\000\018\000\022\001\135\0017\000\024\001\135\0017\000\026\000$\0008\000@\000R\001\135\0017\000h\000\016\000F\000\144\000\188\000`\000\144\000\188\000h\000&\000.\000@\000B\000D\000F\000H\000J\000Z\001\135\0017\000\016\000\018\000\255\000.\000\238\000\018\000(\0017\000\014\001\135\0017\000h\000F\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\001c\000.\000r\000\134\001c\0002\000r\000\138\001c\0004\000r\000\234\000\248\000\252\001\004\001\b\001\n\000\227\000.\000j\000/\000\238\000\016\000\018\000:\000\018\000j\001g\000<\000j\000\238\000L\000h\000:\001g\000Z\001\135\0017\000Z\000\020\000P\0017\000\016\000\"\0017\000\020\001\135\0017\000@\000F\000\252\000T\000`\000\252\000h\000\154\000\252\000F\000`\0005\000\016\000:\001g\0007\000;\000{\000.\000\230\000;\0009\000j\000\198\000\018\000>\000h\000j\000\238\000j\000t\000j\000\238\000x\001\185\000*\0006\000D\000F\000N\000\252\001\135\0017\000h\000\014\0017\000V\001\135\0017\000j\001\007\000\218\000\018\000j\001\r\001\015\001\173\001\183\0017\000^\000`\000d\001\135\0017\000f\001\135\0017\000h\000@\000~\000j\000r\000l\001\135\0017\0000\000\153\000~\000\134\0002\000\138\001\015\001#\0004\001U\000\238\000z\000\250\000\223\000|\0002\000\223\000\134\000\168\001\t\000h\001\t\000.\000\218\000\018\001\021\000\218\000j\001\023\001\157\000\250\000\254\001g\000=\000C\000\\\000s\000&\001\023\001\133\001\187\000\168\001\157\000=\000\205\000C\000\\\001w\001\187\000&\001\187\001w\000I\000q\000\127\0002\000\250\000q\000\239\000P\001\b\000\225\000\131\001\b\001w\001\193\001\002\000:\001g\0017\001\193\0017\001\141\001\183\001\193\000I\0002\000q\000\250\000\127\0002\000\127\0002\000\127\0002\000\176\000\137\0002\000\239\000\239\001\141\000\217\000\198\000\140\001\135\0017\000\144\000\168\000=\000\188\000\192\000\242\000/\0001\000W\000Y\000]\000_\000\216\000_\001\155\000\239\001\007\000\218\000h\000.\000\196\001\135\0017\000Y\000\173\000\177\000\230\000\179\000\230\000\179\000\236\000\179\000\250\000\179\001\002\000/\001\183\000\239\000\179\001\133\001\149\000h\000\020\000j\000\237\000\237\000.\000Y\001\149\001\153\000`\000\236\000.\000\179\000.\000\238\001\141\000.\000\179\000\179\000\236\000.\000\179\000.\000\134\0002\000k\0002\000\179\000,\000k\000]\000\179\000\211\000,\000\016\000,\000\221\001#\000\246\000k\000\246\000/\000\030\000h\000j\000\238\001\141\001W\000.\000j\000<\000h\001W\000\198\000n\000/\000L\000\016\000h\000\179\000\238\001\141\001G\000\209\000.\000j\000\169\000h\000\020\000\237\000.\000\142\000Y\000\198\000p\000N\000\252\001\135\0017\000\178\0017\000h\000.\000\255\000\238\000h\000\178\0017\000\141\001u\001s\000\\\000\245\000\251\000\004\000\020\0009\001U\000\198\000>\000\234\001\193\000\031\001\193\000\143\000\226\001\141\000\198\001\141\000;\000Z\000\020\000\245\000\198\000\251\000\\\000\251\001\183\001\t\000\218\000\018\001g\001\017\001g\001\133\000\234\000\251\001\007\000\198\001\t\000\218\000\234\001\t\000!\000\129\001\006\000!\001u\000\251\000.\000\251\000.\001s\000\\\000\203\001\001\000h\000.\001\001\000.\000\238\000\251\000.\000\203\001\183\001\007\001\133\001\001\000\162\000\134\000\136\000j\000\198\000\138\000j\000\210\000\214\000\140\001\135\0017\000\244\001\135\0017\000\164\001\135\0017\000\180\001\135\0017\000\250\000\179\000\n\000\182\001\135\0017\000h\000\020\000\237\000.\000\\\000\184\001\135\0017\000\179\000\162\000\186\001\135\0017\000\179\000\198\000\252\000-\000/\000[\000\166\000[\000\168\000j\000\212\000h\001\000\001\135\0017\000[\000\218\000h\000K\000[\000\030\000h\000j\000\232\001\141\000\238\001\141\000\232\001\141\000A\000.\000j\000<\000j\000L\000[\000\239\001\007\000\218\000h\000.\000D\000F\000Z\001\135\0017\001\001\000\238\000\251\000.\000^\000`\000n\000Y\000\238\001\141\000\198\000g\000u\000\230\000\239\000[\001\011\001\133\001\149\001\155\001\031\000\162\000g\001!\001K\000\162\000g\001\137\000&\001\137\000B\001\137\000D\001\137\000F\001\137\000H\001\137\000J\001\137\000^\001\137\000`\001\137\000t\001\137\000\150\001\137\000\152\001\137\000\154\001\137\000\156\001\137\000\158\001\137\000\176\001\137\000\198\001\137\000\230\001\137\000\234\001\137\000\236\001\137\000\248\001\137\001\b\001\137\001\n\001\137\001\183\001\149\000[\001\195\001\137\000,\000H\001\185\000g\000g\001\006\0017\000W\000\238\001\141\000\198\000g\000\171\000\198\000g\000\230\000\179\000\236\000\179\000\250\000\179\001\002\000/\001\183\000\173\000\175\000\230\000\179\001M\001O\000\130\001\185\000<\000\179\000\n\000g\000Z\000\020\001\135\0017\001g\000\198\000\251\000\213\000\161\0011\0011\001\135\0017\0000\000\255\000\198\001\001\000\238\000\251\000\198\001\001\001\005\0011\001\006\0017\000\255\001\005\0011\001;\001u\001\005\001;\000\255\001\005\0011\000v\001\185\000\128\001\185\000\160\001\135\0017\001\001\0011\000\194\001\135\0017\000/\000\238\000\135\000:\001g\000\218\001\141\000\165\000\198\000$\000\235\000\235\0011\001\141\000\196\001\135\0017\000\018\000h\000\236\000.\000\134\001\151\000P\000\138\000X\000\243\000j\000\238\000\135\000\218\001\193\000\163\0017\000,\0017\001\193\001Y\0004\001[\001Y\001]\000y\000&\001\187\001\145\001\187\000\198\000h\001\007\000\218\000h\001\149\0017\0011\000\238\000\135\000\218\001\145\000\\\001\187\001\187\001\145\000\\\001\187\001\187\001q\0017\0011\001\153\000\238\000\020\001\135\0017\000T\0009\000j\000\234\000\134\000\138\001Y\0004\000\216\000\250\001\151\001q\0017\000\149\000\250\001o\000\233\000\143\0011\001m\001o\001\141\000\198\000>\000\138\001Y\0004\000\216\001\143\001\151\001q\0017\000\138\001Y\0004\000\216\001\143\001\143\000?\000\143\0011\000=\000B\000>\000\157\000\145\0011\001o\001m\001o\0009\000j\000\234\000\233\000\143\0011\000?\000\143\0011\000=\000B\000\157\000\145\0011\000*\000N\000\252\001\135\0017\001\t\0011\001\135\0017\001\t\0011\000Z\000\020\001\135\0017\001g\000\234\000\251\0011\001\135\0017\000\018\000\234\001\t\0011\0000\000\255\000\238\000\251\0011\001\006\0017\000\255\000\238\000\251\0011\0019\0019\000\255\000\198\001\007\0011\000\238\000\251\001\003\0011\001u\001\003\000\160\001\135\0017\000\251\0011\000\196\001\135\0017\001\151\000\240\000\020\001\135\0017\000\012\000'\000\134\000{\0002\001}\000j\000\198\000R\0017\000h\001\141\000.\001\169\000\014\0017\000\012\000X\000X\000\012\000\241\000j\000\238\001\141\0011\000b\0017\000\012\000>\000>\000\012\000\155\000j\000\238\000\165\0011\000\148\0017\000p\000N\000\252\0017\001\007\000\162\000\134\000}\0002\001\157\000\230\001\141\001\141\001\133\001\157\001\165\001\183\0017\001\007\000\162\001\165\001\165\0011\000\226\0017\001\141\000\198\001\141\001\147\0011\001+\000\204\001_\0011\001\127\001\167\001+\001\165\0011\001\006\0017\000'\001}\000j\000\198\001\165\0011\001=\001=\001\135\0017\000'\001}\000j\000\238\000j\000\238\000C\000\\\000\134\001\141\000C\000\\\000\205\000C\000\\\001\023\001\133\001\161\001\165\001\161\001\161\001\161\0011\001\006\0017\000'\001}\000j\000\238\001\161\0011\001?\001?\000)\000a\000e\000\159\000\229\000\247\000\249\000\253\001/\001_\0011\001i\001\006\0017\0009\000j\000?\000\143\0011\0015\0015\001k\001\006\0017\0009\000j\000\234\000\233\000\143\0011\0013\0013\001\127\001\159\001/\000c\001/\001\141\000\240\001\135\0017\000'\001}\000j\000\198\000R\0017\001\171\000\014\000\252\0017\000\243\000j\000\198\000g\000A\000\198\000g\000+\0011\0017\000\012\000X\000X\000\012\000%\000j\000\238\001\141\000\243\000j\000\198\000g\000A\000\198\000g\000b\000\252\0017\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\165\000\198\000g\000Q\000Y\001Q\000A\000\198\000g\000Q\001{\001\025\0011\0017\000\012\000>\000>\000\012\000#\000j\000\238\000\165\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\165\000\198\000g\000Q\000\146\0017\000g\0011\000\148\000\252\0017\000h\000p\000H\001\185\0017\000\153\001O\0011\000N\000\252\0017\001\007\000\162\000\134\000}\0002\001\173\000\182\0017\001Q\000\\\001I\000\162\001\133\001\163\000\142\000[\000[\000\139\001S\001S\001\173\001\181\001\183\001\191\001\181\001\175\001\175\001\181\0017\001\007\000\162\001\181\0017\000\153\001O\0011\001\181\000.\000\238\001\161\000.\001\181\001\002\000j\000\219\0011\0017\001\181\000\219\0011\000\226\0017\001\147\0011\001)\000\204\001_\0011\001\127\001\179\001)\001\181\000\238\001\161\000\198\001\181\001Q\001\177\001\177\0011\001\006\0017\000'\001}\000j\001\177\0011\001A\001A\000)\000M\000p\001\135\0017\000\153\001O\0011\000S\000e\000\159\000\231\000\249\001\031\001\191\001-\001K\001\191\001_\0011\001i\0015\001\127\001\159\000O\000g\0011\001-\000\167\0002\001\031\001-\001K\000\167\0002\000\167\0002\0011\001\137\000\171\000\198\000g\001C\000\162\000g\001\004\001E\001E\000\252\000g\000.\000~\000\246\000o\000\246\001\137\000,\000o\000\134\0002\000o\0002\000\136\000m\000\172\000\138\000[\000\004\000i\001U\000A\000\207\000\215\000,\000i\000i\000\151\0004\001\007\000\218\000j\000/\000\212\000h\000o\000.\000r\001\137\000\134\000o\0002\000r\001\137\000\138\000o\0004\000r\001\137\000\218\000h\000g\000.\000r\001\137\000\134\000g\0002\000r\001\137\000\138\000g\0004\000r\001\137\001\007\000\212\000h\000o\000.\000r\001\137\000\134\000o\0002\000r\001\137\000\138\000o\0004\000r\001\137\001U\000r\001\137\000\139\001\137\000g\000.\000\134\000g\0002\000\138\000g\0004\001\007\000\212\000h\000o\000.\000\134\000o\0002\000\138\000o\0004\001U\000o\000.\000\134\000o\0002\000\138\000o\0004\000g\000\028\000\208\001\139\000g\000\224\000g\000\220\000g\000\224\000g\000\220\000\198\000g\001\139\000g\000\224\000g\000\220\000g\000h\000\020\000\237\000.\000\238\001\187\000\\\000g\001Q\001y\001y\001y\001Q\001y\000g\000\\\000g\000\\\000\218\000g\001\029\000\133\000\250\001\029\001\029\000g\000 \001\137\000\206\001\137\000\204\000g\000\204\000[\001\137\000\174\000[\000\151\0004\001\137\000\215\000,\000m\000\172\000m\000\172\000o\0002\000g\001\135\0017\001\001\000\162\000g\000Z\001\135\0017\000\255\001\005\000\162\000g\000\196\001\135\0017\001\151\001q\0017\000\162\000g\000g\001{\000Q\000g\000\209\000.\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\135\000\218\001\141\000\198\000g\000A\000\198\000g\000Q\001O\0011\001\137\000\246\000o\000\246\000[\000Z\001\135\0017\001\001\000.\000\238\000\251\000.\000g\000.\000A\000.\000g\000\004\000\133\000g\000\004\000\133\001\137\000.\000\232\000\251\000.\000\238\000\251\000.\000\232\000\251\000.\001\001\0011\001\135\0017\001\001\0011\000g\0011\001-\001-\000\167\0002\000\163\0017\000,\0017\000\216\001\027\001\187\000,\001\027\000\176\001\027\000\176\000C\000\\\001w\000w\000.\000\168\001\157\000=\000\230\001\141\001\141\000.\000\230\001\141\000\138\001Y\0004\000\216\001\141\001\143\000\233\000=\000B\000\157\000\250\001\151\000\198\001\149\0017\000\147\0011\001o\001\131\001m\001o\001\129\001\131\001\151\000\198\001\149\0017\0009\000j\000=\000B\000\157\000\147\0011\000O\000\204\001\001\000\251\000.\000\165\0011\000c\000\204\000\251\000.\000\179\000.\000\238\001\141\000.\001\171\001)\000\204\000g\000\004\000\133\000g\000\004\000\133\000\190\000g\000\190\000g\000g\000\224\000g\000\220\000\167\0002\0017\000g\000\224\000g\000\220\000O\000\202\001e\000\000\000c\000\202\001a\000\000\000h\000\236\000.\0001\000\201\001\t\000\218\000h\000\236\000.\0001\001g\001\019\001g\001\153\001\189\000\202\000\000\000\199\001\149\000\202\000\000\000\197\001\141\000\202\000\000\000g\000\202\000\195\000\000\000\193\001\t\000\202\000\000\000\191\001\007\000\202\000\000\000\189\001\001\000\202\000\000\000\187\000\251\000\202\000\000\000\185\000\245\000\202\000\000\000\179\000\202\000\183\000\000\000-\000\202\000\181\001\007\000\218\000\000\000\168\001g\000\026\000$\000\144\000\192\000-\001\007\000\202\000E\000G\000*\000M\001'\000g\0011\000*\001'\000*\000\000\000*\000G\000M\001%\001%\000g\0011\001%\001%\0003\000g\0011\001%\000\202\001%\000\202") + (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\000U\000\218\001\185\001\185\001\135\000\132\001\185\000\b\001\135\0017\000\016\000\018\000\022\001\135\0017\000\024\001\135\0017\000\026\000$\0008\000@\000R\001\135\0017\000h\000\016\000F\000\144\000\188\000`\000\144\000\188\000h\000&\000.\000@\000B\000D\000F\000H\000J\000Z\001\135\0017\000\016\000\018\000\255\000.\000\238\000\018\000(\0017\000\014\001\135\0017\000h\000F\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\001c\000.\000r\000\134\001c\0002\000r\000\138\001c\0004\000r\000\234\000\248\000\252\001\004\001\b\001\n\000\227\000.\000j\000/\000\238\000\016\000\018\000:\000\018\000j\001g\000<\000j\000\238\000L\000h\000:\001g\000Z\001\135\0017\000Z\000\020\000P\0017\000\016\000\"\0017\000\020\001\135\0017\000@\000F\000\252\000T\000`\000\252\000h\000\154\000\252\000F\000`\0005\000\016\000:\001g\0007\000;\000{\000.\000\230\000;\0009\000j\000\198\000\018\000>\000h\000j\000\238\000j\000t\000j\000\238\000x\001\185\000*\0006\000D\000F\000N\000\252\001\135\0017\000h\000\014\0017\000V\001\135\0017\000j\001\007\000\218\000\018\000j\001\r\001\015\001\173\001\183\0017\000^\000`\000d\001\135\0017\000f\001\135\0017\000h\000@\000~\000j\000r\000l\001\135\0017\0000\000\153\000~\000\134\0002\000\138\001\015\001#\0004\001U\000\238\000z\000\250\000\223\000|\0002\000\223\000\134\000\168\001\t\000h\001\t\000.\000\218\000\018\001\021\000\218\000j\001\023\001\157\000\250\000\254\001g\000=\000C\000\\\000s\000&\001\023\001\133\001\187\000\168\001\157\000=\000\205\000C\000\\\001w\001\187\000&\001\187\001w\000I\000q\000\127\0002\000\250\000q\000\239\000P\001\b\000\225\000\131\001\b\001w\001\193\001\002\000:\001g\0017\001\193\0017\001\141\001\183\001\193\000I\0002\000q\000\250\000\127\0002\000\127\0002\000\127\0002\000\176\000\137\0002\000\239\000\239\001\141\000\217\000\198\000\140\001\135\0017\000\144\000\168\000=\000\188\000\192\000\242\000/\0001\000W\000Y\000]\000_\000\216\000_\001\155\000\239\001\007\000\218\000h\000.\000\196\001\135\0017\000Y\000\173\000\177\000\230\000\179\000\230\000\179\000\236\000\179\000\250\000\179\001\002\000/\001\183\000\239\000\179\001\133\001\149\000h\000\020\000j\000\237\000\237\000.\000Y\001\149\001\153\000`\000\236\000.\000\179\000.\000\238\001\141\000.\000\179\000\179\000\236\000.\000\179\000.\000\134\0002\000k\0002\000\179\000,\000k\000]\000\179\000\211\000,\000\016\000,\000\221\001#\000\246\000k\000\246\000/\000\030\000h\000j\000\238\001\141\001W\000.\000j\000<\000h\001W\000\198\000n\000/\000L\000\016\000h\000\179\000\238\001\141\001G\000\209\000.\000j\000\169\000h\000\020\000\237\000.\000\142\000Y\000\198\000p\000N\000\252\001\135\0017\000\178\0017\000h\000.\000\255\000\238\000h\000.\000\\\000\178\0017\000\141\001u\001s\000\\\000\245\000\251\000\004\000\020\0009\001U\000\198\000>\000\234\001\193\000\031\001\193\000\143\000\226\001\141\000\198\001\141\000;\000Z\000\020\000\245\000\198\000\251\000\\\000\251\001\183\001\t\000\218\000\018\001g\001\017\001g\001\133\000\234\000\251\001\007\000\198\001\t\000\218\000\234\001\t\000!\000\129\001\006\000!\001u\000\251\000\251\000.\000\251\000.\001s\000\\\000\203\001\001\000h\000.\001\001\000.\000\238\000\251\000.\000\203\001\183\001\007\001\133\001\001\000\162\000\134\000\136\000j\000\198\000\138\000j\000\210\000\214\000\140\001\135\0017\000\244\001\135\0017\000\164\001\135\0017\000\180\001\135\0017\000\250\000\179\000\n\000\182\001\135\0017\000h\000\020\000\237\000.\000\\\000\184\001\135\0017\000\179\000\162\000\186\001\135\0017\000\179\000\198\000\252\000-\000/\000[\000\166\000[\000\168\000j\000\212\000h\001\000\001\135\0017\000[\000\218\000h\000K\000[\000\030\000h\000j\000\232\001\141\000\238\001\141\000\232\001\141\000A\000.\000j\000<\000j\000L\000[\000\239\001\007\000\218\000h\000.\000D\000F\000Z\001\135\0017\001\001\000\238\000\251\000.\000^\000`\000n\000Y\000\238\001\141\000\198\000g\000u\000\230\000\239\000[\001\011\001\133\001\149\001\155\001\031\000\162\000g\001!\001K\000\162\000g\001\137\000&\001\137\000B\001\137\000D\001\137\000F\001\137\000H\001\137\000J\001\137\000^\001\137\000`\001\137\000t\001\137\000\150\001\137\000\152\001\137\000\154\001\137\000\156\001\137\000\158\001\137\000\176\001\137\000\198\001\137\000\230\001\137\000\234\001\137\000\236\001\137\000\248\001\137\001\b\001\137\001\n\001\137\001\183\001\149\000[\001\195\001\137\000,\000H\001\185\000g\000g\001\006\0017\000W\000\238\001\141\000\198\000g\000\171\000\198\000g\000\230\000\179\000\236\000\179\000\250\000\179\001\002\000/\001\183\000\173\000\175\000\230\000\179\001M\001O\000\130\001\185\000<\000\179\000\n\000g\000Z\000\020\001\135\0017\001g\000\198\000\251\000\213\000\161\0011\0011\001\135\0017\0000\000\255\000\198\001\001\000\238\000\251\000\198\001\001\001\005\0011\001\006\0017\000\255\001\005\0011\001;\001u\001\005\001;\000\255\001\005\0011\000v\001\185\000\128\001\185\000\160\001\135\0017\001\001\0011\000\194\001\135\0017\000/\000\238\000\135\000:\001g\000\218\001\141\000\165\000\198\000$\000\235\000\235\0011\001\141\000\196\001\135\0017\000\018\000h\000\236\000.\000\134\001\151\000P\000\138\000X\000\243\000j\000\238\000\135\000\218\001\193\000\163\0017\000,\0017\001\193\001Y\0004\001[\001Y\001]\000y\000&\001\187\001\145\001\187\000\198\000h\001\007\000\218\000h\001\149\0017\0011\000\238\000\135\000\218\001\145\000\\\001\187\001\187\001\145\000\\\001\187\001\187\001q\0017\0011\001\153\000\238\000\020\001\135\0017\000T\0009\000j\000\234\000\134\000\138\001Y\0004\000\216\000\250\001\151\001q\0017\000\149\000\250\001o\000\233\000\143\0011\001m\001o\001\141\000\198\000>\000\138\001Y\0004\000\216\001\143\001\151\001q\0017\000\138\001Y\0004\000\216\001\143\001\143\000?\000\143\0011\000=\000B\000>\000\157\000\145\0011\001o\001m\001o\0009\000j\000\234\000\233\000\143\0011\000?\000\143\0011\000=\000B\000\157\000\145\0011\000*\000N\000\252\001\135\0017\001\t\0011\001\135\0017\001\t\0011\000Z\000\020\001\135\0017\001g\000\234\000\251\0011\001\135\0017\000\018\000\234\001\t\0011\0000\000\255\000\238\000\251\0011\001\006\0017\000\255\000\238\000\251\0011\0019\0019\000\255\000\198\001\007\0011\000\238\000\251\001\003\0011\001u\001\003\000\160\001\135\0017\000\251\0011\000\196\001\135\0017\001\151\000\240\000\020\001\135\0017\000\012\000'\000\134\000{\0002\001}\000j\000\198\000R\0017\000h\001\141\000.\001\169\000\014\0017\000\012\000X\000X\000\012\000\241\000j\000\238\001\141\0011\000b\0017\000\012\000>\000>\000\012\000\155\000j\000\238\000\165\0011\000\148\0017\000p\000N\000\252\0017\001\007\000\162\000\134\000}\0002\001\157\000\230\001\141\001\141\001\133\001\157\001\165\001\183\0017\001\007\000\162\001\165\001\165\0011\000\226\0017\001\141\000\198\001\141\001\147\0011\001+\000\204\001_\0011\001\127\001\167\001+\001\165\0011\001\006\0017\000'\001}\000j\000\198\001\165\0011\001=\001=\001\135\0017\000'\001}\000j\000\238\000j\000\238\000C\000\\\000\134\001\141\000C\000\\\000\205\000C\000\\\001\023\001\133\001\161\001\165\001\161\001\161\001\161\0011\001\006\0017\000'\001}\000j\000\238\001\161\0011\001?\001?\000)\000a\000e\000\159\000\229\000\247\000\249\000\253\001/\001_\0011\001i\001\006\0017\0009\000j\000?\000\143\0011\0015\0015\001k\001\006\0017\0009\000j\000\234\000\233\000\143\0011\0013\0013\001\127\001\159\001/\000c\001/\001\141\000\240\001\135\0017\000'\001}\000j\000\198\000R\0017\001\171\000\014\000\252\0017\000\243\000j\000\198\000g\000A\000\198\000g\000+\0011\0017\000\012\000X\000X\000\012\000%\000j\000\238\001\141\000\243\000j\000\198\000g\000A\000\198\000g\000b\000\252\0017\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\165\000\198\000g\000Q\000Y\001Q\000A\000\198\000g\000Q\001{\001\025\0011\0017\000\012\000>\000>\000\012\000#\000j\000\238\000\165\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\165\000\198\000g\000Q\000\146\0017\000g\0011\000\148\000\252\0017\000h\000p\000H\001\185\0017\000\153\001O\0011\000N\000\252\0017\001\007\000\162\000\134\000}\0002\001\173\000\182\0017\001Q\000\\\001I\000\162\001\133\001\163\000\142\000[\000[\000\139\001S\001S\001\173\001\181\001\183\001\191\001\181\001\175\001\175\001\181\0017\001\007\000\162\001\181\0017\000\153\001O\0011\001\181\000.\000\238\001\161\000.\001\181\001\002\000j\000\219\0011\0017\001\181\000\219\0011\000\226\0017\001\147\0011\001)\000\204\001_\0011\001\127\001\179\001)\001\181\000\238\001\161\000\198\001\181\001Q\001\177\001\177\0011\001\006\0017\000'\001}\000j\001\177\0011\001A\001A\000)\000M\000p\001\135\0017\000\153\001O\0011\000S\000e\000\159\000\231\000\249\001\031\001\191\001-\001K\001\191\001_\0011\001i\0015\001\127\001\159\000O\000g\0011\001-\000\167\0002\001\031\001-\001K\000\167\0002\000\167\0002\0011\001\137\000\171\000\198\000g\001C\000\162\000g\001\004\001E\001E\000\252\000g\000.\000~\000\246\000o\000\246\001\137\000,\000o\000\134\0002\000o\0002\000\136\000m\000\172\000\138\000[\000\004\000i\001U\000A\000\207\000\215\000,\000i\000i\000\151\0004\001\007\000\218\000j\000/\000\212\000h\000o\000.\000r\001\137\000\134\000o\0002\000r\001\137\000\138\000o\0004\000r\001\137\000\218\000h\000g\000.\000r\001\137\000\134\000g\0002\000r\001\137\000\138\000g\0004\000r\001\137\001\007\000\212\000h\000o\000.\000r\001\137\000\134\000o\0002\000r\001\137\000\138\000o\0004\000r\001\137\001U\000r\001\137\000\139\001\137\000g\000.\000\134\000g\0002\000\138\000g\0004\001\007\000\212\000h\000o\000.\000\134\000o\0002\000\138\000o\0004\001U\000o\000.\000\134\000o\0002\000\138\000o\0004\000g\000\028\000\208\001\139\000g\000\224\000g\000\220\000g\000\224\000g\000\220\000\198\000g\001\139\000g\000\224\000g\000\220\000g\000h\000\020\000\237\000.\000\238\001\187\000\\\000g\001Q\001y\001y\001y\001Q\001y\000g\000\\\000g\000\\\000\218\000g\001\029\000\133\000\250\001\029\001\029\000g\000 \001\137\000\206\001\137\000\204\000g\000\204\000[\001\137\000\174\000[\000\151\0004\001\137\000\215\000,\000m\000\172\000m\000\172\000o\0002\000g\001\135\0017\001\001\000\162\000g\000Z\001\135\0017\000\255\001\005\000\162\000g\000\196\001\135\0017\001\151\001q\0017\000\162\000g\000g\001{\000Q\000g\000\209\000.\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\135\000\218\001\141\000\198\000g\000A\000\198\000g\000Q\001O\0011\001\137\000\246\000o\000\246\000[\000Z\001\135\0017\001\001\000.\000\238\000\251\000.\000g\000.\000A\000.\000g\000\004\000\133\000g\000\004\000\133\001\137\000.\000\232\000\251\000.\000\238\000\251\000.\000\232\000\251\000.\001\001\0011\001\135\0017\001\001\0011\000g\0011\001-\001-\000\167\0002\000\163\0017\000,\0017\000\216\001\027\001\187\000,\001\027\000\176\001\027\000\176\000C\000\\\001w\000w\000.\000\168\001\157\000=\000\230\001\141\001\141\000.\000\230\001\141\000\138\001Y\0004\000\216\001\141\001\143\000\233\000=\000B\000\157\000\250\001\151\000\198\001\149\0017\000\147\0011\001o\001\131\001m\001o\001\129\001\131\001\151\000\198\001\149\0017\0009\000j\000=\000B\000\157\000\147\0011\000O\000\204\001\001\000\251\000.\000\165\0011\000c\000\204\000\251\000.\000\179\000.\000\238\001\141\000.\001\171\001)\000\204\000g\000\004\000\133\000g\000\004\000\133\000\190\000g\000\190\000g\000g\000\224\000g\000\220\000\167\0002\0017\000g\000\224\000g\000\220\000O\000\202\001e\000\000\000c\000\202\001a\000\000\000h\000\236\000.\0001\000\201\001\t\000\218\000h\000\236\000.\0001\001g\001\019\001g\001\153\001\189\000\202\000\000\000\199\001\149\000\202\000\000\000\197\001\141\000\202\000\000\000g\000\202\000\195\000\000\000\193\001\t\000\202\000\000\000\191\001\007\000\202\000\000\000\189\001\001\000\202\000\000\000\187\000\251\000\202\000\000\000\185\000\245\000\202\000\000\000\179\000\202\000\183\000\000\000-\000\202\000\181\001\007\000\218\000\000\000\168\001g\000\026\000$\000\144\000\192\000-\001\007\000\202\000E\000G\000*\000M\001'\000g\0011\000*\001'\000*\000\000\000*\000G\000M\001%\001%\000g\0011\001%\001%\0003\000g\0011\001%\000\202\001%\000\202") and rhs = - ((16, "\001e\001a\000\201\000\199\000\197\000\195\000\193\000\191\000\189\000\187\000\185\000\183\000\181\000E\0003\000F\000D\001w\001\193\001\002\000:\001g\001\006\0017\001O\0011\001\019\001\153\000h\001\141\000.\000h\000Z\001\135\0017\000\251\000.\000:\001g\000\016\000=\001\187\000=\000h\000w\000.\000=\000t\001\027\000\176\000t\000\176\000\168\001\157\001\187\000\168\001\157\000h\000w\000.\000\168\001\157\000\134\000I\0002\000\134\000\250\000\127\0002\000\134\000q\000\250\000\127\0002\000|\000\223\000\127\0002\000|\0002\000z\000\223\000\127\0002\000z\000\223\000\127\000\176\000\137\0002\001\133\000U\000U\000\218\001\185\000\132\001\185\000\167\0002\001\163\000\182\0017\001\175\001I\000\162\001\181\000p\000N\0017\001\007\000\162\001\181\000p\000N\000\252\0017\001\007\000\162\001\181\001\181\001\183\001\163\000\139\001\133\000\148\0017\001\181\000\219\0011\000\148\000\252\0017\001\181\000\219\0011\000\014\000+\0011\000b\001\025\0011\000\226\0017\001\147\0011\000\146\0017\000g\0011\001_\0011\001\127\000\198\001\181\000\238\001\161\000\198\001\181\001Q\001\177\001Q\000\\\001\181\001Q\001\175\001\015\000h\000\179\000.\000h\000\179\000\238\001\141\000.\000h\001\141\000.\000\148\0017\001\165\0011\000\014\0017\000\241\000j\000\238\001\141\0011\000b\0017\000\155\000j\000\238\000\165\0011\000\226\0017\001\147\0011\001_\0011\001\127\001\157\000\134\000}\0002\001\157\001\133\000R\0017\001\169\001+\000\204\001\165\001\183\000p\000N\0017\001\007\000\162\001\165\000p\000N\000\252\0017\001\007\000\162\001\165\000h\001\181\000.\001\173\000\134\000}\0002\001\173\000h\001\181\000\238\001\161\000.\000R\0017\001\171\001)\000\204\001\165\000\205\000C\000\\\001\161\000j\000\238\000C\000\\\001\161\000C\000\\\001\161\000\240\000\020\001\135\0017\000'\001}\000j\000\198\001\165\0011\001=\001\023\000\144\000\242\000$\000\188\000\134\0002\000h\000.\000\192\000\026\000\018\000h\000\236\000.\001\153\001\007\001\007\000\218\000h\000\236\000.\000h\000\236\000.\001\153\001\141\000\198\001\141\001\187\000y\000&\001\187\000\138\001Y\0004\000\250\000\149\001\193\001\141\001\183\000\028\000\208\001\031\000\162\000g\000d\001\135\0017\000g\000\004\000\133\000\022\001\135\0017\000g\000\022\001\135\0017\000g\000\004\000\133\000\022\001\135\0017\000g\000\190\000g\000\022\001\135\0017\000g\000\004\000\133\000\190\000g\000\006\001\135\0017\000g\000\224\000g\000\220\000\184\001\135\0017\000\179\000\198\000g\001\139\000g\000\224\000g\000\220\000\184\001\135\0017\000\179\000\162\000g\000\224\000g\000\220\000[\000p\000Z\001\135\0017\000\255\001\005\000\162\000g\000p\000\196\001\135\0017\001\151\001q\0017\000\162\000g\000p\000N\001\135\0017\001\001\000\162\000g\000p\000N\000\252\001\135\0017\001\001\000\162\000g\000\180\001\135\0017\000\133\000\182\001\135\0017\001Q\001y\000\182\001\135\0017\000h\000\020\000\237\000.\001y\000f\001\135\0017\000g\000\004\000\133\000\024\001\135\0017\000g\000\004\000\133\000\164\001\135\0017\000g\000 \001\137\000\206\001\137\000\164\001\135\0017\000g\000 \001\137\000\b\001\135\0017\000g\000\224\000g\000\220\000\186\001\135\0017\000\179\000\198\000g\001\139\000g\000\224\000g\000\220\001\000\001\135\0017\000[\000\140\001\135\0017\000[\000[\000\139\000u\001\149\000[\000\239\000[\001\137\000\158\001\137\001\137\000\156\001\137\001\137\000\154\001\137\001\137\000\152\001\137\001\137\000\150\001\137\001\137\000F\001\137\001\137\000D\001\137\001\137\000B\001\137\001\137\000`\001\137\001\137\000^\001\137\001\137\000&\001\137\001\137\000H\001\137\001\137\000\198\001\137\001\137\000t\001\137\001\137\000\176\001\137\001\137\000J\001\137\001\137\000\248\001\137\001\137\001\b\001\137\001\137\001\n\001\137\001\137\000\234\001\137\000K\001\137\001\195\001\137\001K\000\162\000g\000n\001C\000\162\000g\001\137\000\236\001\137\000j\000r\001\137\000[\000\218\001U\000r\001\137\000[\000\218\000h\000g\000.\000r\001\137\000[\000\218\000\138\000g\0004\000r\001\137\000[\000\218\000\134\000g\0002\000r\001\137\000[\000\212\000h\000o\000.\000r\001\137\000[\000\218\001\007\000\212\000h\000o\000.\000r\001\137\000[\000\212\000\138\000o\0004\000r\001\137\000[\000\218\001\007\000\212\000\138\000o\0004\000r\001\137\000[\000\212\000\134\000o\0002\000r\001\137\000[\000\218\001\007\000\212\000\134\000o\0002\000r\001\137\001\137\001\183\000H\001\185\000x\001\185\000\167\0002\0008\000\250\001\151\000\198\001\149\0017\001\151\000\198\001\149\0017\000\128\001\185\000\167\0002\000\134\000{\0002\000Q\000A\000\198\000g\000\\\000g\000\238\001\187\000\\\000g\001Q\001y\000h\000\020\000\237\000.\001y\000C\000\205\000C\000\\\001w\000j\000\238\000C\000\\\001w\000C\000\\\001w\000h\000.\000h\000\255\000\238\000\251\000.\000\141\000P\001\145\000\238\001\145\000\\\001\187\000\238\000\135\000\218\001\145\000\\\001\187\000\238\001\187\000\238\000\135\000\218\001\187\000\250\001\151\001q\0017\001\151\001q\0017\000\020\001\135\0017\0009\000j\000\234\000\233\000\143\0011\000\020\001\135\0017\000T\0009\000j\000\234\000\233\000\143\0011\000\020\001\135\0017\0009\000j\000?\000\143\0011\000\020\001\135\0017\000T\0009\000j\000?\000\143\0011\000\018\000j\000O\000\202\000,\000\216\000c\000\202\000v\001\185\000\167\0002\0006\000\243\000j\000\238\000\163\0017\000\243\000j\000\238\000\163\0017\000,\0017\001]\001[\001[\001Y\000j\000j\000\238\001\141\001\015\000[\000\142\000[\000\030\000j\000\030\000h\000j\000A\000.\000<\000j\000L\000[\000<\000h\001W\000\209\000.\000<\000j\000L\000h\001G\000\209\000.\000L\000\169\000\030\000h\001W\000.\000\030\000j\000\142\000Y\000Y\001M\000/\000/\000Q\000/\000A\000\198\000g\000/\000\238\000\135\000\218\001\141\000\198\000g\000/\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\171\000\198\000g\000W\000\238\001\141\000\198\000g\000p\001\135\0017\000\153\001O\0011\001K\001\191\000p\0017\000\153\001O\0011\000p\000H\001\185\0017\000\153\001O\0011\001I\001\191\000\179\000\179\000\238\001\141\000/\000Q\000/\000Y\000\238\001\141\000\198\000g\000\171\000\198\000g\001E\001C\001\004\001E\001\006\0017\000'\001}\000j\001\177\0011\001A\001\006\0017\000'\001}\000j\000\238\001\161\0011\001?\001\006\0017\000'\001}\000j\000\198\001\165\0011\001=\001\006\0017\000\255\001\005\0011\001;\001\006\0017\000\255\000\238\000\251\0011\0019\001\183\0017\001\006\0017\0009\000j\000?\000\143\0011\0015\001\006\0017\0009\000j\000\234\000\233\000\143\0011\0013\000\161\0011\000*\001/\000a\001/\000*\001-\000*\000g\0011\001-\000M\001-\001\167\001+\001\179\001)\000M\001'\000*\001%\000*\000g\0011\001%\000M\001%\000G\001%\001U\000\217\000\211\001U\000\217\000\211\000,\001U\000\217\000\211\000,\000\016\000\221\001U\000\217\000\211\000,\001#\000l\001\135\0017\000\153\001O\0011\001!\001\031\001\191\000\179\000\\\000g\000\179\000\n\000g\000\\\000g\000\179\000\\\000\218\000j\000\238\000\163\0017\000,\0017\001\027\001\187\000,\001\027\000j\000\238\000\163\0017\000,\0017\001\187\000,\000j\000\238\000\163\0017\001\187\000\216\0017\000#\000j\000\238\000\165\0017\000\157\000j\000Q\000\252\0017\000\157\000j\000Q\0017\000\157\000j\000\238\000\165\000\198\000g\000\252\0017\000\157\000j\000\238\000\165\000\198\000g\0017\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\252\0017\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000j\001\t\000\218\000j\000\018\001\t\000\218\000\018\001g\000h\000\236\000.\0001\001\t\000\218\001g\001\t\000\218\000h\000\236\000.\001\t\000\218\0001\001g\001\t\000\218\001g\000j\001\007\000\218\000j\000\018\001\007\000\218\000\018\000/\001\007\000\218\000/\001\021\001\t\000h\001\t\000.\001\r\000\198\001\001\000\238\000\251\000\198\001\001\001u\001\005\000\238\000\251\001u\001\003\000\"\0017\000O\000\204\000\178\0017\001s\000\\\001\001\000\203\001\001\001\183\001\007\001\001\000\203\001\001\000h\000.\001\133\000\016\000\018\000\016\000Z\001\135\0017\000\018\000\234\001\t\0011\000(\0017\000c\000\204\000\178\0017\001s\000\\\000\251\000Z\000\020\000P\0017\001\001\000h\000\251\000.\000\251\001\183\000\245\000\251\000\\\000\251\000\251\000\004\000\129\001\133\000Z\000\020\001\135\0017\001g\000\213\0011\000Z\000\020\001\135\0017\001g\000\234\000\251\0011\001\017\000X\000X\000\012\000X\000\012\000\012\000X\000\254\001g\000j\000j\000\237\000$\000$\000\235\001\141\000>\001\141\001\143\000>\001\143\001\141\000\198\001\143\001\141\000\198\000>\001\143\000\216\000>\000\216\001\141\000\198\000\216\001\141\000\198\000>\000\216\000\138\001Y\0004\000>\000\138\001Y\0004\001\141\000\198\000\138\001Y\0004\001\141\000\198\000>\000\138\001Y\0004\000N\001\135\0017\001\001\0011\000N\000\252\001\135\0017\001\001\0011\000N\001\135\0017\001\t\0011\000N\000\252\001\135\0017\001\t\0011\000@\000n\001\004\000\212\000h\001c\000.\000\212\000h\001c\000.\000r\000\212\000\134\001c\0002\000\212\000\134\001c\0002\000r\000\212\000\138\001c\0004\000\212\000\138\001c\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\141\000\198\001\137\000\198\000\251\000\198\000\179\000\198\000g\000A\000L\000<\000j\000\238\000h\001\001\000\238\000\251\000.\000h\001\001\000.\000h\000\014\0017\001\137\000.\000h\000\014\0017\001\137\000\238\000\251\000.\000h\000\014\0017\001\137\000\238\000\251\000\232\000\251\000.\000h\000\014\0017\001\137\000\232\000\251\000.\001\189\000\202\001\149\000\202\001\141\000\202\000g\000\202\001\t\000\202\001\007\000\202\001\001\000\202\000\251\000\202\000\245\000\202\000\179\000\202\000-\000\202\000\179\000\236\000\179\000\179\001\183\000\173\000\179\001\002\000/\000\177\000\179\000\250\000\179\000\196\001\135\0017\000\179\000\177\000\230\000\179\000\179\000\230\000\179\000\175\000\230\000\179\000\171\000\230\000\179\000Y\001\149\000\179\001\149\000h\000\020\000\237\000.\000Y\000\239\000\179\000\140\001\135\0017\000Y\000\171\000\236\000\179\000\171\001\183\000\173\000\171\001\002\000/\000\175\000\171\000\250\000\179\000j\000\016\000O\000\238\000c\000\238\001\141\000<\000\179\000<\000\179\000\n\000g\001\141\000\135\000\218\001\141\001\193\000\135\000\218\001\193\000\130\001\185\000\167\0002\000\194\001\135\0017\000/\000\238\000\165\000\198\000\235\0011\000>\000>\000\012\000>\000\012\000\012\000>\0000\000i\000[\000\004\000i\001m\001o\000\149\001o\001m\001\129\001o\001\131\000\147\001o\000\147\001\131\001m\001o\000\145\001o\000\143\000\226\001\141\000\198\001\141\001u\000\141\001u\001S\000\139\001S\000\239\000\137\000\239\000:\001g\000\135\000:\001g\001\029\000\250\001\029\000\133\000\250\001\029\001\193\000\131\001\b\001\193\000!\000\129\001\006\000!\000q\000\127\000\250\000q\001\141\000}\000\230\001\141\000;\000{\000\230\000;\001\187\000y\000&\001\187\000w\000\230\001\141\001\141\000\230\001\141\000u\000\230\001\137\001\137\000\230\001\137\000s\000&\001\187\001\187\000&\001\187\000I\001\141\001\137\001\137\000,\001\137\000,\000o\000j\000\215\000j\000\215\000,\000j\000\215\000,\000m\000\179\000\179\000,\000\179\000,\000k\001U\000\207\000\215\001U\000\207\000\215\000,\001U\000\207\000\215\000,\000i\001\137\001\137\000,\001\137\000,\000g\001\137\000,\000H\001\185\000g\000\196\001\135\0017\001\151\001q\0017\0011\001/\001_\0011\001\127\000)\000\159\001i\0015\001k\0013\000\020\001\135\0017\0009\000=\000B\000\157\000\145\0011\000\020\001\135\0017\000T\0009\000=\000B\000\157\000\145\0011\000e\000Z\001\135\0017\000\255\001\003\0011\000Z\001\135\0017\000\255\000\198\001\007\0011\000\253\000Z\001\135\0017\0000\000\255\000\238\000\251\0011\0019\000\249\000\247\000\229\000\160\001\135\0017\000\251\0011\000\240\001\135\0017\000'\001}\000j\000\238\001\161\0011\001?\001\159\001\155\000`\000\144\000`\000\188\000F\000\144\000F\000\188\000\138\001#\0004\000\134\000k\0002\000~\000k\000\246\000~\000\246\000\214\001\137\000\174\000\210\000[\000h\000g\000.\000h\000g\000A\000.\000[\000\218\000h\000g\000.\000[\000\218\000\138\000g\0004\000[\000\218\000\134\000g\0002\000[\000\212\000h\000o\000.\000[\000\218\001\007\000\212\000h\000o\000.\000[\000\212\000\138\000o\0004\000[\000\218\001\007\000\212\000\138\000o\0004\000[\000\212\000\134\000o\0002\000[\000\218\001\007\000\212\000\134\000o\0002\000\244\001\135\0017\000g\000\204\000\244\001\135\0017\000\204\000V\001\135\0017\001\173\000h\000Z\001\135\0017\001\001\000.\000h\000Z\001\135\0017\001\001\000\238\000\251\000.\000R\001\135\0017\001\171\001)\000\204\000-\001\155\001\149\000\239\000@\000[\000\252\000[\000\136\000m\000\172\000\136\000\172\000[\000\218\001U\001\007\000\218\000h\000g\000.\001\007\000\218\000\136\000m\000\172\000[\000\168\000j\000[\000\166\000[\001\133\000\016\001\007\000\218\000h\000.\000\138\000\151\0004\001\007\000\218\000\138\000\151\0004\000~\000o\000\246\000~\000\246\001\007\000\218\000~\000o\000\246\001\007\000\218\000~\000\246\000\134\000o\0002\001\007\000\218\000\134\000o\0002\001\007\000\218\000\134\0002\001\007\000\218\000h\000Z\001\135\0017\001\001\000\238\000\251\000.\000/\000W\000h\000\179\000.\000]\000h\000Z\001\135\0017\000\255\000.\000h\000Z\001\135\0017\000\255\000\238\000\251\000.\000\016\000_\000_\000\216\000_\001\149\000\239\000\168\000=\001\007\000\218\000]\001\007\000\218\000\134\0002\001\007\000\218\000h\000.\001\007\000\218\000h\000\179\000.\000h\000\179\000\238\001\141\000.\001\133\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\000e\000\196\001\135\0017\001\151\000\198\001\149\0017\0011\000\198\000g\001Q\001{\000h\000\020\000\237\000.\001{\001-\000g\0011\001-\001\031\001K\001_\0011\001\127\000\159\000)\001i\0015\000\020\001\135\0017\0009\000=\000B\000\157\000\147\0011\000\020\001\135\0017\000T\0009\000=\000B\000\157\000\147\0011\000S\000Z\001\135\0017\000\255\001\005\0011\000Z\001\135\0017\0000\000\255\001\005\0011\001;\000\249\000\231\000\240\001\135\0017\000'\001}\000j\001\177\0011\001A\001\159\000\160\001\135\0017\001\001\0011\000`\000^\000\239\000P\000\225\000\131\0017\000\239\0017\000\168\001g\000\168\001g\000$\000\168\001g\000\144\000\168\001g\000-\000\168\001g\001\007\000\168\001g\000\192\000\168\001g\000\026\000g\0011\000*\001'\000*\000G\000*\000\202\001\187\000s\000\238\001\141\000\238\001\141\000\232\001\141\000\232\001\141\000\198\000\233\001\023\0005\0007\000;\000h\000{\000.\000:\001g\000\016\000F\000`\000\252\000F\000\252\000\252\000F\000`\000\252\000\252\000`\000\154\000@\001%\000\202\000g\0011\001%\000\202\000h\000\227\000.\000j\0001\001\011\0017\000%\000j\000\238\001\141\0017\000\243\000j\000\198\000g\000\252\0017\000\243\000j\000\198\000g\0017\000\243\000j\000A\000\198\000g\000\252\0017\000\243\000j\000A\000\198\000g\000\014\001\135\0017\000/\000\238\000\165\0011\000\012\000\012\000X\000\012\000\012\000X\000\012\000>\000\012\000\012\000>\000\020\0009\001U\000\031\001\193\000\143\000\020\0009\001U\000\234\001\193\000Z\001\007\000\198\001\t\000Z\001\007\000\234\001\t\000Z\000\020\000\245\000\198\000\251\000Z\000\020\000\245\000\234\000\251\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\017\000\018\000\022\000\026\000\027\000\028\000\031\000%\000'\000(\000)\000+\000/\0002\0004\0006\0009\000>\000A\000E\000J\000N\000P\000T\000Z\000[\000\\\000_\000c\000d\000g\000j\000p\000w\000y\000{\000|\000\129\000\135\000\138\000\141\000\145\000\149\000\151\000\152\000\154\000\158\000\160\000\163\000\165\000\166\000\169\000\174\000\174\000\177\000\177\000\181\000\188\000\195\000\199\000\201\000\202\000\203\000\207\000\208\000\213\000\215\000\221\000\228\000\231\000\232\000\236\000\241\000\246\000\247\000\251\001\000\001\003\001\014\001\015\001\016\001\017\001\018\001\019\001\021\001\023\001\024\001\025\001\026\001\029\001\030\001\031\001$\001'\001(\001+\001,\001/\0012\0013\0014\0015\0017\0018\0019\001<\001B\001F\001L\001R\001Z\001a\001l\001u\001v\001~\001\135\001\142\001\150\001\154\001\159\001\167\001\173\001\179\001\187\001\193\001\200\001\211\001\215\001\219\001\221\001\222\001\224\001\226\001\229\001\232\001\235\001\238\001\241\001\244\001\247\001\250\001\253\002\000\002\003\002\006\002\t\002\012\002\015\002\018\002\021\002\024\002\027\002\030\002 \002\"\002%\002)\002,\002/\0024\002;\002B\002I\002P\002Y\002`\002i\002p\002y\002{\002{\002}\002\129\002\130\002\135\002\139\002\143\002\143\002\146\002\147\002\150\002\152\002\156\002\158\002\163\002\164\002\168\002\173\002\176\002\178\002\183\002\184\002\184\002\186\002\190\002\196\002\198\002\202\002\206\002\209\002\218\002\228\002\236\002\245\002\246\002\247\002\249\002\249\002\251\002\253\003\001\003\002\003\007\003\014\003\015\003\016\003\018\003\019\003\022\003\023\003\024\003\026\003\028\003!\003#\003%\003*\003,\0031\0033\0037\0039\003;\003<\003=\003>\003@\003D\003K\003S\003V\003[\003a\003c\003h\003o\003q\003r\003u\003w\003x\003}\003\128\003\129\003\132\003\132\003\140\003\140\003\149\003\149\003\158\003\158\003\164\003\164\003\171\003\171\003\173\003\173\003\181\003\181\003\190\003\190\003\192\003\192\003\194\003\196\003\196\003\198\003\202\003\204\003\204\003\206\003\206\003\208\003\208\003\210\003\210\003\212\003\216\003\218\003\220\003\223\003\227\003\233\003\238\003\244\003\245\003\247\003\250\003\255\004\002\004\t\004\012\004\018\004\020\004\024\004\025\004\026\004\031\004#\004(\004/\0047\004A\004L\004M\004P\004Q\004T\004U\004X\004Y\004\\\004a\004d\004e\004h\004i\004l\004m\004p\004q\004t\004u\004y\004z\004|\004\128\004\130\004\132\004\134\004\138\004\143\004\144\004\146\004\147\004\149\004\152\004\153\004\154\004\155\004\156\004\163\004\167\004\172\004\177\004\180\004\182\004\183\004\186\004\189\004\190\004\197\004\205\004\206\004\206\004\207\004\207\004\208\004\209\004\211\004\213\004\215\004\216\004\218\004\219\004\221\004\222\004\224\004\225\004\227\004\230\004\234\004\235\004\237\004\240\004\244\004\247\004\251\005\000\005\006\005\011\005\017\005\022\005\028\005\029\005\030\005\031\005#\005(\005,\0051\0055\005:\005;\005<\005=\005>\005?\005@\005A\005B\005C\005D\005E\005F\005G\005H\005I\005J\005K\005L\005M\005N\005O\005P\005Q\005Q\005Q\005R\005R\005S\005S\005U\005U\005W\005W\005Y\005Y\005[\005[\005]\005]\005_\005_\005`\005a\005d\005i\005l\005q\005x\005\129\005\136\005\138\005\140\005\142\005\144\005\146\005\148\005\150\005\152\005\154\005\156\005\158\005\161\005\163\005\164\005\167\005\168\005\171\005\175\005\178\005\181\005\184\005\187\005\188\005\190\005\196\005\198\005\202\005\205\005\207\005\208\005\211\005\212\005\215\005\216\005\217\005\218\005\220\005\222\005\224\005\228\005\229\005\232\005\233\005\236\005\240\005\249\005\249\005\250\005\250\005\251\005\252\005\254\006\000\006\000\006\001\006\002\006\005\006\006\006\007\006\t\006\n\006\011\006\012\006\r\006\015\006\017\006\018\006\019\006\021\006\021\006\026\006\027\006\029\006\030\006 \006!\006#\006%\006(\006)\006+\006.\006/\0062\0063\0066\0067\006:\006;\006>\006?\006B\006C\006F\006I\006L\006O\006R\006U\006X\006Y\006Z\006[\006]\006`\006b\006e\006i\006j\006l\006o\006r\006v\006{\006|\006~\006\129\006\134\006\141\006\142\006\144\006\145\006\146\006\147\006\149\006\151\006\160\006\170\006\171\006\177\006\184\006\185\006\194\006\195\006\196\006\197\006\202\006\212\006\213\006\214\006\216\006\218\006\220\006\222\006\225\006\228\006\231\006\233\006\236\006\238\006\241\006\245\006\250\006\255\007\004\007\t\007\016\007\021\007\028\007!\007(\007-\0071\0075\007;\007C\007I\007J\007K\007L\007M\007O\007Q\007T\007V\007Y\007^\007c\007f\007i\007j\007k\007o\007r\007w\007z\007|\007\129\007\133\007\136\007\141\007\145\007\155\007\156\007\157\007\160\007\161\007\167\007\175\007\176\007\177\007\180\007\181\007\182\007\184\007\187\007\191\007\195\007\200\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\238\007\239\007\240\007\241\007\242\007\243\007\244\007\245\007\246\007\247\007\248\007\249\007\250\007\251\007\252\007\253\007\254\007\255\b\000\b\001\b\002\b\n\b\012\b\014\b\019\b\020\b\023\b\024\b\025\b\027\b\028\b\029\b\030\b \b)\b3\b4\b:\bB\bC\bD\bM\bN\bS\bT\bU\bZ\b\\\b^\ba\bd\bg\bj\bm\bp\bs\bu\bw\bx\by\bz\b|\b\128\b\130\b\130\b\132\b\133\b\135\b\135\b\136\b\139\b\141\b\142\b\142\b\143\b\144\b\145\b\147\b\149\b\151\b\153\b\154\b\155\b\157\b\161\b\164\b\165\b\166\b\167\b\172\b\177\b\183\b\189\b\196\b\203\b\203\b\204\b\205\b\207\b\209\b\210\b\212\b\214\b\220\b\225\b\229\b\233\b\238\b\243\b\244\b\246")) + ((16, "\001e\001a\000\201\000\199\000\197\000\195\000\193\000\191\000\189\000\187\000\185\000\183\000\181\000E\0003\000F\000D\001w\001\193\001\002\000:\001g\001\006\0017\001O\0011\001\019\001\153\000h\001\141\000.\000h\000Z\001\135\0017\000\251\000.\000:\001g\000\016\000=\001\187\000=\000h\000w\000.\000=\000t\001\027\000\176\000t\000\176\000\168\001\157\001\187\000\168\001\157\000h\000w\000.\000\168\001\157\000\134\000I\0002\000\134\000\250\000\127\0002\000\134\000q\000\250\000\127\0002\000|\000\223\000\127\0002\000|\0002\000z\000\223\000\127\0002\000z\000\223\000\127\000\176\000\137\0002\001\133\000U\000U\000\218\001\185\000\132\001\185\000\167\0002\001\163\000\182\0017\001\175\001I\000\162\001\181\000p\000N\0017\001\007\000\162\001\181\000p\000N\000\252\0017\001\007\000\162\001\181\001\181\001\183\001\163\000\139\001\133\000\148\0017\001\181\000\219\0011\000\148\000\252\0017\001\181\000\219\0011\000\014\000+\0011\000b\001\025\0011\000\226\0017\001\147\0011\000\146\0017\000g\0011\001_\0011\001\127\000\198\001\181\000\238\001\161\000\198\001\181\001Q\001\177\001Q\000\\\001\181\001Q\001\175\001\015\000h\000\179\000.\000h\000\179\000\238\001\141\000.\000h\001\141\000.\000\148\0017\001\165\0011\000\014\0017\000\241\000j\000\238\001\141\0011\000b\0017\000\155\000j\000\238\000\165\0011\000\226\0017\001\147\0011\001_\0011\001\127\001\157\000\134\000}\0002\001\157\001\133\000R\0017\001\169\001+\000\204\001\165\001\183\000p\000N\0017\001\007\000\162\001\165\000p\000N\000\252\0017\001\007\000\162\001\165\000h\001\181\000.\001\173\000\134\000}\0002\001\173\000h\001\181\000\238\001\161\000.\000R\0017\001\171\001)\000\204\001\165\000\205\000C\000\\\001\161\000j\000\238\000C\000\\\001\161\000C\000\\\001\161\000\240\000\020\001\135\0017\000'\001}\000j\000\198\001\165\0011\001=\001\023\000\144\000\242\000$\000\188\000\134\0002\000h\000.\000\192\000\026\000\018\000h\000\236\000.\001\153\001\007\001\007\000\218\000h\000\236\000.\000h\000\236\000.\001\153\001\141\000\198\001\141\001\187\000y\000&\001\187\000\138\001Y\0004\000\250\000\149\001\193\001\141\001\183\000\028\000\208\001\031\000\162\000g\000d\001\135\0017\000g\000\004\000\133\000\022\001\135\0017\000g\000\022\001\135\0017\000g\000\004\000\133\000\022\001\135\0017\000g\000\190\000g\000\022\001\135\0017\000g\000\004\000\133\000\190\000g\000\006\001\135\0017\000g\000\224\000g\000\220\000\184\001\135\0017\000\179\000\198\000g\001\139\000g\000\224\000g\000\220\000\184\001\135\0017\000\179\000\162\000g\000\224\000g\000\220\000[\000p\000Z\001\135\0017\000\255\001\005\000\162\000g\000p\000\196\001\135\0017\001\151\001q\0017\000\162\000g\000p\000N\001\135\0017\001\001\000\162\000g\000p\000N\000\252\001\135\0017\001\001\000\162\000g\000\180\001\135\0017\000\133\000\182\001\135\0017\001Q\001y\000\182\001\135\0017\000h\000\020\000\237\000.\001y\000f\001\135\0017\000g\000\004\000\133\000\024\001\135\0017\000g\000\004\000\133\000\164\001\135\0017\000g\000 \001\137\000\206\001\137\000\164\001\135\0017\000g\000 \001\137\000\b\001\135\0017\000g\000\224\000g\000\220\000\186\001\135\0017\000\179\000\198\000g\001\139\000g\000\224\000g\000\220\001\000\001\135\0017\000[\000\140\001\135\0017\000[\000[\000\139\000u\001\149\000[\000\239\000[\001\137\000\158\001\137\001\137\000\156\001\137\001\137\000\154\001\137\001\137\000\152\001\137\001\137\000\150\001\137\001\137\000F\001\137\001\137\000D\001\137\001\137\000B\001\137\001\137\000`\001\137\001\137\000^\001\137\001\137\000&\001\137\001\137\000H\001\137\001\137\000\198\001\137\001\137\000t\001\137\001\137\000\176\001\137\001\137\000J\001\137\001\137\000\248\001\137\001\137\001\b\001\137\001\137\001\n\001\137\001\137\000\234\001\137\000K\001\137\001\195\001\137\001K\000\162\000g\000n\001C\000\162\000g\001\137\000\236\001\137\000j\000r\001\137\000[\000\218\001U\000r\001\137\000[\000\218\000h\000g\000.\000r\001\137\000[\000\218\000\138\000g\0004\000r\001\137\000[\000\218\000\134\000g\0002\000r\001\137\000[\000\212\000h\000o\000.\000r\001\137\000[\000\218\001\007\000\212\000h\000o\000.\000r\001\137\000[\000\212\000\138\000o\0004\000r\001\137\000[\000\218\001\007\000\212\000\138\000o\0004\000r\001\137\000[\000\212\000\134\000o\0002\000r\001\137\000[\000\218\001\007\000\212\000\134\000o\0002\000r\001\137\001\137\001\183\000H\001\185\000x\001\185\000\167\0002\0008\000\250\001\151\000\198\001\149\0017\001\151\000\198\001\149\0017\000\128\001\185\000\167\0002\000\134\000{\0002\000Q\000A\000\198\000g\000\\\000g\000\238\001\187\000\\\000g\001Q\001y\000h\000\020\000\237\000.\001y\000C\000\205\000C\000\\\001w\000j\000\238\000C\000\\\001w\000C\000\\\001w\000h\000.\000h\000\255\000\238\000\251\000.\000\141\000P\001\145\000\238\001\145\000\\\001\187\000\238\000\135\000\218\001\145\000\\\001\187\000\238\001\187\000\238\000\135\000\218\001\187\000\250\001\151\001q\0017\001\151\001q\0017\000\020\001\135\0017\0009\000j\000\234\000\233\000\143\0011\000\020\001\135\0017\000T\0009\000j\000\234\000\233\000\143\0011\000\020\001\135\0017\0009\000j\000?\000\143\0011\000\020\001\135\0017\000T\0009\000j\000?\000\143\0011\000\018\000j\000O\000\202\000,\000\216\000c\000\202\000v\001\185\000\167\0002\0006\000\243\000j\000\238\000\163\0017\000\243\000j\000\238\000\163\0017\000,\0017\001]\001[\001[\001Y\000j\000j\000\238\001\141\001\015\000[\000\142\000[\000\030\000j\000\030\000h\000j\000A\000.\000<\000j\000L\000[\000<\000h\001W\000\209\000.\000<\000j\000L\000h\001G\000\209\000.\000L\000\169\000\030\000h\001W\000.\000\030\000j\000\142\000Y\000Y\001M\000/\000/\000Q\000/\000A\000\198\000g\000/\000\238\000\135\000\218\001\141\000\198\000g\000/\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\171\000\198\000g\000W\000\238\001\141\000\198\000g\000p\001\135\0017\000\153\001O\0011\001K\001\191\000p\0017\000\153\001O\0011\000p\000H\001\185\0017\000\153\001O\0011\001I\001\191\000\179\000\179\000\238\001\141\000/\000Q\000/\000Y\000\238\001\141\000\198\000g\000\171\000\198\000g\001E\001C\001\004\001E\001\006\0017\000'\001}\000j\001\177\0011\001A\001\006\0017\000'\001}\000j\000\238\001\161\0011\001?\001\006\0017\000'\001}\000j\000\198\001\165\0011\001=\001\006\0017\000\255\001\005\0011\001;\001\006\0017\000\255\000\238\000\251\0011\0019\001\183\0017\001\006\0017\0009\000j\000?\000\143\0011\0015\001\006\0017\0009\000j\000\234\000\233\000\143\0011\0013\000\161\0011\000*\001/\000a\001/\000*\001-\000*\000g\0011\001-\000M\001-\001\167\001+\001\179\001)\000M\001'\000*\001%\000*\000g\0011\001%\000M\001%\000G\001%\001U\000\217\000\211\001U\000\217\000\211\000,\001U\000\217\000\211\000,\000\016\000\221\001U\000\217\000\211\000,\001#\000l\001\135\0017\000\153\001O\0011\001!\001\031\001\191\000\179\000\\\000g\000\179\000\n\000g\000\\\000g\000\179\000\\\000\218\000j\000\238\000\163\0017\000,\0017\001\027\001\187\000,\001\027\000j\000\238\000\163\0017\000,\0017\001\187\000,\000j\000\238\000\163\0017\001\187\000\216\0017\000#\000j\000\238\000\165\0017\000\157\000j\000Q\000\252\0017\000\157\000j\000Q\0017\000\157\000j\000\238\000\165\000\198\000g\000\252\0017\000\157\000j\000\238\000\165\000\198\000g\0017\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\252\0017\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000j\001\t\000\218\000j\000\018\001\t\000\218\000\018\001g\000h\000\236\000.\0001\001\t\000\218\001g\001\t\000\218\000h\000\236\000.\001\t\000\218\0001\001g\001\t\000\218\001g\000j\001\007\000\218\000j\000\018\001\007\000\218\000\018\000/\001\007\000\218\000/\001\021\001\t\000h\001\t\000.\001\r\000\198\001\001\000\238\000\251\000\198\001\001\001u\001\005\000\238\000\251\001u\001\003\000\"\0017\000O\000\204\000\178\0017\001s\000\\\001\001\000\203\001\001\001\183\001\007\001\001\000\203\001\001\000h\000.\001\133\000\016\000\018\000\016\000Z\001\135\0017\000\018\000\234\001\t\0011\000(\0017\000c\000\204\000\178\0017\001s\000\\\000\251\000Z\000\020\000P\0017\001\001\000h\000\251\000.\000\251\001\183\000\245\000h\000.\000\\\000\251\000\251\000\\\000\251\000\251\000\004\000\129\001\133\000Z\000\020\001\135\0017\001g\000\213\0011\000Z\000\020\001\135\0017\001g\000\234\000\251\0011\001\017\000X\000X\000\012\000X\000\012\000\012\000X\000\254\001g\000j\000j\000\237\000$\000$\000\235\001\141\000>\001\141\001\143\000>\001\143\001\141\000\198\001\143\001\141\000\198\000>\001\143\000\216\000>\000\216\001\141\000\198\000\216\001\141\000\198\000>\000\216\000\138\001Y\0004\000>\000\138\001Y\0004\001\141\000\198\000\138\001Y\0004\001\141\000\198\000>\000\138\001Y\0004\000N\001\135\0017\001\001\0011\000N\000\252\001\135\0017\001\001\0011\000N\001\135\0017\001\t\0011\000N\000\252\001\135\0017\001\t\0011\000@\000n\001\004\000\212\000h\001c\000.\000\212\000h\001c\000.\000r\000\212\000\134\001c\0002\000\212\000\134\001c\0002\000r\000\212\000\138\001c\0004\000\212\000\138\001c\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\141\000\198\001\137\000\198\000\251\000\198\000\179\000\198\000g\000A\000L\000<\000j\000\238\000h\001\001\000\238\000\251\000.\000h\001\001\000.\000h\000\014\0017\001\137\000.\000h\000\014\0017\001\137\000\238\000\251\000.\000h\000\014\0017\001\137\000\238\000\251\000\232\000\251\000.\000h\000\014\0017\001\137\000\232\000\251\000.\001\189\000\202\001\149\000\202\001\141\000\202\000g\000\202\001\t\000\202\001\007\000\202\001\001\000\202\000\251\000\202\000\245\000\202\000\179\000\202\000-\000\202\000\179\000\236\000\179\000\179\001\183\000\173\000\179\001\002\000/\000\177\000\179\000\250\000\179\000\196\001\135\0017\000\179\000\177\000\230\000\179\000\179\000\230\000\179\000\175\000\230\000\179\000\171\000\230\000\179\000Y\001\149\000\179\001\149\000h\000\020\000\237\000.\000Y\000\239\000\179\000\140\001\135\0017\000Y\000\171\000\236\000\179\000\171\001\183\000\173\000\171\001\002\000/\000\175\000\171\000\250\000\179\000j\000\016\000O\000\238\000c\000\238\001\141\000<\000\179\000<\000\179\000\n\000g\001\141\000\135\000\218\001\141\001\193\000\135\000\218\001\193\000\130\001\185\000\167\0002\000\194\001\135\0017\000/\000\238\000\165\000\198\000\235\0011\000>\000>\000\012\000>\000\012\000\012\000>\0000\000i\000[\000\004\000i\001m\001o\000\149\001o\001m\001\129\001o\001\131\000\147\001o\000\147\001\131\001m\001o\000\145\001o\000\143\000\226\001\141\000\198\001\141\001u\000\141\001u\001S\000\139\001S\000\239\000\137\000\239\000:\001g\000\135\000:\001g\001\029\000\250\001\029\000\133\000\250\001\029\001\193\000\131\001\b\001\193\000!\000\129\001\006\000!\000q\000\127\000\250\000q\001\141\000}\000\230\001\141\000;\000{\000\230\000;\001\187\000y\000&\001\187\000w\000\230\001\141\001\141\000\230\001\141\000u\000\230\001\137\001\137\000\230\001\137\000s\000&\001\187\001\187\000&\001\187\000I\001\141\001\137\001\137\000,\001\137\000,\000o\000j\000\215\000j\000\215\000,\000j\000\215\000,\000m\000\179\000\179\000,\000\179\000,\000k\001U\000\207\000\215\001U\000\207\000\215\000,\001U\000\207\000\215\000,\000i\001\137\001\137\000,\001\137\000,\000g\001\137\000,\000H\001\185\000g\000\196\001\135\0017\001\151\001q\0017\0011\001/\001_\0011\001\127\000)\000\159\001i\0015\001k\0013\000\020\001\135\0017\0009\000=\000B\000\157\000\145\0011\000\020\001\135\0017\000T\0009\000=\000B\000\157\000\145\0011\000e\000Z\001\135\0017\000\255\001\003\0011\000Z\001\135\0017\000\255\000\198\001\007\0011\000\253\000Z\001\135\0017\0000\000\255\000\238\000\251\0011\0019\000\249\000\247\000\229\000\160\001\135\0017\000\251\0011\000\240\001\135\0017\000'\001}\000j\000\238\001\161\0011\001?\001\159\001\155\000`\000\144\000`\000\188\000F\000\144\000F\000\188\000\138\001#\0004\000\134\000k\0002\000~\000k\000\246\000~\000\246\000\214\001\137\000\174\000\210\000[\000h\000g\000.\000h\000g\000A\000.\000[\000\218\000h\000g\000.\000[\000\218\000\138\000g\0004\000[\000\218\000\134\000g\0002\000[\000\212\000h\000o\000.\000[\000\218\001\007\000\212\000h\000o\000.\000[\000\212\000\138\000o\0004\000[\000\218\001\007\000\212\000\138\000o\0004\000[\000\212\000\134\000o\0002\000[\000\218\001\007\000\212\000\134\000o\0002\000\244\001\135\0017\000g\000\204\000\244\001\135\0017\000\204\000V\001\135\0017\001\173\000h\000Z\001\135\0017\001\001\000.\000h\000Z\001\135\0017\001\001\000\238\000\251\000.\000R\001\135\0017\001\171\001)\000\204\000-\001\155\001\149\000\239\000@\000[\000\252\000[\000\136\000m\000\172\000\136\000\172\000[\000\218\001U\001\007\000\218\000h\000g\000.\001\007\000\218\000\136\000m\000\172\000[\000\168\000j\000[\000\166\000[\001\133\000\016\001\007\000\218\000h\000.\000\138\000\151\0004\001\007\000\218\000\138\000\151\0004\000~\000o\000\246\000~\000\246\001\007\000\218\000~\000o\000\246\001\007\000\218\000~\000\246\000\134\000o\0002\001\007\000\218\000\134\000o\0002\001\007\000\218\000\134\0002\001\007\000\218\000h\000Z\001\135\0017\001\001\000\238\000\251\000.\000/\000W\000h\000\179\000.\000]\000h\000Z\001\135\0017\000\255\000.\000h\000Z\001\135\0017\000\255\000\238\000\251\000.\000\016\000_\000_\000\216\000_\001\149\000\239\000\168\000=\001\007\000\218\000]\001\007\000\218\000\134\0002\001\007\000\218\000h\000.\001\007\000\218\000h\000\179\000.\000h\000\179\000\238\001\141\000.\001\133\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\000e\000\196\001\135\0017\001\151\000\198\001\149\0017\0011\000\198\000g\001Q\001{\000h\000\020\000\237\000.\001{\001-\000g\0011\001-\001\031\001K\001_\0011\001\127\000\159\000)\001i\0015\000\020\001\135\0017\0009\000=\000B\000\157\000\147\0011\000\020\001\135\0017\000T\0009\000=\000B\000\157\000\147\0011\000S\000Z\001\135\0017\000\255\001\005\0011\000Z\001\135\0017\0000\000\255\001\005\0011\001;\000\249\000\231\000\240\001\135\0017\000'\001}\000j\001\177\0011\001A\001\159\000\160\001\135\0017\001\001\0011\000`\000^\000\239\000P\000\225\000\131\0017\000\239\0017\000\168\001g\000\168\001g\000$\000\168\001g\000\144\000\168\001g\000-\000\168\001g\001\007\000\168\001g\000\192\000\168\001g\000\026\000g\0011\000*\001'\000*\000G\000*\000\202\001\187\000s\000\238\001\141\000\238\001\141\000\232\001\141\000\232\001\141\000\198\000\233\001\023\0005\0007\000;\000h\000{\000.\000:\001g\000\016\000F\000`\000\252\000F\000\252\000\252\000F\000`\000\252\000\252\000`\000\154\000@\001%\000\202\000g\0011\001%\000\202\000h\000\227\000.\000j\0001\001\011\0017\000%\000j\000\238\001\141\0017\000\243\000j\000\198\000g\000\252\0017\000\243\000j\000\198\000g\0017\000\243\000j\000A\000\198\000g\000\252\0017\000\243\000j\000A\000\198\000g\000\014\001\135\0017\000/\000\238\000\165\0011\000\012\000\012\000X\000\012\000\012\000X\000\012\000>\000\012\000\012\000>\000\020\0009\001U\000\031\001\193\000\143\000\020\0009\001U\000\234\001\193\000Z\001\007\000\198\001\t\000Z\001\007\000\234\001\t\000Z\000\020\000\245\000\198\000\251\000Z\000\020\000\245\000\234\000\251\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\017\000\018\000\022\000\026\000\027\000\028\000\031\000%\000'\000(\000)\000+\000/\0002\0004\0006\0009\000>\000A\000E\000J\000N\000P\000T\000Z\000[\000\\\000_\000c\000d\000g\000j\000p\000w\000y\000{\000|\000\129\000\135\000\138\000\141\000\145\000\149\000\151\000\152\000\154\000\158\000\160\000\163\000\165\000\166\000\169\000\174\000\174\000\177\000\177\000\181\000\188\000\195\000\199\000\201\000\202\000\203\000\207\000\208\000\213\000\215\000\221\000\228\000\231\000\232\000\236\000\241\000\246\000\247\000\251\001\000\001\003\001\014\001\015\001\016\001\017\001\018\001\019\001\021\001\023\001\024\001\025\001\026\001\029\001\030\001\031\001$\001'\001(\001+\001,\001/\0012\0013\0014\0015\0017\0018\0019\001<\001B\001F\001L\001R\001Z\001a\001l\001u\001v\001~\001\135\001\142\001\150\001\154\001\159\001\167\001\173\001\179\001\187\001\193\001\200\001\211\001\215\001\219\001\221\001\222\001\224\001\226\001\229\001\232\001\235\001\238\001\241\001\244\001\247\001\250\001\253\002\000\002\003\002\006\002\t\002\012\002\015\002\018\002\021\002\024\002\027\002\030\002 \002\"\002%\002)\002,\002/\0024\002;\002B\002I\002P\002Y\002`\002i\002p\002y\002{\002{\002}\002\129\002\130\002\135\002\139\002\143\002\143\002\146\002\147\002\150\002\152\002\156\002\158\002\163\002\164\002\168\002\173\002\176\002\178\002\183\002\184\002\184\002\186\002\190\002\196\002\198\002\202\002\206\002\209\002\218\002\228\002\236\002\245\002\246\002\247\002\249\002\249\002\251\002\253\003\001\003\002\003\007\003\014\003\015\003\016\003\018\003\019\003\022\003\023\003\024\003\026\003\028\003!\003#\003%\003*\003,\0031\0033\0037\0039\003;\003<\003=\003>\003@\003D\003K\003S\003V\003[\003a\003c\003h\003o\003q\003r\003u\003w\003x\003}\003\128\003\129\003\132\003\132\003\140\003\140\003\149\003\149\003\158\003\158\003\164\003\164\003\171\003\171\003\173\003\173\003\181\003\181\003\190\003\190\003\192\003\192\003\194\003\196\003\196\003\198\003\202\003\204\003\204\003\206\003\206\003\208\003\208\003\210\003\210\003\212\003\216\003\218\003\220\003\223\003\227\003\233\003\238\003\244\003\245\003\247\003\250\003\255\004\002\004\t\004\012\004\018\004\020\004\024\004\025\004\026\004\031\004#\004(\004/\0047\004A\004L\004M\004P\004Q\004T\004U\004X\004Y\004\\\004a\004d\004e\004h\004i\004l\004m\004p\004q\004t\004u\004y\004z\004|\004\128\004\130\004\132\004\134\004\138\004\143\004\144\004\146\004\147\004\149\004\152\004\153\004\154\004\155\004\156\004\163\004\167\004\172\004\177\004\180\004\182\004\183\004\187\004\190\004\193\004\194\004\201\004\209\004\210\004\210\004\211\004\211\004\212\004\213\004\215\004\217\004\219\004\220\004\222\004\223\004\225\004\226\004\228\004\229\004\231\004\234\004\238\004\239\004\241\004\244\004\248\004\251\004\255\005\004\005\n\005\015\005\021\005\026\005 \005!\005\"\005#\005'\005,\0050\0055\0059\005>\005?\005@\005A\005B\005C\005D\005E\005F\005G\005H\005I\005J\005K\005L\005M\005N\005O\005P\005Q\005R\005S\005T\005U\005U\005U\005V\005V\005W\005W\005Y\005Y\005[\005[\005]\005]\005_\005_\005a\005a\005c\005c\005d\005e\005h\005m\005p\005u\005|\005\133\005\140\005\142\005\144\005\146\005\148\005\150\005\152\005\154\005\156\005\158\005\160\005\162\005\165\005\167\005\168\005\171\005\172\005\175\005\179\005\182\005\185\005\188\005\191\005\192\005\194\005\200\005\202\005\206\005\209\005\211\005\212\005\215\005\216\005\219\005\220\005\221\005\222\005\224\005\226\005\228\005\232\005\233\005\236\005\237\005\240\005\244\005\253\005\253\005\254\005\254\005\255\006\000\006\002\006\004\006\004\006\005\006\006\006\t\006\n\006\011\006\r\006\014\006\015\006\016\006\017\006\019\006\021\006\022\006\023\006\025\006\025\006\030\006\031\006!\006\"\006$\006%\006'\006)\006,\006-\006/\0062\0063\0066\0067\006:\006;\006>\006?\006B\006C\006F\006G\006J\006M\006P\006S\006V\006Y\006\\\006]\006^\006_\006a\006d\006f\006i\006m\006n\006p\006s\006v\006z\006\127\006\128\006\130\006\133\006\138\006\145\006\146\006\148\006\149\006\150\006\151\006\153\006\155\006\164\006\174\006\175\006\181\006\188\006\189\006\198\006\199\006\200\006\201\006\206\006\216\006\217\006\218\006\220\006\222\006\224\006\226\006\229\006\232\006\235\006\237\006\240\006\242\006\245\006\249\006\254\007\003\007\b\007\r\007\020\007\025\007 \007%\007,\0071\0075\0079\007?\007G\007M\007N\007O\007P\007Q\007S\007U\007X\007Z\007]\007b\007g\007j\007m\007n\007o\007s\007v\007{\007~\007\128\007\133\007\137\007\140\007\145\007\149\007\159\007\160\007\161\007\164\007\165\007\171\007\179\007\180\007\181\007\184\007\185\007\186\007\188\007\191\007\195\007\199\007\204\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\238\007\239\007\240\007\241\007\242\007\243\007\244\007\245\007\246\007\247\007\248\007\249\007\250\007\251\007\252\007\253\007\254\007\255\b\000\b\001\b\002\b\003\b\004\b\005\b\006\b\014\b\016\b\018\b\023\b\024\b\027\b\028\b\029\b\031\b \b!\b\"\b$\b-\b7\b8\b>\bF\bG\bH\bQ\bR\bW\bX\bY\b^\b`\bb\be\bh\bk\bn\bq\bt\bw\by\b{\b|\b}\b~\b\128\b\132\b\134\b\134\b\136\b\137\b\139\b\139\b\140\b\143\b\145\b\146\b\146\b\147\b\148\b\149\b\151\b\153\b\155\b\157\b\158\b\159\b\161\b\165\b\168\b\169\b\170\b\171\b\176\b\181\b\187\b\193\b\200\b\207\b\207\b\208\b\209\b\211\b\213\b\214\b\216\b\218\b\224\b\229\b\233\b\237\b\242\b\247\b\248\b\250")) 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\001y\001z\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\001w\001x\001\146\001\147\001\148\001{\001|\001}\001~\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\249\001\250\001\251\001\252\001\253\001\254\001\255\002\000\002\001\002\002\001\247\001\248\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\024\002\025\002\026\002\027\002\028\002\029\002\030\002\031\002 \002!\002\"\002#\002$\002%\002&\002'\002(\002)\002*\002+\002,\002-\002.\002/\0020\0021\0022\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\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\002V\002W\002X\002Y\002P\002Q\002T\002U\002\\\002]\002^\002_\002`\002a\002b\002c\002d\002e\002f\002g\002h\002i\002j\002k\002l\002m\002R\002S\002Z\002[\005\189\005\190\002\132\002\133\002\134\002\135\002\136\002\137\002\138\002\139\002\140\002\141\002\142\002\143\002\144\002\145\002\146\002\147\002\148\002\149\002\166\002\167\002\192\002\193\002\194\002\195\002\196\002\197\002\198\002\199\002\200\002\201\002\150\002\151\002\156\002\157\002\168\002\169\002\152\002\153\002\154\002\155\002\158\002\159\002\160\002\161\002\162\002\163\002\164\002\165\002\170\002\171\002\172\002\173\002\184\002\185\002\174\002\175\002\176\002\177\002\178\002\179\002\186\002\187\002\188\002\189\002\190\002\191\002\180\002\181\002\182\002\183\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\232\002\233\002\234\002\235\002\236\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\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\003\017\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#\003$\003%\003&\003'\003(\003)\003*\003+\003,\003-\003.\003/\0030\0031\0032\0033\0034\0035\0036\0037\0038\0039\003:\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\003U\003V\003W\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\003u\003v\003w\003x\003y\003z\003{\003|\003}\003~\003\127\003\128\003\129\003\130\003\131\003\132\003\133\003\134\003\135\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\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\225\003\226\003\227\003\228\003\229\003\230\003\231\003\232\003\233\003\234\003\235\003\236\003\237\003\238\003\239\003\240\003\241\003\242\003\243\003\244\003\245\003\246\003\247\003\248\003\249\003\250\003\251\003\252\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\191\005\192\005\193\005\194\005\195\005\196\005\197\005\198\005\199\005\200\005\201\005l\005m\005n\005\202\005\203\005\204\005\205\005\206\005\207\005\208\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\209\005\210\005\211\005\212\005\213\005\214\005\215\005\216\002\131\005\\\005]\005^\005_\005`\005a\005b\005c\005d\005e\005f\005g\005h\005i\005j\005k\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\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\0073\0074\0075\0076\0077\0078\0079\007:\007;\007<\007=\007>\007?\007@\007A\007B\007C\007D") + (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\001y\001z\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\001w\001x\001\146\001\147\001\148\001{\001|\001}\001~\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\251\001\252\001\253\001\254\001\255\002\000\002\001\002\002\002\003\002\004\001\249\001\250\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\024\002\025\002\026\002\027\002\028\002\029\002\030\002\031\002 \002!\002\"\002#\002$\002%\002&\002'\002(\002)\002*\002+\002,\002-\002.\002/\0020\0021\0022\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\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\002Y\002Z\002[\002\\\002S\002T\002W\002X\002_\002`\002a\002b\002c\002d\002e\002f\002g\002h\002i\002j\002k\002l\002m\002n\002o\002p\002U\002V\002]\002^\005\192\005\193\002\135\002\136\002\137\002\138\002\139\002\140\002\141\002\142\002\143\002\144\002\145\002\146\002\147\002\148\002\149\002\150\002\151\002\152\002\169\002\170\002\195\002\196\002\197\002\198\002\199\002\200\002\201\002\202\002\203\002\204\002\153\002\154\002\159\002\160\002\171\002\172\002\155\002\156\002\157\002\158\002\161\002\162\002\163\002\164\002\165\002\166\002\167\002\168\002\173\002\174\002\175\002\176\002\187\002\188\002\177\002\178\002\179\002\180\002\181\002\182\002\189\002\190\002\191\002\192\002\193\002\194\002\183\002\184\002\185\002\186\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\232\002\233\002\234\002\235\002\236\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\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\003\017\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#\003$\003%\003&\003'\003(\003)\003*\003+\003,\003-\003.\003/\0030\0031\0032\0033\0034\0035\0036\0037\0038\0039\003:\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\003U\003V\003W\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\003u\003v\003w\003x\003y\003z\003{\003|\003}\003~\003\127\003\128\003\129\003\130\003\131\003\132\003\133\003\134\003\135\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\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\225\003\226\003\227\003\228\003\229\003\230\003\231\003\232\003\233\003\234\003\235\003\236\003\237\003\238\003\239\003\240\003\241\003\242\003\243\003\244\003\245\003\246\003\247\003\248\003\249\003\250\003\251\003\252\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\194\005\195\005\196\005\197\005\198\005\199\005\200\005\201\005\202\005\203\005\204\005o\005p\005q\005\205\005\206\005\207\005\208\005\209\005\210\005\211\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\212\005\213\005\214\005\215\005\216\005\217\005\218\005\219\002\134\005_\005`\005a\005b\005c\005d\005e\005f\005g\005h\005i\005j\005k\005l\005m\005n\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\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\0073\0074\0075\0076\0077\0078\0079\007:\007;\007<\007=\007>\007?\007@\007A\007B\007C\007D\007E\007F\007G") and lr0_items = - ((32, "\000\000\000\000\000\001\252\001\000\002\240\001\000\011p\001\000\011l\001\000\011h\001\000\011d\001\000\011`\001\000\n\172\001\000\011\\\001\000\011X\001\000\011T\001\000\011P\001\000\011L\001\000\011H\001\000\011D\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\n\168\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\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\000\172\001\000\000\168\001\000\000\172\002\000\000\172\003\000\002\240\002\000\001\252\002\000\000\176\001\000\000\176\002\000\0028\001\000\0028\002\000\0028\003\000\n0\001\000\005h\001\000\001\248\001\000\001\244\001\000\001\240\001\000\001\236\001\000\001\248\002\000\001\244\002\000\001\240\002\000\001\236\002\000\001\248\003\000\001\244\003\000\001\240\003\000\001\236\003\000\002,\001\000\002,\002\000\002,\003\000\001\156\001\000\001\136\001\000\002\248\001\000\n\b\001\000\t\244\001\000\t\244\002\000\t\244\003\000\001\016\001\000\001\012\001\000\nx\001\000\t\152\001\000\t\148\001\000\t\148\002\000\t\152\002\000\t\144\001\000\t\140\001\000\t\140\002\000\t\144\002\000\012x\001\000\n\160\001\000\nt\001\000\np\001\000\nh\001\000\001\180\001\000\001\148\001\000\006\196\001\000\001\148\002\000\006p\001\000\006\184\001\000\006\180\001\000\t\152\001\000\t\148\001\000\006\176\001\000\006\200\001\000\006\216\001\000\nt\002\000\np\002\000\nt\003\000\np\003\000\nt\004\000\np\004\000\005\192\001\000\005\188\001\000\nt\005\000\np\005\000\np\006\000\nt\006\000\0058\001\000\003t\001\000\005\200\001\000\005\200\002\000\012\156\001\000\012\156\002\000\012\156\003\000\012x\001\000\006\176\001\000\006\192\001\000\006\188\001\000\006t\001\000\006\208\001\000\006\172\001\000\006\168\001\000\006\164\001\000\006\160\001\000\006\156\001\000\006\148\001\000\006\212\001\000\006\204\001\000\006\144\001\000\006\140\001\000\006\136\001\000\006\132\001\000\006\128\001\000\006|\001\000\006\128\002\000\006|\002\000\003\132\001\000\003\132\002\000\006\128\003\000\006|\003\000\006\128\004\000\006|\004\000\006\128\005\000\006\136\002\000\006\132\002\000\006\136\003\000\006\132\003\000\006\136\004\000\006\132\004\000\006\136\005\000\006\144\002\000\006\140\002\000\006\144\003\000\006\140\003\000\006\144\004\000\006\140\004\000\006\144\005\000\006\232\001\000\006\220\001\000\006\152\001\000\006x\001\000\006\224\001\000\006\228\001\000\012x\002\000\012x\003\000\012|\001\000\012\156\004\000\012\156\005\000\000d\001\000\0058\001\000\b\144\001\000\000`\001\000\003t\001\000\003x\001\000\b\144\002\000\000`\002\000\007@\001\000\007@\002\000\007@\003\000\007<\001\000\000\132\001\000\000p\001\000\000\\\001\000\000X\001\000\000`\001\000\000`\002\000\000\\\002\000\000\\\003\000\000\\\004\000\005\208\001\000\005\208\002\000\005\208\003\000\005\208\004\000\005\184\001\000\005\152\001\000\005\152\002\000\011\176\001\000\011\172\001\000\003p\001\000\003l\001\000\011\176\002\000\011\172\002\000\003p\002\000\003l\002\000\011\176\003\000\011\172\003\000\003p\003\000\003l\003\000\012l\001\000\012X\001\000\012L\001\000\012X\002\000\011\176\004\000\003p\004\000\012`\001\000\012P\001\000\012`\002\000\012<\001\000\012h\001\000\012d\001\000\012\\\001\000\012T\001\000\012\\\002\000\012d\002\000\0120\001\000\012D\001\000\012@\001\000\012@\002\000\0120\002\000\b\196\001\000\012<\002\000\b\200\001\000\012<\003\000\b\200\002\000\b\200\003\000\011\176\005\000\003p\005\000\0050\001\000\003p\006\000\012(\001\000\0058\001\000\001\160\001\000\006T\001\000\006D\001\000\0064\001\000\006,\001\000\001\164\001\000\001\148\001\000\000\132\001\000\000p\001\000\000\\\001\000\000X\001\000\0050\001\000\0030\001\000\0030\002\000\0050\001\000\000x\001\000\000t\001\000\0050\001\000\005\b\001\000\005\000\001\000\004\248\001\000\005\b\002\000\005\000\002\000\004\248\002\000\002\244\001\000\002\244\002\000\004\156\001\000\004\152\001\000\003\144\001\000\000@\001\000\000<\001\000\006d\001\000\006`\001\000\006d\002\000\006d\003\000\006d\004\000\007X\001\000\007T\001\000\007P\001\000\007L\001\000\007H\001\000\007D\001\000\007X\002\000\007T\002\000\007P\002\000\007L\002\000\007X\003\000\007T\003\000\007P\003\000\007L\003\000\t\232\001\000\t\232\002\000\t\232\003\000\005`\001\000\005l\001\000\005d\001\000\005l\002\000\005d\002\000\005l\003\000\005d\003\000\005\128\001\000\001\b\001\000\t\232\004\000\004l\001\000\004l\002\000\011\216\001\000\011\212\001\000\001\232\001\000\001\232\002\000\001\232\003\000\002(\001\000\002(\002\000\002(\003\000\012x\001\000\t\240\001\000\t\236\001\000\t\184\001\000\t\180\001\000\001\180\001\000\001\148\001\000\n\b\001\000\006p\001\000\nD\001\000\n@\001\000\012|\001\000\002\188\001\000\002\188\002\000\004\224\001\000\004\224\002\000\004\224\003\000\b4\001\000\004\224\004\000\t\168\001\000\t\164\001\000\t\160\001\000\001\144\001\000\001\144\002\000\t\156\001\000\003\176\001\000\t\156\002\000\t\156\003\000\004\220\001\000\004\216\001\000\004\212\001\000\004\208\001\000\007\016\001\000\000\160\001\000\000\156\001\000\006\248\001\000\000\160\002\000\000\156\002\000\000\152\001\000\000\148\001\000\000\152\002\000\000\148\002\000\000\144\001\000\000\140\001\000\000\136\001\000\000|\001\000\005|\001\000\005<\001\000\0054\001\000\005|\002\000\005|\003\000\005|\001\000\005<\001\000\005|\004\000\005<\002\000\005<\003\000\005x\001\000\005<\002\000\0054\002\000\0054\003\000\001|\001\000\000|\002\000\000\140\002\000\006\020\001\000\006\020\002\000\000h\001\000\0034\001\000\003(\001\000\0034\002\000\012\020\001\000\b\228\001\000\b\228\002\000\012,\001\000\000\164\001\000\b\228\003\000\000\128\001\000\000l\001\000\000\128\002\000\000\128\003\000\000l\002\000\003,\001\000\003,\002\000\003,\003\000\003,\004\000\012\016\001\000\b\232\001\000\000\128\001\000\000l\001\000\b\232\002\000\b\232\003\000\000\128\001\000\000l\001\000\0034\003\000\b\236\001\000\b\180\001\000\b\184\001\000\000\140\003\000\000\140\004\000\b\184\002\000\b\184\003\000\011\224\001\000\011\220\001\000\011\220\002\000\006\236\001\000\011\220\003\000\011\220\004\000\b\168\001\000\b\168\002\000\000D\001\000\b\168\003\000\000H\001\000\000H\002\000\000H\003\000\000H\004\000\011\220\005\000\b\164\001\000\000H\001\000\011\224\002\000\b\240\001\000\001\216\001\000\001\216\002\000\001\212\001\000\000H\001\000\b\236\001\000\000\136\002\000\000\136\003\000\000\144\002\000\000\144\003\000\b\184\001\000\000\144\004\000\000\144\005\000\b\184\001\000\000\148\003\000\000\148\004\000\b\184\001\000\000\160\003\000\000\156\003\000\000\156\004\000\000\160\004\000\b\140\001\000\000\160\005\000\000\160\006\000\b\140\002\000\b\136\001\000\007\016\002\000\001\216\001\000\004\220\002\000\004\216\002\000\004\212\002\000\004\208\002\000\007(\001\000\007\196\001\000\007\196\002\000\007\196\003\000\001\128\001\000\n\140\001\000\n\140\002\000\001\140\001\000\001\152\001\000\001\132\001\000\n`\001\000\012\128\001\000\nd\001\000\007\196\004\000\nl\001\000\n\128\001\000\n|\001\000\n\128\002\000\n\128\003\000\t\136\001\000\n\136\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\005l\001\000\001\176\001\000\001\172\001\000\n\156\002\000\n\152\002\000\n\148\002\000\n\144\002\000\005l\002\000\001\176\002\000\n\156\003\000\n\152\003\000\001\176\003\000\n\152\004\000\007\160\001\000\007\160\002\000\007\160\003\000\007\180\001\000\007\144\001\000\007\164\001\000\007\152\001\000\007\164\002\000\007\168\001\000\007\164\003\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\007\168\002\000\007\168\003\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\007\136\002\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\003\000\007\136\001\000\007\156\002\000\007\168\001\000\007\156\003\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\007\148\002\000\007\148\003\000\007\140\002\000\n\136\001\000\007\192\001\000\007\192\002\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\n\164\001\000\n\132\001\000\007\188\001\000\007\184\001\000\012x\001\000\n\160\001\000\nt\001\000\np\001\000\nh\001\000\007\188\002\000\001\180\001\000\001\148\001\000\007\188\003\000\006\028\001\000\006\024\001\000\006\028\002\000\007\188\004\000\007\188\005\000\007\188\006\000\n\132\001\000\001\184\001\000\t\144\001\000\t\140\001\000\006\188\001\000\001\180\002\000\001\180\003\000\n\160\002\000\nh\002\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\nh\003\000\n\160\003\000\n\160\004\000\001\216\001\000\n\160\005\000\007\184\002\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\007\168\001\000\007\160\004\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\001\176\004\000\001\176\005\000\n\156\004\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\n\156\005\000\n\148\003\000\t\160\001\000\n\148\004\000\t\160\002\000\t\160\003\000\t\020\001\000\t\016\001\000\t\012\001\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\t\020\002\000\t\016\002\000\t\020\003\000\n\144\003\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\007(\002\000\004\220\003\000\004\216\003\000\004\212\003\000\004\208\003\000\004\220\004\000\004\216\004\000\004\212\004\000\004\216\005\000\007\000\001\000\004\216\006\000\004\220\005\000\t\168\002\000\t\164\002\000\t\164\003\000\n`\001\000\004\000\001\000\003\252\001\000\003\248\001\000\003\244\001\000\003\240\001\000\003\224\001\000\003\220\001\000\003\220\002\000\003\172\001\000\003\168\001\000\003\172\002\000\003\172\003\000\001\216\001\000\003\220\003\000\003\220\004\000\003\224\002\000\003\208\001\000\003\204\001\000\003\204\002\000\003\204\003\000\0070\001\000\002\180\001\000\n`\001\000\004,\001\000\004(\001\000\003\216\001\000\003\212\001\000\007\228\001\000\003\212\002\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\004$\001\000\004 \001\000\004$\002\000\004$\003\000\001\216\001\000\003\212\003\000\003\212\004\000\003\212\005\000\007\224\001\000\003\216\002\000\012x\001\000\011\132\001\000\n\160\001\000\nt\001\000\np\001\000\nh\001\000\001\180\001\000\001\148\001\000\011\132\002\000\011\132\003\000\011\132\004\000\003\228\001\000\003\228\002\000\011|\001\000\004\012\001\000\002\024\001\000\002\020\001\000\002\016\001\000\002\012\001\000\002\024\002\000\002\020\002\000\002\024\003\000\002\024\004\000\002\024\005\000\005\156\001\000\005\156\002\000\003<\001\000\0038\001\000\0038\002\000\003<\002\000\003<\003\000\005\212\001\000\005\204\001\000\005\204\002\000\b|\001\000\003@\001\000\b|\002\000\005\204\003\000\005\204\004\000\005\220\001\000\005\228\001\000\005\224\001\000\005\216\001\000\005\204\005\000\005\228\002\000\012\196\001\000\012\192\001\000\012\196\002\000\012\192\002\000\012\196\003\000\012\192\003\000\012\220\001\000\012\216\001\000\012\220\002\000\012\196\004\000\012\196\005\000\000H\001\000\012\192\004\000\012\192\005\000\000H\001\000\012\192\006\000\bt\001\000\bt\002\000\bt\003\000\001\216\001\000\bt\004\000\bt\005\000\001\216\001\000\0128\001\000\012\212\001\000\012\208\001\000\012\204\001\000\012\200\001\000\012\212\002\000\012\208\002\000\012\212\003\000\012\208\003\000\012\208\004\000\012\208\005\000\005\228\001\000\005\224\001\000\005\216\001\000\005\224\002\000\005\228\001\000\005\224\003\000\005\224\001\000\005\216\001\000\005\216\002\000\005|\001\000\005\\\001\000\005<\001\000\005\\\002\000\005<\002\000\005<\003\000\003t\001\000\005\\\003\000\005\244\001\000\005X\001\000\005\232\001\000\012\212\004\000\012\212\005\000\005\228\001\000\005\224\001\000\005\216\001\000\012\204\002\000\012\200\002\000\005l\001\000\012\200\003\000\012\200\004\000\005|\001\000\005<\001\000\005l\002\000\012\204\003\000\012\204\004\000\005|\001\000\005<\001\000\b\172\001\000\b\176\001\000\005\228\003\000\b\176\002\000\b\176\003\000\bx\001\000\005\228\001\000\005\224\001\000\005\216\001\000\005\212\002\000\005\212\003\000\005\228\001\000\005\224\001\000\005\216\001\000\003<\004\000\003<\005\000\005\156\003\000\005\156\004\000\005\160\001\000\005\176\001\000\005\172\001\000\005\164\001\000\005\156\005\000\007X\001\000\007T\001\000\007P\001\000\007L\001\000\007H\001\000\007D\001\000\005\176\002\000\005\176\003\000\007H\002\000\007D\002\000\005\176\001\000\005\172\001\000\005\164\001\000\007H\003\000\007D\003\000\007D\004\000\005\228\001\000\005\224\001\000\005\216\001\000\007D\005\000\005\172\002\000\005\164\002\000\005\168\001\000\005l\001\000\005\180\001\000\005\176\001\000\005\172\001\000\005\164\001\000\002\024\006\000\002\024\007\000\nP\001\000\001\144\001\000\n\020\001\000\n\016\001\000\t\b\001\000\t\004\001\000\t\000\001\000\007\024\001\000\n8\001\000\012|\001\000\005`\001\000\t\176\001\000\t\172\001\000\002D\001\000\002D\002\000\002D\003\000\t\228\001\000\t\224\001\000\t\228\002\000\t\224\002\000\t\228\003\000\t\224\003\000\0024\001\000\0020\001\000\0024\002\000\0020\002\000\0024\003\000\0020\003\000\002\028\001\000\002\028\002\000\002\028\003\000\b\156\001\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\004\244\001\000\004\240\001\000\004\236\001\000\004\240\002\000\002$\001\000\002 \001\000\002$\002\000\002 \002\000\002$\003\000\002 \003\000\012x\001\000\n\160\001\000\nt\001\000\np\001\000\nh\001\000\002$\004\000\001\180\001\000\001\148\001\000\002$\005\000\002$\006\000\002$\007\000\003\024\001\000\002\004\001\000\002\000\001\000\002\004\002\000\002\000\002\000\002\004\003\000\002\000\003\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\002\004\004\000\002\000\004\000\002\004\005\000\002<\001\000\002<\002\000\002<\003\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\002<\004\000\002<\005\000\n\012\001\000\t\248\001\000\005p\001\000\n(\001\000\n$\001\000\n\024\001\000\n\012\002\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\n(\002\000\n(\003\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\n$\002\000\n$\003\000\t\216\002\000\t\208\002\000\t\200\002\000\t\200\003\000\002@\001\000\002@\002\000\002@\003\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\002@\004\000\n\024\002\000\t\220\002\000\t\212\002\000\t\204\002\000\t\196\002\000\t\192\002\000\t\188\002\000\t\188\003\000\002\168\001\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\002\228\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\002H\001\000\002\b\001\000\003\192\001\000\003\188\001\000\003\192\002\000\003\192\003\000\012 \001\000\012 \002\000\001\216\001\000\012\028\001\000\012\024\001\000\012\028\002\000\012\024\002\000\001\216\001\000\012\028\003\000\012\028\004\000\001\216\001\000\003\192\004\000\003\192\005\000\003\188\002\000\003\196\001\000\003\196\002\000\003\200\001\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\003\200\002\000\n\004\001\000\n\\\001\000\nX\001\000\nT\001\000\nL\001\000\nH\001\000\n<\001\000\n4\001\000\n \001\000\n\028\001\000\005t\001\000\005l\001\000\001\176\001\000\001\172\001\000\n\\\002\000\nX\002\000\nT\002\000\nL\002\000\nH\002\000\n<\002\000\n4\002\000\n \002\000\n\028\002\000\005t\002\000\005l\002\000\001\176\002\000\012x\001\000\n\\\003\000\n4\003\000\n\028\003\000\001\176\003\000\n4\004\000\006\180\001\000\000@\001\000\006\176\001\000\000<\001\000\n\\\004\000\n\\\005\000\n\\\006\000\n\\\007\000\005\176\001\000\005\172\001\000\005\164\001\000\n\\\b\000\n\\\t\000\005\228\001\000\005\224\001\000\005\216\001\000\n\\\n\000\011\216\001\000\006\192\001\000\011\212\001\000\006\188\001\000\006t\001\000\002\180\001\000\007\180\001\000\0040\001\000\0040\002\000\0040\003\000\001\216\001\000\0040\004\000\0040\005\000\b\220\001\000\002L\001\000\b\220\002\000\n\004\001\000\002T\001\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\002T\002\000\012\132\001\000\n,\001\000\n\000\001\000\t\252\001\000\004\232\001\000\001\228\001\000\001\228\002\000\001\228\003\000\004\228\001\000\004\016\001\000\002\176\001\000\002\176\002\000\002\176\003\000\t0\001\000\t,\001\000\t(\001\000\t$\001\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\128\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002p\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002l\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\132\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\148\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002|\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002x\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\140\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002h\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002d\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002`\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\\\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002X\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\144\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\136\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\b\224\002\000\b\224\003\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\164\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\003\000\002\164\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\002\184\002\000\b\224\001\000\002\232\001\000\002\184\003\000\002\184\001\000\002\164\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\002\152\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\156\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\160\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\002\232\002\000\n\000\001\000\002P\001\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\002P\002\000\002\172\001\000\b\224\001\000\002\232\001\000\002\184\001\000\002\172\002\000\002\164\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\t0\002\000\t,\002\000\t(\002\000\t0\003\000\t0\004\000\t0\005\000\t,\003\000\000L\001\000\000L\002\000\nd\001\000\004\b\001\000\004\b\002\000\004\b\003\000\001\216\001\000\004\b\004\000\004\b\005\000\007\220\001\000\007\212\001\000\007\204\001\000\007\200\001\000\007\176\001\000\004\004\001\000\004\004\002\000\004\004\003\000\007\176\002\000\007\176\003\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\007\200\002\000\007\200\003\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\007\220\002\000\007\220\003\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\007\212\002\000\007\212\003\000\007\204\002\000\007\208\001\000\007\216\001\000\007\172\001\000\007\172\002\000\007\172\003\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\003\236\001\000\000L\003\000\b\012\001\000\b\012\002\000\007\248\001\000\007\244\001\000\007\248\002\000\007\244\002\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\007\248\003\000\007\248\004\000\011\188\001\000\011\184\001\000\005\236\001\000\005\236\002\000\005\236\003\000\005\236\004\000\005\236\005\000\007 \001\000\007 \002\000\005\228\001\000\005\224\001\000\005\216\001\000\005\236\006\000\004\132\001\000\004\132\002\000\005\236\007\000\011\188\002\000\011\184\002\000\011\188\003\000\011\184\003\000\011\188\004\000\011\188\005\000\005\132\001\000\005\176\001\000\005\172\001\000\005\164\001\000\005\132\002\000\005\136\001\000\005\228\001\000\005\224\001\000\005\216\001\000\005\136\002\000\005\136\003\000\005\176\001\000\005\172\001\000\005\164\001\000\005\136\004\000\011\188\006\000\011\188\007\000\004\\\001\000\004\\\002\000\004\\\003\000\004\\\004\000\004\\\005\000\004\\\006\000\005\140\001\000\005\140\002\000\011\188\b\000\011\184\004\000\011\184\005\000\011\184\006\000\003\140\001\000\003\140\002\000\003\004\001\000\003\004\002\000\011\208\001\000\011\208\002\000\011\208\003\000\011\208\004\000\005\176\001\000\005\172\001\000\005\164\001\000\011\208\005\000\b\016\001\000\b\016\002\000\b\016\003\000\b\016\004\000\b\016\005\000\b\148\001\000\b\000\001\000\b\148\002\000\b\148\003\000\b\000\002\000\b\000\003\000\001\216\001\000\b\016\006\000\b\016\007\000\006$\001\000\006 \001\000\006$\002\000\b\016\b\000\b\016\t\000\007\252\001\000\001\216\001\000\011x\001\000\t4\001\000\011x\002\000\t4\002\000\011x\003\000\t4\003\000\001\160\001\000\001\164\001\000\001\148\001\000\001\164\002\000\001\164\003\000\001\144\001\000\011x\004\000\t4\004\000\003H\001\000\001\200\001\000\005\252\001\000\003\152\001\000\003\148\001\000\003\152\002\000\003\148\002\000\003\152\003\000\003\148\003\000\b\148\001\000\b\b\001\000\b\b\002\000\b\b\003\000\000H\001\000\003\152\004\000\003\148\004\000\003\152\005\000\003\148\005\000\003\152\006\000\003\152\007\000\b\004\001\000\000H\001\000\001\200\002\000\001\200\003\000\003\164\001\000\003\160\001\000\003\164\002\000\003\156\001\000\b\208\001\000\001\196\001\000\b\208\002\000\001\196\002\000\b\208\003\000\001\196\003\000\000\128\001\000\000l\001\000\003H\002\000\b\204\001\000\001\192\001\000\000\128\001\000\000l\001\000\011x\005\000\001\180\001\000\001\148\001\000\005l\001\000\001\176\001\000\001\172\001\000\005l\002\000\001\176\002\000\001\176\003\000\011x\006\000\011x\007\000\011x\b\000\003X\001\000\003T\001\000\003P\001\000\003L\001\000\b\148\001\000\003X\002\000\003P\002\000\003X\003\000\003P\003\000\003P\004\000\003P\005\000\003P\006\000\000\128\001\000\000l\001\000\b\204\001\000\003X\004\000\001\192\001\000\000\128\001\000\000l\001\000\003L\002\000\003L\003\000\003L\004\000\000\128\001\000\000l\001\000\b\204\001\000\003T\002\000\001\192\001\000\000\128\001\000\000l\001\000\t4\005\000\t4\006\000\t4\007\000\001\168\001\000\007\240\001\000\007\236\001\000\tX\001\000\tT\001\000\003p\001\000\003l\001\000\003h\001\000\003d\001\000\tX\002\000\tT\002\000\003p\002\000\003l\002\000\003h\002\000\003d\002\000\tX\003\000\tT\003\000\003p\003\000\003l\003\000\003h\003\000\003d\003\000\tX\004\000\003p\004\000\003h\004\000\tX\005\000\003p\005\000\003h\005\000\0050\001\000\003p\006\000\003h\006\000\003h\007\000\001\144\001\000\000\144\001\000\000\140\001\000\000\136\001\000\006P\001\000\006P\002\000\006P\003\000\006@\001\000\003\\\001\000\001\204\001\000\003\\\002\000\003\\\003\000\003\\\004\000\bH\001\000\001\208\001\000\003\\\001\000\bH\002\000\003h\b\000\bt\001\000\003h\t\000\003h\n\000\b@\001\000\bD\001\000\006\\\001\000\006X\001\000\006L\001\000\006H\001\000\006<\001\000\0068\001\000\006(\001\000\001\216\001\000\006\\\002\000\006X\002\000\006L\002\000\006H\002\000\006<\002\000\0068\002\000\006\\\003\000\006L\003\000\006<\003\000\006\\\004\000\006\\\005\000\006\\\006\000\006L\004\000\006<\004\000\003`\001\000\003`\002\000\003`\003\000\006X\003\000\006X\004\000\006X\005\000\006H\003\000\0068\003\000\0060\001\000\003p\007\000\bt\001\000\003p\b\000\003p\t\000\tX\006\000\tX\007\000\b\024\001\000\tX\b\000\tX\t\000\bl\001\000\tX\n\000\bl\002\000\bd\001\000\bh\001\000\tT\004\000\003l\004\000\003d\004\000\0050\001\000\003l\005\000\003d\005\000\003d\006\000\003d\007\000\bt\001\000\003d\b\000\003d\t\000\003l\006\000\bt\001\000\003l\007\000\003l\b\000\tT\005\000\tT\006\000\tT\007\000\tT\b\000\bl\001\000\tT\t\000\004\140\001\000\006l\001\000\006h\001\000\006l\002\000\006l\003\000\006l\004\000\006l\005\000\005|\001\000\005<\001\000\006l\006\000\006h\002\000\006h\003\000\006h\004\000\005|\001\000\005<\001\000\006h\005\000\tl\001\000\td\001\000\t`\001\000\005\240\001\000\005\236\001\000\005\196\001\000\005\240\002\000\005\236\002\000\005\240\003\000\005\236\003\000\005\240\004\000\005\236\004\000\005\240\005\000\005\236\005\000\005\240\006\000\005\240\007\000\005\228\001\000\005\224\001\000\005\216\001\000\005\240\b\000\tl\002\000\td\002\000\t`\002\000\005\196\002\000\tl\003\000\td\003\000\t`\003\000\005\196\003\000\005\196\004\000\005\188\001\000\005\196\005\000\005\196\006\000\005|\001\000\005<\001\000\005\196\007\000\tl\004\000\tl\005\000\tl\006\000\tl\007\000\005\228\001\000\005\224\001\000\005\216\001\000\tl\b\000\004d\001\000\004d\002\000\004d\003\000\004d\004\000\005\228\001\000\005\224\001\000\005\216\001\000\004d\005\000\004d\006\000\004d\007\000\tl\t\000\td\004\000\t`\004\000\td\005\000\td\006\000\005l\001\000\td\007\000\005\144\001\000\005\228\001\000\005\224\001\000\005\216\001\000\005\144\002\000\t`\005\000\t`\006\000\005\148\001\000\005\148\002\000\t|\001\000\t|\002\000\t|\003\000\t|\004\000\005\228\001\000\005\224\001\000\005\216\001\000\t|\005\000\t4\001\000\t4\002\000\t4\003\000\t4\004\000\t\128\001\000\001x\001\000\001x\002\000\001x\003\000\001x\004\000\012\164\001\000\001x\005\000\003\012\001\000\b\200\001\000\003\012\002\000\003\012\003\000\001x\006\000\001x\007\000\001x\b\000\001D\001\000\001D\002\000\001\024\001\000\001\216\001\000\001\024\002\000\001\024\003\000\001D\003\000\001$\001\000\001$\002\000\006\016\001\000\006\b\001\000\006\016\002\000\006\012\001\000\006\004\001\000\006\012\002\000\001$\003\000\001$\004\000\001$\005\000\001\216\001\000\001$\006\000\001$\007\000\001(\001\000\001(\002\000\b,\001\000\b$\001\000\b,\002\000\b(\001\000\b \001\000\b(\002\000\001(\003\000\001(\004\000\001(\005\000\001(\006\000\001(\007\000\001 \001\000\001 \002\000\001P\001\000\001L\001\000\001P\002\000\001L\002\000\001P\003\000\001P\004\000\005l\001\000\001P\005\000\001P\006\000\001<\001\000\b\192\001\000\001<\002\000\001<\003\000\001<\004\000\b\192\002\000\b\192\003\000\001\216\001\000\b\188\001\000\001\216\001\000\001@\001\000\0018\001\000\001P\007\000\001H\001\000\001H\002\000\001L\003\000\005l\001\000\001L\004\000\001L\005\000\001L\006\000\001H\001\000\001H\001\000\001 \003\000\001 \004\000\001,\001\000\001,\002\000\001\216\001\000\001\188\001\000\001\188\002\000\001\216\001\000\001\188\003\000\001,\003\000\001,\004\000\001D\004\000\001D\005\000\0010\001\000\0010\002\000\0014\001\000\004\168\001\000\004\168\002\000\001x\t\000\001H\001\000\001x\n\000\004T\001\000\004T\002\000\004T\003\000\004T\004\000\004T\005\000\004T\006\000\004T\007\000\001H\001\000\004T\b\000\004T\t\000\001x\011\000\t\128\002\000\t\128\003\000\t\128\004\000\t\128\005\000\t\128\006\000\t\128\007\000\0050\001\000\001p\001\000\001p\002\000\001p\003\000\001p\004\000\001<\001\000\000\144\001\000\000\140\001\000\000\136\001\000\b\240\001\000\b\188\001\000\001\216\001\000\001t\001\000\001t\002\000\001l\001\000\001l\002\000\001l\003\000\012,\001\000\001|\001\000\001@\001\000\000\164\001\000\001l\004\000\001h\001\000\001H\001\000\001t\003\000\001p\005\000\t\128\b\000\t\128\t\000\004L\001\000\004L\002\000\004L\003\000\004L\004\000\004L\005\000\004L\006\000\004L\007\000\004L\b\000\004L\t\000\t\128\n\000\tD\001\000\004\144\001\000\t\\\001\000\tH\001\000\tx\001\000\tt\001\000\tp\001\000\th\001\000\004\144\002\000\t<\001\000\t<\002\000\tL\001\000\004t\001\000\004t\002\000\004t\003\000\004t\004\000\004t\005\000\bt\001\000\004t\006\000\004t\007\000\004t\b\000\tL\002\000\tP\001\000\004|\001\000\004|\002\000\004|\003\000\004|\004\000\004|\005\000\004|\006\000\bt\001\000\004|\007\000\004|\b\000\004|\t\000\tP\002\000\t@\001\000\t\132\001\000\004\140\002\000\007\236\002\000\t8\001\000\007\240\002\000\001\216\001\000\011\200\001\000\001x\001\000\011\200\002\000\011\200\003\000\011\200\004\000\011\200\005\000\011\200\006\000\000\244\001\000\001d\001\000\001d\002\000\001d\003\000\000\220\001\000\012\152\001\000\012\144\001\000\012\152\002\000\012\144\002\000\012\152\003\000\012\144\003\000\012\152\004\000\012\144\004\000\012\144\005\000\012\144\006\000\012\152\005\000\012\152\006\000\012\152\007\000\000\220\002\000\000\220\003\000\012\148\001\000\012\140\001\000\012\136\001\000\012\176\001\000\012\168\001\000\012\176\002\000\012\172\001\000\005\252\001\000\012\172\002\000\012\136\002\000\012\136\003\000\012\136\004\000\012\136\005\000\001\216\001\000\012\148\002\000\012\140\002\000\012\148\003\000\012\140\003\000\012\140\004\000\012\140\005\000\012\148\004\000\012\148\005\000\012\148\006\000\000\224\001\000\005,\001\000\005$\001\000\005\028\001\000\005,\002\000\005$\002\000\005\028\002\000\005,\003\000\005$\003\000\005\028\003\000\005,\004\000\005$\004\000\005\028\004\000\005,\005\000\005$\005\000\005,\006\000\005,\007\000\005,\b\000\005,\t\000\001\216\001\000\005,\n\000\005,\011\000\005$\006\000\005$\007\000\005$\b\000\005\028\005\000\003\232\001\000\011\128\001\000\003\020\001\000\003\020\002\000\003\020\003\000\003\016\001\000\011\128\002\000\000\224\002\000\000\224\003\000\005(\001\000\005 \001\000\005\024\001\000\005\020\001\000\012\188\001\000\012\180\001\000\012\188\002\000\012\184\001\000\b\024\001\000\012\184\002\000\005\020\002\000\005\020\003\000\005\020\004\000\005\020\005\000\005(\002\000\005 \002\000\005\024\002\000\005(\003\000\005 \003\000\005\024\003\000\005(\004\000\005 \004\000\005(\005\000\005(\006\000\005(\007\000\005(\b\000\001\216\001\000\005(\t\000\005(\n\000\005 \005\000\005 \006\000\005 \007\000\005\024\004\000\000\232\001\000\000\232\002\000\000\232\003\000\000\232\004\000\000\216\001\000\000\212\001\000\000\216\002\000\000\216\003\000\001`\001\000\001T\001\000\004\024\001\000\004\020\001\000\000\196\001\000\000\192\001\000\004\024\002\000\004\024\003\000\004\024\004\000\004\024\005\000\004\024\006\000\004\024\007\000\000\196\002\000\000\192\002\000\000\196\003\000\000\196\004\000\005l\001\000\000\196\005\000\000\196\006\000\001\\\001\000\b\192\001\000\001\\\002\000\001\\\003\000\001\\\004\000\000\184\001\000\000\184\002\000\001\004\001\000\001\000\001\000\001\000\002\000\004\028\001\000\000\188\001\000\000\188\002\000\000\208\001\000\000\204\001\000\000\180\001\000\003\184\001\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\003\184\002\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\003\180\001\000\b\132\001\000\000\204\002\000\b\132\002\000\b\128\001\000\001X\001\000\000\200\001\000\000\188\003\000\000\200\002\000\004\028\002\000\001\000\003\000\000\200\001\000\001\004\002\000\000\184\003\000\000\200\001\000\000\196\007\000\000\192\003\000\005l\001\000\000\192\004\000\000\192\005\000\000\200\001\000\000\192\006\000\004\020\002\000\004\020\003\000\004\020\004\000\004\020\005\000\001`\002\000\001T\002\000\000\200\001\000\001T\003\000\001`\003\000\001`\004\000\001`\005\000\000\216\004\000\000\200\001\000\007\b\001\000\007\b\002\000\000\216\005\000\000\216\006\000\000\212\002\000\000\212\003\000\000\200\001\000\000\212\004\000\000\212\005\000\000\228\001\000\000\228\002\000\000\228\003\000\000\228\004\000\001d\004\000\001d\005\000\000\236\001\000\000\236\002\000\000\240\001\000\004\176\001\000\004\176\002\000\000\244\002\000\000\200\001\000\000\248\001\000\000\248\002\000\000\248\003\000\000\248\004\000\000\200\001\000\000\252\001\000\000\252\002\000\011\200\007\000\011\200\b\000\004D\001\000\004D\002\000\004D\003\000\004D\004\000\004D\005\000\004D\006\000\004D\007\000\004D\b\000\011\200\t\000\011\164\001\000\004\160\001\000\004\012\001\000\004\012\002\000\004\012\003\000\004\012\004\000\004\012\005\000\004\012\006\000\011\180\001\000\011t\001\000\011\160\001\000\011\196\001\000\011\192\001\000\011\144\001\000\004\232\001\000\004\232\002\000\004\160\002\000\011\148\001\000\004\016\001\000\004\016\002\000\011\152\001\000\011\152\002\000\011\168\001\000\011\168\002\000\011\156\001\000\011\204\001\000\007\232\001\000\011\140\001\000\011\140\002\000\011\140\003\000\003\004\003\000\003\004\004\000\011\144\001\000\004\232\001\000\001\228\001\000\011\136\001\000\011\148\001\000\004\016\001\000\002\176\001\000\003\140\003\000\003\140\004\000\b\012\003\000\b\012\004\000\000L\004\000\b\224\001\000\b\220\003\000\002\232\001\000\002\184\001\000\002\164\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\007\220\001\000\007\212\001\000\007\204\001\000\007\200\001\000\007\176\001\000\0044\001\000\0044\002\000\0044\003\000\004<\001\000\002\180\002\000\002\180\003\000\002\180\004\000\004<\002\000\004<\003\000\0048\001\000\n\012\001\000\006\152\001\000\n\028\004\000\n\028\005\000\nL\003\000\nH\003\000\nL\004\000\nH\004\000\nH\005\000\b\252\001\000\b\248\001\000\b\244\001\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\b\252\002\000\b\248\002\000\b\252\003\000\nX\003\000\nT\003\000\nX\004\000\nT\004\000\nT\005\000\n \003\000\n \004\000\n \005\000\n<\003\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\b<\001\000\b<\002\000\b<\003\000\t \001\000\t\028\001\000\t\024\001\000\0078\001\000\t \002\000\t\028\002\000\t\024\002\000\t \003\000\t\028\003\000\t\024\003\000\t \004\000\t\028\004\000\t \005\000\b8\001\000\n<\004\000\n<\005\000\n\\\001\000\nX\001\000\nT\001\000\nL\001\000\nH\001\000\n<\001\000\n4\001\000\n \001\000\n\028\001\000\005t\001\000\005l\001\000\005d\001\000\001\176\001\000\001\172\001\000\n\\\002\000\nX\002\000\nT\002\000\nL\002\000\nH\002\000\n<\002\000\n4\002\000\n \002\000\n\028\002\000\005t\002\000\005l\002\000\005d\002\000\001\176\002\000\012|\001\000\005d\003\000\005t\003\000\t\216\002\000\t\208\002\000\t\200\002\000\002\224\002\000\002\216\002\000\002\208\002\000\t\200\003\000\002\208\003\000\t\200\004\000\002\208\004\000\t\200\005\000\002\208\005\000\002\208\006\000\b\224\001\000\002\232\001\000\002\208\007\000\002\184\001\000\002\164\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\t\216\003\000\002\224\003\000\t\216\004\000\002\224\004\000\t\216\005\000\002\224\005\000\002\224\006\000\b\224\001\000\002\232\001\000\002\224\007\000\002\184\001\000\002\164\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\t\208\003\000\002\216\003\000\t\208\004\000\002\216\004\000\t\208\005\000\002\216\005\000\002\216\006\000\b\224\001\000\002\232\001\000\002\216\007\000\002\184\001\000\002\164\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\n\024\002\000\t\220\002\000\t\212\002\000\t\204\002\000\t\196\002\000\t\192\002\000\t\188\002\000\002\228\002\000\002\220\002\000\002\212\002\000\002\204\002\000\002\200\002\000\002\196\002\000\002\192\002\000\t\188\003\000\002\196\003\000\t\188\004\000\002\196\004\000\t\188\005\000\002\196\005\000\002\196\006\000\b\224\001\000\002\232\001\000\002\196\007\000\002\184\001\000\002\164\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\t\196\003\000\002\204\003\000\t\196\004\000\002\204\004\000\t\196\005\000\002\204\005\000\002\204\006\000\b\224\001\000\002\232\001\000\002\204\007\000\002\184\001\000\002\164\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\t\192\003\000\002\200\003\000\t\192\004\000\002\200\004\000\t\192\005\000\002\200\005\000\002\200\006\000\b\224\001\000\002\232\001\000\002\200\007\000\002\184\001\000\002\164\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\t\220\003\000\t\212\003\000\t\204\003\000\005l\001\000\005d\001\000\002\228\003\000\002\220\003\000\002\212\003\000\t\220\004\000\t\212\004\000\t\204\004\000\002\228\004\000\002\220\004\000\002\212\004\000\t\204\005\000\002\212\005\000\t\204\006\000\002\212\006\000\t\204\007\000\002\212\007\000\002\212\b\000\b\224\001\000\002\232\001\000\002\212\t\000\002\184\001\000\002\164\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\t\220\005\000\002\228\005\000\t\220\006\000\002\228\006\000\t\220\007\000\002\228\007\000\002\228\b\000\b\224\001\000\002\232\001\000\002\228\t\000\002\184\001\000\002\164\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\t\212\005\000\002\220\005\000\t\212\006\000\002\220\006\000\t\212\007\000\002\220\007\000\002\220\b\000\b\224\001\000\002\232\001\000\002\220\t\000\002\184\001\000\002\164\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\n\024\003\000\002\192\003\000\002\192\004\000\b\224\001\000\002\232\001\000\002\192\005\000\002\184\001\000\002\164\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\b\132\001\000\002H\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\168\002\000\002\164\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\t\188\004\000\t\188\005\000\t\196\003\000\t\196\004\000\t\196\005\000\t\192\003\000\t\192\004\000\t\192\005\000\t\220\003\000\t\212\003\000\t\204\003\000\005l\001\000\005d\001\000\t\220\004\000\t\212\004\000\t\204\004\000\t\204\005\000\t\204\006\000\t\204\007\000\t\220\005\000\t\220\006\000\t\220\007\000\t\212\005\000\t\212\006\000\t\212\007\000\n\024\003\000\t\200\004\000\t\200\005\000\t\216\003\000\t\216\004\000\t\216\005\000\t\208\003\000\t\208\004\000\t\208\005\000\002<\006\000\001\220\001\000\001\224\001\000\002<\007\000\002<\b\000\002<\t\000\002<\n\000\002<\011\000\002\004\006\000\002\004\007\000\002\004\b\000\002\004\t\000\002\000\005\000\002\000\006\000\002\000\007\000\002\000\b\000\002\000\t\000\002\000\n\000\002\000\011\000\003\024\002\000\012x\001\000\n\160\001\000\nt\001\000\np\001\000\nh\001\000\003$\001\000\001\180\001\000\001\148\001\000\003$\002\000\003$\003\000\003$\004\000\003\028\001\000\003\028\002\000\000\128\001\000\000l\001\000\003\028\003\000\003\028\004\000\003 \001\000\003 \002\000\003$\005\000\002$\b\000\002 \004\000\002 \005\000\004\240\003\000\004\240\004\000\004\240\005\000\004\244\002\000\004\236\002\000\004\244\003\000\004\236\003\000\b\156\002\000\b\160\001\000\002\028\004\000\b\160\002\000\b\160\003\000\b\152\001\000\0024\004\000\0020\004\000\0024\005\000\0020\005\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\0024\006\000\0020\006\000\0020\007\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\0020\b\000\t\228\004\000\t\224\004\000\t\224\005\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\002D\004\000\t\172\002\000\b\224\001\000\002\232\001\000\002\184\001\000\002\164\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\t\172\003\000\n(\001\000\n$\001\000\n\024\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\176\002\000\n8\002\000\n8\003\000\b\224\001\000\007\024\002\000\002\232\001\000\002\184\001\000\002\164\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\t\b\002\000\t\004\002\000\t\000\002\000\t\b\003\000\t\004\003\000\t\b\004\000\n\020\002\000\n\016\002\000\n\016\003\000\nP\002\000\nP\003\000\002\024\b\000\002\020\003\000\002\020\004\000\005\176\001\000\005\172\001\000\005\164\001\000\002\020\005\000\002\020\006\000\002\020\007\000\002\012\002\000\002\012\003\000\002\012\004\000\002\012\005\000\002\012\006\000\002\012\007\000\002\012\b\000\002\016\002\000\002\016\003\000\002\016\004\000\002\016\005\000\002\016\006\000\002\016\007\000\002\016\b\000\002\016\t\000\011|\002\000\011\132\005\000\004(\002\000\0070\002\000\003\204\004\000\003\204\005\000\003\208\002\000\012\028\001\000\012\024\001\000\004\000\002\000\003\252\002\000\004\000\003\000\004\000\004\000\004\000\005\000\004\000\006\000\001\216\001\000\004\000\007\000\004\000\b\000\b\148\001\000\003\252\003\000\003\252\004\000\003\252\005\000\001\216\001\000\003\252\006\000\003\252\007\000\003\248\002\000\003\248\003\000\003\248\004\000\003\244\002\000\004\224\005\000\004\224\006\000\b\224\001\000\002\232\001\000\002\188\003\000\002\184\001\000\002\164\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\nD\002\000\n@\002\000\n@\003\000\n(\001\000\n$\001\000\n\024\001\000\n\b\002\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\188\001\000\t\240\002\000\t\236\002\000\t\240\003\000\t\236\003\000\t\240\004\000\t\236\004\000\t\240\005\000\t\236\005\000\005\176\001\000\005\172\001\000\005\164\001\000\t\236\006\000\t\240\006\000\t\240\007\000\005\228\001\000\005\224\001\000\005\216\001\000\t\240\b\000\t\184\002\000\t\180\002\000\t\180\003\000\t\184\003\000\t\184\004\000\002(\004\000\002(\005\000\b\160\001\000\002(\006\000\001\232\004\000\001\232\005\000\b\160\001\000\001\232\006\000\b\224\001\000\007X\004\000\007T\004\000\007P\004\000\007L\004\000\002\232\001\000\002\184\001\000\002\164\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\007L\005\000\007X\005\000\007X\006\000\005\228\001\000\005\224\001\000\005\216\001\000\007X\007\000\007T\005\000\007P\005\000\007T\006\000\007P\006\000\005\228\001\000\005\224\001\000\005\216\001\000\007P\007\000\007T\007\000\007T\b\000\005\228\001\000\005\224\001\000\005\216\001\000\007T\t\000\006d\005\000\005\176\001\000\005\172\001\000\005\164\001\000\006d\006\000\006`\002\000\006`\003\000\006`\004\000\005\176\001\000\005\172\001\000\005\164\001\000\006`\005\000\004\156\002\000\004\156\003\000\004\156\004\000\004\152\002\000\002\244\003\000\002\244\004\000\005\b\003\000\005\000\003\000\004\248\003\000\005\b\004\000\005\000\004\000\004\248\004\000\005\000\005\000\004\248\005\000\005\000\006\000\004\248\006\000\005\016\001\000\004\248\007\000\005\012\001\000\005\004\001\000\004\252\001\000\000\128\001\000\000l\001\000\005\004\002\000\004\252\002\000\004\252\003\000\000x\002\000\000t\002\000\000t\003\000\0030\003\000\0030\004\000\0030\005\000\b\212\001\000\000\132\002\000\000p\002\000\000\132\003\000\000p\003\000\000\132\004\000\000\132\005\000\000p\004\000\b\212\002\000\b\212\003\000\001\216\001\000\b\216\001\000\001\216\001\000\000X\002\000\000X\003\000\b\216\002\000\b\216\003\000\001\216\001\000\006T\002\000\006T\003\000\006T\004\000\006D\002\000\006,\002\000\001\216\001\000\0064\002\000\012(\002\000\011\176\006\000\011\176\007\000\011\176\b\000\003\\\001\000\002\252\001\000\003\\\002\000\002\252\002\000\002\252\003\000\002\252\004\000\002\252\005\000\011\176\t\000\b`\001\000\b\\\001\000\011\176\n\000\b\\\002\000\b`\002\000\bL\001\000\bT\001\000\bP\001\000\bX\001\000\003`\001\000\003\000\001\000\003\000\002\000\003\000\003\000\003\000\004\000\011\172\004\000\003l\004\000\0050\001\000\003l\005\000\011\172\005\000\011\172\006\000\011\172\007\000\011\172\b\000\b`\001\000\b\\\001\000\011\172\t\000\005\152\003\000\005\152\004\000\005\208\005\000\005\176\001\000\005\172\001\000\005\164\001\000\005\228\001\000\005\224\001\000\005\216\001\000\000\\\005\000\000\\\006\000\012\156\006\000\012\156\007\000\005\200\003\000\005\200\004\000\nt\007\000\005\228\001\000\005\224\001\000\005\216\001\000\nt\b\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\001\016\002\000\001\012\002\000\001\012\003\000\001\016\003\000\001\216\001\000\001\016\004\000\001\016\005\000\t\244\004\000\t\244\005\000\t\244\006\000\002,\004\000\002,\005\000\b\160\001\000\002,\006\000\001\248\004\000\001\244\004\000\001\240\004\000\001\236\004\000\001\248\005\000\001\240\005\000\b\160\001\000\001\248\006\000\001\240\006\000\001\248\007\000\001\248\b\000\001\244\005\000\001\244\006\000\0028\004\000\0028\005\000\0028\006\000\0028\007\000\000\176\003\000\000\176\004\000\001\252\003\000\001\252\004\000\001\252\005\000\001\252\006\000\001\252\007\000\003|\001\000\003|\002\000\000\000\001\000\000\004\000\000\003\136\001\000\003\136\002\000\000\004\001\000\000\b\000\000\012x\001\000\005D\001\000\001\148\001\000\005D\002\000\005D\003\000\005H\001\000\000\b\001\000\005|\001\000\005T\001\000\005P\001\000\005L\001\000\005<\001\000\005T\002\000\005P\002\000\005L\002\000\005<\002\000\012x\001\000\005P\003\000\005P\004\000\005P\005\000\005T\003\000\005L\003\000\000P\001\000\005@\001\000\000T\001\000\007\\\001\000\007\\\002\000\000\012\000\000\000\012\001\000\007`\001\000\007`\002\000\000\016\000\000\000\016\001\000\007d\001\000\001\216\001\000\007d\002\000\000\020\000\000\007h\001\000\007h\002\000\000\020\001\000\000\024\000\000\000\024\001\000\007l\001\000\005|\001\000\005<\001\000\007l\002\000\000\028\000\000\000\028\001\000\007p\001\000\005l\001\000\007p\002\000\000 \000\000\000 \001\000\007t\001\000\005\176\001\000\005\172\001\000\005\164\001\000\007t\002\000\000$\000\000\000$\001\000\007x\001\000\005\228\001\000\005\224\001\000\005\216\001\000\007x\002\000\000(\000\000\000(\001\000\007|\001\000\007|\002\000\000,\000\000\007\168\001\000\007\156\001\000\007\148\001\000\007\140\001\000\007\136\001\000\007\128\001\000\007\128\002\000\000,\001\000\0000\000\000\007\132\001\000\007\132\002\000\0000\001\000\005t\001\000\005l\001\000\005t\002\000\005l\002\000\0004\000\000\011\252\001\000\011\248\001\000\011\244\001\000\011\240\001\000\011\236\001\000\011\232\001\000\011\228\001\000\011\252\002\000\011\248\002\000\011\244\002\000\011\240\002\000\011\236\002\000\011\232\002\000\011\228\002\000\011\252\003\000\011\232\003\000\011\236\003\000\011\248\003\000\011\240\003\000\011\244\003\000\005t\001\000\005l\001\000\012\012\001\000\0004\001\000\012\b\001\000\012\b\002\000\004\184\001\000\004\184\002\000\012\000\001\000\012\000\002\000\012\000\003\000\012\004\001\000\012\004\002\000\0008\000\000\004\196\001\000\004\192\001\000\004\204\001\000\004\200\001\000\004\200\002\000\004\204\002\000\004\196\002\000\004\196\003\000\004\196\004\000\004\192\002\000\0008\001\000\012t\001\000\012t\002\000\012t\003\000\012t\004\000\012p\001\000\012p\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\000[\000\\\000^\000_\000`\000b\000c\000d\000k\000l\000m\000n\000o\000p\000s\000t\000u\000w\000y\000{\000|\000}\000\127\000\128\000\129\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\156\000\158\000\159\000\160\000\162\000\164\000\165\000\167\000\169\000\171\000\172\000\174\000\176\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\194\000\195\000\196\000\198\000\199\000\200\000\201\000\202\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\222\000\226\000\230\000\231\000\233\000\234\000\236\000\238\000\239\000\240\000\241\000\244\000\245\000\246\000\247\000\248\000\249\000\250\000\251\000\252\000\254\000\255\001\000\001\001\001\003\001\005\001\006\001\b\001\012\001\018\001\020\001\021\001\022\001\024\001\028\001\031\001 \001!\001#\001$\001%\001&\001(\001)\001*\001+\0011\0015\0019\001:\001;\001<\001=\001?\001A\001B\001C\001D\001E\001F\001G\001H\001I\001J\001K\001L\001M\001N\001O\001P\001W\001Y\001[\001]\001^\001_\001`\001a\001b\001c\001e\001g\001h\001i\001j\001k\001l\001p\001q\001s\001t\001v\001x\001y\001z\001}\001~\001\129\001\130\001\133\001\134\001\135\001\136\001\137\001\139\001\140\001\141\001\142\001\143\001\144\001\145\001\146\001\148\001\149\001\151\001\152\001\153\001\154\001\157\001\158\001\159\001\160\001\161\001\162\001\163\001\164\001\168\001\169\001\172\001\173\001\174\001\175\001\177\001\178\001\179\001\180\001\182\001\183\001\184\001\185\001\187\001\188\001\189\001\191\001\192\001\193\001\194\001\195\001\197\001\198\001\200\001\201\001\203\001\205\001\206\001\207\001\208\001\210\001\211\001\213\001\214\001\217\001\218\001\219\001\221\001\222\001\223\001\224\001\226\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\247\001\248\001\249\001\250\001\251\002\002\002\b\002\011\002\012\002\r\002\014\002\015\002\016\002\017\002\019\002\020\002\026\002\027\002!\002\"\002(\002)\002/\0020\0021\0022\0024\002:\002;\002>\002F\002G\002I\002J\002K\002L\002M\002N\002O\002R\002S\002T\002[\002\\\002]\002_\002`\002f\002l\002m\002n\002t\002u\002w\002x\002y\002z\002\130\002\132\002\133\002\134\002\140\002\144\002\147\002\148\002\149\002\150\002\151\002\152\002\153\002\154\002\160\002\162\002\163\002\165\002\166\002\168\002\169\002\170\002\171\002\173\002\174\002\175\002\176\002\177\002\180\002\182\002\183\002\184\002\191\002\192\002\194\002\195\002\196\002\197\002\198\002\199\002\207\002\208\002\209\002\210\002\211\002\212\002\213\002\218\002\220\002\221\002\222\002\223\002\224\002\225\002\227\002\228\002\229\002\230\002\231\002\232\002\233\002\235\002\236\002\237\002\238\002\239\002\243\002\244\002\246\002\248\002\250\002\252\002\253\002\254\003\000\003\001\003\003\003\005\003\006\003\b\003\t\003\011\003\012\003\016\003\018\003\020\003\021\003\025\003\026\003\030\003\031\003\"\003$\003&\003'\003(\003)\003*\003+\003/\0032\0033\0036\0037\0038\003;\003<\003>\003?\003@\003A\003E\003F\003J\003K\003L\003M\003N\003R\003Y\003Z\003_\003`\003a\003e\003f\003g\003h\003j\003k\003o\003p\003r\003t\003w\003x\003y\003{\003|\003}\003~\003\127\003\128\003\130\003\132\003\134\003\136\003\138\003\140\003\141\003\142\003\143\003\144\003\152\003\153\003\155\003\157\003\159\003\167\003\168\003\169\003\170\003\171\003\173\003\175\003\177\003\184\003\185\003\186\003\187\003\188\003\194\003\195\003\196\003\197\003\198\003\211\003\212\003\225\003\226\003\227\003\230\003\231\003\232\003\233\003\234\003\247\003\254\003\255\004\000\004\024\004\026\004\027\004\028\004\029\004\031\004!\004$\004%\004'\004(\004)\004*\004+\004,\004-\004:\004;\004H\004T\004Y\004Z\004\\\004^\004_\004`\004a\004e\004f\004j\004k\004m\004o\004q\004s\004t\004v\004w\004x\004z\004{\004}\004\138\004\139\004\140\004\141\004\142\004\144\004\145\004\146\004\147\004\149\004\150\004\151\004\178\004\179\004\203\004\204\004\228\004\229\004\253\004\254\005\022\005\023\005/\0050\005H\005I\005a\005b\005z\005{\005\147\005\148\005\172\005\173\005\197\005\198\005\222\005\223\005\247\005\248\006\016\006\017\006)\006*\006B\006C\006[\006\\\006t\006u\006\141\006\142\006\166\006\167\006\191\006\192\006\216\006\217\006\219\006\232\006\233\007\001\007\004\007\005\007\006\007\007\007\b\007\t\007\n\007\012\007\r\007\015\007\016\007\017\007\023\007\024\007\025\007\026\007 \007!\007'\007(\007.\007/\0070\0071\0072\0074\0075\007;\007<\007=\007>\007?\007A\007H\007I\007J\007M\007N\007O\007P\007Q\007R\007V\007W\007X\007Y\007Z\007\\\007^\007_\007`\007a\007e\007f\007j\007k\007o\007p\007q\007r\007s\007t\007u\007v\007w\007x\007y\007z\007{\007|\007}\007~\007\127\007\128\007\129\007\130\007\131\007\132\007\136\007\137\007\138\007\139\007\140\007\141\007\142\007\144\007\145\007\146\007\147\007\149\007\150\007\151\007\153\007\154\007\155\007\156\007\158\007\160\007\162\007\164\007\165\007\167\007\168\007\169\007\170\007\172\007\173\007\174\007\175\007\177\007\179\007\181\007\183\007\184\007\186\007\188\007\190\007\191\007\192\007\194\007\195\007\196\007\198\007\199\007\200\007\202\007\204\007\208\007\209\007\213\007\214\007\216\007\219\007\221\007\222\007\223\007\224\007\225\007\229\007\232\007\234\007\235\007\236\007\239\007\244\007\245\007\246\007\249\007\254\007\255\b\000\b\001\b\002\b\004\b\n\b\016\b\022\b\025\b\028\b\031\b \b$\b%\b&\b'\b(\b*\b+\b,\b-\b/\b0\b1\b2\b4\b5\b6\b7\b?\bE\bH\bI\bJ\bK\bL\bM\bN\bO\bP\bQ\bR\bS\bT\bU\bV\bW\bY\bZ\b[\b\\\b]\b^\b`\ba\bb\bc\bd\bg\bj\bk\bl\bn\bo\bp\br\bs\bt\bu\bv\bx\by\bz\b|\b}\b~\b\127\b\130\b\131\b\132\b\133\b\136\b\137\b\143\b\145\b\147\b\149\b\151\b\152\b\156\b\157\b\161\b\165\b\167\b\168\b\171\b\172\b\173\b\174\b\175\b\179\b\180\b\181\b\182\b\183\b\184\b\188\b\189\b\190\b\191\b\193\b\194\b\196\b\197\b\198\b\202\b\203\b\204\b\205\b\206\b\207\b\208\b\209\b\213\b\214\b\215\b\216\b\217\b\218\b\220\b\221\b\222\b\223\b\224\b\225\b\226\b\228\b\229\b\230\b\231\b\232\b\233\b\234\b\235\b\237\b\238\b\239\b\240\b\241\b\243\b\244\b\246\b\247\b\248\b\249\b\250\b\252\b\253\b\254\b\255\t\001\t\002\t\004\t\005\t\006\t\007\t\b\t\t\t\n\t\011\t\012\t\014\t\016\t\017\t\018\t\020\t\021\t\022\t\024\t\025\t\026\t\027\t\029\t\031\t \t!\t#\t$\t%\t'\t(\t*\t,\t-\t.\t/\t1\t2\t4\t5\t6\t7\t8\t9\t:\t;\t<\t=\t?\t@\tA\tB\tC\tD\tE\tF\tH\tI\tJ\tK\tL\tM\tN\tO\tP\tQ\tS\tT\tU\tV\tZ\t]\t^\t_\t`\ta\tb\td\tf\tg\ti\tj\tk\tl\tm\tn\to\tp\tq\tr\ts\tt\tu\tv\tw\tx\ty\tz\t{\t|\t}\t~\t\127\t\128\t\129\t\130\t\131\t\132\t\133\t\134\t\135\t\136\t\138\t\139\t\140\t\141\t\142\t\143\t\144\t\145\t\146\t\147\t\148\t\150\t\151\t\152\t\153\t\154\t\155\t\156\t\157\t\158\t\160\t\162\t\163\t\164\t\165\t\166\t\167\t\168\t\169\t\170\t\171\t\172\t\174\t\176\t\178\t\180\t\181\t\182\t\183\t\184\t\185\t\186\t\187\t\190\t\192\t\193\t\195\t\196\t\197\t\198\t\199\t\201\t\203\t\205\t\206\t\207\t\208\t\209\t\210\t\211\t\214\t\217\t\220\t\223\t\225\t\226\t\227\t\228\t\230\t\231\t\232\t\233\t\234\t\235\t\236\t\237\t\238\t\239\t\240\t\241\t\242\t\243\t\244\t\245\t\249\t\251\t\252\t\254\t\255\n\000\n\001\n\002\n\003\n\006\n\t\n\011\n\012\n\r\n\014\n\016\n\017\n\018\n\019\n\020\n\021\n\022\n\023\n\024\n\025\n\026\n\028\n\029\n\030\n \n$\n%\n&\n'\n(\n)\n*\n,\n-\n.\n0\n1\n2\n4\n5\n6\n7\n8\n:\n;\n=\n>\n?\nA\nB\nO\n\\\n^\n_\n`\na\nc\nd\ne\ng\nh\ni\nk\nl\nn\no\nq\nr\ns\nt\nu\nx\ny\nz\n{\n|\n~\n\127\n\128\n\129\n\130\n\131\n\133\n\134\n\135\n\136\n\137\n\138\n\139\n\140\n\141\n\142\n\143\n\144\n\145\n\146\n\148\n\149\n\150\n\151\n\153\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\167\n\168\n\169\n\170\n\171\n\172\n\173\n\174\n\175\n\176\n\177\n\178\n\179\n\181\n\182\n\183\n\185\n\186\n\187\n\188\n\189\n\190\n\191\n\192\n\193\n\194\n\195\n\196\n\197\n\198\n\201\n\202\n\205\n\206\n\207\n\208\n\209\n\210\n\234\n\240\n\241\n\242\n\244\n\245\n\246\n\247\n\248\n\249\n\251\n\252\n\253\n\255\011\000\011\001\011\002\011\028\011\030\011\031\011!\011\"\011#\011$\011%\011&\011'\011(\0115\0116\0117\011:\011;\011>\011A\011C\011D\011E\011F\011G\011U\011b\011d\011e\011k\011m\011o\011q\011r\011\138\011\140\011\142\011\144\011\145\011\169\011\171\011\173\011\175\011\176\011\200\011\214\011\216\011\218\011\220\011\221\011\245\011\247\011\249\011\251\011\252\012\020\012\022\012\024\012\026\012\027\0123\012;\012A\012C\012E\012G\012H\012`\012b\012d\012f\012g\012\127\012\129\012\131\012\133\012\134\012\158\012\160\012\161\012\185\012\187\012\211\012\212\012\213\012\214\012\215\012\216\012\217\012\218\012\219\012\224\012\227\012\228\012\229\012\230\012\231\012\232\012\233\012\234\012\235\012\236\012\237\012\238\012\239\012\240\012\241\012\242\012\243\012\244\012\245\012\246\012\247\012\248\012\249\012\250\012\251\012\252\012\253\012\254\012\255\r\000\r\001\r\002\r\003\r\004\r\005\r\006\r\007\r\b\r\t\r\017\r\018\r\019\r\020\r\021\r\024\r\025\r\026\r\027\r\028\r\029\r\030\r\031\r \r!\r\"\r#\r%\r&\r'\r(\r*\r+\r,\r-\r/\r1\rJ\rK\rc\rd\re\rf\rs\r\139\r\140\r\153\r\154\r\155\r\179\r\182\r\184\r\185\r\186\r\187\r\188\r\189\r\190\r\191\r\192\r\193\r\197\r\198\r\199\r\200\r\201\r\202\r\203\r\204\r\205\r\206\r\207\r\208\r\209\r\210\r\211\r\212\r\213\r\214\r\215\r\216\r\217\r\218\r\219\r\220\r\221\r\225\r\226\r\227\r\228\r\230\r\231\r\232\r\234\r\235\r\237\r\238\r\239\r\240\r\241\r\242\r\243\r\244\r\245\014\r\014\014\014\015\014\016\014\029\014\031\014!\014#\014(\014)\014*\014.\014/\0141\0142\0143\0144\0145\0146\0148\0149\014:\014<\014W\014X\014Y\014]\014^\014`\014e\014f\014g\014k\014l\014p\014q\014r\014s\014w\014x\014y\014z\014{\014|\014}\014~\014\129\014\132\014\134\014\136\014\137\014\138\014\143\014\145\014\146\014\147\014\148\014\149\014\150\014\151\014\152\014\155\014\157\014\158\014\159\014\160\014\161\014\163\014\166\014\167\014\168\014\170\014\171\014\172\014\173\014\174\014\176\014\177\014\178\014\179\014\180\014\181\014\183\014\185\014\186\014\187\014\188\014\191\014\192\014\193\014\194\014\195\014\196\014\197\014\198\014\200\014\201\014\202\014\203\014\205\014\207\014\208\014\209\014\210\014\213\014\214\014\215\014\216\014\220\014\224\014\225\014\226\014\227\014\228\014\229\014\233\014\234\014\241\014\242\014\243\014\245\014\246\014\247\014\248\014\249\014\250\014\251\014\253\015\001\015\003\015\006\015\007\015\b\015\t\015\n\015\011\015\012\015\r\015\014\015\015\015\016\015\017\015\018\015\019\015\020\015\021\015\022\015\023\015\024\015\025\015\026\015\027\015\028\015\029\015 \015!\015\"\015#\015$\015)\015-\015/\0150\0151\0152\0153\0154\0155\0156\0157\0158\0159\015:\015;\015<\015=\015>\015@\015A\015B\015C\015D\015E\015F\015G\015J\015K\015L\015M\015O\015P\015Q\015R\015V\015W\015X\015Y\015]\015^\015_\015`\015a\015b\015c\015i\015j\015k\015l\015m\015n\015o\015q\015s\015t\015{\015\130\015\131\015\132\015\133\015\134\015\135\015\138\015\139\015\140\015\141\015\142\015\143\015\144\015\145\015\146\015\147\015\148\015\149\015\150\015\152\015\153\015\154\015\155\015\156\015\157\015\158\015\159\015\160\015\161\015\162\015\163\015\164\015\165\015\166\015\167")) + ((32, "\000\000\000\000\000\001\252\001\000\002\240\001\000\011t\001\000\011p\001\000\011l\001\000\011h\001\000\011d\001\000\n\176\001\000\011`\001\000\011\\\001\000\011X\001\000\011T\001\000\011P\001\000\011L\001\000\011H\001\000\011D\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\n\172\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\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\000\172\001\000\000\168\001\000\000\172\002\000\000\172\003\000\002\240\002\000\001\252\002\000\000\176\001\000\000\176\002\000\0028\001\000\0028\002\000\0028\003\000\n4\001\000\005h\001\000\001\248\001\000\001\244\001\000\001\240\001\000\001\236\001\000\001\248\002\000\001\244\002\000\001\240\002\000\001\236\002\000\001\248\003\000\001\244\003\000\001\240\003\000\001\236\003\000\002,\001\000\002,\002\000\002,\003\000\001\156\001\000\001\136\001\000\002\248\001\000\n\012\001\000\t\248\001\000\t\248\002\000\t\248\003\000\001\016\001\000\001\012\001\000\n|\001\000\t\156\001\000\t\152\001\000\t\152\002\000\t\156\002\000\t\148\001\000\t\144\001\000\t\144\002\000\t\148\002\000\012|\001\000\n\164\001\000\nx\001\000\nt\001\000\nl\001\000\001\180\001\000\001\148\001\000\006\200\001\000\001\148\002\000\006t\001\000\006\188\001\000\006\184\001\000\t\156\001\000\t\152\001\000\006\180\001\000\006\204\001\000\006\220\001\000\nx\002\000\nt\002\000\nx\003\000\nt\003\000\nx\004\000\nt\004\000\005\192\001\000\005\188\001\000\nx\005\000\nt\005\000\nt\006\000\nx\006\000\0058\001\000\003t\001\000\005\200\001\000\005\200\002\000\012\160\001\000\012\160\002\000\012\160\003\000\012|\001\000\006\180\001\000\006\196\001\000\006\192\001\000\006x\001\000\006\212\001\000\006\176\001\000\006\172\001\000\006\168\001\000\006\164\001\000\006\160\001\000\006\152\001\000\006\216\001\000\006\208\001\000\006\148\001\000\006\144\001\000\006\140\001\000\006\136\001\000\006\132\001\000\006\128\001\000\006\132\002\000\006\128\002\000\003\132\001\000\003\132\002\000\006\132\003\000\006\128\003\000\006\132\004\000\006\128\004\000\006\132\005\000\006\140\002\000\006\136\002\000\006\140\003\000\006\136\003\000\006\140\004\000\006\136\004\000\006\140\005\000\006\148\002\000\006\144\002\000\006\148\003\000\006\144\003\000\006\148\004\000\006\144\004\000\006\148\005\000\006\236\001\000\006\224\001\000\006\156\001\000\006|\001\000\006\228\001\000\006\232\001\000\012|\002\000\012|\003\000\012\128\001\000\012\160\004\000\012\160\005\000\000d\001\000\0058\001\000\b\148\001\000\000`\001\000\003t\001\000\003x\001\000\b\148\002\000\000`\002\000\007D\001\000\007D\002\000\007D\003\000\007@\001\000\000\132\001\000\000p\001\000\000\\\001\000\000X\001\000\000`\001\000\000`\002\000\000\\\002\000\000\\\003\000\000\\\004\000\005\208\001\000\005\208\002\000\005\208\003\000\005\208\004\000\005\184\001\000\005\152\001\000\005\152\002\000\011\180\001\000\011\176\001\000\003p\001\000\003l\001\000\011\180\002\000\011\176\002\000\003p\002\000\003l\002\000\011\180\003\000\011\176\003\000\003p\003\000\003l\003\000\012p\001\000\012\\\001\000\012P\001\000\012\\\002\000\011\180\004\000\003p\004\000\012d\001\000\012T\001\000\012d\002\000\012@\001\000\012l\001\000\012h\001\000\012`\001\000\012X\001\000\012`\002\000\012h\002\000\0124\001\000\012H\001\000\012D\001\000\012D\002\000\0124\002\000\b\200\001\000\012@\002\000\b\204\001\000\012@\003\000\b\204\002\000\b\204\003\000\011\180\005\000\003p\005\000\0050\001\000\003p\006\000\012,\001\000\0058\001\000\001\160\001\000\006X\001\000\006H\001\000\0068\001\000\0060\001\000\001\164\001\000\001\148\001\000\000\132\001\000\000p\001\000\000\\\001\000\000X\001\000\0050\001\000\0030\001\000\0030\002\000\0050\001\000\000x\001\000\000t\001\000\0050\001\000\005\b\001\000\005\000\001\000\004\248\001\000\005\b\002\000\005\000\002\000\004\248\002\000\002\244\001\000\002\244\002\000\004\156\001\000\004\152\001\000\003\144\001\000\000@\001\000\000<\001\000\006h\001\000\006d\001\000\006h\002\000\006h\003\000\006h\004\000\007\\\001\000\007X\001\000\007T\001\000\007P\001\000\007L\001\000\007H\001\000\007\\\002\000\007X\002\000\007T\002\000\007P\002\000\007\\\003\000\007X\003\000\007T\003\000\007P\003\000\t\236\001\000\t\236\002\000\t\236\003\000\005`\001\000\005l\001\000\005d\001\000\005l\002\000\005d\002\000\005l\003\000\005d\003\000\005\128\001\000\001\b\001\000\t\236\004\000\004l\001\000\004l\002\000\011\220\001\000\011\216\001\000\001\232\001\000\001\232\002\000\001\232\003\000\002(\001\000\002(\002\000\002(\003\000\012|\001\000\t\244\001\000\t\240\001\000\t\188\001\000\t\184\001\000\001\180\001\000\001\148\001\000\n\012\001\000\006t\001\000\nH\001\000\nD\001\000\012\128\001\000\002\188\001\000\002\188\002\000\004\224\001\000\004\224\002\000\004\224\003\000\b8\001\000\004\224\004\000\t\172\001\000\t\168\001\000\t\164\001\000\001\144\001\000\001\144\002\000\t\160\001\000\003\176\001\000\t\160\002\000\t\160\003\000\004\220\001\000\004\216\001\000\004\212\001\000\004\208\001\000\007\020\001\000\000\160\001\000\000\156\001\000\006\252\001\000\000\160\002\000\000\156\002\000\000\152\001\000\000\148\001\000\000\152\002\000\000\148\002\000\000\144\001\000\000\140\001\000\000\136\001\000\000|\001\000\005|\001\000\005<\001\000\0054\001\000\005|\002\000\005|\003\000\005|\001\000\005<\001\000\005|\004\000\005<\002\000\005<\003\000\005x\001\000\005<\002\000\0054\002\000\0054\003\000\001|\001\000\000|\002\000\000\140\002\000\006\024\001\000\006\024\002\000\000h\001\000\0034\001\000\003(\001\000\0034\002\000\012\024\001\000\b\232\001\000\b\232\002\000\0120\001\000\000\164\001\000\b\232\003\000\000\128\001\000\000l\001\000\000\128\002\000\000\128\003\000\000l\002\000\003,\001\000\003,\002\000\003,\003\000\003,\004\000\012\020\001\000\b\236\001\000\000\128\001\000\000l\001\000\b\236\002\000\b\236\003\000\000\128\001\000\000l\001\000\0034\003\000\b\240\001\000\b\184\001\000\b\188\001\000\000\140\003\000\000\140\004\000\b\188\002\000\b\188\003\000\011\228\001\000\011\224\001\000\011\224\002\000\006\240\001\000\011\224\003\000\011\224\004\000\b\172\001\000\b\172\002\000\000D\001\000\b\172\003\000\000H\001\000\000H\002\000\000H\003\000\000H\004\000\011\224\005\000\b\168\001\000\000H\001\000\011\228\002\000\b\244\001\000\001\216\001\000\001\216\002\000\001\212\001\000\000H\001\000\b\240\001\000\000\136\002\000\000\136\003\000\000\144\002\000\000\144\003\000\b\188\001\000\000\144\004\000\000\144\005\000\b\188\001\000\000\148\003\000\000\148\004\000\b\188\001\000\000\160\003\000\000\156\003\000\000\156\004\000\000\160\004\000\b\144\001\000\000\160\005\000\000\160\006\000\b\144\002\000\b\140\001\000\007\020\002\000\001\216\001\000\004\220\002\000\004\216\002\000\004\212\002\000\004\208\002\000\007,\001\000\007\200\001\000\007\200\002\000\007\200\003\000\001\128\001\000\n\144\001\000\n\144\002\000\001\140\001\000\001\152\001\000\001\132\001\000\nd\001\000\012\132\001\000\nh\001\000\007\200\004\000\np\001\000\n\132\001\000\n\128\001\000\n\132\002\000\n\132\003\000\t\140\001\000\n\140\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\005l\001\000\001\176\001\000\001\172\001\000\n\160\002\000\n\156\002\000\n\152\002\000\n\148\002\000\005l\002\000\001\176\002\000\n\160\003\000\n\156\003\000\001\176\003\000\n\156\004\000\007\164\001\000\007\164\002\000\007\164\003\000\007\184\001\000\007\148\001\000\007\168\001\000\007\156\001\000\007\168\002\000\007\172\001\000\007\168\003\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\172\002\000\007\172\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\140\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\003\000\007\140\001\000\007\160\002\000\007\172\001\000\007\160\003\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\152\002\000\007\152\003\000\007\144\002\000\n\140\001\000\007\196\001\000\007\196\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\n\168\001\000\n\136\001\000\007\192\001\000\007\188\001\000\012|\001\000\n\164\001\000\nx\001\000\nt\001\000\nl\001\000\007\192\002\000\001\180\001\000\001\148\001\000\007\192\003\000\006 \001\000\006\028\001\000\006 \002\000\007\192\004\000\007\192\005\000\007\192\006\000\n\136\001\000\001\184\001\000\t\148\001\000\t\144\001\000\006\192\001\000\001\180\002\000\001\180\003\000\n\164\002\000\nl\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\nl\003\000\n\164\003\000\n\164\004\000\001\216\001\000\n\164\005\000\007\188\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\172\001\000\007\164\004\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\001\176\004\000\001\176\005\000\n\160\004\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\n\160\005\000\n\152\003\000\t\164\001\000\n\152\004\000\t\164\002\000\t\164\003\000\t\024\001\000\t\020\001\000\t\016\001\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\t\024\002\000\t\020\002\000\t\024\003\000\n\148\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007,\002\000\004\220\003\000\004\216\003\000\004\212\003\000\004\208\003\000\004\220\004\000\004\216\004\000\004\212\004\000\004\216\005\000\007\004\001\000\004\216\006\000\004\220\005\000\t\172\002\000\t\168\002\000\t\168\003\000\nd\001\000\004\000\001\000\003\252\001\000\003\248\001\000\003\244\001\000\003\240\001\000\003\224\001\000\003\220\001\000\003\220\002\000\003\172\001\000\003\168\001\000\003\172\002\000\003\172\003\000\001\216\001\000\003\220\003\000\003\220\004\000\003\224\002\000\003\208\001\000\003\204\001\000\003\204\002\000\003\204\003\000\0074\001\000\002\180\001\000\nd\001\000\004,\001\000\004(\001\000\003\216\001\000\003\212\001\000\007\232\001\000\003\212\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\004$\001\000\004 \001\000\004$\002\000\004$\003\000\001\216\001\000\003\212\003\000\003\212\004\000\003\212\005\000\007\228\001\000\003\216\002\000\012|\001\000\011\136\001\000\n\164\001\000\nx\001\000\nt\001\000\nl\001\000\001\180\001\000\001\148\001\000\011\136\002\000\011\136\003\000\011\136\004\000\003\228\001\000\003\228\002\000\011\128\001\000\004\012\001\000\002\024\001\000\002\020\001\000\002\016\001\000\002\012\001\000\002\024\002\000\002\020\002\000\002\024\003\000\002\024\004\000\002\024\005\000\005\156\001\000\005\156\002\000\003<\001\000\0038\001\000\0038\002\000\003<\002\000\003<\003\000\005\224\001\000\005\212\001\000\005\224\002\000\005\224\003\000\005\204\001\000\005\204\002\000\b\128\001\000\003@\001\000\b\128\002\000\005\204\003\000\005\204\004\000\005\220\001\000\005\232\001\000\005\228\001\000\005\216\001\000\005\204\005\000\005\232\002\000\012\200\001\000\012\196\001\000\012\200\002\000\012\196\002\000\012\200\003\000\012\196\003\000\012\224\001\000\012\220\001\000\012\224\002\000\012\200\004\000\012\200\005\000\000H\001\000\012\196\004\000\012\196\005\000\000H\001\000\012\196\006\000\bx\001\000\bx\002\000\bx\003\000\001\216\001\000\bx\004\000\bx\005\000\001\216\001\000\012<\001\000\012\216\001\000\012\212\001\000\012\208\001\000\012\204\001\000\012\216\002\000\012\212\002\000\012\216\003\000\012\212\003\000\012\212\004\000\012\212\005\000\005\232\001\000\005\228\001\000\005\216\001\000\005\228\002\000\005\232\001\000\005\228\003\000\005\228\001\000\005\216\001\000\005\216\002\000\005|\001\000\005\\\001\000\005<\001\000\005\\\002\000\005<\002\000\005<\003\000\003t\001\000\005\\\003\000\005\248\001\000\005X\001\000\005\236\001\000\012\216\004\000\012\216\005\000\005\232\001\000\005\228\001\000\005\216\001\000\012\208\002\000\012\204\002\000\005l\001\000\012\204\003\000\012\204\004\000\005|\001\000\005<\001\000\005l\002\000\012\208\003\000\012\208\004\000\005|\001\000\005<\001\000\b\176\001\000\b\180\001\000\005\232\003\000\b\180\002\000\b\180\003\000\b|\001\000\005\232\001\000\005\228\001\000\005\224\004\000\005\216\001\000\005\232\001\000\005\228\001\000\005\216\001\000\005\212\002\000\005\212\003\000\005\232\001\000\005\228\001\000\005\216\001\000\003<\004\000\003<\005\000\005\156\003\000\005\156\004\000\005\160\001\000\005\176\001\000\005\172\001\000\005\164\001\000\005\156\005\000\007\\\001\000\007X\001\000\007T\001\000\007P\001\000\007L\001\000\007H\001\000\005\176\002\000\005\176\003\000\007L\002\000\007H\002\000\005\176\001\000\005\172\001\000\005\164\001\000\007L\003\000\007H\003\000\007H\004\000\005\232\001\000\005\228\001\000\005\216\001\000\007H\005\000\005\172\002\000\005\164\002\000\005\168\001\000\005l\001\000\005\180\001\000\005\176\001\000\005\172\001\000\005\164\001\000\002\024\006\000\002\024\007\000\nT\001\000\001\144\001\000\n\024\001\000\n\020\001\000\t\012\001\000\t\b\001\000\t\004\001\000\007\028\001\000\n<\001\000\012\128\001\000\005`\001\000\t\180\001\000\t\176\001\000\002D\001\000\002D\002\000\002D\003\000\t\232\001\000\t\228\001\000\t\232\002\000\t\228\002\000\t\232\003\000\t\228\003\000\0024\001\000\0020\001\000\0024\002\000\0020\002\000\0024\003\000\0020\003\000\002\028\001\000\002\028\002\000\002\028\003\000\b\160\001\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\004\244\001\000\004\240\001\000\004\236\001\000\004\240\002\000\002$\001\000\002 \001\000\002$\002\000\002 \002\000\002$\003\000\002 \003\000\012|\001\000\n\164\001\000\nx\001\000\nt\001\000\nl\001\000\002$\004\000\001\180\001\000\001\148\001\000\002$\005\000\002$\006\000\002$\007\000\003\024\001\000\002\004\001\000\002\000\001\000\002\004\002\000\002\000\002\000\002\004\003\000\002\000\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\002\004\004\000\002\000\004\000\002\004\005\000\002<\001\000\002<\002\000\002<\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\002<\004\000\002<\005\000\n\016\001\000\t\252\001\000\005p\001\000\n,\001\000\n(\001\000\n\028\001\000\n\016\002\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\n,\002\000\n,\003\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\n(\002\000\n(\003\000\t\220\002\000\t\212\002\000\t\204\002\000\t\204\003\000\002@\001\000\002@\002\000\002@\003\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\002@\004\000\n\028\002\000\t\224\002\000\t\216\002\000\t\208\002\000\t\200\002\000\t\196\002\000\t\192\002\000\t\192\003\000\002\168\001\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\002\228\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\002H\001\000\002\b\001\000\003\192\001\000\003\188\001\000\003\192\002\000\003\192\003\000\012$\001\000\012$\002\000\001\216\001\000\012 \001\000\012\028\001\000\012 \002\000\012\028\002\000\001\216\001\000\012 \003\000\012 \004\000\001\216\001\000\003\192\004\000\003\192\005\000\003\188\002\000\003\196\001\000\003\196\002\000\003\200\001\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\003\200\002\000\n\b\001\000\n`\001\000\n\\\001\000\nX\001\000\nP\001\000\nL\001\000\n@\001\000\n8\001\000\n$\001\000\n \001\000\005t\001\000\005l\001\000\001\176\001\000\001\172\001\000\n`\002\000\n\\\002\000\nX\002\000\nP\002\000\nL\002\000\n@\002\000\n8\002\000\n$\002\000\n \002\000\005t\002\000\005l\002\000\001\176\002\000\012|\001\000\n`\003\000\n8\003\000\n \003\000\001\176\003\000\n8\004\000\006\184\001\000\000@\001\000\006\180\001\000\000<\001\000\n`\004\000\n`\005\000\n`\006\000\n`\007\000\005\176\001\000\005\172\001\000\005\164\001\000\n`\b\000\n`\t\000\005\232\001\000\005\228\001\000\005\216\001\000\n`\n\000\011\220\001\000\006\196\001\000\011\216\001\000\006\192\001\000\006x\001\000\002\180\001\000\007\184\001\000\0040\001\000\0040\002\000\0040\003\000\001\216\001\000\0040\004\000\0040\005\000\b\224\001\000\002L\001\000\b\224\002\000\n\b\001\000\002T\001\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\002T\002\000\012\136\001\000\n0\001\000\n\004\001\000\n\000\001\000\004\232\001\000\001\228\001\000\001\228\002\000\001\228\003\000\004\228\001\000\004\016\001\000\002\176\001\000\002\176\002\000\002\176\003\000\t4\001\000\t0\001\000\t,\001\000\t(\001\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\128\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002p\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002l\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\132\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\148\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002|\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002x\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\140\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002h\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002d\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002`\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\\\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002X\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\144\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\136\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\b\228\002\000\b\228\003\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\164\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\003\000\002\164\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\002\184\002\000\b\228\001\000\002\232\001\000\002\184\003\000\002\184\001\000\002\164\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\002\152\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\156\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\160\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\232\002\000\n\004\001\000\002P\001\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\002P\002\000\002\172\001\000\b\228\001\000\002\232\001\000\002\184\001\000\002\172\002\000\002\164\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\t4\002\000\t0\002\000\t,\002\000\t4\003\000\t4\004\000\t4\005\000\t0\003\000\000L\001\000\000L\002\000\nh\001\000\004\b\001\000\004\b\002\000\004\b\003\000\001\216\001\000\004\b\004\000\004\b\005\000\007\224\001\000\007\216\001\000\007\208\001\000\007\204\001\000\007\180\001\000\004\004\001\000\004\004\002\000\004\004\003\000\007\180\002\000\007\180\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\204\002\000\007\204\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\224\002\000\007\224\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\216\002\000\007\216\003\000\007\208\002\000\007\212\001\000\007\220\001\000\007\176\001\000\007\176\002\000\007\176\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\003\236\001\000\000L\003\000\b\016\001\000\b\016\002\000\007\252\001\000\007\248\001\000\007\252\002\000\007\248\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\252\003\000\007\252\004\000\011\192\001\000\011\188\001\000\005\240\001\000\005\240\002\000\005\240\003\000\005\240\004\000\005\240\005\000\007$\001\000\007$\002\000\005\232\001\000\005\228\001\000\005\216\001\000\005\240\006\000\004\132\001\000\004\132\002\000\005\240\007\000\011\192\002\000\011\188\002\000\011\192\003\000\011\188\003\000\011\192\004\000\011\192\005\000\005\132\001\000\005\176\001\000\005\172\001\000\005\164\001\000\005\132\002\000\005\136\001\000\005\232\001\000\005\228\001\000\005\216\001\000\005\136\002\000\005\136\003\000\005\176\001\000\005\172\001\000\005\164\001\000\005\136\004\000\011\192\006\000\011\192\007\000\004\\\001\000\004\\\002\000\004\\\003\000\004\\\004\000\004\\\005\000\004\\\006\000\005\140\001\000\005\140\002\000\011\192\b\000\011\188\004\000\011\188\005\000\011\188\006\000\003\140\001\000\003\140\002\000\003\004\001\000\003\004\002\000\011\212\001\000\011\212\002\000\011\212\003\000\011\212\004\000\005\176\001\000\005\172\001\000\005\164\001\000\011\212\005\000\b\020\001\000\b\020\002\000\b\020\003\000\b\020\004\000\b\020\005\000\b\152\001\000\b\004\001\000\b\152\002\000\b\152\003\000\b\004\002\000\b\004\003\000\001\216\001\000\b\020\006\000\b\020\007\000\006(\001\000\006$\001\000\006(\002\000\b\020\b\000\b\020\t\000\b\000\001\000\001\216\001\000\011|\001\000\t8\001\000\011|\002\000\t8\002\000\011|\003\000\t8\003\000\001\160\001\000\001\164\001\000\001\148\001\000\001\164\002\000\001\164\003\000\001\144\001\000\011|\004\000\t8\004\000\003H\001\000\001\200\001\000\006\000\001\000\003\152\001\000\003\148\001\000\003\152\002\000\003\148\002\000\003\152\003\000\003\148\003\000\b\152\001\000\b\012\001\000\b\012\002\000\b\012\003\000\000H\001\000\003\152\004\000\003\148\004\000\003\152\005\000\003\148\005\000\003\152\006\000\003\152\007\000\b\b\001\000\000H\001\000\001\200\002\000\001\200\003\000\003\164\001\000\003\160\001\000\003\164\002\000\003\156\001\000\b\212\001\000\001\196\001\000\b\212\002\000\001\196\002\000\b\212\003\000\001\196\003\000\000\128\001\000\000l\001\000\003H\002\000\b\208\001\000\001\192\001\000\000\128\001\000\000l\001\000\011|\005\000\001\180\001\000\001\148\001\000\005l\001\000\001\176\001\000\001\172\001\000\005l\002\000\001\176\002\000\001\176\003\000\011|\006\000\011|\007\000\011|\b\000\003X\001\000\003T\001\000\003P\001\000\003L\001\000\b\152\001\000\003X\002\000\003P\002\000\003X\003\000\003P\003\000\003P\004\000\003P\005\000\003P\006\000\000\128\001\000\000l\001\000\b\208\001\000\003X\004\000\001\192\001\000\000\128\001\000\000l\001\000\003L\002\000\003L\003\000\003L\004\000\000\128\001\000\000l\001\000\b\208\001\000\003T\002\000\001\192\001\000\000\128\001\000\000l\001\000\t8\005\000\t8\006\000\t8\007\000\001\168\001\000\007\244\001\000\007\240\001\000\t\\\001\000\tX\001\000\003p\001\000\003l\001\000\003h\001\000\003d\001\000\t\\\002\000\tX\002\000\003p\002\000\003l\002\000\003h\002\000\003d\002\000\t\\\003\000\tX\003\000\003p\003\000\003l\003\000\003h\003\000\003d\003\000\t\\\004\000\003p\004\000\003h\004\000\t\\\005\000\003p\005\000\003h\005\000\0050\001\000\003p\006\000\003h\006\000\003h\007\000\001\144\001\000\000\144\001\000\000\140\001\000\000\136\001\000\006T\001\000\006T\002\000\006T\003\000\006D\001\000\003\\\001\000\001\204\001\000\003\\\002\000\003\\\003\000\003\\\004\000\bL\001\000\001\208\001\000\003\\\001\000\bL\002\000\003h\b\000\bx\001\000\003h\t\000\003h\n\000\bD\001\000\bH\001\000\006`\001\000\006\\\001\000\006P\001\000\006L\001\000\006@\001\000\006<\001\000\006,\001\000\001\216\001\000\006`\002\000\006\\\002\000\006P\002\000\006L\002\000\006@\002\000\006<\002\000\006`\003\000\006P\003\000\006@\003\000\006`\004\000\006`\005\000\006`\006\000\006P\004\000\006@\004\000\003`\001\000\003`\002\000\003`\003\000\006\\\003\000\006\\\004\000\006\\\005\000\006L\003\000\006<\003\000\0064\001\000\003p\007\000\bx\001\000\003p\b\000\003p\t\000\t\\\006\000\t\\\007\000\b\028\001\000\t\\\b\000\t\\\t\000\bp\001\000\t\\\n\000\bp\002\000\bh\001\000\bl\001\000\tX\004\000\003l\004\000\003d\004\000\0050\001\000\003l\005\000\003d\005\000\003d\006\000\003d\007\000\bx\001\000\003d\b\000\003d\t\000\003l\006\000\bx\001\000\003l\007\000\003l\b\000\tX\005\000\tX\006\000\tX\007\000\tX\b\000\bp\001\000\tX\t\000\004\140\001\000\006p\001\000\006l\001\000\006p\002\000\006p\003\000\006p\004\000\006p\005\000\005|\001\000\005<\001\000\006p\006\000\006l\002\000\006l\003\000\006l\004\000\005|\001\000\005<\001\000\006l\005\000\tp\001\000\th\001\000\td\001\000\005\244\001\000\005\240\001\000\005\196\001\000\005\244\002\000\005\240\002\000\005\244\003\000\005\240\003\000\005\244\004\000\005\240\004\000\005\244\005\000\005\240\005\000\005\244\006\000\005\244\007\000\005\232\001\000\005\228\001\000\005\216\001\000\005\244\b\000\tp\002\000\th\002\000\td\002\000\005\196\002\000\tp\003\000\th\003\000\td\003\000\005\196\003\000\005\196\004\000\005\188\001\000\005\196\005\000\005\196\006\000\005|\001\000\005<\001\000\005\196\007\000\tp\004\000\tp\005\000\tp\006\000\tp\007\000\005\232\001\000\005\228\001\000\005\216\001\000\tp\b\000\004d\001\000\004d\002\000\004d\003\000\004d\004\000\005\232\001\000\005\228\001\000\005\216\001\000\004d\005\000\004d\006\000\004d\007\000\tp\t\000\th\004\000\td\004\000\th\005\000\th\006\000\005l\001\000\th\007\000\005\144\001\000\005\232\001\000\005\228\001\000\005\216\001\000\005\144\002\000\td\005\000\td\006\000\005\148\001\000\005\148\002\000\t\128\001\000\t\128\002\000\t\128\003\000\t\128\004\000\005\232\001\000\005\228\001\000\005\216\001\000\t\128\005\000\t8\001\000\t8\002\000\t8\003\000\t8\004\000\t\132\001\000\001x\001\000\001x\002\000\001x\003\000\001x\004\000\012\168\001\000\001x\005\000\003\012\001\000\b\204\001\000\003\012\002\000\003\012\003\000\001x\006\000\001x\007\000\001x\b\000\001D\001\000\001D\002\000\001\024\001\000\001\216\001\000\001\024\002\000\001\024\003\000\001D\003\000\001$\001\000\001$\002\000\006\020\001\000\006\012\001\000\006\020\002\000\006\016\001\000\006\b\001\000\006\016\002\000\001$\003\000\001$\004\000\001$\005\000\001\216\001\000\001$\006\000\001$\007\000\001(\001\000\001(\002\000\b0\001\000\b(\001\000\b0\002\000\b,\001\000\b$\001\000\b,\002\000\001(\003\000\001(\004\000\001(\005\000\001(\006\000\001(\007\000\001 \001\000\001 \002\000\001P\001\000\001L\001\000\001P\002\000\001L\002\000\001P\003\000\001P\004\000\005l\001\000\001P\005\000\001P\006\000\001<\001\000\b\196\001\000\001<\002\000\001<\003\000\001<\004\000\b\196\002\000\b\196\003\000\001\216\001\000\b\192\001\000\001\216\001\000\001@\001\000\0018\001\000\001P\007\000\001H\001\000\001H\002\000\001L\003\000\005l\001\000\001L\004\000\001L\005\000\001L\006\000\001H\001\000\001H\001\000\001 \003\000\001 \004\000\001,\001\000\001,\002\000\001\216\001\000\001\188\001\000\001\188\002\000\001\216\001\000\001\188\003\000\001,\003\000\001,\004\000\001D\004\000\001D\005\000\0010\001\000\0010\002\000\0014\001\000\004\168\001\000\004\168\002\000\001x\t\000\001H\001\000\001x\n\000\004T\001\000\004T\002\000\004T\003\000\004T\004\000\004T\005\000\004T\006\000\004T\007\000\001H\001\000\004T\b\000\004T\t\000\001x\011\000\t\132\002\000\t\132\003\000\t\132\004\000\t\132\005\000\t\132\006\000\t\132\007\000\0050\001\000\001p\001\000\001p\002\000\001p\003\000\001p\004\000\001<\001\000\000\144\001\000\000\140\001\000\000\136\001\000\b\244\001\000\b\192\001\000\001\216\001\000\001t\001\000\001t\002\000\001l\001\000\001l\002\000\001l\003\000\0120\001\000\001|\001\000\001@\001\000\000\164\001\000\001l\004\000\001h\001\000\001H\001\000\001t\003\000\001p\005\000\t\132\b\000\t\132\t\000\004L\001\000\004L\002\000\004L\003\000\004L\004\000\004L\005\000\004L\006\000\004L\007\000\004L\b\000\004L\t\000\t\132\n\000\tH\001\000\004\144\001\000\t`\001\000\tL\001\000\t|\001\000\tx\001\000\tt\001\000\tl\001\000\004\144\002\000\t@\001\000\t@\002\000\tP\001\000\004t\001\000\004t\002\000\004t\003\000\004t\004\000\004t\005\000\bx\001\000\004t\006\000\004t\007\000\004t\b\000\tP\002\000\tT\001\000\004|\001\000\004|\002\000\004|\003\000\004|\004\000\004|\005\000\004|\006\000\bx\001\000\004|\007\000\004|\b\000\004|\t\000\tT\002\000\tD\001\000\t\136\001\000\004\140\002\000\007\240\002\000\t<\001\000\007\244\002\000\001\216\001\000\011\204\001\000\001x\001\000\011\204\002\000\011\204\003\000\011\204\004\000\011\204\005\000\011\204\006\000\000\244\001\000\001d\001\000\001d\002\000\001d\003\000\000\220\001\000\012\156\001\000\012\148\001\000\012\156\002\000\012\148\002\000\012\156\003\000\012\148\003\000\012\156\004\000\012\148\004\000\012\148\005\000\012\148\006\000\012\156\005\000\012\156\006\000\012\156\007\000\000\220\002\000\000\220\003\000\012\152\001\000\012\144\001\000\012\140\001\000\012\180\001\000\012\172\001\000\012\180\002\000\012\176\001\000\006\000\001\000\012\176\002\000\012\140\002\000\012\140\003\000\012\140\004\000\012\140\005\000\001\216\001\000\012\152\002\000\012\144\002\000\012\152\003\000\012\144\003\000\012\144\004\000\012\144\005\000\012\152\004\000\012\152\005\000\012\152\006\000\000\224\001\000\005,\001\000\005$\001\000\005\028\001\000\005,\002\000\005$\002\000\005\028\002\000\005,\003\000\005$\003\000\005\028\003\000\005,\004\000\005$\004\000\005\028\004\000\005,\005\000\005$\005\000\005,\006\000\005,\007\000\005,\b\000\005,\t\000\001\216\001\000\005,\n\000\005,\011\000\005$\006\000\005$\007\000\005$\b\000\005\028\005\000\003\232\001\000\011\132\001\000\003\020\001\000\003\020\002\000\003\020\003\000\003\016\001\000\011\132\002\000\000\224\002\000\000\224\003\000\005(\001\000\005 \001\000\005\024\001\000\005\020\001\000\012\192\001\000\012\184\001\000\012\192\002\000\012\188\001\000\b\028\001\000\012\188\002\000\005\020\002\000\005\020\003\000\005\020\004\000\005\020\005\000\005(\002\000\005 \002\000\005\024\002\000\005(\003\000\005 \003\000\005\024\003\000\005(\004\000\005 \004\000\005(\005\000\005(\006\000\005(\007\000\005(\b\000\001\216\001\000\005(\t\000\005(\n\000\005 \005\000\005 \006\000\005 \007\000\005\024\004\000\000\232\001\000\000\232\002\000\000\232\003\000\000\232\004\000\000\216\001\000\000\212\001\000\000\216\002\000\000\216\003\000\001`\001\000\001T\001\000\004\024\001\000\004\020\001\000\000\196\001\000\000\192\001\000\004\024\002\000\004\024\003\000\004\024\004\000\004\024\005\000\004\024\006\000\004\024\007\000\000\196\002\000\000\192\002\000\000\196\003\000\000\196\004\000\005l\001\000\000\196\005\000\000\196\006\000\001\\\001\000\b\196\001\000\001\\\002\000\001\\\003\000\001\\\004\000\000\184\001\000\000\184\002\000\001\004\001\000\001\000\001\000\001\000\002\000\004\028\001\000\000\188\001\000\000\188\002\000\000\208\001\000\000\204\001\000\000\180\001\000\003\184\001\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\003\184\002\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\003\180\001\000\b\136\001\000\000\204\002\000\b\136\002\000\b\132\001\000\001X\001\000\000\200\001\000\000\188\003\000\000\200\002\000\004\028\002\000\001\000\003\000\000\200\001\000\001\004\002\000\000\184\003\000\000\200\001\000\000\196\007\000\000\192\003\000\005l\001\000\000\192\004\000\000\192\005\000\000\200\001\000\000\192\006\000\004\020\002\000\004\020\003\000\004\020\004\000\004\020\005\000\001`\002\000\001T\002\000\000\200\001\000\001T\003\000\001`\003\000\001`\004\000\001`\005\000\000\216\004\000\000\200\001\000\007\012\001\000\007\012\002\000\000\216\005\000\000\216\006\000\000\212\002\000\000\212\003\000\000\200\001\000\000\212\004\000\000\212\005\000\000\228\001\000\000\228\002\000\000\228\003\000\000\228\004\000\001d\004\000\001d\005\000\000\236\001\000\000\236\002\000\000\240\001\000\004\176\001\000\004\176\002\000\000\244\002\000\000\200\001\000\000\248\001\000\000\248\002\000\000\248\003\000\000\248\004\000\000\200\001\000\000\252\001\000\000\252\002\000\011\204\007\000\011\204\b\000\004D\001\000\004D\002\000\004D\003\000\004D\004\000\004D\005\000\004D\006\000\004D\007\000\004D\b\000\011\204\t\000\011\168\001\000\004\160\001\000\004\012\001\000\004\012\002\000\004\012\003\000\004\012\004\000\004\012\005\000\004\012\006\000\011\184\001\000\011x\001\000\011\164\001\000\011\200\001\000\011\196\001\000\011\148\001\000\004\232\001\000\004\232\002\000\004\160\002\000\011\152\001\000\004\016\001\000\004\016\002\000\011\156\001\000\011\156\002\000\011\172\001\000\011\172\002\000\011\160\001\000\011\208\001\000\007\236\001\000\011\144\001\000\011\144\002\000\011\144\003\000\003\004\003\000\003\004\004\000\011\148\001\000\004\232\001\000\001\228\001\000\011\140\001\000\011\152\001\000\004\016\001\000\002\176\001\000\003\140\003\000\003\140\004\000\b\016\003\000\b\016\004\000\000L\004\000\b\228\001\000\b\224\003\000\002\232\001\000\002\184\001\000\002\164\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\007\224\001\000\007\216\001\000\007\208\001\000\007\204\001\000\007\180\001\000\0044\001\000\0044\002\000\0044\003\000\004<\001\000\002\180\002\000\002\180\003\000\002\180\004\000\004<\002\000\004<\003\000\0048\001\000\n\016\001\000\006\156\001\000\n \004\000\n \005\000\nP\003\000\nL\003\000\nP\004\000\nL\004\000\nL\005\000\t\000\001\000\b\252\001\000\b\248\001\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\t\000\002\000\b\252\002\000\t\000\003\000\n\\\003\000\nX\003\000\n\\\004\000\nX\004\000\nX\005\000\n$\003\000\n$\004\000\n$\005\000\n@\003\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\b@\001\000\b@\002\000\b@\003\000\t$\001\000\t \001\000\t\028\001\000\007<\001\000\t$\002\000\t \002\000\t\028\002\000\t$\003\000\t \003\000\t\028\003\000\t$\004\000\t \004\000\t$\005\000\b<\001\000\n@\004\000\n@\005\000\n`\001\000\n\\\001\000\nX\001\000\nP\001\000\nL\001\000\n@\001\000\n8\001\000\n$\001\000\n \001\000\005t\001\000\005l\001\000\005d\001\000\001\176\001\000\001\172\001\000\n`\002\000\n\\\002\000\nX\002\000\nP\002\000\nL\002\000\n@\002\000\n8\002\000\n$\002\000\n \002\000\005t\002\000\005l\002\000\005d\002\000\001\176\002\000\012\128\001\000\005d\003\000\005t\003\000\t\220\002\000\t\212\002\000\t\204\002\000\002\224\002\000\002\216\002\000\002\208\002\000\t\204\003\000\002\208\003\000\t\204\004\000\002\208\004\000\t\204\005\000\002\208\005\000\002\208\006\000\b\228\001\000\002\232\001\000\002\208\007\000\002\184\001\000\002\164\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\t\220\003\000\002\224\003\000\t\220\004\000\002\224\004\000\t\220\005\000\002\224\005\000\002\224\006\000\b\228\001\000\002\232\001\000\002\224\007\000\002\184\001\000\002\164\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\t\212\003\000\002\216\003\000\t\212\004\000\002\216\004\000\t\212\005\000\002\216\005\000\002\216\006\000\b\228\001\000\002\232\001\000\002\216\007\000\002\184\001\000\002\164\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\n\028\002\000\t\224\002\000\t\216\002\000\t\208\002\000\t\200\002\000\t\196\002\000\t\192\002\000\002\228\002\000\002\220\002\000\002\212\002\000\002\204\002\000\002\200\002\000\002\196\002\000\002\192\002\000\t\192\003\000\002\196\003\000\t\192\004\000\002\196\004\000\t\192\005\000\002\196\005\000\002\196\006\000\b\228\001\000\002\232\001\000\002\196\007\000\002\184\001\000\002\164\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\t\200\003\000\002\204\003\000\t\200\004\000\002\204\004\000\t\200\005\000\002\204\005\000\002\204\006\000\b\228\001\000\002\232\001\000\002\204\007\000\002\184\001\000\002\164\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\t\196\003\000\002\200\003\000\t\196\004\000\002\200\004\000\t\196\005\000\002\200\005\000\002\200\006\000\b\228\001\000\002\232\001\000\002\200\007\000\002\184\001\000\002\164\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\t\224\003\000\t\216\003\000\t\208\003\000\005l\001\000\005d\001\000\002\228\003\000\002\220\003\000\002\212\003\000\t\224\004\000\t\216\004\000\t\208\004\000\002\228\004\000\002\220\004\000\002\212\004\000\t\208\005\000\002\212\005\000\t\208\006\000\002\212\006\000\t\208\007\000\002\212\007\000\002\212\b\000\b\228\001\000\002\232\001\000\002\212\t\000\002\184\001\000\002\164\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\t\224\005\000\002\228\005\000\t\224\006\000\002\228\006\000\t\224\007\000\002\228\007\000\002\228\b\000\b\228\001\000\002\232\001\000\002\228\t\000\002\184\001\000\002\164\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\t\216\005\000\002\220\005\000\t\216\006\000\002\220\006\000\t\216\007\000\002\220\007\000\002\220\b\000\b\228\001\000\002\232\001\000\002\220\t\000\002\184\001\000\002\164\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\n\028\003\000\002\192\003\000\002\192\004\000\b\228\001\000\002\232\001\000\002\192\005\000\002\184\001\000\002\164\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\b\136\001\000\002H\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\168\002\000\002\164\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\t\192\004\000\t\192\005\000\t\200\003\000\t\200\004\000\t\200\005\000\t\196\003\000\t\196\004\000\t\196\005\000\t\224\003\000\t\216\003\000\t\208\003\000\005l\001\000\005d\001\000\t\224\004\000\t\216\004\000\t\208\004\000\t\208\005\000\t\208\006\000\t\208\007\000\t\224\005\000\t\224\006\000\t\224\007\000\t\216\005\000\t\216\006\000\t\216\007\000\n\028\003\000\t\204\004\000\t\204\005\000\t\220\003\000\t\220\004\000\t\220\005\000\t\212\003\000\t\212\004\000\t\212\005\000\002<\006\000\001\220\001\000\001\224\001\000\002<\007\000\002<\b\000\002<\t\000\002<\n\000\002<\011\000\002\004\006\000\002\004\007\000\002\004\b\000\002\004\t\000\002\000\005\000\002\000\006\000\002\000\007\000\002\000\b\000\002\000\t\000\002\000\n\000\002\000\011\000\003\024\002\000\012|\001\000\n\164\001\000\nx\001\000\nt\001\000\nl\001\000\003$\001\000\001\180\001\000\001\148\001\000\003$\002\000\003$\003\000\003$\004\000\003\028\001\000\003\028\002\000\000\128\001\000\000l\001\000\003\028\003\000\003\028\004\000\003 \001\000\003 \002\000\003$\005\000\002$\b\000\002 \004\000\002 \005\000\004\240\003\000\004\240\004\000\004\240\005\000\004\244\002\000\004\236\002\000\004\244\003\000\004\236\003\000\b\160\002\000\b\164\001\000\002\028\004\000\b\164\002\000\b\164\003\000\b\156\001\000\0024\004\000\0020\004\000\0024\005\000\0020\005\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\0024\006\000\0020\006\000\0020\007\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\0020\b\000\t\232\004\000\t\228\004\000\t\228\005\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\002D\004\000\t\176\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\t\176\003\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\180\002\000\n<\002\000\n<\003\000\b\228\001\000\007\028\002\000\002\232\001\000\002\184\001\000\002\164\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\t\012\002\000\t\b\002\000\t\004\002\000\t\012\003\000\t\b\003\000\t\012\004\000\n\024\002\000\n\020\002\000\n\020\003\000\nT\002\000\nT\003\000\002\024\b\000\002\020\003\000\002\020\004\000\005\176\001\000\005\172\001\000\005\164\001\000\002\020\005\000\002\020\006\000\002\020\007\000\002\012\002\000\002\012\003\000\002\012\004\000\002\012\005\000\002\012\006\000\002\012\007\000\002\012\b\000\002\016\002\000\002\016\003\000\002\016\004\000\002\016\005\000\002\016\006\000\002\016\007\000\002\016\b\000\002\016\t\000\011\128\002\000\011\136\005\000\004(\002\000\0074\002\000\003\204\004\000\003\204\005\000\003\208\002\000\012 \001\000\012\028\001\000\004\000\002\000\003\252\002\000\004\000\003\000\004\000\004\000\004\000\005\000\004\000\006\000\001\216\001\000\004\000\007\000\004\000\b\000\b\152\001\000\003\252\003\000\003\252\004\000\003\252\005\000\001\216\001\000\003\252\006\000\003\252\007\000\003\248\002\000\003\248\003\000\003\248\004\000\003\244\002\000\004\224\005\000\004\224\006\000\b\228\001\000\002\232\001\000\002\188\003\000\002\184\001\000\002\164\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\nH\002\000\nD\002\000\nD\003\000\n,\001\000\n(\001\000\n\028\001\000\n\012\002\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\244\002\000\t\240\002\000\t\244\003\000\t\240\003\000\t\244\004\000\t\240\004\000\t\244\005\000\t\240\005\000\005\176\001\000\005\172\001\000\005\164\001\000\t\240\006\000\t\244\006\000\t\244\007\000\005\232\001\000\005\228\001\000\005\216\001\000\t\244\b\000\t\188\002\000\t\184\002\000\t\184\003\000\t\188\003\000\t\188\004\000\002(\004\000\002(\005\000\b\164\001\000\002(\006\000\001\232\004\000\001\232\005\000\b\164\001\000\001\232\006\000\b\228\001\000\007\\\004\000\007X\004\000\007T\004\000\007P\004\000\002\232\001\000\002\184\001\000\002\164\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\007P\005\000\007\\\005\000\007\\\006\000\005\232\001\000\005\228\001\000\005\216\001\000\007\\\007\000\007X\005\000\007T\005\000\007X\006\000\007T\006\000\005\232\001\000\005\228\001\000\005\216\001\000\007T\007\000\007X\007\000\007X\b\000\005\232\001\000\005\228\001\000\005\216\001\000\007X\t\000\006h\005\000\005\176\001\000\005\172\001\000\005\164\001\000\006h\006\000\006d\002\000\006d\003\000\006d\004\000\005\176\001\000\005\172\001\000\005\164\001\000\006d\005\000\004\156\002\000\004\156\003\000\004\156\004\000\004\152\002\000\002\244\003\000\002\244\004\000\005\b\003\000\005\000\003\000\004\248\003\000\005\b\004\000\005\000\004\000\004\248\004\000\005\000\005\000\004\248\005\000\005\000\006\000\004\248\006\000\005\016\001\000\004\248\007\000\005\012\001\000\005\004\001\000\004\252\001\000\000\128\001\000\000l\001\000\005\004\002\000\004\252\002\000\004\252\003\000\000x\002\000\000t\002\000\000t\003\000\0030\003\000\0030\004\000\0030\005\000\b\216\001\000\000\132\002\000\000p\002\000\000\132\003\000\000p\003\000\000\132\004\000\000\132\005\000\000p\004\000\b\216\002\000\b\216\003\000\001\216\001\000\b\220\001\000\001\216\001\000\000X\002\000\000X\003\000\b\220\002\000\b\220\003\000\001\216\001\000\006X\002\000\006X\003\000\006X\004\000\006H\002\000\0060\002\000\001\216\001\000\0068\002\000\012,\002\000\011\180\006\000\011\180\007\000\011\180\b\000\003\\\001\000\002\252\001\000\003\\\002\000\002\252\002\000\002\252\003\000\002\252\004\000\002\252\005\000\011\180\t\000\bd\001\000\b`\001\000\011\180\n\000\b`\002\000\bd\002\000\bP\001\000\bX\001\000\bT\001\000\b\\\001\000\003`\001\000\003\000\001\000\003\000\002\000\003\000\003\000\003\000\004\000\011\176\004\000\003l\004\000\0050\001\000\003l\005\000\011\176\005\000\011\176\006\000\011\176\007\000\011\176\b\000\bd\001\000\b`\001\000\011\176\t\000\005\152\003\000\005\152\004\000\005\208\005\000\005\176\001\000\005\172\001\000\005\164\001\000\005\232\001\000\005\228\001\000\005\216\001\000\000\\\005\000\000\\\006\000\012\160\006\000\012\160\007\000\005\200\003\000\005\200\004\000\nx\007\000\005\232\001\000\005\228\001\000\005\216\001\000\nx\b\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\001\016\002\000\001\012\002\000\001\012\003\000\001\016\003\000\001\216\001\000\001\016\004\000\001\016\005\000\t\248\004\000\t\248\005\000\t\248\006\000\002,\004\000\002,\005\000\b\164\001\000\002,\006\000\001\248\004\000\001\244\004\000\001\240\004\000\001\236\004\000\001\248\005\000\001\240\005\000\b\164\001\000\001\248\006\000\001\240\006\000\001\248\007\000\001\248\b\000\001\244\005\000\001\244\006\000\0028\004\000\0028\005\000\0028\006\000\0028\007\000\000\176\003\000\000\176\004\000\001\252\003\000\001\252\004\000\001\252\005\000\001\252\006\000\001\252\007\000\003|\001\000\003|\002\000\000\000\001\000\000\004\000\000\003\136\001\000\003\136\002\000\000\004\001\000\000\b\000\000\012|\001\000\005D\001\000\001\148\001\000\005D\002\000\005D\003\000\005H\001\000\000\b\001\000\005|\001\000\005T\001\000\005P\001\000\005L\001\000\005<\001\000\005T\002\000\005P\002\000\005L\002\000\005<\002\000\012|\001\000\005P\003\000\005P\004\000\005P\005\000\005T\003\000\005L\003\000\000P\001\000\005@\001\000\000T\001\000\007`\001\000\007`\002\000\000\012\000\000\000\012\001\000\007d\001\000\007d\002\000\000\016\000\000\000\016\001\000\007h\001\000\001\216\001\000\007h\002\000\000\020\000\000\007l\001\000\007l\002\000\000\020\001\000\000\024\000\000\000\024\001\000\007p\001\000\005|\001\000\005<\001\000\007p\002\000\000\028\000\000\000\028\001\000\007t\001\000\005l\001\000\007t\002\000\000 \000\000\000 \001\000\007x\001\000\005\176\001\000\005\172\001\000\005\164\001\000\007x\002\000\000$\000\000\000$\001\000\007|\001\000\005\232\001\000\005\228\001\000\005\216\001\000\007|\002\000\000(\000\000\000(\001\000\007\128\001\000\007\128\002\000\000,\000\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\132\001\000\007\132\002\000\000,\001\000\0000\000\000\007\136\001\000\007\136\002\000\0000\001\000\005t\001\000\005l\001\000\005t\002\000\005l\002\000\0004\000\000\012\000\001\000\011\252\001\000\011\248\001\000\011\244\001\000\011\240\001\000\011\236\001\000\011\232\001\000\012\000\002\000\011\252\002\000\011\248\002\000\011\244\002\000\011\240\002\000\011\236\002\000\011\232\002\000\012\000\003\000\011\236\003\000\011\240\003\000\011\252\003\000\011\244\003\000\011\248\003\000\005t\001\000\005l\001\000\012\016\001\000\0004\001\000\012\012\001\000\012\012\002\000\004\184\001\000\004\184\002\000\012\004\001\000\012\004\002\000\012\004\003\000\012\b\001\000\012\b\002\000\0008\000\000\004\196\001\000\004\192\001\000\004\204\001\000\004\200\001\000\004\200\002\000\004\204\002\000\004\196\002\000\004\196\003\000\004\196\004\000\004\192\002\000\0008\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\000[\000\\\000^\000_\000`\000b\000c\000d\000k\000l\000m\000n\000o\000p\000s\000t\000u\000w\000y\000{\000|\000}\000\127\000\128\000\129\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\156\000\158\000\159\000\160\000\162\000\164\000\165\000\167\000\169\000\171\000\172\000\174\000\176\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\194\000\195\000\196\000\198\000\199\000\200\000\201\000\202\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\222\000\226\000\230\000\231\000\233\000\234\000\236\000\238\000\239\000\240\000\241\000\244\000\245\000\246\000\247\000\248\000\249\000\250\000\251\000\252\000\254\000\255\001\000\001\001\001\003\001\005\001\006\001\b\001\012\001\018\001\020\001\021\001\022\001\024\001\028\001\031\001 \001!\001#\001$\001%\001&\001(\001)\001*\001+\0011\0015\0019\001:\001;\001<\001=\001?\001A\001B\001C\001D\001E\001F\001G\001H\001I\001J\001K\001L\001M\001N\001O\001P\001W\001Y\001[\001]\001^\001_\001`\001a\001b\001c\001e\001g\001h\001i\001j\001k\001l\001p\001q\001s\001t\001v\001x\001y\001z\001}\001~\001\129\001\130\001\133\001\134\001\135\001\136\001\137\001\139\001\140\001\141\001\142\001\143\001\144\001\145\001\146\001\148\001\149\001\151\001\152\001\153\001\154\001\157\001\158\001\159\001\160\001\161\001\162\001\163\001\164\001\168\001\169\001\172\001\173\001\174\001\175\001\177\001\178\001\179\001\180\001\182\001\183\001\184\001\185\001\187\001\188\001\189\001\191\001\192\001\193\001\194\001\195\001\197\001\198\001\200\001\201\001\203\001\205\001\206\001\207\001\208\001\210\001\211\001\213\001\214\001\217\001\218\001\219\001\221\001\222\001\223\001\224\001\226\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\247\001\248\001\249\001\250\001\251\002\002\002\b\002\011\002\012\002\r\002\014\002\015\002\016\002\017\002\019\002\020\002\026\002\027\002!\002\"\002(\002)\002/\0020\0021\0022\0024\002:\002;\002>\002F\002G\002I\002J\002K\002L\002M\002N\002O\002R\002S\002T\002[\002\\\002]\002_\002`\002f\002l\002m\002n\002t\002u\002w\002x\002y\002z\002\130\002\132\002\133\002\134\002\140\002\144\002\147\002\148\002\149\002\150\002\151\002\152\002\153\002\154\002\160\002\162\002\163\002\165\002\166\002\168\002\169\002\170\002\171\002\173\002\174\002\175\002\176\002\177\002\180\002\182\002\183\002\184\002\191\002\192\002\194\002\195\002\196\002\197\002\198\002\199\002\207\002\208\002\209\002\210\002\211\002\212\002\213\002\218\002\220\002\221\002\222\002\223\002\224\002\225\002\227\002\228\002\229\002\230\002\232\002\233\002\234\002\235\002\236\002\238\002\239\002\240\002\241\002\242\002\246\002\247\002\249\002\251\002\253\002\255\003\000\003\001\003\003\003\004\003\006\003\b\003\t\003\011\003\012\003\014\003\015\003\019\003\021\003\023\003\024\003\028\003\029\003!\003\"\003%\003'\003)\003*\003+\003,\003-\003.\0032\0035\0036\0039\003:\003;\003>\003?\003A\003B\003C\003D\003H\003L\003M\003Q\003R\003S\003T\003U\003Y\003`\003a\003f\003g\003h\003l\003m\003n\003o\003q\003r\003v\003w\003y\003{\003~\003\127\003\128\003\130\003\131\003\132\003\133\003\134\003\135\003\137\003\139\003\141\003\143\003\145\003\147\003\148\003\149\003\150\003\151\003\159\003\160\003\162\003\164\003\166\003\174\003\175\003\176\003\177\003\178\003\180\003\182\003\184\003\191\003\192\003\193\003\194\003\195\003\201\003\202\003\203\003\204\003\205\003\218\003\219\003\232\003\233\003\234\003\237\003\238\003\239\003\240\003\241\003\254\004\005\004\006\004\007\004\031\004!\004\"\004#\004$\004&\004(\004+\004,\004.\004/\0040\0041\0042\0043\0044\004A\004B\004O\004[\004`\004a\004c\004e\004f\004g\004h\004l\004m\004q\004r\004t\004v\004x\004z\004{\004}\004~\004\127\004\129\004\130\004\132\004\145\004\146\004\147\004\148\004\149\004\151\004\152\004\153\004\154\004\156\004\157\004\158\004\185\004\186\004\210\004\211\004\235\004\236\005\004\005\005\005\029\005\030\0056\0057\005O\005P\005h\005i\005\129\005\130\005\154\005\155\005\179\005\180\005\204\005\205\005\229\005\230\005\254\005\255\006\023\006\024\0060\0061\006I\006J\006b\006c\006{\006|\006\148\006\149\006\173\006\174\006\198\006\199\006\223\006\224\006\226\006\239\006\240\007\b\007\011\007\012\007\r\007\014\007\015\007\016\007\017\007\019\007\020\007\022\007\023\007\024\007\030\007\031\007 \007!\007'\007(\007.\007/\0075\0076\0077\0078\0079\007;\007<\007B\007C\007D\007E\007F\007H\007O\007P\007Q\007T\007U\007V\007W\007X\007Y\007]\007^\007_\007`\007a\007c\007e\007f\007g\007h\007l\007m\007q\007r\007v\007w\007x\007y\007z\007{\007|\007}\007~\007\127\007\128\007\129\007\130\007\131\007\132\007\133\007\134\007\135\007\136\007\137\007\138\007\139\007\143\007\144\007\145\007\146\007\147\007\148\007\149\007\151\007\152\007\153\007\154\007\156\007\157\007\158\007\160\007\161\007\162\007\163\007\165\007\167\007\169\007\171\007\172\007\174\007\175\007\176\007\177\007\179\007\180\007\181\007\182\007\184\007\186\007\188\007\190\007\191\007\193\007\195\007\197\007\198\007\199\007\201\007\202\007\203\007\205\007\206\007\207\007\209\007\211\007\215\007\216\007\220\007\221\007\223\007\226\007\228\007\229\007\230\007\231\007\232\007\236\007\239\007\241\007\242\007\243\007\246\007\251\007\252\007\253\b\000\b\005\b\006\b\007\b\b\b\t\b\011\b\017\b\023\b\029\b \b#\b&\b'\b+\b,\b-\b.\b/\b1\b2\b3\b4\b6\b7\b8\b9\b;\b<\b=\b>\bF\bL\bO\bP\bQ\bR\bS\bT\bU\bV\bW\bX\bY\bZ\b[\b\\\b]\b^\b`\ba\bb\bc\bd\be\bg\bh\bi\bj\bk\bn\bq\br\bs\bu\bv\bw\by\bz\b{\b|\b}\b\127\b\128\b\129\b\131\b\132\b\133\b\134\b\137\b\138\b\139\b\140\b\143\b\144\b\150\b\152\b\154\b\156\b\158\b\159\b\163\b\164\b\168\b\172\b\174\b\175\b\178\b\179\b\180\b\181\b\182\b\186\b\187\b\188\b\189\b\190\b\191\b\195\b\196\b\197\b\198\b\200\b\201\b\203\b\204\b\205\b\209\b\210\b\211\b\212\b\213\b\214\b\215\b\216\b\220\b\221\b\222\b\223\b\224\b\225\b\227\b\228\b\229\b\230\b\231\b\232\b\233\b\235\b\236\b\237\b\238\b\239\b\240\b\241\b\242\b\244\b\245\b\246\b\247\b\248\b\250\b\251\b\253\b\254\b\255\t\000\t\001\t\003\t\004\t\005\t\006\t\b\t\t\t\011\t\012\t\r\t\014\t\015\t\016\t\017\t\018\t\019\t\021\t\023\t\024\t\025\t\027\t\028\t\029\t\031\t \t!\t\"\t$\t&\t'\t(\t*\t+\t,\t.\t/\t1\t3\t4\t5\t6\t8\t9\t;\t<\t=\t>\t?\t@\tA\tB\tC\tD\tF\tG\tH\tI\tJ\tK\tL\tM\tO\tP\tQ\tR\tS\tT\tU\tV\tW\tX\tZ\t[\t\\\t]\ta\td\te\tf\tg\th\ti\tk\tm\tn\tp\tq\tr\ts\tt\tu\tv\tw\tx\ty\tz\t{\t|\t}\t~\t\127\t\128\t\129\t\130\t\131\t\132\t\133\t\134\t\135\t\136\t\137\t\138\t\139\t\140\t\141\t\142\t\143\t\145\t\146\t\147\t\148\t\149\t\150\t\151\t\152\t\153\t\154\t\155\t\157\t\158\t\159\t\160\t\161\t\162\t\163\t\164\t\165\t\167\t\169\t\170\t\171\t\172\t\173\t\174\t\175\t\176\t\177\t\178\t\179\t\181\t\183\t\185\t\187\t\188\t\189\t\190\t\191\t\192\t\193\t\194\t\197\t\199\t\200\t\202\t\203\t\204\t\205\t\206\t\208\t\210\t\212\t\213\t\214\t\215\t\216\t\217\t\218\t\221\t\224\t\227\t\230\t\232\t\233\t\234\t\235\t\237\t\238\t\239\t\240\t\241\t\242\t\243\t\244\t\245\t\246\t\247\t\248\t\249\t\250\t\251\t\252\n\000\n\002\n\003\n\005\n\006\n\007\n\b\n\t\n\n\n\r\n\016\n\018\n\019\n\020\n\021\n\023\n\024\n\025\n\026\n\027\n\028\n\029\n\030\n\031\n \n!\n#\n$\n%\n'\n+\n,\n-\n.\n/\n0\n1\n3\n4\n5\n7\n8\n9\n;\n<\n=\n>\n?\nA\nB\nD\nE\nF\nH\nI\nV\nc\ne\nf\ng\nh\nj\nk\nl\nn\no\np\nr\ns\nu\nv\nx\ny\nz\n{\n|\n\127\n\128\n\129\n\130\n\131\n\133\n\134\n\135\n\136\n\137\n\138\n\140\n\141\n\142\n\143\n\144\n\145\n\146\n\147\n\148\n\149\n\150\n\151\n\152\n\153\n\155\n\156\n\157\n\158\n\160\n\161\n\162\n\163\n\164\n\165\n\166\n\167\n\168\n\169\n\170\n\171\n\172\n\173\n\174\n\175\n\176\n\177\n\178\n\179\n\180\n\181\n\182\n\183\n\184\n\185\n\186\n\188\n\189\n\190\n\192\n\193\n\194\n\195\n\196\n\197\n\198\n\199\n\200\n\201\n\202\n\203\n\204\n\205\n\208\n\209\n\212\n\213\n\214\n\215\n\216\n\217\n\241\n\247\n\248\n\249\n\251\n\252\n\253\n\254\n\255\011\000\011\002\011\003\011\004\011\006\011\007\011\b\011\t\011#\011%\011&\011(\011)\011*\011+\011,\011-\011.\011/\011<\011=\011>\011A\011B\011E\011H\011J\011K\011L\011M\011N\011\\\011i\011k\011l\011r\011t\011v\011x\011y\011\145\011\147\011\149\011\151\011\152\011\176\011\178\011\180\011\182\011\183\011\207\011\221\011\223\011\225\011\227\011\228\011\252\011\254\012\000\012\002\012\003\012\027\012\029\012\031\012!\012\"\012:\012B\012H\012J\012L\012N\012O\012g\012i\012k\012m\012n\012\134\012\136\012\138\012\140\012\141\012\165\012\167\012\168\012\192\012\194\012\218\012\219\012\220\012\221\012\222\012\223\012\224\012\225\012\226\012\231\012\234\012\235\012\236\012\237\012\238\012\239\012\240\012\241\012\242\012\243\012\244\012\245\012\246\012\247\012\248\012\249\012\250\012\251\012\252\012\253\012\254\012\255\r\000\r\001\r\002\r\003\r\004\r\005\r\006\r\007\r\b\r\t\r\n\r\011\r\012\r\r\r\014\r\015\r\016\r\024\r\025\r\026\r\027\r\028\r\031\r \r!\r\"\r#\r$\r%\r&\r'\r(\r)\r*\r,\r-\r.\r/\r1\r2\r3\r4\r6\r8\rQ\rR\rj\rk\rl\rm\rz\r\146\r\147\r\160\r\161\r\162\r\186\r\189\r\191\r\192\r\193\r\194\r\195\r\196\r\197\r\198\r\199\r\200\r\204\r\205\r\206\r\207\r\208\r\209\r\210\r\211\r\212\r\213\r\214\r\215\r\216\r\217\r\218\r\219\r\220\r\221\r\222\r\223\r\224\r\225\r\226\r\227\r\228\r\232\r\233\r\234\r\235\r\237\r\238\r\239\r\241\r\242\r\244\r\245\r\246\r\247\r\248\r\249\r\250\r\251\r\252\014\020\014\021\014\022\014\023\014$\014&\014(\014*\014/\0140\0141\0145\0146\0148\0149\014:\014;\014<\014=\014?\014@\014A\014C\014^\014_\014`\014d\014e\014g\014l\014m\014n\014r\014s\014w\014x\014y\014z\014~\014\127\014\128\014\129\014\130\014\131\014\132\014\133\014\136\014\139\014\141\014\143\014\144\014\145\014\150\014\152\014\153\014\154\014\155\014\156\014\157\014\158\014\159\014\162\014\164\014\165\014\166\014\167\014\168\014\170\014\173\014\174\014\175\014\177\014\178\014\179\014\180\014\181\014\183\014\184\014\185\014\186\014\187\014\188\014\190\014\192\014\193\014\194\014\195\014\198\014\199\014\200\014\201\014\202\014\203\014\204\014\205\014\207\014\208\014\209\014\210\014\212\014\214\014\215\014\216\014\217\014\220\014\221\014\222\014\223\014\227\014\231\014\232\014\233\014\234\014\235\014\236\014\240\014\241\014\248\014\249\014\250\014\252\014\253\014\254\014\255\015\000\015\001\015\002\015\004\015\b\015\n\015\r\015\014\015\015\015\016\015\017\015\018\015\019\015\020\015\021\015\022\015\023\015\024\015\025\015\026\015\027\015\028\015\029\015\030\015\031\015 \015!\015\"\015#\015$\015'\015(\015)\015*\015+\0150\0154\0156\0157\0158\0159\015:\015;\015<\015=\015>\015?\015@\015A\015B\015C\015D\015E\015G\015H\015I\015J\015K\015L\015M\015N\015Q\015R\015S\015T\015V\015W\015X\015Y\015]\015^\015_\015`\015d\015e\015f\015g\015h\015i\015j\015p\015q\015r\015s\015t\015u\015v\015x\015z\015{\015\130\015\137\015\138\015\139\015\140\015\141\015\142\015\145\015\146\015\147\015\148\015\149\015\150\015\151\015\152\015\153\015\154\015\155\015\156\015\157\015\159\015\160\015\161\015\162\015\163\015\164\015\165\015\166\015\167\015\168\015\169\015\170\015\171\015\172\015\173\015\174")) and nullable = "\000\000\016)\001\000@\000\001\014\016\000\001\255\128\192\000\000?\255\128\000@\130\016\000\012\000\000" @@ -46239,59 +46304,59 @@ end let use_file = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1844 lexer lexbuf) : (Parsetree.toplevel_phrase list)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1847 lexer lexbuf) : (Parsetree.toplevel_phrase list)) and toplevel_phrase = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1824 lexer lexbuf) : (Parsetree.toplevel_phrase)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1827 lexer lexbuf) : (Parsetree.toplevel_phrase)) and parse_val_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1818 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1821 lexer lexbuf) : (Longident.t)) and parse_pattern = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1814 lexer lexbuf) : (Parsetree.pattern)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1817 lexer lexbuf) : (Parsetree.pattern)) and parse_mty_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1810 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1813 lexer lexbuf) : (Longident.t)) and parse_module_type = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1806 lexer lexbuf) : (Parsetree.module_type)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1809 lexer lexbuf) : (Parsetree.module_type)) and parse_module_expr = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1802 lexer lexbuf) : (Parsetree.module_expr)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1805 lexer lexbuf) : (Parsetree.module_expr)) and parse_mod_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1798 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1801 lexer lexbuf) : (Longident.t)) and parse_mod_ext_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1794 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1797 lexer lexbuf) : (Longident.t)) and parse_expression = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1790 lexer lexbuf) : (Parsetree.expression)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1793 lexer lexbuf) : (Parsetree.expression)) and parse_core_type = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1786 lexer lexbuf) : (Parsetree.core_type)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1789 lexer lexbuf) : (Parsetree.core_type)) and parse_constr_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1782 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1785 lexer lexbuf) : (Longident.t)) and parse_any_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1764 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1767 lexer lexbuf) : (Longident.t)) and interface = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1760 lexer lexbuf) : (Parsetree.signature)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1763 lexer lexbuf) : (Parsetree.signature)) and implementation = fun lexer lexbuf -> @@ -46301,59 +46366,59 @@ module Incremental = struct let use_file = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1844 initial_position) : (Parsetree.toplevel_phrase list) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1847 initial_position) : (Parsetree.toplevel_phrase list) MenhirInterpreter.checkpoint) and toplevel_phrase = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1824 initial_position) : (Parsetree.toplevel_phrase) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1827 initial_position) : (Parsetree.toplevel_phrase) MenhirInterpreter.checkpoint) and parse_val_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1818 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1821 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_pattern = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1814 initial_position) : (Parsetree.pattern) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1817 initial_position) : (Parsetree.pattern) MenhirInterpreter.checkpoint) and parse_mty_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1810 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1813 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_module_type = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1806 initial_position) : (Parsetree.module_type) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1809 initial_position) : (Parsetree.module_type) MenhirInterpreter.checkpoint) and parse_module_expr = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1802 initial_position) : (Parsetree.module_expr) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1805 initial_position) : (Parsetree.module_expr) MenhirInterpreter.checkpoint) and parse_mod_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1798 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1801 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_mod_ext_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1794 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1797 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_expression = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1790 initial_position) : (Parsetree.expression) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1793 initial_position) : (Parsetree.expression) MenhirInterpreter.checkpoint) and parse_core_type = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1786 initial_position) : (Parsetree.core_type) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1789 initial_position) : (Parsetree.core_type) MenhirInterpreter.checkpoint) and parse_constr_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1782 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1785 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_any_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1764 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1767 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and interface = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1760 initial_position) : (Parsetree.signature) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1763 initial_position) : (Parsetree.signature) MenhirInterpreter.checkpoint) and implementation = fun initial_position -> @@ -46361,12 +46426,12 @@ module Incremental = struct end -# 4122 "src/ocaml/preprocess/parser_raw.mly" +# 4142 "src/ocaml/preprocess/parser_raw.mly" -# 46368 "src/ocaml/preprocess/parser_raw.ml" +# 46433 "src/ocaml/preprocess/parser_raw.ml" # 269 "" -# 46373 "src/ocaml/preprocess/parser_raw.ml" +# 46438 "src/ocaml/preprocess/parser_raw.ml" diff --git a/src/ocaml/preprocess/parser_raw.mli b/src/ocaml/preprocess/parser_raw.mli index 8813c36a87..128ee3f63e 100644 --- a/src/ocaml/preprocess/parser_raw.mli +++ b/src/ocaml/preprocess/parser_raw.mli @@ -472,8 +472,10 @@ module MenhirInterpreter : sig | 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_let_binding_body_no_punning : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option) nonterminal + | N_let_binding_body : (Parsetree.pattern * Parsetree.expression * + Parsetree.value_constraint option * 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 diff --git a/src/ocaml/preprocess/parser_raw.mly b/src/ocaml/preprocess/parser_raw.mly index adfeddfa22..f0e8f80cda 100644 --- a/src/ocaml/preprocess/parser_raw.mly +++ b/src/ocaml/preprocess/parser_raw.mly @@ -512,10 +512,11 @@ let extra_rhs_core_type ct ~pos = let docs = rhs_info pos in { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes } -(* +(* moved to ast_helper type let_binding = { lb_pattern: pattern; lb_expression: expression; + lb_constraint: value_constraint option; lb_is_pun: bool; lb_attributes: attributes; lb_docs: docs Lazy.t; @@ -528,10 +529,11 @@ type let_bindings = lbs_extension: string Asttypes.loc option } *) -let mklb first ~loc (p, e, is_pun) attrs = +let mklb first ~loc (p, e, typ, is_pun) attrs = { lb_pattern = p; lb_expression = e; + lb_constraint=typ; lb_is_pun = is_pun; lb_attributes = attrs; lb_docs = symbol_docs_lazy loc; @@ -564,7 +566,7 @@ let val_of_let_bindings ~loc lbs = 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) + ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) lbs.lbs_bindings in let str = mkstr ~loc (Pstr_value(lbs.lbs_rec, List.rev bindings)) in @@ -577,7 +579,7 @@ let expr_of_let_bindings ~loc lbs body = List.map (fun lb -> Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - lb.lb_pattern lb.lb_expression) + ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) lbs.lbs_bindings in mkexp_attrs ~loc (Pexp_let(lbs.lbs_rec, List.rev bindings, body)) @@ -588,7 +590,7 @@ let class_of_let_bindings ~loc lbs body = List.map (fun lb -> Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - lb.lb_pattern lb.lb_expression) + ?value_constraint:lb.lb_constraint lb.lb_pattern lb.lb_expression) lbs.lbs_bindings in (* Our use of let_bindings(no_ext) guarantees the following: *) @@ -1411,6 +1413,10 @@ module_expr [@recovery default_module_expr ()]: | STRUCT attributes structure error { unclosed "struct" $loc($1) "end" $loc($4) } *) + (* + | SIG error + { expecting $loc($1) "struct" } + *) | FUNCTOR attrs = attributes args = functor_args MINUSGREATER me = module_expr { wrap_mod_attrs ~loc:$sloc attrs ( List.fold_left (fun acc (startpos, arg) -> @@ -1428,10 +1434,9 @@ module_expr [@recovery default_module_expr ()]: | (* 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 [])) } + | (* Functor applied to unit. *) + me = module_expr LPAREN RPAREN + { Pmod_apply_unit me } | (* An extension. *) ex = extension { Pmod_extension ex } @@ -1580,6 +1585,10 @@ structure [@recovery []]: module_binding_body: EQUAL me = module_expr { me } + (* + | COLON error + { expecting $loc($1) "=" } + *) | mkmod( COLON mty = module_type EQUAL me = module_expr { Pmod_constraint(me, mty) } @@ -1716,6 +1725,10 @@ module_type [@recovery default_module_type ()]: | SIG attributes signature error { unclosed "sig" $loc($1) "end" $loc($4) } *) + (* + | STRUCT error + { expecting $loc($1) "sig" } + *) | FUNCTOR attrs = attributes args = functor_args MINUSGREATER mty = module_type %prec below_WITH @@ -1737,6 +1750,8 @@ module_type [@recovery default_module_type ()]: | mkmty( mkrhs(mty_longident) { Pmty_ident $1 } + | LPAREN RPAREN MINUSGREATER module_type + { Pmty_functor(Unit, $4) } | module_type MINUSGREATER module_type %prec below_WITH { Pmty_functor(Named (mknoloc None, $1), $3) } @@ -1830,6 +1845,10 @@ signature_item: module_declaration_body: COLON mty = module_type { mty } + (* + | EQUAL error + { expecting $loc($1) ":" } + *) | mkmty( arg_and_pos = functor_arg body = module_declaration_body { let (_, arg) = arg_and_pos in @@ -2459,6 +2478,10 @@ let_pattern [@recovery default_pattern ()]: { 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 } + (* + | WHILE ext_attributes seq_expr DO seq_expr error + { unclosed "do" $loc($1) "done" $loc($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 } @@ -2670,42 +2693,39 @@ labeled_simple_expr: ; let_binding_body_no_punning: let_ident strict_binding - { ($1, $2) } + { ($1, $2, None) } | 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 + Some t, None -> + Pvc_constraint { locally_abstract_univars = []; typ=t } + | ground, Some coercion -> Pvc_coercion { ground; coercion} | _ -> 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) } + (v, $4, Some t) + } | let_ident COLON poly(core_type) EQUAL seq_expr - { let patloc = ($startpos($1), $endpos($3)) in - (ghpat ~loc:patloc - (Ppat_constraint($1, ghtyp ~loc:($loc($3)) $3)), - $5) } + { + let t = ghtyp ~loc:($loc($3)) $3 in + ($1, $5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) + } | 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) } + { let constraint' = + Pvc_constraint { locally_abstract_univars=$4; typ = $6} + in + ($1, $8, Some constraint') } | pattern_no_exn EQUAL seq_expr - { ($1, $3) } + { ($1, $3, None) } | simple_pattern_not_ident COLON core_type EQUAL seq_expr - { let loc = ($startpos($1), $endpos($3)) in - (ghpat ~loc (Ppat_constraint($1, $3)), $5) } + { ($1, $5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=$3 })) } ; let_binding_body: | let_binding_body_no_punning - { let p,e = $1 in (p,e,false) } + { let p,e,c = $1 in (p,e,c,false) } /* BEGIN AVOID */ | val_ident %prec below_HASH - { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, true) } + { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, None, 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 diff --git a/src/ocaml/preprocess/parser_recover.ml b/src/ocaml/preprocess/parser_recover.ml index ed931709b7..542f452b63 100644 --- a/src/ocaml/preprocess/parser_recover.ml +++ b/src/ocaml/preprocess/parser_recover.ml @@ -379,7 +379,7 @@ type decision = | 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;1;2;2;1;2;2;1;1;2;1;1;1;1;1;1;2;3;4;1;1;5;6;6;1;1;2;1;2;3;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;1;4;5;1;1;1;1;1;2;1;2;3;1;1;1;2;2;3;4;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;1;1;1;2;3;4;1;2;3;1;2;3;1;1;2;3;3;1;1;4;1;2;1;1;1;2;3;1;2;3;1;1;1;1;2;1;2;3;1;4;1;1;2;1;1;2;3;1;1;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;2;2;1;1;2;3;1;1;2;1;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;1;2;3;2;3;2;3;3;4;5;2;3;2;3;2;4;4;5;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;2;3;4;5;1;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;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;3;1;2;1;2;3;4;4;5;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;1;2;1;2;3;4;1;2;3;4;5;1;2;6;1;2;7;2;3;4;5;1;2;1;2;3;4;6;7;1;2;3;4;5;6;1;2;8;4;5;6;1;2;1;2;1;2;3;4;5;1;2;3;4;5;1;2;3;2;3;6;7;1;2;8;9;1;1;2;3;1;1;2;3;1;4;1;1;1;1;2;3;1;2;3;4;5;6;7;1;2;3;1;2;1;1;2;3;2;1;5;1;1;2;3;6;7;8;1;2;3;4;5;6;4;2;3;4;2;5;6;7;1;1;1;2;3;4;5;6;7;1;1;2;3;1;1;2;3;4;1;1;2;8;9;10;1;1;1;2;3;4;5;6;4;4;1;2;3;3;4;5;3;3;1;7;8;9;6;7;1;8;9;10;2;1;1;4;5;6;7;8;9;6;7;8;5;6;7;8;9;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;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;6;7;8;5;1;1;1;2;3;1;2;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;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;1;2;1;2;2;1;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;2;3;4;5;6;1;1;1;1;1;1;2;2;1;2;1;2;1;2;1;1;1;1;2;3;3;4;1;1;1;3;4;3;4;4;3;3;4;5;3;4;5;3;4;5;6;7;1;2;3;5;6;7;5;6;7;3;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;2;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;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;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;8;3;4;5;6;7;2;3;4;5;6;7;8;2;3;4;5;6;7;8;9;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;2;2;3;2;2;3;4;5;6;6;7;8;2;3;3;4;4;5;6;4;5;6;4;5;5;6;7;5;6;7;7;8;9;5;6;2;3;4;5;2;3;4;2;3;4;3;4;5;6;1;7;1;2;3;2;2;3;3;4;5;2;3;4;5;4;2;3;2;3;2;3;2;3;4;2;2;2;2;6;7;8;1;2;3;4;5;9;10;2;2;1;1;1;1;1;2;3;4;4;5;5;6;7;8;9;3;4;5;5;6;6;7;3;4;7;8;2;3;3;4;5;4;5;6;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;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;|] + [|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;1;2;2;1;2;2;1;1;2;1;1;1;1;1;1;2;3;4;1;1;5;6;6;1;1;2;1;2;3;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;1;4;5;1;1;1;1;1;2;1;2;3;1;1;1;2;2;3;4;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;1;1;1;2;3;4;1;2;3;1;2;3;1;1;2;3;3;1;1;4;1;2;1;1;1;2;3;1;2;3;1;1;1;1;2;1;2;3;1;4;1;1;2;1;1;2;3;1;1;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;2;2;1;1;2;3;1;1;2;1;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;1;2;3;2;3;2;3;3;4;5;2;3;2;3;2;4;4;5;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;2;3;1;2;1;2;3;4;1;5;2;1;2;3;1;2;4;5;4;5;6;2;3;4;5;1;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;4;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;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;3;1;2;1;2;3;4;4;5;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;1;2;1;2;3;4;1;2;3;4;5;1;2;6;1;2;7;2;3;4;5;1;2;1;2;3;4;6;7;1;2;3;4;5;6;1;2;8;4;5;6;1;2;1;2;1;2;3;4;5;1;2;3;4;5;1;2;3;2;3;6;7;1;2;8;9;1;1;2;3;1;1;2;3;1;4;1;1;1;1;2;3;1;2;3;4;5;6;7;1;2;3;1;2;1;1;2;3;2;1;5;1;1;2;3;6;7;8;1;2;3;4;5;6;4;2;3;4;2;5;6;7;1;1;1;2;3;4;5;6;7;1;1;2;3;1;1;2;3;4;1;1;2;8;9;10;1;1;1;2;3;4;5;6;4;4;1;2;3;3;4;5;3;3;1;7;8;9;6;7;1;8;9;10;2;1;1;4;5;6;7;8;9;6;7;8;5;6;7;8;9;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;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;6;7;8;5;1;1;1;2;3;1;2;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;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;1;2;1;2;2;1;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;2;3;4;5;6;1;1;1;1;1;1;2;2;1;2;1;2;1;2;1;1;1;1;2;3;3;4;1;1;1;3;4;3;4;4;3;3;4;5;3;4;5;3;4;5;6;7;1;2;3;5;6;7;5;6;7;3;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;2;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;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;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;8;3;4;5;6;7;2;3;4;5;6;7;8;2;3;4;5;6;7;8;9;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;2;2;3;2;2;3;4;5;6;6;7;8;2;3;3;4;4;5;6;4;5;6;4;5;5;6;7;5;6;7;7;8;9;5;6;2;3;4;5;2;3;4;2;3;4;3;4;5;6;1;7;1;2;3;2;2;3;3;4;5;2;3;4;5;4;2;3;2;3;2;3;2;3;4;2;2;2;2;6;7;8;1;2;3;4;5;9;10;2;2;1;1;1;1;1;2;3;4;4;5;5;6;7;8;9;3;4;5;5;6;6;7;3;4;7;8;2;3;3;4;5;4;5;6;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;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 @@ -494,7 +494,7 @@ let can_pop (type a) : a terminal -> bool = function | _ -> false let recover = - let r0 = [R 585] in + let r0 = [R 586] in let r1 = S (N N_expr) :: r0 in let r2 = [R 127] in let r3 = S (T T_DONE) :: r2 in @@ -502,13 +502,13 @@ let recover = let r5 = S (T T_DO) :: r4 in let r6 = Sub (r1) :: r5 in let r7 = R 282 :: r6 in - let r8 = [R 684] in + let r8 = [R 685] in let r9 = S (T T_AND) :: r8 in let r10 = [R 42] in let r11 = Sub (r9) :: r10 in let r12 = [R 188] in let r13 = [R 43] in - let r14 = [R 506] in + let r14 = [R 507] in let r15 = S (N N_structure) :: r14 in let r16 = [R 44] in let r17 = S (T T_RBRACKET) :: r16 in @@ -519,7 +519,7 @@ let recover = let r22 = S (T T_DO) :: r21 in let r23 = Sub (r1) :: r22 in let r24 = R 282 :: r23 in - let r25 = [R 652] in + let r25 = [R 653] in let r26 = [R 346] in let r27 = [R 123] in let r28 = Sub (r1) :: r27 in @@ -528,7 +528,7 @@ let recover = 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 550] in + let r34 = [R 551] in let r35 = Sub (r33) :: r34 in let r36 = [R 139] in let r37 = Sub (r35) :: r36 in @@ -537,44 +537,44 @@ let recover = let r40 = R 282 :: r39 in let r41 = [R 190] in let r42 = S (T T_UNDERSCORE) :: r25 in - let r43 = [R 642] in - let r44 = [R 637] in + let r43 = [R 643] in + let r44 = [R 638] in let r45 = S (T T_END) :: r44 in let r46 = R 299 :: r45 in let r47 = R 69 :: r46 in let r48 = R 282 :: r47 in let r49 = [R 67] in let r50 = S (T T_RPAREN) :: r49 in - let r51 = [R 670] in - let r52 = [R 613] in - let r53 = [R 611] in + let r51 = [R 671] in + let r52 = [R 614] in + let r53 = [R 612] in let r54 = [R 101] in - let r55 = [R 666] in + let r55 = [R 667] in let r56 = S (T T_RPAREN) :: r55 in - let r57 = [R 441] in + let r57 = [R 442] in let r58 = S (T T_AMPERAMPER) :: r57 in - let r59 = [R 798] in + let r59 = [R 799] in let r60 = S (T T_RPAREN) :: r59 in let r61 = Sub (r58) :: r60 in let r62 = [R 368] in let r63 = S (T T_UNDERSCORE) :: r62 in - let r64 = [R 668] in + let r64 = [R 669] in let r65 = S (T T_RPAREN) :: r64 in let r66 = Sub (r63) :: r65 in let r67 = R 282 :: r66 in - let r68 = [R 669] in + let r68 = [R 670] in let r69 = S (T T_RPAREN) :: r68 in let r70 = [R 334] in - let r71 = [R 590] in + let r71 = [R 591] in let r72 = R 290 :: r71 in let r73 = [R 370] in let r74 = S (T T_END) :: r73 in let r75 = Sub (r72) :: r74 in - let r76 = [R 799] in + let r76 = [R 800] in let r77 = S (T T_LIDENT) :: r76 in let r78 = [R 25] in let r79 = S (T T_UNDERSCORE) :: r78 in - let r80 = [R 772] in + let r80 = [R 773] in let r81 = Sub (r79) :: r80 in let r82 = [R 202] in let r83 = Sub (r81) :: r82 in @@ -582,28 +582,28 @@ let recover = let r85 = Sub (r83) :: r84 in let r86 = [R 117] in let r87 = Sub (r85) :: r86 in - let r88 = [R 511] in + let r88 = [R 512] in let r89 = Sub (r87) :: r88 in - let r90 = [R 807] in + let r90 = [R 808] in let r91 = R 288 :: r90 in let r92 = Sub (r89) :: r91 in let r93 = S (T T_COLON) :: r92 in let r94 = Sub (r77) :: r93 in let r95 = R 282 :: r94 in - let r96 = [R 415] in + let r96 = [R 416] in let r97 = S (T T_RPAREN) :: r96 in let r98 = R 224 :: r97 in let r99 = [R 225] in - let r100 = [R 417] in + let r100 = [R 418] in let r101 = S (T T_RBRACKET) :: r100 in - let r102 = [R 419] in + let r102 = [R 420] in let r103 = S (T T_RBRACE) :: r102 in let r104 = [R 222] in let r105 = S (T T_LIDENT) :: r104 in let r106 = [R 24] in let r107 = Sub (r105) :: r106 in - let r108 = [R 548] in - let r109 = [R 464] in + let r108 = [R 549] in + let r109 = [R 465] in let r110 = S (T T_COLON) :: r109 in let r111 = [R 23] in let r112 = S (T T_RPAREN) :: r111 in @@ -619,7 +619,7 @@ let recover = let r122 = S (N N_structure) :: r121 in let r123 = [R 332] in let r124 = S (T T_LIDENT) :: r123 in - let r125 = [R 779] in + let r125 = [R 780] in let r126 = Sub (r124) :: r125 in let r127 = [R 102] in let r128 = S (T T_FALSE) :: r127 in @@ -629,51 +629,51 @@ let recover = let r132 = R 282 :: r131 in let r133 = R 209 :: r132 in let r134 = Sub (r130) :: r133 in - let r135 = [R 531] in + let r135 = [R 532] in let r136 = Sub (r134) :: r135 in - let r137 = [R 747] in + let r137 = [R 748] in let r138 = R 288 :: r137 in let r139 = Sub (r136) :: r138 in - let r140 = R 517 :: r139 in + let r140 = R 518 :: r139 in let r141 = S (T T_PLUSEQ) :: r140 in let r142 = Sub (r126) :: r141 in - let r143 = R 781 :: r142 in + let r143 = R 782 :: r142 in let r144 = R 282 :: r143 in let r145 = [R 219] in let r146 = R 288 :: r145 in - let r147 = R 540 :: r146 in - let r148 = R 777 :: r147 in + let r147 = R 541 :: r146 in + let r148 = R 778 :: r147 in let r149 = S (T T_LIDENT) :: r148 in - let r150 = R 781 :: r149 in + let r150 = R 782 :: r149 in let r151 = R 282 :: r150 in let r152 = R 187 :: r151 in - let r153 = [R 748] in + let r153 = [R 749] in let r154 = R 288 :: r153 in let r155 = Sub (r136) :: r154 in - let r156 = R 517 :: r155 in + let r156 = R 518 :: r155 in let r157 = S (T T_PLUSEQ) :: r156 in let r158 = Sub (r126) :: r157 in let r159 = [R 220] in let r160 = R 288 :: r159 in - let r161 = R 540 :: r160 in - let r162 = R 777 :: r161 in + let r161 = R 541 :: r160 in + let r162 = R 778 :: r161 in let r163 = S (T T_LIDENT) :: r162 in - let r164 = R 781 :: r163 in - let r165 = [R 785] in + let r164 = R 782 :: r163 in + let r165 = [R 786] in let r166 = S (T T_UNDERSCORE) :: r165 in - let r167 = [R 780] in + let r167 = [R 781] in let r168 = Sub (r166) :: r167 in - let r169 = R 786 :: r168 in - let r170 = [R 561] in + let r169 = R 787 :: r168 in + let r170 = [R 562] in let r171 = Sub (r169) :: r170 in - let r172 = [R 783] in + let r172 = [R 784] in let r173 = S (T T_RPAREN) :: r172 in - let r174 = [R 784] in - let r175 = [R 562] in - let r176 = [R 400] in + let r174 = [R 785] in + let r175 = [R 563] in + let r176 = [R 401] in let r177 = S (T T_DOTDOT) :: r176 in - let r178 = [R 778] in - let r179 = [R 401] in + let r178 = [R 779] in + let r179 = [R 402] in let r180 = [R 105] in let r181 = S (T T_RPAREN) :: r180 in let r182 = [R 204] in @@ -681,7 +681,7 @@ let recover = let r184 = S (T T_MINUSGREATER) :: r183 in let r185 = Sub (r81) :: r184 in let r186 = [R 30] in - let r187 = [R 513] in + let r187 = [R 514] in let r188 = Sub (r85) :: r187 in let r189 = [R 322] in let r190 = R 282 :: r189 in @@ -690,24 +690,24 @@ let recover = let r193 = S (T T_RBRACKET) :: r192 in let r194 = Sub (r15) :: r193 in let r195 = [R 294] in - let r196 = [R 408] in + let r196 = [R 409] in let r197 = R 288 :: r196 in let r198 = S (N N_module_expr) :: r197 in let r199 = R 282 :: r198 in - let r200 = [R 409] in + let r200 = [R 410] in let r201 = R 288 :: r200 in let r202 = S (N N_module_expr) :: r201 in let r203 = R 282 :: r202 in - let r204 = [R 466] in + let r204 = [R 467] in let r205 = S (T T_RPAREN) :: r204 in - let r206 = [R 467] in + let r206 = [R 468] in let r207 = S (T T_RPAREN) :: r206 in let r208 = S (N N_expr) :: r207 in let r209 = [R 344] in let r210 = S (T T_LIDENT) :: r209 in let r211 = [R 66] in let r212 = Sub (r210) :: r211 in - let r213 = [R 634] in + let r213 = [R 635] in let r214 = Sub (r212) :: r213 in let r215 = R 282 :: r214 in let r216 = [R 345] in @@ -725,35 +725,35 @@ let recover = let r228 = S (T T_WITH) :: r227 in let r229 = Sub (r1) :: r228 in let r230 = R 282 :: r229 in - let r231 = [R 621] in + let r231 = [R 622] in let r232 = S (T T_RPAREN) :: r231 in - let r233 = [R 657] in + let r233 = [R 658] in let r234 = [R 175] in let r235 = [R 252] in let r236 = Sub (r77) :: r235 in let r237 = [R 312] in let r238 = R 288 :: r237 in let r239 = Sub (r236) :: r238 in - let r240 = R 524 :: r239 in + let r240 = R 525 :: r239 in let r241 = R 282 :: r240 in - let r242 = [R 618] in + let r242 = [R 619] in let r243 = [R 100] in - let r244 = [R 579] in + let r244 = [R 580] in let r245 = S (N N_pattern) :: r244 in - let r246 = [R 616] in + let r246 = [R 617] in let r247 = S (T T_RBRACKET) :: r246 in let r248 = [R 236] in let r249 = Sub (r210) :: r248 in let r250 = [R 308] in - let r251 = R 457 :: r250 in - let r252 = R 451 :: r251 in + let r251 = R 458 :: r250 in + let r252 = R 452 :: r251 in let r253 = Sub (r249) :: r252 in - let r254 = [R 615] in + let r254 = [R 616] in let r255 = S (T T_RBRACE) :: r254 in - let r256 = [R 452] in - let r257 = [R 572] in + let r256 = [R 453] in + let r257 = [R 573] in let r258 = Sub (r87) :: r257 in - let r259 = [R 557] in + let r259 = [R 558] in let r260 = Sub (r258) :: r259 in let r261 = [R 39] in let r262 = S (T T_RBRACKET) :: r261 in @@ -761,10 +761,10 @@ let recover = let r264 = [R 38] in let r265 = [R 37] in let r266 = S (T T_RBRACKET) :: r265 in - let r267 = [R 389] in + let r267 = [R 390] in let r268 = Sub (r105) :: r267 in let r269 = S (T T_BACKQUOTE) :: r268 in - let r270 = [R 760] in + let r270 = [R 761] in let r271 = R 282 :: r270 in let r272 = Sub (r269) :: r271 in let r273 = [R 34] in @@ -785,70 +785,70 @@ let recover = let r288 = [R 35] in let r289 = S (T T_RBRACKET) :: r288 in let r290 = [R 205] in - let r291 = [R 569] in + let r291 = [R 570] in let r292 = [R 32] in let r293 = [R 203] in let r294 = Sub (r83) :: r293 in let r295 = S (T T_MINUSGREATER) :: r294 in - let r296 = [R 570] in - let r297 = [R 558] in - let r298 = [R 553] in + let r296 = [R 571] in + let r297 = [R 559] in + let r298 = [R 554] in let r299 = Sub (r85) :: r298 in - let r300 = [R 759] in + let r300 = [R 760] in let r301 = R 282 :: r300 in let r302 = Sub (r299) :: r301 in - let r303 = [R 554] in + let r303 = [R 555] in let r304 = [R 18] in let r305 = Sub (r105) :: r304 in let r306 = [R 36] in let r307 = S (T T_RBRACKET) :: r306 in let r308 = Sub (r260) :: r307 in - let r309 = [R 546] in + let r309 = [R 547] in let r310 = Sub (r269) :: r309 in let r311 = [R 40] in let r312 = S (T T_RBRACKET) :: r311 in - let r313 = [R 458] in + let r313 = [R 459] in let r314 = S (T T_UNDERSCORE) :: r51 in - let r315 = [R 665] in + let r315 = [R 666] in let r316 = Sub (r314) :: r315 in - let r317 = [R 497] in + let r317 = [R 498] in let r318 = Sub (r316) :: r317 in let r319 = R 282 :: r318 in let r320 = [R 96] in - let r321 = [R 675] in + let r321 = [R 676] in let r322 = S (T T_INT) :: r320 in - let r323 = [R 610] in + let r323 = [R 611] in let r324 = Sub (r322) :: r323 in - let r325 = [R 672] in - let r326 = [R 677] in + let r325 = [R 673] in + let r326 = [R 678] in let r327 = S (T T_RBRACKET) :: r326 in let r328 = S (T T_LBRACKET) :: r327 in - let r329 = [R 678] in - let r330 = [R 488] in + let r329 = [R 679] in + let r330 = [R 489] in let r331 = S (N N_pattern) :: r330 in let r332 = R 282 :: r331 in - let r333 = [R 489] in - let r334 = [R 482] in - let r335 = [R 496] in - let r336 = [R 494] in - let r337 = [R 390] in + let r333 = [R 490] in + let r334 = [R 483] in + let r335 = [R 497] in + let r336 = [R 495] in + let r337 = [R 391] in let r338 = S (T T_LIDENT) :: r337 in - let r339 = [R 495] in + let r339 = [R 496] in let r340 = Sub (r316) :: r339 in let r341 = S (T T_RPAREN) :: r340 in let r342 = [R 110] in let r343 = [R 109] in let r344 = S (T T_RPAREN) :: r343 in - let r345 = [R 490] in - let r346 = [R 680] in + let r345 = [R 491] in + let r346 = [R 681] in let r347 = S (T T_RPAREN) :: r346 in - let r348 = [R 487] in - let r349 = [R 485] in + let r348 = [R 488] in + let r349 = [R 486] in let r350 = [R 108] in let r351 = S (T T_RPAREN) :: r350 in - let r352 = [R 679] in + let r352 = [R 680] in let r353 = [R 310] in - let r354 = [R 617] in + let r354 = [R 618] in let r355 = [R 248] in let r356 = [R 234] in let r357 = S (T T_LIDENT) :: r356 in @@ -858,8 +858,8 @@ let recover = let r361 = [R 244] in let r362 = [R 243] in let r363 = S (T T_RPAREN) :: r362 in - let r364 = R 459 :: r363 in - let r365 = [R 460] in + let r364 = R 460 :: r363 in + let r365 = [R 461] in let r366 = [R 267] in let r367 = Sub (r77) :: r366 in let r368 = [R 270] in @@ -867,19 +867,19 @@ let recover = let r370 = [R 173] in let r371 = Sub (r1) :: r370 in let r372 = S (T T_IN) :: r371 in - let r373 = [R 505] in + let r373 = [R 506] in let r374 = S (T T_UNDERSCORE) :: r373 in let r375 = [R 246] in let r376 = [R 245] in let r377 = S (T T_RPAREN) :: r376 in - let r378 = R 459 :: r377 in + let r378 = R 460 :: r377 in let r379 = [R 265] in - let r380 = [R 735] in + let r380 = [R 736] in let r381 = Sub (r1) :: r380 in let r382 = S (T T_EQUAL) :: r381 in let r383 = [R 196] in let r384 = Sub (r382) :: r383 in - let r385 = [R 737] in + let r385 = [R 738] in let r386 = Sub (r384) :: r385 in let r387 = S (T T_RPAREN) :: r386 in let r388 = Sub (r338) :: r387 in @@ -893,7 +893,7 @@ let recover = let r396 = [R 259] in let r397 = R 288 :: r396 in let r398 = Sub (r236) :: r397 in - let r399 = R 524 :: r398 in + let r399 = R 525 :: r398 in let r400 = R 282 :: r399 in let r401 = R 187 :: r400 in let r402 = [R 134] in @@ -911,834 +911,836 @@ let recover = let r414 = S (N N_module_type) :: r413 in let r415 = [R 373] in let r416 = S (T T_RPAREN) :: r415 in - let r417 = [R 371] in + let r417 = [R 376] in let r418 = S (N N_module_type) :: r417 in - let r419 = S (T T_MINUSGREATER) :: r418 in - let r420 = S (N N_functor_args) :: r419 in - let r421 = [R 342] in - let r422 = Sub (r105) :: r421 in - let r423 = [R 381] in - let r424 = Sub (r422) :: r423 in - let r425 = [R 820] in - let r426 = S (N N_module_type) :: r425 in - let r427 = S (T T_EQUAL) :: r426 in - let r428 = Sub (r424) :: r427 in - let r429 = S (T T_TYPE) :: r428 in - let r430 = S (T T_MODULE) :: r429 in - let r431 = [R 555] in - let r432 = Sub (r430) :: r431 in - let r433 = [R 377] in - let r434 = [R 817] in - let r435 = Sub (r85) :: r434 in - let r436 = S (T T_COLONEQUAL) :: r435 in - let r437 = Sub (r249) :: r436 in - let r438 = [R 816] in - let r439 = R 540 :: r438 in - let r440 = [R 541] in - let r441 = Sub (r87) :: r440 in - let r442 = S (T T_EQUAL) :: r441 in - let r443 = [R 343] in - let r444 = Sub (r105) :: r443 in - let r445 = [R 821] in - let r446 = [R 376] in - let r447 = [R 818] in - let r448 = Sub (r285) :: r447 in - let r449 = S (T T_UIDENT) :: r218 in - let r450 = [R 819] in - let r451 = [R 556] in - let r452 = [R 364] in - let r453 = [R 465] in - let r454 = S (T T_RPAREN) :: r453 in - let r455 = [R 573] in - let r456 = S (N N_expr) :: r455 in - let r457 = [R 660] in - let r458 = S (T T_RBRACKET) :: r457 in - let r459 = [R 645] in - let r460 = [R 576] in - let r461 = R 453 :: r460 in - let r462 = [R 454] in - let r463 = [R 582] in - let r464 = R 453 :: r463 in - let r465 = R 461 :: r464 in - let r466 = Sub (r249) :: r465 in - let r467 = [R 526] in - let r468 = Sub (r466) :: r467 in - let r469 = [R 654] in - let r470 = S (T T_RBRACE) :: r469 in - let r471 = [R 620] in - let r472 = [R 619] in - let r473 = S (T T_GREATERDOT) :: r472 in - let r474 = [R 145] in - let r475 = Sub (r42) :: r474 in - let r476 = R 282 :: r475 in - let r477 = [R 633] in - let r478 = S (T T_END) :: r477 in - let r479 = R 282 :: r478 in - let r480 = [R 141] in - let r481 = S (N N_expr) :: r480 in - let r482 = S (T T_THEN) :: r481 in - let r483 = Sub (r1) :: r482 in - let r484 = R 282 :: r483 in - let r485 = [R 135] in - let r486 = Sub (r35) :: r485 in - let r487 = R 282 :: r486 in - let r488 = [R 551] in - let r489 = [R 316] in - let r490 = Sub (r1) :: r489 in - let r491 = S (T T_MINUSGREATER) :: r490 in - let r492 = [R 250] in - let r493 = Sub (r316) :: r492 in - let r494 = [R 198] in - let r495 = Sub (r1) :: r494 in - let r496 = S (T T_MINUSGREATER) :: r495 in - let r497 = [R 136] in - let r498 = Sub (r496) :: r497 in - let r499 = Sub (r493) :: r498 in - let r500 = R 282 :: r499 in - let r501 = [R 137] in - let r502 = Sub (r496) :: r501 in - let r503 = S (T T_RPAREN) :: r502 in - let r504 = [R 129] in - let r505 = S (T T_DONE) :: r504 in - let r506 = Sub (r1) :: r505 in - let r507 = S (T T_DO) :: r506 in + let r419 = [R 371] in + let r420 = S (N N_module_type) :: r419 in + let r421 = S (T T_MINUSGREATER) :: r420 in + let r422 = S (N N_functor_args) :: r421 in + let r423 = [R 342] in + let r424 = Sub (r105) :: r423 in + let r425 = [R 382] in + let r426 = Sub (r424) :: r425 in + let r427 = [R 821] in + let r428 = S (N N_module_type) :: r427 in + let r429 = S (T T_EQUAL) :: r428 in + let r430 = Sub (r426) :: r429 in + let r431 = S (T T_TYPE) :: r430 in + let r432 = S (T T_MODULE) :: r431 in + let r433 = [R 556] in + let r434 = Sub (r432) :: r433 in + let r435 = [R 378] in + let r436 = [R 818] in + let r437 = Sub (r85) :: r436 in + let r438 = S (T T_COLONEQUAL) :: r437 in + let r439 = Sub (r249) :: r438 in + let r440 = [R 817] in + let r441 = R 541 :: r440 in + let r442 = [R 542] in + let r443 = Sub (r87) :: r442 in + let r444 = S (T T_EQUAL) :: r443 in + let r445 = [R 343] in + let r446 = Sub (r105) :: r445 in + let r447 = [R 822] in + let r448 = [R 377] in + let r449 = [R 819] in + let r450 = Sub (r285) :: r449 in + let r451 = S (T T_UIDENT) :: r218 in + let r452 = [R 820] in + let r453 = [R 557] in + let r454 = [R 364] in + let r455 = [R 466] in + let r456 = S (T T_RPAREN) :: r455 in + let r457 = [R 574] in + let r458 = S (N N_expr) :: r457 in + let r459 = [R 661] in + let r460 = S (T T_RBRACKET) :: r459 in + let r461 = [R 646] in + let r462 = [R 577] in + let r463 = R 454 :: r462 in + let r464 = [R 455] in + let r465 = [R 583] in + let r466 = R 454 :: r465 in + let r467 = R 462 :: r466 in + let r468 = Sub (r249) :: r467 in + let r469 = [R 527] in + let r470 = Sub (r468) :: r469 in + let r471 = [R 655] in + let r472 = S (T T_RBRACE) :: r471 in + let r473 = [R 621] in + let r474 = [R 620] in + let r475 = S (T T_GREATERDOT) :: r474 in + let r476 = [R 145] in + let r477 = Sub (r42) :: r476 in + let r478 = R 282 :: r477 in + let r479 = [R 634] in + let r480 = S (T T_END) :: r479 in + let r481 = R 282 :: r480 in + let r482 = [R 141] in + let r483 = S (N N_expr) :: r482 in + let r484 = S (T T_THEN) :: r483 in + let r485 = Sub (r1) :: r484 in + let r486 = R 282 :: r485 in + let r487 = [R 135] in + let r488 = Sub (r35) :: r487 in + let r489 = R 282 :: r488 in + let r490 = [R 552] in + let r491 = [R 316] in + let r492 = Sub (r1) :: r491 in + let r493 = S (T T_MINUSGREATER) :: r492 in + let r494 = [R 250] in + let r495 = Sub (r316) :: r494 in + let r496 = [R 198] in + let r497 = Sub (r1) :: r496 in + let r498 = S (T T_MINUSGREATER) :: r497 in + let r499 = [R 136] in + let r500 = Sub (r498) :: r499 in + let r501 = Sub (r495) :: r500 in + let r502 = R 282 :: r501 in + let r503 = [R 137] in + let r504 = Sub (r498) :: r503 in + let r505 = S (T T_RPAREN) :: r504 in + let r506 = [R 129] in + let r507 = S (T T_DONE) :: r506 in let r508 = Sub (r1) :: r507 in - let r509 = S (T T_IN) :: r508 in - let r510 = S (N N_pattern) :: r509 in - let r511 = R 282 :: r510 in - let r512 = [R 120] in - let r513 = S (T T_DOWNTO) :: r512 in - let r514 = [R 143] in - let r515 = S (T T_DONE) :: r514 in - let r516 = Sub (r1) :: r515 in - let r517 = S (T T_DO) :: r516 in + let r509 = S (T T_DO) :: r508 in + let r510 = Sub (r1) :: r509 in + let r511 = S (T T_IN) :: r510 in + let r512 = S (N N_pattern) :: r511 in + let r513 = R 282 :: r512 in + let r514 = [R 120] in + let r515 = S (T T_DOWNTO) :: r514 in + let r516 = [R 143] in + let r517 = S (T T_DONE) :: r516 in let r518 = Sub (r1) :: r517 in - let r519 = Sub (r513) :: r518 in + let r519 = S (T T_DO) :: r518 in let r520 = Sub (r1) :: r519 in - let r521 = S (T T_EQUAL) :: r520 in - let r522 = S (N N_pattern) :: r521 in - let r523 = R 282 :: r522 in - let r524 = [R 643] in - let r525 = [R 653] in - let r526 = S (T T_RPAREN) :: r525 in - let r527 = S (T T_LPAREN) :: r526 in - let r528 = S (T T_DOT) :: r527 in - let r529 = [R 663] in - let r530 = S (T T_RPAREN) :: r529 in - let r531 = S (N N_module_type) :: r530 in - let r532 = S (T T_COLON) :: r531 in - let r533 = S (N N_module_expr) :: r532 in - let r534 = R 282 :: r533 in - let r535 = [R 268] in - let r536 = Sub (r1) :: r535 in - let r537 = S (T T_EQUAL) :: r536 in - let r538 = [R 144] in - let r539 = Sub (r42) :: r538 in - let r540 = R 282 :: r539 in - let r541 = [R 650] in - let r542 = [R 626] in - let r543 = S (T T_RPAREN) :: r542 in - let r544 = Sub (r456) :: r543 in - let r545 = S (T T_LPAREN) :: r544 in - let r546 = [R 170] in - let r547 = [R 239] in - let r548 = [R 774] in - let r549 = Sub (r87) :: r548 in - let r550 = S (T T_COLON) :: r549 in - let r551 = [R 240] in - let r552 = S (T T_RPAREN) :: r551 in - let r553 = Sub (r550) :: r552 in - let r554 = [R 776] in - let r555 = [R 775] in - let r556 = [R 241] in - let r557 = [R 242] in - let r558 = [R 649] in - let r559 = [R 623] in - let r560 = S (T T_RPAREN) :: r559 in - let r561 = Sub (r1) :: r560 in - let r562 = S (T T_LPAREN) :: r561 in - let r563 = [R 567] in - let r564 = [R 121] in - let r565 = Sub (r1) :: r564 in - let r566 = [R 172] in + let r521 = Sub (r515) :: r520 in + let r522 = Sub (r1) :: r521 in + let r523 = S (T T_EQUAL) :: r522 in + let r524 = S (N N_pattern) :: r523 in + let r525 = R 282 :: r524 in + let r526 = [R 644] in + let r527 = [R 654] in + let r528 = S (T T_RPAREN) :: r527 in + let r529 = S (T T_LPAREN) :: r528 in + let r530 = S (T T_DOT) :: r529 in + let r531 = [R 664] in + let r532 = S (T T_RPAREN) :: r531 in + let r533 = S (N N_module_type) :: r532 in + let r534 = S (T T_COLON) :: r533 in + let r535 = S (N N_module_expr) :: r534 in + let r536 = R 282 :: r535 in + let r537 = [R 268] in + let r538 = Sub (r1) :: r537 in + let r539 = S (T T_EQUAL) :: r538 in + let r540 = [R 144] in + let r541 = Sub (r42) :: r540 in + let r542 = R 282 :: r541 in + let r543 = [R 651] in + let r544 = [R 627] in + let r545 = S (T T_RPAREN) :: r544 in + let r546 = Sub (r458) :: r545 in + let r547 = S (T T_LPAREN) :: r546 in + let r548 = [R 170] in + let r549 = [R 239] in + let r550 = [R 775] in + let r551 = Sub (r87) :: r550 in + let r552 = S (T T_COLON) :: r551 in + let r553 = [R 240] in + let r554 = S (T T_RPAREN) :: r553 in + let r555 = Sub (r552) :: r554 in + let r556 = [R 777] in + let r557 = [R 776] in + let r558 = [R 241] in + let r559 = [R 242] in + let r560 = [R 650] in + let r561 = [R 624] in + let r562 = S (T T_RPAREN) :: r561 in + let r563 = Sub (r1) :: r562 in + let r564 = S (T T_LPAREN) :: r563 in + let r565 = [R 568] in + let r566 = [R 121] in let r567 = Sub (r1) :: r566 in - let r568 = [R 160] in - let r569 = [R 154] in - let r570 = [R 171] in - let r571 = [R 588] in - let r572 = Sub (r1) :: r571 in - let r573 = [R 157] in - let r574 = [R 161] in - let r575 = [R 153] in - let r576 = [R 156] in - let r577 = [R 155] in - let r578 = [R 165] in - let r579 = [R 159] in - let r580 = [R 158] in - let r581 = [R 163] in - let r582 = [R 152] in - let r583 = [R 151] in - let r584 = [R 174] in - let r585 = [R 150] in - let r586 = [R 164] in - let r587 = [R 162] in - let r588 = [R 166] in - let r589 = [R 167] in - let r590 = [R 168] in - let r591 = [R 568] in - let r592 = [R 169] in - let r593 = [R 19] in - let r594 = R 288 :: r593 in - let r595 = Sub (r236) :: r594 in - let r596 = [R 258] in - let r597 = Sub (r1) :: r596 in - let r598 = S (T T_EQUAL) :: r597 in - let r599 = [R 257] in - let r600 = Sub (r1) :: r599 in - let r601 = [R 492] in - let r602 = [R 498] in - let r603 = [R 503] in - let r604 = [R 501] in - let r605 = [R 491] in - let r606 = [R 515] in - let r607 = S (T T_RBRACKET) :: r606 in - let r608 = Sub (r15) :: r607 in - let r609 = [R 509] in - let r610 = [R 510] in - let r611 = [R 353] in - let r612 = S (N N_module_expr) :: r611 in - let r613 = S (T T_EQUAL) :: r612 in - let r614 = [R 750] in - let r615 = R 288 :: r614 in - let r616 = Sub (r613) :: r615 in - let r617 = Sub (r63) :: r616 in - let r618 = R 282 :: r617 in - let r619 = [R 379] in - let r620 = R 288 :: r619 in - let r621 = R 455 :: r620 in - let r622 = Sub (r105) :: r621 in - let r623 = R 282 :: r622 in - let r624 = R 187 :: r623 in - let r625 = [R 456] in - let r626 = [R 289] in - let r627 = [R 751] in - let r628 = R 278 :: r627 in - let r629 = R 288 :: r628 in - let r630 = Sub (r613) :: r629 in - let r631 = [R 354] in - let r632 = S (N N_module_expr) :: r631 in - let r633 = S (T T_EQUAL) :: r632 in - let r634 = [R 279] in - let r635 = R 278 :: r634 in - let r636 = R 288 :: r635 in - let r637 = Sub (r613) :: r636 in - let r638 = Sub (r63) :: r637 in - let r639 = [R 355] in - let r640 = [R 227] in - let r641 = S (T T_RBRACKET) :: r640 in - let r642 = Sub (r15) :: r641 in - let r643 = [R 193] in - let r644 = S (T T_RBRACKET) :: r643 in - let r645 = Sub (r15) :: r644 in - let r646 = [R 756] in - let r647 = R 288 :: r646 in - let r648 = S (N N_module_expr) :: r647 in - let r649 = R 282 :: r648 in - let r650 = [R 392] in - let r651 = S (T T_STRING) :: r650 in - let r652 = [R 516] in - let r653 = R 288 :: r652 in - let r654 = Sub (r651) :: r653 in - let r655 = S (T T_EQUAL) :: r654 in - let r656 = Sub (r89) :: r655 in - let r657 = S (T T_COLON) :: r656 in - let r658 = Sub (r77) :: r657 in - let r659 = R 282 :: r658 in - let r660 = [R 512] in - let r661 = Sub (r87) :: r660 in - let r662 = [R 549] in - let r663 = Sub (r128) :: r342 in - let r664 = [R 734] in - let r665 = R 288 :: r664 in - let r666 = R 282 :: r665 in - let r667 = Sub (r663) :: r666 in - let r668 = S (T T_EQUAL) :: r667 in - let r669 = Sub (r130) :: r668 in - let r670 = R 282 :: r669 in - let r671 = [R 589] in - let r672 = R 288 :: r671 in - let r673 = R 282 :: r672 in - let r674 = R 209 :: r673 in - let r675 = Sub (r130) :: r674 in - let r676 = R 282 :: r675 in - let r677 = R 187 :: r676 in - let r678 = [R 112] in - let r679 = Sub (r79) :: r678 in - let r680 = [R 210] in - let r681 = [R 229] in - let r682 = R 282 :: r681 in - let r683 = Sub (r188) :: r682 in - let r684 = S (T T_COLON) :: r683 in - let r685 = S (T T_LIDENT) :: r684 in - let r686 = R 382 :: r685 in - let r687 = [R 231] in - let r688 = Sub (r686) :: r687 in - let r689 = [R 114] in - let r690 = S (T T_RBRACE) :: r689 in - let r691 = [R 230] in - let r692 = R 282 :: r691 in - let r693 = S (T T_SEMI) :: r692 in + let r568 = [R 172] in + let r569 = Sub (r1) :: r568 in + let r570 = [R 160] in + let r571 = [R 154] in + let r572 = [R 171] in + let r573 = [R 589] in + let r574 = Sub (r1) :: r573 in + let r575 = [R 157] in + let r576 = [R 161] in + let r577 = [R 153] in + let r578 = [R 156] in + let r579 = [R 155] in + let r580 = [R 165] in + let r581 = [R 159] in + let r582 = [R 158] in + let r583 = [R 163] in + let r584 = [R 152] in + let r585 = [R 151] in + let r586 = [R 174] in + let r587 = [R 150] in + let r588 = [R 164] in + let r589 = [R 162] in + let r590 = [R 166] in + let r591 = [R 167] in + let r592 = [R 168] in + let r593 = [R 569] in + let r594 = [R 169] in + let r595 = [R 19] in + let r596 = R 288 :: r595 in + let r597 = Sub (r236) :: r596 in + let r598 = [R 258] in + let r599 = Sub (r1) :: r598 in + let r600 = S (T T_EQUAL) :: r599 in + let r601 = [R 257] in + let r602 = Sub (r1) :: r601 in + let r603 = [R 493] in + let r604 = [R 499] in + let r605 = [R 504] in + let r606 = [R 502] in + let r607 = [R 492] in + let r608 = [R 516] in + let r609 = S (T T_RBRACKET) :: r608 in + let r610 = Sub (r15) :: r609 in + let r611 = [R 510] in + let r612 = [R 511] in + let r613 = [R 353] in + let r614 = S (N N_module_expr) :: r613 in + let r615 = S (T T_EQUAL) :: r614 in + let r616 = [R 751] in + let r617 = R 288 :: r616 in + let r618 = Sub (r615) :: r617 in + let r619 = Sub (r63) :: r618 in + let r620 = R 282 :: r619 in + let r621 = [R 380] in + let r622 = R 288 :: r621 in + let r623 = R 456 :: r622 in + let r624 = Sub (r105) :: r623 in + let r625 = R 282 :: r624 in + let r626 = R 187 :: r625 in + let r627 = [R 457] in + let r628 = [R 289] in + let r629 = [R 752] in + let r630 = R 278 :: r629 in + let r631 = R 288 :: r630 in + let r632 = Sub (r615) :: r631 in + let r633 = [R 354] in + let r634 = S (N N_module_expr) :: r633 in + let r635 = S (T T_EQUAL) :: r634 in + let r636 = [R 279] in + let r637 = R 278 :: r636 in + let r638 = R 288 :: r637 in + let r639 = Sub (r615) :: r638 in + let r640 = Sub (r63) :: r639 in + let r641 = [R 355] in + let r642 = [R 227] in + let r643 = S (T T_RBRACKET) :: r642 in + let r644 = Sub (r15) :: r643 in + let r645 = [R 193] in + let r646 = S (T T_RBRACKET) :: r645 in + let r647 = Sub (r15) :: r646 in + let r648 = [R 757] in + let r649 = R 288 :: r648 in + let r650 = S (N N_module_expr) :: r649 in + let r651 = R 282 :: r650 in + let r652 = [R 393] in + let r653 = S (T T_STRING) :: r652 in + let r654 = [R 517] in + let r655 = R 288 :: r654 in + let r656 = Sub (r653) :: r655 in + let r657 = S (T T_EQUAL) :: r656 in + let r658 = Sub (r89) :: r657 in + let r659 = S (T T_COLON) :: r658 in + let r660 = Sub (r77) :: r659 in + let r661 = R 282 :: r660 in + let r662 = [R 513] in + let r663 = Sub (r87) :: r662 in + let r664 = [R 550] in + let r665 = Sub (r128) :: r342 in + let r666 = [R 735] in + let r667 = R 288 :: r666 in + let r668 = R 282 :: r667 in + let r669 = Sub (r665) :: r668 in + let r670 = S (T T_EQUAL) :: r669 in + let r671 = Sub (r130) :: r670 in + let r672 = R 282 :: r671 in + let r673 = [R 590] in + let r674 = R 288 :: r673 in + let r675 = R 282 :: r674 in + let r676 = R 209 :: r675 in + let r677 = Sub (r130) :: r676 in + let r678 = R 282 :: r677 in + let r679 = R 187 :: r678 in + let r680 = [R 112] in + let r681 = Sub (r79) :: r680 in + let r682 = [R 210] in + let r683 = [R 229] in + let r684 = R 282 :: r683 in + let r685 = Sub (r188) :: r684 in + let r686 = S (T T_COLON) :: r685 in + let r687 = S (T T_LIDENT) :: r686 in + let r688 = R 383 :: r687 in + let r689 = [R 231] in + let r690 = Sub (r688) :: r689 in + let r691 = [R 114] in + let r692 = S (T T_RBRACE) :: r691 in + let r693 = [R 230] in let r694 = R 282 :: r693 in - let r695 = Sub (r188) :: r694 in - let r696 = S (T T_COLON) :: r695 in - let r697 = [R 514] in - let r698 = Sub (r85) :: r697 in - let r699 = [R 113] in - let r700 = Sub (r79) :: r699 in - let r701 = S (T T_COLONCOLON) :: r351 in - let r702 = [R 213] in - let r703 = [R 214] in - let r704 = Sub (r79) :: r703 in - let r705 = [R 212] in + let r695 = S (T T_SEMI) :: r694 in + let r696 = R 282 :: r695 in + let r697 = Sub (r188) :: r696 in + let r698 = S (T T_COLON) :: r697 in + let r699 = [R 515] in + let r700 = Sub (r85) :: r699 in + let r701 = [R 113] in + let r702 = Sub (r79) :: r701 in + let r703 = S (T T_COLONCOLON) :: r351 in + let r704 = [R 213] in + let r705 = [R 214] in let r706 = Sub (r79) :: r705 in - let r707 = [R 211] in + let r707 = [R 212] in let r708 = Sub (r79) :: r707 in - let r709 = [R 507] in - let r710 = [R 537] in - let r711 = Sub (r134) :: r710 in - let r712 = [R 597] in - let r713 = R 288 :: r712 in - let r714 = Sub (r711) :: r713 in - let r715 = R 517 :: r714 in - let r716 = S (T T_PLUSEQ) :: r715 in - let r717 = Sub (r126) :: r716 in - let r718 = R 781 :: r717 in - let r719 = R 282 :: r718 in - let r720 = [R 598] in - let r721 = R 288 :: r720 in - let r722 = Sub (r711) :: r721 in - let r723 = R 517 :: r722 in - let r724 = S (T T_PLUSEQ) :: r723 in - let r725 = Sub (r126) :: r724 in - let r726 = [R 218] in - let r727 = R 288 :: r726 in - let r728 = R 540 :: r727 in - let r729 = [R 404] in - let r730 = S (T T_RBRACE) :: r729 in - let r731 = [R 215] in - let r732 = R 282 :: r731 in - let r733 = R 209 :: r732 in - let r734 = Sub (r130) :: r733 in - let r735 = [R 402] in - let r736 = [R 403] in - let r737 = [R 407] in - let r738 = S (T T_RBRACE) :: r737 in - let r739 = [R 406] in + let r709 = [R 211] in + let r710 = Sub (r79) :: r709 in + let r711 = [R 508] in + let r712 = [R 538] in + let r713 = Sub (r134) :: r712 in + let r714 = [R 598] in + let r715 = R 288 :: r714 in + let r716 = Sub (r713) :: r715 in + let r717 = R 518 :: r716 in + let r718 = S (T T_PLUSEQ) :: r717 in + let r719 = Sub (r126) :: r718 in + let r720 = R 782 :: r719 in + let r721 = R 282 :: r720 in + let r722 = [R 599] in + let r723 = R 288 :: r722 in + let r724 = Sub (r713) :: r723 in + let r725 = R 518 :: r724 in + let r726 = S (T T_PLUSEQ) :: r725 in + let r727 = Sub (r126) :: r726 in + let r728 = [R 218] in + let r729 = R 288 :: r728 in + let r730 = R 541 :: r729 in + let r731 = [R 405] in + let r732 = S (T T_RBRACE) :: r731 in + let r733 = [R 215] in + let r734 = R 282 :: r733 in + let r735 = R 209 :: r734 in + let r736 = Sub (r130) :: r735 in + let r737 = [R 403] in + let r738 = [R 404] in + let r739 = [R 408] in let r740 = S (T T_RBRACE) :: r739 in - let r741 = [R 217] in - let r742 = R 288 :: r741 in - let r743 = R 540 :: r742 in - let r744 = [R 291] in - let r745 = [R 410] in - let r746 = R 288 :: r745 in - let r747 = Sub (r285) :: r746 in - let r748 = R 282 :: r747 in - let r749 = [R 411] in - let r750 = R 288 :: r749 in - let r751 = Sub (r285) :: r750 in - let r752 = R 282 :: r751 in - let r753 = [R 356] in - let r754 = S (N N_module_type) :: r753 in - let r755 = S (T T_COLON) :: r754 in - let r756 = [R 600] in - let r757 = R 288 :: r756 in - let r758 = Sub (r755) :: r757 in - let r759 = Sub (r63) :: r758 in - let r760 = R 282 :: r759 in - let r761 = [R 380] in - let r762 = R 288 :: r761 in - let r763 = S (N N_module_type) :: r762 in - let r764 = S (T T_COLONEQUAL) :: r763 in - let r765 = Sub (r105) :: r764 in - let r766 = R 282 :: r765 in - let r767 = [R 369] in - let r768 = R 288 :: r767 in - let r769 = [R 603] in - let r770 = R 280 :: r769 in - let r771 = R 288 :: r770 in - let r772 = S (N N_module_type) :: r771 in - let r773 = S (T T_COLON) :: r772 in - let r774 = [R 281] in - let r775 = R 280 :: r774 in - let r776 = R 288 :: r775 in - let r777 = S (N N_module_type) :: r776 in - let r778 = S (T T_COLON) :: r777 in - let r779 = Sub (r63) :: r778 in - let r780 = S (T T_UIDENT) :: r26 in - let r781 = Sub (r780) :: r219 in - let r782 = [R 601] in - let r783 = R 288 :: r782 in - let r784 = [R 357] in - let r785 = [R 607] in - let r786 = R 288 :: r785 in - let r787 = S (N N_module_type) :: r786 in - let r788 = R 282 :: r787 in - let r789 = S (T T_QUOTED_STRING_EXPR) :: r41 in - let r790 = [R 80] in - let r791 = Sub (r789) :: r790 in - let r792 = [R 90] in + let r741 = [R 407] in + let r742 = S (T T_RBRACE) :: r741 in + let r743 = [R 217] in + let r744 = R 288 :: r743 in + let r745 = R 541 :: r744 in + let r746 = [R 291] in + let r747 = [R 411] in + let r748 = R 288 :: r747 in + let r749 = Sub (r285) :: r748 in + let r750 = R 282 :: r749 in + let r751 = [R 412] in + let r752 = R 288 :: r751 in + let r753 = Sub (r285) :: r752 in + let r754 = R 282 :: r753 in + let r755 = [R 356] in + let r756 = S (N N_module_type) :: r755 in + let r757 = S (T T_COLON) :: r756 in + let r758 = [R 601] in + let r759 = R 288 :: r758 in + let r760 = Sub (r757) :: r759 in + let r761 = Sub (r63) :: r760 in + let r762 = R 282 :: r761 in + let r763 = [R 381] in + let r764 = R 288 :: r763 in + let r765 = S (N N_module_type) :: r764 in + let r766 = S (T T_COLONEQUAL) :: r765 in + let r767 = Sub (r105) :: r766 in + let r768 = R 282 :: r767 in + let r769 = [R 369] in + let r770 = R 288 :: r769 in + let r771 = [R 604] in + let r772 = R 280 :: r771 in + let r773 = R 288 :: r772 in + let r774 = S (N N_module_type) :: r773 in + let r775 = S (T T_COLON) :: r774 in + let r776 = [R 281] in + let r777 = R 280 :: r776 in + let r778 = R 288 :: r777 in + let r779 = S (N N_module_type) :: r778 in + let r780 = S (T T_COLON) :: r779 in + let r781 = Sub (r63) :: r780 in + let r782 = S (T T_UIDENT) :: r26 in + let r783 = Sub (r782) :: r219 in + let r784 = [R 602] in + let r785 = R 288 :: r784 in + let r786 = [R 357] in + let r787 = [R 608] in + let r788 = R 288 :: r787 in + let r789 = S (N N_module_type) :: r788 in + let r790 = R 282 :: r789 in + let r791 = S (T T_QUOTED_STRING_EXPR) :: r41 in + let r792 = [R 80] in let r793 = Sub (r791) :: r792 in - let r794 = [R 608] in - let r795 = R 274 :: r794 in - let r796 = R 288 :: r795 in - let r797 = Sub (r793) :: r796 in - let r798 = S (T T_COLON) :: r797 in - let r799 = S (T T_LIDENT) :: r798 in - let r800 = R 194 :: r799 in - let r801 = R 808 :: r800 in - let r802 = R 282 :: r801 in - let r803 = [R 94] in - let r804 = R 276 :: r803 in - let r805 = R 288 :: r804 in - let r806 = Sub (r791) :: r805 in - let r807 = S (T T_EQUAL) :: r806 in - let r808 = S (T T_LIDENT) :: r807 in - let r809 = R 194 :: r808 in - let r810 = R 808 :: r809 in - let r811 = R 282 :: r810 in - let r812 = [R 195] in - let r813 = S (T T_RBRACKET) :: r812 in - let r814 = [R 81] in - let r815 = S (T T_END) :: r814 in - let r816 = R 297 :: r815 in - let r817 = R 71 :: r816 in - let r818 = [R 70] in - let r819 = S (T T_RPAREN) :: r818 in - let r820 = [R 73] in - let r821 = R 288 :: r820 in - let r822 = Sub (r87) :: r821 in - let r823 = S (T T_COLON) :: r822 in - let r824 = S (T T_LIDENT) :: r823 in - let r825 = R 384 :: r824 in - let r826 = [R 74] in - let r827 = R 288 :: r826 in - let r828 = Sub (r89) :: r827 in - let r829 = S (T T_COLON) :: r828 in - let r830 = S (T T_LIDENT) :: r829 in - let r831 = R 519 :: r830 in - let r832 = [R 72] in - let r833 = R 288 :: r832 in - let r834 = Sub (r791) :: r833 in - let r835 = [R 83] in - let r836 = Sub (r791) :: r835 in - let r837 = S (T T_IN) :: r836 in - let r838 = Sub (r781) :: r837 in - let r839 = R 282 :: r838 in - let r840 = [R 84] in - let r841 = Sub (r791) :: r840 in - let r842 = S (T T_IN) :: r841 in - let r843 = Sub (r781) :: r842 in - let r844 = [R 559] in - let r845 = Sub (r87) :: r844 in - let r846 = [R 79] in - let r847 = Sub (r276) :: r846 in - let r848 = S (T T_RBRACKET) :: r847 in - let r849 = Sub (r845) :: r848 in - let r850 = [R 560] in - let r851 = [R 111] in - let r852 = Sub (r87) :: r851 in - let r853 = S (T T_EQUAL) :: r852 in + let r794 = [R 90] in + let r795 = Sub (r793) :: r794 in + let r796 = [R 609] in + let r797 = R 274 :: r796 in + let r798 = R 288 :: r797 in + let r799 = Sub (r795) :: r798 in + let r800 = S (T T_COLON) :: r799 in + let r801 = S (T T_LIDENT) :: r800 in + let r802 = R 194 :: r801 in + let r803 = R 809 :: r802 in + let r804 = R 282 :: r803 in + let r805 = [R 94] in + let r806 = R 276 :: r805 in + let r807 = R 288 :: r806 in + let r808 = Sub (r793) :: r807 in + let r809 = S (T T_EQUAL) :: r808 in + let r810 = S (T T_LIDENT) :: r809 in + let r811 = R 194 :: r810 in + let r812 = R 809 :: r811 in + let r813 = R 282 :: r812 in + let r814 = [R 195] in + let r815 = S (T T_RBRACKET) :: r814 in + let r816 = [R 81] in + let r817 = S (T T_END) :: r816 in + let r818 = R 297 :: r817 in + let r819 = R 71 :: r818 in + let r820 = [R 70] in + let r821 = S (T T_RPAREN) :: r820 in + let r822 = [R 73] in + let r823 = R 288 :: r822 in + let r824 = Sub (r87) :: r823 in + let r825 = S (T T_COLON) :: r824 in + let r826 = S (T T_LIDENT) :: r825 in + let r827 = R 385 :: r826 in + let r828 = [R 74] in + let r829 = R 288 :: r828 in + let r830 = Sub (r89) :: r829 in + let r831 = S (T T_COLON) :: r830 in + let r832 = S (T T_LIDENT) :: r831 in + let r833 = R 520 :: r832 in + let r834 = [R 72] in + let r835 = R 288 :: r834 in + let r836 = Sub (r793) :: r835 in + let r837 = [R 83] in + let r838 = Sub (r793) :: r837 in + let r839 = S (T T_IN) :: r838 in + let r840 = Sub (r783) :: r839 in + let r841 = R 282 :: r840 in + let r842 = [R 84] in + let r843 = Sub (r793) :: r842 in + let r844 = S (T T_IN) :: r843 in + let r845 = Sub (r783) :: r844 in + let r846 = [R 560] in + let r847 = Sub (r87) :: r846 in + let r848 = [R 79] in + let r849 = Sub (r276) :: r848 in + let r850 = S (T T_RBRACKET) :: r849 in + let r851 = Sub (r847) :: r850 in + let r852 = [R 561] in + let r853 = [R 111] in let r854 = Sub (r87) :: r853 in - let r855 = [R 75] in - let r856 = R 288 :: r855 in - let r857 = Sub (r854) :: r856 in - let r858 = [R 76] in - let r859 = [R 298] in - let r860 = [R 277] in - let r861 = R 276 :: r860 in - let r862 = R 288 :: r861 in - let r863 = Sub (r791) :: r862 in - let r864 = S (T T_EQUAL) :: r863 in - let r865 = S (T T_LIDENT) :: r864 in - let r866 = R 194 :: r865 in - let r867 = R 808 :: r866 in - let r868 = [R 92] in - let r869 = Sub (r793) :: r868 in - let r870 = S (T T_MINUSGREATER) :: r869 in - let r871 = Sub (r81) :: r870 in - let r872 = [R 93] in - let r873 = Sub (r793) :: r872 in - let r874 = [R 91] in - let r875 = Sub (r793) :: r874 in - let r876 = S (T T_MINUSGREATER) :: r875 in - let r877 = [R 275] in - let r878 = R 274 :: r877 in - let r879 = R 288 :: r878 in - let r880 = Sub (r793) :: r879 in - let r881 = S (T T_COLON) :: r880 in - let r882 = S (T T_LIDENT) :: r881 in - let r883 = R 194 :: r882 in - let r884 = R 808 :: r883 in - let r885 = [R 292] in - let r886 = [R 591] in - let r887 = [R 595] in - let r888 = [R 285] in - let r889 = R 284 :: r888 in - let r890 = R 288 :: r889 in - let r891 = R 540 :: r890 in - let r892 = R 777 :: r891 in - let r893 = S (T T_LIDENT) :: r892 in - let r894 = R 781 :: r893 in - let r895 = [R 596] in - let r896 = [R 287] in - let r897 = R 286 :: r896 in - let r898 = R 288 :: r897 in - let r899 = R 540 :: r898 in - let r900 = Sub (r177) :: r899 in - let r901 = S (T T_COLONEQUAL) :: r900 in - let r902 = S (T T_LIDENT) :: r901 in - let r903 = R 781 :: r902 in - let r904 = [R 52] in - let r905 = Sub (r789) :: r904 in - let r906 = [R 61] in - let r907 = Sub (r905) :: r906 in - let r908 = S (T T_EQUAL) :: r907 in - let r909 = [R 754] in - let r910 = R 272 :: r909 in - let r911 = R 288 :: r910 in - let r912 = Sub (r908) :: r911 in - let r913 = S (T T_LIDENT) :: r912 in - let r914 = R 194 :: r913 in - let r915 = R 808 :: r914 in - let r916 = R 282 :: r915 in - let r917 = [R 89] in - let r918 = S (T T_END) :: r917 in - let r919 = R 299 :: r918 in - let r920 = R 69 :: r919 in - let r921 = [R 803] in - let r922 = Sub (r1) :: r921 in - let r923 = S (T T_EQUAL) :: r922 in - let r924 = S (T T_LIDENT) :: r923 in - let r925 = R 382 :: r924 in - let r926 = R 282 :: r925 in - let r927 = [R 55] in - let r928 = R 288 :: r927 in - let r929 = [R 804] in - let r930 = Sub (r1) :: r929 in - let r931 = S (T T_EQUAL) :: r930 in - let r932 = S (T T_LIDENT) :: r931 in - let r933 = R 382 :: r932 in - let r934 = [R 806] in - let r935 = Sub (r1) :: r934 in - let r936 = [R 802] in - let r937 = Sub (r87) :: r936 in - let r938 = S (T T_COLON) :: r937 in - let r939 = [R 805] in - let r940 = Sub (r1) :: r939 in - let r941 = [R 326] in - let r942 = Sub (r382) :: r941 in - let r943 = S (T T_LIDENT) :: r942 in - let r944 = R 517 :: r943 in - let r945 = R 282 :: r944 in - let r946 = [R 56] in - let r947 = R 288 :: r946 in - let r948 = [R 327] in - let r949 = Sub (r382) :: r948 in - let r950 = S (T T_LIDENT) :: r949 in - let r951 = R 517 :: r950 in - let r952 = [R 329] in - let r953 = Sub (r1) :: r952 in - let r954 = S (T T_EQUAL) :: r953 in - let r955 = [R 331] in - let r956 = Sub (r1) :: r955 in - let r957 = S (T T_EQUAL) :: r956 in - let r958 = Sub (r87) :: r957 in - let r959 = S (T T_DOT) :: r958 in - let r960 = [R 736] in - let r961 = [R 197] in - let r962 = Sub (r1) :: r961 in - let r963 = [R 325] in - let r964 = Sub (r89) :: r963 in - let r965 = S (T T_COLON) :: r964 in - let r966 = [R 328] in - let r967 = Sub (r1) :: r966 in - let r968 = S (T T_EQUAL) :: r967 in - let r969 = [R 330] in - let r970 = Sub (r1) :: r969 in - let r971 = S (T T_EQUAL) :: r970 in - let r972 = Sub (r87) :: r971 in - let r973 = S (T T_DOT) :: r972 in - let r974 = [R 58] in - let r975 = R 288 :: r974 in - let r976 = Sub (r1) :: r975 in - let r977 = [R 53] in - let r978 = R 288 :: r977 in - let r979 = R 449 :: r978 in - let r980 = Sub (r905) :: r979 in - let r981 = [R 54] in - let r982 = R 288 :: r981 in - let r983 = R 449 :: r982 in - let r984 = Sub (r905) :: r983 in - let r985 = [R 85] in - let r986 = S (T T_RPAREN) :: r985 in - let r987 = [R 48] in - let r988 = Sub (r905) :: r987 in - let r989 = S (T T_IN) :: r988 in - let r990 = Sub (r781) :: r989 in - let r991 = R 282 :: r990 in - let r992 = [R 262] in - let r993 = R 288 :: r992 in - let r994 = Sub (r236) :: r993 in - let r995 = R 524 :: r994 in - let r996 = R 282 :: r995 in - let r997 = [R 49] in - let r998 = Sub (r905) :: r997 in - let r999 = S (T T_IN) :: r998 in - let r1000 = Sub (r781) :: r999 in - let r1001 = [R 87] in - let r1002 = Sub (r212) :: r1001 in - let r1003 = S (T T_RBRACKET) :: r1002 in - let r1004 = [R 64] in - let r1005 = Sub (r905) :: r1004 in - let r1006 = S (T T_MINUSGREATER) :: r1005 in - let r1007 = Sub (r493) :: r1006 in - let r1008 = [R 46] in - let r1009 = Sub (r1007) :: r1008 in - let r1010 = [R 47] in - let r1011 = Sub (r905) :: r1010 in - let r1012 = [R 238] in - let r1013 = [R 261] in - let r1014 = R 288 :: r1013 in - let r1015 = Sub (r236) :: r1014 in - let r1016 = [R 88] in - let r1017 = S (T T_RPAREN) :: r1016 in - let r1018 = [R 450] in - let r1019 = [R 57] in - let r1020 = R 288 :: r1019 in - let r1021 = Sub (r854) :: r1020 in - let r1022 = [R 59] in - let r1023 = [R 300] in - let r1024 = [R 62] in - let r1025 = Sub (r905) :: r1024 in - let r1026 = S (T T_EQUAL) :: r1025 in - let r1027 = [R 63] in - let r1028 = [R 273] in - let r1029 = R 272 :: r1028 in - let r1030 = R 288 :: r1029 in - let r1031 = Sub (r908) :: r1030 in - let r1032 = S (T T_LIDENT) :: r1031 in - let r1033 = R 194 :: r1032 in - let r1034 = R 808 :: r1033 in - let r1035 = [R 296] in - let r1036 = [R 742] in - let r1037 = [R 746] in - let r1038 = [R 739] in - let r1039 = R 293 :: r1038 in - let r1040 = [R 625] in - let r1041 = S (T T_RBRACKET) :: r1040 in - let r1042 = Sub (r1) :: r1041 in - let r1043 = [R 624] in - let r1044 = S (T T_RBRACE) :: r1043 in - let r1045 = Sub (r1) :: r1044 in - let r1046 = [R 627] in - let r1047 = S (T T_RPAREN) :: r1046 in - let r1048 = Sub (r456) :: r1047 in - let r1049 = S (T T_LPAREN) :: r1048 in - let r1050 = [R 631] in - let r1051 = S (T T_RBRACKET) :: r1050 in - let r1052 = Sub (r456) :: r1051 in - let r1053 = [R 629] in - let r1054 = S (T T_RBRACE) :: r1053 in - let r1055 = Sub (r456) :: r1054 in - let r1056 = [R 180] in - let r1057 = [R 630] in - let r1058 = S (T T_RBRACKET) :: r1057 in - let r1059 = Sub (r456) :: r1058 in - let r1060 = [R 184] in - let r1061 = [R 628] in - let r1062 = S (T T_RBRACE) :: r1061 in - let r1063 = Sub (r456) :: r1062 in - let r1064 = [R 182] in - let r1065 = [R 177] in - let r1066 = [R 179] in - let r1067 = [R 178] in - let r1068 = [R 181] in - let r1069 = [R 185] in - let r1070 = [R 183] in - let r1071 = [R 176] in - let r1072 = [R 269] in - let r1073 = Sub (r1) :: r1072 in - let r1074 = [R 271] in - let r1075 = [R 647] in - let r1076 = [R 659] in - let r1077 = [R 658] in - let r1078 = [R 662] in - let r1079 = [R 661] in - let r1080 = S (T T_LIDENT) :: r461 in - let r1081 = [R 648] in - let r1082 = S (T T_GREATERRBRACE) :: r1081 in - let r1083 = [R 655] in - let r1084 = S (T T_RBRACE) :: r1083 in - let r1085 = [R 527] in - let r1086 = Sub (r466) :: r1085 in - let r1087 = [R 128] in - let r1088 = S (T T_DONE) :: r1087 in - let r1089 = Sub (r1) :: r1088 in - let r1090 = S (T T_DO) :: r1089 in + let r855 = S (T T_EQUAL) :: r854 in + let r856 = Sub (r87) :: r855 in + let r857 = [R 75] in + let r858 = R 288 :: r857 in + let r859 = Sub (r856) :: r858 in + let r860 = [R 76] in + let r861 = [R 298] in + let r862 = [R 277] in + let r863 = R 276 :: r862 in + let r864 = R 288 :: r863 in + let r865 = Sub (r793) :: r864 in + let r866 = S (T T_EQUAL) :: r865 in + let r867 = S (T T_LIDENT) :: r866 in + let r868 = R 194 :: r867 in + let r869 = R 809 :: r868 in + let r870 = [R 92] in + let r871 = Sub (r795) :: r870 in + let r872 = S (T T_MINUSGREATER) :: r871 in + let r873 = Sub (r81) :: r872 in + let r874 = [R 93] in + let r875 = Sub (r795) :: r874 in + let r876 = [R 91] in + let r877 = Sub (r795) :: r876 in + let r878 = S (T T_MINUSGREATER) :: r877 in + let r879 = [R 275] in + let r880 = R 274 :: r879 in + let r881 = R 288 :: r880 in + let r882 = Sub (r795) :: r881 in + let r883 = S (T T_COLON) :: r882 in + let r884 = S (T T_LIDENT) :: r883 in + let r885 = R 194 :: r884 in + let r886 = R 809 :: r885 in + let r887 = [R 292] in + let r888 = [R 592] in + let r889 = [R 596] in + let r890 = [R 285] in + let r891 = R 284 :: r890 in + let r892 = R 288 :: r891 in + let r893 = R 541 :: r892 in + let r894 = R 778 :: r893 in + let r895 = S (T T_LIDENT) :: r894 in + let r896 = R 782 :: r895 in + let r897 = [R 597] in + let r898 = [R 287] in + let r899 = R 286 :: r898 in + let r900 = R 288 :: r899 in + let r901 = R 541 :: r900 in + let r902 = Sub (r177) :: r901 in + let r903 = S (T T_COLONEQUAL) :: r902 in + let r904 = S (T T_LIDENT) :: r903 in + let r905 = R 782 :: r904 in + let r906 = [R 52] in + let r907 = Sub (r791) :: r906 in + let r908 = [R 61] in + let r909 = Sub (r907) :: r908 in + let r910 = S (T T_EQUAL) :: r909 in + let r911 = [R 755] in + let r912 = R 272 :: r911 in + let r913 = R 288 :: r912 in + let r914 = Sub (r910) :: r913 in + let r915 = S (T T_LIDENT) :: r914 in + let r916 = R 194 :: r915 in + let r917 = R 809 :: r916 in + let r918 = R 282 :: r917 in + let r919 = [R 89] in + let r920 = S (T T_END) :: r919 in + let r921 = R 299 :: r920 in + let r922 = R 69 :: r921 in + let r923 = [R 804] in + let r924 = Sub (r1) :: r923 in + let r925 = S (T T_EQUAL) :: r924 in + let r926 = S (T T_LIDENT) :: r925 in + let r927 = R 383 :: r926 in + let r928 = R 282 :: r927 in + let r929 = [R 55] in + let r930 = R 288 :: r929 in + let r931 = [R 805] in + let r932 = Sub (r1) :: r931 in + let r933 = S (T T_EQUAL) :: r932 in + let r934 = S (T T_LIDENT) :: r933 in + let r935 = R 383 :: r934 in + let r936 = [R 807] in + let r937 = Sub (r1) :: r936 in + let r938 = [R 803] in + let r939 = Sub (r87) :: r938 in + let r940 = S (T T_COLON) :: r939 in + let r941 = [R 806] in + let r942 = Sub (r1) :: r941 in + let r943 = [R 326] in + let r944 = Sub (r382) :: r943 in + let r945 = S (T T_LIDENT) :: r944 in + let r946 = R 518 :: r945 in + let r947 = R 282 :: r946 in + let r948 = [R 56] in + let r949 = R 288 :: r948 in + let r950 = [R 327] in + let r951 = Sub (r382) :: r950 in + let r952 = S (T T_LIDENT) :: r951 in + let r953 = R 518 :: r952 in + let r954 = [R 329] in + let r955 = Sub (r1) :: r954 in + let r956 = S (T T_EQUAL) :: r955 in + let r957 = [R 331] in + let r958 = Sub (r1) :: r957 in + let r959 = S (T T_EQUAL) :: r958 in + let r960 = Sub (r87) :: r959 in + let r961 = S (T T_DOT) :: r960 in + let r962 = [R 737] in + let r963 = [R 197] in + let r964 = Sub (r1) :: r963 in + let r965 = [R 325] in + let r966 = Sub (r89) :: r965 in + let r967 = S (T T_COLON) :: r966 in + let r968 = [R 328] in + let r969 = Sub (r1) :: r968 in + let r970 = S (T T_EQUAL) :: r969 in + let r971 = [R 330] in + let r972 = Sub (r1) :: r971 in + let r973 = S (T T_EQUAL) :: r972 in + let r974 = Sub (r87) :: r973 in + let r975 = S (T T_DOT) :: r974 in + let r976 = [R 58] in + let r977 = R 288 :: r976 in + let r978 = Sub (r1) :: r977 in + let r979 = [R 53] in + let r980 = R 288 :: r979 in + let r981 = R 450 :: r980 in + let r982 = Sub (r907) :: r981 in + let r983 = [R 54] in + let r984 = R 288 :: r983 in + let r985 = R 450 :: r984 in + let r986 = Sub (r907) :: r985 in + let r987 = [R 85] in + let r988 = S (T T_RPAREN) :: r987 in + let r989 = [R 48] in + let r990 = Sub (r907) :: r989 in + let r991 = S (T T_IN) :: r990 in + let r992 = Sub (r783) :: r991 in + let r993 = R 282 :: r992 in + let r994 = [R 262] in + let r995 = R 288 :: r994 in + let r996 = Sub (r236) :: r995 in + let r997 = R 525 :: r996 in + let r998 = R 282 :: r997 in + let r999 = [R 49] in + let r1000 = Sub (r907) :: r999 in + let r1001 = S (T T_IN) :: r1000 in + let r1002 = Sub (r783) :: r1001 in + let r1003 = [R 87] in + let r1004 = Sub (r212) :: r1003 in + let r1005 = S (T T_RBRACKET) :: r1004 in + let r1006 = [R 64] in + let r1007 = Sub (r907) :: r1006 in + let r1008 = S (T T_MINUSGREATER) :: r1007 in + let r1009 = Sub (r495) :: r1008 in + let r1010 = [R 46] in + let r1011 = Sub (r1009) :: r1010 in + let r1012 = [R 47] in + let r1013 = Sub (r907) :: r1012 in + let r1014 = [R 238] in + let r1015 = [R 261] in + let r1016 = R 288 :: r1015 in + let r1017 = Sub (r236) :: r1016 in + let r1018 = [R 88] in + let r1019 = S (T T_RPAREN) :: r1018 in + let r1020 = [R 451] in + let r1021 = [R 57] in + let r1022 = R 288 :: r1021 in + let r1023 = Sub (r856) :: r1022 in + let r1024 = [R 59] in + let r1025 = [R 300] in + let r1026 = [R 62] in + let r1027 = Sub (r907) :: r1026 in + let r1028 = S (T T_EQUAL) :: r1027 in + let r1029 = [R 63] in + let r1030 = [R 273] in + let r1031 = R 272 :: r1030 in + let r1032 = R 288 :: r1031 in + let r1033 = Sub (r910) :: r1032 in + let r1034 = S (T T_LIDENT) :: r1033 in + let r1035 = R 194 :: r1034 in + let r1036 = R 809 :: r1035 in + let r1037 = [R 296] in + let r1038 = [R 743] in + let r1039 = [R 747] in + let r1040 = [R 740] in + let r1041 = R 293 :: r1040 in + let r1042 = [R 626] in + let r1043 = S (T T_RBRACKET) :: r1042 in + let r1044 = Sub (r1) :: r1043 in + let r1045 = [R 625] in + let r1046 = S (T T_RBRACE) :: r1045 in + let r1047 = Sub (r1) :: r1046 in + let r1048 = [R 628] in + let r1049 = S (T T_RPAREN) :: r1048 in + let r1050 = Sub (r458) :: r1049 in + let r1051 = S (T T_LPAREN) :: r1050 in + let r1052 = [R 632] in + let r1053 = S (T T_RBRACKET) :: r1052 in + let r1054 = Sub (r458) :: r1053 in + let r1055 = [R 630] in + let r1056 = S (T T_RBRACE) :: r1055 in + let r1057 = Sub (r458) :: r1056 in + let r1058 = [R 180] in + let r1059 = [R 631] in + let r1060 = S (T T_RBRACKET) :: r1059 in + let r1061 = Sub (r458) :: r1060 in + let r1062 = [R 184] in + let r1063 = [R 629] in + let r1064 = S (T T_RBRACE) :: r1063 in + let r1065 = Sub (r458) :: r1064 in + let r1066 = [R 182] in + let r1067 = [R 177] in + let r1068 = [R 179] in + let r1069 = [R 178] in + let r1070 = [R 181] in + let r1071 = [R 185] in + let r1072 = [R 183] in + let r1073 = [R 176] in + let r1074 = [R 269] in + let r1075 = Sub (r1) :: r1074 in + let r1076 = [R 271] in + let r1077 = [R 648] in + let r1078 = [R 660] in + let r1079 = [R 659] in + let r1080 = [R 663] in + let r1081 = [R 662] in + let r1082 = S (T T_LIDENT) :: r463 in + let r1083 = [R 649] in + let r1084 = S (T T_GREATERRBRACE) :: r1083 in + let r1085 = [R 656] in + let r1086 = S (T T_RBRACE) :: r1085 in + let r1087 = [R 528] in + let r1088 = Sub (r468) :: r1087 in + let r1089 = [R 128] in + let r1090 = S (T T_DONE) :: r1089 in let r1091 = Sub (r1) :: r1090 in - let r1092 = Sub (r513) :: r1091 in - let r1093 = [R 201] in - let r1094 = Sub (r496) :: r1093 in - let r1095 = S (T T_RPAREN) :: r1094 in - let r1096 = [R 199] in - let r1097 = Sub (r1) :: r1096 in - let r1098 = S (T T_MINUSGREATER) :: r1097 in - let r1099 = [R 200] in - let r1100 = [R 552] in - let r1101 = [R 140] in - let r1102 = [R 632] in - let r1103 = [R 644] in - let r1104 = [R 131] in - let r1105 = Sub (r1) :: r1104 in - let r1106 = S (T T_IN) :: r1105 in - let r1107 = Sub (r613) :: r1106 in - let r1108 = Sub (r63) :: r1107 in - let r1109 = R 282 :: r1108 in - let r1110 = [R 132] in - let r1111 = Sub (r1) :: r1110 in - let r1112 = S (T T_IN) :: r1111 in - let r1113 = R 282 :: r1112 in - let r1114 = R 209 :: r1113 in - let r1115 = Sub (r130) :: r1114 in - let r1116 = R 282 :: r1115 in - let r1117 = [R 256] in - let r1118 = Sub (r1) :: r1117 in - let r1119 = S (T T_EQUAL) :: r1118 in - let r1120 = Sub (r87) :: r1119 in - let r1121 = S (T T_DOT) :: r1120 in - let r1122 = [R 255] in - let r1123 = Sub (r1) :: r1122 in - let r1124 = S (T T_EQUAL) :: r1123 in - let r1125 = Sub (r87) :: r1124 in - let r1126 = [R 254] in - let r1127 = Sub (r1) :: r1126 in - let r1128 = [R 656] in - let r1129 = [R 635] in - let r1130 = S (T T_RPAREN) :: r1129 in - let r1131 = S (N N_module_expr) :: r1130 in - let r1132 = R 282 :: r1131 in - let r1133 = [R 636] in - let r1134 = S (T T_RPAREN) :: r1133 in - let r1135 = [R 622] in - let r1136 = [R 470] in - let r1137 = S (T T_RPAREN) :: r1136 in - let r1138 = [R 468] in + let r1092 = S (T T_DO) :: r1091 in + let r1093 = Sub (r1) :: r1092 in + let r1094 = Sub (r515) :: r1093 in + let r1095 = [R 201] in + let r1096 = Sub (r498) :: r1095 in + let r1097 = S (T T_RPAREN) :: r1096 in + let r1098 = [R 199] in + let r1099 = Sub (r1) :: r1098 in + let r1100 = S (T T_MINUSGREATER) :: r1099 in + let r1101 = [R 200] in + let r1102 = [R 553] in + let r1103 = [R 140] in + let r1104 = [R 633] in + let r1105 = [R 645] in + let r1106 = [R 131] in + let r1107 = Sub (r1) :: r1106 in + let r1108 = S (T T_IN) :: r1107 in + let r1109 = Sub (r615) :: r1108 in + let r1110 = Sub (r63) :: r1109 in + let r1111 = R 282 :: r1110 in + let r1112 = [R 132] in + let r1113 = Sub (r1) :: r1112 in + let r1114 = S (T T_IN) :: r1113 in + let r1115 = R 282 :: r1114 in + let r1116 = R 209 :: r1115 in + let r1117 = Sub (r130) :: r1116 in + let r1118 = R 282 :: r1117 in + let r1119 = [R 256] in + let r1120 = Sub (r1) :: r1119 in + let r1121 = S (T T_EQUAL) :: r1120 in + let r1122 = Sub (r87) :: r1121 in + let r1123 = S (T T_DOT) :: r1122 in + let r1124 = [R 255] in + let r1125 = Sub (r1) :: r1124 in + let r1126 = S (T T_EQUAL) :: r1125 in + let r1127 = Sub (r87) :: r1126 in + let r1128 = [R 254] in + let r1129 = Sub (r1) :: r1128 in + let r1130 = [R 657] in + let r1131 = [R 636] in + let r1132 = S (T T_RPAREN) :: r1131 in + let r1133 = S (N N_module_expr) :: r1132 in + let r1134 = R 282 :: r1133 in + let r1135 = [R 637] in + let r1136 = S (T T_RPAREN) :: r1135 in + let r1137 = [R 623] in + let r1138 = [R 471] in let r1139 = S (T T_RPAREN) :: r1138 in let r1140 = [R 469] in let r1141 = S (T T_RPAREN) :: r1140 in - let r1142 = [R 295] in - let r1143 = R 293 :: r1142 in - let r1144 = [R 320] in - let r1145 = [R 29] in - let r1146 = [R 28] in - let r1147 = Sub (r126) :: r1146 in - let r1148 = [R 33] in - let r1149 = [R 565] in - let r1150 = [R 22] in + let r1142 = [R 470] in + let r1143 = S (T T_RPAREN) :: r1142 in + let r1144 = [R 295] in + let r1145 = R 293 :: r1144 in + let r1146 = [R 320] in + let r1147 = [R 29] in + let r1148 = [R 28] in + let r1149 = Sub (r126) :: r1148 in + let r1150 = [R 33] in let r1151 = [R 566] in - let r1152 = [R 405] in - let r1153 = S (T T_RBRACE) :: r1152 in - let r1154 = [R 191] in - let r1155 = R 282 :: r1154 in - let r1156 = [R 192] in + let r1152 = [R 22] in + let r1153 = [R 567] in + let r1154 = [R 406] in + let r1155 = S (T T_RBRACE) :: r1154 in + let r1156 = [R 191] in let r1157 = R 282 :: r1156 in - let r1158 = [R 68] in - let r1159 = S (T T_RPAREN) :: r1158 in - let r1160 = [R 124] in - let r1161 = [R 126] in - let r1162 = [R 125] in - let r1163 = [R 223] in - let r1164 = [R 226] in - let r1165 = [R 337] in - let r1166 = [R 340] in - let r1167 = S (T T_RPAREN) :: r1166 in - let r1168 = S (T T_COLONCOLON) :: r1167 in - let r1169 = S (T T_LPAREN) :: r1168 in - let r1170 = [R 471] in - let r1171 = [R 472] in - let r1172 = [R 473] in - let r1173 = [R 474] in - let r1174 = [R 475] in - let r1175 = [R 476] in - let r1176 = [R 477] in - let r1177 = [R 478] in - let r1178 = [R 479] in - let r1179 = [R 480] in - let r1180 = [R 481] in - let r1181 = [R 761] in - let r1182 = [R 770] in - let r1183 = [R 302] in - let r1184 = [R 768] in - let r1185 = S (T T_SEMISEMI) :: r1184 in + let r1158 = [R 192] in + let r1159 = R 282 :: r1158 in + let r1160 = [R 68] in + let r1161 = S (T T_RPAREN) :: r1160 in + let r1162 = [R 124] in + let r1163 = [R 126] in + let r1164 = [R 125] in + let r1165 = [R 223] in + let r1166 = [R 226] in + let r1167 = [R 337] in + let r1168 = [R 340] in + let r1169 = S (T T_RPAREN) :: r1168 in + let r1170 = S (T T_COLONCOLON) :: r1169 in + let r1171 = S (T T_LPAREN) :: r1170 in + let r1172 = [R 472] in + let r1173 = [R 473] in + let r1174 = [R 474] in + let r1175 = [R 475] in + let r1176 = [R 476] in + let r1177 = [R 477] in + let r1178 = [R 478] in + let r1179 = [R 479] in + let r1180 = [R 480] in + let r1181 = [R 481] in + let r1182 = [R 482] in + let r1183 = [R 762] in + let r1184 = [R 771] in + let r1185 = [R 302] in let r1186 = [R 769] in - let r1187 = [R 304] in - let r1188 = [R 307] in - let r1189 = [R 306] in - let r1190 = [R 305] in - let r1191 = R 303 :: r1190 in - let r1192 = [R 797] in - let r1193 = S (T T_EOF) :: r1192 in - let r1194 = R 303 :: r1193 in - let r1195 = [R 796] in + let r1187 = S (T T_SEMISEMI) :: r1186 in + let r1188 = [R 770] in + let r1189 = [R 304] in + let r1190 = [R 307] in + let r1191 = [R 306] in + let r1192 = [R 305] in + let r1193 = R 303 :: r1192 in + let r1194 = [R 798] in + let r1195 = S (T T_EOF) :: r1194 in + let r1196 = R 303 :: r1195 in + let r1197 = [R 797] in function - | 0 | 1760 | 1764 | 1782 | 1786 | 1790 | 1794 | 1798 | 1802 | 1806 | 1810 | 1814 | 1818 | 1824 | 1844 -> Nothing - | 1759 -> One ([R 0]) - | 1763 -> One ([R 1]) - | 1769 -> One ([R 2]) - | 1783 -> One ([R 3]) - | 1787 -> One ([R 4]) - | 1793 -> One ([R 5]) - | 1795 -> One ([R 6]) - | 1799 -> One ([R 7]) - | 1803 -> One ([R 8]) - | 1807 -> One ([R 9]) - | 1811 -> One ([R 10]) - | 1817 -> One ([R 11]) - | 1821 -> One ([R 12]) - | 1834 -> One ([R 13]) - | 1854 -> One ([R 14]) + | 0 | 1763 | 1767 | 1785 | 1789 | 1793 | 1797 | 1801 | 1805 | 1809 | 1813 | 1817 | 1821 | 1827 | 1847 -> Nothing + | 1762 -> One ([R 0]) + | 1766 -> One ([R 1]) + | 1772 -> One ([R 2]) + | 1786 -> One ([R 3]) + | 1790 -> One ([R 4]) + | 1796 -> One ([R 5]) + | 1798 -> One ([R 6]) + | 1802 -> One ([R 7]) + | 1806 -> One ([R 8]) + | 1810 -> One ([R 9]) + | 1814 -> One ([R 10]) + | 1820 -> One ([R 11]) + | 1824 -> One ([R 12]) + | 1837 -> One ([R 13]) + | 1857 -> One ([R 14]) | 214 -> One ([R 15]) | 213 -> One ([R 16]) - | 1777 -> One ([R 20]) - | 1779 -> One ([R 21]) + | 1780 -> One ([R 20]) + | 1782 -> One ([R 21]) | 284 -> One ([R 26]) | 294 -> One ([R 27]) | 290 -> One ([R 41]) - | 1268 -> One ([R 45]) - | 1277 -> One ([R 50]) - | 1272 -> One ([R 51]) - | 1313 -> One ([R 60]) - | 1280 -> One ([R 65]) - | 1064 -> One ([R 77]) - | 1044 -> One ([R 78]) - | 1046 -> One ([R 82]) - | 1275 -> One ([R 86]) + | 1271 -> One ([R 45]) + | 1280 -> One ([R 50]) + | 1275 -> One ([R 51]) + | 1316 -> One ([R 60]) + | 1283 -> One ([R 65]) + | 1067 -> One ([R 77]) + | 1047 -> One ([R 78]) + | 1049 -> One ([R 82]) + | 1278 -> One ([R 86]) | 352 -> One ([R 97]) | 73 -> One ([R 98]) | 350 -> One ([R 99]) | 72 -> One ([R 103]) - | 200 | 810 -> One ([R 104]) - | 842 -> One ([R 107]) - | 876 -> One ([R 115]) - | 880 -> One ([R 116]) + | 200 | 813 -> One ([R 104]) + | 845 -> One ([R 107]) + | 879 -> One ([R 115]) + | 883 -> One ([R 116]) | 324 -> One ([R 118]) - | 1498 -> One ([R 119]) - | 622 -> One ([R 130]) - | 1446 -> One ([R 146]) - | 645 -> One ([R 147]) - | 667 -> One ([R 148]) - | 648 -> One ([R 149]) - | 665 -> One ([R 186]) + | 1501 -> One ([R 119]) + | 625 -> One ([R 130]) + | 1449 -> One ([R 146]) + | 648 -> One ([R 147]) + | 670 -> One ([R 148]) + | 651 -> One ([R 149]) + | 668 -> One ([R 186]) | 1 -> One (R 187 :: r7) | 61 -> One (R 187 :: r24) | 66 -> One (R 187 :: r29) @@ -1755,548 +1757,549 @@ let recover = | 344 -> One (R 187 :: r319) | 367 -> One (R 187 :: r332) | 464 -> One (R 187 :: r406) - | 555 -> One (R 187 :: r476) - | 558 -> One (R 187 :: r479) - | 561 -> One (R 187 :: r484) - | 564 -> One (R 187 :: r487) - | 570 -> One (R 187 :: r500) - | 578 -> One (R 187 :: r511) - | 583 -> One (R 187 :: r523) - | 599 -> One (R 187 :: r534) - | 613 -> One (R 187 :: r540) - | 746 -> One (R 187 :: r618) - | 785 -> One (R 187 :: r649) - | 790 -> One (R 187 :: r659) - | 932 -> One (R 187 :: r748) - | 933 -> One (R 187 :: r752) - | 942 -> One (R 187 :: r760) - | 979 -> One (R 187 :: r788) - | 988 -> One (R 187 :: r802) - | 989 -> One (R 187 :: r811) - | 1152 -> One (R 187 :: r916) - | 1571 -> One (R 187 :: r1109) - | 1578 -> One (R 187 :: r1116) - | 1616 -> One (R 187 :: r1132) - | 476 -> One ([R 208]) + | 558 -> One (R 187 :: r478) + | 561 -> One (R 187 :: r481) + | 564 -> One (R 187 :: r486) + | 567 -> One (R 187 :: r489) + | 573 -> One (R 187 :: r502) + | 581 -> One (R 187 :: r513) + | 586 -> One (R 187 :: r525) + | 602 -> One (R 187 :: r536) + | 616 -> One (R 187 :: r542) + | 749 -> One (R 187 :: r620) + | 788 -> One (R 187 :: r651) + | 793 -> One (R 187 :: r661) + | 935 -> One (R 187 :: r750) + | 936 -> One (R 187 :: r754) + | 945 -> One (R 187 :: r762) + | 982 -> One (R 187 :: r790) + | 991 -> One (R 187 :: r804) + | 992 -> One (R 187 :: r813) + | 1155 -> One (R 187 :: r918) + | 1574 -> One (R 187 :: r1111) + | 1581 -> One (R 187 :: r1118) + | 1619 -> One (R 187 :: r1134) + | 478 -> One ([R 208]) | 153 -> One ([R 221]) | 131 -> One (R 224 :: r101) | 135 -> One (R 224 :: r103) | 212 -> One ([R 228]) - | 832 -> One ([R 232]) - | 833 -> One ([R 233]) - | 1271 -> One ([R 237]) - | 738 -> One ([R 251]) - | 1608 -> One ([R 253]) - | 1351 -> One ([R 260]) - | 1278 -> One ([R 263]) + | 835 -> One ([R 232]) + | 836 -> One ([R 233]) + | 1274 -> One ([R 237]) + | 741 -> One ([R 251]) + | 1611 -> One ([R 253]) + | 1354 -> One ([R 260]) + | 1281 -> One ([R 263]) | 447 -> One ([R 264]) - | 1588 -> One ([R 266]) + | 1591 -> One ([R 266]) | 105 -> One (R 282 :: r75) | 171 -> One (R 282 :: r122) | 220 -> One (R 282 :: r208) | 233 -> One (R 282 :: r220) | 467 -> One (R 282 :: r410) - | 474 -> One (R 282 :: r420) - | 715 -> One (R 282 :: r595) - | 769 -> One (R 282 :: r638) - | 961 -> One (R 282 :: r779) - | 1000 -> One (R 282 :: r817) - | 1006 -> One (R 282 :: r825) - | 1017 -> One (R 282 :: r831) - | 1028 -> One (R 282 :: r834) - | 1032 -> One (R 282 :: r843) - | 1053 -> One (R 282 :: r857) - | 1069 -> One (R 282 :: r867) - | 1104 -> One (R 282 :: r884) - | 1126 -> One (R 282 :: r894) - | 1136 -> One (R 282 :: r903) - | 1159 -> One (R 282 :: r920) - | 1163 -> One (R 282 :: r933) - | 1191 -> One (R 282 :: r951) - | 1237 -> One (R 282 :: r976) - | 1241 -> One (R 282 :: r980) - | 1242 -> One (R 282 :: r984) - | 1253 -> One (R 282 :: r1000) - | 1261 -> One (R 282 :: r1009) - | 1305 -> One (R 282 :: r1021) - | 1325 -> One (R 282 :: r1034) - | 1659 -> One (R 282 :: r1144) - | 1125 -> One (R 284 :: r887) - | 1354 -> One (R 284 :: r1037) - | 1135 -> One (R 286 :: r895) - | 754 -> One (R 288 :: r626) - | 1062 -> One (R 288 :: r858) - | 1123 -> One (R 288 :: r886) - | 1311 -> One (R 288 :: r1022) - | 1352 -> One (R 288 :: r1036) - | 1359 -> One (R 288 :: r1039) - | 1651 -> One (R 288 :: r1143) - | 1839 -> One (R 288 :: r1185) - | 1850 -> One (R 288 :: r1191) - | 1855 -> One (R 288 :: r1194) - | 931 -> One (R 290 :: r744) - | 1115 -> One (R 290 :: r885) + | 476 -> One (R 282 :: r422) + | 718 -> One (R 282 :: r597) + | 772 -> One (R 282 :: r640) + | 964 -> One (R 282 :: r781) + | 1003 -> One (R 282 :: r819) + | 1009 -> One (R 282 :: r827) + | 1020 -> One (R 282 :: r833) + | 1031 -> One (R 282 :: r836) + | 1035 -> One (R 282 :: r845) + | 1056 -> One (R 282 :: r859) + | 1072 -> One (R 282 :: r869) + | 1107 -> One (R 282 :: r886) + | 1129 -> One (R 282 :: r896) + | 1139 -> One (R 282 :: r905) + | 1162 -> One (R 282 :: r922) + | 1166 -> One (R 282 :: r935) + | 1194 -> One (R 282 :: r953) + | 1240 -> One (R 282 :: r978) + | 1244 -> One (R 282 :: r982) + | 1245 -> One (R 282 :: r986) + | 1256 -> One (R 282 :: r1002) + | 1264 -> One (R 282 :: r1011) + | 1308 -> One (R 282 :: r1023) + | 1328 -> One (R 282 :: r1036) + | 1662 -> One (R 282 :: r1146) + | 1128 -> One (R 284 :: r889) + | 1357 -> One (R 284 :: r1039) + | 1138 -> One (R 286 :: r897) + | 757 -> One (R 288 :: r628) + | 1065 -> One (R 288 :: r860) + | 1126 -> One (R 288 :: r888) + | 1314 -> One (R 288 :: r1024) + | 1355 -> One (R 288 :: r1038) + | 1362 -> One (R 288 :: r1041) + | 1654 -> One (R 288 :: r1145) + | 1842 -> One (R 288 :: r1187) + | 1853 -> One (R 288 :: r1193) + | 1858 -> One (R 288 :: r1196) + | 934 -> One (R 290 :: r746) + | 1118 -> One (R 290 :: r887) | 211 -> One (R 293 :: r195) - | 1335 -> One (R 293 :: r1035) - | 1065 -> One (R 297 :: r859) - | 1314 -> One (R 299 :: r1023) - | 1837 -> One (R 301 :: r1183) - | 1845 -> One (R 303 :: r1187) - | 1846 -> One (R 303 :: r1188) - | 1847 -> One (R 303 :: r1189) + | 1338 -> One (R 293 :: r1037) + | 1068 -> One (R 297 :: r861) + | 1317 -> One (R 299 :: r1025) + | 1840 -> One (R 301 :: r1185) + | 1848 -> One (R 303 :: r1189) + | 1849 -> One (R 303 :: r1190) + | 1850 -> One (R 303 :: r1191) | 421 -> One ([R 309]) | 425 -> One ([R 311]) - | 656 -> One ([R 313]) - | 1348 -> One ([R 314]) - | 1535 -> One ([R 317]) - | 1662 -> One ([R 318]) - | 1665 -> One ([R 319]) - | 1664 -> One ([R 321]) - | 1663 -> One ([R 323]) - | 1661 -> One ([R 324]) - | 1778 -> One ([R 336]) - | 1768 -> One ([R 338]) - | 1776 -> One ([R 339]) - | 1775 -> One ([R 341]) - | 590 -> One ([R 348]) - | 1496 -> One ([R 349]) - | 532 -> One ([R 360]) - | 542 -> One ([R 361]) - | 543 -> One ([R 362]) - | 541 -> One ([R 363]) - | 544 -> One ([R 365]) + | 659 -> One ([R 313]) + | 1351 -> One ([R 314]) + | 1538 -> One ([R 317]) + | 1665 -> One ([R 318]) + | 1668 -> One ([R 319]) + | 1667 -> One ([R 321]) + | 1666 -> One ([R 323]) + | 1664 -> One ([R 324]) + | 1781 -> One ([R 336]) + | 1771 -> One ([R 338]) + | 1779 -> One ([R 339]) + | 1778 -> One ([R 341]) + | 593 -> One ([R 348]) + | 1499 -> One ([R 349]) + | 535 -> One ([R 360]) + | 545 -> One ([R 361]) + | 546 -> One ([R 362]) + | 544 -> One ([R 363]) + | 547 -> One ([R 365]) | 170 -> One ([R 366]) - | 100 | 952 -> One ([R 367]) - | 503 -> One ([R 374]) - | 480 -> One ([R 375]) - | 510 -> One ([R 378]) - | 818 | 1177 -> One ([R 383]) - | 1010 -> One ([R 385]) - | 1008 -> One ([R 386]) + | 100 | 955 -> One ([R 367]) + | 505 -> One ([R 374]) + | 482 -> One ([R 375]) + | 512 -> One ([R 379]) + | 821 | 1180 -> One ([R 384]) + | 1013 -> One ([R 386]) | 1011 -> One ([R 387]) - | 1009 -> One ([R 388]) - | 385 -> One ([R 391]) - | 803 -> One ([R 393]) - | 888 -> One ([R 394]) - | 1687 -> One ([R 395]) - | 904 -> One ([R 396]) - | 1688 -> One ([R 397]) - | 903 -> One ([R 398]) - | 895 -> One ([R 399]) - | 90 | 244 -> One ([R 412]) - | 114 | 608 -> One ([R 413]) - | 142 -> One ([R 414]) - | 130 -> One ([R 416]) - | 134 -> One ([R 418]) - | 138 -> One ([R 420]) - | 121 -> One ([R 421]) - | 141 | 1466 -> One ([R 422]) - | 120 -> One ([R 423]) - | 119 -> One ([R 424]) - | 118 -> One ([R 425]) - | 117 -> One ([R 426]) - | 116 -> One ([R 427]) - | 93 | 111 | 598 -> One ([R 428]) - | 92 | 597 -> One ([R 429]) - | 91 -> One ([R 430]) - | 113 | 391 | 607 -> One ([R 431]) - | 112 | 606 -> One ([R 432]) - | 88 -> One ([R 433]) - | 94 -> One ([R 434]) - | 123 -> One ([R 435]) - | 115 -> One ([R 436]) - | 122 -> One ([R 437]) - | 95 -> One ([R 438]) - | 140 -> One ([R 439]) - | 143 -> One ([R 440]) - | 139 -> One ([R 442]) - | 311 -> One ([R 443]) - | 310 -> One (R 444 :: r302) - | 262 -> One (R 445 :: r263) - | 263 -> One ([R 446]) - | 422 -> One (R 447 :: r353) - | 423 -> One ([R 448]) - | 1485 -> One ([R 462]) - | 159 -> One ([R 463]) - | 377 -> One ([R 483]) - | 371 -> One ([R 484]) - | 372 -> One ([R 486]) - | 370 | 609 -> One ([R 493]) - | 733 -> One ([R 499]) - | 734 -> One ([R 500]) - | 735 -> One ([R 502]) - | 453 -> One ([R 504]) - | 1151 -> One ([R 508]) - | 910 | 1218 -> One ([R 518]) - | 1021 -> One ([R 520]) - | 1019 -> One ([R 521]) + | 1014 -> One ([R 388]) + | 1012 -> One ([R 389]) + | 385 -> One ([R 392]) + | 806 -> One ([R 394]) + | 891 -> One ([R 395]) + | 1690 -> One ([R 396]) + | 907 -> One ([R 397]) + | 1691 -> One ([R 398]) + | 906 -> One ([R 399]) + | 898 -> One ([R 400]) + | 90 | 244 -> One ([R 413]) + | 114 | 611 -> One ([R 414]) + | 142 -> One ([R 415]) + | 130 -> One ([R 417]) + | 134 -> One ([R 419]) + | 138 -> One ([R 421]) + | 121 -> One ([R 422]) + | 141 | 1469 -> One ([R 423]) + | 120 -> One ([R 424]) + | 119 -> One ([R 425]) + | 118 -> One ([R 426]) + | 117 -> One ([R 427]) + | 116 -> One ([R 428]) + | 93 | 111 | 601 -> One ([R 429]) + | 92 | 600 -> One ([R 430]) + | 91 -> One ([R 431]) + | 113 | 391 | 610 -> One ([R 432]) + | 112 | 609 -> One ([R 433]) + | 88 -> One ([R 434]) + | 94 -> One ([R 435]) + | 123 -> One ([R 436]) + | 115 -> One ([R 437]) + | 122 -> One ([R 438]) + | 95 -> One ([R 439]) + | 140 -> One ([R 440]) + | 143 -> One ([R 441]) + | 139 -> One ([R 443]) + | 311 -> One ([R 444]) + | 310 -> One (R 445 :: r302) + | 262 -> One (R 446 :: r263) + | 263 -> One ([R 447]) + | 422 -> One (R 448 :: r353) + | 423 -> One ([R 449]) + | 1488 -> One ([R 463]) + | 159 -> One ([R 464]) + | 377 -> One ([R 484]) + | 371 -> One ([R 485]) + | 372 -> One ([R 487]) + | 370 | 612 -> One ([R 494]) + | 736 -> One ([R 500]) + | 737 -> One ([R 501]) + | 738 -> One ([R 503]) + | 453 -> One ([R 505]) + | 1154 -> One ([R 509]) + | 913 | 1221 -> One ([R 519]) + | 1024 -> One ([R 521]) | 1022 -> One ([R 522]) - | 1020 -> One ([R 523]) - | 1287 -> One (R 524 :: r1015) - | 251 -> One ([R 525]) - | 886 -> One ([R 528]) - | 887 -> One ([R 529]) - | 882 -> One ([R 530]) - | 1704 -> One ([R 532]) - | 1703 -> One ([R 533]) - | 1705 -> One ([R 534]) - | 1700 -> One ([R 535]) - | 1701 -> One ([R 536]) - | 916 -> One ([R 538]) - | 914 -> One ([R 539]) - | 525 -> One ([R 542]) - | 477 -> One ([R 543]) - | 1274 -> One ([R 544]) - | 1273 -> One ([R 545]) - | 339 -> One ([R 547]) - | 303 -> One ([R 571]) - | 1385 -> One ([R 574]) - | 1386 -> One ([R 575]) - | 1558 -> One ([R 577]) - | 1559 -> One ([R 578]) - | 416 -> One ([R 580]) - | 417 -> One ([R 581]) - | 1488 -> One ([R 583]) - | 1489 -> One ([R 584]) - | 670 -> One ([R 586]) - | 674 -> One ([R 587]) - | 1146 -> One ([R 592]) - | 1114 -> One ([R 593]) + | 1025 -> One ([R 523]) + | 1023 -> One ([R 524]) + | 1290 -> One (R 525 :: r1017) + | 251 -> One ([R 526]) + | 889 -> One ([R 529]) + | 890 -> One ([R 530]) + | 885 -> One ([R 531]) + | 1707 -> One ([R 533]) + | 1706 -> One ([R 534]) + | 1708 -> One ([R 535]) + | 1703 -> One ([R 536]) + | 1704 -> One ([R 537]) + | 919 -> One ([R 539]) + | 917 -> One ([R 540]) + | 527 -> One ([R 543]) + | 479 -> One ([R 544]) + | 1277 -> One ([R 545]) + | 1276 -> One ([R 546]) + | 339 -> One ([R 548]) + | 303 -> One ([R 572]) + | 1388 -> One ([R 575]) + | 1389 -> One ([R 576]) + | 1561 -> One ([R 578]) + | 1562 -> One ([R 579]) + | 416 -> One ([R 581]) + | 417 -> One ([R 582]) + | 1491 -> One ([R 584]) + | 1492 -> One ([R 585]) + | 673 -> One ([R 587]) + | 677 -> One ([R 588]) + | 1149 -> One ([R 593]) | 1117 -> One ([R 594]) - | 1116 -> One ([R 599]) - | 1121 -> One ([R 602]) - | 1120 -> One ([R 604]) - | 1119 -> One ([R 605]) - | 1118 -> One ([R 606]) - | 1147 -> One ([R 609]) - | 86 -> One ([R 612]) - | 83 -> One ([R 614]) - | 589 -> One ([R 638]) - | 652 -> One ([R 639]) - | 651 | 666 -> One ([R 640]) - | 592 | 647 -> One ([R 641]) - | 1393 | 1443 -> One ([R 646]) - | 650 -> One ([R 651]) - | 353 -> One ([R 664]) - | 357 -> One ([R 667]) - | 358 -> One ([R 671]) - | 389 -> One ([R 673]) - | 362 -> One ([R 674]) - | 418 -> One ([R 676]) - | 380 -> One ([R 681]) - | 28 -> One ([R 682]) - | 8 -> One ([R 683]) - | 52 -> One ([R 685]) - | 51 -> One ([R 686]) - | 50 -> One ([R 687]) - | 49 -> One ([R 688]) - | 48 -> One ([R 689]) - | 47 -> One ([R 690]) - | 46 -> One ([R 691]) - | 45 -> One ([R 692]) - | 44 -> One ([R 693]) - | 43 -> One ([R 694]) - | 42 -> One ([R 695]) - | 41 -> One ([R 696]) - | 40 -> One ([R 697]) - | 39 -> One ([R 698]) - | 38 -> One ([R 699]) - | 37 -> One ([R 700]) - | 36 -> One ([R 701]) - | 35 -> One ([R 702]) - | 34 -> One ([R 703]) - | 33 -> One ([R 704]) - | 32 -> One ([R 705]) - | 31 -> One ([R 706]) - | 30 -> One ([R 707]) - | 29 -> One ([R 708]) - | 27 -> One ([R 709]) - | 26 -> One ([R 710]) - | 25 -> One ([R 711]) - | 24 -> One ([R 712]) - | 23 -> One ([R 713]) - | 22 -> One ([R 714]) - | 21 -> One ([R 715]) - | 20 -> One ([R 716]) - | 19 -> One ([R 717]) - | 18 -> One ([R 718]) - | 17 -> One ([R 719]) - | 16 -> One ([R 720]) - | 15 -> One ([R 721]) - | 14 -> One ([R 722]) - | 13 -> One ([R 723]) - | 12 -> One ([R 724]) - | 11 -> One ([R 725]) - | 10 -> One ([R 726]) - | 9 -> One ([R 727]) - | 7 -> One ([R 728]) - | 6 -> One ([R 729]) - | 5 -> One ([R 730]) - | 4 -> One ([R 731]) - | 3 -> One ([R 732]) - | 1343 -> One ([R 733]) - | 1365 -> One ([R 738]) - | 1347 | 1364 -> One ([R 740]) - | 1350 | 1366 -> One ([R 741]) - | 1356 -> One ([R 743]) - | 1344 -> One ([R 744]) - | 1334 -> One ([R 745]) - | 1342 -> One ([R 749]) - | 1346 -> One ([R 752]) - | 1345 -> One ([R 753]) - | 1357 -> One ([R 755]) - | 236 -> One ([R 757]) - | 235 -> One ([R 758]) - | 1828 -> One ([R 762]) - | 1829 -> One ([R 763]) - | 1831 -> One ([R 764]) - | 1832 -> One ([R 765]) - | 1830 -> One ([R 766]) - | 1827 -> One ([R 767]) - | 1833 -> One ([R 771]) - | 287 -> One ([R 773]) - | 483 -> One (R 781 :: r437) - | 497 -> One ([R 782]) - | 177 -> One ([R 787]) - | 180 -> One ([R 788]) - | 184 -> One ([R 789]) - | 178 -> One ([R 790]) - | 185 -> One ([R 791]) - | 181 -> One ([R 792]) - | 186 -> One ([R 793]) - | 183 -> One ([R 794]) - | 176 -> One ([R 795]) - | 354 -> One ([R 800]) - | 649 -> One ([R 801]) - | 992 -> One ([R 809]) - | 1175 -> One ([R 810]) + | 1120 -> One ([R 595]) + | 1119 -> One ([R 600]) + | 1124 -> One ([R 603]) + | 1123 -> One ([R 605]) + | 1122 -> One ([R 606]) + | 1121 -> One ([R 607]) + | 1150 -> One ([R 610]) + | 86 -> One ([R 613]) + | 83 -> One ([R 615]) + | 592 -> One ([R 639]) + | 655 -> One ([R 640]) + | 654 | 669 -> One ([R 641]) + | 595 | 650 -> One ([R 642]) + | 1396 | 1446 -> One ([R 647]) + | 653 -> One ([R 652]) + | 353 -> One ([R 665]) + | 357 -> One ([R 668]) + | 358 -> One ([R 672]) + | 389 -> One ([R 674]) + | 362 -> One ([R 675]) + | 418 -> One ([R 677]) + | 380 -> One ([R 682]) + | 28 -> One ([R 683]) + | 8 -> One ([R 684]) + | 52 -> One ([R 686]) + | 51 -> One ([R 687]) + | 50 -> One ([R 688]) + | 49 -> One ([R 689]) + | 48 -> One ([R 690]) + | 47 -> One ([R 691]) + | 46 -> One ([R 692]) + | 45 -> One ([R 693]) + | 44 -> One ([R 694]) + | 43 -> One ([R 695]) + | 42 -> One ([R 696]) + | 41 -> One ([R 697]) + | 40 -> One ([R 698]) + | 39 -> One ([R 699]) + | 38 -> One ([R 700]) + | 37 -> One ([R 701]) + | 36 -> One ([R 702]) + | 35 -> One ([R 703]) + | 34 -> One ([R 704]) + | 33 -> One ([R 705]) + | 32 -> One ([R 706]) + | 31 -> One ([R 707]) + | 30 -> One ([R 708]) + | 29 -> One ([R 709]) + | 27 -> One ([R 710]) + | 26 -> One ([R 711]) + | 25 -> One ([R 712]) + | 24 -> One ([R 713]) + | 23 -> One ([R 714]) + | 22 -> One ([R 715]) + | 21 -> One ([R 716]) + | 20 -> One ([R 717]) + | 19 -> One ([R 718]) + | 18 -> One ([R 719]) + | 17 -> One ([R 720]) + | 16 -> One ([R 721]) + | 15 -> One ([R 722]) + | 14 -> One ([R 723]) + | 13 -> One ([R 724]) + | 12 -> One ([R 725]) + | 11 -> One ([R 726]) + | 10 -> One ([R 727]) + | 9 -> One ([R 728]) + | 7 -> One ([R 729]) + | 6 -> One ([R 730]) + | 5 -> One ([R 731]) + | 4 -> One ([R 732]) + | 3 -> One ([R 733]) + | 1346 -> One ([R 734]) + | 1368 -> One ([R 739]) + | 1350 | 1367 -> One ([R 741]) + | 1353 | 1369 -> One ([R 742]) + | 1359 -> One ([R 744]) + | 1347 -> One ([R 745]) + | 1337 -> One ([R 746]) + | 1345 -> One ([R 750]) + | 1349 -> One ([R 753]) + | 1348 -> One ([R 754]) + | 1360 -> One ([R 756]) + | 236 -> One ([R 758]) + | 235 -> One ([R 759]) + | 1831 -> One ([R 763]) + | 1832 -> One ([R 764]) + | 1834 -> One ([R 765]) + | 1835 -> One ([R 766]) + | 1833 -> One ([R 767]) + | 1830 -> One ([R 768]) + | 1836 -> One ([R 772]) + | 287 -> One ([R 774]) + | 485 -> One (R 782 :: r439) + | 499 -> One ([R 783]) + | 177 -> One ([R 788]) + | 180 -> One ([R 789]) + | 184 -> One ([R 790]) + | 178 -> One ([R 791]) + | 185 -> One ([R 792]) + | 181 -> One ([R 793]) + | 186 -> One ([R 794]) + | 183 -> One ([R 795]) + | 176 -> One ([R 796]) + | 354 -> One ([R 801]) + | 652 -> One ([R 802]) + | 995 -> One ([R 810]) | 1178 -> One ([R 811]) - | 1176 -> One ([R 812]) - | 1216 -> One ([R 813]) + | 1181 -> One ([R 812]) + | 1179 -> One ([R 813]) | 1219 -> One ([R 814]) - | 1217 -> One ([R 815]) - | 486 -> One ([R 822]) - | 487 -> One ([R 823]) - | 1481 -> One (S (T T_WITH) :: r1086) + | 1222 -> One ([R 815]) + | 1220 -> One ([R 816]) + | 488 -> One ([R 823]) + | 489 -> One ([R 824]) + | 1484 -> One (S (T T_WITH) :: r1088) | 166 -> One (S (T T_TYPE) :: r119) | 455 -> One (S (T T_TYPE) :: r388) - | 835 -> One (S (T T_STAR) :: r700) - | 1835 -> One (S (T T_SEMISEMI) :: r1182) - | 1842 -> One (S (T T_SEMISEMI) :: r1186) - | 1765 -> One (S (T T_RPAREN) :: r54) + | 838 -> One (S (T T_STAR) :: r702) + | 1838 -> One (S (T T_SEMISEMI) :: r1184) + | 1845 -> One (S (T T_SEMISEMI) :: r1188) + | 1768 -> One (S (T T_RPAREN) :: r54) | 365 -> One (S (T T_RPAREN) :: r329) | 409 -> One (S (T T_RPAREN) :: r352) | 469 -> One (S (T T_RPAREN) :: r411) - | 534 -> One (S (T T_RPAREN) :: r452) - | 1467 -> One (S (T T_RPAREN) :: r1075) - | 1626 -> One (S (T T_RPAREN) :: r1135) - | 1672 -> One (S (T T_RPAREN) :: r1147) - | 1679 -> One (S (T T_RPAREN) :: r1150) - | 1766 -> One (S (T T_RPAREN) :: r1165) - | 814 | 871 -> One (S (T T_RBRACKET) :: r243) + | 537 -> One (S (T T_RPAREN) :: r454) + | 1470 -> One (S (T T_RPAREN) :: r1077) + | 1629 -> One (S (T T_RPAREN) :: r1137) + | 1675 -> One (S (T T_RPAREN) :: r1149) + | 1682 -> One (S (T T_RPAREN) :: r1152) + | 1769 -> One (S (T T_RPAREN) :: r1167) + | 817 | 874 -> One (S (T T_RBRACKET) :: r243) | 265 -> One (S (T T_RBRACKET) :: r264) - | 1473 -> One (S (T T_RBRACKET) :: r1078) - | 1475 -> One (S (T T_RBRACKET) :: r1079) + | 1476 -> One (S (T T_RBRACKET) :: r1080) + | 1478 -> One (S (T T_RBRACKET) :: r1081) | 317 -> One (S (T T_QUOTE) :: r305) - | 1030 -> One (S (T T_OPEN) :: r839) - | 1245 -> One (S (T T_OPEN) :: r991) + | 1033 -> One (S (T T_OPEN) :: r841) + | 1248 -> One (S (T T_OPEN) :: r993) | 160 -> One (S (T T_MODULE) :: r115) - | 851 -> One (S (T T_MINUSGREATER) :: r706) - | 855 -> One (S (T T_MINUSGREATER) :: r708) - | 1091 -> One (S (T T_MINUSGREATER) :: r873) + | 474 -> One (S (T T_MINUSGREATER) :: r418) + | 854 -> One (S (T T_MINUSGREATER) :: r708) + | 858 -> One (S (T T_MINUSGREATER) :: r710) + | 1094 -> One (S (T T_MINUSGREATER) :: r875) | 124 -> One (S (T T_LPAREN) :: r98) | 156 -> One (S (T T_LIDENT) :: r110) | 430 -> One (S (T T_LIDENT) :: r355) | 438 -> One (S (T T_LIDENT) :: r361) - | 623 -> One (S (T T_LIDENT) :: r547) - | 624 -> One (S (T T_LIDENT) :: r553) - | 635 -> One (S (T T_LIDENT) :: r556) - | 639 -> One (S (T T_LIDENT) :: r558) - | 819 -> One (S (T T_LIDENT) :: r696) - | 1179 -> One (S (T T_LIDENT) :: r938) - | 1220 -> One (S (T T_LIDENT) :: r965) - | 1297 -> One (S (T T_LIDENT) :: r1018) + | 626 -> One (S (T T_LIDENT) :: r549) + | 627 -> One (S (T T_LIDENT) :: r555) + | 638 -> One (S (T T_LIDENT) :: r558) + | 642 -> One (S (T T_LIDENT) :: r560) + | 822 -> One (S (T T_LIDENT) :: r698) + | 1182 -> One (S (T T_LIDENT) :: r940) + | 1223 -> One (S (T T_LIDENT) :: r967) + | 1300 -> One (S (T T_LIDENT) :: r1020) | 81 -> One (S (T T_INT) :: r52) | 84 -> One (S (T T_INT) :: r53) - | 653 -> One (S (T T_IN) :: r565) - | 657 -> One (S (T T_IN) :: r567) - | 1265 -> One (S (T T_IN) :: r1011) - | 548 -> One (S (T T_GREATERRBRACE) :: r459) - | 1561 -> One (S (T T_GREATERRBRACE) :: r1103) + | 656 -> One (S (T T_IN) :: r567) + | 660 -> One (S (T T_IN) :: r569) + | 1268 -> One (S (T T_IN) :: r1013) + | 551 -> One (S (T T_GREATERRBRACE) :: r461) + | 1564 -> One (S (T T_GREATERRBRACE) :: r1105) | 206 -> One (S (T T_GREATER) :: r186) - | 1667 -> One (S (T T_GREATER) :: r1145) - | 515 -> One (S (T T_EQUAL) :: r448) - | 722 -> One (S (T T_EQUAL) :: r600) - | 1169 -> One (S (T T_EQUAL) :: r935) - | 1187 -> One (S (T T_EQUAL) :: r940) - | 1208 -> One (S (T T_EQUAL) :: r962) - | 1457 -> One (S (T T_EQUAL) :: r1073) - | 1605 -> One (S (T T_EQUAL) :: r1127) - | 1757 -> One (S (T T_EOF) :: r1163) - | 1761 -> One (S (T T_EOF) :: r1164) - | 1780 -> One (S (T T_EOF) :: r1170) - | 1784 -> One (S (T T_EOF) :: r1171) - | 1788 -> One (S (T T_EOF) :: r1172) - | 1791 -> One (S (T T_EOF) :: r1173) - | 1796 -> One (S (T T_EOF) :: r1174) - | 1800 -> One (S (T T_EOF) :: r1175) - | 1804 -> One (S (T T_EOF) :: r1176) - | 1808 -> One (S (T T_EOF) :: r1177) - | 1812 -> One (S (T T_EOF) :: r1178) - | 1815 -> One (S (T T_EOF) :: r1179) - | 1819 -> One (S (T T_EOF) :: r1180) - | 1859 -> One (S (T T_EOF) :: r1195) - | 1548 -> One (S (T T_END) :: r1102) + | 1670 -> One (S (T T_GREATER) :: r1147) + | 517 -> One (S (T T_EQUAL) :: r450) + | 725 -> One (S (T T_EQUAL) :: r602) + | 1172 -> One (S (T T_EQUAL) :: r937) + | 1190 -> One (S (T T_EQUAL) :: r942) + | 1211 -> One (S (T T_EQUAL) :: r964) + | 1460 -> One (S (T T_EQUAL) :: r1075) + | 1608 -> One (S (T T_EQUAL) :: r1129) + | 1760 -> One (S (T T_EOF) :: r1165) + | 1764 -> One (S (T T_EOF) :: r1166) + | 1783 -> One (S (T T_EOF) :: r1172) + | 1787 -> One (S (T T_EOF) :: r1173) + | 1791 -> One (S (T T_EOF) :: r1174) + | 1794 -> One (S (T T_EOF) :: r1175) + | 1799 -> One (S (T T_EOF) :: r1176) + | 1803 -> One (S (T T_EOF) :: r1177) + | 1807 -> One (S (T T_EOF) :: r1178) + | 1811 -> One (S (T T_EOF) :: r1179) + | 1815 -> One (S (T T_EOF) :: r1180) + | 1818 -> One (S (T T_EOF) :: r1181) + | 1822 -> One (S (T T_EOF) :: r1182) + | 1862 -> One (S (T T_EOF) :: r1197) + | 1551 -> One (S (T T_END) :: r1104) | 126 -> One (S (T T_DOTDOT) :: r99) | 201 -> One (S (T T_DOTDOT) :: r179) - | 889 -> One (S (T T_DOTDOT) :: r735) - | 890 -> One (S (T T_DOTDOT) :: r736) - | 226 | 1379 | 1426 -> One (S (T T_DOT) :: r217) - | 1822 -> One (S (T T_DOT) :: r449) - | 795 -> One (S (T T_DOT) :: r661) - | 822 -> One (S (T T_DOT) :: r698) - | 849 -> One (S (T T_DOT) :: r704) - | 1600 -> One (S (T T_DOT) :: r1125) - | 1770 -> One (S (T T_DOT) :: r1169) - | 202 | 811 -> One (S (T T_COLONCOLON) :: r181) + | 892 -> One (S (T T_DOTDOT) :: r737) + | 893 -> One (S (T T_DOTDOT) :: r738) + | 226 | 1382 | 1429 -> One (S (T T_DOT) :: r217) + | 1825 -> One (S (T T_DOT) :: r451) + | 798 -> One (S (T T_DOT) :: r663) + | 825 -> One (S (T T_DOT) :: r700) + | 852 -> One (S (T T_DOT) :: r706) + | 1603 -> One (S (T T_DOT) :: r1127) + | 1773 -> One (S (T T_DOT) :: r1171) + | 202 | 814 -> One (S (T T_COLONCOLON) :: r181) | 207 -> One (S (T T_COLON) :: r191) | 471 -> One (S (T T_COLON) :: r414) - | 1085 -> One (S (T T_COLON) :: r871) + | 1088 -> One (S (T T_COLON) :: r873) | 245 -> One (S (T T_BARRBRACKET) :: r233) | 253 -> One (S (T T_BARRBRACKET) :: r242) | 427 -> One (S (T T_BARRBRACKET) :: r354) - | 1469 -> One (S (T T_BARRBRACKET) :: r1076) - | 1471 -> One (S (T T_BARRBRACKET) :: r1077) - | 1613 -> One (S (T T_BARRBRACKET) :: r1128) + | 1472 -> One (S (T T_BARRBRACKET) :: r1078) + | 1474 -> One (S (T T_BARRBRACKET) :: r1079) + | 1616 -> One (S (T T_BARRBRACKET) :: r1130) | 328 -> One (S (T T_BAR) :: r308) | 79 -> One (S (N N_pattern) :: r50) - | 382 | 573 | 1517 -> One (S (N N_pattern) :: r56) + | 382 | 576 | 1520 -> One (S (N N_pattern) :: r56) | 343 -> One (S (N N_pattern) :: r313) | 373 -> One (S (N N_pattern) :: r333) | 375 -> One (S (N N_pattern) :: r334) | 396 -> One (S (N N_pattern) :: r345) | 401 -> One (S (N N_pattern) :: r348) - | 725 -> One (S (N N_pattern) :: r601) - | 727 -> One (S (N N_pattern) :: r602) - | 729 -> One (S (N N_pattern) :: r603) - | 736 -> One (S (N N_pattern) :: r605) - | 742 -> One (S (N N_pattern) :: r609) + | 728 -> One (S (N N_pattern) :: r603) + | 730 -> One (S (N N_pattern) :: r604) + | 732 -> One (S (N N_pattern) :: r605) + | 739 -> One (S (N N_pattern) :: r607) + | 745 -> One (S (N N_pattern) :: r611) | 103 -> One (S (N N_module_type) :: r69) | 473 -> One (S (N N_module_type) :: r416) - | 511 -> One (S (N N_module_type) :: r445) - | 513 -> One (S (N N_module_type) :: r446) - | 538 -> One (S (N N_module_type) :: r454) - | 751 -> One (S (N N_module_type) :: r625) - | 763 -> One (S (N N_module_type) :: r633) - | 1621 -> One (S (N N_module_type) :: r1134) - | 1636 -> One (S (N N_module_type) :: r1137) + | 513 -> One (S (N N_module_type) :: r447) + | 515 -> One (S (N N_module_type) :: r448) + | 541 -> One (S (N N_module_type) :: r456) + | 754 -> One (S (N N_module_type) :: r627) + | 766 -> One (S (N N_module_type) :: r635) + | 1624 -> One (S (N N_module_type) :: r1136) | 1639 -> One (S (N N_module_type) :: r1139) | 1642 -> One (S (N N_module_type) :: r1141) + | 1645 -> One (S (N N_module_type) :: r1143) | 219 -> One (S (N N_module_expr) :: r205) | 446 -> One (S (N N_let_pattern) :: r378) | 247 -> One (S (N N_expr) :: r234) - | 550 -> One (S (N N_expr) :: r462) - | 554 -> One (S (N N_expr) :: r473) - | 621 -> One (S (N N_expr) :: r546) - | 646 -> One (S (N N_expr) :: r563) - | 661 -> One (S (N N_expr) :: r568) - | 663 -> One (S (N N_expr) :: r569) - | 668 -> One (S (N N_expr) :: r570) - | 675 -> One (S (N N_expr) :: r573) - | 677 -> One (S (N N_expr) :: r574) - | 679 -> One (S (N N_expr) :: r575) - | 681 -> One (S (N N_expr) :: r576) - | 683 -> One (S (N N_expr) :: r577) - | 685 -> One (S (N N_expr) :: r578) - | 687 -> One (S (N N_expr) :: r579) - | 689 -> One (S (N N_expr) :: r580) - | 691 -> One (S (N N_expr) :: r581) - | 693 -> One (S (N N_expr) :: r582) - | 695 -> One (S (N N_expr) :: r583) - | 697 -> One (S (N N_expr) :: r584) - | 699 -> One (S (N N_expr) :: r585) - | 701 -> One (S (N N_expr) :: r586) - | 703 -> One (S (N N_expr) :: r587) - | 705 -> One (S (N N_expr) :: r588) - | 707 -> One (S (N N_expr) :: r589) - | 709 -> One (S (N N_expr) :: r590) - | 711 -> One (S (N N_expr) :: r591) - | 713 -> One (S (N N_expr) :: r592) - | 1398 -> One (S (N N_expr) :: r1056) - | 1403 -> One (S (N N_expr) :: r1060) - | 1408 -> One (S (N N_expr) :: r1064) - | 1414 -> One (S (N N_expr) :: r1065) - | 1419 -> One (S (N N_expr) :: r1066) - | 1424 -> One (S (N N_expr) :: r1067) - | 1431 -> One (S (N N_expr) :: r1068) - | 1436 -> One (S (N N_expr) :: r1069) - | 1441 -> One (S (N N_expr) :: r1070) - | 1444 -> One (S (N N_expr) :: r1071) - | 1545 -> One (S (N N_expr) :: r1101) + | 553 -> One (S (N N_expr) :: r464) + | 557 -> One (S (N N_expr) :: r475) + | 624 -> One (S (N N_expr) :: r548) + | 649 -> One (S (N N_expr) :: r565) + | 664 -> One (S (N N_expr) :: r570) + | 666 -> One (S (N N_expr) :: r571) + | 671 -> One (S (N N_expr) :: r572) + | 678 -> One (S (N N_expr) :: r575) + | 680 -> One (S (N N_expr) :: r576) + | 682 -> One (S (N N_expr) :: r577) + | 684 -> One (S (N N_expr) :: r578) + | 686 -> One (S (N N_expr) :: r579) + | 688 -> One (S (N N_expr) :: r580) + | 690 -> One (S (N N_expr) :: r581) + | 692 -> One (S (N N_expr) :: r582) + | 694 -> One (S (N N_expr) :: r583) + | 696 -> One (S (N N_expr) :: r584) + | 698 -> One (S (N N_expr) :: r585) + | 700 -> One (S (N N_expr) :: r586) + | 702 -> One (S (N N_expr) :: r587) + | 704 -> One (S (N N_expr) :: r588) + | 706 -> One (S (N N_expr) :: r589) + | 708 -> One (S (N N_expr) :: r590) + | 710 -> One (S (N N_expr) :: r591) + | 712 -> One (S (N N_expr) :: r592) + | 714 -> One (S (N N_expr) :: r593) + | 716 -> One (S (N N_expr) :: r594) + | 1401 -> One (S (N N_expr) :: r1058) + | 1406 -> One (S (N N_expr) :: r1062) + | 1411 -> One (S (N N_expr) :: r1066) + | 1417 -> One (S (N N_expr) :: r1067) + | 1422 -> One (S (N N_expr) :: r1068) + | 1427 -> One (S (N N_expr) :: r1069) + | 1434 -> One (S (N N_expr) :: r1070) + | 1439 -> One (S (N N_expr) :: r1071) + | 1444 -> One (S (N N_expr) :: r1072) + | 1447 -> One (S (N N_expr) :: r1073) + | 1548 -> One (S (N N_expr) :: r1103) | 441 -> One (Sub (r1) :: r365) - | 569 -> One (Sub (r1) :: r491) - | 744 -> One (Sub (r1) :: r610) - | 1509 -> One (Sub (r1) :: r1092) - | 1742 -> One (Sub (r1) :: r1161) - | 1744 -> One (Sub (r1) :: r1162) + | 572 -> One (Sub (r1) :: r493) + | 747 -> One (Sub (r1) :: r612) + | 1512 -> One (Sub (r1) :: r1094) + | 1745 -> One (Sub (r1) :: r1163) + | 1747 -> One (Sub (r1) :: r1164) | 2 -> One (Sub (r11) :: r12) | 55 -> One (Sub (r11) :: r13) | 59 -> One (Sub (r11) :: r18) | 209 -> One (Sub (r11) :: r194) - | 671 -> One (Sub (r11) :: r572) - | 740 -> One (Sub (r11) :: r608) - | 781 -> One (Sub (r11) :: r642) - | 783 -> One (Sub (r11) :: r645) - | 1246 -> One (Sub (r11) :: r996) - | 567 -> One (Sub (r33) :: r488) - | 1539 -> One (Sub (r33) :: r1100) - | 1740 -> One (Sub (r35) :: r1160) + | 674 -> One (Sub (r11) :: r574) + | 743 -> One (Sub (r11) :: r610) + | 784 -> One (Sub (r11) :: r644) + | 786 -> One (Sub (r11) :: r647) + | 1249 -> One (Sub (r11) :: r998) + | 570 -> One (Sub (r33) :: r490) + | 1542 -> One (Sub (r33) :: r1102) + | 1743 -> One (Sub (r35) :: r1162) | 75 -> One (Sub (r42) :: r43) - | 553 -> One (Sub (r42) :: r471) - | 588 -> One (Sub (r42) :: r524) - | 617 -> One (Sub (r42) :: r541) - | 637 -> One (Sub (r42) :: r557) - | 1269 -> One (Sub (r42) :: r1012) - | 759 -> One (Sub (r63) :: r630) - | 956 -> One (Sub (r63) :: r773) - | 863 -> One (Sub (r72) :: r709) + | 556 -> One (Sub (r42) :: r473) + | 591 -> One (Sub (r42) :: r526) + | 620 -> One (Sub (r42) :: r543) + | 640 -> One (Sub (r42) :: r559) + | 1272 -> One (Sub (r42) :: r1014) + | 762 -> One (Sub (r63) :: r632) + | 959 -> One (Sub (r63) :: r775) + | 866 -> One (Sub (r72) :: r711) | 403 -> One (Sub (r77) :: r349) - | 731 -> One (Sub (r77) :: r604) + | 734 -> One (Sub (r77) :: r606) | 288 -> One (Sub (r79) :: r291) | 300 -> One (Sub (r79) :: r296) - | 848 -> One (Sub (r79) :: r702) - | 1521 -> One (Sub (r79) :: r1098) + | 851 -> One (Sub (r79) :: r704) + | 1524 -> One (Sub (r79) :: r1100) | 295 -> One (Sub (r81) :: r295) - | 1093 -> One (Sub (r81) :: r876) + | 1096 -> One (Sub (r81) :: r878) | 286 -> One (Sub (r83) :: r290) | 314 -> One (Sub (r85) :: r303) - | 490 -> One (Sub (r85) :: r439) + | 492 -> One (Sub (r85) :: r441) | 261 -> One (Sub (r87) :: r256) | 398 -> One (Sub (r87) :: r347) | 433 -> One (Sub (r87) :: r360) | 448 -> One (Sub (r87) :: r379) - | 493 -> One (Sub (r87) :: r442) - | 610 -> One (Sub (r87) :: r537) - | 626 -> One (Sub (r87) :: r554) - | 630 -> One (Sub (r87) :: r555) - | 718 -> One (Sub (r87) :: r598) - | 1002 -> One (Sub (r87) :: r819) - | 1040 -> One (Sub (r87) :: r850) - | 1677 -> One (Sub (r87) :: r1149) - | 1681 -> One (Sub (r87) :: r1151) - | 1730 -> One (Sub (r87) :: r1159) - | 1195 -> One (Sub (r89) :: r954) - | 1226 -> One (Sub (r89) :: r968) + | 495 -> One (Sub (r87) :: r444) + | 613 -> One (Sub (r87) :: r539) + | 629 -> One (Sub (r87) :: r556) + | 633 -> One (Sub (r87) :: r557) + | 721 -> One (Sub (r87) :: r600) + | 1005 -> One (Sub (r87) :: r821) + | 1043 -> One (Sub (r87) :: r852) + | 1680 -> One (Sub (r87) :: r1151) + | 1684 -> One (Sub (r87) :: r1153) + | 1733 -> One (Sub (r87) :: r1161) + | 1198 -> One (Sub (r89) :: r956) + | 1229 -> One (Sub (r89) :: r970) | 189 -> One (Sub (r105) :: r174) - | 796 -> One (Sub (r105) :: r662) - | 1825 -> One (Sub (r105) :: r1181) + | 799 -> One (Sub (r105) :: r664) + | 1828 -> One (Sub (r105) :: r1183) | 348 -> One (Sub (r126) :: r321) | 195 -> One (Sub (r169) :: r175) | 182 -> One (Sub (r171) :: r173) - | 994 -> One (Sub (r171) :: r813) + | 997 -> One (Sub (r171) :: r815) | 199 -> One (Sub (r177) :: r178) - | 870 -> One (Sub (r177) :: r728) - | 919 -> One (Sub (r177) :: r743) + | 873 -> One (Sub (r177) :: r730) + | 922 -> One (Sub (r177) :: r745) | 256 -> One (Sub (r253) :: r255) | 307 -> One (Sub (r258) :: r297) | 267 -> One (Sub (r260) :: r266) @@ -2304,93 +2307,93 @@ let recover = | 268 -> One (Sub (r272) :: r274) | 269 -> One (Sub (r276) :: r277) | 292 -> One (Sub (r276) :: r292) - | 1674 -> One (Sub (r276) :: r1148) + | 1677 -> One (Sub (r276) :: r1150) | 271 -> One (Sub (r285) :: r287) - | 519 -> One (Sub (r285) :: r450) - | 953 -> One (Sub (r285) :: r768) + | 521 -> One (Sub (r285) :: r452) + | 956 -> One (Sub (r285) :: r770) | 336 -> One (Sub (r310) :: r312) | 459 -> One (Sub (r316) :: r389) | 359 -> One (Sub (r324) :: r325) | 383 -> One (Sub (r338) :: r341) - | 574 -> One (Sub (r338) :: r503) - | 1196 -> One (Sub (r338) :: r959) - | 1227 -> One (Sub (r338) :: r973) - | 1518 -> One (Sub (r338) :: r1095) - | 1594 -> One (Sub (r338) :: r1121) + | 577 -> One (Sub (r338) :: r505) + | 1199 -> One (Sub (r338) :: r961) + | 1230 -> One (Sub (r338) :: r975) + | 1521 -> One (Sub (r338) :: r1097) + | 1597 -> One (Sub (r338) :: r1123) | 431 -> One (Sub (r357) :: r359) | 439 -> One (Sub (r357) :: r364) - | 1463 -> One (Sub (r367) :: r1074) + | 1466 -> One (Sub (r367) :: r1076) | 442 -> One (Sub (r369) :: r372) | 444 -> One (Sub (r374) :: r375) - | 1207 -> One (Sub (r384) :: r960) - | 523 -> One (Sub (r430) :: r451) - | 482 -> One (Sub (r432) :: r433) - | 551 -> One (Sub (r468) :: r470) - | 1480 -> One (Sub (r468) :: r1084) - | 1525 -> One (Sub (r496) :: r1099) - | 775 -> One (Sub (r613) :: r639) - | 1695 -> One (Sub (r663) :: r1155) - | 1707 -> One (Sub (r663) :: r1157) - | 816 -> One (Sub (r679) :: r680) - | 817 -> One (Sub (r688) :: r690) - | 872 -> One (Sub (r688) :: r730) - | 891 -> One (Sub (r688) :: r738) - | 899 -> One (Sub (r688) :: r740) - | 1683 -> One (Sub (r688) :: r1153) - | 977 -> One (Sub (r755) :: r784) - | 970 -> One (Sub (r781) :: r783) - | 1293 -> One (Sub (r793) :: r1017) - | 1317 -> One (Sub (r793) :: r1026) - | 1257 -> One (Sub (r845) :: r1003) - | 1244 -> One (Sub (r905) :: r986) - | 1321 -> One (Sub (r908) :: r1027) - | 1162 -> One (Sub (r926) :: r928) - | 1190 -> One (Sub (r945) :: r947) - | 1477 -> One (Sub (r1080) :: r1082) - | 660 -> One (r0) - | 1756 -> One (r2) - | 1755 -> One (r3) - | 1754 -> One (r4) - | 1753 -> One (r5) - | 1752 -> One (r6) + | 1210 -> One (Sub (r384) :: r962) + | 525 -> One (Sub (r432) :: r453) + | 484 -> One (Sub (r434) :: r435) + | 554 -> One (Sub (r470) :: r472) + | 1483 -> One (Sub (r470) :: r1086) + | 1528 -> One (Sub (r498) :: r1101) + | 778 -> One (Sub (r615) :: r641) + | 1698 -> One (Sub (r665) :: r1157) + | 1710 -> One (Sub (r665) :: r1159) + | 819 -> One (Sub (r681) :: r682) + | 820 -> One (Sub (r690) :: r692) + | 875 -> One (Sub (r690) :: r732) + | 894 -> One (Sub (r690) :: r740) + | 902 -> One (Sub (r690) :: r742) + | 1686 -> One (Sub (r690) :: r1155) + | 980 -> One (Sub (r757) :: r786) + | 973 -> One (Sub (r783) :: r785) + | 1296 -> One (Sub (r795) :: r1019) + | 1320 -> One (Sub (r795) :: r1028) + | 1260 -> One (Sub (r847) :: r1005) + | 1247 -> One (Sub (r907) :: r988) + | 1324 -> One (Sub (r910) :: r1029) + | 1165 -> One (Sub (r928) :: r930) + | 1193 -> One (Sub (r947) :: r949) + | 1480 -> One (Sub (r1082) :: r1084) + | 663 -> One (r0) + | 1759 -> One (r2) + | 1758 -> One (r3) + | 1757 -> One (r4) + | 1756 -> One (r5) + | 1755 -> One (r6) | 58 -> One (r7) | 53 -> One (r8) | 54 -> One (r10) | 57 -> One (r12) | 56 -> One (r13) - | 1358 -> One (r14) - | 1751 -> One (r16) - | 1750 -> One (r17) + | 1361 -> One (r14) + | 1754 -> One (r16) + | 1753 -> One (r17) | 60 -> One (r18) - | 1749 -> One (r19) - | 1748 -> One (r20) - | 1747 -> One (r21) - | 1746 -> One (r22) + | 1752 -> One (r19) + | 1751 -> One (r20) + | 1750 -> One (r21) + | 1749 -> One (r22) | 63 -> One (r23) | 62 -> One (r24) | 64 -> One (r25) | 65 -> One (r26) - | 1739 -> One (r27) + | 1742 -> One (r27) | 68 -> One (r28) | 67 -> One (r29) - | 1536 -> One (r30) - | 1534 -> One (r31) - | 568 -> One (r32) - | 1541 -> One (r34) - | 1738 -> One (r36) - | 1737 -> One (r37) - | 1736 -> One (r38) + | 1539 -> One (r30) + | 1537 -> One (r31) + | 571 -> One (r32) + | 1544 -> One (r34) + | 1741 -> One (r36) + | 1740 -> One (r37) + | 1739 -> One (r38) | 71 -> One (r39) | 70 -> One (r40) | 74 -> One (r41) - | 1615 -> One (r43) - | 1735 -> One (r44) - | 1734 -> One (r45) - | 1733 -> One (r46) + | 1618 -> One (r43) + | 1738 -> One (r44) + | 1737 -> One (r45) + | 1736 -> One (r46) | 78 -> One (r47) | 77 -> One (r48) - | 1729 -> One (r49) - | 1728 -> One (r50) + | 1732 -> One (r49) + | 1731 -> One (r50) | 80 -> One (r51) | 82 -> One (r52) | 85 -> One (r53) @@ -2406,22 +2409,22 @@ let recover = | 101 -> One (r65) | 98 -> One (r66) | 97 -> One (r67) - | 1727 -> One (r68) - | 1726 -> One (r69) + | 1730 -> One (r68) + | 1729 -> One (r69) | 104 | 151 -> One (r70) - | 1150 -> One (r71) - | 1725 -> One (r73) - | 1724 -> One (r74) + | 1153 -> One (r71) + | 1728 -> One (r73) + | 1727 -> One (r74) | 106 -> One (r75) - | 147 | 246 | 552 | 1495 -> One (r76) + | 147 | 246 | 555 | 1498 -> One (r76) | 150 -> One (r78) | 299 -> One (r80) | 285 -> One (r82) | 315 -> One (r84) | 325 -> One (r86) - | 806 -> One (r88) - | 1723 -> One (r90) - | 1722 -> One (r91) + | 809 -> One (r88) + | 1726 -> One (r90) + | 1725 -> One (r91) | 149 -> One (r92) | 148 -> One (r93) | 109 -> One (r94) @@ -2439,42 +2442,42 @@ let recover = | 161 -> One (r107) | 158 -> One (r109) | 157 -> One (r110) - | 1721 -> One (r111) - | 1720 -> One (r112) + | 1724 -> One (r111) + | 1723 -> One (r112) | 165 -> One (r113) | 164 -> One (r114) | 163 -> One (r115) - | 1719 -> One (r116) + | 1722 -> One (r116) | 169 -> One (r117) | 168 -> One (r118) | 167 -> One (r119) - | 1718 -> One (r120) - | 1717 -> One (r121) + | 1721 -> One (r120) + | 1720 -> One (r121) | 172 -> One (r122) | 205 -> One (r123) | 289 -> One (r125) | 351 -> One (r127) - | 862 -> One (r129) - | 898 -> One (r131) - | 897 -> One (r132) - | 896 | 1706 -> One (r133) - | 1702 -> One (r135) - | 1716 -> One (r137) - | 1715 -> One (r138) - | 1714 -> One (r139) - | 1713 -> One (r140) - | 1712 -> One (r141) - | 925 -> One (r145) - | 924 -> One (r146) - | 923 -> One (r147) - | 1699 -> One (r153) - | 1698 -> One (r154) - | 1692 -> One (r155) - | 1691 -> One (r156) - | 1690 -> One (r157) - | 907 -> One (r159) - | 906 -> One (r160) - | 905 -> One (r161) + | 865 -> One (r129) + | 901 -> One (r131) + | 900 -> One (r132) + | 899 | 1709 -> One (r133) + | 1705 -> One (r135) + | 1719 -> One (r137) + | 1718 -> One (r138) + | 1717 -> One (r139) + | 1716 -> One (r140) + | 1715 -> One (r141) + | 928 -> One (r145) + | 927 -> One (r146) + | 926 -> One (r147) + | 1702 -> One (r153) + | 1701 -> One (r154) + | 1695 -> One (r155) + | 1694 -> One (r156) + | 1693 -> One (r157) + | 910 -> One (r159) + | 909 -> One (r160) + | 908 -> One (r161) | 188 -> One (r165) | 191 -> One (r167) | 187 -> One (r168) @@ -2483,36 +2486,36 @@ let recover = | 193 -> One (r173) | 190 -> One (r174) | 196 -> One (r175) - | 875 -> One (r176) - | 1689 -> One (r178) - | 1686 -> One (r179) - | 813 -> One (r180) - | 812 -> One (r181) - | 1671 -> One (r182) - | 1670 -> One (r183) - | 1669 -> One (r184) + | 878 -> One (r176) + | 1692 -> One (r178) + | 1689 -> One (r179) + | 816 -> One (r180) + | 815 -> One (r181) + | 1674 -> One (r182) + | 1673 -> One (r183) + | 1672 -> One (r184) | 204 -> One (r185) - | 1666 -> One (r186) - | 829 -> One (r187) - | 1658 -> One (r189) - | 1657 -> One (r190) + | 1669 -> One (r186) + | 832 -> One (r187) + | 1661 -> One (r189) + | 1660 -> One (r190) | 208 -> One (r191) - | 1656 -> One (r192) - | 1655 -> One (r193) + | 1659 -> One (r192) + | 1658 -> One (r193) | 210 -> One (r194) - | 1654 -> One (r195) - | 1650 -> One (r196) - | 1649 -> One (r197) - | 1648 -> One (r198) - | 1647 -> One (r199) - | 1646 -> One (r200) - | 1645 -> One (r201) + | 1657 -> One (r195) + | 1653 -> One (r196) + | 1652 -> One (r197) + | 1651 -> One (r198) + | 1650 -> One (r199) + | 1649 -> One (r200) + | 1648 -> One (r201) | 218 -> One (r202) | 217 -> One (r203) - | 537 -> One (r204) - | 536 -> One (r205) - | 1635 -> One (r206) - | 1634 -> One (r207) + | 540 -> One (r204) + | 539 -> One (r205) + | 1638 -> One (r206) + | 1637 -> One (r207) | 221 -> One (r208) | 225 -> One (r209) | 231 -> One (r211) @@ -2524,23 +2527,23 @@ let recover = | 228 -> One (r218) | 230 -> One (r219) | 234 -> One (r220) - | 1633 -> One (r221) - | 1632 -> One (r222) - | 1631 -> One (r223) + | 1636 -> One (r221) + | 1635 -> One (r222) + | 1634 -> One (r223) | 239 -> One (r224) | 238 -> One (r225) - | 1630 -> One (r226) - | 1629 -> One (r227) - | 1628 -> One (r228) + | 1633 -> One (r226) + | 1632 -> One (r227) + | 1631 -> One (r228) | 242 -> One (r229) | 241 -> One (r230) - | 1625 -> One (r231) - | 1624 -> One (r232) - | 1612 -> One (r233) - | 1611 -> One (r234) + | 1628 -> One (r231) + | 1627 -> One (r232) + | 1615 -> One (r233) + | 1614 -> One (r234) | 429 -> One (r235) - | 1610 -> One (r237) - | 1609 -> One (r238) + | 1613 -> One (r237) + | 1612 -> One (r238) | 252 -> One (r239) | 250 -> One (r240) | 249 -> One (r241) @@ -2570,7 +2573,7 @@ let recover = | 309 -> One (r271) | 327 -> One (r273) | 326 -> One (r274) - | 279 | 1096 -> One (r275) + | 279 | 1099 -> One (r275) | 280 -> One (r277) | 275 -> One (r278) | 274 -> One (r279) @@ -2602,7 +2605,7 @@ let recover = | 338 -> One (r311) | 337 -> One (r312) | 419 -> One (r313) - | 355 | 717 -> One (r315) + | 355 | 720 -> One (r315) | 356 -> One (r317) | 346 -> One (r318) | 345 -> One (r319) @@ -2643,826 +2646,828 @@ let recover = | 436 -> One (r358) | 435 -> One (r359) | 434 -> One (r360) - | 1592 -> One (r361) - | 1591 -> One (r362) - | 1590 -> One (r363) + | 1595 -> One (r361) + | 1594 -> One (r362) + | 1593 -> One (r363) | 440 -> One (r364) - | 1589 -> One (r365) + | 1592 -> One (r365) | 443 -> One (r366) - | 1465 -> One (r368) - | 1462 -> One (r370) - | 1461 -> One (r371) - | 1460 -> One (r372) + | 1468 -> One (r368) + | 1465 -> One (r370) + | 1464 -> One (r371) + | 1463 -> One (r372) | 445 -> One (r373) | 454 -> One (r375) | 452 -> One (r376) | 451 -> One (r377) | 450 -> One (r378) | 449 -> One (r379) - | 1586 -> One (r380) + | 1589 -> One (r380) | 461 -> One (r381) - | 1211 -> One (r383) - | 1587 -> One (r385) + | 1214 -> One (r383) + | 1590 -> One (r385) | 458 -> One (r386) | 457 -> One (r387) | 456 -> One (r388) | 460 -> One (r389) - | 1570 -> One (r390) - | 1569 -> One (r391) - | 1568 -> One (r392) - | 1567 -> One (r393) - | 1566 -> One (r394) + | 1573 -> One (r390) + | 1572 -> One (r391) + | 1571 -> One (r392) + | 1570 -> One (r393) + | 1569 -> One (r394) | 463 -> One (r395) - | 1341 -> One (r396) - | 1340 -> One (r397) - | 1339 -> One (r398) - | 1338 -> One (r399) - | 1337 -> One (r400) - | 1336 -> One (r401) - | 1565 -> One (r402) - | 546 -> One (r403) - | 545 -> One (r404) + | 1344 -> One (r396) + | 1343 -> One (r397) + | 1342 -> One (r398) + | 1341 -> One (r399) + | 1340 -> One (r400) + | 1339 -> One (r401) + | 1568 -> One (r402) + | 549 -> One (r403) + | 548 -> One (r404) | 466 -> One (r405) | 465 -> One (r406) - | 533 -> One (r407) - | 531 -> One (r408) - | 530 -> One (r409) + | 536 -> One (r407) + | 534 -> One (r408) + | 533 -> One (r409) | 468 -> One (r410) | 470 -> One (r411) - | 529 -> One (r412) - | 528 -> One (r413) + | 532 -> One (r412) + | 531 -> One (r413) | 472 -> One (r414) - | 527 -> One (r415) - | 526 -> One (r416) - | 481 -> One (r417) - | 479 -> One (r418) - | 478 -> One (r419) - | 475 -> One (r420) - | 509 -> One (r421) - | 508 -> One (r423) - | 502 -> One (r425) - | 501 -> One (r426) - | 500 -> One (r427) - | 499 -> One (r428) - | 498 -> One (r429) - | 521 -> One (r431) - | 522 -> One (r433) - | 489 -> One (r434) - | 488 -> One (r435) - | 485 -> One (r436) - | 484 -> One (r437) - | 492 -> One (r438) - | 491 -> One (r439) - | 496 -> One (r440) - | 495 -> One (r441) - | 494 -> One (r442) - | 507 -> One (r443) - | 512 -> One (r445) - | 514 -> One (r446) - | 517 -> One (r447) + | 530 -> One (r415) + | 529 -> One (r416) + | 528 -> One (r417) + | 475 -> One (r418) + | 483 -> One (r419) + | 481 -> One (r420) + | 480 -> One (r421) + | 477 -> One (r422) + | 511 -> One (r423) + | 510 -> One (r425) + | 504 -> One (r427) + | 503 -> One (r428) + | 502 -> One (r429) + | 501 -> One (r430) + | 500 -> One (r431) + | 523 -> One (r433) + | 524 -> One (r435) + | 491 -> One (r436) + | 490 -> One (r437) + | 487 -> One (r438) + | 486 -> One (r439) + | 494 -> One (r440) + | 493 -> One (r441) + | 498 -> One (r442) + | 497 -> One (r443) + | 496 -> One (r444) + | 509 -> One (r445) + | 514 -> One (r447) | 516 -> One (r448) - | 518 | 1823 -> One (r449) - | 520 -> One (r450) - | 524 -> One (r451) - | 535 -> One (r452) - | 540 -> One (r453) - | 539 -> One (r454) - | 1384 -> One (r455) - | 1564 -> One (r457) - | 1563 -> One (r458) - | 1560 -> One (r459) - | 1557 -> One (r460) - | 549 -> One (r461) - | 1556 -> One (r462) - | 1487 -> One (r463) - | 1486 -> One (r464) - | 1484 -> One (r465) - | 1490 -> One (r467) - | 1555 -> One (r469) - | 1554 -> One (r470) - | 1553 -> One (r471) - | 1552 -> One (r472) - | 1551 -> One (r473) - | 1550 -> One (r474) - | 557 -> One (r475) - | 556 -> One (r476) - | 1547 -> One (r477) - | 560 -> One (r478) - | 559 -> One (r479) - | 1544 -> One (r480) - | 1543 -> One (r481) - | 1542 -> One (r482) - | 563 -> One (r483) - | 562 -> One (r484) - | 1538 -> One (r485) - | 566 -> One (r486) - | 565 -> One (r487) - | 1537 -> One (r488) - | 1533 -> One (r489) - | 1532 -> One (r490) - | 1531 -> One (r491) - | 1206 -> One (r492) - | 1516 -> One (r494) - | 577 -> One (r495) - | 1530 -> One (r497) - | 1529 -> One (r498) - | 572 -> One (r499) - | 571 -> One (r500) - | 1528 -> One (r501) - | 576 -> One (r502) - | 575 -> One (r503) - | 1508 -> One (r504) - | 1507 -> One (r505) - | 1506 -> One (r506) - | 1505 -> One (r507) - | 582 -> One (r508) - | 581 -> One (r509) - | 580 -> One (r510) - | 579 -> One (r511) - | 1499 -> One (r512) - | 1504 -> One (r514) - | 1503 -> One (r515) - | 1502 -> One (r516) - | 1501 -> One (r517) - | 1500 -> One (r518) - | 1497 -> One (r519) - | 587 -> One (r520) - | 586 -> One (r521) - | 585 -> One (r522) - | 584 -> One (r523) - | 591 -> One (r524) - | 596 -> One (r525) - | 595 -> One (r526) - | 594 | 1494 -> One (r527) - | 1493 -> One (r528) - | 605 -> One (r529) - | 604 -> One (r530) - | 603 -> One (r531) - | 602 -> One (r532) - | 601 -> One (r533) - | 600 -> One (r534) - | 1456 -> One (r535) - | 612 -> One (r536) - | 611 -> One (r537) - | 616 -> One (r538) - | 615 -> One (r539) - | 614 -> One (r540) + | 519 -> One (r449) + | 518 -> One (r450) + | 520 | 1826 -> One (r451) + | 522 -> One (r452) + | 526 -> One (r453) + | 538 -> One (r454) + | 543 -> One (r455) + | 542 -> One (r456) + | 1387 -> One (r457) + | 1567 -> One (r459) + | 1566 -> One (r460) + | 1563 -> One (r461) + | 1560 -> One (r462) + | 552 -> One (r463) + | 1559 -> One (r464) + | 1490 -> One (r465) + | 1489 -> One (r466) + | 1487 -> One (r467) + | 1493 -> One (r469) + | 1558 -> One (r471) + | 1557 -> One (r472) + | 1556 -> One (r473) + | 1555 -> One (r474) + | 1554 -> One (r475) + | 1553 -> One (r476) + | 560 -> One (r477) + | 559 -> One (r478) + | 1550 -> One (r479) + | 563 -> One (r480) + | 562 -> One (r481) + | 1547 -> One (r482) + | 1546 -> One (r483) + | 1545 -> One (r484) + | 566 -> One (r485) + | 565 -> One (r486) + | 1541 -> One (r487) + | 569 -> One (r488) + | 568 -> One (r489) + | 1540 -> One (r490) + | 1536 -> One (r491) + | 1535 -> One (r492) + | 1534 -> One (r493) + | 1209 -> One (r494) + | 1519 -> One (r496) + | 580 -> One (r497) + | 1533 -> One (r499) + | 1532 -> One (r500) + | 575 -> One (r501) + | 574 -> One (r502) + | 1531 -> One (r503) + | 579 -> One (r504) + | 578 -> One (r505) + | 1511 -> One (r506) + | 1510 -> One (r507) + | 1509 -> One (r508) + | 1508 -> One (r509) + | 585 -> One (r510) + | 584 -> One (r511) + | 583 -> One (r512) + | 582 -> One (r513) + | 1502 -> One (r514) + | 1507 -> One (r516) + | 1506 -> One (r517) + | 1505 -> One (r518) + | 1504 -> One (r519) + | 1503 -> One (r520) + | 1500 -> One (r521) + | 590 -> One (r522) + | 589 -> One (r523) + | 588 -> One (r524) + | 587 -> One (r525) + | 594 -> One (r526) + | 599 -> One (r527) + | 598 -> One (r528) + | 597 | 1497 -> One (r529) + | 1496 -> One (r530) + | 608 -> One (r531) + | 607 -> One (r532) + | 606 -> One (r533) + | 605 -> One (r534) + | 604 -> One (r535) + | 603 -> One (r536) + | 1459 -> One (r537) + | 615 -> One (r538) + | 614 -> One (r539) + | 619 -> One (r540) | 618 -> One (r541) - | 1397 | 1449 -> One (r542) - | 1396 | 1448 -> One (r543) - | 620 | 1395 -> One (r544) - | 619 | 1394 -> One (r545) - | 1447 -> One (r546) - | 634 -> One (r547) - | 629 -> One (r548) - | 628 | 1593 -> One (r549) - | 633 -> One (r551) - | 632 -> One (r552) - | 625 -> One (r553) - | 627 -> One (r554) - | 631 -> One (r555) - | 636 -> One (r556) - | 638 -> One (r557) - | 640 -> One (r558) - | 644 | 1413 -> One (r559) - | 643 | 1412 -> One (r560) - | 642 | 1411 -> One (r561) - | 641 | 1410 -> One (r562) - | 1372 -> One (r563) - | 655 -> One (r564) - | 654 -> One (r565) - | 659 -> One (r566) - | 658 -> One (r567) + | 617 -> One (r542) + | 621 -> One (r543) + | 1400 | 1452 -> One (r544) + | 1399 | 1451 -> One (r545) + | 623 | 1398 -> One (r546) + | 622 | 1397 -> One (r547) + | 1450 -> One (r548) + | 637 -> One (r549) + | 632 -> One (r550) + | 631 | 1596 -> One (r551) + | 636 -> One (r553) + | 635 -> One (r554) + | 628 -> One (r555) + | 630 -> One (r556) + | 634 -> One (r557) + | 639 -> One (r558) + | 641 -> One (r559) + | 643 -> One (r560) + | 647 | 1416 -> One (r561) + | 646 | 1415 -> One (r562) + | 645 | 1414 -> One (r563) + | 644 | 1413 -> One (r564) + | 1375 -> One (r565) + | 658 -> One (r566) + | 657 -> One (r567) | 662 -> One (r568) - | 664 -> One (r569) - | 669 -> One (r570) - | 673 -> One (r571) + | 661 -> One (r569) + | 665 -> One (r570) + | 667 -> One (r571) | 672 -> One (r572) | 676 -> One (r573) - | 678 -> One (r574) - | 680 -> One (r575) - | 682 -> One (r576) - | 684 -> One (r577) - | 686 -> One (r578) - | 688 -> One (r579) - | 690 -> One (r580) - | 692 -> One (r581) - | 694 -> One (r582) - | 696 -> One (r583) - | 698 -> One (r584) - | 700 -> One (r585) - | 702 -> One (r586) - | 704 -> One (r587) - | 706 -> One (r588) - | 708 -> One (r589) - | 710 -> One (r590) - | 712 -> One (r591) - | 714 -> One (r592) - | 1371 -> One (r593) - | 739 -> One (r594) - | 716 -> One (r595) - | 721 -> One (r596) - | 720 -> One (r597) - | 719 -> One (r598) - | 724 -> One (r599) - | 723 -> One (r600) - | 726 -> One (r601) - | 728 -> One (r602) - | 730 -> One (r603) - | 732 -> One (r604) - | 737 -> One (r605) - | 1370 -> One (r606) - | 1369 -> One (r607) - | 741 -> One (r608) - | 743 -> One (r609) - | 745 -> One (r610) - | 762 -> One (r611) - | 761 -> One (r612) - | 780 -> One (r614) - | 779 -> One (r615) - | 778 -> One (r616) - | 758 -> One (r617) - | 757 -> One (r618) - | 756 -> One (r619) - | 753 -> One (r620) - | 750 -> One (r621) - | 749 -> One (r622) - | 748 -> One (r623) - | 747 -> One (r624) - | 752 -> One (r625) - | 755 -> One (r626) - | 777 -> One (r627) - | 768 -> One (r628) - | 767 -> One (r629) - | 760 -> One (r630) - | 766 -> One (r631) - | 765 -> One (r632) - | 764 -> One (r633) - | 774 -> One (r634) - | 773 -> One (r635) - | 772 -> One (r636) - | 771 -> One (r637) - | 770 -> One (r638) - | 776 -> One (r639) - | 1368 -> One (r640) - | 1367 -> One (r641) - | 782 -> One (r642) - | 1363 -> One (r643) - | 1362 -> One (r644) - | 784 -> One (r645) - | 789 -> One (r646) - | 788 -> One (r647) - | 787 -> One (r648) - | 786 -> One (r649) - | 802 -> One (r650) + | 675 -> One (r574) + | 679 -> One (r575) + | 681 -> One (r576) + | 683 -> One (r577) + | 685 -> One (r578) + | 687 -> One (r579) + | 689 -> One (r580) + | 691 -> One (r581) + | 693 -> One (r582) + | 695 -> One (r583) + | 697 -> One (r584) + | 699 -> One (r585) + | 701 -> One (r586) + | 703 -> One (r587) + | 705 -> One (r588) + | 707 -> One (r589) + | 709 -> One (r590) + | 711 -> One (r591) + | 713 -> One (r592) + | 715 -> One (r593) + | 717 -> One (r594) + | 1374 -> One (r595) + | 742 -> One (r596) + | 719 -> One (r597) + | 724 -> One (r598) + | 723 -> One (r599) + | 722 -> One (r600) + | 727 -> One (r601) + | 726 -> One (r602) + | 729 -> One (r603) + | 731 -> One (r604) + | 733 -> One (r605) + | 735 -> One (r606) + | 740 -> One (r607) + | 1373 -> One (r608) + | 1372 -> One (r609) + | 744 -> One (r610) + | 746 -> One (r611) + | 748 -> One (r612) + | 765 -> One (r613) + | 764 -> One (r614) + | 783 -> One (r616) + | 782 -> One (r617) + | 781 -> One (r618) + | 761 -> One (r619) + | 760 -> One (r620) + | 759 -> One (r621) + | 756 -> One (r622) + | 753 -> One (r623) + | 752 -> One (r624) + | 751 -> One (r625) + | 750 -> One (r626) + | 755 -> One (r627) + | 758 -> One (r628) + | 780 -> One (r629) + | 771 -> One (r630) + | 770 -> One (r631) + | 763 -> One (r632) + | 769 -> One (r633) + | 768 -> One (r634) + | 767 -> One (r635) + | 777 -> One (r636) + | 776 -> One (r637) + | 775 -> One (r638) + | 774 -> One (r639) + | 773 -> One (r640) + | 779 -> One (r641) + | 1371 -> One (r642) + | 1370 -> One (r643) + | 785 -> One (r644) + | 1366 -> One (r645) + | 1365 -> One (r646) + | 787 -> One (r647) + | 792 -> One (r648) + | 791 -> One (r649) + | 790 -> One (r650) + | 789 -> One (r651) | 805 -> One (r652) - | 804 -> One (r653) - | 801 -> One (r654) - | 800 -> One (r655) - | 794 -> One (r656) - | 793 -> One (r657) - | 792 -> One (r658) - | 791 -> One (r659) - | 799 -> One (r660) - | 798 -> One (r661) - | 797 -> One (r662) - | 847 -> One (r664) - | 846 -> One (r665) - | 845 -> One (r666) - | 840 -> One (r667) - | 861 -> One (r671) - | 860 -> One (r672) - | 859 -> One (r673) - | 987 -> One (r674) - | 986 -> One (r675) - | 985 -> One (r676) - | 984 -> One (r677) - | 839 -> One (r678) - | 838 -> One (r680) - | 834 -> One (r687) - | 831 -> One (r689) - | 830 -> One (r690) - | 828 -> One (r691) - | 827 -> One (r692) - | 826 -> One (r693) - | 825 -> One (r694) - | 821 -> One (r695) - | 820 -> One (r696) + | 808 -> One (r654) + | 807 -> One (r655) + | 804 -> One (r656) + | 803 -> One (r657) + | 797 -> One (r658) + | 796 -> One (r659) + | 795 -> One (r660) + | 794 -> One (r661) + | 802 -> One (r662) + | 801 -> One (r663) + | 800 -> One (r664) + | 850 -> One (r666) + | 849 -> One (r667) + | 848 -> One (r668) + | 843 -> One (r669) + | 864 -> One (r673) + | 863 -> One (r674) + | 862 -> One (r675) + | 990 -> One (r676) + | 989 -> One (r677) + | 988 -> One (r678) + | 987 -> One (r679) + | 842 -> One (r680) + | 841 -> One (r682) + | 837 -> One (r689) + | 834 -> One (r691) + | 833 -> One (r692) + | 831 -> One (r693) + | 830 -> One (r694) + | 829 -> One (r695) + | 828 -> One (r696) | 824 -> One (r697) | 823 -> One (r698) - | 837 -> One (r699) - | 836 -> One (r700) - | 844 -> One (r701) - | 858 -> One (r702) - | 854 -> One (r703) - | 850 -> One (r704) - | 853 -> One (r705) - | 852 -> One (r706) - | 857 -> One (r707) - | 856 -> One (r708) - | 1149 -> One (r709) - | 915 -> One (r710) - | 930 -> One (r712) - | 929 -> One (r713) - | 928 -> One (r714) - | 927 -> One (r715) - | 926 -> One (r716) - | 913 -> One (r720) - | 912 -> One (r721) - | 911 -> One (r722) - | 909 -> One (r723) - | 908 -> One (r724) - | 885 -> One (r726) - | 884 -> One (r727) - | 883 -> One (r728) - | 874 -> One (r729) - | 873 -> One (r730) - | 879 -> One (r731) - | 878 -> One (r732) - | 877 | 1694 -> One (r733) - | 881 | 1693 -> One (r734) - | 902 -> One (r735) - | 894 -> One (r736) - | 893 -> One (r737) - | 892 -> One (r738) - | 901 -> One (r739) - | 900 -> One (r740) - | 922 -> One (r741) - | 921 -> One (r742) - | 920 -> One (r743) - | 1148 -> One (r744) - | 941 -> One (r745) - | 940 -> One (r746) - | 939 -> One (r747) - | 938 -> One (r748) - | 937 -> One (r749) - | 936 -> One (r750) - | 935 -> One (r751) - | 934 -> One (r752) - | 974 -> One (r753) - | 973 -> One (r754) + | 827 -> One (r699) + | 826 -> One (r700) + | 840 -> One (r701) + | 839 -> One (r702) + | 847 -> One (r703) + | 861 -> One (r704) + | 857 -> One (r705) + | 853 -> One (r706) + | 856 -> One (r707) + | 855 -> One (r708) + | 860 -> One (r709) + | 859 -> One (r710) + | 1152 -> One (r711) + | 918 -> One (r712) + | 933 -> One (r714) + | 932 -> One (r715) + | 931 -> One (r716) + | 930 -> One (r717) + | 929 -> One (r718) + | 916 -> One (r722) + | 915 -> One (r723) + | 914 -> One (r724) + | 912 -> One (r725) + | 911 -> One (r726) + | 888 -> One (r728) + | 887 -> One (r729) + | 886 -> One (r730) + | 877 -> One (r731) + | 876 -> One (r732) + | 882 -> One (r733) + | 881 -> One (r734) + | 880 | 1697 -> One (r735) + | 884 | 1696 -> One (r736) + | 905 -> One (r737) + | 897 -> One (r738) + | 896 -> One (r739) + | 895 -> One (r740) + | 904 -> One (r741) + | 903 -> One (r742) + | 925 -> One (r743) + | 924 -> One (r744) + | 923 -> One (r745) + | 1151 -> One (r746) + | 944 -> One (r747) + | 943 -> One (r748) + | 942 -> One (r749) + | 941 -> One (r750) + | 940 -> One (r751) + | 939 -> One (r752) + | 938 -> One (r753) + | 937 -> One (r754) + | 977 -> One (r755) | 976 -> One (r756) - | 975 -> One (r757) - | 969 -> One (r758) - | 951 -> One (r759) - | 950 -> One (r760) - | 949 -> One (r761) - | 948 -> One (r762) - | 947 -> One (r763) - | 955 -> One (r767) - | 954 -> One (r768) - | 968 -> One (r769) - | 960 -> One (r770) - | 959 -> One (r771) - | 958 -> One (r772) - | 957 -> One (r773) - | 967 -> One (r774) - | 966 -> One (r775) - | 965 -> One (r776) - | 964 -> One (r777) - | 963 -> One (r778) - | 962 -> One (r779) - | 972 -> One (r782) - | 971 -> One (r783) - | 978 -> One (r784) - | 983 -> One (r785) - | 982 -> One (r786) - | 981 -> One (r787) - | 980 -> One (r788) - | 1043 | 1097 -> One (r790) - | 1099 -> One (r792) - | 1113 -> One (r794) - | 1103 -> One (r795) - | 1102 -> One (r796) - | 1084 -> One (r797) - | 1083 -> One (r798) - | 1082 -> One (r799) - | 1081 -> One (r800) - | 1080 -> One (r801) - | 1079 -> One (r802) - | 1078 -> One (r803) - | 1068 -> One (r804) - | 1067 -> One (r805) - | 999 -> One (r806) - | 998 -> One (r807) - | 997 -> One (r808) - | 993 -> One (r809) - | 991 -> One (r810) - | 990 -> One (r811) - | 996 -> One (r812) - | 995 -> One (r813) - | 1061 -> One (r814) - | 1060 -> One (r815) - | 1005 -> One (r816) - | 1001 -> One (r817) - | 1004 -> One (r818) - | 1003 -> One (r819) - | 1016 -> One (r820) - | 1015 -> One (r821) - | 1014 -> One (r822) - | 1013 -> One (r823) - | 1012 -> One (r824) - | 1007 -> One (r825) - | 1027 -> One (r826) - | 1026 -> One (r827) - | 1025 -> One (r828) - | 1024 -> One (r829) - | 1023 -> One (r830) - | 1018 -> One (r831) - | 1052 -> One (r832) - | 1051 -> One (r833) - | 1029 -> One (r834) - | 1050 -> One (r835) - | 1049 -> One (r836) - | 1048 -> One (r837) - | 1047 -> One (r838) - | 1031 -> One (r839) - | 1045 -> One (r840) - | 1035 -> One (r841) - | 1034 -> One (r842) - | 1033 -> One (r843) - | 1042 | 1090 -> One (r844) - | 1039 -> One (r846) - | 1038 -> One (r847) - | 1037 -> One (r848) - | 1036 | 1089 -> One (r849) - | 1041 -> One (r850) - | 1057 -> One (r851) - | 1056 -> One (r852) - | 1055 -> One (r853) - | 1059 -> One (r855) - | 1058 -> One (r856) - | 1054 -> One (r857) - | 1063 -> One (r858) - | 1066 -> One (r859) - | 1077 -> One (r860) - | 1076 -> One (r861) - | 1075 -> One (r862) - | 1074 -> One (r863) - | 1073 -> One (r864) - | 1072 -> One (r865) - | 1071 -> One (r866) - | 1070 -> One (r867) - | 1101 -> One (r868) - | 1088 -> One (r869) - | 1087 -> One (r870) - | 1086 -> One (r871) - | 1100 -> One (r872) - | 1092 -> One (r873) - | 1098 -> One (r874) + | 979 -> One (r758) + | 978 -> One (r759) + | 972 -> One (r760) + | 954 -> One (r761) + | 953 -> One (r762) + | 952 -> One (r763) + | 951 -> One (r764) + | 950 -> One (r765) + | 958 -> One (r769) + | 957 -> One (r770) + | 971 -> One (r771) + | 963 -> One (r772) + | 962 -> One (r773) + | 961 -> One (r774) + | 960 -> One (r775) + | 970 -> One (r776) + | 969 -> One (r777) + | 968 -> One (r778) + | 967 -> One (r779) + | 966 -> One (r780) + | 965 -> One (r781) + | 975 -> One (r784) + | 974 -> One (r785) + | 981 -> One (r786) + | 986 -> One (r787) + | 985 -> One (r788) + | 984 -> One (r789) + | 983 -> One (r790) + | 1046 | 1100 -> One (r792) + | 1102 -> One (r794) + | 1116 -> One (r796) + | 1106 -> One (r797) + | 1105 -> One (r798) + | 1087 -> One (r799) + | 1086 -> One (r800) + | 1085 -> One (r801) + | 1084 -> One (r802) + | 1083 -> One (r803) + | 1082 -> One (r804) + | 1081 -> One (r805) + | 1071 -> One (r806) + | 1070 -> One (r807) + | 1002 -> One (r808) + | 1001 -> One (r809) + | 1000 -> One (r810) + | 996 -> One (r811) + | 994 -> One (r812) + | 993 -> One (r813) + | 999 -> One (r814) + | 998 -> One (r815) + | 1064 -> One (r816) + | 1063 -> One (r817) + | 1008 -> One (r818) + | 1004 -> One (r819) + | 1007 -> One (r820) + | 1006 -> One (r821) + | 1019 -> One (r822) + | 1018 -> One (r823) + | 1017 -> One (r824) + | 1016 -> One (r825) + | 1015 -> One (r826) + | 1010 -> One (r827) + | 1030 -> One (r828) + | 1029 -> One (r829) + | 1028 -> One (r830) + | 1027 -> One (r831) + | 1026 -> One (r832) + | 1021 -> One (r833) + | 1055 -> One (r834) + | 1054 -> One (r835) + | 1032 -> One (r836) + | 1053 -> One (r837) + | 1052 -> One (r838) + | 1051 -> One (r839) + | 1050 -> One (r840) + | 1034 -> One (r841) + | 1048 -> One (r842) + | 1038 -> One (r843) + | 1037 -> One (r844) + | 1036 -> One (r845) + | 1045 | 1093 -> One (r846) + | 1042 -> One (r848) + | 1041 -> One (r849) + | 1040 -> One (r850) + | 1039 | 1092 -> One (r851) + | 1044 -> One (r852) + | 1060 -> One (r853) + | 1059 -> One (r854) + | 1058 -> One (r855) + | 1062 -> One (r857) + | 1061 -> One (r858) + | 1057 -> One (r859) + | 1066 -> One (r860) + | 1069 -> One (r861) + | 1080 -> One (r862) + | 1079 -> One (r863) + | 1078 -> One (r864) + | 1077 -> One (r865) + | 1076 -> One (r866) + | 1075 -> One (r867) + | 1074 -> One (r868) + | 1073 -> One (r869) + | 1104 -> One (r870) + | 1091 -> One (r871) + | 1090 -> One (r872) + | 1089 -> One (r873) + | 1103 -> One (r874) | 1095 -> One (r875) - | 1094 -> One (r876) - | 1112 -> One (r877) - | 1111 -> One (r878) - | 1110 -> One (r879) - | 1109 -> One (r880) - | 1108 -> One (r881) - | 1107 -> One (r882) - | 1106 -> One (r883) - | 1105 -> One (r884) - | 1122 -> One (r885) - | 1124 -> One (r886) - | 1134 -> One (r887) - | 1133 -> One (r888) - | 1132 -> One (r889) - | 1131 -> One (r890) - | 1130 -> One (r891) - | 1129 -> One (r892) - | 1128 -> One (r893) - | 1127 -> One (r894) - | 1145 -> One (r895) - | 1144 -> One (r896) - | 1143 -> One (r897) - | 1142 -> One (r898) - | 1141 -> One (r899) - | 1140 -> One (r900) - | 1139 -> One (r901) - | 1138 -> One (r902) - | 1137 -> One (r903) - | 1267 -> One (r904) - | 1316 -> One (r906) - | 1158 -> One (r907) - | 1333 -> One (r909) - | 1324 -> One (r910) - | 1323 -> One (r911) - | 1157 -> One (r912) - | 1156 -> One (r913) - | 1155 -> One (r914) - | 1154 -> One (r915) - | 1153 -> One (r916) - | 1310 -> One (r917) - | 1309 -> One (r918) - | 1161 -> One (r919) - | 1160 -> One (r920) - | 1186 -> One (r921) - | 1185 -> One (r922) - | 1184 -> One (r923) - | 1183 -> One (r924) - | 1174 -> One (r925) - | 1173 -> One (r927) - | 1172 -> One (r928) - | 1168 -> One (r929) - | 1167 -> One (r930) - | 1166 -> One (r931) - | 1165 -> One (r932) - | 1164 -> One (r933) - | 1171 -> One (r934) - | 1170 -> One (r935) - | 1182 -> One (r936) - | 1181 -> One (r937) - | 1180 -> One (r938) - | 1189 -> One (r939) - | 1188 -> One (r940) - | 1236 -> One (r941) - | 1225 -> One (r942) - | 1224 -> One (r943) - | 1215 -> One (r944) - | 1214 -> One (r946) - | 1213 -> One (r947) - | 1205 -> One (r948) - | 1194 -> One (r949) - | 1193 -> One (r950) - | 1192 -> One (r951) - | 1204 -> One (r952) - | 1203 -> One (r953) - | 1202 -> One (r954) - | 1201 -> One (r955) - | 1200 -> One (r956) - | 1199 -> One (r957) - | 1198 -> One (r958) - | 1197 -> One (r959) - | 1212 -> One (r960) - | 1210 -> One (r961) - | 1209 -> One (r962) - | 1223 -> One (r963) - | 1222 -> One (r964) - | 1221 -> One (r965) - | 1235 -> One (r966) - | 1234 -> One (r967) - | 1233 -> One (r968) - | 1232 -> One (r969) - | 1231 -> One (r970) - | 1230 -> One (r971) - | 1229 -> One (r972) - | 1228 -> One (r973) - | 1240 -> One (r974) - | 1239 -> One (r975) - | 1238 -> One (r976) - | 1304 -> One (r977) - | 1303 -> One (r978) - | 1302 -> One (r979) - | 1301 -> One (r980) - | 1300 -> One (r981) - | 1299 -> One (r982) - | 1296 -> One (r983) - | 1243 -> One (r984) - | 1292 -> One (r985) - | 1291 -> One (r986) - | 1286 -> One (r987) - | 1285 -> One (r988) - | 1284 -> One (r989) - | 1283 -> One (r990) - | 1252 -> One (r991) - | 1251 -> One (r992) - | 1250 -> One (r993) - | 1249 -> One (r994) - | 1248 -> One (r995) - | 1247 -> One (r996) - | 1282 -> One (r997) - | 1256 -> One (r998) - | 1255 -> One (r999) - | 1254 -> One (r1000) - | 1260 -> One (r1001) - | 1259 -> One (r1002) - | 1258 -> One (r1003) - | 1279 -> One (r1004) - | 1264 -> One (r1005) - | 1263 -> One (r1006) - | 1281 -> One (r1008) - | 1262 -> One (r1009) - | 1276 -> One (r1010) - | 1266 -> One (r1011) - | 1270 -> One (r1012) - | 1290 -> One (r1013) - | 1289 -> One (r1014) - | 1288 -> One (r1015) - | 1295 -> One (r1016) - | 1294 -> One (r1017) + | 1101 -> One (r876) + | 1098 -> One (r877) + | 1097 -> One (r878) + | 1115 -> One (r879) + | 1114 -> One (r880) + | 1113 -> One (r881) + | 1112 -> One (r882) + | 1111 -> One (r883) + | 1110 -> One (r884) + | 1109 -> One (r885) + | 1108 -> One (r886) + | 1125 -> One (r887) + | 1127 -> One (r888) + | 1137 -> One (r889) + | 1136 -> One (r890) + | 1135 -> One (r891) + | 1134 -> One (r892) + | 1133 -> One (r893) + | 1132 -> One (r894) + | 1131 -> One (r895) + | 1130 -> One (r896) + | 1148 -> One (r897) + | 1147 -> One (r898) + | 1146 -> One (r899) + | 1145 -> One (r900) + | 1144 -> One (r901) + | 1143 -> One (r902) + | 1142 -> One (r903) + | 1141 -> One (r904) + | 1140 -> One (r905) + | 1270 -> One (r906) + | 1319 -> One (r908) + | 1161 -> One (r909) + | 1336 -> One (r911) + | 1327 -> One (r912) + | 1326 -> One (r913) + | 1160 -> One (r914) + | 1159 -> One (r915) + | 1158 -> One (r916) + | 1157 -> One (r917) + | 1156 -> One (r918) + | 1313 -> One (r919) + | 1312 -> One (r920) + | 1164 -> One (r921) + | 1163 -> One (r922) + | 1189 -> One (r923) + | 1188 -> One (r924) + | 1187 -> One (r925) + | 1186 -> One (r926) + | 1177 -> One (r927) + | 1176 -> One (r929) + | 1175 -> One (r930) + | 1171 -> One (r931) + | 1170 -> One (r932) + | 1169 -> One (r933) + | 1168 -> One (r934) + | 1167 -> One (r935) + | 1174 -> One (r936) + | 1173 -> One (r937) + | 1185 -> One (r938) + | 1184 -> One (r939) + | 1183 -> One (r940) + | 1192 -> One (r941) + | 1191 -> One (r942) + | 1239 -> One (r943) + | 1228 -> One (r944) + | 1227 -> One (r945) + | 1218 -> One (r946) + | 1217 -> One (r948) + | 1216 -> One (r949) + | 1208 -> One (r950) + | 1197 -> One (r951) + | 1196 -> One (r952) + | 1195 -> One (r953) + | 1207 -> One (r954) + | 1206 -> One (r955) + | 1205 -> One (r956) + | 1204 -> One (r957) + | 1203 -> One (r958) + | 1202 -> One (r959) + | 1201 -> One (r960) + | 1200 -> One (r961) + | 1215 -> One (r962) + | 1213 -> One (r963) + | 1212 -> One (r964) + | 1226 -> One (r965) + | 1225 -> One (r966) + | 1224 -> One (r967) + | 1238 -> One (r968) + | 1237 -> One (r969) + | 1236 -> One (r970) + | 1235 -> One (r971) + | 1234 -> One (r972) + | 1233 -> One (r973) + | 1232 -> One (r974) + | 1231 -> One (r975) + | 1243 -> One (r976) + | 1242 -> One (r977) + | 1241 -> One (r978) + | 1307 -> One (r979) + | 1306 -> One (r980) + | 1305 -> One (r981) + | 1304 -> One (r982) + | 1303 -> One (r983) + | 1302 -> One (r984) + | 1299 -> One (r985) + | 1246 -> One (r986) + | 1295 -> One (r987) + | 1294 -> One (r988) + | 1289 -> One (r989) + | 1288 -> One (r990) + | 1287 -> One (r991) + | 1286 -> One (r992) + | 1255 -> One (r993) + | 1254 -> One (r994) + | 1253 -> One (r995) + | 1252 -> One (r996) + | 1251 -> One (r997) + | 1250 -> One (r998) + | 1285 -> One (r999) + | 1259 -> One (r1000) + | 1258 -> One (r1001) + | 1257 -> One (r1002) + | 1263 -> One (r1003) + | 1262 -> One (r1004) + | 1261 -> One (r1005) + | 1282 -> One (r1006) + | 1267 -> One (r1007) + | 1266 -> One (r1008) + | 1284 -> One (r1010) + | 1265 -> One (r1011) + | 1279 -> One (r1012) + | 1269 -> One (r1013) + | 1273 -> One (r1014) + | 1293 -> One (r1015) + | 1292 -> One (r1016) + | 1291 -> One (r1017) | 1298 -> One (r1018) - | 1308 -> One (r1019) - | 1307 -> One (r1020) - | 1306 -> One (r1021) - | 1312 -> One (r1022) - | 1315 -> One (r1023) - | 1320 -> One (r1024) - | 1319 -> One (r1025) - | 1318 -> One (r1026) + | 1297 -> One (r1019) + | 1301 -> One (r1020) + | 1311 -> One (r1021) + | 1310 -> One (r1022) + | 1309 -> One (r1023) + | 1315 -> One (r1024) + | 1318 -> One (r1025) + | 1323 -> One (r1026) | 1322 -> One (r1027) - | 1332 -> One (r1028) - | 1331 -> One (r1029) - | 1330 -> One (r1030) - | 1329 -> One (r1031) - | 1328 -> One (r1032) - | 1327 -> One (r1033) - | 1326 -> One (r1034) - | 1349 -> One (r1035) - | 1353 -> One (r1036) - | 1355 -> One (r1037) - | 1361 -> One (r1038) - | 1360 -> One (r1039) - | 1375 | 1418 -> One (r1040) - | 1374 | 1417 -> One (r1041) - | 1373 | 1416 -> One (r1042) - | 1378 | 1423 -> One (r1043) - | 1377 | 1422 -> One (r1044) - | 1376 | 1421 -> One (r1045) - | 1383 | 1430 -> One (r1046) - | 1382 | 1429 -> One (r1047) - | 1381 | 1428 -> One (r1048) - | 1380 | 1427 -> One (r1049) - | 1389 | 1435 -> One (r1050) - | 1388 | 1434 -> One (r1051) - | 1387 | 1433 -> One (r1052) - | 1392 | 1440 -> One (r1053) - | 1391 | 1439 -> One (r1054) - | 1390 | 1438 -> One (r1055) - | 1399 -> One (r1056) - | 1402 | 1452 -> One (r1057) - | 1401 | 1451 -> One (r1058) - | 1400 | 1450 -> One (r1059) - | 1404 -> One (r1060) - | 1407 | 1455 -> One (r1061) - | 1406 | 1454 -> One (r1062) - | 1405 | 1453 -> One (r1063) - | 1409 -> One (r1064) - | 1415 -> One (r1065) - | 1420 -> One (r1066) - | 1425 -> One (r1067) - | 1432 -> One (r1068) - | 1437 -> One (r1069) - | 1442 -> One (r1070) - | 1445 -> One (r1071) - | 1459 -> One (r1072) - | 1458 -> One (r1073) - | 1464 -> One (r1074) - | 1468 -> One (r1075) - | 1470 -> One (r1076) - | 1472 -> One (r1077) - | 1474 -> One (r1078) - | 1476 -> One (r1079) + | 1321 -> One (r1028) + | 1325 -> One (r1029) + | 1335 -> One (r1030) + | 1334 -> One (r1031) + | 1333 -> One (r1032) + | 1332 -> One (r1033) + | 1331 -> One (r1034) + | 1330 -> One (r1035) + | 1329 -> One (r1036) + | 1352 -> One (r1037) + | 1356 -> One (r1038) + | 1358 -> One (r1039) + | 1364 -> One (r1040) + | 1363 -> One (r1041) + | 1378 | 1421 -> One (r1042) + | 1377 | 1420 -> One (r1043) + | 1376 | 1419 -> One (r1044) + | 1381 | 1426 -> One (r1045) + | 1380 | 1425 -> One (r1046) + | 1379 | 1424 -> One (r1047) + | 1386 | 1433 -> One (r1048) + | 1385 | 1432 -> One (r1049) + | 1384 | 1431 -> One (r1050) + | 1383 | 1430 -> One (r1051) + | 1392 | 1438 -> One (r1052) + | 1391 | 1437 -> One (r1053) + | 1390 | 1436 -> One (r1054) + | 1395 | 1443 -> One (r1055) + | 1394 | 1442 -> One (r1056) + | 1393 | 1441 -> One (r1057) + | 1402 -> One (r1058) + | 1405 | 1455 -> One (r1059) + | 1404 | 1454 -> One (r1060) + | 1403 | 1453 -> One (r1061) + | 1407 -> One (r1062) + | 1410 | 1458 -> One (r1063) + | 1409 | 1457 -> One (r1064) + | 1408 | 1456 -> One (r1065) + | 1412 -> One (r1066) + | 1418 -> One (r1067) + | 1423 -> One (r1068) + | 1428 -> One (r1069) + | 1435 -> One (r1070) + | 1440 -> One (r1071) + | 1445 -> One (r1072) + | 1448 -> One (r1073) + | 1462 -> One (r1074) + | 1461 -> One (r1075) + | 1467 -> One (r1076) + | 1471 -> One (r1077) + | 1473 -> One (r1078) + | 1475 -> One (r1079) + | 1477 -> One (r1080) | 1479 -> One (r1081) - | 1478 -> One (r1082) - | 1492 -> One (r1083) - | 1491 -> One (r1084) - | 1483 -> One (r1085) - | 1482 -> One (r1086) - | 1515 -> One (r1087) - | 1514 -> One (r1088) - | 1513 -> One (r1089) - | 1512 -> One (r1090) - | 1511 -> One (r1091) - | 1510 -> One (r1092) - | 1527 -> One (r1093) - | 1520 -> One (r1094) - | 1519 -> One (r1095) - | 1524 -> One (r1096) - | 1523 -> One (r1097) - | 1522 -> One (r1098) + | 1482 -> One (r1083) + | 1481 -> One (r1084) + | 1495 -> One (r1085) + | 1494 -> One (r1086) + | 1486 -> One (r1087) + | 1485 -> One (r1088) + | 1518 -> One (r1089) + | 1517 -> One (r1090) + | 1516 -> One (r1091) + | 1515 -> One (r1092) + | 1514 -> One (r1093) + | 1513 -> One (r1094) + | 1530 -> One (r1095) + | 1523 -> One (r1096) + | 1522 -> One (r1097) + | 1527 -> One (r1098) | 1526 -> One (r1099) - | 1540 -> One (r1100) - | 1546 -> One (r1101) - | 1549 -> One (r1102) - | 1562 -> One (r1103) - | 1577 -> One (r1104) - | 1576 -> One (r1105) - | 1575 -> One (r1106) - | 1574 -> One (r1107) - | 1573 -> One (r1108) - | 1572 -> One (r1109) - | 1585 -> One (r1110) - | 1584 -> One (r1111) - | 1583 -> One (r1112) - | 1582 -> One (r1113) - | 1581 -> One (r1114) - | 1580 -> One (r1115) - | 1579 -> One (r1116) - | 1599 -> One (r1117) - | 1598 -> One (r1118) - | 1597 -> One (r1119) - | 1596 -> One (r1120) - | 1595 -> One (r1121) - | 1604 -> One (r1122) - | 1603 -> One (r1123) - | 1602 -> One (r1124) - | 1601 -> One (r1125) - | 1607 -> One (r1126) - | 1606 -> One (r1127) - | 1614 -> One (r1128) - | 1620 -> One (r1129) - | 1619 -> One (r1130) - | 1618 -> One (r1131) - | 1617 -> One (r1132) - | 1623 -> One (r1133) - | 1622 -> One (r1134) - | 1627 -> One (r1135) - | 1638 -> One (r1136) - | 1637 -> One (r1137) + | 1525 -> One (r1100) + | 1529 -> One (r1101) + | 1543 -> One (r1102) + | 1549 -> One (r1103) + | 1552 -> One (r1104) + | 1565 -> One (r1105) + | 1580 -> One (r1106) + | 1579 -> One (r1107) + | 1578 -> One (r1108) + | 1577 -> One (r1109) + | 1576 -> One (r1110) + | 1575 -> One (r1111) + | 1588 -> One (r1112) + | 1587 -> One (r1113) + | 1586 -> One (r1114) + | 1585 -> One (r1115) + | 1584 -> One (r1116) + | 1583 -> One (r1117) + | 1582 -> One (r1118) + | 1602 -> One (r1119) + | 1601 -> One (r1120) + | 1600 -> One (r1121) + | 1599 -> One (r1122) + | 1598 -> One (r1123) + | 1607 -> One (r1124) + | 1606 -> One (r1125) + | 1605 -> One (r1126) + | 1604 -> One (r1127) + | 1610 -> One (r1128) + | 1609 -> One (r1129) + | 1617 -> One (r1130) + | 1623 -> One (r1131) + | 1622 -> One (r1132) + | 1621 -> One (r1133) + | 1620 -> One (r1134) + | 1626 -> One (r1135) + | 1625 -> One (r1136) + | 1630 -> One (r1137) | 1641 -> One (r1138) | 1640 -> One (r1139) | 1644 -> One (r1140) | 1643 -> One (r1141) - | 1653 -> One (r1142) - | 1652 -> One (r1143) - | 1660 -> One (r1144) - | 1668 -> One (r1145) - | 1676 -> One (r1146) - | 1673 -> One (r1147) - | 1675 -> One (r1148) - | 1678 -> One (r1149) - | 1680 -> One (r1150) - | 1682 -> One (r1151) - | 1685 -> One (r1152) - | 1684 -> One (r1153) - | 1697 -> One (r1154) - | 1696 -> One (r1155) - | 1709 -> One (r1156) - | 1708 -> One (r1157) - | 1732 -> One (r1158) - | 1731 -> One (r1159) - | 1741 -> One (r1160) - | 1743 -> One (r1161) - | 1745 -> One (r1162) - | 1758 -> One (r1163) - | 1762 -> One (r1164) - | 1767 -> One (r1165) - | 1774 -> One (r1166) - | 1773 -> One (r1167) - | 1772 -> One (r1168) - | 1771 -> One (r1169) - | 1781 -> One (r1170) - | 1785 -> One (r1171) - | 1789 -> One (r1172) - | 1792 -> One (r1173) - | 1797 -> One (r1174) - | 1801 -> One (r1175) - | 1805 -> One (r1176) - | 1809 -> One (r1177) - | 1813 -> One (r1178) - | 1816 -> One (r1179) - | 1820 -> One (r1180) - | 1826 -> One (r1181) - | 1836 -> One (r1182) - | 1838 -> One (r1183) - | 1841 -> One (r1184) - | 1840 -> One (r1185) - | 1843 -> One (r1186) - | 1853 -> One (r1187) - | 1849 -> One (r1188) - | 1848 -> One (r1189) + | 1647 -> One (r1142) + | 1646 -> One (r1143) + | 1656 -> One (r1144) + | 1655 -> One (r1145) + | 1663 -> One (r1146) + | 1671 -> One (r1147) + | 1679 -> One (r1148) + | 1676 -> One (r1149) + | 1678 -> One (r1150) + | 1681 -> One (r1151) + | 1683 -> One (r1152) + | 1685 -> One (r1153) + | 1688 -> One (r1154) + | 1687 -> One (r1155) + | 1700 -> One (r1156) + | 1699 -> One (r1157) + | 1712 -> One (r1158) + | 1711 -> One (r1159) + | 1735 -> One (r1160) + | 1734 -> One (r1161) + | 1744 -> One (r1162) + | 1746 -> One (r1163) + | 1748 -> One (r1164) + | 1761 -> One (r1165) + | 1765 -> One (r1166) + | 1770 -> One (r1167) + | 1777 -> One (r1168) + | 1776 -> One (r1169) + | 1775 -> One (r1170) + | 1774 -> One (r1171) + | 1784 -> One (r1172) + | 1788 -> One (r1173) + | 1792 -> One (r1174) + | 1795 -> One (r1175) + | 1800 -> One (r1176) + | 1804 -> One (r1177) + | 1808 -> One (r1178) + | 1812 -> One (r1179) + | 1816 -> One (r1180) + | 1819 -> One (r1181) + | 1823 -> One (r1182) + | 1829 -> One (r1183) + | 1839 -> One (r1184) + | 1841 -> One (r1185) + | 1844 -> One (r1186) + | 1843 -> One (r1187) + | 1846 -> One (r1188) + | 1856 -> One (r1189) | 1852 -> One (r1190) | 1851 -> One (r1191) - | 1858 -> One (r1192) - | 1857 -> One (r1193) - | 1856 -> One (r1194) + | 1855 -> One (r1192) + | 1854 -> One (r1193) + | 1861 -> One (r1194) | 1860 -> One (r1195) + | 1859 -> One (r1196) + | 1863 -> One (r1197) | 363 -> Select (function | -1 -> [R 107] | _ -> S (T T_DOT) :: r328) - | 593 -> Select (function + | 596 -> Select (function | -1 -> [R 107] - | _ -> r528) + | _ -> r530) | 173 -> Select (function | -1 -> r152 | _ -> R 187 :: r144) - | 807 -> Select (function - | -1 -> r677 - | _ -> R 187 :: r670) - | 864 -> Select (function + | 810 -> Select (function + | -1 -> r679 + | _ -> R 187 :: r672) + | 867 -> Select (function | -1 -> r152 - | _ -> R 187 :: r719) - | 943 -> Select (function - | -1 -> r624 - | _ -> R 187 :: r766) - | 506 -> Select (function + | _ -> R 187 :: r721) + | 946 -> Select (function + | -1 -> r626 + | _ -> R 187 :: r768) + | 508 -> Select (function | -1 -> r278 | _ -> [R 221]) | 381 -> Select (function - | -1 -> [R 673] + | -1 -> [R 674] | _ -> S (N N_pattern) :: r336) | 378 -> Select (function - | -1 -> [R 674] + | -1 -> [R 675] | _ -> S (N N_pattern) :: r335) | 179 -> Select (function | -1 -> r164 - | _ -> R 781 :: r158) - | 867 -> Select (function + | _ -> R 782 :: r158) + | 870 -> Select (function | -1 -> r164 - | _ -> R 781 :: r725) - | 841 -> Select (function + | _ -> R 782 :: r727) + | 844 -> Select (function | -1 -> S (T T_RPAREN) :: r54 | _ -> S (T T_COLONCOLON) :: r344) | 87 -> Select (function - | 252 | 442 | 608 | 716 | 1249 | 1288 | 1339 | 1463 -> r61 + | 252 | 442 | 611 | 719 | 1252 | 1291 | 1342 | 1466 -> r61 | -1 -> S (T T_RPAREN) :: r54 | _ -> S (N N_pattern) :: r56) | 243 -> Select (function @@ -3471,43 +3476,43 @@ let recover = | 254 -> Select (function | -1 -> S (T T_RBRACKET) :: r243 | _ -> Sub (r245) :: r247) - | 547 -> Select (function + | 550 -> Select (function | -1 -> S (T T_RBRACKET) :: r243 - | _ -> Sub (r456) :: r458) + | _ -> Sub (r458) :: r460) | 462 -> Select (function - | 60 | 172 | 210 | 741 | 782 | 784 -> r401 + | 60 | 172 | 210 | 744 | 785 | 787 -> r401 | _ -> S (T T_OPEN) :: r395) - | 843 -> Select (function - | -1 -> r449 - | _ -> S (T T_LPAREN) :: r701) + | 846 -> Select (function + | -1 -> r451 + | _ -> S (T T_LPAREN) :: r703) | 270 -> Select (function | -1 -> r280 | _ -> S (T T_DOT) :: r282) - | 504 -> Select (function + | 506 -> Select (function | -1 -> r280 - | _ -> S (T T_DOT) :: r444) + | _ -> S (T T_DOT) :: r446) | 203 -> Select (function | -1 -> r123 | _ -> S (T T_COLON) :: r185) | 152 -> Select (function - | 848 | 1593 -> r107 + | 851 | 1596 -> r107 | _ -> Sub (r105) :: r108) | 155 -> Select (function - | 848 | 1593 -> r106 + | 851 | 1596 -> r106 | _ -> r108) - | 1711 -> Select (function + | 1714 -> Select (function | -1 -> r148 | _ -> r123) | 198 -> Select (function | -1 -> r162 | _ -> r123) - | 918 -> Select (function + | 921 -> Select (function | -1 -> r148 | _ -> r123) - | 869 -> Select (function + | 872 -> Select (function | -1 -> r162 | _ -> r123) - | 1710 -> Select (function + | 1713 -> Select (function | -1 -> r149 | _ -> r142) | 175 -> Select (function @@ -3516,43 +3521,43 @@ let recover = | 174 -> Select (function | -1 -> r151 | _ -> r144) - | 917 -> Select (function + | 920 -> Select (function | -1 -> r149 - | _ -> r717) - | 866 -> Select (function + | _ -> r719) + | 869 -> Select (function | -1 -> r150 - | _ -> r718) - | 865 -> Select (function + | _ -> r720) + | 868 -> Select (function | -1 -> r151 - | _ -> r719) + | _ -> r721) | 197 -> Select (function | -1 -> r163 | _ -> r158) - | 868 -> Select (function + | 871 -> Select (function | -1 -> r163 - | _ -> r725) + | _ -> r727) | 277 -> Select (function | -1 -> r279 | _ -> r282) - | 505 -> Select (function + | 507 -> Select (function | -1 -> r279 - | _ -> r444) - | 946 -> Select (function - | -1 -> r621 - | _ -> r764) - | 945 -> Select (function - | -1 -> r622 - | _ -> r765) - | 944 -> Select (function + | _ -> r446) + | 949 -> Select (function | -1 -> r623 | _ -> r766) - | 815 -> Select (function - | -1 -> r674 - | _ -> r668) - | 809 -> Select (function - | -1 -> r675 - | _ -> r669) - | 808 -> Select (function + | 948 -> Select (function + | -1 -> r624 + | _ -> r767) + | 947 -> Select (function + | -1 -> r625 + | _ -> r768) + | 818 -> Select (function | -1 -> r676 | _ -> r670) + | 812 -> Select (function + | -1 -> r677 + | _ -> r671) + | 811 -> Select (function + | -1 -> r678 + | _ -> r672) | _ -> raise Not_found diff --git a/src/ocaml/typing/btype.ml b/src/ocaml/typing/btype.ml index e1f3b299f0..2191cad4f2 100644 --- a/src/ocaml/typing/btype.ml +++ b/src/ocaml/typing/btype.ml @@ -47,6 +47,7 @@ module TransientTypeHash = Hashtbl.Make(TransientTypeOps) module TypeHash = struct include TransientTypeHash let add hash = wrap_repr (add hash) + let remove hash = wrap_repr (remove hash) let find hash = wrap_repr (find hash) let iter f = TransientTypeHash.iter (wrap_type_expr f) end diff --git a/src/ocaml/typing/btype.mli b/src/ocaml/typing/btype.mli index b495555b20..d79b8d2748 100644 --- a/src/ocaml/typing/btype.mli +++ b/src/ocaml/typing/btype.mli @@ -40,6 +40,7 @@ end module TypeHash : sig include Hashtbl.S with type key = transient_expr val add: 'a t -> type_expr -> 'a -> unit + val remove : 'a t -> type_expr -> unit val find: 'a t -> type_expr -> 'a val iter: (type_expr -> 'a -> unit) -> 'a t -> unit end diff --git a/src/ocaml/typing/ctype.ml b/src/ocaml/typing/ctype.ml index 201cb55626..b70965ec86 100644 --- a/src/ocaml/typing/ctype.ml +++ b/src/ocaml/typing/ctype.ml @@ -147,9 +147,11 @@ exception Incompatible let current_level = s_ref 0 let nongen_level = s_ref 0 -let global_level = s_ref 1 +let global_level = s_ref 0 let saved_level = s_ref [] + +(* merlin specific *) type levels = { current_level: int; nongen_level: int; global_level: int; saved_level: (int * int) list; } @@ -163,6 +165,7 @@ let set_levels l = nongen_level := l.nongen_level; global_level := l.global_level; saved_level := l.saved_level +(* end merlin specific *) let get_current_level () = !current_level let init_def level = current_level := level; nongen_level := level @@ -183,8 +186,46 @@ let create_scope () = init_def (!current_level + 1); !current_level +let wrap_end_def f = Misc.try_finally f ~always:end_def + +let with_local_level ?post f = + begin_def (); + let result = wrap_end_def f in + Option.iter (fun g -> g result) post; + result +let with_local_level_if cond f ~post = + if cond then with_local_level f ~post else f () +let with_local_level_iter f ~post = + begin_def (); + let result, l = wrap_end_def f in + List.iter post l; + result +let with_local_level_iter_if cond f ~post = + if cond then with_local_level_iter f ~post else fst (f ()) +let with_local_level_if_principal f ~post = + with_local_level_if !Clflags.principal f ~post +let with_local_level_iter_if_principal f ~post = + with_local_level_iter_if !Clflags.principal f ~post +let with_level ~level f = + begin_def (); init_def level; + let result = wrap_end_def f in + result +let with_level_if cond ~level f = + if cond then with_level ~level f else f () + +let with_local_level_for_class ?post f = + begin_class_def (); + let result = wrap_end_def f in + Option.iter (fun g -> g result) post; + result + +let with_raised_nongen_level f = + raise_nongen_level (); + wrap_end_def f + + let reset_global_level () = - global_level := !current_level + 1 + global_level := !current_level let increase_global_level () = let gl = !global_level in global_level := !current_level; @@ -192,14 +233,6 @@ let increase_global_level () = 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 @@ -221,9 +254,8 @@ let wrap_trace_gadt_instances env f x = let simple_abbrevs = ref Mnil -let proper_abbrevs path tl abbrev = - if tl <> [] || !trace_gadt_instances || !Clflags.principal || - is_object_type path +let proper_abbrevs tl abbrev = + if tl <> [] || !trace_gadt_instances || !Clflags.principal then abbrev else simple_abbrevs @@ -247,37 +279,93 @@ let none = newty (Ttuple []) (* Clearly ill-formed type *) (**** 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 : TypePairs.t } +type unification_mode = + | Expression (* unification in expression *) + | Pattern of + { equations_generation : equations_generation; + assume_injective : bool; + allow_recursive_equations : bool; } + (* unification in pattern which may add local constraints *) + | Subst + (* unification during type constructor expansion; more + relaxed than [Expression] in some cases. *) + let umode = ref Expression -let equations_generation = ref Forbidden -let assume_injective = ref false -let allow_recursive_equation = ref false + +let in_pattern_mode () = + match !umode with + | Expression | Subst -> false + | Pattern _ -> true + +let in_subst_mode () = + match !umode with + | Expression | Pattern _ -> false + | Subst -> true 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 + match !umode with + | Expression | Subst | Pattern { equations_generation = Forbidden } -> false + | Pattern { equations_generation = Allowed _ } -> true + +(* Can only be called when generate_equations is true *) +let record_equation t1 t2 = + match !umode with + | Expression | Subst | Pattern { equations_generation = Forbidden } -> + assert false + | Pattern { equations_generation = Allowed { equated_types } } -> + TypePairs.add equated_types (t1, t2) + +let can_assume_injective () = + match !umode with + | Expression | Subst -> false + | Pattern { assume_injective } -> assume_injective + +let in_counterexample () = + match !umode with + | Expression | Subst -> false + | Pattern { allow_recursive_equations } -> allow_recursive_equations + +let allow_recursive_equations () = + !Clflags.recursive_types + || match !umode with + | Expression | Subst -> false + | Pattern { allow_recursive_equations } -> allow_recursive_equations + +let set_mode_pattern ~allow_recursive_equations ~equated_types f = + let equations_generation = Allowed { equated_types } in + let assume_injective = true in + let new_umode = + Pattern + { equations_generation; + assume_injective; + allow_recursive_equations } + in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f + +let without_assume_injective f = + match !umode with + | Expression | Subst -> f () + | Pattern r -> + let new_umode = Pattern { r with assume_injective = false } in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f + +let without_generating_equations f = + match !umode with + | Expression | Subst -> f () + | Pattern r -> + let new_umode = Pattern { r with equations_generation = Forbidden } in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f (*** Checks for type definitions ***) -let in_current_module = function +let rec in_current_module = function | Path.Pident _ -> true | Path.Pdot _ | Path.Papply _ -> false + | Path.Pextra_ty (p, _) -> in_current_module p let in_pervasives p = in_current_module p && @@ -418,67 +506,54 @@ let rec filter_row_fields erase = function (* Check genericity of type schemes *) (**************************************) +type variable_kind = Row_variable | Type_variable +exception Non_closed of type_expr * variable_kind -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 +(* [free_vars] collects the variables of the input type expression. It + is used for several different things in the type-checker, with the + following bells and whistles: + - If [env] 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 collect both type variables and row variables, paired with + a [variable_kind] to distinguish them. - 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 + [free_variables] below drops the type/row information and only returns a [variable list]. *) -let rec free_vars_rec real ty = - if try_mark_node ty then - match get_desc ty, !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 get_level body <> 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, _ -> - iter_row (free_vars_rec true) row; - if not (static_row row) then free_vars_rec false (row_more row) - | _ -> - 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 rec fv ~kind acc ty = + if not (try_mark_node ty) then acc + else match get_desc ty, env with + | Tvar _, _ -> + (ty, kind) :: acc + | Tconstr (path, tl, _), Some env -> + let acc = + match Env.find_type_expansion path env with + | exception Not_found -> acc + | (_, body, _) -> + if get_level body = generic_level then acc + else (ty, kind) :: acc + in + List.fold_left (fv ~kind:Type_variable) acc tl + | Tobject (ty, _), _ -> + (* ignoring the second parameter of [Tobject] amounts to not + counting "virtual free variables". *) + fv ~kind:Row_variable acc ty + | Tfield (_, _, ty1, ty2), _ -> + let acc = fv ~kind:Type_variable acc ty1 in + fv ~kind:Row_variable acc ty2 + | Tvariant row, _ -> + let acc = fold_row (fv ~kind:Type_variable) acc row in + if static_row row then acc + else fv ~kind:Row_variable acc (row_more row) + | _ -> + fold_type_expr (fv ~kind) acc ty + in fv ~kind:Type_variable [] ty let free_variables ?env ty = let tl = List.map fst (free_vars ?env ty) in @@ -542,7 +617,12 @@ let closed_extension_constructor ext = unmark_extension_constructor ext; Some ty -exception CCFailure of (type_expr * bool * string * type_expr) +type closed_class_failure = { + free_variable: type_expr * variable_kind; + meth: string; + meth_ty: type_expr; +} +exception CCFailure of closed_class_failure let closed_class params sign = List.iter mark_type params; @@ -551,8 +631,12 @@ let closed_class params sign = Meths.iter (fun lab (priv, _, ty) -> if priv = Mpublic then begin - try closed_type ty with Non_closed (ty0, real) -> - raise (CCFailure (ty0, real, lab, ty)) + try closed_type ty with Non_closed (ty0, variable_kind) -> + raise (CCFailure { + free_variable = (ty0, variable_kind); + meth = lab; + meth_ty = ty; + }) end) sign.csig_meths; List.iter unmark_type params; @@ -613,13 +697,12 @@ let rec generalize_structure ty = if level <> generic_level then begin if is_Tvar ty && level > !current_level then set_level ty !current_level - else if - level > !current_level && - match get_desc ty with - Tconstr (p, _, abbrev) -> - not (is_object_type p) && (abbrev := Mnil; true) - | _ -> true - then begin + else if level > !current_level then begin + begin match get_desc ty with + Tconstr (_, _, abbrev) -> + abbrev := Mnil + | _ -> () + end; set_level ty generic_level; iter_type_expr generalize_structure ty end @@ -648,7 +731,7 @@ let rec generalize_spine ty = | 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) -> + | Tconstr (_, tyl, memo) -> set_level ty generic_level; memo := Mnil; List.iter generalize_spine tyl @@ -1005,20 +1088,22 @@ let rec find_repr p1 = (* 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]. -*) + + During instantiation, the result of copying a generic node is + "cached" in-place by temporarily mutating the node description by + a stub [Tsubst (newvar ())] using [For_copy.redirect_desc]. The + scope of this mutation is determined by the [copy_scope] parameter, + and the [For_copy.with_scope] helper is in charge of creating a new + scope and performing the necessary book-keeping -- in particular + reverting the in-place updates after the instantiation is done. *) 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 rec copy ?partial ?keep_names copy_scope ty = + let copy = copy ?partial ?keep_names copy_scope in match get_desc ty with Tsubst (ty, _) -> ty | desc -> @@ -1037,11 +1122,11 @@ let rec copy ?partial ?keep_names scope ty = in if forget <> generic_level then newty2 ~level:forget (Tvar None) else let t = newstub ~scope:(get_scope ty) in - For_copy.redirect_desc scope ty (Tsubst (t, None)); + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); let desc' = match desc with | Tconstr (p, tl, _) -> - let abbrevs = proper_abbrevs p tl !abbreviations in + let abbrevs = proper_abbrevs tl !abbreviations in begin match find_repr p !abbrevs with Some ty when not (eq_type ty t) -> Tlink ty @@ -1069,7 +1154,7 @@ let rec copy ?partial ?keep_names scope ty = Tsubst (_, Some ty2) -> (* This variant type has been already copied *) (* Change the stub to avoid Tlink in the new type *) - For_copy.redirect_desc scope ty (Tsubst (ty2, None)); + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); Tlink ty2 | _ -> (* If the row variable is not generic, we must keep it *) @@ -1097,12 +1182,6 @@ let rec copy ?partial ?keep_names scope ty = let more', row = match partial with Some (free_univars, false) -> - let more' = - if not (eq_type more more') then - more' (* we've already made a copy *) - else - newvar () - in let not_reither (_, f) = match row_field_repr f with Reither _ -> false @@ -1112,6 +1191,7 @@ let rec copy ?partial ?keep_names scope ty = if row_closed row && not (is_fixed row) && TypeSet.is_empty (free_univars ty) && not (List.for_all not_reither fields) then + let more' = newvar () in (more', create_row ~fields:(List.filter not_reither fields) ~more:more' ~closed:false ~fixed:None ~name:None) @@ -1119,7 +1199,7 @@ let rec copy ?partial ?keep_names scope ty = | _ -> (more', row) in (* Register new type first for recursion *) - For_copy.redirect_desc scope more + For_copy.redirect_desc copy_scope more (Tsubst(more', Some t)); (* Return a new copy *) Tvariant (copy_row copy true row keep more') @@ -1139,7 +1219,8 @@ let instance ?partial sch = None -> None | Some keep -> Some (compute_univars sch, keep) in - For_copy.with_scope (fun scope -> copy ?partial scope sch) + For_copy.with_scope (fun copy_scope -> + copy ?partial copy_scope sch) let generic_instance sch = let old = !current_level in @@ -1149,22 +1230,25 @@ let generic_instance sch = 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 + For_copy.with_scope (fun copy_scope -> + List.map (fun t -> copy copy_scope t) schl) + +(* Create unique names to new type constructors. + Used for existential types and local constraints. *) +let get_new_abstract_name env s = + (* unique names are needed only for error messages *) + if in_counterexample () then s else + let name index = + if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else + Printf.sprintf "%s%d" s index + in + let check index = + match Env.find_type_by_name (Longident.Lident (name index)) env with + | _ -> false + | exception Not_found -> true + in + let index = Misc.find_first_mono check in + name index let new_local_type ?(loc = Location.none) ?manifest_and_scope () = let manifest, expansion_scope = @@ -1199,45 +1283,37 @@ type existential_treatment = | Make_existentials_abstract of { env: Env.t ref; scope: int } let instance_constructor existential_treatment cstr = - For_copy.with_scope (fun scope -> + For_copy.with_scope (fun copy_scope -> let copy_existential = match existential_treatment with - | Keep_existentials_flexible -> copy scope + | Keep_existentials_flexible -> copy copy_scope | Make_existentials_abstract {env; scope = fresh_constr_scope} -> fun 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 + Env.enter_type (get_new_abstract_name !env 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 + let tv = copy copy_scope existential in assert (is_Tvar tv); link_type tv to_unify; tv in let ty_ex = List.map copy_existential cstr.cstr_existentials in - let ty_res = copy scope cstr.cstr_res in - let ty_args = List.map (copy scope) cstr.cstr_args in + let ty_res = copy copy_scope cstr.cstr_res in + let ty_args = List.map (copy copy_scope) cstr.cstr_args 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 + For_copy.with_scope (fun copy_scope -> + let ty_args = List.map (fun t -> copy ?keep_names copy_scope t) sch_args in + let ty = copy 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 @@ -1259,10 +1335,10 @@ let map_kind f = function 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; + For_copy.with_scope (fun copy_scope -> + {decl with type_params = List.map (copy copy_scope) decl.type_params; + type_manifest = Option.map (copy copy_scope) decl.type_manifest; + type_kind = map_kind (copy copy_scope) decl.type_kind; } ) @@ -1274,107 +1350,105 @@ let generic_instance_declaration decl = decl let instance_class params cty = - let rec copy_class_type scope = function + let rec copy_class_type copy_scope = function | Cty_constr (path, tyl, cty) -> - let tyl' = List.map (copy scope) tyl in - let cty' = copy_class_type scope cty in + let tyl' = List.map (copy copy_scope) tyl in + let cty' = copy_class_type copy_scope cty in Cty_constr (path, tyl', cty') | Cty_signature sign -> Cty_signature - {csig_self = copy scope sign.csig_self; - csig_self_row = copy scope sign.csig_self_row; + {csig_self = copy copy_scope sign.csig_self; + csig_self_row = copy copy_scope sign.csig_self_row; csig_vars = Vars.map - (function (m, v, ty) -> (m, v, copy scope ty)) + (function (m, v, ty) -> (m, v, copy copy_scope ty)) sign.csig_vars; csig_meths = Meths.map - (function (p, v, ty) -> (p, v, copy scope ty)) + (function (p, v, ty) -> (p, v, copy copy_scope ty)) sign.csig_meths} | Cty_arrow (l, ty, cty) -> - Cty_arrow (l, copy scope ty, copy_class_type scope cty) + Cty_arrow (l, copy copy_scope ty, copy_class_type copy_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 + For_copy.with_scope (fun copy_scope -> + let params' = List.map (copy copy_scope) params in + let cty' = copy_class_type copy_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 get_id bound in - TypeSet.exists (fun t -> List.memq (get_id 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 ~may_share - (visited : (int * (type_expr * type_expr list)) list) (ty : type_expr) = - let univars = free ty in - if is_Tvar ty || may_share && TypeSet.is_empty univars then - if get_level ty <> generic_level then ty else - let t = newstub ~scope:(get_scope ty) in - delayed_copy := - lazy (Transient_expr.set_stub_desc t (Tlink (copy cleanup_scope ty))) - :: !delayed_copy; - t - else try - let t, bound_t = List.assq (get_id 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 = newstub ~scope:(get_scope ty) in - let desc = get_desc ty in - let visited = - match desc with - Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ -> - (get_id 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 - let desc' = - match desc with - | Tvariant row -> - let more = row_more row in - (* We shall really check the level on the row variable *) - let keep = is_Tvar more && get_level more <> generic_level in - let more' = copy_rec ~may_share:false more in - let fixed' = fixed && (is_Tvar more || is_Tunivar more) in - let row = - copy_row (copy_rec ~may_share:true) fixed' row keep more' in - Tvariant row - | Tpoly (t1, tl) -> - let tl' = List.map (fun t -> newty (get_desc t)) tl in - let bound = tl @ bound in - let visited = - List.map2 (fun ty t -> get_id ty, (t, bound)) tl tl' @ visited in - let body = - copy_sep ~cleanup_scope ~fixed ~free ~bound ~may_share:true - visited t1 in - Tpoly (body, tl') - | Tfield (p, k, ty1, ty2) -> - (* the kind is kept shared, see Btype.copy_type_desc *) - Tfield (p, field_kind_internal_repr k, copy_rec ~may_share:true ty1, - copy_rec ~may_share:false ty2) - | _ -> copy_type_desc (copy_rec ~may_share:true) desc - in - Transient_expr.set_stub_desc t desc'; - t - end +(* [copy_sep] is used to instantiate first-class polymorphic types. + * It first makes a separate copy of the type as a graph, omitting nodes + that have no free univars. + * In this first pass, [visited] is used as a mapping for previously visited + nodes, and must already contain all the free univars in [ty]. + * The remaining (univar-closed) parts of the type are then instantiated + with [copy] using a common [copy_scope]. + The reason to work in two passes lies in recursive types such as: + [let h (x : < m : 'a. < n : 'a; p : 'b > > as 'b) = x#m] + The type of [x#m] should be: + [ < n : 'c; p : < m : 'a. < n : 'a; p : 'b > > as 'b > ] + I.e., the universal type variable ['a] is both instantiated as a fresh + type variable ['c] when outside of its binder, and kept as universal + when under its binder. + Assumption: in the first call to [copy_sep], all the free univars should + be bound by the same [Tpoly] node. This guarantees that they are only + bound when under this [Tpoly] node, which has no free univars, and as + such is not part of the separate copy. In turn, this allows the separate + copy to keep the sharing of the original type without breaking its + binding structure. + *) +let copy_sep ~copy_scope ~fixed ~(visited : type_expr TypeHash.t) sch = + let free = compute_univars sch in + let delayed_copies = ref [] in + let add_delayed_copy t ty = + delayed_copies := + lazy (Transient_expr.set_stub_desc t (Tlink (copy copy_scope ty))) :: + !delayed_copies + in + let rec copy_rec ~may_share (ty : type_expr) = + let univars = free ty in + if is_Tvar ty || may_share && TypeSet.is_empty univars then + if get_level ty <> generic_level then ty else + let t = newstub ~scope:(get_scope ty) in + add_delayed_copy t ty; + t + else try + TypeHash.find visited ty + with Not_found -> begin + let t = newstub ~scope:(get_scope ty) in + TypeHash.add visited ty t; + let desc' = + match get_desc ty with + | Tvariant row -> + let more = row_more row in + (* We shall really check the level on the row variable *) + let keep = is_Tvar more && get_level more <> generic_level in + (* In that case we should keep the original, but we still + call copy to correct the levels *) + if keep then (add_delayed_copy t ty; Tvar None) else + let more' = copy_rec ~may_share:false more in + let fixed' = fixed && (is_Tvar more || is_Tunivar more) in + let row = + copy_row (copy_rec ~may_share:true) fixed' row keep more' in + Tvariant row + | Tfield (p, k, ty1, ty2) -> + (* the kind is kept shared, see Btype.copy_type_desc *) + Tfield (p, field_kind_internal_repr k, + copy_rec ~may_share:true ty1, + copy_rec ~may_share:false ty2) + | desc -> copy_type_desc (copy_rec ~may_share:true) desc + in + Transient_expr.set_stub_desc t desc'; + t + end + in + let ty = copy_rec ~may_share:true sch in + List.iter Lazy.force !delayed_copies; + ty -let instance_poly' cleanup_scope ~keep_names fixed univars sch = +let instance_poly' copy_scope ~keep_names fixed univars sch = (* In order to compute univars below, [sch] should not contain [Tsubst] *) let copy_var ty = match get_desc ty with @@ -1382,31 +1456,27 @@ let instance_poly' cleanup_scope ~keep_names fixed univars sch = | _ -> assert false in let vars = List.map copy_var univars in - let pairs = List.map2 (fun u v -> get_id u, (v, [])) univars vars in - delayed_copy := []; - let ty = - copy_sep ~cleanup_scope ~fixed ~free:(compute_univars sch) ~bound:[] - ~may_share:true pairs sch in - List.iter Lazy.force !delayed_copy; - delayed_copy := []; + let visited = TypeHash.create 17 in + List.iter2 (TypeHash.add visited) univars vars; + let ty = copy_sep ~copy_scope ~fixed ~visited sch in 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 + For_copy.with_scope (fun copy_scope -> + instance_poly' copy_scope ~keep_names fixed univars sch ) let instance_label fixed lbl = - For_copy.with_scope (fun scope -> + For_copy.with_scope (fun copy_scope -> let vars, ty_arg = match get_desc lbl.lbl_arg with Tpoly (ty, tl) -> - instance_poly' scope ~keep_names:false fixed tl ty + instance_poly' copy_scope ~keep_names:false fixed tl ty | _ -> - [], copy scope lbl.lbl_arg + [], copy copy_scope lbl.lbl_arg in (* call [copy] after [instance_poly] to avoid introducing [Tsubst] *) - let ty_res = copy scope lbl.lbl_res in + let ty_res = copy copy_scope lbl.lbl_res in (vars, ty_arg, ty_res) ) @@ -1427,7 +1497,7 @@ let subst env level priv abbrev oty params args body = | Some ty -> match get_desc ty with Tconstr (path, tl, _) -> - let abbrev = proper_abbrevs path tl abbrev in + let abbrev = proper_abbrevs tl abbrev in memorize_abbrev abbrev priv path ty body0; fun () -> forget_abbrev abbrev path | _ -> assert false @@ -1435,25 +1505,30 @@ let subst env level priv abbrev oty params args body = abbreviations := abbrev; let (params', body') = instance_parameterized_type params body in abbreviations := ref Mnil; + let old_umode = !umode in + umode := Subst; try !unify_var' env body0 body'; List.iter2 (!unify_var' env) params' args; current_level := old_level; + umode := old_umode; body' with Unify _ -> current_level := old_level; + umode := old_umode; 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 + Default to generic level. Usually, 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 = +let apply ?(use_current_level = false) env params body args = + let level = if use_current_level then !current_level else generic_level in try - subst env generic_level Public (ref Mnil) None params args body + subst env level Public (ref Mnil) None params args body with Cannot_subst -> raise Cannot_apply @@ -1503,7 +1578,7 @@ let expand_abbrev_gen kind find_type_expansion env ty = Tconstr (path, args, abbrev) -> let level = get_level ty in let scope = get_scope ty in - let lookup_abbrev = proper_abbrevs path args abbrev in + let lookup_abbrev = proper_abbrevs args abbrev in begin match find_expans kind path !lookup_abbrev with Some ty' -> (* prerr_endline @@ -1686,16 +1761,12 @@ let full_expand ~may_forget_scope env ty = if may_forget_scope then try expand_head_unif env ty with Unify_trace _ -> (* #10277: forget scopes when printing trace *) - begin_def (); - init_def (get_level ty); - let ty = + with_level ~level:(get_level ty) begin fun () -> (* The same as [expand_head], except in the failing case we return the - *original* type, not [correct_levels ty].*) + *original* type, not [correct_levels ty].*) try try_expand_head try_expand_safe env (correct_levels ty) with | Cannot_expand -> ty - in - end_def (); - ty + end else expand_head env ty in match get_desc ty with @@ -1771,8 +1842,7 @@ 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 allow_recursive = allow_recursive_equations () in let old = !type_changed in try while @@ -1832,8 +1902,7 @@ let rec local_non_recursive_abbrev ~allow_rec strict 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 + let allow_rec = allow_recursive_equations () 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; @@ -2008,20 +2077,20 @@ let univar_pairs = ref [] (**** Instantiate a generic type into a poly type ***) let polyfy env ty vars = - let subst_univar scope ty = + let subst_univar copy_scope ty = match get_desc ty with | Tvar name when get_level ty = generic_level -> let t = newty (Tunivar name) in - For_copy.redirect_desc scope ty (Tsubst (t, None)); + For_copy.redirect_desc copy_scope 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 + For_copy.with_scope (fun copy_scope -> + let vars' = List.filter_map (subst_univar copy_scope) vars in + let ty = copy copy_scope ty in let ty = newty2 ~level:(get_level ty) (Tpoly(ty, vars')) in let complete = List.length vars = List.length vars' in ty, complete @@ -2119,7 +2188,7 @@ let reify env t = 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 + Env.enter_type (get_new_abstract_name !env name) decl !env ~scope:fresh_constr_scope in let path = Path.Pident id in let t = newty2 ~level:lev (Tconstr (path,[],ref Mnil)) in @@ -2155,21 +2224,16 @@ let reify env t = | _ -> 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 find_expansion_scope env path = + match Env.find_type path env with + | { type_manifest = None ; _ } | exception Not_found -> generic_level + | decl -> decl.type_expansion_scope let non_aliasable p decl = (* in_pervasives p || (subsumed by in_current_module) *) @@ -2186,7 +2250,6 @@ let is_instantiable env p = 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 || @@ -2428,9 +2491,6 @@ let find_lowest_level 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; *) @@ -2539,11 +2599,9 @@ let unify_package env unify_list lv1 p1 fl1 lv2 p2 fl2 = let rigid_variants = ref false let unify_eq t1 t2 = - eq_type t1 t2 || - match !umode with - | Expression -> false - | Pattern -> - TypePairs.mem unify_eq_set (order_type_pair t1 t2) + eq_type t1 t2 + || (in_pattern_mode () + && TypePairs.mem unify_eq_set (order_type_pair t1 t2)) let unify1_var env t1 t2 = assert (is_Tvar t1); @@ -2559,22 +2617,15 @@ let unify1_var env t1 t2 = end; link_type t1 t2; true - | exception Unify_trace _ when !umode = Pattern -> + | exception Unify_trace _ when in_pattern_mode () -> 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_trace _ when !umode = Pattern -> + | exception Unify_trace _ when in_pattern_mode () -> reify env t1'; reify env t2'; if can_generate_equations () then begin @@ -2637,18 +2688,8 @@ let rec unify (env:Env.t ref) t1 t2 = update_level_for Unify !env (get_level t1) t2; update_scope_for Unify (get_scope t1) 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 + | (Tconstr _, Tconstr _) when Env.has_local_constraints !env -> + unify2_rec env t1 t1 t2 t2 | _ -> unify2 env t1 t2 end; @@ -2657,13 +2698,34 @@ let rec unify (env:Env.t ref) t1 t2 = reset_trace_gadt_instances reset_tracing; raise_trace_for Unify (Diff {got = t1; expected = t2} :: trace) -and unify2 env t1 t2 = +and unify2 env t1 t2 = unify2_expand env t1 t1 t2 t2 + +and unify2_rec env t10 t1 t20 t2 = + if unify_eq t1 t2 then () else + try match (get_desc t1, get_desc t2) with + | (Tconstr (p1, tl1, a1), Tconstr (p2, tl2, a2)) -> + if Path.same p1 p2 && tl1 = [] && tl2 = [] + && not (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) + then begin + update_level_for Unify !env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + end else + if find_expansion_scope !env p1 > find_expansion_scope !env p2 + then unify2_rec env t10 t1 t20 (try_expand_safe !env t2) + else unify2_rec env t10 (try_expand_safe !env t1) t20 t2 + | _ -> + raise Cannot_expand + with Cannot_expand -> + unify2_expand env t10 t1 t20 t2 + +and unify2_expand env t1 t1' t2 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 + 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 (get_level t1') (get_level t2') in let scope = Int.max (get_scope t1') (get_scope t2') in update_level_for Unify !env lv t2; @@ -2706,17 +2768,16 @@ and unify3 env t1 t1' t2 t2' = | (Tfield _, Tfield _) -> (* special case for GADTs *) unify_fields env t1' t2' | _ -> - begin match !umode with - | Expression -> - occur_for Unify !env t1' t2; - link_type t1' t2 - | Pattern -> - add_type_equality t1' t2' + if in_pattern_mode () then + add_type_equality t1' t2' + else begin + occur_for Unify !env t1' t2; + link_type 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) && + (!Clflags.classic || in_pattern_mode ()) && not (is_optional l1 || is_optional l2) -> unify env t1 t2; unify env u1 u2; begin match is_commu_ok c1, is_commu_ok c2 with @@ -2728,12 +2789,10 @@ and unify3 env t1 t1' t2 t2' = | (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 + if not (can_generate_equations ()) 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 can_assume_injective () then + without_assume_injective (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 @@ -2747,8 +2806,7 @@ and unify3 env t1 t1' t2 t2' = 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 + without_generating_equations begin fun () -> let snap = snapshot () in try unify env t1 t2 with Unify_trace _ -> @@ -2778,7 +2836,7 @@ and unify3 env t1 t1' t2 t2' = reify env t1'; record_equation t1' t2'; add_gadt_equation env path t1' - | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern -> + | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when in_pattern_mode () -> reify env t1'; reify env t2'; if can_generate_equations () then ( @@ -2797,7 +2855,7 @@ and unify3 env t1 t1' t2 t2' = | _ -> () end | (Tvariant row1, Tvariant row2) -> - if !umode = Expression then + if not (in_pattern_mode ()) then unify_row env row1 row2 else begin let snap = snapshot () in @@ -2836,7 +2894,7 @@ and unify3 env t1 t1' t2 t2' = unify_package !env (unify_list env) (get_level t1) p1 fl1 (get_level t2) p2 fl2 with Not_found -> - if !umode = Expression then raise_unexplained_for Unify; + if not (in_pattern_mode ()) 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 @@ -2902,7 +2960,8 @@ and unify_fields env ty1 ty2 = (* Optimization *) (fun (name, k1, t1, k2, t2) -> unify_kind k1 k2; try - if !trace_gadt_instances then begin + if !trace_gadt_instances && not (in_subst_mode ()) then begin + (* in_subst_mode: see PR#11771 *) update_level_for Unify !env (get_level va) t1; update_scope_for Unify (get_scope va) t1 end; @@ -2994,7 +3053,8 @@ and unify_row env row1 row2 = (* 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 + if !trace_gadt_instances && not (in_subst_mode ()) then + (* in_subst_mode: see PR#11771 *) update_level_for Unify !env (get_level rm) (newgenty (Tvariant row)); if has_fixed_explanation row then if eq_type more rm then () else @@ -3130,15 +3190,13 @@ let unify env ty1 ty2 = undo_compress snap; raise (Unify (expand_to_unification_error !env trace)) -let unify_gadt ~equations_level:lev ~allow_recursive (env:Env.t ref) ty1 ty2 = +let unify_gadt ~equations_level:lev ~allow_recursive_equations + (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 + set_mode_pattern ~allow_recursive_equations ~equated_types (fun () -> unify env ty1 ty2); gadt_equations_level := None; TypePairs.clear unify_eq_set; @@ -3179,6 +3237,8 @@ let unify_pairs env ty1 ty2 pairs = let unify env ty1 ty2 = unify_pairs (ref env) ty1 ty2 [] +(* Lower the level of a type to the current level *) +let enforce_current_level env ty = unify_var env (newvar ()) ty (**** Special cases of unification ****) @@ -5003,69 +5063,108 @@ let rec arity ty = | _ -> 0 (* Check for non-generalizable type variables *) -exception Nongen -let visited = ref TypeSet.empty - -let rec nongen_schema_rec env ty = - if TypeSet.mem ty !visited then () else begin - visited := TypeSet.add ty !visited; - match get_desc ty with - Tvar _ when get_level ty <> generic_level -> - raise Nongen - | Tconstr _ -> - let old = !visited in - begin try iter_type_expr (nongen_schema_rec env) ty - with Nongen -> try - visited := old; - nongen_schema_rec env (try_expand_head try_expand_safe env ty) - with Cannot_expand -> - raise Nongen - end - | Tfield(_, kind, t1, t2) -> - if field_kind_repr kind = Fpublic then - nongen_schema_rec env t1; - nongen_schema_rec env t2 - | Tvariant row -> - iter_row (nongen_schema_rec env) row; - if not (static_row row) then nongen_schema_rec env (row_more row) - | _ -> - iter_type_expr (nongen_schema_rec env) ty - end +let add_nongen_vars_in_schema = + let rec loop env ((visited, weak_set) as acc) ty = + if TypeSet.mem ty visited + then acc + else begin + let visited = TypeSet.add ty visited in + match get_desc ty with + | Tvar _ when get_level ty <> generic_level -> + visited, TypeSet.add ty weak_set + | Tconstr _ -> + let (_, unexpanded_candidate) as unexpanded_candidate' = + fold_type_expr + (loop env) + (visited, weak_set) + ty + in + (* Using `==` is okay because `loop` will return the original set + when it does not change it. Similarly, `TypeSet.add` will return + the original set if the element is already present. *) + if unexpanded_candidate == weak_set + then (visited, weak_set) + else begin + match + loop env (visited, weak_set) + (try_expand_head try_expand_safe env ty) + with + | exception Cannot_expand -> unexpanded_candidate' + | expanded_result -> expanded_result + end + | Tfield(_, kind, t1, t2) -> + let visited, weak_set = + match field_kind_repr kind with + | Fpublic -> loop env (visited, weak_set) t1 + | _ -> visited, weak_set + in + loop env (visited, weak_set) t2 + | Tvariant row -> + let visited, weak_set = + fold_row (loop env) (visited, weak_set) row + in + if not (static_row row) + then loop env (visited, weak_set) (row_more row) + else (visited, weak_set) + | _ -> + fold_type_expr (loop env) (visited, weak_set) ty + end + in + fun env acc ty -> + let _, result = loop env (TypeSet.empty, acc) ty in + result -(* Return whether all variables of type [ty] are generic. *) -let nongen_schema env ty = - visited := TypeSet.empty; - try - nongen_schema_rec env ty; - visited := TypeSet.empty; - false - with Nongen -> - visited := TypeSet.empty; - true +(* Return all non-generic variables of [ty]. *) +let nongen_vars_in_schema env ty = + let result = add_nongen_vars_in_schema env TypeSet.empty ty in + if TypeSet.is_empty result + then None + else Some result (* 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 nongen_class_type = function - | Cty_constr (_, params, _) -> - List.exists (nongen_schema Env.empty) params - | Cty_signature sign -> - nongen_schema Env.empty sign.csig_self - || nongen_schema Env.empty sign.csig_self_row - || Meths.exists - (fun _ (_, _, ty) -> nongen_schema Env.empty ty) - sign.csig_meths - || Vars.exists - (fun _ (_, _, ty) -> nongen_schema Env.empty ty) - sign.csig_vars - | Cty_arrow (_, ty, cty) -> - nongen_schema Env.empty ty - || nongen_class_type cty +let nongen_class_type = + let add_nongen_vars_in_schema' ty weak_set = + add_nongen_vars_in_schema Env.empty weak_set ty + in + let add_nongen_vars_in_schema_fold fold m weak_set = + let f _key (_,_,ty) weak_set = + add_nongen_vars_in_schema Env.empty weak_set ty + in + fold f m weak_set + in + let rec nongen_class_type cty weak_set = + match cty with + | Cty_constr (_, params, _) -> + List.fold_left + (add_nongen_vars_in_schema Env.empty) + weak_set + params + | Cty_signature sign -> + weak_set + |> add_nongen_vars_in_schema' sign.csig_self + |> add_nongen_vars_in_schema' sign.csig_self_row + |> add_nongen_vars_in_schema_fold Meths.fold sign.csig_meths + |> add_nongen_vars_in_schema_fold Vars.fold sign.csig_vars + | Cty_arrow (_, ty, cty) -> + add_nongen_vars_in_schema' ty weak_set + |> nongen_class_type cty + in + nongen_class_type let nongen_class_declaration cty = - List.exists (nongen_schema Env.empty) cty.cty_params - || nongen_class_type cty.cty_type + List.fold_left + (add_nongen_vars_in_schema Env.empty) + TypeSet.empty + cty.cty_params + |> nongen_class_type cty.cty_type +let nongen_vars_in_class_declaration cty = + let result = nongen_class_declaration cty in + if TypeSet.is_empty result + then None + else Some result (* Normalize a type before printing, saving... *) (* Cannot use mark_type because deep_occur uses it too *) @@ -5165,7 +5264,7 @@ let rec nondep_type_rec ?(expand_private=false) env ids ty = with Not_found -> let ty' = newgenstub ~scope:(get_scope ty) in TypeHash.add nondep_hash ty ty'; - let desc = + match match get_desc ty with | Tconstr(p, tl, _abbrev) as desc -> begin try @@ -5226,9 +5325,13 @@ let rec nondep_type_rec ?(expand_private=false) env ids ty = | _ -> Tvariant row end | desc -> copy_type_desc (nondep_type_rec env ids) desc - in - Transient_expr.set_stub_desc ty' desc; - ty' + with + | desc -> + Transient_expr.set_stub_desc ty' desc; + ty' + | exception e -> + TypeHash.remove nondep_hash ty; + raise e let nondep_type env id ty = try @@ -5373,6 +5476,7 @@ let nondep_cltype_declaration env ids decl = clty_variance = decl.clty_variance; clty_type = nondep_class_type env ids decl.clty_type; clty_path = decl.clty_path; + clty_hash_type = nondep_type_decl env ids false decl.clty_hash_type ; clty_loc = decl.clty_loc; clty_attributes = decl.clty_attributes; clty_uid = decl.clty_uid; diff --git a/src/ocaml/typing/ctype.mli b/src/ocaml/typing/ctype.mli index 186142d445..be4fddbe5b 100644 --- a/src/ocaml/typing/ctype.mli +++ b/src/ocaml/typing/ctype.mli @@ -33,14 +33,40 @@ exception Matches_failure of Env.t * Errortrace.unification_error 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 +(* All the following wrapper functions revert to the original level, + even in case of exception. *) +val with_local_level: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* [with_local_level (fun () -> cmd) ~post] evaluates [cmd] at a + raised level. + If given, [post] is applied to the result, at the original level. + It is expected to contain only level related post-processing. *) +val with_local_level_if: bool -> (unit -> 'a) -> post:('a -> unit) -> 'a + (* Same as [with_local_level], but only raise the level conditionally. + [post] also is only called if the level is raised. *) +val with_local_level_iter: (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Variant of [with_local_level], where [post] is iterated on the + returned list. *) +val with_local_level_iter_if: + bool -> (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Conditional variant of [with_local_level_iter] *) +val with_level: level: int -> (unit -> 'a) -> 'a + (* [with_level ~level (fun () -> cmd)] evaluates [cmd] with + [current_level] set to [level] *) +val with_level_if: bool -> level: int -> (unit -> 'a) -> 'a + (* Conditional variant of [with_level] *) +val with_local_level_if_principal: (unit -> 'a) -> post:('a -> unit) -> 'a +val with_local_level_iter_if_principal: + (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Applications of [with_local_level_if] and [with_local_level_iter_if] + to [!Clflags.principal] *) + +val with_local_level_for_class: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* Variant of [with_local_level], where the current level is raised but + the nongen level is not touched *) +val with_raised_nongen_level: (unit -> 'a) -> 'a + (* Variant of [with_local_level], + raises the nongen level to the current level *) + val reset_global_level: unit -> unit (* Reset the global level before typing an expression *) val increase_global_level: unit -> int @@ -115,6 +141,8 @@ val lower_contravariant: Env.t -> type_expr -> unit to be used before generalize for expansive expressions *) val lower_variables_only: Env.t -> int -> type_expr -> unit (* Lower all variables to the given level *) +val enforce_current_level: Env.t -> type_expr -> unit + (* Lower whole type to !current_level *) val generalize_structure: type_expr -> unit (* Generalize the structure of a type, lowering variables to !current_level *) @@ -163,9 +191,6 @@ val instance_constructor: existential_treatment -> 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 *) @@ -181,10 +206,14 @@ val instance_label: bool -> label_description -> type_expr list * type_expr * type_expr (* Same, for a label *) val apply: + ?use_current_level:bool -> 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. *) + (* [apply [p1...pN] t [a1...aN]] applies the type function + [fun p1 ... pN -> t] to the arguments [a1...aN] and returns the + resulting instance of [t]. + New nodes default to generic level except if [use_current_level] is + set to true. + 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 @@ -226,7 +255,7 @@ val extract_concrete_typedecl: 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 -> + equations_level:int -> allow_recursive_equations:bool -> Env.t ref -> type_expr -> type_expr -> Btype.TypePairs.t (* Unify the two types given and update the environment with the local constraints. Raise [Unify] if not possible. @@ -390,13 +419,19 @@ val nondep_cltype_declaration: val is_contractive: Env.t -> Path.t -> bool val normalize_type: type_expr -> unit -val nongen_schema: Env.t -> type_expr -> bool - (* Check whether the given type scheme contains no non-generic - type variables *) +val nongen_vars_in_schema: Env.t -> type_expr -> Btype.TypeSet.t option + (* Return any non-generic variables in the type scheme *) + +val nongen_vars_in_class_declaration:class_declaration -> Btype.TypeSet.t option + (* Return any non-generic variables in the class type. + Uses the empty environment. *) -val nongen_class_declaration: class_declaration -> bool - (* Check whether the given class type contains no non-generic - type variables. Uses the empty environment. *) +type variable_kind = Row_variable | Type_variable +type closed_class_failure = { + free_variable: type_expr * variable_kind; + meth: string; + meth_ty: type_expr; +} val free_variables: ?env:Env.t -> type_expr -> type_expr list (* If env present, then check for incomplete definitions too *) @@ -404,7 +439,7 @@ val closed_type_decl: type_declaration -> type_expr option val closed_extension_constructor: extension_constructor -> type_expr option val closed_class: type_expr list -> class_signature -> - (type_expr * bool * string * type_expr) option + closed_class_failure option (* Check whether all type variables are bound *) val unalias: type_expr -> type_expr @@ -417,7 +452,6 @@ val collapse_conj_params: Env.t -> type_expr list -> unit 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 diff --git a/src/ocaml/typing/datarepr.ml b/src/ocaml/typing/datarepr.ml index 75b3a1e660..004859ee34 100644 --- a/src/ocaml/typing/datarepr.ml +++ b/src/ocaml/typing/datarepr.ml @@ -125,7 +125,7 @@ let constructor_descrs ~current_unit ty_path decl cstrs rep = | 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 + Path.(Pextra_ty (ty_path, Pcstr_ty cstr_name)) representation in let cstr = { cstr_name; @@ -154,7 +154,7 @@ let extension_descr ~current_unit path_ext ext = 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) + Path.(Pextra_ty (path_ext, Pext_ty)) (Record_extension path_ext) in { cstr_name = Path.last path_ext; cstr_res = ty_res; diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml index cb191003a1..986b46d8d7 100644 --- a/src/ocaml/typing/env.ml +++ b/src/ocaml/typing/env.ml @@ -435,6 +435,23 @@ module IdTbl = List.map (fun (p, desc) -> (p, f desc)) (find_all wrap name next) + let rec find_all_idents name tbl () = + let current = + Ident.find_all_seq name tbl.current + |> Seq.map (fun (id, _) -> Some id) + in + let next () = + match tbl.layer with + | Nothing -> Seq.Nil + | Open { next; components; _ } -> + if NameMap.mem name components then + Seq.Cons(None, find_all_idents name next) + else + find_all_idents name next () + | Map {next; _ } -> find_all_idents name next () + in + Seq.append current next () + let rec fold_name wrap f tbl acc = let acc = Ident.fold_name @@ -504,6 +521,7 @@ let stamped_add table path value = | Pident id -> Ident.stamp id | Pdot (t, _) -> path_stamp t | Papply (t1, t2) -> Int.max (path_stamp t1) (path_stamp t2) + | Pextra_ty (t, _) -> path_stamp t in let stamp = path_stamp path in let stamp = if stamp = 0 then None else Some stamp in @@ -746,10 +764,6 @@ 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 @@ -757,7 +771,11 @@ let is_ext cda = let is_local_ext cda = match cda.cda_description with - | {cstr_tag = Cstr_extension(p, _)} -> is_ident p + | {cstr_tag = Cstr_extension(p, _)} -> begin + match p with + | Pident _ -> true + | Pdot _ | Papply _ | Pextra_ty _ -> false + end | _ -> false let diff env1 env2 = @@ -836,7 +854,7 @@ end = struct Ident.persistent id && is (Ident.name id) let is_path = function | Pident id -> is_ident id - | Pdot _ | Papply _ -> false + | Pdot _ | Papply _ | Pextra_ty _ -> false end let set_unit_name = Current_unit_name.set @@ -1074,6 +1092,7 @@ let rec find_module_components path env = 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 + | Pextra_ty _ -> raise Not_found and find_structure_components path env = match get_components (find_module_components path env) with @@ -1098,6 +1117,7 @@ let find_module ~alias path env = let fc = find_functor_components p1 env in if alias then md (fc.fcomp_res) else md (modtype_of_functor_appl fc p1 p2) + | Pextra_ty _ -> raise Not_found let find_module_lazy ~alias path env = match path with @@ -1115,6 +1135,7 @@ let find_module_lazy ~alias path env = else md (modtype_of_functor_appl fc p1 p2) in Subst.Lazy.of_module_decl md + | Pextra_ty _ -> raise Not_found let find_strengthened_module ~aliasable path env = let md = find_module_lazy ~alias:true path env in @@ -1131,15 +1152,70 @@ let find_value_full path env = | Pdot(p, s) -> let sc = find_structure_components p env in NameMap.find s sc.comp_values - | Papply _ -> raise Not_found + | Papply _ | Pextra_ty _ -> raise Not_found -let find_type_full path env = +let find_extension_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 + | Pident id -> TycompTbl.find_same id env.constrs + | Pdot(p, s) -> begin + let comps = find_structure_components p env in + let cstrs = NameMap.find s comps.comp_constrs in + let exts = List.filter is_ext cstrs in + match exts with + | [cda] -> cda + | _ -> raise Not_found + end + | Papply _ | Pextra_ty _ -> raise Not_found + +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); + tda_shape = Shape.leaf decl.type_uid; + } + | _ -> assert false + end + | _ -> assert false + +let rec find_type_data path env = + match Path.Map.find path env.local_constraints with + | decl -> + { + tda_declaration = decl; + tda_descriptions = Type_abstract; + tda_shape = Shape.leaf decl.type_uid; + } + | exception Not_found -> begin + 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 + | Pextra_ty (p, extra) -> begin + match extra with + | Pcstr_ty s -> + let cstr = find_cstr p s env in + type_of_cstr path cstr + | Pext_ty -> + let cda = find_extension_full p env in + type_of_cstr path cda.cda_description + end + end +and find_cstr path name env = + let tda = find_type_data path env in + match tda.tda_descriptions with + | Type_variant (cstrs, _) -> + List.find (fun cstr -> cstr.cstr_name = name) cstrs + | Type_record _ | Type_abstract | Type_open -> raise Not_found + + let find_modtype_lazy path env = match path with @@ -1147,7 +1223,7 @@ let find_modtype_lazy path env = | Pdot(p, s) -> let sc = find_structure_components p env in (NameMap.find s sc.comp_modtypes).mtda_declaration - | Papply _ -> raise Not_found + | Papply _ | Pextra_ty _ -> raise Not_found let find_modtype path env = Subst.Lazy.force_modtype_decl (find_modtype_lazy path env) @@ -1158,7 +1234,7 @@ let find_class_full path env = | Pdot(p, s) -> let sc = find_structure_components p env in NameMap.find s sc.comp_classes - | Papply _ -> raise Not_found + | Papply _ | Pextra_ty _ -> raise Not_found let find_cltype path env = match path with @@ -1166,7 +1242,7 @@ let find_cltype path env = | Pdot(p, s) -> let sc = find_structure_components p env in (NameMap.find s sc.comp_cltypes).cltda_declaration - | Papply _ -> raise Not_found + | Papply _ | Pextra_ty _ -> raise Not_found let find_value path env = (find_value_full path env).vda_description @@ -1180,71 +1256,6 @@ let find_ident_constructor id env = 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); - tda_shape = Shape.leaf decl.type_uid; - } - | _ -> 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; - tda_shape = Shape.leaf decl.type_uid; - } - | 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 = @@ -1256,7 +1267,7 @@ let rec find_module_address path env = | 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 + | Papply _ | Pextra_ty _ -> raise Not_found and force_address = function | Projection { parent; pos } -> Adot(get_address parent, pos) @@ -1289,24 +1300,21 @@ let find_constructor_address path env = | Pdot(p, s) -> let c = find_structure_components p env in get_constrs_address (NameMap.find s c.comp_constrs) - | Papply _ -> - raise Not_found + | Papply _ | Pextra_ty _ -> 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 + let name = Ident.name id in + let _, cltda = + IdTbl.find_name wrap_identity ~mark:false name env.cltypes in - tda.tda_declaration - | Pdot(p, s) -> + cltda.cltda_declaration.clty_hash_type + | Pdot(p, name) -> 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 cltda = NameMap.find name c.comp_cltypes in + cltda.cltda_declaration.clty_hash_type + | Papply _ | Pextra_ty _ -> raise Not_found let find_shape env (ns : Shape.Sig_component_kind.t) id = match ns with @@ -1369,6 +1377,7 @@ let rec normalize_module_path lax env = function else expand_module_path lax env (Papply(p1', p2')) | Pident _ as path -> expand_module_path lax env path + | Pextra_ty _ -> assert false and expand_module_path lax env path = try match find_module_lazy ~alias:true path env with @@ -1392,36 +1401,22 @@ let normalize_module_path oloc env path = error (Missing_module(loc, path, normalize_module_path true env path)) -let normalize_path_prefix oloc env path = +let rec normalize_path_prefix oloc env path = match path with - Pdot(p, s) -> + | Pdot(p, s) -> let p2 = normalize_module_path oloc env p in if p == p2 then path else Pdot(p2, s) | Pident _ -> path - | Papply _ -> + | Pextra_ty (p, extra) -> + let p2 = normalize_path_prefix oloc env p in + if p == p2 then path else Pextra_ty (p2, extra) + | 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 normalize_type_path = normalize_path_prefix + +let normalize_value_path = normalize_path_prefix let rec normalize_modtype_path env path = let path = normalize_path_prefix None env path in @@ -1481,7 +1476,7 @@ let rec is_functor_arg path env = begin try Ident.find_same id env.functor_args; true with Not_found -> false end - | Pdot (p, _s) -> is_functor_arg p env + | Pdot (p, _) | Pextra_ty (p, _) -> is_functor_arg p env | Papply _ -> true (* Copying types associated with values *) @@ -1616,7 +1611,7 @@ let rec find_shadowed_comps path env = (fun comps -> comps.comp_modules) s) l in List.flatten l' - | Papply _ -> [] + | Papply _ | Pextra_ty _ -> [] let find_shadowed wrap proj1 proj2 path env = match path with @@ -1626,7 +1621,7 @@ let find_shadowed wrap proj1 proj2 path env = let l = find_shadowed_comps p env in let l' = List.map (find_all_comps wrap proj2 s) l in List.flatten l' - | Papply _ -> [] + | Papply _ | Pextra_ty _ -> [] let find_shadowed_types path env = List.map fst @@ -2021,6 +2016,7 @@ and store_value ?check id addr decl shape env = summary = Env_value(env.summary, id, decl) } and store_constructor ~check type_decl type_id cstr_id cstr env = + Builtin_attributes.warning_scope cstr.cstr_attributes (fun () -> if check && not type_decl.type_loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_constructor ("", Unused)) then begin @@ -2044,7 +2040,7 @@ and store_constructor ~check type_decl type_id cstr_id cstr env = (Warnings.Unused_constructor(name, complaint))) (constructor_usage_complaint ~rebind:false priv used)); end; - end; + end); let cda_shape = Shape.leaf cstr.cstr_uid in { env with constrs = @@ -2053,6 +2049,7 @@ and store_constructor ~check type_decl type_id cstr_id cstr env = } and store_label ~check type_decl type_id lbl_id lbl env = + Builtin_attributes.warning_scope lbl.lbl_attributes (fun () -> if check && not type_decl.type_loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_field ("", Unused)) then begin @@ -2075,7 +2072,7 @@ and store_label ~check type_decl type_id lbl_id lbl env = Location.prerr_warning loc (Warnings.Unused_field(name, complaint))) (label_usage_complaint priv mut used)) - end; + end); { env with labels = TycompTbl.add lbl_id lbl env.labels; } @@ -2148,6 +2145,7 @@ and store_extension ~check ~rebind id addr ext shape env = cda_address = Some addr; cda_shape = shape } in + Builtin_attributes.warning_scope ext.ext_attributes (fun () -> if check && not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_extension ("", false, Unused)) then begin @@ -2169,7 +2167,7 @@ and store_extension ~check ~rebind id addr ext shape env = (name, is_exception, complaint))) (constructor_usage_complaint ~rebind priv used)) end; - end; + end); { env with constrs = TycompTbl.add id cda env.constrs; summary = Env_extension(env.summary, id, ext) } @@ -3328,6 +3326,23 @@ 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 +(* Stable name lookup for printing *) + +let find_index_tbl ident tbl = + let lbs = IdTbl.find_all_idents (Ident.name ident) tbl in + let find_ident (n,p) = match p with + | Some id -> if Ident.same ident id then Some n else None + | _ -> None + in + Seq.find_map find_ident @@ Seq.mapi (fun i x -> i,x) lbs + +let find_value_index id env = find_index_tbl id env.values +let find_type_index id env = find_index_tbl id env.types +let find_module_index id env = find_index_tbl id env.modules +let find_modtype_index id env = find_index_tbl id env.modtypes +let find_class_index id env = find_index_tbl id env.classes +let find_cltype_index id env = find_index_tbl id env.cltypes + (* Ordinary lookup functions *) let lookup_module_path ?(use=true) ~loc ~load lid env = @@ -3693,8 +3708,7 @@ let report_lookup_error _loc env ppf = function Location.get_pos_info def_loc.Location.loc_start in fprintf ppf - "@.@[%s@ %s %i@]" - "Hint: If this is a recursive definition," + "@.@[@{Hint@}: If this is a recursive definition,@ %s %i@]" "you should add the 'rec' keyword on line" line end @@ -3707,8 +3721,7 @@ let report_lookup_error _loc env ppf = function | exception Not_found -> spellcheck ppf extract_modules env lid; | _ -> fprintf ppf - "@.@[%s %a, %s@]" - "Hint: There is a module type named" + "@.@[@{Hint@}: There is a module type named %a, %s@]" !print_longident lid "but module types are not modules" end @@ -3724,8 +3737,7 @@ let report_lookup_error _loc env ppf = function | exception Not_found -> spellcheck ppf extract_classes env lid; | _ -> fprintf ppf - "@.@[%s %a, %s@]" - "Hint: There is a class type named" + "@.@[@{Hint@}: There is a class type named %a, %s@]" !print_longident lid "but classes are not class types" end @@ -3735,8 +3747,7 @@ let report_lookup_error _loc env ppf = function | exception Not_found -> spellcheck ppf extract_modtypes env lid; | _ -> fprintf ppf - "@.@[%s %a, %s@]" - "Hint: There is a module named" + "@.@[@{Hint@}: There is a module named %a, %s@]" !print_longident lid "but modules are not module types" end diff --git a/src/ocaml/typing/env.mli b/src/ocaml/typing/env.mli index f00d9f5f2c..f8c95daae6 100644 --- a/src/ocaml/typing/env.mli +++ b/src/ocaml/typing/env.mli @@ -127,9 +127,8 @@ val normalize_module_path: Location.t option -> t -> Path.t -> Path.t 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_value_path: Location.t option -> t -> Path.t -> Path.t +(* Normalize the prefix part of the value path *) val normalize_modtype_path: t -> Path.t -> Path.t (* Normalize a module type path *) @@ -268,6 +267,21 @@ val find_constructor_by_name: val find_label_by_name: Longident.t -> t -> label_description +(** The [find_*_index] functions computes a "namespaced" De Bruijn index + of an identifier in a given environment. In other words, it returns how many + times an identifier has been shadowed by a more recent identifiers with the + same name in a given environment. + Those functions return [None] when the identifier is not bound in the + environment. This behavior is there to facilitate the detection of + inconsistent printing environment, but should disappear in the long term. +*) +val find_value_index: Ident.t -> t -> int option +val find_type_index: Ident.t -> t -> int option +val find_module_index: Ident.t -> t -> int option +val find_modtype_index: Ident.t -> t -> int option +val find_class_index: Ident.t -> t -> int option +val find_cltype_index: Ident.t -> t -> int option + (* Check if a name is bound *) val bound_value: string -> t -> bool diff --git a/src/ocaml/typing/ident.ml b/src/ocaml/typing/ident.ml index e881294bb2..149feff921 100644 --- a/src/ocaml/typing/ident.ml +++ b/src/ocaml/typing/ident.ml @@ -294,6 +294,21 @@ let rec find_all n = function else find_all n (if c < 0 then l else r) +let get_all_seq k () = + Seq.unfold (Option.map (fun k -> (k.ident, k.data), k.previous)) + k () + +let rec find_all_seq n tbl () = + match tbl with + | Empty -> Seq.Nil + | Node(l, k, r, _) -> + let c = String.compare n (name k.ident) in + if c = 0 then + Seq.Cons((k.ident, k.data), get_all_seq k.previous) + else + find_all_seq n (if c < 0 then l else r) () + + let rec fold_aux f stack accu = function Empty -> begin match stack with diff --git a/src/ocaml/typing/ident.mli b/src/ocaml/typing/ident.mli index d78aa4e020..cfc4ca10b7 100644 --- a/src/ocaml/typing/ident.mli +++ b/src/ocaml/typing/ident.mli @@ -100,6 +100,7 @@ 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 find_all_seq: string -> 'a tbl -> (t * 'a) Seq.t 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 diff --git a/src/ocaml/typing/includecore.ml b/src/ocaml/typing/includecore.ml index 1cfc973134..a3cdd189c9 100644 --- a/src/ocaml/typing/includecore.ml +++ b/src/ocaml/typing/includecore.ml @@ -133,6 +133,20 @@ type privacy_mismatch = | Private_extensible_variant | Private_row_type +type type_kind = + | Kind_abstract + | Kind_record + | Kind_variant + | Kind_open + +let of_kind = function + | Type_abstract -> Kind_abstract + | Type_record (_, _) -> Kind_record + | Type_variant (_, _) -> Kind_variant + | Type_open -> Kind_open + +type kind_mismatch = type_kind * type_kind + type label_mismatch = | Type of Errortrace.equality_error | Mutability of position @@ -177,7 +191,7 @@ type variant_change = type type_mismatch = | Arity | Privacy of privacy_mismatch - | Kind + | Kind of kind_mismatch | Constraint of Errortrace.equality_error | Manifest of Errortrace.equality_error | Private_variant of type_expr * type_expr * private_variant_mismatch @@ -378,6 +392,19 @@ let report_private_object_mismatch env ppf err = | Missing s -> pr "The implementation is missing the method %s" s | Types err -> report_type_inequality env ppf err +let report_kind_mismatch first second ppf (kind1, kind2) = + let pr fmt = Format.fprintf ppf fmt in + let kind_to_string = function + | Kind_abstract -> "abstract" + | Kind_record -> "a record" + | Kind_variant -> "a variant" + | Kind_open -> "an extensible variant" in + pr "%s is %s, but %s is %s." + (String.capitalize_ascii first) + (kind_to_string kind1) + second + (kind_to_string kind2) + let report_type_mismatch first second decl env ppf err = let pr fmt = Format.fprintf ppf fmt in pr "@ "; @@ -386,8 +413,8 @@ let report_type_mismatch first second decl env ppf err = pr "They have different arities." | Privacy err -> report_privacy_mismatch ppf err - | Kind -> - pr "Their kinds differ." + | Kind err -> + report_kind_mismatch first second ppf err | Constraint err -> (* This error can come from implicit parameter disagreement or from explicit `constraint`s. Both affect the parameters, hence this choice @@ -921,7 +948,7 @@ let type_declarations ?(equality = false) ~loc env ~mark name labels1 labels2 rep1 rep2 | (Type_open, Type_open) -> None - | (_, _) -> Some Kind + | (_, _) -> Some (Kind (of_kind decl1.type_kind, of_kind decl2.type_kind)) in if err <> None then err else let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in @@ -952,8 +979,8 @@ let type_declarations ?(equality = false) ~loc env ~mark name (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)) + let (p1,n1,j1) = get_lower v1 and (p2,n2,j2) = get_lower v2 in + imp abstr (imp p2 p1 && imp n2 n1 && imp j2 j1)) decl2.type_params (List.combine decl1.type_variance decl2.type_variance) then None else Some Variance diff --git a/src/ocaml/typing/includecore.mli b/src/ocaml/typing/includecore.mli index be1687b620..50825976ce 100644 --- a/src/ocaml/typing/includecore.mli +++ b/src/ocaml/typing/includecore.mli @@ -43,6 +43,14 @@ type privacy_mismatch = | Private_extensible_variant | Private_row_type +type type_kind = + | Kind_abstract + | Kind_record + | Kind_variant + | Kind_open + +type kind_mismatch = type_kind * type_kind + type label_mismatch = | Type of Errortrace.equality_error | Mutability of position @@ -85,7 +93,7 @@ type private_object_mismatch = type type_mismatch = | Arity | Privacy of privacy_mismatch - | Kind + | Kind of kind_mismatch | Constraint of Errortrace.equality_error | Manifest of Errortrace.equality_error | Private_variant of type_expr * type_expr * private_variant_mismatch diff --git a/src/ocaml/typing/includemod.ml b/src/ocaml/typing/includemod.ml index 27491f609f..d0fa23a211 100644 --- a/src/ocaml/typing/includemod.ml +++ b/src/ocaml/typing/includemod.ml @@ -53,6 +53,9 @@ module Error = struct | Anonymous | Named of Path.t | Unit + | Empty_struct + (** For backward compatibility's sake, an empty struct can be implicitly + converted to an unit module *) type ('a,'b) diff = {got:'a; expected:'a; symptom:'b} type 'a core_diff =('a,unit) diff @@ -566,24 +569,28 @@ and functor_param ~in_eq ~loc env ~mark subst param1 param2 = | 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 -> - let id1 = Ident.rename id2 in - Env.add_module id1 Mp_present arg2' env, - Subst.add_module id2 (Path.Pident id1) subst - | Some id1, None -> - Env.add_module id1 Mp_present arg2' env, subst - | None, None -> - env, subst - in + let env, subst = equate_one_functor_param subst env arg2' name1 name2 in cc_arg, env, subst | _, _ -> Error (Error.Incompatible_params (param1, param2)), env, subst +and equate_one_functor_param subst env arg2' name1 name2 = + match name1, name2 with + | Some id1, Some id2 -> + (* two matching abstract parameters: we add one identifier to the + environment and record the equality between the two identifiers + in the substitution *) + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | None, Some id2 -> + let id1 = Ident.rename id2 in + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | Some id1, None -> + Env.add_module id1 Mp_present arg2' env, subst + | None, None -> + env, subst + and strengthened_modtypes ~in_eq ~loc ~aliasable env ~mark subst mty1 path1 mty2 shape = match mty1, mty2 with @@ -908,7 +915,7 @@ and check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 = let can_alias env path = let rec no_apply = function | Path.Pident _ -> true - | Path.Pdot(p, _) -> no_apply p + | Path.Pdot(p, _) | Path.Pextra_ty (p, _) -> no_apply p | Path.Papply _ -> false in no_apply path && not (Env.is_functor_arg path env) @@ -1033,36 +1040,36 @@ module Functor_inclusion_diff = struct | None -> state, [||] | Some (res, expansion) -> { state with res }, expansion - let update (d:Diff.change) st = match d with + (* Whenever we have a named parameter that doesn't match it anonymous + counterpart, we add it to the typing environment because it may + contain useful abbreviations, but without adding any equations *) + let bind id arg state = + let arg' = Subst.modtype Keep state.subst arg in + let env = Env.add_module id Mp_present arg' state.env in + { state with env } + + let rec update (d:Diff.change) st = + match d with | Insert (Unit | Named (None,_)) | Delete (Unit | Named (None,_)) | Keep (Unit,_,_) - | Keep (_,Unit,_) - | Change (_,(Unit | Named (None,_)), _) -> + | Keep (_,Unit,_) -> + (* No named abstract parameters: we keep the same environment *) 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 + | Insert (Named (Some id, arg)) | Delete (Named (Some id, arg)) -> + (* one named parameter to bind *) + st |> bind id arg |> expand_params + | Change (delete, insert, _) -> + (* Change should be delete + insert: we add both abstract parameters + to the environment without equating them. *) + let st, _expansion = update (Diffing.Delete delete) st in + update (Diffing.Insert insert) st + | Keep (Named (name1, _), Named (name2, arg2), _) -> + let arg = Subst.modtype Keep st.subst arg2 in + let env, subst = + equate_one_functor_param st.subst st.env arg name1 name2 + in + expand_params { st with env; subst } let diff env (l1,res1) (l2,_) = let module Compute = Diff.Left_variadic(struct @@ -1107,56 +1114,50 @@ module Functor_app_diff = struct begin let desc1 : Error.functor_arg_descr = fst param1 in match desc1, I.param_name param2 with - | (Unit | Anonymous) , None + | (Unit | Empty_struct | 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 + | Named _, None | (Unit | Empty_struct | Anonymous), Some _ -> 1 end let update (d: Diff.change) (st:Defs.state) = let open Error in match d with - | Insert _ - | Delete _ - | Keep ((Unit,_),_,_) - | Keep (_,Unit,_) - | Change (_,(Unit | Named (None,_)), _ ) - | Change ((Unit,_), Named (Some _, _), _) -> + | Insert (Unit|Named(None,_)) + | Delete _ (* delete is a concrete argument, not an abstract parameter*) + | Keep ((Unit,_),_,_) (* Keep(Unit,_) implies Keep(Unit,Unit) *) + | Keep (_,(Unit|Named(None,_)),_) + | Change (_,(Unit|Named (None,_)), _ ) -> + (* no abstract parameters to add, nor any equations *) 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 + | Insert(Named(Some param, param_ty)) + | Change(_, Named(Some param, param_ty), _ ) -> + (* Change is Delete + Insert: we add the Inserted parameter to the + environnement to track equalities with external components that the + parameter might add. *) + let mty = Subst.modtype Keep st.subst param_ty in + let env = Env.add_module ~arg:true param Mp_present mty st.env in + I.expand_params { st with env } + | Keep ((Named arg, _mty) , Named (Some param, _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 } + | Keep (((Anonymous|Empty_struct), mty), + Named (Some param, _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} let diff env ~f ~args = let params, res = retrieve_functor_params env f in @@ -1165,10 +1166,10 @@ module Functor_app_diff = struct let test (state:Defs.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|Empty_struct), Unit -> Ok Tcoerce_none | Unit, Named _ | (Anonymous | Named _), Unit -> Result.Error (Error.Incompatible_params(arg,param)) - | ( Anonymous | Named _ ) , Named (_, param) -> + | ( Anonymous | Named _ | Empty_struct ), Named (_, param) -> match modtypes ~in_eq:false ~loc state.env ~mark:Mark_neither state.subst arg_mty param Shape.dummy_mod diff --git a/src/ocaml/typing/includemod.mli b/src/ocaml/typing/includemod.mli index 8846c4510c..d5b2ee9a13 100644 --- a/src/ocaml/typing/includemod.mli +++ b/src/ocaml/typing/includemod.mli @@ -43,6 +43,9 @@ module Error: sig | Anonymous | Named of Path.t | Unit + | Empty_struct + (** For backward compatibility's sake, an empty struct can be implicitly + converted to an unit module. *) type core_sigitem_symptom = | Value_descriptions of diff --git a/src/ocaml/typing/includemod_errorprinter.ml b/src/ocaml/typing/includemod_errorprinter.ml index df49a16e29..f72795cb6c 100644 --- a/src/ocaml/typing/includemod_errorprinter.ml +++ b/src/ocaml/typing/includemod_errorprinter.ml @@ -339,6 +339,7 @@ module With_shorthand = struct let arg, mty = ua.item in match (arg: Err.functor_arg_descr) with | Unit -> Format.dprintf "()" + | Empty_struct -> Format.dprintf "(struct end)" | Named p -> let mty = modtype { ua with item = mty } in Format.dprintf @@ -357,6 +358,7 @@ module With_shorthand = struct let arg, mty = ua.item in match (arg: Err.functor_arg_descr) with | Unit -> Format.dprintf "()" + | Empty_struct -> Format.dprintf "(struct end)" | Named p -> fun ppf -> Printtyp.path ppf p | Anonymous -> let short_mty = modtype { ua with item=mty } in @@ -519,7 +521,10 @@ module Functor_suberror = struct | Named _ | Anonymous -> Format.dprintf "The functor was expected to be generative at this position" - + | Empty_struct -> + (* an empty structure can be used in both applicative and generative + context *) + assert false end let subcase sub ~expansion_token env (pos, diff) = diff --git a/src/ocaml/typing/magic_numbers.ml b/src/ocaml/typing/magic_numbers.ml index 7ec5200618..f052ec9850 100644 --- a/src/ocaml/typing/magic_numbers.ml +++ b/src/ocaml/typing/magic_numbers.ml @@ -23,6 +23,7 @@ module Cmi = struct | "Caml1999I030" -> Some "4.13" | "Caml1999I031" -> Some "4.14" | "Caml1999I032" -> Some "5.0" + | "Caml1999I033" -> Some "5.1" | _ -> None let () = assert (to_version_opt Config.cmi_magic_number <> None) diff --git a/src/ocaml/typing/mtype.ml b/src/ocaml/typing/mtype.ml index 3f6a61c047..312fec5fc8 100644 --- a/src/ocaml/typing/mtype.ml +++ b/src/ocaml/typing/mtype.ml @@ -418,12 +418,12 @@ let contains_type env mty = let rec get_prefixes = function | Pident _ -> Path.Set.empty - | Pdot (p, _) - | Papply (p, _) -> Path.Set.add p (get_prefixes p) + | Pdot (p, _) | Papply (p, _) | Pextra_ty (p, _) + -> Path.Set.add p (get_prefixes p) let rec get_arg_paths = function | Pident _ -> Path.Set.empty - | Pdot (p, _) -> get_arg_paths p + | Pdot (p, _) | Pextra_ty (p, _) -> get_arg_paths p | Papply (p1, p2) -> Path.Set.add p2 (Path.Set.union (get_prefixes p2) @@ -437,6 +437,10 @@ let rec rollback_path subst 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)) + | Pextra_ty (p1, extra) -> + let p1' = rollback_path subst p1 in + if Path.same p1 p1' then p + else rollback_path subst (Pextra_ty (p1', extra)) let rec collect_ids subst bindings p = begin match rollback_path subst p with diff --git a/src/ocaml/typing/oprint.ml b/src/ocaml/typing/oprint.ml index 5950b2f041..85124265e4 100644 --- a/src/ocaml/typing/oprint.ml +++ b/src/ocaml/typing/oprint.ml @@ -255,14 +255,18 @@ let pr_present = print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") let pr_var = Pprintast.tyvar +let ty_var ~non_gen ppf s = + pr_var ppf (if non_gen then "_" ^ s else s) 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_alias {non_gen; aliased; alias } -> + fprintf ppf "@[%a@ as %a@]" + print_out_type aliased + (ty_var ~non_gen) alias | Otyp_poly (sl, ty) -> fprintf ppf "@[%a.@ %a@]" pr_vars sl @@ -288,19 +292,18 @@ and print_out_type_2 ppf = | 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_class (id, tyl) -> + fprintf ppf "@[%a#%a@]" print_typargs tyl 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_object {fields; open_row} -> + fprintf ppf "@[<2>< %a >@]" (print_fields open_row) 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) -> + | Otyp_var (non_gen, s) -> ty_var ~non_gen ppf s + | Otyp_variant (row_fields, closed, tags) -> let print_present ppf = function None | Some [] -> () @@ -314,8 +317,7 @@ and print_simple_out_type ppf = | Ovar_typ typ -> print_simple_out_type ppf typ in - fprintf ppf "%s@[[%s@[@[%a@]%a@]@ ]@]" - (if non_gen then "_" else "") + fprintf ppf "@[[%s@[@[%a@]%a@]@ ]@]" (if closed then if tags = None then " " else "< " else if tags = None then "> " else "? ") print_fields row_fields @@ -344,22 +346,16 @@ and print_simple_out_type ppf = 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 = +and print_fields open_row ppf = function [] -> - begin match rest with - Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") - | None -> () - end + if open_row then fprintf ppf ".."; | [s, t] -> fprintf ppf "%s : %a" s print_out_type t; - begin match rest with - Some _ -> fprintf ppf ";@ " - | None -> () - end; - print_fields rest ppf [] + if open_row then fprintf ppf ";@ "; + print_fields open_row ppf [] | (s, t) :: l -> - fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l + fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields open_row) l and print_row_field ppf (l, opt_amp, tyl) = let pr_of ppf = if opt_amp then fprintf ppf " of@ &@ " @@ -396,6 +392,8 @@ let out_label = ref print_out_label let out_type = ref print_out_type +let out_type_args = ref print_typargs + (* Class types *) let print_type_parameter ppf s = diff --git a/src/ocaml/typing/oprint.mli b/src/ocaml/typing/oprint.mli index baa733d824..31dad9a906 100644 --- a/src/ocaml/typing/oprint.mli +++ b/src/ocaml/typing/oprint.mli @@ -20,6 +20,7 @@ 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_type_args : (formatter -> out_type list -> unit) ref val out_constr : (formatter -> out_constructor -> unit) ref val out_class_type : (formatter -> out_class_type -> unit) ref val out_module_type : (formatter -> out_module_type -> unit) ref diff --git a/src/ocaml/typing/outcometree.mli b/src/ocaml/typing/outcometree.mli index b9d03e88b1..8c32954a30 100644 --- a/src/ocaml/typing/outcometree.mli +++ b/src/ocaml/typing/outcometree.mli @@ -61,19 +61,18 @@ type out_type_param = string * (Asttypes.variance * Asttypes.injectivity) type out_type = | Otyp_abstract | Otyp_open - | Otyp_alias of out_type * string + | Otyp_alias of {non_gen:bool; aliased:out_type; alias:string} | Otyp_arrow of string * out_type * out_type - | Otyp_class of bool * out_ident * out_type list + | Otyp_class of 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_object of { fields: (string * out_type) list; open_row:bool} | Otyp_record of (string * bool * out_type) list | Otyp_stuff of string | Otyp_sum of out_constructor list | Otyp_tuple of out_type list | Otyp_var of bool * string - | Otyp_variant of - bool * out_variant * bool * (string list) option + | Otyp_variant of 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 diff --git a/src/ocaml/typing/parmatch.ml b/src/ocaml/typing/parmatch.ml index e85f7a1119..2a388f1fc8 100644 --- a/src/ocaml/typing/parmatch.ml +++ b/src/ocaml/typing/parmatch.ml @@ -823,13 +823,11 @@ let pat_of_constrs ex_pat cstrs = 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 get_desc ty' with - | Tconstr (path, _, _) -> +let pats_of_type env ty = + match Ctype.extract_concrete_typedecl env ty with + | Typedecl (_, path, {type_kind = Type_variant _ | Type_record _}) -> begin match Env.find_type_descrs path env with - | exception Not_found -> [omega] - | Type_variant (cstrs,_) when always || List.length cstrs <= 1 || + | Type_variant (cstrs,_) when 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 @@ -840,24 +838,24 @@ let pats_of_type ?(always=false) env ty = labels in [make_pat (Tpat_record (fields, Closed)) ty env] - | Type_variant _ | Type_abstract | Type_open -> [omega] + | _ -> [omega] end - | Ttuple tl -> - [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] - | _ -> [omega] + | Has_no_typedecl -> + begin match get_desc (Ctype.expand_head env ty) with + Ttuple tl -> + [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] + | _ -> [omega] + end + | Typedecl (_, _, {type_kind = Type_abstract | Type_open}) + | May_have_typedecl -> [omega] -let rec get_variant_constructors env ty = - match get_desc ty 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)) +let get_variant_constructors env ty = + match Ctype.extract_concrete_typedecl env ty with + | Typedecl (_, path, {type_kind = Type_variant _}) -> + begin match Env.find_type_descrs path env with + | Type_variant (cstrs,_) -> cstrs | _ -> fatal_error "Parmatch.get_variant_constructors" - with Not_found -> - fatal_error "Parmatch.get_variant_constructors" - end + end | _ -> fatal_error "Parmatch.get_variant_constructors" module ConstructorSet = Set.Make(struct @@ -1585,7 +1583,7 @@ let extract_columns pss qs = match pss with let rec every_satisfiables pss qs = match qs.active with | [] -> - (* qs is now partitionned, check usefulness *) + (* qs is now partitioned, check usefulness *) begin match qs.ors with | [] -> (* no or-patterns *) if satisfiable (make_matrix pss) (make_vector qs) then @@ -1843,68 +1841,6 @@ let rec initial_only_guarded = function (* 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 @@ -1913,32 +1849,6 @@ let contains_extension pat = | _ -> 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 | [] -> (* @@ -1958,8 +1868,7 @@ let do_check_partial ~pred loc casel pss = match pss with Partial | ps::_ -> let counter_examples = - exhaust None pss (List.length ps) - |> Seq.filter_map (typecheck ~pred) in + exhaust None pss (List.length ps) |> Seq.filter_map pred in match counter_examples () with | Seq.Nil -> Total | Seq.Cons (v, _rest) -> @@ -2102,9 +2011,8 @@ let check_unused pred casel = 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 + let pattern = {u with pat_loc = q.pat_loc} in + match pred refute pattern with None when not refute -> Location.prerr_warning q.pat_loc Warnings.Unreachable_case; Used @@ -2404,52 +2312,17 @@ let pattern_stable_vars ns p = (* 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) -> + 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 + (* Use default iterator methods for rest of match.*) + | _ -> Tast_iterator.default_iterator.expr iter exp in let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in iterator.expr iterator exp; @@ -2481,27 +2354,21 @@ let check_ambiguous_bindings = in ignore (List.fold_left check_case [] cases) -let do_complete_partial ?pred pss = +let do_complete_partial ~(pred : pattern -> pattern option) 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) + pred p in exhaust None pss (List.length ps) |> Seq.filter_map typecheck |> List.of_seq -let complete_partial ~pred pss = +let complete_partial ~(pred : pattern -> pattern option) pss = let pss = get_mins le_pats pss in - do_complete_partial ~pred pss let return_unused casel = diff --git a/src/ocaml/typing/parmatch.mli b/src/ocaml/typing/parmatch.mli index f0ff75fc84..0fe0d50810 100644 --- a/src/ocaml/typing/parmatch.mli +++ b/src/ocaml/typing/parmatch.mli @@ -71,28 +71,18 @@ val complete_constrs : constructor_description list -> constructor_description list -(** [ppat_of_type] builds an untyped pattern from its expected type, +(** [pats_of_type] builds a list of patterns from a given 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]) + - the type is empty ([]) + - no further explosion is necessary ([Pat_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]). + or a single-variant type ([tp]) + - a list of patterns, in the case that all branches + are GADT constructors ([tp1; ..; tpn]). *) -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 pats_of_type : Env.t -> type_expr -> pattern list val pressure_variants: Env.t -> pattern list -> unit @@ -107,16 +97,9 @@ val pressure_variants_in_computation_pattern: [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 + (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 + (bool -> pattern -> pattern option) -> value case list -> unit (* Irrefutability tests *) val irrefutable : pattern -> bool @@ -138,12 +121,9 @@ val some_private_tag : label (*******************) val complete_partial : - pred:((label, constructor_description) Hashtbl.t -> - (label, label_description) Hashtbl.t -> - Parsetree.pattern -> pattern option) -> + pred:(pattern -> pattern option) -> pattern list list -> - (pattern * ((label, constructor_description) Hashtbl.t * - (label, label_description) Hashtbl.t) option) list + (pattern) 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 index 4190c27e6a..69b8f34a01 100644 --- a/src/ocaml/typing/path.ml +++ b/src/ocaml/typing/path.ml @@ -17,14 +17,25 @@ type t = Pident of Ident.t | Pdot of t * string | Papply of t * t + | Pextra_ty of t * extra_ty +and extra_ty = + | Pcstr_ty of string + | Pext_ty 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 + | (Pdot(p1, s1), Pdot(p2, s2)) -> + s1 = s2 && same p1 p2 | (Papply(fun1, arg1), Papply(fun2, arg2)) -> - same fun1 fun2 && same arg1 arg2 + same fun1 fun2 && same arg1 arg2 + | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> + let same_extra = match t1, t2 with + | (Pcstr_ty s1, Pcstr_ty s2) -> s1 = s2 + | (Pext_ty, Pext_ty) -> true + | ((Pcstr_ty _ | Pext_ty), _) -> false + in same_extra && same p1 p2 | (_, _) -> false let rec compare p1 p2 = @@ -37,16 +48,35 @@ let rec compare p1 p2 = | (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 + | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> + let h = compare_extra t1 t2 in + if h <> 0 then h else compare p1 p2 + | (Pident _, (Pdot _ | Papply _ | Pextra_ty _)) + | (Pdot _, (Papply _ | Pextra_ty _)) + | (Papply _, Pextra_ty _) + -> -1 + | ((Pextra_ty _ | Papply _ | Pdot _), Pident _) + | ((Pextra_ty _ | Papply _) , Pdot _) + | (Pextra_ty _, Papply _) + -> 1 +and compare_extra t1 t2 = + match (t1, t2) with + Pcstr_ty s1, Pcstr_ty s2 -> String.compare s1 s2 + | (Pext_ty, Pext_ty) + -> 0 + | (Pcstr_ty _, Pext_ty) + -> -1 + | (Pext_ty, Pcstr_ty _) + -> 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) -> + | Pdot(p, _) | Pextra_ty (p, _) -> find_free_opt ids p + | Papply(p1, p2) -> begin match find_free_opt ids p1 with | None -> find_free_opt ids p2 | Some _ as res -> res + end let exists_free ids p = match find_free_opt ids p with @@ -55,71 +85,56 @@ let exists_free ids p = let rec scope = function Pident id -> Ident.scope id - | Pdot(p, _s) -> scope p + | Pdot(p, _) | Pextra_ty (p, _) -> 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) -> + | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" + | Pextra_ty (p, Pext_ty) -> name ~paren p let rec print ppf = function | Pident id -> Ident.print_with_scope ppf id - | Pdot(p, s) -> Format.fprintf ppf "%a.%s" print p s + | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> + Format.fprintf ppf "%a.%s" print p s | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2 + | Pextra_ty (p, Pext_ty) -> print ppf p let rec head = function Pident id -> id - | Pdot(p, _s) -> head p + | Pdot(p, _) | Pextra_ty (p, _) -> head p | Papply _ -> assert false let flatten = let rec flatten acc = function | Pident id -> `Ok (id, acc) - | Pdot (p, s) -> flatten (s :: acc) p + | Pdot (p, s) | Pextra_ty (p, Pcstr_ty s) -> flatten (s :: acc) p | Papply _ -> `Contains_apply + | Pextra_ty (p, Pext_ty) -> flatten acc p 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 + | Pdot (p, _) | Pextra_ty (p, _) -> 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 + | Pdot(_, s) | Pextra_ty (_, Pcstr_ty s) -> s + | Papply(_, p) | Pextra_ty (p, Pext_ty) -> last p let is_constructor_typath p = - match constructor_typath p with - | Regular _ -> false - | _ -> true + match p with + | Pident _ | Pdot _ | Papply _ -> false + | Pextra_ty _ -> true module T = struct type nonrec t = t diff --git a/src/ocaml/typing/path.mli b/src/ocaml/typing/path.mli index bddf9d670a..39e76a3727 100644 --- a/src/ocaml/typing/path.mli +++ b/src/ocaml/typing/path.mli @@ -16,12 +16,49 @@ (* Access paths *) type t = - Pident of Ident.t + | Pident of Ident.t + (** Examples: x, List, int *) | Pdot of t * string + (** Examples: List.map, Float.Array *) | Papply of t * t + (** Examples: Set.Make(Int), Map.Make(Set.Make(Int)) *) + | Pextra_ty of t * extra_ty + (** [Pextra_ty (p, extra)] are additional paths of types + introduced by specific OCaml constructs. See below. + *) +and extra_ty = + | Pcstr_ty of string + (** [Pextra_ty (p, Pcstr_ty c)] is the type of the inline record for + constructor [c] inside type [p]. + + For example, in + {[ + type 'a t = Nil | Cons of {hd : 'a; tl : 'a t} + ]} + + The inline record type [{hd : 'a; tl : 'a t}] cannot + be named by the user in the surface syntax, but internally + it has the path + [Pextra_ty (Pident `t`, Pcstr_ty "Cons")]. + *) + | Pext_ty + (** [Pextra_ty (p, Pext_ty)] is the type of the inline record for + the extension constructor [p]. + + For example, in + {[ + type exn += Error of {loc : loc; msg : string} + ]} + + The inline record type [{loc : loc; msg : string}] cannot + be named by the user in the surface syntax, but internally + it has the path + [Pextra_ty (Pident `Error`, Pext_ty)]. + *) val same: t -> t -> bool val compare: t -> t -> int +val compare_extra: extra_ty -> extra_ty -> int val find_free_opt: Ident.t list -> t -> Ident.t option val exists_free: Ident.t list -> t -> bool val scope: t -> int @@ -37,15 +74,6 @@ 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 diff --git a/src/ocaml/typing/persistent_env.ml b/src/ocaml/typing/persistent_env.ml index 42811ee430..15bb94165c 100644 --- a/src/ocaml/typing/persistent_env.ml +++ b/src/ocaml/typing/persistent_env.ml @@ -200,7 +200,7 @@ let save_pers_struct penv crc ps pm = | Alerts _ -> () | Opaque -> register_import_as_opaque penv modname) ps.ps_flags; - Consistbl.set crc_units modname crc ps.ps_filename; + Consistbl.check crc_units modname crc ps.ps_filename; add_import penv modname let acknowledge_pers_struct penv short_path_comps check modname pers_sig pm = diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml index 450450870a..cba0d9c51d 100644 --- a/src/ocaml/typing/printtyp.ml +++ b/src/ocaml/typing/printtyp.ml @@ -42,7 +42,6 @@ let () = Env.print_longident := longident 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 *) @@ -56,15 +55,15 @@ let printing_env = ref Env.empty 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 = Shape.Sig_component_kind.t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type -type namespace = - | Type - | Module - | Module_type - | Class - | Class_type - | Other (** Other bypasses the unique name identifier mechanism *) module Namespace = struct @@ -74,49 +73,44 @@ module Namespace = struct | Module_type -> 2 | Class -> 3 | Class_type -> 4 - | Other -> 5 + | Extension_constructor | Value -> 5 + (* we do not handle those component *) - let size = 1 + id Other + let size = 1 + id Value - 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 pp ppf x = + Format.pp_print_string ppf (Shape.Sig_component_kind.to_string 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 + | Some Type -> to_lookup Env.find_type_by_name + | Some Module -> to_lookup Env.find_module_by_name + | Some Module_type -> to_lookup Env.find_modtype_by_name + | Some Class -> to_lookup Env.find_class_by_name + | Some Class_type -> to_lookup Env.find_cltype_by_name + | None | Some(Value|Extension_constructor) -> 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 + | Some Type -> (in_printing_env @@ Env.find_type path).type_loc + | Some Module -> (in_printing_env @@ Env.find_module path).md_loc + | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc + | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc + | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc + | Some (Extension_constructor|Value) | None -> Location.none ) with Not_found -> None let best_class_namespace = function - | Papply _ | Pdot _ -> Module + | Papply _ | Pdot _ -> Some Module + | Pextra_ty _ -> assert false (* Only in type path *) | Pident c -> - match location Class c with - | Some _ -> Class - | None -> Class_type + match location (Some Class) c with + | Some _ -> Some Class + | None -> Some Class_type end @@ -130,19 +124,37 @@ 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 add namespace name id = + match Namespace.location (Some namespace) id with + | None -> () + | Some location -> + let explanation = + { kind = namespace; location; name; root_name=Ident.name id} + in + explanations := M.add name explanation !explanations + + let collect_explanation namespace id ~name = 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 + (* if [name] is of the form "root_name/%d", we register both + [id] and the identifier in scope for [root_name]. + *) + if root_name <> name && not (M.mem name !explanations) then + begin + add namespace name id; + if not (M.mem root_name !explanations) then + (* lookup the identifier in scope with name [root_name] and + add it too + *) + match Namespace.lookup (Some namespace) root_name with + | Pident root_id -> add namespace root_name root_id + | exception Not_found | _ -> () + end let pp_explanation ppf r= Format.fprintf ppf "@[%a:@,Definition of %s %s@]" - Location.print_loc r.location (Namespace.show r.kind) r.name + Location.print_loc r.location + (Shape.Sig_component_kind.to_string r.kind) r.name let print_located_explanations ppf l = Format.fprintf ppf "@[%a@]" (Format.pp_print_list pp_explanation) l @@ -169,7 +181,7 @@ module Conflicts = struct | [namespace, a] -> Format.fprintf ppf "@ \ - @[<2>Hint: The %a %s has been defined multiple times@ \ + @[<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?@]" @@ -177,7 +189,7 @@ module Conflicts = struct | (namespace, _) :: _ :: _ -> Format.fprintf ppf "@ \ - @[<2>Hint: The %a %a have been defined multiple times@ \ + @[<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?@]" @@ -209,43 +221,30 @@ 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 +(* Names bound in recursive definitions should be considered as bound + in the environment when printing identifiers but not when trying + to find shortest path. + For instance, if we define + [{ + module Avoid__me = struct + type t = A + end + type t = X + type u = [` A of t * t ] + module M = struct + type t = A of [ u | `B ] + type r = Avoid__me.t + end + }] + It is is important that in the definition of [t] that the outer type [t] is + printed as [t/2] reserving the name [t] to the type being defined in the + current recursive definition. + Contrarily, in the definition of [r], one should not shorten the + path [Avoid__me.t] to [r] until the end of the definition of [r]. + The [bound_in_recursion] bridges the gap between those two slightly different + notions of printing environment. +*) +let bound_in_recursion = ref M.empty (* When dealing with functor arguments, identity becomes fuzzy because the same syntactic argument may be represented by different identifiers during the @@ -257,96 +256,86 @@ let with_arg id 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) + let update m id = M.add (Ident.name id.ident) id.ident m in + let updated = List.fold_left update !bound_in_recursion ids in + protect_refs [ R(bound_in_recursion, updated )] f + +let human_id id index = + (* The identifier with index [k] is the (k+1)-th most recent identifier in + the printing environment. We print them as [name/(k+1)] except for [k=0] + which is printed as [name] rather than [name/1]. + *) + if index = 0 then + 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)) + let ordinal = index + 1 in + String.concat "/" [Ident.name id; string_of_int ordinal] + +let indexed_name namespace id = + let find namespace id env = match namespace with + | Type -> Env.find_type_index id env + | Module -> Env.find_module_index id env + | Module_type -> Env.find_modtype_index id env + | Class -> Env.find_class_index id env + | Class_type-> Env.find_cltype_index id env + | Value | Extension_constructor -> None + in + let index = + match M.find_opt (Ident.name id) !bound_in_recursion with + | Some rec_bound_id -> + (* the identifier name appears in the current group of recursive + definition *) + if Ident.same rec_bound_id id then + Some 0 + else + (* the current recursive definition shadows one more time the + previously existing identifier with the same name *) + Option.map succ (in_printing_env (find namespace id)) + | None -> + in_printing_env (find namespace id) + in + let index = + (* If [index] is [None] at this point, it might indicate that + the identifier id is not defined in the environment, while there + are other identifiers in scope that share the same name. + Currently, this kind of partially incoherent environment happens + within functor error messages where the left and right hand side + have a different views of the environment at the source level. + Printing the source-level by using a default index of `0` + seems like a reasonable compromise in this situation however.*) + Option.value index ~default:0 + in + human_id id index +let ident_name namespace id = + match namespace, !enabled with + | None, _ | _, false -> Out_name.create (Ident.name id) + | Some namespace, true -> + if fuzzy_id namespace id then Out_name.create (Ident.name id) + else + let name = indexed_name namespace id in + Conflicts.collect_explanation namespace id ~name; + Out_name.create name 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)) + (Out_name.print (Naming_context.ident_name None id)) + +let namespaced_ident namespace id = + Out_name.print (Naming_context.ident_name (Some namespace) id) + (* Print a path *) let ident_stdlib = Ident.create_persistent "Stdlib" -let non_shadowed_pervasive = function - | Pdot(Pident id, _) -> Ident.same id ident_stdlib +let non_shadowed_stdlib namespace = function + | Pdot(Pident id, s) as path -> + Ident.same id ident_stdlib && + (match Namespace.lookup namespace s with + | path' -> Path.same path path' + | exception Not_found -> true) | _ -> false let find_double_underscore s = @@ -378,6 +367,8 @@ let rec rewrite_double_underscore_paths env p = | Papply (a, b) -> Papply (rewrite_double_underscore_paths env a, rewrite_double_underscore_paths env b) + | Pextra_ty (p, extra) -> + Pextra_ty (rewrite_double_underscore_paths env p, extra) | Pident id -> let name = Ident.name id in match find_double_underscore name with @@ -403,31 +394,41 @@ let rewrite_double_underscore_paths env p = else rewrite_double_underscore_paths env p -let rec tree_of_path namespace = function +let rec tree_of_path ?(disambiguation=true) namespace p = + let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in + let namespace = if disambiguation then namespace else None in + match p with | 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(_, s) as path when non_shadowed_stdlib namespace path -> + Oide_ident (Out_name.create s) | Pdot(p, s) -> - Oide_dot (tree_of_path Module p, s) + Oide_dot (tree_of_path (Some Module) p, s) | Papply(p1, p2) -> - Oide_apply (tree_of_path Module p1, tree_of_path Module p2) + let t1 = tree_of_path (Some Module) p1 in + let t2 = tree_of_path (Some Module) p2 in + Oide_apply (t1, t2) + | Pextra_ty (p, extra) -> begin + (* inline record types are syntactically prevented from escaping their + binding scope, and are never shown to users. *) + match extra with + Pcstr_ty s -> + Oide_dot (tree_of_path (Some Type) p, s) + | Pext_ty -> + tree_of_path None p + end -let tree_of_path namespace p = - tree_of_path namespace (rewrite_double_underscore_paths !printing_env p) +let tree_of_path ?disambiguation namespace p = + tree_of_path ?disambiguation namespace + (rewrite_double_underscore_paths !printing_env p) let path ppf p = - !Oprint.out_ident ppf (tree_of_path Other p) + !Oprint.out_ident ppf (tree_of_path None 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 @@ -576,7 +577,6 @@ let set_printing_env 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 = @@ -637,6 +637,13 @@ let best_class_type_path_simple p = then p else Short_paths.find_class_type_simple (Env.short_paths !printing_env) p +(* When building a tree for a best type path, we should not disambiguate + identifiers whenever the short-path algorithm detected a better path than + the original one.*) +let tree_of_best_type_path p p' = + if Path.same p p' then tree_of_path (Some Type) p' + else tree_of_path ~disambiguation:false None p' + (* Print a type expression *) let proxy ty = Transient_expr.repr (proxy ty) @@ -707,10 +714,10 @@ module Names : sig val add_subst : (type_expr * type_expr) list -> unit val new_name : unit -> string - val new_weak_name : type_expr -> unit -> string + val new_var_name : non_gen:bool -> type_expr -> unit -> string val name_of_type : (unit -> string) -> transient_expr -> string - val check_name_of_type : transient_expr -> unit + val check_name_of_type : non_gen:bool -> transient_expr -> unit val remove_names : transient_expr list -> unit @@ -795,6 +802,10 @@ end = struct name end + let new_var_name ~non_gen ty () = + if non_gen then new_weak_name ty () + else new_name () + 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. *) @@ -807,16 +818,16 @@ end = struct (* 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 + let available name = + List.for_all + (fun (_, name') -> name <> name') + !names + in + if available name then name + else + let suffixed i = name ^ Int.to_string i in + let i = Misc.find_first_mono (fun i -> available (suffixed i)) in + suffixed i | _ -> (* No name available, create a new one *) name_generator () @@ -825,7 +836,9 @@ end = struct if name <> "_" then names := (t, name) :: !names; name - let check_name_of_type t = ignore(name_of_type new_name t) + let check_name_of_type ~non_gen px = + let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in + ignore(name_of_type name_gen px) let remove_names tyl = let tyl = List.map substitute tyl in @@ -880,8 +893,8 @@ let add_alias_proxy px = let add_alias ty = add_alias_proxy (proxy ty) -let add_printed_alias_proxy px = - Names.check_name_of_type px; +let add_printed_alias_proxy ~non_gen px = + Names.check_name_of_type ~non_gen px; printed_aliases := px :: !printed_aliases let add_printed_alias ty = add_printed_alias_proxy (proxy ty) @@ -1003,7 +1016,7 @@ let reset_except_context () = Names.reset_names (); reset_loop_marks () let reset () = - reset_naming_context (); Conflicts.reset (); + Conflicts.reset (); reset_except_context () let prepare_for_printing tyl = @@ -1015,24 +1028,26 @@ let add_type_to_preparation = prepare_type (* Disabled in classic mode when printing an unification error *) let print_labels = ref true +let alias_nongen_row mode px ty = + match get_desc ty with + | Tvariant _ | Tobject _ -> + if is_non_gen mode (Transient_expr.type_expr px) then + add_alias_proxy px + | _ -> () + let rec tree_of_typexp mode ty = let px = proxy ty in if List.memq px !printed_aliases && not (List.memq px !delayed) then - let mark = is_non_gen mode ty in - let name = Names.name_of_type - (if mark then Names.new_weak_name ty else Names.new_name) - px - in - Otyp_var (mark, name) else + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + let name = Names.name_of_type (Names.new_var_name ~non_gen ty) px in + Otyp_var (non_gen, name) else let pr_typ () = let tty = Transient_expr.repr ty in match tty.desc with | Tvar _ -> let non_gen = is_non_gen mode ty in - let name_gen = - if non_gen then Names.new_weak_name ty else Names.new_name - in + let name_gen = Names.new_var_name ~non_gen ty in Otyp_var (non_gen, Names.name_of_type name_gen tty) | Tarrow(l, ty1, ty2, _) -> let lab = @@ -1054,10 +1069,10 @@ let rec tree_of_typexp mode ty = | Nth n -> tree_of_typexp mode (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 mode tyl') + Otyp_constr (tree_of_path (Some Type) p, tree_of_typlist mode tyl') end | Tvariant row -> - let Row {fields; name; closed} = row_repr row in + let Row {fields; name; closed; _} = row_repr row in let fields = if closed then List.filter (fun (_, f) -> row_field_repr f <> Rabsent) @@ -1077,25 +1092,21 @@ let rec tree_of_typexp mode ty = match best_type_path p with | Nth n -> tree_of_typexp mode (apply_nth n tyl) | Path(s, p) -> - let id = tree_of_path Type p in + let id = tree_of_path (Some Type) p in let args = tree_of_typlist mode (apply_subst_opt s tyl) in Otyp_constr (id, args) in if closed && all_present then out_variant else - let non_gen = is_non_gen mode (Transient_expr.type_expr px) in let tags = if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_typ out_variant, closed, tags) + Otyp_variant (Ovar_typ out_variant, closed, tags) | _ -> - let non_gen = - not (closed && all_present) && - is_non_gen mode (Transient_expr.type_expr px) in let fields = List.map (tree_of_row_field mode) fields in let tags = if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_fields fields, closed, tags) + Otyp_variant (Ovar_fields fields, closed, tags) end | Tobject (fi, nm) -> tree_of_typobject mode fi !nm @@ -1134,12 +1145,17 @@ let rec tree_of_typexp mode ty = String.concat "." (Longident.flatten li), tree_of_typexp mode ty )) fl in - Otyp_module (tree_of_path Module_type p, fl) + Otyp_module (tree_of_path (Some Module_type) p, fl) in if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; + alias_nongen_row mode px ty; if is_aliased_proxy px && aliasable ty then begin - add_printed_alias_proxy px; - Otyp_alias (pr_typ (), Names.name_of_type Names.new_name px) end + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + add_printed_alias_proxy ~non_gen px; + (* add_printed_alias chose a name, thus the name generator + doesn't matter.*) + let alias = Names.name_of_type (Names.new_var_name ~non_gen ty) px in + Otyp_alias {non_gen; aliased = pr_typ (); alias } end else pr_typ () and tree_of_row_field mode (l, f) = @@ -1171,28 +1187,25 @@ and tree_of_typobject mode fi nm = List.sort (fun (n, _) (n', _) -> String.compare n n') present_fields in tree_of_typfields mode 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 mode ty in + let (fields, open_row) = pr_fields fi in + Otyp_object {fields; open_row} + | Some (p, _ty :: tyl) -> let args = tree_of_typlist mode tyl in - let p = best_type_path_simple p in - Otyp_class (non_gen, tree_of_path Type p, args) - end + let p' = best_type_path_simple p in + Otyp_class (tree_of_best_type_path p p', args) | _ -> fatal_error "Printtyp.tree_of_typobject" end and tree_of_typfields mode rest = function | [] -> - let rest = + let open_row = match get_desc rest with - | Tvar _ | Tunivar _ -> Some (is_non_gen mode rest) - | Tconstr _ -> Some false - | Tnil -> None + | Tvar _ | Tunivar _ | Tconstr _-> true + | Tnil -> false | _ -> fatal_error "typfields (1)" in - ([], rest) + ([], open_row) | (s, t) :: l -> let field = (s, tree_of_typexp mode t) in let (fields, rest) = tree_of_typfields mode rest l in @@ -1202,6 +1215,7 @@ let typexp mode ppf ty = !Oprint.out_type ppf (tree_of_typexp mode ty) let prepared_type_expr ppf ty = typexp Type ppf ty +let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty let type_expr ppf ty = (* [type_expr] is used directly by error message printers, @@ -1222,11 +1236,11 @@ let shared_type_scheme ppf ty = let type_scheme ppf ty = prepare_for_printing [ty]; - typexp Type_scheme ppf ty + prepared_type_scheme ppf ty let type_path ppf p = let p = best_class_type_path_simple p in - let t = tree_of_path Type p in + let t = tree_of_path (Some Type) p in !Oprint.out_ident ppf t let tree_of_type_scheme ty = @@ -1263,12 +1277,38 @@ let prepare_type_constructor_arguments = function | Cstr_tuple l -> List.iter prepare_type l | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l -let rec tree_of_type_decl id decl = +let tree_of_label l = + (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type l.ld_type) - reset_except_context(); +let tree_of_constructor_arguments = function + | Cstr_tuple l -> tree_of_typlist Type l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] - let params = filter_params decl.type_params in +let tree_of_single_constructor cd = + let name = Ident.name cd.cd_id in + let ret = Option.map (tree_of_typexp Type) cd.cd_res in + let args = tree_of_constructor_arguments cd.cd_args in + { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +(* When printing GADT constructor, we need to forget the naming decision we took + for the type parameters and constraints. Indeed, in + {[ + type 'a t = X: 'a -> 'b t + ]} + It is fine to print both the type parameter ['a] and the existentially + quantified ['a] in the definition of the constructor X as ['a] + *) +let tree_of_constructor_in_decl cd = + match cd.cd_res with + | None -> tree_of_single_constructor cd + | Some _ -> Names.with_local_names (fun () -> tree_of_single_constructor cd) +let prepare_decl id decl = + let params = filter_params decl.type_params in begin match decl.type_manifest with | Some ty -> let vars = free_variables ty in @@ -1279,10 +1319,9 @@ let rec tree_of_type_decl id decl = params | None -> () end; - List.iter add_alias params; List.iter prepare_type params; - List.iter add_printed_alias params; + List.iter (add_printed_alias ~non_gen:false) params; let ty_manifest = match decl.type_manifest with | None -> None @@ -1313,7 +1352,10 @@ let rec tree_of_type_decl id decl = List.iter (fun l -> prepare_type l.ld_type) l | Type_open -> () end; + ty_manifest, params +let tree_of_type_decl id decl = + let ty_manifest, params = prepare_decl id decl in let type_param = function | Otyp_var (_, id) -> id @@ -1371,7 +1413,8 @@ let rec tree_of_type_decl id decl = tree_of_typexp Type ty, decl.type_private, false end | Type_variant (cstrs, rep) -> - tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), + tree_of_manifest + (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)), decl.type_private, (rep = Variant_unboxed) | Type_record(lbls, rep) -> @@ -1391,37 +1434,27 @@ let rec tree_of_type_decl id decl = otype_unboxed = unboxed; otype_cstrs = constraints } -and tree_of_constructor_arguments = function - | Cstr_tuple l -> tree_of_typlist Type l - | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] +let add_type_decl_to_preparation id decl = + ignore @@ prepare_decl id decl -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 -> { - ocstr_name = name; - ocstr_args = arg (); - ocstr_return_type = None; - } - | Some res -> - Names.with_local_names (fun () -> - let ret = tree_of_typexp Type res in - let args = arg () in - { - ocstr_name = name; - ocstr_args = args; - ocstr_return_type = Some ret; - }) - -and tree_of_label l = - (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type l.ld_type) +let tree_of_prepared_type_decl id decl = + tree_of_type_decl id decl + +let tree_of_type_decl id decl = + reset_except_context(); + tree_of_type_decl id decl + +let add_constructor_to_preparation c = + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res + +let prepared_constructor ppf c = + !Oprint.out_constr ppf (tree_of_single_constructor c) let constructor ppf c = reset_except_context (); - prepare_type_constructor_arguments c.cd_args; - Option.iter prepare_type c.cd_res; - !Oprint.out_constr ppf (tree_of_constructor c) + add_constructor_to_preparation c; + prepared_constructor ppf c let label ppf l = reset_except_context (); @@ -1431,9 +1464,19 @@ let label ppf l = let tree_of_type_declaration id decl rs = Osig_type (tree_of_type_decl id decl, tree_of_rec rs) +let tree_of_prepared_type_declaration id decl rs = + Osig_type (tree_of_prepared_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 add_type_declaration_to_preparation id decl = + add_type_decl_to_preparation id decl + +let prepared_type_declaration id ppf decl = + !Oprint.out_sig_item ppf + (tree_of_prepared_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) @@ -1441,31 +1484,62 @@ let constructor_arguments ppf a = (* 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 -> - Names.with_local_names (fun () -> - let ret = tree_of_typexp Type res in - let args = tree_of_constructor_arguments ext_args in - (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 ret = Option.map (tree_of_typexp Type) ext_ret_type in + let args = tree_of_constructor_arguments ext_args in + (args, ret) + +(* When printing extension constructor, it is important to ensure that +after printing the constructor, we are still in the scope of the constructor. +For GADT constructor, this can be done by printing the type parameters inside +their own isolated scope. This ensures that in +{[ + type 'b t += A: 'b -> 'b any t +]} +the type parameter `'b` is not bound when printing the type variable `'b` from +the constructor definition from the type parameter. + +Contrarily, for non-gadt constructor, we must keep the same scope for +the type parameters and the constructor because a type constraint may +have changed the name of the type parameter: +{[ +type -'a t = .. constraint 'a> = 'a +(* the universal 'a is here to steal the name 'a from the type parameter *) +type 'a t = X of 'a +]} *) + +let add_extension_constructor_to_preparation ext = let ty_params = filter_params ext.ext_type_params in List.iter add_alias ty_params; List.iter prepare_type ty_params; - List.iter add_printed_alias ty_params; prepare_type_constructor_arguments ext.ext_args; - Option.iter prepare_type ext.ext_ret_type; + Option.iter prepare_type ext.ext_ret_type + +let prepared_tree_of_extension_constructor + id ext es + = + 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 let type_param = function | Otyp_var (_, id) -> id | _ -> "?" in + let param_scope f = + match ext.ext_ret_type with + | None -> + (* normal constructor: same scope for parameters and the constructor *) + f () + | Some _ -> + (* gadt constructor: isolated scope for the type parameters *) + Names.with_local_names f + in let ty_params = - List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params + param_scope + (fun () -> + List.iter (add_printed_alias ~non_gen:false) ty_params; + List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params + ) in let name = Ident.name id in let args, ret = @@ -1489,9 +1563,18 @@ let tree_of_extension_constructor id ext es = in Osig_typext (ext, es) +let tree_of_extension_constructor id ext es = + reset_except_context (); + add_extension_constructor_to_preparation ext; + prepared_tree_of_extension_constructor id ext es + let extension_constructor id ppf ext = !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) +let prepared_extension_constructor id ppf ext = + !Oprint.out_sig_item ppf + (prepared_tree_of_extension_constructor id ext Text_first) + let extension_only_constructor id ppf ext = reset_except_context (); prepare_type_constructor_arguments ext.ext_args; @@ -1662,8 +1745,8 @@ let tree_of_class_declaration id cl rs = let px = proxy (Btype.self_type_row cl.cty_type) in List.iter prepare_type params; - List.iter add_printed_alias params; - if is_aliased_proxy px then add_printed_alias_proxy px; + List.iter (add_printed_alias ~non_gen:false) params; + if is_aliased_proxy px then add_printed_alias_proxy ~non_gen:false px; let vir_flag = cl.cty_new = None in Osig_class @@ -1684,8 +1767,8 @@ let tree_of_cltype_declaration id cl rs = let px = proxy (Btype.self_type_row cl.clty_type) in List.iter prepare_type params; - List.iter add_printed_alias params; - if is_aliased_proxy px then add_printed_alias_proxy px; + List.iter (add_printed_alias ~non_gen:false) params; + if is_aliased_proxy px then (add_printed_alias_proxy ~non_gen:false) px; let sign = Btype.signature_of_class_type cl.clty_type in let has_virtual_vars = @@ -1770,7 +1853,7 @@ let add_sigitem env x = 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) + Omty_ident (tree_of_path (Some Module_type) p) | Mty_signature sg -> Omty_signature (if ellipsis then [Osig_ellipsis] else tree_of_signature sg) @@ -1782,7 +1865,7 @@ let rec tree_of_modtype ?(ellipsis=false) = function Omty_functor (param, res) | Mty_alias p -> let p = best_module_path p in - Omty_alias (tree_of_path Module p) + Omty_alias (tree_of_path (Some Module) p) | Mty_for_hole -> Omty_hole and tree_of_functor_parameter = function @@ -1809,8 +1892,7 @@ and tree_of_signature_rec env' sg = 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) + trees_of_recursive_sigitem_group env group in set_printing_env env'; (env, group_trees) in @@ -1888,7 +1970,6 @@ let modtype_declaration id ppf decl = let print_items showval env x = Names.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 @@ -1906,7 +1987,6 @@ let signature ppf sg = 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 () @@ -1981,8 +2061,8 @@ let trees_of_trace mode = List.map (Errortrace.map_diff (trees_of_type_expansion mode)) 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') + if Path.same tp tp' then Same(tree_of_path (Some Type) tp) else + Diff(tree_of_path (Some Type) tp, tree_of_path (Some Type) tp') let type_path_expansion ppf = function | Same p -> !Oprint.out_ident ppf p @@ -1994,7 +2074,7 @@ let type_path_expansion ppf = function 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" + fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@]%a" type_expansion got txt type_expansion expected (trace false txt) rem | _ -> () @@ -2041,18 +2121,15 @@ let prepare_any_trace printing_status tr = let prepare_trace f tr = prepare_any_trace printing_status (Errortrace.map f tr) -(** Keep elements that are not [Diff _ ] and take the decision +(** Keep elements that are [Diff _ ] and take the decision for the last element, require a prepared trace *) -let rec filter_trace - (trace_format : 'variety trace_format) - keep_last - : ('a, 'variety) Errortrace.t -> _ = function +let rec filter_trace 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 + | Errortrace.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) @@ -2082,7 +2159,8 @@ let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = reserve_names ty; Errortrace.{ty; expanded = ty} | _ -> prepare_expansion ty_exp -let print_path p = Format.dprintf "%a" !Oprint.out_ident (tree_of_path Type p) +let print_path p = + Format.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p) let print_tag ppf = fprintf ppf "`%s" @@ -2110,12 +2188,12 @@ let explanation_diff env t3 t4 : (Format.formatter -> unit) option = when is_unit env ty1 && unifiable env ty2 t4 -> Some (fun ppf -> fprintf ppf - "@,@[Hint: Did you forget to provide `()' as argument?@]") + "@,@[@{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 \ + "@,@[@{Hint@}: Did you forget to wrap the expression using \ `fun () ->'?@]") | _ -> None @@ -2323,7 +2401,7 @@ let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = | elt :: tr -> try print_labels := not !Clflags.classic; - let tr = filter_trace trace_format (mis = None) tr in + let tr = filter_trace (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 mode txt1 txt2 head in @@ -2407,8 +2485,6 @@ module Subtype = struct 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] @@ -2444,7 +2520,7 @@ module Subtype = struct if tr_unif = [] then fprintf ppf "@]" else let mis = mismatch (dprintf "Within this type") env tr_unif in fprintf ppf "%a%t%t@]" - (trace filter_unification_trace unification_get_diff false + (trace filter_trace unification_get_diff false (mis = None) "is not compatible with type") tr_unif (explain mis) Conflicts.print_explanations @@ -2473,7 +2549,7 @@ let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 = txt3 type_path_expansion tp0) (* Adapt functions to exposed interface *) -let tree_of_path = tree_of_path Other +let tree_of_path = tree_of_path None let tree_of_modtype = tree_of_modtype ~ellipsis:false let type_expansion mode ppf ty_exp = type_expansion ppf (trees_of_type_expansion mode ty_exp) diff --git a/src/ocaml/typing/printtyp.mli b/src/ocaml/typing/printtyp.mli index 653abc8d14..2769fe0322 100644 --- a/src/ocaml/typing/printtyp.mli +++ b/src/ocaml/typing/printtyp.mli @@ -21,6 +21,7 @@ open Outcometree val longident: formatter -> Longident.t -> unit val ident: formatter -> Ident.t -> unit +val namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string val tree_of_path: Path.t -> out_ident val path: formatter -> Path.t -> unit val string_of_path: Path.t -> string @@ -34,13 +35,7 @@ module Out_name: sig val print: out_name -> string end -type namespace = - | Type - | Module - | Module_type - | Class - | Class_type - | Other (** Other bypasses the unique name for identifier mechanism *) +type namespace := Shape.Sig_component_kind.t option val strings_of_paths: namespace -> Path.t list -> string list (** Print a list of paths, using the same naming context to @@ -62,9 +57,6 @@ 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 @@ -76,7 +68,7 @@ module Conflicts: sig an identifier to avoid a name collision *) type explanation = - { kind: namespace; + { kind: Shape.Sig_component_kind.t; name:string; root_name:string; location:Location.t @@ -132,6 +124,7 @@ val prepared_type_expr: formatter -> type_expr -> unit val constructor_arguments: formatter -> constructor_arguments -> unit val tree_of_type_scheme: type_expr -> out_type val type_scheme: formatter -> type_expr -> unit +val prepared_type_scheme: formatter -> type_expr -> unit val shared_type_scheme: formatter -> type_expr -> unit (** [shared_type_scheme] is very similar to [type_scheme], but does not reset the printing context first. This is intended to be used in cases where the @@ -142,12 +135,21 @@ val shared_type_scheme: formatter -> type_expr -> unit 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 add_constructor_to_preparation : constructor_declaration -> unit +val prepared_constructor : formatter -> constructor_declaration -> unit val constructor : formatter -> constructor_declaration -> unit val tree_of_type_declaration: Ident.t -> type_declaration -> rec_status -> out_sig_item +val add_type_declaration_to_preparation : + Ident.t -> type_declaration -> unit +val prepared_type_declaration: Ident.t -> formatter -> type_declaration -> unit val type_declaration: Ident.t -> formatter -> type_declaration -> unit val tree_of_extension_constructor: Ident.t -> extension_constructor -> ext_status -> out_sig_item +val add_extension_constructor_to_preparation : + extension_constructor -> unit +val prepared_extension_constructor: + Ident.t -> formatter -> extension_constructor -> unit val extension_constructor: Ident.t -> formatter -> extension_constructor -> unit (* Prints extension constructor with the type signature: diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml index d2976712ac..67afedcdbf 100644 --- a/src/ocaml/typing/printtyped.ml +++ b/src/ocaml/typing/printtyped.ml @@ -53,9 +53,11 @@ let fmt_modname f = function 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.Pdot (y, s) | Path.(Pextra_ty (y, Pcstr_ty 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 + | Path.Pextra_ty (y, Pext_ty) -> fmt_path_aux f y let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x @@ -413,7 +415,7 @@ and expression i ppf x = line i ppf "Texp_letexception\n"; extension_constructor i ppf cd; expression i ppf e; - | Texp_assert (e) -> + | Texp_assert (e, _) -> line i ppf "Texp_assert"; expression i ppf e; | Texp_lazy (e) -> @@ -813,6 +815,9 @@ and module_expr i ppf x = line i ppf "Tmod_apply\n"; module_expr i ppf me1; module_expr i ppf me2; + | Tmod_apply_unit me1 -> + line i ppf "Tmod_apply_unit\n"; + module_expr i ppf me1; | Tmod_constraint (me, _, Tmodtype_explicit mt, _) -> line i ppf "Tmod_constraint\n"; module_expr i ppf me; diff --git a/src/ocaml/typing/rec_check.ml b/src/ocaml/typing/rec_check.ml index 99802cbf51..6dae3a0a95 100644 --- a/src/ocaml/typing/rec_check.ml +++ b/src/ocaml/typing/rec_check.ml @@ -27,7 +27,7 @@ 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 @@ -250,7 +250,7 @@ let classify_expression : Typedtree.expression -> sd = *) Dynamic end - | Path.Pdot _ | Path.Papply _ -> + | Path.Pdot _ | Path.Papply _ | Path.Pextra_ty _ -> (* local modules could have such paths to local definitions; classify_expression could be extend to compute module shapes more precisely *) @@ -733,7 +733,7 @@ let rec expression : Typedtree.expression -> term_judg = G |- let exception A in e: m *) remove_id ext_id (expression e) - | Texp_assert e -> + | Texp_assert (e, _) -> (* G |- e: m[Dereference] ----------------------- @@ -869,6 +869,8 @@ and modexp : Typedtree.module_expr -> term_judg = modexp f << Dereference; modexp p << Dereference; ] + | Tmod_apply_unit f -> + modexp f << Dereference | Tmod_constraint (mexp, _, _, coe) -> let rec coercion coe k = match coe with | Tcoerce_none -> @@ -919,6 +921,8 @@ and path : Path.t -> term_judg = path f << Dereference; path p << Dereference; ] + | Path.Pextra_ty (p, _extra) -> + path p (* G |- struct ... end : m *) and structure : Typedtree.structure -> term_judg = diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml index 8bd04f4dd5..fb8966077c 100644 --- a/src/ocaml/typing/shape.ml +++ b/src/ocaml/typing/shape.ml @@ -143,8 +143,20 @@ let print fmt = | Var id -> Format.fprintf fmt "%a%a" Ident.print id print_uid_opt uid | Abs (id, t) -> + let rec collect_idents = function + | { uid = None; desc = Abs(id, t) } -> + let (ids, body) = collect_idents t in + id :: ids, body + | body -> + ([], body) + in + let (other_idents, body) = collect_idents t in + let pp_idents fmt idents = + let pp_sep fmt () = Format.fprintf fmt ",@ " in + Format.pp_print_list ~pp_sep Ident.print fmt idents + in Format.fprintf fmt "Abs@[%a@,(@[%a,@ @[%a@]@])@]" - print_uid_opt uid Ident.print id aux t + print_uid_opt uid pp_idents (id :: other_idents) aux body | App (t1, t2) -> Format.fprintf fmt "@[%a(@,%a)%a@]" aux t1 aux t2 print_uid_opt uid @@ -166,7 +178,7 @@ let print fmt = | Struct map -> let print_map fmt = Item.Map.iter (fun item t -> - Format.fprintf fmt "@[%a ->@ %a;@]@," + Format.fprintf fmt "@[%a ->@ %a;@]@," Item.print item aux t ) @@ -502,6 +514,11 @@ let of_path ~find_shape ~namespace = | Pident id -> find_shape ns id | Pdot (path, name) -> proj (aux Module path) (name, ns) | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) + | Pextra_ty (path, extra) -> begin + match extra with + Pcstr_ty _ -> aux Type path + | Pext_ty -> aux Extension_constructor path + end in aux namespace diff --git a/src/ocaml/typing/short_paths.ml b/src/ocaml/typing/short_paths.ml index efc423e375..9493afbf70 100644 --- a/src/ocaml/typing/short_paths.ml +++ b/src/ocaml/typing/short_paths.ml @@ -1531,6 +1531,7 @@ module Shortest = struct Application { kind; node; origin; best; min; max; func; arg; func_first; searched; finished } + | Path.Pextra_ty _ -> raise Not_found in loop kind canonical_path diff --git a/src/ocaml/typing/short_paths_graph.ml b/src/ocaml/typing/short_paths_graph.ml index 5266317120..c3d9d8bfcd 100644 --- a/src/ocaml/typing/short_paths_graph.ml +++ b/src/ocaml/typing/short_paths_graph.ml @@ -25,42 +25,13 @@ module Path = struct | Pident of Ident.t | Pdot of t * string | Papply of t * t + | Pextra_ty of t * Path.extra_ty - open Path + (* 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 + let equal t1 t2 = Path.same t1 t2 + + let compare t1 t2 = Path.compare t1 t2 end @@ -1390,6 +1361,8 @@ end = struct | Path.Papply(p, arg) -> let md = find_module t p in Module.find_application t md arg + | Path.Pextra_ty _ -> + raise Not_found let find_type t path = match path with @@ -1398,7 +1371,7 @@ end = struct | Path.Pdot(p, name) -> let md = find_module t p in Module.find_type t md name - | Path.Papply _ -> + | Path.Papply _ | Path.Pextra_ty _ -> raise Not_found let find_class_type t path = @@ -1408,7 +1381,7 @@ end = struct | Path.Pdot(p, name) -> let md = find_module t p in Module.find_class_type t md name - | Path.Papply _ -> + | Path.Papply _ | Path.Pextra_ty _ -> raise Not_found let find_module_type t path = @@ -1418,7 +1391,7 @@ end = struct | Path.Pdot(p, name) -> let md = find_module t p in Module.find_module_type t md name - | Path.Papply _ -> + | Path.Papply _ | Path.Pextra_ty _ -> raise Not_found let canonical_type_path t id = @@ -1458,7 +1431,7 @@ end = struct let rec is_module_path_visible t = function | Path.Pident id -> is_module_ident_visible t id - | Path.Pdot(path, _) -> + | Path.Pdot(path, _) | Pextra_ty (path, _) -> is_module_path_visible t path | Path.Papply(path1, path2) -> is_module_path_visible t path1 @@ -1481,7 +1454,7 @@ end = struct 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.Pdot(path, _) | Pextra_ty (path, _) -> is_module_path_visible t path | Path.Papply _ -> failwith "Short_paths_graph.Graph.is_type_path_visible: \ @@ -1505,7 +1478,7 @@ end = struct 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 _ -> + | Path.Papply _ | Path.Pextra_ty _ -> failwith "Short_paths_graph.Graph.is_class_type_path_visible: \ invalid class type path" @@ -1528,7 +1501,7 @@ end = struct 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 _ -> + | Path.Papply _ | Path.Pextra_ty _ -> failwith "Short_paths_graph.Graph.is_module_type_path_visible: \ invalid module type path" diff --git a/src/ocaml/typing/short_paths_graph.mli b/src/ocaml/typing/short_paths_graph.mli index 5f02176416..82d02b04ca 100644 --- a/src/ocaml/typing/short_paths_graph.mli +++ b/src/ocaml/typing/short_paths_graph.mli @@ -34,6 +34,7 @@ module Path : sig | Pident of Ident.t | Pdot of t * string | Papply of t * t + | Pextra_ty of t * Path.extra_ty val equal : t -> t -> bool diff --git a/src/ocaml/typing/signature_group.ml b/src/ocaml/typing/signature_group.ml index b2cc7d4910..b98a9eb67f 100644 --- a/src/ocaml/typing/signature_group.ml +++ b/src/ocaml/typing/signature_group.ml @@ -46,16 +46,16 @@ let next_group = function 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] *) + declarations of class type [c], and type [c] *) begin match q with - | ct::t::ht::q -> [ct;t;ht], q + | ct::t::q -> [ct;t], 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] *) + declaration of type [ct] *) begin match q with - | t::ht::q -> [t;ht], q + | t::q -> [t], q | _ -> assert false end | Types.(Sig_module _ | Sig_value _ | Sig_type _ | Sig_typext _ diff --git a/src/ocaml/typing/subst.ml b/src/ocaml/typing/subst.ml index d77b73b592..deef66768e 100644 --- a/src/ocaml/typing/subst.ml +++ b/src/ocaml/typing/subst.ml @@ -98,6 +98,8 @@ let rec module_path s path = Pdot(module_path s p, n) | Papply(p1, p2) -> Papply(module_path s p1, module_path s p2) + | Pextra_ty _ -> + fatal_error "Subst.module_path" let modtype_path s path = match Path.Map.find path s.modtypes with @@ -108,11 +110,18 @@ let modtype_path s path = match path with | Pdot(p, n) -> Pdot(module_path s p, n) - | Papply _ -> + | Papply _ | Pextra_ty _ -> fatal_error "Subst.modtype_path" | Pident _ -> path -let type_path s path = +(* For values, extension constructors, classes and class types *) +let value_path s path = + match path with + | Pident _ -> path + | Pdot(p, n) -> Pdot(module_path s p, n) + | Papply _ | Pextra_ty _ -> fatal_error "Subst.value_path" + +let rec type_path s path = match Path.Map.find path s.types with | Path p -> p | Type_function _ -> assert false @@ -123,13 +132,10 @@ let type_path s path = 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) + | Pextra_ty (p, extra) -> + match extra with + | Pcstr_ty _ -> Pextra_ty (type_path s p, extra) + | Pext_ty -> Pextra_ty (value_path s p, extra) let to_subst_by_type_function s p = match Path.Map.find p s.types with @@ -384,6 +390,7 @@ let cltype_declaration' copy_scope s decl = clty_variance = decl.clty_variance; clty_type = class_type copy_scope s decl.clty_type; clty_path = type_path s decl.clty_path; + clty_hash_type = type_declaration' copy_scope s decl.clty_hash_type ; clty_loc = loc s decl.clty_loc; clty_attributes = attrs s decl.clty_attributes; clty_uid = decl.clty_uid; @@ -587,7 +594,7 @@ and subst_lazy_modtype scoping s = function | Pident _ -> MtyL_ident p | Pdot(p, n) -> MtyL_ident(Pdot(module_path s p, n)) - | Papply _ -> + | Papply _ | Pextra_ty _ -> fatal_error "Subst.modtype" end end diff --git a/src/ocaml/typing/tast_iterator.ml b/src/ocaml/typing/tast_iterator.ml index 98bc77dfb5..049dded4ff 100644 --- a/src/ocaml/typing/tast_iterator.ml +++ b/src/ocaml/typing/tast_iterator.ml @@ -18,6 +18,8 @@ open Typedtree type iterator = { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attributes -> unit; binding_op: iterator -> binding_op -> unit; case: 'k . iterator -> 'k case -> unit; class_declaration: iterator -> class_declaration -> unit; @@ -32,6 +34,7 @@ type iterator = env: iterator -> Env.t -> unit; expr: iterator -> expression -> unit; extension_constructor: iterator -> extension_constructor -> unit; + location: iterator -> Location.t -> unit; module_binding: iterator -> module_binding -> unit; module_coercion: iterator -> module_coercion -> unit; module_declaration: iterator -> module_declaration -> unit; @@ -61,22 +64,55 @@ type iterator = with_constraint: iterator -> with_constraint -> unit; } +let iter_snd f (_, y) = f y +let iter_loc sub {loc; _} = sub.location sub loc + +let location _sub _l = () + +let attribute sub x = + let iterator = { + Ast_iterator.default_iterator + with location = fun _this x -> sub.location sub x + } in + iter_loc sub x.Parsetree.attr_name; + iterator.payload iterator x.Parsetree.attr_payload; + sub.location sub x.Parsetree.attr_loc + +let attributes sub l = List.iter (attribute sub) l + 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 = + sub.location sub x.ci_loc; + sub.attributes sub x.ci_attributes; + iter_loc sub x.ci_id_name; 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_type_declaration sub x = + sub.location sub x.mtd_loc; + sub.attributes sub x.mtd_attributes; + iter_loc sub x.mtd_name; + Option.iter (sub.module_type sub) x.mtd_type -let module_declaration sub {md_type; _} = +let module_declaration sub {md_loc; md_name; md_type; md_attributes; _} = + sub.location sub md_loc; + sub.attributes sub md_attributes; + iter_loc sub md_name; sub.module_type sub md_type -let module_substitution _ _ = () -let include_infos f {incl_mod; _} = f incl_mod +let module_substitution sub {ms_loc; ms_name; ms_txt; ms_attributes; _} = + sub.location sub ms_loc; + sub.attributes sub ms_attributes; + iter_loc sub ms_name; + iter_loc sub ms_txt + +let include_infos sub f {incl_loc; incl_mod; incl_attributes; _} = + sub.location sub incl_loc; + sub.attributes sub incl_attributes; + f incl_mod let class_type_declaration sub x = class_infos sub (sub.class_type sub) x @@ -84,10 +120,11 @@ let class_type_declaration sub x = let class_declaration sub x = class_infos sub (sub.class_expr sub) x -let structure_item sub {str_desc; str_env; _} = +let structure_item sub {str_loc; str_desc; str_env; _} = + sub.location sub str_loc; sub.env sub str_env; match str_desc with - | Tstr_eval (exp, _) -> sub.expr sub exp + | Tstr_eval (exp, attrs) -> sub.expr sub exp; sub.attributes sub attrs | 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) @@ -99,22 +136,35 @@ let structure_item sub {str_desc; str_env; _} = | 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 + List.iter (fun (_, s, cltd) -> + iter_loc sub s; sub.class_type_declaration sub cltd) list + | Tstr_include incl -> include_infos sub (sub.module_expr sub) incl | Tstr_open od -> sub.open_declaration sub od - | Tstr_attribute _ -> () + | Tstr_attribute attr -> sub.attribute sub attr -let value_description sub x = sub.typ sub x.val_desc +let value_description sub x = + sub.location sub x.val_loc; + sub.attributes sub x.val_attributes; + iter_loc sub x.val_name; + sub.typ sub x.val_desc -let label_decl sub {ld_type; _} = sub.typ sub ld_type +let label_decl sub {ld_loc; ld_name; ld_type; ld_attributes; _} = + sub.location sub ld_loc; + sub.attributes sub ld_attributes; + iter_loc sub ld_name; + 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 constructor_decl sub x = + sub.location sub x.cd_loc; + sub.attributes sub x.cd_attributes; + iter_loc sub x.cd_name; + List.iter (iter_loc sub) x.cd_vars; + constructor_args sub x.cd_args; + Option.iter (sub.typ sub) x.cd_res let type_kind sub = function | Ttype_abstract -> () @@ -122,55 +172,76 @@ let type_kind sub = function | Ttype_record list -> List.iter (label_decl sub) list | Ttype_open -> () -let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} = +let type_declaration sub x = + sub.location sub x.typ_loc; + sub.attributes sub x.typ_attributes; + iter_loc sub x.typ_name; List.iter - (fun (c1, c2, _) -> + (fun (c1, c2, loc) -> 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 + sub.typ sub c2; + sub.location sub loc) + x.typ_cstrs; + sub.type_kind sub x.typ_kind; + Option.iter (sub.typ sub) x.typ_manifest; + List.iter (fun (c, _) -> sub.typ sub c) x.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_extension sub x = + sub.location sub x.tyext_loc; + sub.attributes sub x.tyext_attributes; + iter_loc sub x.tyext_txt; + List.iter (fun (c, _) -> sub.typ sub c) x.tyext_params; + List.iter (sub.extension_constructor sub) x.tyext_constructors -let type_exception sub {tyexn_constructor; _} = +let type_exception sub {tyexn_loc; tyexn_constructor; tyexn_attributes; _} = + sub.location sub tyexn_loc; + sub.attributes sub tyexn_attributes; sub.extension_constructor sub tyexn_constructor -let extension_constructor sub {ext_kind; _} = +let extension_constructor sub {ext_loc; ext_name; ext_kind; ext_attributes; _} = + sub.location sub ext_loc; + sub.attributes sub ext_attributes; + iter_loc sub ext_name; match ext_kind with - | Text_decl (_, ctl, cto) -> + | Text_decl (ids, ctl, cto) -> + List.iter (iter_loc sub) ids; constructor_args sub ctl; Option.iter (sub.typ sub) cto - | Text_rebind _ -> () + | Text_rebind (_, lid) -> iter_loc sub lid -let pat_extra sub (e, _loc, _attrs) = match e with - | Tpat_type _ -> () +let pat_extra sub (e, loc, attrs) = + sub.location sub loc; + sub.attributes sub attrs; + match e with + | Tpat_type (_, lid) -> iter_loc sub lid | Tpat_unpack -> () - | Tpat_open (_, _, env) -> sub.env sub env + | Tpat_open (_, lid, env) -> iter_loc sub lid; 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; _} -> + = fun sub {pat_loc; pat_extra=extra; pat_desc; pat_env; pat_attributes; _} -> + sub.location sub pat_loc; + sub.attributes sub pat_attributes; sub.env sub pat_env; List.iter (pat_extra sub) extra; match pat_desc with | Tpat_any -> () - | Tpat_var _ -> () + | Tpat_var (_, s) -> iter_loc sub s | Tpat_constant _ -> () | Tpat_tuple l -> List.iter (sub.pat sub) l - | Tpat_construct (_, _, l, vto) -> + | Tpat_construct (lid, _, l, vto) -> + iter_loc sub lid; List.iter (sub.pat sub) l; - Option.iter (fun (_ids, ct) -> sub.typ sub ct) vto + Option.iter (fun (ids, ct) -> + List.iter (iter_loc sub) ids; 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_record (l, _) -> + List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l | Tpat_array l -> List.iter (sub.pat sub) l - | Tpat_alias (p, _, _) -> sub.pat sub p + | Tpat_alias (p, _, s) -> sub.pat sub p; iter_loc sub s | Tpat_lazy p -> sub.pat sub p | Tpat_value p -> sub.pat sub (p :> pattern) | Tpat_exception p -> sub.pat sub p @@ -178,7 +249,7 @@ let pat sub.pat sub p1; sub.pat sub p2 -let expr sub {exp_extra; exp_desc; exp_env; _} = +let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = let extra = function | Texp_constraint cty -> sub.typ sub cty | Texp_coerce (cty1, cty2) -> @@ -188,10 +259,12 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = | Texp_newtype' _ -> () | Texp_poly cto -> Option.iter (sub.typ sub) cto in - List.iter (fun (e, _, _) -> extra e) exp_extra; + sub.location sub exp_loc; + sub.attributes sub exp_attributes; + List.iter (fun (e, loc, _) -> extra e; sub.location sub loc) exp_extra; sub.env sub exp_env; match exp_desc with - | Texp_ident _ -> () + | Texp_ident (_, lid, _) -> iter_loc sub lid | Texp_constant _ -> () | Texp_let (rec_flag, list, exp) -> sub.value_bindings sub (rec_flag, list); @@ -208,16 +281,21 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = 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_construct (lid, _, args) -> + iter_loc sub lid; + 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) + | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp) fields; Option.iter (sub.expr sub) extended_expression; - | Texp_field (exp, _, _) -> sub.expr sub exp - | Texp_setfield (exp1, _, _, exp2) -> + | Texp_field (exp, lid, _) -> + iter_loc sub lid; + sub.expr sub exp + | Texp_setfield (exp1, lid, _, exp2) -> + iter_loc sub lid; sub.expr sub exp1; sub.expr sub exp2 | Texp_array list -> List.iter (sub.expr sub) list @@ -237,18 +315,21 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = sub.expr sub exp3 | Texp_send (exp, _) -> sub.expr sub exp - | Texp_new _ -> () - | Texp_instvar _ -> () - | Texp_setinstvar (_, _, _, exp) ->sub.expr sub exp + | Texp_new (_, lid, _) -> iter_loc sub lid + | Texp_instvar (_, _, s) -> iter_loc sub s + | Texp_setinstvar (_, _, s, exp) -> + iter_loc sub s; + sub.expr sub exp | Texp_override (_, list) -> - List.iter (fun (_, _, e) -> sub.expr sub e) list - | Texp_letmodule (_, _, _, mexpr, exp) -> + List.iter (fun (_, s, e) -> iter_loc sub s; sub.expr sub e) list + | Texp_letmodule (_, s, _, mexpr, exp) -> + iter_loc sub s; 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_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 @@ -257,23 +338,28 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = List.iter (sub.binding_op sub) ands; sub.case sub body | Texp_unreachable -> () - | Texp_extension_constructor _ -> () + | Texp_extension_constructor (lid, _) -> iter_loc sub lid | 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 package_type sub {pack_fields; pack_txt; _} = + List.iter (fun (lid, p) -> iter_loc sub lid; sub.typ sub p) pack_fields; + iter_loc sub pack_txt -let binding_op sub {bop_exp; _} = sub.expr sub bop_exp +let binding_op sub {bop_loc; bop_op_name; bop_exp; _} = + sub.location sub bop_loc; + iter_loc sub bop_op_name; + 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; _} = +let signature_item sub {sig_loc; sig_desc; sig_env; _} = + sub.location sub sig_loc; sub.env sub sig_env; match sig_desc with | Tsig_value v -> sub.value_description sub v @@ -286,7 +372,7 @@ let signature_item sub {sig_desc; sig_env; _} = | 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_include incl -> include_infos sub (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 @@ -297,34 +383,43 @@ let class_description sub x = let functor_parameter sub = function | Unit -> () - | Named (_, _, mtype) -> sub.module_type sub mtype + | Named (_, s, mtype) -> iter_loc sub s; sub.module_type sub mtype -let module_type sub {mty_desc; mty_env; _} = +let module_type sub {mty_loc; mty_desc; mty_env; mty_attributes; _} = + sub.location sub mty_loc; + sub.attributes sub mty_attributes; sub.env sub mty_env; match mty_desc with - | Tmty_ident _ -> () - | Tmty_alias _ -> () + | Tmty_ident (_, lid) -> iter_loc sub lid + | Tmty_alias (_, lid) -> iter_loc sub lid | 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 + List.iter (fun (_, lid, e) -> + iter_loc sub lid; 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 _ -> () + | Twith_module (_, lid) -> iter_loc sub lid + | Twith_modsubst (_, lid) -> iter_loc sub lid + | Twith_modtype mty -> sub.module_type sub mty + | Twith_modtypesubst mty -> sub.module_type sub mty -let open_description sub {open_env; _} = sub.env sub open_env +let open_description sub {open_loc; open_expr; open_env; open_attributes; _} = + sub.location sub open_loc; + sub.attributes sub open_attributes; + iter_snd (iter_loc sub) open_expr; + sub.env sub open_env -let open_declaration sub {open_expr; open_env; _} = +let open_declaration sub {open_loc; open_expr; open_env; open_attributes; _} = + sub.location sub open_loc; + sub.attributes sub open_attributes; sub.module_expr sub open_expr; sub.env sub open_env @@ -339,12 +434,17 @@ let module_coercion sub = function | 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 + | Tcoerce_primitive {pc_loc; pc_env; _} -> + sub.location sub pc_loc; + sub.env sub pc_env -let module_expr sub {mod_desc; mod_env; _} = +let module_expr sub {mod_loc; mod_desc; mod_env; mod_attributes; _} = + sub.location sub mod_loc; + sub.attributes sub mod_attributes; sub.env sub mod_env; match mod_desc with - | Tmod_ident _ | Tmod_hole -> () + | Tmod_hole -> () + | Tmod_ident (_, lid) -> iter_loc sub lid | Tmod_structure st -> sub.structure sub st | Tmod_functor (arg, mexpr) -> functor_parameter sub arg; @@ -353,6 +453,8 @@ let module_expr sub {mod_desc; mod_env; _} = sub.module_expr sub mexp1; sub.module_expr sub mexp2; sub.module_coercion sub c + | Tmod_apply_unit mexp1 -> + sub.module_expr sub mexp1; | Tmod_constraint (mexpr, _, Tmodtype_implicit, c) -> sub.module_expr sub mexpr; sub.module_coercion sub c @@ -362,9 +464,15 @@ let module_expr sub {mod_desc; mod_env; _} = 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 module_binding sub {mb_loc; mb_name; mb_expr; mb_attributes; _} = + sub.location sub mb_loc; + sub.attributes sub mb_attributes; + iter_loc sub mb_name; + sub.module_expr sub mb_expr -let class_expr sub {cl_desc; cl_env; _} = +let class_expr sub {cl_loc; cl_desc; cl_env; cl_attributes; _} = + sub.location sub cl_loc; + sub.attributes sub cl_attributes; sub.env sub cl_env; match cl_desc with | Tcl_constraint (cl, clty, _, _, _) -> @@ -382,16 +490,22 @@ let class_expr sub {cl_desc; cl_env; _} = 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_ident (_, lid, tyl) -> + iter_loc sub lid; + 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; _} = +let class_type sub {cltyp_loc; cltyp_desc; cltyp_env; cltyp_attributes; _} = + sub.location sub cltyp_loc; + sub.attributes sub cltyp_attributes; 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_constr (_, lid, list) -> + iter_loc sub lid; + List.iter (sub.typ sub) list | Tcty_arrow (_, ct, cl) -> sub.typ sub ct; sub.class_type sub cl @@ -403,7 +517,9 @@ 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; _} = +let class_type_field sub {ctf_loc; ctf_desc; ctf_attributes; _} = + sub.location sub ctf_loc; + sub.attributes sub ctf_attributes; match ctf_desc with | Tctf_inherit ct -> sub.class_type sub ct | Tctf_val (_, _, _, ct) -> sub.typ sub ct @@ -411,9 +527,11 @@ let class_type_field sub {ctf_desc; _} = | Tctf_constraint (ct1, ct2) -> sub.typ sub ct1; sub.typ sub ct2 - | Tctf_attribute _ -> () + | Tctf_attribute attr -> sub.attribute sub attr -let typ sub {ctyp_desc; ctyp_env; _} = +let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = + sub.location sub ctyp_loc; + sub.attributes sub ctyp_attributes; sub.env sub ctyp_env; match ctyp_desc with | Ttyp_any -> () @@ -422,9 +540,13 @@ let typ sub {ctyp_desc; ctyp_env; _} = 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_constr (_, lid, list) -> + iter_loc sub lid; + 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_class (_, lid, list) -> + iter_loc sub lid; + 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 @@ -434,29 +556,36 @@ 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; _} = +let row_field sub {rf_loc; rf_desc; rf_attributes; _} = + sub.location sub rf_loc; + sub.attributes sub rf_attributes; match rf_desc with - | Ttag (_, _, list) -> List.iter (sub.typ sub) list + | Ttag (s, _, list) -> iter_loc sub s; List.iter (sub.typ sub) list | Tinherit ct -> sub.typ sub ct -let object_field sub {of_desc; _} = +let object_field sub {of_loc; of_desc; of_attributes; _} = + sub.location sub of_loc; + sub.attributes sub of_attributes; match of_desc with - | OTtag (_, ct) -> sub.typ sub ct + | OTtag (s, ct) -> iter_loc sub s; 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 +let class_field sub {cf_loc; cf_desc; cf_attributes; _} = + sub.location sub cf_loc; + sub.attributes sub cf_attributes; + 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_val (s, _, _, k, _) -> iter_loc sub s; class_field_kind sub k + | Tcf_method (s, _, k) -> iter_loc sub s;class_field_kind sub k | Tcf_initializer exp -> sub.expr sub exp - | Tcf_attribute _ -> () + | Tcf_attribute attr -> sub.attribute sub attr let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list @@ -465,7 +594,9 @@ let case sub {c_lhs; c_guard; c_rhs} = Option.iter (sub.expr sub) c_guard; sub.expr sub c_rhs -let value_binding sub {vb_pat; vb_expr; _} = +let value_binding sub {vb_loc; vb_pat; vb_expr; vb_attributes; _} = + sub.location sub vb_loc; + sub.attributes sub vb_attributes; sub.pat sub vb_pat; sub.expr sub vb_expr @@ -473,6 +604,8 @@ let env _sub _ = () let default_iterator = { + attribute; + attributes; binding_op; case; class_declaration; @@ -487,6 +620,7 @@ let default_iterator = env; expr; extension_constructor; + location; module_binding; module_coercion; module_declaration; diff --git a/src/ocaml/typing/tast_iterator.mli b/src/ocaml/typing/tast_iterator.mli index e126128edf..96352fc351 100644 --- a/src/ocaml/typing/tast_iterator.mli +++ b/src/ocaml/typing/tast_iterator.mli @@ -22,6 +22,8 @@ open Typedtree type iterator = { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attributes -> unit; binding_op: iterator -> binding_op -> unit; case: 'k . iterator -> 'k case -> unit; class_declaration: iterator -> class_declaration -> unit; @@ -36,6 +38,7 @@ type iterator = env: iterator -> Env.t -> unit; expr: iterator -> expression -> unit; extension_constructor: iterator -> extension_constructor -> unit; + location: iterator -> Location.t -> unit; module_binding: iterator -> module_binding -> unit; module_coercion: iterator -> module_coercion -> unit; module_declaration: iterator -> module_declaration -> unit; diff --git a/src/ocaml/typing/tast_mapper.ml b/src/ocaml/typing/tast_mapper.ml index 838d0cd19a..500c07c4ab 100644 --- a/src/ocaml/typing/tast_mapper.ml +++ b/src/ocaml/typing/tast_mapper.ml @@ -16,11 +16,13 @@ open Asttypes open Typedtree -(* TODO: add 'methods' for location, attribute, extension, +(* TODO: add 'methods' for extension, include_declaration, include_description *) type mapper = { + attribute : mapper -> attribute -> attribute; + attributes : mapper -> attributes -> attributes; binding_op: mapper -> binding_op -> binding_op; case: 'k . mapper -> 'k case -> 'k case; class_declaration: mapper -> class_declaration -> class_declaration; @@ -37,6 +39,7 @@ type mapper = expr: mapper -> expression -> expression; extension_constructor: mapper -> extension_constructor -> extension_constructor; + location: mapper -> Location.t -> Location.t; module_binding: mapper -> module_binding -> module_binding; module_coercion: mapper -> module_coercion -> module_coercion; module_declaration: mapper -> module_declaration -> module_declaration; @@ -72,6 +75,22 @@ type mapper = 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 map_loc sub {loc; txt} = {loc=sub.location sub loc; txt} + +let location _sub l = l + +let attribute sub x = + let mapper = { + Ast_mapper.default_mapper + with location = fun _this x -> sub.location sub x + } in + Parsetree.{ + attr_name = map_loc sub x.attr_name; + attr_payload = mapper.payload mapper x.attr_payload; + attr_loc = sub.location sub x.attr_loc + } + +let attributes sub l = List.map (attribute sub) l let structure sub {str_items; str_type; str_final_env} = { @@ -82,21 +101,38 @@ let structure sub {str_items; str_type; str_final_env} = let class_infos sub f x = {x with + ci_loc = sub.location sub x.ci_loc; + ci_id_name = map_loc sub x.ci_id_name; ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params; ci_expr = f x.ci_expr; + ci_attributes = sub.attributes sub x.ci_attributes; } let module_type_declaration sub x = + let mtd_loc = sub.location sub x.mtd_loc in + let mtd_name = map_loc sub x.mtd_name in let mtd_type = Option.map (sub.module_type sub) x.mtd_type in - {x with mtd_type} + let mtd_attributes = sub.attributes sub x.mtd_attributes in + {x with mtd_loc; mtd_name; mtd_type; mtd_attributes} let module_declaration sub x = + let md_loc = sub.location sub x.md_loc in + let md_name = map_loc sub x.md_name in let md_type = sub.module_type sub x.md_type in - {x with md_type} + let md_attributes = sub.attributes sub x.md_attributes in + {x with md_loc; md_name; md_type; md_attributes} -let module_substitution _ x = x +let module_substitution sub x = + let ms_loc = sub.location sub x.ms_loc in + let ms_name = map_loc sub x.ms_name in + let ms_txt = map_loc sub x.ms_txt in + let ms_attributes = sub.attributes sub x.ms_attributes in + {x with ms_loc; ms_name; ms_txt; ms_attributes} -let include_infos f x = {x with incl_mod = f x.incl_mod} +let include_infos sub f x = + let incl_loc = sub.location sub x.incl_loc in + let incl_attributes = sub.attributes sub x.incl_attributes in + {x with incl_loc; incl_attributes; incl_mod = f x.incl_mod} let class_type_declaration sub x = class_infos sub (sub.class_type sub) x @@ -104,11 +140,13 @@ let class_type_declaration 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 structure_item sub {str_loc; str_desc; str_env} = + let str_loc = sub.location sub str_loc in 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_eval (exp, attrs) -> + Tstr_eval (sub.expr sub exp, sub.attributes sub attrs) | Tstr_value (rec_flag, list) -> let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in Tstr_value (rec_flag, list) @@ -127,30 +165,41 @@ let structure_item sub {str_desc; str_loc; str_env} = (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) + (List.map (tuple3 + id (map_loc sub) (sub.class_type_declaration sub)) list) | Tstr_include incl -> - Tstr_include (include_infos (sub.module_expr sub) incl) + Tstr_include (include_infos sub (sub.module_expr sub) incl) | Tstr_open od -> Tstr_open (sub.open_declaration sub od) - | Tstr_attribute _ as d -> d + | Tstr_attribute attr -> Tstr_attribute (sub.attribute sub attr) in {str_desc; str_env; str_loc} let value_description sub x = + let val_loc = sub.location sub x.val_loc in + let val_name = map_loc sub x.val_name in let val_desc = sub.typ sub x.val_desc in - {x with val_desc} + let val_attributes = sub.attributes sub x.val_attributes in + {x with val_loc; val_name; val_desc; val_attributes} let label_decl sub x = + let ld_loc = sub.location sub x.ld_loc in + let ld_name = map_loc sub x.ld_name in let ld_type = sub.typ sub x.ld_type in - {x with ld_type} + let ld_attributes = sub.attributes sub x.ld_attributes in + {x with ld_loc; ld_name; ld_type; ld_attributes} 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_loc = sub.location sub cd.cd_loc in + let cd_name = map_loc sub cd.cd_name in + let cd_vars = List.map (map_loc sub) cd.cd_vars in 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 cd_attributes = sub.attributes sub cd.cd_attributes in + {cd with cd_loc; cd_name; cd_vars; cd_args; cd_res; cd_attributes} let type_kind sub = function | Ttype_abstract -> Ttype_abstract @@ -159,67 +208,89 @@ let type_kind sub = function | Ttype_open -> Ttype_open let type_declaration sub x = + let typ_loc = sub.location sub x.typ_loc in + let typ_name = map_loc sub x.typ_name in let typ_cstrs = List.map - (tuple3 (sub.typ sub) (sub.typ sub) id) + (tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) 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 typ_attributes = sub.attributes sub x.typ_attributes in + {x with typ_loc; typ_name; typ_cstrs; typ_kind; typ_manifest; typ_params; + typ_attributes} let type_declarations sub (rec_flag, list) = (rec_flag, List.map (sub.type_declaration sub) list) let type_extension sub x = + let tyext_loc = sub.location sub x.tyext_loc in + let tyext_txt = map_loc sub x.tyext_txt in 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 tyext_attributes = sub.attributes sub x.tyext_attributes in + {x with tyext_loc; tyext_txt; tyext_constructors; tyext_params; + tyext_attributes} let type_exception sub x = + let tyexn_loc = sub.location sub x.tyexn_loc in let tyexn_constructor = sub.extension_constructor sub x.tyexn_constructor in - {x with tyexn_constructor} + let tyexn_attributes = sub.attributes sub x.tyexn_attributes in + {tyexn_loc; tyexn_constructor; tyexn_attributes} let extension_constructor sub x = + let ext_loc = sub.location sub x.ext_loc in + let ext_name = map_loc sub x.ext_name in let ext_kind = match x.ext_kind with - Text_decl(v, ctl, cto) -> - Text_decl(v, constructor_args sub ctl, Option.map (sub.typ sub) cto) - | Text_rebind _ as d -> d + Text_decl(ids, ctl, cto) -> + Text_decl( + List.map (map_loc sub) ids, + constructor_args sub ctl, + Option.map (sub.typ sub) cto + ) + | Text_rebind (path, lid) -> + Text_rebind (path, map_loc sub lid) in - {x with ext_kind} + let ext_attributes = sub.attributes sub x.ext_attributes in + {x with ext_loc; ext_name; ext_kind; ext_attributes} 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_type (path,loc) -> Tpat_type (path, map_loc sub loc) + | Tpat_open (path,loc,env) -> + Tpat_open (path, map_loc sub 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_loc = sub.location sub x.pat_loc in 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_extra = + List.map (tuple3 (pat_extra sub) id (sub.attributes sub)) 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_var (id, s) -> Tpat_var (id, map_loc sub s) | 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) + let vto = Option.map (fun (vl,cty) -> + List.map (map_loc sub) vl, sub.typ sub cty) vto in + Tpat_construct (map_loc sub 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_record (List.map (tuple3 (map_loc sub) 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_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, map_loc sub s) | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) | Tpat_value p -> (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc @@ -228,7 +299,8 @@ let pat | 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 pat_attributes = sub.attributes sub x.pat_attributes in + {x with pat_loc; pat_extra; pat_desc; pat_env; pat_attributes} let expr sub x = let extra = function @@ -240,11 +312,13 @@ let expr sub x = | 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_loc = sub.location sub x.exp_loc in + let exp_extra = List.map (tuple3 extra (sub.location sub) 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_ident (path, lid, vd) -> + Texp_ident (path, map_loc sub lid, vd) | Texp_constant _ as d -> d | Texp_let (rec_flag, list, exp) -> let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in @@ -271,14 +345,14 @@ let expr sub x = | 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_construct (map_loc sub 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, mut) -> label, Kept (t, mut) | label, Overridden (lid, exp) -> - label, Overridden (lid, sub.expr sub exp)) + label, Overridden (map_loc sub lid, sub.expr sub exp)) fields in Texp_record { @@ -286,11 +360,11 @@ let expr sub x = extended_expression = Option.map (sub.expr sub) extended_expression; } | Texp_field (exp, lid, ld) -> - Texp_field (sub.expr sub exp, lid, ld) + Texp_field (sub.expr sub exp, map_loc sub lid, ld) | Texp_setfield (exp1, lid, ld, exp2) -> Texp_setfield ( sub.expr sub exp1, - lid, + map_loc sub lid, ld, sub.expr sub exp2 ) @@ -327,24 +401,34 @@ let expr sub x = sub.expr sub exp, meth ) - | Texp_new _ - | Texp_instvar _ as d -> d + | Texp_new (path, lid, cd) -> + Texp_new ( + path, + map_loc sub lid, + cd + ) + | Texp_instvar (path1, path2, id) -> + Texp_instvar ( + path1, + path2, + map_loc sub id + ) | Texp_setinstvar (path1, path2, id, exp) -> Texp_setinstvar ( path1, path2, - id, + map_loc sub id, sub.expr sub exp ) | Texp_override (path, list) -> Texp_override ( path, - List.map (tuple3 id id (sub.expr sub)) list + List.map (tuple3 id (map_loc sub) (sub.expr sub)) list ) | Texp_letmodule (id, s, pres, mexpr, exp) -> Texp_letmodule ( id, - s, + map_loc sub s, pres, sub.module_expr sub mexpr, sub.expr sub exp @@ -354,8 +438,8 @@ let expr sub x = sub.extension_constructor sub cd, sub.expr sub exp ) - | Texp_assert exp -> - Texp_assert (sub.expr sub exp) + | Texp_assert (exp, loc) -> + Texp_assert (sub.expr sub exp, loc) | Texp_lazy exp -> Texp_lazy (sub.expr sub exp) | Texp_object (cl, sl) -> @@ -372,22 +456,27 @@ let expr sub x = } | Texp_unreachable -> Texp_unreachable - | Texp_extension_constructor _ as e -> - e + | Texp_extension_constructor (lid, path) -> + Texp_extension_constructor (map_loc sub lid, path) | 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 exp_attributes = sub.attributes sub x.exp_attributes in + {x with exp_loc; exp_extra; exp_desc; exp_env; exp_attributes} let package_type sub x = - let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in - {x with pack_fields} + let pack_txt = map_loc sub x.pack_txt in + let pack_fields = List.map + (tuple2 (map_loc sub) (sub.typ sub)) x.pack_fields in + {x with pack_txt; pack_fields} let binding_op sub x = - { x with bop_exp = sub.expr sub x.bop_exp } + let bop_loc = sub.location sub x.bop_loc in + let bop_op_name = map_loc sub x.bop_op_name in + { x with bop_loc; bop_op_name; bop_exp = sub.expr sub x.bop_exp } let signature sub x = let sig_final_env = sub.env sub x.sig_final_env in @@ -395,6 +484,7 @@ let signature sub x = {x with sig_items; sig_final_env} let signature_item sub x = + let sig_loc = sub.location sub x.sig_loc in let sig_env = sub.env sub x.sig_env in let sig_desc = match x.sig_desc with @@ -421,57 +511,64 @@ let signature_item 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_include (include_infos sub (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 + | Tsig_attribute attr -> Tsig_attribute (sub.attribute sub attr) in - {x with sig_desc; sig_env} + {sig_loc; 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) + | Named (id, s, mtype) -> Named (id, map_loc sub s, sub.module_type sub mtype) let module_type sub x = + let mty_loc = sub.location sub x.mty_loc in 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_ident (path, lid) -> Tmty_ident (path, map_loc sub lid) + | Tmty_alias (path, lid) -> Tmty_alias (path, map_loc sub lid) | 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 + List.map (tuple3 id (map_loc sub) (sub.with_constraint sub)) list ) | Tmty_typeof mexpr -> Tmty_typeof (sub.module_expr sub mexpr) in - {x with mty_desc; mty_env} + let mty_attributes = sub.attributes sub x.mty_attributes in + {x with mty_loc; mty_desc; mty_env; mty_attributes} 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_modtype mty -> Twith_modtype (sub.module_type sub mty) | Twith_modtypesubst mty -> Twith_modtypesubst (sub.module_type sub mty) - | Twith_module _ - | Twith_modsubst _ as d -> d + | Twith_module (path, lid) -> Twith_module (path, map_loc sub lid) + | Twith_modsubst (path, lid) -> Twith_modsubst (path, map_loc sub lid) let open_description sub od = - {od with open_env = sub.env sub od.open_env} + {od with open_loc = sub.location sub od.open_loc; + open_expr = tuple2 id (map_loc sub) od.open_expr; + open_env = sub.env sub od.open_env; + open_attributes = sub.attributes sub od.open_attributes} let open_declaration sub od = - {od with open_expr = sub.module_expr sub od.open_expr; - open_env = sub.env sub od.open_env} + {od with open_loc = sub.location sub od.open_loc; + open_expr = sub.module_expr sub od.open_expr; + open_env = sub.env sub od.open_env; + open_attributes = sub.attributes sub od.open_attributes} let module_coercion sub = function | Tcoerce_none -> Tcoerce_none @@ -486,13 +583,15 @@ let module_coercion sub = function in Tcoerce_structure (l1', l2') | Tcoerce_primitive pc -> - Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env} + Tcoerce_primitive {pc with pc_loc = sub.location sub pc.pc_loc; + pc_env = sub.env sub pc.pc_env} let module_expr sub x = + let mod_loc = sub.location sub x.mod_loc in let mod_env = sub.env sub x.mod_env in let mod_desc = match x.mod_desc with - | Tmod_ident _ as d -> d + | Tmod_ident (path, lid) -> Tmod_ident (path, map_loc sub lid) | Tmod_hole -> Tmod_hole | Tmod_structure st -> Tmod_structure (sub.structure sub st) | Tmod_functor (arg, mexpr) -> @@ -503,6 +602,8 @@ let module_expr sub x = sub.module_expr sub mexp2, sub.module_coercion sub c ) + | Tmod_apply_unit mexp1 -> + Tmod_apply_unit (sub.module_expr sub mexp1) | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) -> Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit, sub.module_coercion sub c) @@ -520,13 +621,18 @@ let module_expr sub x = mty ) in - {x with mod_desc; mod_env} + let mod_attributes = sub.attributes sub x.mod_attributes in + {x with mod_loc; mod_desc; mod_env; mod_attributes} let module_binding sub x = + let mb_loc = sub.location sub x.mb_loc in + let mb_name = map_loc sub x.mb_name in let mb_expr = sub.module_expr sub x.mb_expr in - {x with mb_expr} + let mb_attributes = sub.attributes sub x.mb_attributes in + {x with mb_loc; mb_name; mb_expr; mb_attributes} let class_expr sub x = + let cl_loc = sub.location sub x.cl_loc in let cl_env = sub.env sub x.cl_env in let cl_desc = match x.cl_desc with @@ -564,13 +670,15 @@ let class_expr sub x = sub.class_expr sub cl ) | Tcl_ident (path, lid, tyl) -> - Tcl_ident (path, lid, List.map (sub.typ sub) tyl) + Tcl_ident (path, map_loc sub 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 cl_attributes = sub.attributes sub x.cl_attributes in + {x with cl_loc; cl_desc; cl_env; cl_attributes} let class_type sub x = + let cltyp_loc = sub.location sub x.cltyp_loc in let cltyp_env = sub.env sub x.cltyp_env in let cltyp_desc = match x.cltyp_desc with @@ -578,7 +686,7 @@ let class_type sub x = | Tcty_constr (path, lid, list) -> Tcty_constr ( path, - lid, + map_loc sub lid, List.map (sub.typ sub) list ) | Tcty_arrow (label, ct, cl) -> @@ -590,7 +698,8 @@ let class_type sub x = | Tcty_open (od, e) -> Tcty_open (sub.open_description sub od, sub.class_type sub e) in - {x with cltyp_desc; cltyp_env} + let cltyp_attributes = sub.attributes sub x.cltyp_attributes in + {x with cltyp_loc; cltyp_desc; cltyp_env; cltyp_attributes} let class_signature sub x = let csig_self = sub.typ sub x.csig_self in @@ -598,6 +707,7 @@ let class_signature sub x = {x with csig_self; csig_fields} let class_type_field sub x = + let ctf_loc = sub.location sub x.ctf_loc in let ctf_desc = match x.ctf_desc with | Tctf_inherit ct -> @@ -608,11 +718,14 @@ let class_type_field sub x = 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 + | Tctf_attribute attr -> + Tctf_attribute (sub.attribute sub attr) in - {x with ctf_desc} + let ctf_attributes = sub.attributes sub x.ctf_attributes in + {ctf_loc; ctf_desc; ctf_attributes} let typ sub x = + let ctyp_loc = sub.location sub x.ctyp_loc in let ctyp_env = sub.env sub x.ctyp_env in let ctyp_desc = match x.ctyp_desc with @@ -622,13 +735,13 @@ let typ sub x = 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_constr (path, map_loc sub 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, + map_loc sub lid, List.map (sub.typ sub) list ) | Ttyp_alias (ct, s) -> @@ -640,7 +753,8 @@ let typ sub x = | Ttyp_package pack -> Ttyp_package (sub.package_type sub pack) in - {x with ctyp_desc; ctyp_env} + let ctyp_attributes = sub.attributes sub x.ctyp_attributes in + {x with ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes} let class_structure sub x = let cstr_self = sub.pat sub x.cstr_self in @@ -648,26 +762,31 @@ let class_structure sub x = {x with cstr_self; cstr_fields} let row_field sub x = + let rf_loc = sub.location sub x.rf_loc in let rf_desc = match x.rf_desc with | Ttag (label, b, list) -> - Ttag (label, b, List.map (sub.typ sub) list) + Ttag (map_loc sub label, b, List.map (sub.typ sub) list) | Tinherit ct -> Tinherit (sub.typ sub ct) in - { x with rf_desc; } + let rf_attributes = sub.attributes sub x.rf_attributes in + {rf_loc; rf_desc; rf_attributes} let object_field sub x = + let of_loc = sub.location sub x.of_loc in let of_desc = match x.of_desc with | OTtag (label, ct) -> - OTtag (label, (sub.typ sub ct)) + OTtag (map_loc sub label, (sub.typ sub ct)) | OTinherit ct -> OTinherit (sub.typ sub ct) in - { x with of_desc; } + let of_attributes = sub.attributes sub x.of_attributes in + {of_loc; of_desc; of_attributes} 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_loc = sub.location sub x.cf_loc in let cf_desc = match x.cf_desc with | Tcf_inherit (ovf, cl, super, vals, meths) -> @@ -678,14 +797,16 @@ let class_field sub x = sub.typ sub cty' ) | Tcf_val (s, mf, id, k, b) -> - Tcf_val (s, mf, id, class_field_kind sub k, b) + Tcf_val (map_loc sub s, mf, id, class_field_kind sub k, b) | Tcf_method (s, priv, k) -> - Tcf_method (s, priv, class_field_kind sub k) + Tcf_method (map_loc sub s, priv, class_field_kind sub k) | Tcf_initializer exp -> Tcf_initializer (sub.expr sub exp) - | Tcf_attribute _ as d -> d + | Tcf_attribute attr -> + Tcf_attribute (sub.attribute sub attr) in - {x with cf_desc} + let cf_attributes = sub.attributes sub x.cf_attributes in + {cf_loc; cf_desc; cf_attributes} let value_bindings sub (rec_flag, list) = (rec_flag, List.map (sub.value_binding sub) list) @@ -700,14 +821,18 @@ let case } let value_binding sub x = + let vb_loc = sub.location sub x.vb_loc in 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 vb_attributes = sub.attributes sub x.vb_attributes in + {vb_loc; vb_pat; vb_expr; vb_attributes} let env _sub x = x let default = { + attribute; + attributes; binding_op; case; class_declaration; @@ -722,6 +847,7 @@ let default = env; expr; extension_constructor; + location; module_binding; module_coercion; module_declaration; diff --git a/src/ocaml/typing/tast_mapper.mli b/src/ocaml/typing/tast_mapper.mli index ea6543d04f..f54cef2b06 100644 --- a/src/ocaml/typing/tast_mapper.mli +++ b/src/ocaml/typing/tast_mapper.mli @@ -20,6 +20,8 @@ open Typedtree type mapper = { + attribute : mapper -> attribute -> attribute; + attributes : mapper -> attributes -> attributes; binding_op: mapper -> binding_op -> binding_op; case: 'k . mapper -> 'k case -> 'k case; class_declaration: mapper -> class_declaration -> class_declaration; @@ -36,6 +38,7 @@ type mapper = expr: mapper -> expression -> expression; extension_constructor: mapper -> extension_constructor -> extension_constructor; + location: mapper -> Location.t -> Location.t; module_binding: mapper -> module_binding -> module_binding; module_coercion: mapper -> module_coercion -> module_coercion; module_declaration: mapper -> module_declaration -> module_declaration; diff --git a/src/ocaml/typing/typeclass.ml b/src/ocaml/typing/typeclass.ml index c9841a2618..82b8c55251 100644 --- a/src/ocaml/typing/typeclass.ml +++ b/src/ocaml/typing/typeclass.ml @@ -29,7 +29,6 @@ type 'a class_info = { 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; @@ -42,7 +41,6 @@ type class_type_info = { 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; } @@ -55,8 +53,6 @@ type 'a full_class = { 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; @@ -93,12 +89,16 @@ type error = | Undeclared_methods of kind * string list | Parameter_arity_mismatch of Longident.t * int * int | Parameter_mismatch of Errortrace.unification_error - | Bad_parameters of Ident.t * type_expr * type_expr + | Bad_parameters of Ident.t * type_expr list * type_expr list + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list | Class_match_failure of Ctype.class_match_failure list | Unbound_val of string - | Unbound_type_var of - (formatter -> unit) * (type_expr * bool * string * type_expr) - | Non_generalizable_class of Ident.t * Types.class_declaration + | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure + | Non_generalizable_class of + { id : Ident.t + ; clty : Types.class_declaration + ; nongen_vars : type_expr list + } | Cannot_coerce_self of type_expr | Non_collapsable_conjunction of Ident.t * Types.class_declaration * Errortrace.unification_error @@ -255,9 +255,9 @@ let unify_delayed_method_type loc env label ty expected_ty= raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) let type_constraint val_env sty sty' loc = - let cty = transl_simple_type val_env false sty in + let cty = transl_simple_type val_env ~closed:false sty in let ty = cty.ctyp_type in - let cty' = transl_simple_type val_env false sty' in + let cty' = transl_simple_type val_env ~closed:false sty' in let ty' = cty'.ctyp_type in begin try Ctype.unify val_env ty ty' with Ctype.Unify err -> @@ -297,7 +297,7 @@ let rec class_type_field env sign self_scope ctf = | Pctf_val ({txt=lab}, mut, virt, sty) -> mkctf_with_attrs (fun () -> - let cty = transl_simple_type env false sty in + let cty = transl_simple_type env ~closed:false sty in let ty = cty.ctyp_type in add_instance_variable ~strict:false loc env lab mut virt ty sign; Tctf_val (lab, mut, virt, cty)) @@ -321,7 +321,7 @@ let rec class_type_field env sign self_scope ctf = ) :: !delayed_meth_specs; Tctf_method (lab, priv, virt, returned_cty) | _ -> - let cty = transl_simple_type env false sty in + let cty = transl_simple_type env ~closed:false sty in let ty = cty.ctyp_type in add_method loc env lab priv virt ty sign; Tctf_method (lab, priv, virt, cty)) @@ -345,7 +345,7 @@ and class_signature virt env pcsig self_scope loc = (* Introduce a dummy method preventing self type from being closed. *) Ctype.add_dummy_method env ~scope:self_scope sign; - let self_cty = transl_simple_type env false sty in + let self_cty = transl_simple_type env ~closed:false sty in let self_type = self_cty.ctyp_type in begin try Ctype.unify env self_type sign.csig_self @@ -395,7 +395,7 @@ and class_type_aux env virt self_scope scty = List.length styl))); let ctys = List.map2 (fun sty ty -> - let cty' = transl_simple_type env false sty in + let cty' = transl_simple_type env ~closed:false sty in let ty' = cty'.ctyp_type in begin try Ctype.unify env ty' ty with Ctype.Unify err -> @@ -415,7 +415,7 @@ and class_type_aux env virt self_scope scty = cltyp (Tcty_signature clsig) typ | Pcty_arrow (l, sty, scty) -> - let cty = transl_simple_type env false sty in + let cty = transl_simple_type env ~closed:false sty in let ty = cty.ctyp_type in let ty = if Btype.is_optional l @@ -646,15 +646,14 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = | Pcf_val (label, mut, Cfk_virtual styp) -> with_attrs (fun () -> - 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 cty = + Ctype.with_local_level_if_principal + (fun () -> Typetexp.transl_simple_type val_env + ~closed:false styp) + ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type) + in add_instance_variable ~strict:true loc val_env - label.txt mut Virtual ty sign; + label.txt mut Virtual cty.ctyp_type sign; let already_declared, val_env, par_env, id, vars = match Vars.find label.txt vars with | id -> true, val_env, par_env, id, vars @@ -687,12 +686,11 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = raise(Error(loc, val_env, No_overriding ("instance variable", label.txt))) end; - if !Clflags.principal then Ctype.begin_def (); - let definition = type_exp val_env sdefinition in - if !Clflags.principal then begin - Ctype.end_def (); - Ctype.generalize_structure definition.exp_type - end; + let definition = + Ctype.with_local_level_if_principal + ~post:Typecore.generalize_structure_exp + (fun () -> type_exp val_env sdefinition) + in add_instance_variable ~strict:true loc val_env label.txt mut Concrete definition.exp_type sign; let already_declared, val_env, par_env, id, vars = @@ -721,7 +719,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = with_attrs (fun () -> let sty = Ast_helper.Typ.force_poly sty in - let cty = transl_simple_type val_env false sty in + let cty = transl_simple_type val_env ~closed:false sty in let ty = cty.ctyp_type in add_method loc val_env label.txt priv Virtual ty sign; let field = @@ -761,7 +759,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = | Some sty -> let sty = Ast_helper.Typ.force_poly sty in let cty' = - Typetexp.transl_simple_type val_env false sty + Typetexp.transl_simple_type val_env ~closed:false sty in cty'.ctyp_type in @@ -910,9 +908,9 @@ and class_field_second_pass cl_num sign met_env field = mk_expected (Btype.newgenty (Tarrow(Nolabel, self_type, ty, commu_ok))) in - Ctype.raise_nongen_level (); - let texp = type_expect met_env sdefinition meth_type in - Ctype.end_def (); + let texp = + Ctype.with_raised_nongen_level + (fun () -> type_expect met_env sdefinition meth_type) in let kind = Tcfk_concrete (override, texp) in let desc = Tcf_method(label, priv, kind) in met_env, mkcf desc loc attributes) @@ -922,15 +920,15 @@ and class_field_second_pass cl_num sign met_env field = | Initializer { sexpr; warning_state; loc; attributes } -> Warnings.with_state warning_state (fun () -> - Ctype.raise_nongen_level (); let unit_type = Ctype.instance Predef.type_unit in let self_type = sign.Types.csig_self in let meth_type = mk_expected (Ctype.newty (Tarrow (Nolabel, self_type, unit_type, commu_ok))) in - let texp = type_expect met_env sexpr meth_type in - Ctype.end_def (); + let texp = + Ctype.with_raised_nongen_level + (fun () -> type_expect met_env sexpr meth_type) in let desc = Tcf_initializer texp in met_env, mkcf desc loc attributes) | Attribute { attribute; loc; attributes; } -> @@ -1065,7 +1063,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = 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) + (fun sty -> transl_simple_type val_env ~closed:false sty) styl in let (params, clty) = @@ -1145,15 +1143,15 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = in class_expr cl_num val_env met_env virt self_scope 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 + Ctype.with_local_level_if_principal + (fun () -> + Typecore.type_class_arg_pattern cl_num val_env met_env l spat) + ~post: begin fun (pat, _, _, _) -> + let gen {pat_type = ty} = Ctype.generalize_structure ty in + iter_pattern gen pat + end 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) -> @@ -1177,12 +1175,12 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = 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 + Typecore.check_partial Modules_rejected 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 virt self_scope scl' in - Ctype.end_def (); + let cl = + Ctype.with_raised_nongen_level + (fun () -> class_expr cl_num val_env' met_env virt self_scope scl') in if Btype.is_optional l && not_nolabel_function cl.cl_type then Location.prerr_warning pat.pat_loc Warnings.Unerasable_optional_argument; @@ -1195,12 +1193,11 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = } | Pcl_apply (scl', sargs) -> assert (sargs <> []); - if !Clflags.principal then Ctype.begin_def (); - let cl = class_expr cl_num val_env met_env virt self_scope scl' in - if !Clflags.principal then begin - Ctype.end_def (); - Ctype.generalize_class_type_structure cl.cl_type; - end; + let cl = + Ctype.with_local_level_if_principal + (fun () -> class_expr cl_num val_env met_env virt self_scope scl') + ~post:(fun cl -> Ctype.generalize_class_type_structure cl.cl_type) + in let rec nonopt_labels ls ty_fun = match ty_fun with | Cty_arrow (l, _, ty_res) -> @@ -1309,21 +1306,22 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = 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 ty = + Ctype.with_local_level ~post:Ctype.generalize + (fun () -> Ctype.instance vd.val_type) + in 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_type = ty; 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_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; @@ -1347,22 +1345,29 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = 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 virt self_scope scl' in - complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type; - Typetexp.widen context; - let context = Typetexp.narrow () in - let clty = class_type val_env virt self_scope scty in - complete_class_type clty.cltyp_loc val_env virt Class clty.cltyp_type; - Typetexp.widen context; - Ctype.end_def (); - - Ctype.limited_generalize_class_type - (Btype.self_type_row cl.cl_type) cl.cl_type; - Ctype.limited_generalize_class_type - (Btype.self_type_row clty.cltyp_type) clty.cltyp_type; - + let cl, clty = + Ctype.with_local_level_for_class begin fun () -> + let cl = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let cl = class_expr cl_num val_env met_env virt self_scope scl' in + complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type; + cl + end + and clty = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let clty = class_type val_env virt self_scope scty in + complete_class_type + clty.cltyp_loc val_env virt Class clty.cltyp_type; + clty + end + in + cl, clty + end + ~post: begin fun ({cl_type=cl}, {cltyp_type=clty}) -> + Ctype.limited_generalize_class_type (Btype.self_type_row cl) cl; + Ctype.limited_generalize_class_type (Btype.self_type_row clty) clty; + end + in begin match Includeclass.class_types val_env cl.cl_type clty.cltyp_type with @@ -1426,14 +1431,13 @@ let rec approx_description ct = (*******************************) -let temp_abbrev loc env id arity uid = +let temp_abbrev loc 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 + let ty_td = {type_params = !params; type_arity = arity; type_kind = Type_abstract; @@ -1449,24 +1453,22 @@ let temp_abbrev loc env id arity uid = type_unboxed_default = false; type_uid = uid; } - env in - (!params, ty, env) + (!params, ty, ty_td) let initial_env define_class approx - (res, env) (cl, id, ty_id, obj_id, cl_id, uid) = + (res, env) (cl, id, ty_id, obj_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 + let (obj_params, obj_ty, obj_td) = temp_abbrev cl.pci_loc arity uid in + let env = Env.add_type ~check:true obj_id obj_td env in + let (cl_params, cl_ty, cl_td) = temp_abbrev cl.pci_loc arity uid in (* Temporary type for the class constructor *) - if !Clflags.principal then Ctype.begin_def (); - let constr_type = approx cl.pci_expr in - if !Clflags.principal then begin - Ctype.end_def (); - Ctype.generalize_structure constr_type; - end; + let constr_type = + Ctype.with_local_level_if_principal (fun () -> approx cl.pci_expr) + ~post:Ctype.generalize_structure + in let dummy_cty = Cty_signature (Ctype.new_class_signature ()) in let dummy_class = {Types.cty_params = []; (* Dummy value *) @@ -1489,6 +1491,7 @@ let initial_env define_class approx clty_variance = []; clty_type = dummy_cty; (* Dummy value *) clty_path = unbound_class; + clty_hash_type = cl_td; (* Dummy value *) clty_loc = Location.none; clty_attributes = []; clty_uid = uid; @@ -1502,54 +1505,57 @@ let initial_env define_class approx in ((cl, id, ty_id, obj_id, obj_params, obj_ty, - cl_id, cl_params, cl_ty, - constr_type, dummy_class)::res, + cl_params, cl_ty, cl_td, + 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) + cl_params, cl_ty, cl_td, + 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_virt cl.pci_expr in - Typecore.self_coercion := List.tl !Typecore.self_coercion; - res - with exn -> - Typecore.self_coercion := []; raise exn + let ci_params, params, coercion_locs, expr, typ, sign = + Ctype.with_local_level_for_class begin fun () -> + TyVarEnv.reset (); + (* 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_virt cl.pci_expr in + Typecore.self_coercion := List.tl !Typecore.self_coercion; + res + with exn -> + Typecore.self_coercion := []; raise exn + in + let sign = Btype.signature_of_class_type typ in + (ci_params, params, coercion_locs, expr, typ, sign) + end + ~post: begin fun (_, params, _, _, typ, sign) -> + (* Generalize the row variable *) + List.iter (Ctype.limited_generalize sign.csig_self_row) params; + Ctype.limited_generalize_class_type sign.csig_self_row typ; + end in - let sign = Btype.signature_of_class_type typ in - - Ctype.end_def (); - - (* Generalize the row variable *) - List.iter (Ctype.limited_generalize sign.csig_self_row) params; - Ctype.limited_generalize_class_type sign.csig_self_row 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 @@ -1560,9 +1566,7 @@ let class_infos define_class kind 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'))) + Bad_parameters (obj_id, obj_params, obj_params'))) end; let ty = Btype.self_type obj_type in begin try @@ -1583,17 +1587,13 @@ let class_infos define_class kind 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'))) + Bad_class_type_parameters (ty_id, cl_params, 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))) + let ty_expanded = Ctype.object_fields ty in + raise(Error(cl.pci_loc, env, Abbrev_type_clash (ty, ty_expanded, cl_ty))) end end; @@ -1614,6 +1614,7 @@ let class_infos define_class kind {clty_params = params; clty_type = Btype.class_body typ; clty_variance = cty_variance; clty_path = Path.Pident obj_id; + clty_hash_type = cl_td; clty_loc = cl.pci_loc; clty_attributes = cl.pci_attributes; clty_uid = dummy_class.cty_uid; @@ -1644,15 +1645,7 @@ let class_infos define_class kind (* Final definitions *) let (params', typ') = Ctype.instance_class params typ in - let cltydef = - {clty_params = params'; clty_type = Btype.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 = + let clty = {cty_params = params'; cty_type = typ'; cty_variance = cty_variance; cty_path = Path.Pident obj_id; @@ -1690,31 +1683,29 @@ let class_infos define_class kind in Ctype.set_object_name obj_id cl_params cl_ty; let cl_abbr = - let arity = List.length cl_params in - { + { cl_td with 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; + type_manifest = Some cl_ty } in - ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params, + let cltydef = + {clty_params = params'; clty_type = Btype.class_body typ'; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_hash_type = cl_abbr; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; + clty_uid = dummy_class.cty_uid; + } + in + ((cl, id, clty, ty_id, cltydef, obj_id, obj_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, + (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, ci_params, arity, pub_meths, coe, expr) = + let cl_abbr = cltydef.clty_hash_type in begin try Ctype.collapse_conj_params env clty.cty_params with Ctype.Unify err -> @@ -1729,8 +1720,12 @@ let final_decl env define_class List.iter Ctype.generalize cl_abbr.type_params; Option.iter Ctype.generalize cl_abbr.type_manifest; - if Ctype.nongen_class_declaration clty then - raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty))); + Ctype.nongen_vars_in_class_declaration clty + |> Option.iter (fun vars -> + let nongen_vars = Btype.TypeSet.elements vars in + raise(Error(cl.pci_loc, env + , Non_generalizable_class { id; clty; nongen_vars })); + ); begin match Ctype.closed_class clty.cty_params @@ -1745,7 +1740,7 @@ let final_decl env define_class 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; + { id; clty; ty_id; cltydef; obj_id; obj_abbr; arity; pub_meths; coe; id_loc = cl.pci_name; req = { ci_loc = cl.pci_loc; @@ -1756,7 +1751,6 @@ let final_decl env define_class 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; @@ -1768,40 +1762,40 @@ let final_decl env define_class 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) + cl_params, cl_ty, cl_td, + 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) + cl_params, cl_ty, cl_td, + 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 extract_type_decls { clty; cltydef; obj_id; obj_abbr; req} decls = + (obj_id, obj_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 merge_type_decls decl (obj_abbr, clty, cltydef) = + {decl with obj_abbr; clty; cltydef} -let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_abbr; - cl_id; cl_abbr } = +let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_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))) + 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 } = + arity; pub_meths; coe; req } = + let cl_abbr = cltydef.clty_hash_type in begin match coe with [] -> () | loc :: _ -> let cl_ty, obj_ty = @@ -1830,7 +1824,6 @@ let check_coercions env { id; id_loc; clty; ty_id; cltydef; obj_id; obj_abbr; 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; @@ -1847,19 +1840,21 @@ let type_classes define_class approx kind env cls = 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) + let res, newenv = + Ctype.with_local_level_for_class begin fun () -> + 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 + res, env + end 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 = @@ -1915,7 +1910,6 @@ let class_type_declarations env cls = 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, @@ -1936,6 +1930,32 @@ let () = (*******************************) +(* Check that there is no references through recursive modules (GPR#6491) *) +let rec check_recmod_class_type env cty = + match cty.pcty_desc with + | Pcty_constr(lid, _) -> + ignore (Env.lookup_cltype ~use:false ~loc:lid.loc lid.txt env) + | Pcty_extension _ -> () + | Pcty_arrow(_, _, cty) -> + check_recmod_class_type env cty + | Pcty_open(od, cty) -> + let _, env = !type_open_descr env od in + check_recmod_class_type env cty + | Pcty_signature csig -> + check_recmod_class_sig env csig + +and check_recmod_class_sig env csig = + List.iter + (fun ctf -> + match ctf.pctf_desc with + | Pctf_inherit cty -> check_recmod_class_type env cty + | Pctf_val _ | Pctf_method _ + | Pctf_constraint _ | Pctf_attribute _ | Pctf_extension _ -> ()) + csig.pcsig_fields + +let check_recmod_decl env sdecl = + check_recmod_class_type env sdecl.pci_expr + (* Approximate the class declaration as class ['params] id = object end *) let approx_class sdecl = let open Ast_helper in @@ -1944,7 +1964,9 @@ let approx_class sdecl = { sdecl with pci_expr = clty' } let approx_class_declarations env sdecls = - fst (class_type_declarations env (List.map approx_class sdecls)) + let decls, env = class_type_declarations env (List.map approx_class sdecls) in + List.iter (check_recmod_decl env) sdecls; + decls, env (*******************************) @@ -2046,39 +2068,57 @@ let report_error env ppf = function (function ppf -> fprintf ppf "does not meet its constraint: it should be") | Bad_parameters (id, params, cstrs) -> - Printtyp.prepare_for_printing [params; cstrs]; + Printtyp.prepare_for_printing (params @ cstrs); fprintf ppf - "@[The abbreviation %a@ is used with parameters@ %a@ \ - which are incompatible with constraints@ %a@]" + "@[The abbreviation %a@ is used with parameter(s)@ %a@ \ + which are incompatible with constraint(s)@ %a@]" Printtyp.ident id - !Oprint.out_type (Printtyp.tree_of_typexp Type params) - !Oprint.out_type (Printtyp.tree_of_typexp Type cstrs) + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) params) + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) cstrs) + | Bad_class_type_parameters (id, params, cstrs) -> + Printtyp.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The class type #%a@ is used with parameter(s)@ %a,@ \ + whereas the class type definition@ constrains@ \ + those parameters to be@ %a@]" + Printtyp.ident id + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) params) + !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) cstrs) | Class_match_failure error -> Includeclass.report_error Type ppf error | Unbound_val lab -> fprintf ppf "Unbound instance variable %s" lab - | Unbound_type_var (printer, (ty0, real, lab, ty)) -> - let ty1 = - if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) - in - Printtyp.add_type_to_preparation ty; - Printtyp.add_type_to_preparation ty1; - let print_reason ppf (ty0, lab, ty) = + | Unbound_type_var (printer, reason) -> + let print_reason ppf { Ctype.free_variable; meth; meth_ty; } = + let (ty0, kind) = free_variable in + let ty1 = + match kind with + | Type_variable -> ty0 + | Row_variable -> Btype.newgenty(Tobject(ty0, ref None)) + in + Printtyp.add_type_to_preparation meth_ty; + Printtyp.add_type_to_preparation ty1; fprintf ppf "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound" - lab - !Oprint.out_type (Printtyp.tree_of_typexp Type ty) + meth + !Oprint.out_type (Printtyp.tree_of_typexp Type meth_ty) !Oprint.out_type (Printtyp.tree_of_typexp Type ty0) in fprintf ppf "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ @[%a@]@]" printer print_reason reason - | Non_generalizable_class (id, clty) -> + | Non_generalizable_class {id; clty; nongen_vars } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in + Printtyp.prepare_for_printing nongen_vars; fprintf ppf "@[The type of this class,@ %a,@ \ - contains type variables that cannot be generalized@]" + contains the non-generalizable type variable(s): %a.@ %a@]" (Printtyp.class_declaration id) clty + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + Printtyp.prepared_type_scheme) nongen_vars + Misc.print_see_manual manual_ref + | Cannot_coerce_self ty -> fprintf ppf "@[The type of self cannot be coerced to@ \ diff --git a/src/ocaml/typing/typeclass.mli b/src/ocaml/typing/typeclass.mli index bf89e44648..cdecc8dfb7 100644 --- a/src/ocaml/typing/typeclass.mli +++ b/src/ocaml/typing/typeclass.mli @@ -25,7 +25,6 @@ type 'a class_info = { 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; @@ -38,7 +37,6 @@ type class_type_info = { 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; } @@ -70,7 +68,7 @@ and class_type_declaration = *) val approx_class_declarations: - Env.t -> Parsetree.class_description list -> class_type_info list + Env.t -> Parsetree.class_description list -> class_type_info list * Env.t (* val type_classes : @@ -109,12 +107,16 @@ type error = | Undeclared_methods of kind * string list | Parameter_arity_mismatch of Longident.t * int * int | Parameter_mismatch of Errortrace.unification_error - | Bad_parameters of Ident.t * type_expr * type_expr + | Bad_parameters of Ident.t * type_expr list * type_expr list + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list | Class_match_failure of Ctype.class_match_failure list | Unbound_val of string - | Unbound_type_var of - (formatter -> unit) * (type_expr * bool * string * type_expr) - | Non_generalizable_class of Ident.t * Types.class_declaration + | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure + | Non_generalizable_class of + { id : Ident.t + ; clty : Types.class_declaration + ; nongen_vars : type_expr list + } | Cannot_coerce_self of type_expr | Non_collapsable_conjunction of Ident.t * Types.class_declaration * Errortrace.unification_error diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index d5884cf7a9..5240dd01f3 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -42,12 +42,6 @@ type type_expected = { 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 @@ -99,14 +93,20 @@ type error = | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * Errortrace.unification_error | Pattern_type_clash : - Errortrace.unification_error * _ pattern_desc option -> error + Errortrace.unification_error * Parsetree.pattern_desc option -> error | Or_pattern_type_clash of Ident.t * Errortrace.unification_error | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list | Expr_type_clash of Errortrace.unification_error * type_forcing_context option - * expression_desc option - | Apply_non_function of type_expr + * Parsetree.expression_desc option + | Apply_non_function of { + funct : Typedtree.expression; + func_ty : type_expr; + res_ty : type_expr; + previous_arg_loc : Location.t; + extra_arg_loc : Location.t; + } | Apply_wrong_label of arg_label * type_expr * bool | Label_multiply_defined of string | Label_missing of Ident.t list @@ -233,7 +233,9 @@ let error (loc, env, err) = | 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_non_function { t with + func_ty = deep_copy () t.func_ty; + res_ty = deep_copy () t.res_ty } | Apply_wrong_label (l, t, b) -> Apply_wrong_label (l, deep_copy () t, b) | Wrong_name (s1, t, wn) -> @@ -325,6 +327,15 @@ type recarg = | Required | Rejected +(* Whether or not patterns of the form (module M) are accepted. (If they are, + the idents will be created at the provided scope.) When module patterns are + allowed, the caller should take care to check that the introduced module + bindings' types don't escape their scope; see the callsites in [type_let] + and [type_cases] for examples. +*) +type module_patterns_restriction = + | Modules_allowed of { scope : int } + | Modules_rejected let mk_expected ?explanation ty = { ty; explanation; } @@ -466,9 +477,9 @@ let nothing_equated = TypePairs.create 0 let unify_pat_types_return_equated_pairs ?(refine = None) loc env ty ty' = try match refine with - | Some allow_recursive -> + | Some allow_recursive_equations -> unify_gadt ~equations_level:(get_gadt_equations_level ()) - ~allow_recursive env ty ty' + ~allow_recursive_equations env ty ty' | None -> unify !env ty ty'; nothing_equated @@ -482,10 +493,13 @@ 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 = + +(** [sdesc_for_hint] is used by error messages to report literals in their + original formatting *) +let unify_pat ?refine ?sdesc_for_hint 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(err, None)) -> - raise(Error(loc, env, Pattern_type_clash(err, Some pat.pat_desc))) + raise(error(loc, env, Pattern_type_clash(err, sdesc_for_hint))) (* unification of a type with a Tconstr with freshly created arguments *) let unify_head_only ~refine loc env ty constr = @@ -546,11 +560,16 @@ type pattern_variable = } type module_variable = - string loc * Location.t + { + mv_id: Ident.t; + mv_name: string Location.loc; + mv_loc: Location.t; + mv_uid: Uid.t + } let pattern_variables = ref ([] : pattern_variable list) let pattern_force = ref ([] : (unit -> unit) list) -let allow_modules = ref false +let allow_modules = ref Modules_rejected let module_variables = ref ([] : module_variable list) let reset_pattern allow = pattern_variables := []; @@ -574,19 +593,33 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty 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 + let id = + if is_module then begin + (* Unpack patterns result in both a module declaration and a value + variable of the same name being entered into the environment. (The + module is via [module_variables], and the variable is via + [pattern_variables].) *) + match !allow_modules with + | Modules_rejected -> + raise (error (loc, Env.empty, Modules_not_allowed)); + | Modules_allowed { scope } -> + let id = Ident.create_scoped name.txt ~scope in + module_variables := + { mv_id = id; + mv_name = name; + mv_loc = loc; + mv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } :: !module_variables; + id + end else + 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 = @@ -641,10 +674,10 @@ let rec build_as_type ~refine (env : Env.t ref) p = 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; + let ty = + with_local_level ~post:generalize_structure + (fun () -> instance cty.ctyp_type) + in (* This call to unify can't fail since the pattern is well typed. *) unify_pat_types ~refine p.pat_loc env (instance as_ty) (instance ty); ty @@ -718,19 +751,15 @@ let solve_Ppat_poly_constraint ~refine env loc sty expected_ty = pattern_force := force :: !pattern_force; match get_desc ty with | Tpoly (body, tyl) -> - begin_def (); - init_def generic_level; - let _, ty' = instance_poly ~keep_names:true false tyl body in - end_def (); + let _, ty' = + with_level ~level:generic_level + (fun () -> instance_poly ~keep_names:true false tyl body) + in (cty, ty, ty') | _ -> assert false let solve_Ppat_alias ~refine env pat = - begin_def (); - let ty_var = build_as_type ~refine env pat in - end_def (); - generalize ty_var; - ty_var + with_local_level ~post:generalize (fun () -> build_as_type ~refine env pat) let solve_Ppat_tuple (type a) ~refine loc env (args : a list) expected_ty = let vars = List.map (fun _ -> newgenvar ()) args in @@ -751,10 +780,10 @@ let solve_constructor_annotation env name_list sty ty_args ty_ex = {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; + let cty, ty, force = + with_local_level ~post:(fun (_,ty,_) -> generalize_structure ty) + (fun () -> Typetexp.transl_simple_type_delayed !env sty) + in pattern_force := force :: !pattern_force; let ty_args = let ty1 = instance ty and ty2 = instance ty in @@ -794,10 +823,9 @@ let solve_Ppat_construct ~refine env loc constr no_existentials 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 unify_res ty_res expected_ty = let refine = match refine, no_existentials with | None, None when constr.cstr_generalized -> Some false @@ -805,38 +833,43 @@ let solve_Ppat_construct ~refine env loc constr no_existentials 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 - (Make_existentials_abstract { env; scope = expansion_scope }) constr - in - ty_args, ty_res, unify_res ty_res, None - | Some (name_list, sty) -> - let existential_treatment = - if name_list = [] then - Make_existentials_abstract { env; scope = expansion_scope } - else - (* we will unify them (in solve_constructor_annotation) with the - local types provided by the user *) - Keep_existentials_flexible - in - let ty_args, ty_res, ty_ex = - instance_constructor existential_treatment 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 + + let ty_args, equated_types, existential_ctyp = + with_local_level_iter ~post: generalize_structure begin fun () -> + let expected_ty = instance 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 + (Make_existentials_abstract { env; scope = expansion_scope }) + constr + in + ty_args, ty_res, unify_res ty_res expected_ty, None + | Some (name_list, sty) -> + let existential_treatment = + if name_list = [] then + Make_existentials_abstract { env; scope = expansion_scope } + else + (* we will unify them (in solve_constructor_annotation) with the + local types provided by the user *) + Keep_existentials_flexible + in + let ty_args, ty_res, ty_ex = + instance_constructor existential_treatment constr + in + let equated_types = unify_res ty_res expected_ty 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 + if constr.cstr_existentials <> [] then + lower_variables_only !env expansion_scope ty_res; + ((ty_args, equated_types, existential_ctyp), + expected_ty :: ty_res :: ty_args) + end in - if constr.cstr_existentials <> [] then - lower_variables_only !env expansion_scope ty_res; - end_def (); - generalize_structure expected_ty; - generalize_structure ty_res; - List.iter generalize_structure ty_args; if !Clflags.principal && refine = None then begin (* Do not warn for counter-examples *) let exception Warn_only_once in @@ -862,18 +895,16 @@ let solve_Ppat_construct ~refine env loc constr no_existentials (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(err, _)) -> - raise(error(label_lid.loc, !env, - Label_mismatch(label_lid.txt, err))) - end; - end_def (); - generalize_structure ty_res; - generalize_structure ty_arg; - ty_arg + with_local_level_iter ~post:generalize_structure begin fun () -> + 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(err, _)) -> + raise(error(label_lid.loc, !env, + Label_mismatch(label_lid.txt, err))) + end; + (ty_arg, [ty_res; ty_arg]) + end let solve_Ppat_array ~refine loc env expected_ty = let ty_elt = newgenvar() in @@ -889,11 +920,11 @@ let solve_Ppat_lazy ~refine loc env 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(); + let cty, ty, force = + with_local_level ~post:(fun (_, ty, _) -> generalize_structure ty) + (fun () -> Typetexp.transl_simple_type_delayed !env sty) + in 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') @@ -1060,7 +1091,7 @@ end) = struct [_] -> [] | _ -> let open Printtyp in wrap_printing_env ~error:true env (fun () -> - reset(); strings_of_paths Type tpaths) + reset(); strings_of_paths (Some Type) tpaths) let disambiguate_by_type env tpath lbls = match lbls with @@ -1289,7 +1320,52 @@ let disambiguate_lid_a_list loc closed env usage expected_type lid_a_list = 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 one label is qualified [{ foo = ...; M.bar = ... }], + we will disambiguate all labels using one of the qualifying modules, + as if the user had written [{ M.foo = ...; M.bar = ... }]. + + #11630: It is important to process first the + user-qualified labels, instead of processing all labels in + order, so that error messages coming from the lookup of + M (maybe no such module/path exists) are shown to the user + in context of a qualified field [M.bar] they wrote + themselves, instead of the "ghost" qualification [M.foo] + that does not come from the source program. *) + let lbl_list = + List.map (fun (lid, _) -> + match lid.txt with + | Longident.Ldot _ -> Some (process_label lid) + | _ -> None + ) lid_a_list + in + (* Find a module prefix (if any) to qualify unqualified labels *) + let qual = + List.find_map (function + | {txt = Longident.Ldot (modname, _); _}, _ -> Some modname + | _ -> None + ) lid_a_list + in + (* Prefix unqualified labels with [qual] and resolve them. + + Prefixing unqualified labels does not change the final + disambiguation result, it restricts the set of candidates + without removing any valid choice. + It matters if users activated warnings for ambiguous or + out-of-scope resolutions -- they get less warnings by + qualifying at least one of the fields. *) + List.map2 (fun lid_a lbl -> + match lbl, lid_a with + | Some lbl, (lid, a) -> lid, lbl, a + | None, (lid, a) -> + let qual_lid = + match qual, lid.txt with + | Some modname, Longident.Lident s -> + {lid with txt = Longident.Ldot (modname, s)} + | _ -> lid + in + lid, process_label qual_lid, a + ) lid_a_list lbl_list + in if !w_pr then Location.prerr_warning loc (Warnings.Not_principal "this type-based record disambiguation") @@ -1315,39 +1391,13 @@ let disambiguate_lid_a_list loc closed env usage expected_type lid_a_list = (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 type_label_a_list loc closed env usage type_lbl_a expected_type lid_a_list = 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 + 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 = @@ -1355,7 +1405,7 @@ let type_label_a_list (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) lbl_a_list in - map_fold_cont type_lbl_a lbl_a_list k + List.map type_lbl_a lbl_a_list (* Checks over the labels mentioned in a record pattern: no duplicate definitions (error); properly closed (warning) *) @@ -1423,7 +1473,7 @@ type 'case_pattern half_typed_case = untyped_case: Parsetree.case; branch_env: Env.t; pat_vars: pattern_variable list; - unpacks: module_variable list; + module_vars: module_variable list; contains_gadt: bool; } let rec has_literal_pattern p = match p.ppat_desc with @@ -1464,186 +1514,6 @@ let check_scope_escape loc env level ty = env, Pattern_type_clash(Errortrace.unification_error ~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: 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 @@ -1693,26 +1563,20 @@ let as_comp_pattern | 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. *) +(** [type_pat] propagates the expected type, and + unification may update the typing environment. *) let rec type_pat - : type k r . k pattern_category -> + : type k . 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 -> + env: Env.t ref -> Parsetree.pattern -> type_expr -> k general_pattern + = fun category ~no_existentials ~env sp expected_ty -> 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 -> + type_pat_aux category ~no_existentials ~env sp expected_ty + with Error _ as exn -> (* We only want to catch error, not internal exceptions such as [Need_backtrack], etc. *) Msupport.erroneous_type_register expected_ty; @@ -1729,93 +1593,55 @@ let rec type_pat pat_attributes = Msupport.recovery_attributes sp.ppat_attributes; } in - k (match category with + (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 + : type k . k pattern_category -> no_existentials:_ -> + env:_ -> _ -> _ -> k general_pattern + = fun category ~no_existentials ~env sp expected_ty -> + let type_pat category ?(env=env) = + type_pat category ~no_existentials ~env in let loc = sp.ppat_loc in - let refine = - match mode with Normal -> None | Counter_example _ -> Some true in + let refine = None in let solve_expected (x : pattern) : pattern = - unify_pat ~refine env x (instance expected_ty); + unify_pat ~refine ~sdesc_for_hint:sp.ppat_desc 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 + let crp (x : k general_pattern) : k general_pattern = + match category with + | Value -> rp x + | Computation -> rcp x in + (* record {general,value,computation} pattern *) + let rp = crp + and rvp x = crp (pure category x) + and rcp x = crp (only_impure category x) in match sp.ppat_desc with Ppat_any -> - let k' d = rvp k { - pat_desc = d; + rvp { + pat_desc = Tpat_any; 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 { + let id = enter_variable loc name ty sp.ppat_attributes in + rvp { 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 { + rvp { pat_desc = Tpat_any; pat_loc = sp.ppat_loc; pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes]; @@ -1824,8 +1650,11 @@ and type_pat_aux pat_env = !env } | Some s -> let v = { name with txt = s } in + (* We're able to pass ~is_module:true here without an error because + [Ppat_unpack] is a case identified by [may_contain_modules]. See + the comment on [may_contain_modules]. *) let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in - rvp k { + rvp { pat_desc = Tpat_var (id, v); pat_loc = sp.ppat_loc; pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; @@ -1837,32 +1666,29 @@ and type_pat_aux {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 } + rvp { 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 ~refine 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 }) + let q = type_pat Value sq expected_ty in + let ty_var = solve_Ppat_alias ~refine env q in + let id = + enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes + in + rvp { 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 { + rvp @@ solve_expected { pat_desc = Tpat_constant cst; pat_loc = loc; pat_extra=[]; pat_type = type_constant cst; @@ -1880,21 +1706,20 @@ and type_pat_aux 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 + type_pat category p expected_ty (* 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 { + let pl = List.map2 (type_pat Value) spl expected_tys in + rvp { 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 }) + pat_env = !env } | Ppat_construct(lid, sarg) -> let expected_type = match extract_concrete_variant !env expected_ty with @@ -1907,12 +1732,6 @@ and type_pat_aux raise (error (loc, !env, err)) 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" @@ -1920,8 +1739,6 @@ and type_pat_aux (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) -> @@ -1988,35 +1805,29 @@ and type_pat_aux 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); + let args = List.map2 (type_pat Value) sargs ty_args in + rvp { 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 }) + pat_env = !env } | Ppat_variant(tag, sarg) -> - if tag = Parmatch.some_private_tag then - assert (match mode with Normal -> false | Counter_example _ -> true); + assert (tag <> Parmatch.some_private_tag); 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 { + let arg = + (* PR#6235: propagate type information *) + match sarg, arg_type with + Some sp, [ty] -> Some (type_pat Value sp ty) + | _ -> None + in + rvp { pat_desc = Tpat_variant(tag, arg, ref row); 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 = @@ -2029,11 +1840,10 @@ and type_pat_aux let err = Wrong_expected_kind(Record, Pattern, expected_ty) in raise (error (loc, !env, err)) in - let type_label_pat (label_lid, label, sarg) k = + let type_label_pat (label_lid, label, sarg) = 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)) + (label_lid, label, type_pat Value sarg ty_arg) in let make_record_pat lbl_pat_list = check_recordpat_labels loc lbl_pat_list closed; @@ -2045,41 +1855,34 @@ and type_pat_aux 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 + let lbl_a_list = + 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 + in + rvp @@ solve_expected (make_record_pat lbl_a_list) | 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 { + let pl = List.map (fun p -> type_pat Value p ty_elt) spl in + rvp { pat_desc = Tpat_array pl; pat_loc = loc; pat_extra=[]; pat_type = instance expected_ty; pat_attributes = sp.ppat_attributes; - pat_env = !env }) + 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 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 using with_local_level without generalizations *) + let env1, p1, p1_variables, p1_module_variables, env2, p2 = + with_local_level begin fun () -> 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 type_pat_rec env sp = type_pat category sp expected_ty ~env in let env1 = ref !env in let p1 = type_pat_rec env1 sp1 in let p1_variables = !pattern_variables in @@ -2088,183 +1891,90 @@ and type_pat_aux 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 + (env1, p1, p1_variables, p1_module_variables, env2, p2) + end + in + 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 { 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 } | 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 { + let p1 = type_pat Value sp1 nv in + rvp { pat_desc = Tpat_lazy p1; pat_loc = loc; pat_extra=[]; pat_type = instance expected_ty; pat_attributes = sp.ppat_attributes; - pat_env = !env }) + 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) + let p = type_pat category sp expected_ty' in + let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in + begin 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 } + end | Ppat_type lid -> - assert construction_not_used_in_counterexamples; let (path, p) = build_or_pat !env loc lid in - k @@ pure category @@ solve_expected + 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), + let p = type_pat category ~env p expected_ty in + 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; + { 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 { + let p_exn = type_pat Value p Predef.type_exn in + rcp { 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) +let type_pat category ?no_existentials ?(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 (error (spat.ppat_loc, env, Unrefuted_pattern pat)); - Some pat - | r -> r) - cases + Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] + (fun () -> type_pat category ~no_existentials ~env sp expected_ty) let iter_pattern_variables_type f : pattern_variable list -> unit = List.iter (fun {pv_type; _} -> f pv_type) @@ -2281,18 +1991,50 @@ let add_pattern_variables ?check ?check_as env pv = ) pv env -let type_pattern category ~lev env spat expected_ty = - reset_pattern true; +let add_module_variables env module_variables = + List.fold_left (fun env { mv_id; mv_loc; mv_name; mv_uid } -> + Typetexp.TyVarEnv.with_local_scope begin fun () -> + (* This code is parallel to the typing of Pexp_letmodule. However we + omit the call to [Mtype.lower_nongen] as it's not necessary here. + For Pexp_letmodule, the call to [type_module] is done in a raised + level and so needs to be modified to have the correct, outer level. + Here, on the other hand, we're calling [type_module] outside the + raised level, so there's no extra step to take. + *) + let modl, md_shape = + !type_module env + Ast_helper.( + Mod.unpack ~loc:mv_loc + (Exp.ident ~loc:mv_name.loc + (mkloc (Longident.Lident mv_name.txt) + mv_name.loc))) + in + let pres = + match modl.mod_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let md = + { md_type = modl.mod_type; md_attributes = []; + md_loc = mv_name.loc; + md_uid = mv_uid; } + in + Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md env + end + ) env module_variables + +let type_pattern category ~lev env spat expected_ty allow_modules = + reset_pattern allow_modules; 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 mvs = get_ref module_variables in + (pat, !new_env, get_ref pattern_force, pvs, mvs) let type_pattern_list - category no_existentials env spatl expected_tys allow + category no_existentials env spatl expected_tys allow_modules = - reset_pattern allow; + reset_pattern allow_modules; let new_env = ref env in let type_pat (attrs, pat) ty = Builtin_attributes.warning_scope ~ppwarning:false attrs @@ -2302,17 +2044,11 @@ let type_pattern_list 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 mvs = get_ref module_variables in + (patl, !new_env, get_ref pattern_force, pvs, mvs) let type_class_arg_pattern cl_num val_env met_env l spat = - reset_pattern false; + reset_pattern Modules_rejected; let nv = newvar () in let pat = type_pat Value ~no_existentials:In_class_args (ref val_env) spat nv in @@ -2359,7 +2095,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat = let type_self_pattern env spat = let open Ast_helper in let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in - reset_pattern false; + reset_pattern Modules_rejected; let nv = newvar() in let pat = type_pat Value ~no_existentials:In_self_pattern (ref env) spat nv in @@ -2370,15 +2106,356 @@ let type_self_pattern env spat = 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 +(** In [check_counter_example_pat], we will check a counter-example candidate + produced by Parmatch. This is a 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 [check_counter_example_pat] is to refine this untyped 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}) + *) + +type counter_example_checking_info = { + explosion_fuel: int; + splitting_mode: splitting_mode; + } +(** + [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. + *) + +(** 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, + [check_counter_example_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 [check_counter_example_pat], + 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 [check_counter_example_pat]. + 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). + In the GADT mode, [env] may be extended by unification, + and therefore it needs to be saved along with a [snapshot]. *) +type unification_state = + { snapshot: snapshot; + env: Env.t; } +let save_state env = + { snapshot = Btype.snapshot (); + env = !env; } +let set_state s env = + Btype.backtrack s.snapshot; + 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.pat_desc with + | Tpat_or(p1,p2,_) -> + (try find_valid_alternative f p1 with + | Empty_branch | Error _ -> find_valid_alternative f p2 + ) + | _ -> f pat + +let no_explosion info = { info with explosion_fuel = 0 } + +let enter_nonsplit_or 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 { info with splitting_mode } + +let rec check_counter_example_pat ~info ~env tp expected_ty k = + let check_rec ?(info=info) ?(env=env) = + check_counter_example_pat ~info ~env in + let loc = tp.pat_loc in + let refine = Some true in + let solve_expected (x : pattern) : pattern = + unify_pat ~refine env x (instance expected_ty); + x + in + (* "make pattern" and "make pattern then continue" *) + let mp ?(pat_type = expected_ty) desc = + { pat_desc = desc; pat_loc = loc; pat_extra=[]; + pat_type = instance pat_type; pat_attributes = []; pat_env = !env } in + let mkp k ?pat_type desc = k (mp ?pat_type desc) in + let must_backtrack_on_gadt = + match info.splitting_mode with + | Backtrack_or -> false + | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or + in + match tp.pat_desc with + Tpat_any | Tpat_var _ -> + let k' () = mkp k tp.pat_desc in + if info.explosion_fuel <= 0 then k' () else + let decrease n = {info with explosion_fuel = info.explosion_fuel - n} in + begin match Parmatch.pats_of_type !env expected_ty with + | [] -> raise Empty_branch + | [{pat_desc = Tpat_any}] -> k' () + | [tp] -> check_rec ~info:(decrease 1) tp expected_ty k + | tp :: tpl -> + if must_backtrack_on_gadt then raise Need_backtrack; + let tp = + List.fold_left + (fun tp tp' -> {tp with pat_desc = Tpat_or (tp, tp', None)}) + tp tpl + in + check_rec ~info:(decrease 5) tp expected_ty k + end + | Tpat_alias (p, _, _) -> check_rec ~info p expected_ty k + | Tpat_constant cst -> + let cst = constant_or_raise !env loc (Untypeast.constant cst) in + k @@ solve_expected (mp (Tpat_constant cst) ~pat_type:(type_constant cst)) + | Tpat_tuple tpl -> + assert (List.length tpl >= 2); + let expected_tys = solve_Ppat_tuple ~refine loc env tpl expected_ty in + let tpl_ann = List.combine tpl expected_tys in + map_fold_cont (fun (p,t) -> check_rec p t) tpl_ann (fun pl -> + mkp k (Tpat_tuple pl) + ~pat_type:(newty (Ttuple(List.map (fun p -> p.pat_type) pl)))) + | Tpat_construct(cstr_lid, constr, targs, _) -> + if constr.cstr_generalized && must_backtrack_on_gadt then + raise Need_backtrack; + let (ty_args, existential_ctyp) = + solve_Ppat_construct ~refine env loc constr None None expected_ty + in + map_fold_cont + (fun (p,t) -> check_rec p t) + (List.combine targs ty_args) + (fun args -> + mkp k (Tpat_construct(cstr_lid, constr, args, existential_ctyp))) + | Tpat_variant(tag, targ, _) -> + let constant = (targ = None) in + let arg_type, row, pat_type = + solve_Ppat_variant ~refine loc env tag constant expected_ty in + let k arg = + mkp k ~pat_type (Tpat_variant(tag, arg, ref row)) + in begin + (* PR#6235: propagate type information *) + match targ, arg_type with + Some p, [ty] -> check_rec p ty (fun p -> k (Some p)) + | _ -> k None + end + | Tpat_record(fields, closed) -> + let record_ty = generic_instance expected_ty in + let type_label_pat (label_lid, label, targ) k = + let ty_arg = + solve_Ppat_record_field ~refine loc env label label_lid record_ty in + check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) + in + map_fold_cont type_label_pat fields + (fun fields -> mkp k (Tpat_record (fields, closed))) + | Tpat_array tpl -> + let ty_elt = solve_Ppat_array ~refine loc env expected_ty in + map_fold_cont (fun p -> check_rec p ty_elt) tpl + (fun pl -> mkp k (Tpat_array pl)) + | Tpat_or(tp1, tp2, _) -> + (* We are in counter-example mode, but try to avoid backtracking *) + let must_split = + match info.splitting_mode with + | Backtrack_or -> true + | Refine_or _ -> false in + let state = save_state env in + let split_or tp = + let type_alternative pat = + set_state state env; check_rec pat expected_ty k in + find_valid_alternative type_alternative tp + in + if must_split then split_or tp else + let check_rec_result env tp : (_, abort_reason) result = + let info = enter_nonsplit_or info in + match check_rec ~info tp expected_ty ~env (fun x -> x) with + | res -> Ok res + | exception Need_backtrack -> Error Adds_constraints + | exception Empty_branch -> Error Empty + in + let p1 = check_rec_result (ref !env) tp1 in + let p2 = check_rec_result (ref !env) tp2 in + 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 info.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 tp + | Ok p, Error _ + | Error _, Ok p -> + k p + | Ok p1, Ok p2 -> + mkp k (Tpat_or (p1, p2, None)) + end + | Tpat_lazy tp1 -> + let nv = solve_Ppat_lazy ~refine loc env expected_ty in + (* do not explode under lazy: PR#7421 *) + check_rec ~info:(no_explosion info) tp1 nv + (fun p1 -> mkp k (Tpat_lazy p1)) + +let check_counter_example_pat ~counter_example_args + ?(lev=get_current_level()) env tp expected_ty = + Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () -> + check_counter_example_pat + ~info:counter_example_args ~env tp expected_ty (fun x -> x) + ) + +(* this function is passed to Partial.parmatch + to type check gadt nonexhaustiveness *) +let partial_pred ~lev ~allow_modules ~splitting_mode ?(explode=0) + env expected_ty p = + let env = ref env in + let state = save_state env in + let counter_example_args = + { + splitting_mode; + explosion_fuel = explode; + } in + try + reset_pattern allow_modules; + let typed_p = + check_counter_example_pat ~lev ~counter_example_args 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 ()) allow_modules 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 ~allow_modules ~splitting_mode ~explode env expected_ty) + loc cases + +let check_unused + ?(lev=get_current_level ()) allow_modules env expected_ty cases + = + Parmatch.check_unused + (fun refute pat -> + match + partial_pred ~lev ~allow_modules ~splitting_mode:Backtrack_or ~explode:5 + env expected_ty pat + with + Some pat' when refute -> + raise_error (error (pat.pat_loc, env, Unrefuted_pattern pat')); + Some pat + | r -> r) + cases + +(** Some delayed checks, to be executed after typing the whole + compilation unit or toplevel phrase *) +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) @@ -2478,7 +2555,7 @@ let rec is_nonexpansive exp = 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 -> + | Texp_assert (exp, _) -> is_nonexpansive exp | Texp_apply ( { exp_desc = Texp_ident (_, _, {val_kind = @@ -2534,7 +2611,7 @@ and is_nonexpansive_mod mexp = | Tstr_attribute _ -> true ) str.str_items - | Tmod_apply _ -> false + | Tmod_apply _ | Tmod_apply_unit _ -> false and is_nonexpansive_opt = function | None -> true @@ -2635,22 +2712,20 @@ let list_labels env ty = 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 get_desc pty 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 + with_local_level_iter ~post:generalize begin fun () -> + match get_desc pty with + Tpoly (body, tl) -> + (* Enforce scoping for type_let: + since body is not generic, instance_poly only makes + copies of nodes that have a Tunivar 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), exp_ty::vars) + | _ -> assert false + end 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 @@ -2770,6 +2845,19 @@ let check_partial_application ~statement exp = | _ -> doit () +let pattern_needs_partial_application_check p = + let rec check : type a. a general_pattern -> bool = fun p -> + not (List.exists (function (Tpat_constraint _, _, _) -> true | _ -> false) + p.pat_extra) && + match p.pat_desc with + | Tpat_any -> true + | Tpat_exception _ -> true + | Tpat_or (p1, p2, _) -> check p1 && check p2 + | Tpat_value p -> check (p :> value general_pattern) + | _ -> false + in + check p + (* Check that a type is generalizable at some level *) let generalizable level ty = let rec check ty = @@ -2853,6 +2941,22 @@ let may_contain_gadts p = | _ -> false) p +(* There are various things that we need to do in presence of module patterns + that aren't required if there are none. Most notably, we need to ensure the + modules are entered at the appropriate scope. The caller should use + [may_contain_modules] as an indication to set up the proper scope handling + code (via [allow_modules]) to permit module patterns. + The class of patterns identified here should stay in sync with the patterns + whose typing involves [enter_variable ~is_module:true], as these calls + will error if the scope handling isn't set up. +*) +let may_contain_modules p = + exists_ppat + (function + | {ppat_desc = Ppat_unpack _} -> true + | _ -> false) + p + let check_absent_variant env = iter_general_pattern { f = fun (type k) (pat : k general_pattern) -> match pat.pat_desc with @@ -2909,12 +3013,14 @@ let name_cases default lst = (* Typing of expressions *) -let unify_exp env exp expected_ty = +(** [sdesc_for_hint] is used by error messages to report literals in their + original formatting *) +let unify_exp ?sdesc_for_hint 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(err, tfc, None)) -> - raise (Error(loc, env, Expr_type_clash(err, tfc, Some exp.exp_desc))) + raise (error(loc, env, Expr_type_clash(err, tfc, sdesc_for_hint))) (* If [is_inferred e] is true, [e] will be typechecked without using the "expected type" provided by the context. *) @@ -2963,7 +3069,57 @@ let with_explanation explanation f = with Error (loc', env', Expr_type_clash(err', None, exp')) when not loc'.Location.loc_ghost -> let err = Expr_type_clash(err', Some explanation, exp') in - raise (Error (loc', env', err)) + raise (error (loc', env', err)) + +(* Generalize expressions *) +let generalize_structure_exp exp = generalize_structure exp.exp_type +let may_lower_contravariant_then_generalize env exp = + if maybe_expansive exp then lower_contravariant env exp.exp_type; + generalize exp.exp_type + +(* value binding elaboration *) + +let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; _ } = + let open Ast_helper in + match ct with + | None -> expr + | Some (Pvc_constraint { locally_abstract_univars=[]; typ }) -> + begin match typ.ptyp_desc with + | Ptyp_poly _ -> expr + | _ -> + let loc = { expr.pexp_loc with Location.loc_ghost = true } in + Exp.constraint_ ~loc expr typ + end + | Some (Pvc_coercion { ground; coercion}) -> + let loc = { expr.pexp_loc with Location.loc_ghost = true } in + Exp.coerce ~loc expr ground coercion + | Some (Pvc_constraint { locally_abstract_univars=vars;typ}) -> + let loc_start = pat.ppat_loc.Location.loc_start in + let loc = { expr.pexp_loc with loc_start; loc_ghost=true } in + let expr = Exp.constraint_ ~loc expr typ in + List.fold_right (Exp.newtype ~loc) vars expr + +let vb_pat_constraint ({pvb_pat=pat; pvb_expr = exp; _ } as vb) = + vb.pvb_attributes, + let open Ast_helper in + match vb.pvb_constraint, pat.ppat_desc, exp.pexp_desc with + | Some (Pvc_constraint {locally_abstract_univars=[]; typ} + | Pvc_coercion { coercion=typ; _ }), + _, _ -> + Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat typ + | Some (Pvc_constraint {locally_abstract_univars=vars; typ }), _, _ -> + let varified = Typ.varify_constructors vars typ in + let t = Typ.poly ~loc:typ.ptyp_loc vars varified in + let loc_end = typ.ptyp_loc.Location.loc_end in + let loc = { pat.ppat_loc with loc_end; loc_ghost=true } in + Pat.constraint_ ~loc pat t + | None, (Ppat_any | Ppat_constraint _), _ -> pat + | None, _, Pexp_coerce (_, _, sty) + | None, _, Pexp_constraint (_, sty) when !Clflags.principal -> + (* propagate type annotation to pattern, + to allow it to be generalized in -principal mode *) + Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat sty + | _ -> pat let rec type_exp ?recarg env sexp = (* We now delegate everything to type_expect *) @@ -2972,7 +3128,8 @@ let rec type_exp ?recarg env sexp = (* 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. + In the principal case, structural nodes of [type_expected_explained] may be + at [generic_level] (but its variables no higher than [!current_level]). *) and type_expect ?in_function ?recarg env sexp ty_expected_explained = @@ -3010,14 +3167,16 @@ and type_expect_ env sexp ty_expected_explained = let { ty = ty_expected; explanation } = ty_expected_explained in let loc = sexp.pexp_loc in + let desc = sexp.pexp_desc in (* Record the expression type before unifying it with the expected type *) let with_explanation = with_explanation explanation in + (* Unify the result with [ty_expected], enforcing the current level *) let rue exp = with_explanation (fun () -> - unify_exp env (re exp) (instance ty_expected)); + unify_exp ~sdesc_for_hint:desc env (re exp) (instance ty_expected)); exp in - match sexp.pexp_desc with + match desc with | Pexp_ident lid -> let path, desc = type_ident env ~recarg lid in let exp_desc = @@ -3081,9 +3240,10 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_let(Nonrecursive, - [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody) + [{pvb_pat=spat; pvb_attributes=[]; _ } as vb], sbody) when may_contain_gadts spat -> - (* TODO: allow non-empty attributes? *) + (* TODO: allow non-empty attributes? *) + let sval = vb_exp_constraint vb in type_expect ?in_function env {sexp with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])} @@ -3093,12 +3253,64 @@ and type_expect_ 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 + let may_contain_modules = + List.exists (fun pvb -> may_contain_modules pvb.pvb_pat) spat_sexp_list + in + let outer_level = get_current_level () in + let (pat_exp_list, body, _new_env) = + (* If the patterns contain module unpacks, there is a possibility that + the types of the let body or bound expressions mention types + introduced by those unpacks. The below code checks for scope escape + via both of these pathways (body, bound expressions). + *) + with_local_level_if may_contain_modules begin fun () -> + let allow_modules = + if may_contain_modules + then + let scope = create_scope () in + Modules_allowed { scope } + else Modules_rejected + in + let (pat_exp_list, new_env) = + type_let existential_context env rec_flag spat_sexp_list + allow_modules + in + let body = type_expect new_env sbody ty_expected_explained in + let () = + if rec_flag = Recursive then + check_recursive_bindings env pat_exp_list + in + (* The "bound expressions" component of the scope escape check. + + This kind of scope escape is relevant only for recursive + module definitions. + *) + if rec_flag = Recursive && may_contain_modules then begin + List.iter + (fun vb -> + (* [type_let] already generalized bound expressions' types + in-place. We first take an instance before checking scope + escape at the outer level to avoid losing generality of + types added to [new_env]. + *) + let bound_exp = vb.vb_expr in + generalize_structure_exp bound_exp; + let bound_exp_type = Ctype.instance bound_exp.exp_type in + let loc = proper_exp_loc bound_exp in + let outer_var = newvar2 outer_level in + (* Checking unification within an environment extended with the + module bindings allows us to correctly accept more programs. + This environment allows unification to identify more cases + where a type introduced by the module is equal to a type + introduced at an outer scope. *) + unify_exp_types loc new_env bound_exp_type outer_var) + pat_exp_list + end; + (pat_exp_list, body, new_env) + end + ~post:(fun (_pat_exp_list, body, new_env) -> + (* The "body" component of the scope escape check. *) + unify_exp new_env body (newvar ())) in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); @@ -3110,12 +3322,13 @@ and type_expect_ assert(is_optional l); (* default allowed only with optional argument *) let open Ast_helper in let default_loc = default.pexp_loc in + let default_ghost = {default.pexp_loc with loc_ghost = true} in let scases = [ Exp.case - (Pat.construct ~loc:default_loc + (Pat.construct ~loc:default_ghost (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) - (Some ([], Pat.var ~loc:default_loc (mknoloc "*sth*")))) - (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*"))); + (Some ([], Pat.var ~loc:default_ghost (mknoloc "*sth*")))) + (Exp.ident ~loc:default_ghost (mknoloc (Longident.Lident "*sth*"))); Exp.case (Pat.construct ~loc:default_loc @@ -3155,23 +3368,23 @@ and type_expect_ if TypeSet.mem ty seen then () else match get_desc ty with Tarrow (_l, ty_arg, ty_fun, _com) -> - (try unify_var env (newvar()) ty_arg + (try enforce_current_level env ty_arg with Unify _ -> assert false); lower_args (TypeSet.add 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 TypeSet.empty) ty; - funct + (* one more level for warning on non-returning functions *) + with_local_level_iter + begin fun () -> + let funct = + with_local_level_if_principal (fun () -> type_exp env sfunct) + ~post: generalize_structure_exp + in + let ty = instance funct.exp_type in + (funct, [ty]) + end + ~post:(wrap_trace_gadt_instances env (lower_args TypeSet.empty)) in let funct, sargs = let funct = type_sfunct sfunct in @@ -3190,31 +3403,25 @@ and type_expect_ | _ -> 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 ~statement:false exp) - end + 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 arg = + with_local_level (fun () -> type_exp env sarg) + ~post:(may_lower_contravariant_then_generalize env) + in let cases, partial = type_cases Computation env arg.exp_type ty_expected_explained true loc caselist in + if + List.for_all (fun c -> pattern_needs_partial_application_check c.c_lhs) + cases + then check_partial_application ~statement:false arg; re { exp_desc = Texp_match(arg, cases, partial); exp_loc = loc; exp_extra = []; @@ -3300,12 +3507,11 @@ and type_expect_ 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; + let exp = + with_local_level_if_principal + (fun () -> type_exp ~recarg env sexp) + ~post: generalize_structure_exp + in Some exp in let ty_record, expected_type = @@ -3336,10 +3542,10 @@ and type_expect_ | Some(_, _, true), Some _ -> ty_expected, expected_opath | (None | Some (_, _, false)), Some (_, p', _) -> 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; + let ty = + with_local_level ~post:generalize_structure + (fun () -> newconstr p' (instance_list decl.type_params)) + in ty, opt_exp_opath in let closed = (opt_sexp = None) in @@ -3347,9 +3553,9 @@ and type_expect_ 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) + (type_label_exp true env loc ty_record) + expected_type) + lid_sexp_list in with_explanation (fun () -> unify_exp_types loc env (instance ty_record) (instance ty_expected)); @@ -3566,11 +3772,13 @@ and type_expect_ 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 cty = + with_local_level begin fun () -> + Typetexp.transl_simple_type env ~closed:false sty + end + ~post:(fun cty -> generalize_structure cty.ctyp_type) + 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; @@ -3591,12 +3799,14 @@ and type_expect_ 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 (get_level tv) arg.exp_type in - unify_var env tv arg.exp_type; + let arg, gen = + let lv = get_current_level () in + with_local_level begin fun () -> + let arg = type_exp env sarg in + (arg, generalizable lv arg.exp_type) + end + ~post:(fun (arg,_) -> enforce_current_level env arg.exp_type) + in begin match arg.exp_desc, !self_coercion, get_desc ty' with Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _, Tconstr(path',_,_) when Path.same path path' -> @@ -3634,15 +3844,17 @@ and type_expect_ 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' + let cty, ty, force, cty', ty', force' = + with_local_level_iter ~post:generalize_structure begin fun () -> + let (cty, ty, force) = + Typetexp.transl_simple_type_delayed env sty + and (cty', ty', force') = + Typetexp.transl_simple_type_delayed env sty' + in + ((cty, ty, force, cty', ty', force'), + [ty; ty']) + end in - end_def (); - generalize_structure ty; - generalize_structure ty'; begin try let force'' = subtype env (instance ty) (instance ty') in force (); force' (); force'' () @@ -3662,95 +3874,13 @@ and type_expect_ 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, typ) = - match obj.exp_desc with - | Texp_ident(_, _, {val_kind = Val_self(sign, meths, _, _)}) -> - let id, typ = - match meths with - | Self_concrete meths -> - obj_meths := Some meths; - let id = - match Meths.find met meths with - | id -> id - | exception Not_found -> - let valid_methods = - Meths.fold (fun lab _ acc -> lab :: acc) meths [] - in - raise (error(e.pexp_loc, env, - Undefined_self_method (met, valid_methods))) - in - let typ = Btype.method_type met sign in - id, typ - | Self_virtual meths_ref -> begin - obj_meths := Some !meths_ref; - match Meths.find met !meths_ref with - | id -> id, Btype.method_type met sign - | exception Not_found -> - let id = Ident.create_local met in - let ty = newvar () in - meths_ref := Meths.add met id !meths_ref; - add_method env met Private Virtual ty sign; - Location.prerr_warning loc - (Warnings.Undeclared_virtual_method met); - id, ty - end - in - Tmeth_val id, typ - | Texp_ident(_, _, {val_kind = Val_anc (sign, meths, cl_num)}) -> - obj_meths := Some meths; - let id = - match Meths.find met meths with - | id -> id - | exception Not_found -> - let valid_methods = - Meths.fold (fun lab _ acc -> lab :: acc) meths [] - in - raise (error(e.pexp_loc, env, - Undefined_self_method (met, valid_methods))) - in - let typ = Btype.method_type met sign in - let (self_path, _) = - Env.find_value_by_name - (Longident.Lident ("self-" ^ cl_num)) env - in - Tmeth_ancestor(id, self_path), typ - | _ -> - let ty = - match filter_method env met obj.exp_type with - | ty -> ty - | exception Filter_method_failed err -> - let err = - match err with - | Unification_error err -> - Expr_type_clash(err, explanation, None) - | Not_an_object ty -> - Not_an_object(ty, explanation) - | Not_a_method -> - let valid_methods = - match get_desc (expand_head env obj.exp_type) with - | Tobject (fields, _) -> - let (fields, _) = Ctype.flatten_fields fields in - let collect_fields li (meth, meth_kind, _meth_ty) = - if field_kind_repr meth_kind = Fpublic - then meth::li else li - in - Some (List.fold_left collect_fields [] fields) - | _ -> None - in - Undefined_method(obj.exp_type, met, valid_methods) - in - raise (error(e.pexp_loc, env, err)) - in - Tmeth_name met, ty + let obj = type_exp env e in + begin try + let (obj,meth,typ) = + with_local_level_if_principal + (fun () -> type_send env loc explanation e met) + ~post:(fun (_,_,typ) -> generalize_structure typ) in - if !Clflags.principal then begin - end_def (); - generalize_structure typ; - end; let typ = match get_desc typ with | Tpoly (ty, []) -> @@ -3775,11 +3905,10 @@ and type_expect_ exp_type = typ; exp_attributes = sexp.pexp_attributes; exp_env = env } - with Error (_, _, Undefined_method _) -> + with Error (_, _, Undefined_method (_, _, valid_methods)) -> let valid_methods = - match !obj_meths with - | Some meths -> - Some (Meths.fold (fun meth _meth_ty li -> meth::li) meths []) + match valid_methods with + | Some meths -> Some meths | None -> match get_desc (expand_head env obj.exp_type) with | Tobject (fields, _) -> @@ -3877,44 +4006,55 @@ and type_expect_ assert false end | Pexp_letmodule(name, smodl, sbody) -> - let ty = newvar() in - (* remember original level *) - begin_def (); - let context = Typetexp.narrow () in - let modl, md_shape = !type_module env smodl in - Mtype.lower_nongen (get_level ty) 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 ~shape:md_shape name pres md env + let lv = get_current_level () in + let (id, pres, modl, _, body) = + with_local_level begin fun () -> + let modl, pres, id, new_env = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let modl, md_shape = !type_module env smodl in + Mtype.lower_nongen lv 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 ~shape:md_shape name pres md env + in + Some id, env + in + modl, pres, id, new_env + end in - Some id, env + (* 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 + (id, pres, modl, new_env, body) + end + ~post: begin fun (_id, _pres, _modl, new_env, body) -> + (* Ensure that local definitions do not leak. *) + (* required for implicit unpack *) + enforce_current_level new_env body.exp_type + end 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_type = body.exp_type; exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_letexception(cd, sbody) -> @@ -3937,8 +4077,14 @@ and type_expect_ | _ -> instance Predef.type_unit in + let rec innermost_location loc_stack = + match loc_stack with + | [] -> loc + | [l] -> l + | _ :: s -> innermost_location s + in rue { - exp_desc = Texp_assert cond; + exp_desc = Texp_assert (cond, innermost_location sexp.pexp_loc_stack); exp_loc = loc; exp_extra = []; exp_type; exp_attributes = sexp.pexp_attributes; @@ -3967,18 +4113,17 @@ and type_expect_ exp_env = env; } | Pexp_poly(sbody, sty) -> - if !Clflags.principal then begin_def (); let ty, cty = - match sty with None -> protect_expansion env ty_expected, None - | Some sty -> - let sty = Ast_helper.Typ.force_poly sty in - let cty = Typetexp.transl_simple_type env false sty in - cty.ctyp_type, Some cty + with_local_level_if_principal + ~post:(fun (ty,_) -> generalize_structure ty) + begin fun () -> + match sty with None -> protect_expansion env ty_expected, None + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = Typetexp.transl_simple_type env ~closed:false sty in + cty.ctyp_type, Some cty + end 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)); @@ -3989,16 +4134,20 @@ and type_expect_ { 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; + let (exp,_) = + with_local_level begin fun () -> + let vars, ty'' = + with_local_level_if_principal + (fun () -> instance_poly true tl ty') + ~post:(fun (_,ty'') -> generalize_structure ty'') + in + let exp = type_expect env sbody (mk_expected ty'') in + (exp, vars) + end + ~post: begin fun (exp,vars) -> + generalize_and_check_univars env "method" exp ty_expected vars + end + in { exp with exp_type = instance ty } | Tvar _ -> let exp = type_exp env sbody in @@ -4016,33 +4165,31 @@ and type_expect_ 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 (get_id t) then () - else begin - Hashtbl.add seen (get_id t) (); - match get_desc t with - | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty - | _ -> Btype.iter_type_expr replace t - end + (* Use [with_local_level] just for scoping *) + let body, ety, id = with_local_level begin fun () -> + (* 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 (get_id t) then () + else begin + Hashtbl.add seen (get_id t) (); + match get_desc t 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; + (body, ety, id) + 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; @@ -4107,32 +4254,33 @@ and type_expect_ 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, commu_ok)) 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, commu_ok)), commu_ok)) + let op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops = + with_local_level_iter_if_principal + ~post:generalize_structure begin fun () -> + 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, commu_ok)) 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, commu_ok)), commu_ok)) + in + begin try + unify env op_type ty_op + with Unify err -> + raise(error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err))) + end; + ((op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops), + [ty_andops; ty_params; ty_func_result; ty_result]) + end in - begin try - unify env op_type ty_op - with Unify err -> - raise(error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err))) - 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 = @@ -4249,41 +4397,40 @@ and type_function ?(in_function : (Location.t * type_expr) option) | 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 Filter_arrow_failed err -> - let err = match err with - | Unification_error unif_err -> - Expr_type_clash(unif_err, explanation, None) - | Label_mismatch { got; expected; expected_type} -> - Abstract_wrong_label { got; expected; expected_type; explanation } - | Not_a_function -> begin - match in_function with - | Some _ -> Too_many_arguments(ty_fun, explanation) - | None -> Not_a_function(ty_fun, explanation) + let ty_arg, ty_res = + with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + let (ty_arg, ty_res) = + try filter_arrow env (instance ty_expected) arg_label + with Filter_arrow_failed err -> + let err = match err with + | Unification_error unif_err -> + Expr_type_clash(unif_err, explanation, None) + | Label_mismatch { got; expected; expected_type} -> + Abstract_wrong_label { got; expected; expected_type; explanation } + | Not_a_function -> begin + match in_function with + | Some _ -> Too_many_arguments(ty_fun, explanation) + | None -> Not_a_function(ty_fun, explanation) end + in + (* Merlin: we recover with an expected type of 'a -> 'b *) + let level = get_level (instance ty_expected) in + raise_error (error(loc_fun, env, err)); + (newvar2 level, newvar2 level) in - (* Merlin: we recover with an expected type of 'a -> 'b *) - let level = get_level (instance ty_expected) in - raise_error (error(loc_fun, env, err)); - (newvar2 level, newvar2 level) - 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 + 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 + ((ty_arg, ty_res), [ty_arg; ty_res]) + end 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 @@ -4305,12 +4452,10 @@ and type_function ?(in_function : (Location.t * type_expr) option) 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 record = + with_local_level_if_principal ~post:generalize_structure_exp + (fun () -> type_exp ~recarg:Allowed env srecord) + in let ty_exp = record.exp_type in let expected_type = match extract_concrete_record env ty_exp with @@ -4593,60 +4738,77 @@ and type_format loc str env = 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 err -> - raise (error(lid.loc, env, Label_mismatch(lid.txt, err))) - 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))); + (* #4682: we try two type-checking approaches for [arg] using backtracking: + - first try: we try with [ty_arg] as expected type; + - second try; if that fails, we backtrack and try without + *) + let (vars, ty_arg, snap, arg) = + (* try the first approach *) + with_local_level begin fun () -> + let (vars, ty_arg) = + with_local_level_iter_if separate begin fun () -> + let (vars, ty_arg, ty_res) = + with_local_level_iter_if separate ~post:generalize_structure + begin fun () -> + let ((_, ty_arg, ty_res) as r) = instance_label true label in + (r, [ty_arg; ty_res]) + end + in + begin try + unify env (instance ty_res) (instance ty_expected) + with Unify err -> + raise (error(lid.loc, env, Label_mismatch(lid.txt, err))) + end; + (* Instantiate so that we can generalize internal nodes *) + let ty_arg = instance ty_arg in + ((vars, ty_arg), [ty_arg]) + end + ~post:generalize_structure + in + + 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 snap = if vars = [] then None else Some (Btype.snapshot ()) in + let arg = type_argument env sarg ty_arg (instance ty_arg) in + (vars, ty_arg, snap, arg) + end + (* Note: there is no generalization logic here as could be expected, + because it is part of the backtracking logic below. *) + in 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 + (* We detect if the first try failed here, + during generalization. *) 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 *) + with first_try_exn when maybe_expansive arg -> try + (* backtrack and try the second approach *) 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; + let arg = with_local_level (fun () -> type_exp env sarg) + ~post:(fun arg -> lower_contravariant env arg.exp_type) + in + let arg = + with_local_level begin fun () -> + let arg = {arg with exp_type = instance arg.exp_type} in + unify_exp env arg (instance ty_arg); + arg + end + ~post: begin fun arg -> + generalize_and_check_univars env "field value" arg label.lbl_arg vars + end + in {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 *) + | _ -> raise first_try_exn in (lid, label, arg) @@ -4675,12 +4837,10 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = 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 texp = + with_local_level_if_principal ~post:generalize_structure_exp + (fun () -> type_exp env sarg) + in let rec make_args args ty_fun = match get_desc (expand_head env ty_fun) with | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> @@ -4807,9 +4967,22 @@ and type_application env funct sargs = Msupport.resume_raise (error(funct.exp_loc, env, Incoherent_label_order)) | _ -> + let previous_arg_loc = + (* [typed_args] is the arguments typed until now, in reverse + order of appearance. Not all arguments have a location + attached (eg. an optional argument that is not passed). *) + typed_args + |> List.find_map + (function (_, Some (_, loc)) -> loc | _ -> None) + |> Option.value ~default:funct.exp_loc + in Msupport.resume_raise - (error(funct.exp_loc, env, Apply_non_function - (expand_head env funct.exp_type))) + (error(funct.exp_loc, env, Apply_non_function { + funct; + func_ty = expand_head env funct.exp_type; + res_ty = expand_head env ty_res; + previous_arg_loc; + extra_arg_loc = sarg.pexp_loc; })) with Msupport.Resume -> newvar(), ty_fun in @@ -4819,7 +4992,7 @@ and type_application env funct sargs = unify_exp env arg (type_option(newvar())); arg in - (ty_res, (lbl, Some arg) :: typed_args) + (ty_res, (lbl, Some (arg, Some sarg.pexp_loc)) :: typed_args) in let ignore_labels = !Clflags.classic || @@ -4839,6 +5012,7 @@ and type_application env funct sargs = end in let warned = ref false in + (* [args] remember the location of each argument in sources. *) let rec type_args args ty_fun ty_fun0 sargs = let type_unknown_args () = (* We're not looking at a *known* function type anymore, or there are no @@ -4853,7 +5027,7 @@ and type_application env funct sargs = List.map (function | l, None -> l, None - | l, Some f -> l, Some (f ())) + | l, Some (f, _loc) -> l, Some (f ())) (List.rev typed_args) in let result_ty = instance (result_type !omitted_parameters ty_fun) in @@ -4875,24 +5049,22 @@ and type_application env funct sargs = 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 - ) + 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) + (fun () -> option_none env (instance ty) Location.none) in let remaining_sargs, arg = if ignore_labels then begin @@ -4901,7 +5073,7 @@ and type_application env funct sargs = | [] -> assert false | (l', sarg) :: remaining_sargs -> if name = label_name l' || (not optional && l' = Nolabel) then - (remaining_sargs, use_arg sarg l') + (remaining_sargs, Some (use_arg sarg l', Some sarg.pexp_loc)) else if optional && not (List.exists (fun (l, _) -> name = label_name l) @@ -4909,7 +5081,7 @@ and type_application env funct sargs = List.exists (function (Nolabel, _) -> true | _ -> false) sargs then - (sargs, eliminate_optional_arg ()) + (sargs, Some (eliminate_optional_arg (), Some sarg.pexp_loc)) else raise(error(sarg.pexp_loc, env, Apply_wrong_label(l', ty_fun', optional))) @@ -4925,11 +5097,11 @@ and type_application env funct sargs = 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' + remaining_sargs, Some (use_arg sarg l', Some sarg.pexp_loc) | None -> sargs, if optional && List.mem_assoc Nolabel sargs then - eliminate_optional_arg () + Some (eliminate_optional_arg (), None) else begin (* No argument was given for this parameter, we abstract over it. *) @@ -4948,16 +5120,20 @@ and type_application env funct sargs = (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true with Filter_arrow_failed _ -> 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 ~statement:false exp; - ([Nolabel, Some exp], ty_res) - | _ -> - let ty = funct.exp_type in - type_args [] ty (instance ty) sargs + (* Extra scope to check for non-returning functions *) + with_local_level begin fun () -> + 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 ~statement:false exp; + ([Nolabel, Some exp], ty_res) + | _ -> + let ty = funct.exp_type in + type_args [] ty (instance ty) sargs + end and type_construct env loc lid sarg ty_expected_explained attrs = let { ty = ty_expected; explanation } = ty_expected_explained in @@ -4991,27 +5167,32 @@ and type_construct env loc lid sarg ty_expected_explained attrs = 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 Keep_existentials_flexible constr + let ty_args, ty_res, texp = + with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + let ty_args, ty_res, texp = + with_local_level_if separate begin fun () -> + let (ty_args, ty_res, _) = + instance_constructor Keep_existentials_flexible 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 + (ty_args, ty_res, texp) + end + ~post: begin fun (_, ty_res, texp) -> + generalize_structure ty_res; + with_explanation explanation (fun () -> + unify_exp env {texp with exp_type = instance ty_res} + (instance ty_expected)); + end + in + ((ty_args, ty_res, texp), ty_res::ty_args) + end 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 @@ -5052,11 +5233,10 @@ and type_construct env loc lid sarg ty_expected_explained attrs = 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 && get_level ty > get_level tv && not !has_errors then + (* Raise the current level to detect non-returning functions *) + let exp = with_local_level (fun () -> type_exp env sexp) in + let ty = expand_head env exp.exp_type in + if is_Tvar ty && get_level ty > get_current_level () && not !has_errors then Location.prerr_warning (final_subexpression exp).exp_loc Warnings.Nonreturning_statement; @@ -5067,68 +5247,10 @@ and type_statement ?explanation env sexp = exp else begin if not !has_errors then check_partial_application ~statement:true exp; - unify_var env tv ty; + enforce_current_level env ty; exp end -and type_unpacks ?(in_function : (Location.t * type_expr) option) - env (unpacks : to_unpack list) sbody expected_ty = - if unpacks = [] then type_expect ?in_function env sbody expected_ty else - 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, md_shape = - !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 (get_level ty) 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 ~shape:md_shape - 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 -> @@ -5143,6 +5265,8 @@ and type_cases 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 may_contain_modules = List.exists may_contain_modules patterns in + let create_inner_level = may_contain_gadts || may_contain_modules in let ty_arg = if (may_contain_gadts || erase_either) && not !Clflags.principal then correct_levels ty_arg else ty_arg @@ -5159,90 +5283,108 @@ and type_cases | _ -> true in let outer_level = get_current_level () in - let lev = - if may_contain_gadts then begin_def (); - get_current_level () + with_local_level_iter_if create_inner_level begin fun () -> + let lev = get_current_level () in + let allow_modules = + if may_contain_modules + then + (* The corresponding check for scope escape is done together with + the check for GADT-induced existentials by + [with_local_level_iter_if create_inner_level]. + *) + Modules_allowed { scope = lev } + else Modules_rejected 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); } + let half_typed_cases, ty_res, do_copy_types, ty_arg' = + (* propagation of the argument *) + with_local_level begin fun () -> + 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 htc = + with_local_level_if_principal begin fun () -> + let ty_arg = + (* propagation of pattern *) + with_local_level ~post:generalize_structure + (fun () -> instance ?partial:take_partial_instance ty_arg) + in + let (pat, ext_env, force, pvs, mvs) = + type_pattern category ~lev env pc_lhs ty_arg allow_modules + in + pattern_force := force @ !pattern_force; + { typed_pat = pat; + pat_type_for_unif = ty_arg; + untyped_case = case; + branch_env = ext_env; + pat_vars = pvs; + module_vars = mvs; + contains_gadt = contains_gadt (as_comp_pattern category pat); } + end + ~post: begin fun htc -> + iter_pattern_variables_type generalize_structure htc.pat_vars; + end + in + (* Ensure that no ambivalent pattern type escapes its branch *) + check_scope_escape htc.typed_pat.pat_loc env outer_level + htc.pat_type_for_unif; + let pat = htc.typed_pat in + {htc with typed_pat = { pat with pat_type = instance pat.pat_type }} ) - 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 + 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 (enforce_current_level env) pat_vars + ) half_typed_cases; + (half_typed_cases, ty_res, do_copy_types, ty_arg') + end + ~post: begin fun (half_typed_cases, _, _, ty_arg') -> + generalize ty_arg'; + List.iter (fun { pat_vars; _ } -> + iter_pattern_variables_type generalize pat_vars + ) half_typed_cases + end 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 ty_res' = instance ty_res in - if !Clflags.principal then begin_def (); - let cases = + let cases = with_local_level_if_principal ~post:ignore begin fun () -> List.map - (fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks; + (fun { typed_pat = pat; branch_env = ext_env; + pat_vars = pvs; module_vars = mvs; untyped_case = {pc_lhs = _; pc_guard; pc_rhs}; contains_gadt; _ } -> let ext_env = @@ -5256,15 +5398,11 @@ and type_cases ~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 ext_env = add_module_variables ext_env mvs in let ty_expected = if contains_gadt && not !Clflags.principal then - (* allow propagation from preceding branches *) + (* Take a generic copy of [ty_res] again to allow propagation of + type information from preceding branches *) correct_levels ty_res else ty_res in let guard = @@ -5272,12 +5410,12 @@ and type_cases | None -> None | Some scond -> Some - (type_unpacks ext_env unpacks scond + (type_expect ext_env 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_expected) + type_expect ?in_function ext_env + pc_rhs (mk_expected ?explanation ty_expected) in { c_lhs = pat; @@ -5286,8 +5424,7 @@ and type_cases } ) half_typed_cases - in - if !Clflags.principal then end_def (); + end in let do_init = may_contain_gadts || needs_exhaust_check in let ty_arg_check = if do_init then @@ -5303,7 +5440,7 @@ and type_cases raise (error (loc, env, No_value_clauses)); let partial = if partial_flag then - check_partial ~lev env ty_arg_check loc val_cases + check_partial ~lev allow_modules env ty_arg_check loc val_cases else Partial in @@ -5311,10 +5448,10 @@ and type_cases 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 (); + with_level_if delayed ~level:lev begin fun () -> + check_unused ~lev allow_modules env ty_arg_check val_cases ; + check_unused ~lev allow_modules env Predef.type_exn exn_cases ; + end; Parmatch.check_ambiguous_bindings val_cases ; Parmatch.check_ambiguous_bindings exn_cases in @@ -5325,24 +5462,180 @@ and type_cases (* 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 ty_res' (newvar ()) ; - end; - cases, partial + ((cases, partial), [ty_res']) + end + (* Ensure that existential types do not escape *) + ~post:(fun ty_res' -> unify_exp_types loc env ty_res' (newvar ())) (* Typing of let bindings *) -and type_let +and type_let ?check ?check_strict + existential_context env rec_flag spat_sexp_list allow_modules = + let spatl = List.map vb_pat_constraint spat_sexp_list in + let attrs_list = List.map fst spatl in + let is_recursive = (rec_flag = Recursive) in + + let (pat_list, exp_list, new_env, mvs, _pvs) = + with_local_level begin fun () -> + if existential_context = At_toplevel then Typetexp.TyVarEnv.reset (); + let (pat_list, new_env, force, pvs, mvs) = + with_local_level_if_principal begin fun () -> + let nvs = List.map (fun _ -> newvar ()) spatl in + let (pat_list, _new_env, _force, _pvs, _mvs as res) = + type_pattern_list + Value existential_context env spatl nvs allow_modules in + (* If recursive, first unify with an approximation of the + expression *) + if is_recursive then + List.iter2 + (fun pat binding -> + let pat = + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + {pat with pat_type = + snd (instance_poly ~keep_names:true false tl ty)} + | _ -> pat + in + let bound_expr = vb_exp_constraint binding in + unify_pat (ref env) pat (type_approx env bound_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; + res + end + ~post: begin fun (pat_list, _, _, pvs, _) -> + (* Generalize the structure *) + iter_pattern_variables_type generalize_structure pvs; + List.iter (fun pat -> generalize_structure pat.pat_type) pat_list + end + in + (* Note [add_module_variables after checking expressions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Don't call [add_module_variables] here, because its use of + [type_module] will fail until after we have type-checked the expression + of the let. Example: [let m : (module S) = ... in let (module M) = m in + ...] We learn the signature [S] from the type of [m] in the RHS of the + second let, and we need that knowledge for [type_module] to succeed. If + we type-checked expressions before patterns, then we could call + [add_module_variables] here. + *) + let new_env = add_pattern_variables new_env pvs in + let pat_list = + List.map + (fun pat -> {pat with pat_type = instance pat.pat_type}) + pat_list + in + (* Only bind pattern variables after generalizing *) + List.iter (fun f -> f()) force; + + let exp_list = + (* See Note [add_module_variables after checking expressions] + We can't defer type-checking module variables with recursive + definitions, so things like [let rec (module M) = m in ...] always + fail, even if the type of [m] is known. + *) + let exp_env = + if is_recursive then add_module_variables new_env mvs else env + in + type_let_def_wrap_warnings ?check ?check_strict ~is_recursive + ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs + (fun exp_env ({pvb_attributes; _} as vb) pat -> + let sexp = vb_exp_constraint vb in + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + let vars, ty' = + with_local_level_if_principal + ~post:(fun (_,ty') -> generalize_structure ty') + (fun () -> instance_poly ~keep_names:true true tl ty) + in + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp (mk_expected ty')) + in + exp, Some vars + | _ -> + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp (mk_expected pat.pat_type)) + in + exp, None) + in + List.iter2 + (fun pat (attrs, exp) -> + Builtin_attributes.warning_scope ~ppwarning:false attrs + (fun () -> + ignore(check_partial allow_modules env pat.pat_type pat.pat_loc + [case pat exp] : Typedtree.partial) + ) + ) + pat_list + (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list); + (pat_list, exp_list, new_env, mvs, + List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs) + end + ~post: begin fun (pat_list, exp_list, _, _, pvs) -> + 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 = + ]} + 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 + end + in + 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 (fun vb -> + if pattern_needs_partial_application_check vb.vb_pat then + check_partial_application ~statement:false vb.vb_expr + ) l; + (* See Note [add_module_variables after checking expressions] *) + let new_env = add_module_variables new_env mvs in + (l, new_env) + +and type_let_def_wrap_warnings ?(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 (); - + ~is_recursive ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs + type_def = let is_fake_let = match spat_sexp_list with | [{pvb_expr={pexp_desc=Pexp_match( @@ -5352,71 +5645,21 @@ and type_let 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 get_desc pat.pat_type 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 + 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 - (* 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 + if not is_recursive && 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 @@ -5428,109 +5671,78 @@ and type_let 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 + | {pvb_loc; _} :: _ -> + maybe_add_pattern_variables_ghost pvb_loc exp_env pvs | _ -> assert false end - else env in - + else exp_env + in + (* 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. + *) 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 + 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 () -> - 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 - )) + 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) -> + (fun case (pat, slot) -> if is_recursive then current_slot := slot; - match get_desc pat.pat_type 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 + type_def exp_env case pat) + 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 @@ -5540,92 +5752,34 @@ and type_let 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 = - ]} - 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 ~statement:false vb_expr - | _ -> ()) l; - (l, new_env, unpacks) + exp_list 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, commu_ok)) in - let ty_op = newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, commu_ok)) in - begin try - unify env op_type ty_op - with Unify err -> - raise(error(sop.loc, env, Andop_type_clash(sop.txt, err))) - end; - if !Clflags.principal then begin - end_def (); - generalize_structure ty_rest; - generalize_structure ty_arg; - generalize_structure ty_result - end; + let op_path, op_desc, op_type, ty_arg, ty_rest, ty_result = + with_local_level_iter_if_principal begin fun () -> + 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, commu_ok)) in + let ty_op = + newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, commu_ok)) in + begin try + unify env op_type ty_op + with Unify err -> + raise(error(sop.loc, env, Andop_type_clash(sop.txt, err))) + end; + ((op_path, op_desc, op_type, ty_arg, ty_rest, ty_result), + [ty_rest; ty_arg; ty_result]) + end + ~post:generalize_structure + in 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 @@ -5646,33 +5800,116 @@ and type_andops env sarg sands expected_ty = let let_arg, rev_ands = loop env sarg (List.rev sands) expected_ty in let_arg, List.rev rev_ands +(* Typing of method call *) +and type_send env loc explanation e met = + let obj = type_exp env e in + let (meth, typ) = + match obj.exp_desc with + | Texp_ident(_, _, {val_kind = Val_self(sign, meths, _, _)}) -> + let id, typ = + match meths with + | Self_concrete meths -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + id, typ + | Self_virtual meths_ref -> begin + match Meths.find met !meths_ref with + | id -> id, Btype.method_type met sign + | exception Not_found -> + let id = Ident.create_local met in + let ty = newvar () in + meths_ref := Meths.add met id !meths_ref; + add_method env met Private Virtual ty sign; + Location.prerr_warning loc + (Warnings.Undeclared_virtual_method met); + id, ty + end + in + Tmeth_val id, typ + | Texp_ident(_, _, {val_kind = Val_anc (sign, meths, cl_num)}) -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + let (self_path, _) = + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env + in + Tmeth_ancestor(id, self_path), typ + | _ -> + let ty = + match filter_method env met obj.exp_type with + | ty -> ty + | exception Filter_method_failed err -> + let error_ = + match err with + | Unification_error err -> + Expr_type_clash(err, explanation, None) + | Not_an_object ty -> + Not_an_object(ty, explanation) + | Not_a_method -> + let valid_methods = + match get_desc (expand_head env obj.exp_type) with + | Tobject (fields, _) -> + let (fields, _) = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if field_kind_repr meth_kind = Fpublic + then meth::li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None + in + Undefined_method(obj.exp_type, met, valid_methods) + in + raise (error(e.pexp_loc, env, error_)) + in + Tmeth_name met, ty + in + (obj,meth,typ) + (* Typing of toplevel bindings *) let type_binding env rec_flag spat_sexp_list = - Typetexp.reset_type_variables(); - let (pat_exp_list, new_env, _unpacks) = + let (pat_exp_list, new_env) = 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 + env rec_flag spat_sexp_list Modules_rejected 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 + let (pat_exp_list, new_env) = + type_let existential_ctx env rec_flag spat_sexp_list Modules_rejected 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; + let exp = + with_local_level begin fun () -> + Typetexp.TyVarEnv.reset(); + type_exp env sexp + end + ~post:(may_lower_contravariant_then_generalize env) + in match sexp.pexp_desc with Pexp_ident lid -> let loc = sexp.pexp_loc in @@ -5707,10 +5944,7 @@ let type_clash_of_trace trace = 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) + | Pconst_integer (s, _) -> Some s | _ -> None in let suffix = @@ -5725,7 +5959,8 @@ let report_literal_type_constraint expected_type const = else None in match const_str, suffix with - | Some c, Some s -> [ Location.msg "@[Hint: Did you mean `%s%c'?@]" c s ] + | Some c, Some s -> [ Location.msg "@[@{Hint@}: Did you \ + mean `%s%c'?@]" c s ] | _, _ -> [] let report_literal_type_constraint const = function @@ -5737,15 +5972,26 @@ let report_literal_type_constraint const = function end | None -> [] +let report_partial_application = function + | Some tr -> begin + match get_desc tr.Errortrace.got.Errortrace.expanded with + | Tarrow _ -> + [ Location.msg + "@[@{Hint@}: This function application is partial,@ \ + maybe some arguments are missing.@]" ] + | _ -> [] + end + | None -> [] + let report_expr_type_clash_hints exp diff = match exp with - | Some (Texp_constant const) -> report_literal_type_constraint const diff + | Some (Pexp_constant const) -> report_literal_type_constraint const diff + | Some (Pexp_apply _) -> report_partial_application diff | _ -> [] -let report_pattern_type_clash_hints - (type k) (pat : k pattern_desc option) diff = +let report_pattern_type_clash_hints pat diff = match pat with - | Some (Tpat_constant const) -> report_literal_type_constraint const diff + | Some (Ppat_constant const) -> report_literal_type_constraint const diff | _ -> [] let report_type_expected_explanation expl ppf = @@ -5784,6 +6030,42 @@ let report_unification_error ~loc ?sub env err ?type_expected_explanation txt1 txt2 ) () +let report_this_function ppf funct = + if Typedtree.exp_is_nominal funct then + let pexp = Untypeast.untype_expression funct in + Format.fprintf ppf "The function '%a'" Pprintast.expression pexp + else Format.fprintf ppf "This function" + +let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc = + let open Location in + let cnum_offset off (pos : Lexing.position) = + { pos with pos_cnum = pos.pos_cnum + off } + in + let app_loc = + (* Span the application, including the extra argument. *) + { loc_start = loc.loc_start; + loc_end = extra_arg_loc.loc_end; + loc_ghost = false } + and tail_loc = + (* Possible location for a ';'. The location is widened to overlap the end + of the argument. *) + let arg_end = previous_arg_loc.loc_end in + { loc_start = cnum_offset ~-1 arg_end; + loc_end = cnum_offset ~+1 arg_end; + loc_ghost = false } + in + let hint_semicolon = if returns_unit then [ + msg ~loc:tail_loc "@{Hint@}: Did you forget a ';'?"; + ] else [] in + let sub = hint_semicolon @ [ + msg ~loc:extra_arg_loc "This extra argument is not expected."; + ] in + errorf ~loc:app_loc ~sub + "@[@[<2>%a has type@ %a@]\ + @ It is applied to too many arguments@]" + report_this_function funct Printtyp.type_expr func_ty + let report_error ~loc env = function | Constructor_arity_mismatch(lid, expected, provided) -> Location.errorf ~loc @@ -5834,16 +6116,20 @@ let report_error ~loc env = function fprintf ppf "This expression has type") (function ppf -> fprintf ppf "but an expression was expected of type"); - | Apply_non_function typ -> - begin match get_desc typ with + | Apply_non_function { + funct; func_ty; res_ty; previous_arg_loc; extra_arg_loc + } -> + begin match get_desc func_ty with Tarrow _ -> - Location.errorf ~loc - "@[@[<2>This function has type@ %a@]\ - @ @[It is applied to too many arguments;@ %s@]@]" - Printtyp.type_expr typ "maybe you forgot a `;'."; + let returns_unit = match get_desc res_ty with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + in + report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc | _ -> Location.errorf ~loc "@[@[<2>This expression has type@ %a@]@ %s@]" - Printtyp.type_expr typ + Printtyp.type_expr func_ty "This is not a function; it cannot be applied." end | Apply_wrong_label (l, ty, extra_info) -> @@ -5966,9 +6252,9 @@ let report_error ~loc env = function (function ppf -> fprintf ppf "but is here used with type"); if b then - fprintf ppf ".@.@[%s@ %s@ %s@]" + fprintf ppf ".@.@[%s@ @{Hint@}: Consider using a fully \ + explicit coercion@ %s@]" "This simple coercion was not fully general." - "Hint: Consider using a fully explicit coercion" "of the form: `(foo : ty1 :> ty2)'." ) () | Not_a_function (ty, explanation) -> @@ -6194,6 +6480,6 @@ 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 partial_pred ~lev = let splitting_mode = Refine_or {inside_nonsplit_or = false} in - partial_pred ~splitting_mode + partial_pred ~allow_modules:(Modules_allowed { scope = lev }) ~splitting_mode ~lev diff --git a/src/ocaml/typing/typecore.mli b/src/ocaml/typing/typecore.mli index 73772b47ac..1c6374c368 100644 --- a/src/ocaml/typing/typecore.mli +++ b/src/ocaml/typing/typecore.mli @@ -98,6 +98,10 @@ type existential_restriction = | In_class_def (** or in [class c = let ... in ...] *) | In_self_pattern (** or in self pattern *) +type module_patterns_restriction = + | Modules_allowed of { scope : int } + | Modules_rejected + val type_binding: Env.t -> rec_flag -> Parsetree.value_binding list -> @@ -117,7 +121,7 @@ val type_self_pattern: Env.t -> Parsetree.pattern -> Typedtree.pattern * pattern_variable list val check_partial: - ?lev:int -> Env.t -> type_expr -> + ?lev:int -> module_patterns_restriction -> Env.t -> type_expr -> Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial val type_expect: ?in_function:(Location.t * type_expr) -> @@ -134,6 +138,7 @@ 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 generalize_structure_exp: Typedtree.expression -> unit type delayed_check val delayed_checks: delayed_check list ref val reset_delayed_checks: unit -> unit @@ -148,15 +153,21 @@ type error = | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * Errortrace.unification_error | Pattern_type_clash : - Errortrace.unification_error * _ Typedtree.pattern_desc option + Errortrace.unification_error * Parsetree.pattern_desc option -> error | Or_pattern_type_clash of Ident.t * Errortrace.unification_error | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list | Expr_type_clash of Errortrace.unification_error * type_forcing_context option - * Typedtree.expression_desc option - | Apply_non_function of type_expr + * Parsetree.expression_desc option + | Apply_non_function of { + funct : Typedtree.expression; + func_ty : type_expr; + res_ty : type_expr; + previous_arg_loc : Location.t; + extra_arg_loc : Location.t; + } | Apply_wrong_label of arg_label * type_expr * bool | Label_multiply_defined of string | Label_missing of Ident.t list @@ -257,7 +268,5 @@ val partial_pred : ?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 + Typedtree.pattern -> + Typedtree.pattern option diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index 653a326359..e01e80e5f4 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/src/ocaml/typing/typedecl.ml @@ -26,13 +26,22 @@ module String = Misc.String type native_repr_kind = Unboxed | Untagged +(* Our static analyses explore the set of type expressions "reachable" + from a type declaration, by expansion of definitions or by the + subterm relation (a type expression is syntactically contained + in another). *) +type reaching_type_path = reaching_type_step list +and reaching_type_step = + | Expands_to of type_expr * type_expr + | Contains of type_expr * type_expr + 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 + | Recursive_abbrev of string * Env.t * reaching_type_path + | Cycle_in_def of string * Env.t * reaching_type_path | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option | Constraint_failed of Env.t * Errortrace.unification_error | Inconsistent_constraint of Env.t * Errortrace.unification_error @@ -41,7 +50,7 @@ type error = definition: Path.t; used_as: type_expr; defined_as: type_expr; - expansions: (type_expr * type_expr) list; + reaching_path: reaching_type_path; } | Null_arity_external | Missing_native_external @@ -223,7 +232,7 @@ let transl_labels env univars closed lbls = Builtin_attributes.warning_scope attrs (fun () -> let arg = Ast_helper.Typ.force_poly arg in - let cty = transl_simple_type env ?univars closed arg in + let cty = transl_simple_type env ?univars ~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} @@ -250,7 +259,7 @@ let transl_labels env univars closed lbls = let transl_constructor_arguments env univars closed = function | Pcstr_tuple l -> - let l = List.map (transl_simple_type env ?univars closed) l in + let l = List.map (transl_simple_type env ?univars ~closed) l in Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), Cstr_tuple l | Pcstr_record l -> @@ -268,60 +277,61 @@ let make_constructor env loc type_path type_params svars sargs sret_type = | 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 univars, closed = - match svars with - | [] -> None, false - | vs -> - Ctype.begin_def(); - Some (make_poly_univars (List.map (fun v -> v.txt) vs)), true - in - let args, targs = - transl_constructor_arguments env univars closed sargs - in - let tret_type = transl_simple_type env ?univars closed sret_type in - let ret_type = tret_type.ctyp_type in - (* TODO add back type_path as a parameter ? *) - begin match get_desc ret_type with - | Tconstr (p', _, _) when Path.same type_path p' -> () - | _ -> - let trace = - (* Expansion is not helpful here -- the restriction on GADT return - types is purely syntactic. (In the worst case, expansion - produces gibberish.) *) - [Ctype.unexpanded_diff - ~got:ret_type - ~expected:(Ctype.newconstr type_path type_params)] + (* narrow and widen are now invoked through wrap_type_variable_scope *) + TyVarEnv.with_local_scope begin fun () -> + let closed = svars <> [] in + let targs, tret_type, args, ret_type, _univars = + Ctype.with_local_level_if closed begin fun () -> + TyVarEnv.reset (); + let univar_list = + TyVarEnv.make_poly_univars (List.map (fun v -> v.txt) svars) in + let univars = if closed then Some univar_list else None in + let args, targs = + transl_constructor_arguments env univars closed sargs in - raise (Error(sret_type.ptyp_loc, - Constraint_failed(env, - Errortrace.unification_error ~trace))) - end; - begin match univars with - | None -> () - | Some univars -> - Ctype.end_def(); - Btype.iter_type_expr_cstr_args Ctype.generalize args; - Ctype.generalize ret_type; - let _vars = instance_poly_univars env loc univars in - let set_level t = Ctype.unify_var env (Ctype.newvar()) t in - Btype.iter_type_expr_cstr_args set_level args; - set_level ret_type; - end; - widen z; + let tret_type = + transl_simple_type env ?univars ~closed sret_type in + let ret_type = tret_type.ctyp_type in + (* TODO add back type_path as a parameter ? *) + begin match get_desc ret_type with + | Tconstr (p', _, _) when Path.same type_path p' -> () + | _ -> + let trace = + (* Expansion is not helpful here -- the restriction on GADT + return types is purely syntactic. (In the worst case, + expansion produces gibberish.) *) + [Ctype.unexpanded_diff + ~got:ret_type + ~expected:(Ctype.newconstr type_path type_params)] + in + raise (Error(sret_type.ptyp_loc, + Constraint_failed( + env, Errortrace.unification_error ~trace))) + end; + (targs, tret_type, args, ret_type, univar_list) + end + ~post: begin fun (_, _, args, ret_type, univars) -> + Btype.iter_type_expr_cstr_args Ctype.generalize args; + Ctype.generalize ret_type; + let _vars = TyVarEnv.instance_poly_univars env loc univars in + let set_level t = Ctype.enforce_current_level env t in + Btype.iter_type_expr_cstr_args set_level args; + set_level ret_type; + end + in targs, Some tret_type, args, Some ret_type + end let transl_declaration env sdecl (id, uid) = (* Bind type parameters *) - reset_type_variables(); - Ctype.begin_def (); + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); 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) + transl_simple_type env ~closed:false sty, + transl_simple_type env ~closed:false sty', loc) sdecl.ptype_cstrs in let unboxed_attr = get_unboxed_from_attributes sdecl in @@ -438,7 +448,7 @@ let transl_declaration env sdecl (id, uid) = None -> None, None | Some sty -> let no_row = not (is_fixed_type sdecl) in - let cty = transl_simple_type env no_row sty in + let cty = transl_simple_type env ~closed:no_row sty in Some cty, Some cty.ctyp_type in let arity = List.length params in @@ -467,7 +477,6 @@ let transl_declaration env sdecl (id, uid) = try Ctype.unify env ty ty' with Ctype.Unify err -> raise(Error(loc, Inconsistent_constraint (env, err)))) cstrs; - Ctype.end_def (); (* Add abstract row *) if is_fixed_type sdecl then begin let p, _ = @@ -489,6 +498,7 @@ let transl_declaration env sdecl (id, uid) = typ_private = sdecl.ptype_private; typ_attributes = sdecl.ptype_attributes; } + end (* Generalize a type declaration *) @@ -644,80 +654,260 @@ let check_coherence env loc dpath decl = 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 = +(* Note: Well-foundedness for OCaml types + + We want to guarantee that all cycles within OCaml types are + "guarded". + + More precisly, we consider a reachability relation + "[t] is reachable [guarded|unguarded] from [u]" + defined as follows: + + - [t1, t2...] are reachable guarded from object types + [< m1 : t1; m2 : t2; ... >] + or polymorphic variants + [[`A of t1 | `B of t2 | ...]]. + + - [t1, t2...] are reachable rectypes-guarded from + [t1 -> t2], [t1 * t2 * ...], and all other built-in + contractive type constructors. + + (By rectypes-guarded we mean: guarded if -rectypes is set, + unguarded if it is not set.) + + - If [(t1, t2...) c] is a datatype (variant or record), + then [t1, t2...] are reachable rectypes-guarded from it. + + - If [(t1, t2...) c] is an abstract type, + then [t1, t2...] are reachable unguarded from it. + + - If [(t1, t2...) c] is an (expandable) abbreviation, + then its expansion is reachable unguarded from it. + Note that we do not define [t1, t2...] as reachable. + + - The relation is transitive and guardedness of a composition + is the disjunction of each guardedness: + if t1 is reachable from t2 and t2 is reachable from t3; + then t1 is reachable guarded from t3 if t1 is guarded in t2 + or t2 is guarded in t3, and reachable unguarded otherwise. + + A type [t] is not well-founded if and only if [t] is reachable + unguarded in [t]. + + Notice that, in the case of datatypes, the arguments of + a parametrized datatype are reachable (they must not contain + recursive occurrences of the type), but the definition of the + datatype is not defined as reachable. + + (* well-founded *) + type t = Foo of u + and u = t + + (* ill-founded *) + type 'a t = Foo of 'a + and u = u t + > Error: The type abbreviation u is cyclic + + Indeed, in the second example [u] is reachable unguarded in [u t] + -- its own definition. +*) + +(* Note: Forms of ill-foundedness + + Several OCaml language constructs could introduce ill-founded + types, and there are several distinct checks that forbid different + sources of ill-foundedness. + + 1. Type aliases. + + (* well-founded *) + type t = < x : 'a > as 'a + + (* ill-founded, unless -rectypes is used *) + type t = (int * 'a) as 'a + > Error: This alias is bound to type int * 'a + > but is used as an instance of type 'a + > The type variable 'a occurs inside int * 'a + + Ill-foundedness coming from type aliases is detected by the "occur check" + used by our type unification algorithm. See typetexp.ml. + + 2. Type abbreviations. + + (* well-founded *) + type t = < x : t > + + (* ill-founded, unless -rectypes is used *) + type t = (int * t) + > Error: The type abbreviation t is cyclic + + Ill-foundedness coming from type abbreviations is detected by + [check_well_founded] below. + + 3. Recursive modules. + + (* well-founded *) + module rec M : sig type t = < x : M.t > end = M + + (* ill-founded, unless -rectypes is used *) + module rec M : sig type t = int * M.t end = M + > Error: The definition of M.t contains a cycle: + > int * M.t + + This is also checked by [check_well_founded] below, + as called from [check_recmod_typedecl]. + + 4. Functor application + + A special case of (3) is that a type can be abstract + in a functor definition, and be instantiated with + an abbreviation in an application of the functor. + This can introduce ill-foundedness, so functor applications + must be checked by re-checking the type declarations of their result. + + module type T = sig type t end + module Fix(F:(T -> T)) = struct + (* this recursive definition is well-founded + as F(Fixed).t contains no reachable type expression. *) + module rec Fixed : T with type t = F(Fixed).t = F(Fixed) + end + + (* well-founded *) + Module M = Fix(functor (M:T) -> struct type t = < x : M.t > end) + + (* ill-founded *) + module M = Fix(functor (M:T) -> struct type t = int * M.t end);; + > Error: In the signature of this functor application: + > The definition of Fixed.t contains a cycle: + > F(Fixed).t +*) + +(* Check that a type expression is well-founded: + - if -rectypes is used, we must prevent non-contractive fixpoints + ('a as 'a) + - if -rectypes is not used, we only allow cycles in the type graph + if they go through an object or polymorphic variant type *) + +let check_well_founded env loc path to_check visited ty0 = + let rec check parents trace ty = if TypeSet.mem ty parents then begin (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) - if match get_desc ty0 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))) + let err = + let reaching_path, rec_abbrev = + (* The reaching trace is accumulated in reverse order, we + reverse it to get a reaching path. *) + match trace with + | [] -> assert false + | Expands_to (ty1, _) :: trace when (match get_desc ty1 with + Tconstr (p,_,_) -> Path.same p path | _ -> false) -> + List.rev trace, true + | trace -> List.rev trace, false + in + if rec_abbrev + then Recursive_abbrev (Path.name path, env, reaching_path) + else Cycle_in_def (Path.name path, env, reaching_path) + in raise (Error (loc, err)) end; let (fini, parents) = try + (* Map each node to the set of its already checked parents *) let prev = TypeMap.find ty !visited in if TypeSet.subset parents prev then (true, parents) else - (false, TypeSet.union parents prev) + let parents = TypeSet.union parents prev in + visited := TypeMap.add ty parents !visited; + (false, parents) with Not_found -> + visited := TypeMap.add ty parents !visited; (false, parents) in if fini then () else let rec_ok = match get_desc ty with - Tconstr(p,_,_) -> + | 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 + if rec_ok then () else + let parents = TypeSet.add ty parents in match get_desc ty 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 + | Tconstr(p, tyl, _) -> + let to_check = to_check p in + if to_check then List.iter (check_subtype parents trace ty) tyl; + begin match Ctype.try_expand_once_opt env ty with + | ty' -> check parents (Expands_to (ty, ty') :: trace) ty' + | exception Ctype.Cannot_expand -> + if not to_check then List.iter (check_subtype parents trace ty) tyl end - | _ -> Option.iter raise arg_exn + | _ -> + Btype.iter_type_expr (check_subtype parents trace ty) ty + and check_subtype parents trace outer_ty inner_ty = + check parents (Contains (outer_ty, inner_ty) :: trace) inner_ty in let snap = Btype.snapshot () in - try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty + try Ctype.wrap_trace_gadt_instances env (check TypeSet.empty []) ty0 with Ctype.Escape _ -> - (* Will be detected by check_recursion *) + (* Will be detected by check_regularity *) 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 visited = ref TypeMap.empty in + check_well_founded env loc path (Path.same path) visited + (Ctype.newconstr path args) + +(* Given a new type declaration [type t = ...] (potentially mutually-recursive), + we check that accepting the declaration does not introduce ill-founded types. + + Note: we check that the types at the toplevel of the declaration + are not reachable unguarded from themselves, that is, we check that + there is no cycle going through the "root" of the declaration. But + we *also* check that all the type sub-expressions reachable from + the root even those that are guarded, are themselves + well-founded. (So we check the absence of cycles, even for cycles + going through inner type subexpressions but not the root. + + We are not actually sure that this "deep check" is necessary + (we don't have an example at hand where it is necessary), but we + are doing it anyway out of caution. +*) let check_well_founded_decl env loc path decl to_check = let open Btype in + (* We iterate on all subexpressions of the declaration to check + "in depth" that no ill-founded type exists. *) let it = - {type_iterators with - it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in + let checked = + (* [checked] remembers the types that the iterator already + checked, to avoid looping on cyclic types. *) + ref TypeSet.empty in + let visited = + (* [visited] remembers the inner visits performed by + [check_well_founded] on each type expression reachable from + this declaration. This avoids unnecessary duplication of + [check_well_founded] work when invoked on two parts of the + type declaration that have common subexpressions. *) + ref TypeMap.empty in + {type_iterators with it_type_expr = + (fun self ty -> + if TypeSet.mem ty !checked then () else begin + check_well_founded env loc path to_check visited ty; + checked := TypeSet.add ty !checked; + self.it_do_type_expr self ty + end)} in it.it_type_declaration it (Ctype.generic_instance_declaration decl) -(* Check for ill-defined abbrevs *) +(* Check for non-regular abbreviations; an abbreviation + [type 'a t = ...] is non-regular if the expansion of [...] + contains instances [ty t] where [ty] is not equal to ['a]. -let check_recursion ~orig_env env loc path decl to_check = + Note: in the case of a constrained type definition + [type 'a t = ... constraint 'a = ...], we require + that all instances in [...] be equal to the constrainted type. +*) + +let check_regularity ~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. *) @@ -725,7 +915,7 @@ let check_recursion ~orig_env env loc path decl to_check = let visited = ref TypeSet.empty in - let rec check_regular cpath args prev_exp prev_expansions ty = + let rec check_regular cpath args prev_exp trace ty = if not (TypeSet.mem ty !visited) then begin visited := TypeSet.add ty !visited; match get_desc ty with @@ -737,7 +927,7 @@ let check_recursion ~orig_env env loc path decl to_check = definition=path; used_as=ty; defined_as=Ctype.newconstr path args; - expansions=List.rev prev_expansions; + reaching_path=List.rev trace; })) end (* Attempt to expand a type abbreviation if: @@ -758,18 +948,22 @@ let check_recursion ~orig_env env loc path decl to_check = raise (Error(loc, Constraint_failed (orig_env, err))); end; check_regular path' args - (path' :: prev_exp) ((ty,body) :: prev_expansions) + (path' :: prev_exp) (Expands_to (ty,body) :: trace) body with Not_found -> () end; - List.iter (check_regular cpath args prev_exp prev_expansions) args' + List.iter (check_subtype cpath args prev_exp trace ty) 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 + check_regular cpath args prev_exp trace ty | _ -> Btype.iter_type_expr - (check_regular cpath args prev_exp prev_expansions) ty - end in + (check_subtype cpath args prev_exp trace ty) ty + end + and check_subtype cpath args prev_exp trace outer_ty inner_ty = + let trace = Contains (outer_ty, inner_ty) :: trace in + check_regular cpath args prev_exp trace inner_ty + in Option.iter (fun body -> @@ -780,10 +974,10 @@ let check_recursion ~orig_env env loc path decl to_check = check_regular path args [] [] body) decl.type_manifest -let check_abbrev_recursion ~orig_env env id_loc_list to_check tdecl = +let check_abbrev_regularity ~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) + check_regularity ~orig_env env (List.assoc id id_loc_list) (Path.Pident id) decl to_check let check_duplicates sdecl_list = @@ -882,59 +1076,62 @@ let transl_type_decl env rec_flag sdecl_list = 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) + let tdecls, decls, new_env = + Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> + (* 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; + ((tdecls, decls, new_env), List.map snd decls) + end 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)) @@ -951,7 +1148,7 @@ let transl_type_decl env rec_flag sdecl_list = decl to_check) decls; List.iter - (check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check) tdecls; + (check_abbrev_regularity ~orig_env:env new_env id_loc_list to_check) tdecls; (* Check that all type variables are closed *) List.iter2 (fun sdecl tdecl -> @@ -1122,11 +1319,6 @@ let is_rebind ext = | 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 @@ -1171,24 +1363,34 @@ let transl_type_extension extend env loc styext = | None -> () | Some err -> raise (Error(loc, Extension_mismatch (type_path, env, 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 + let ttype_params, _type_params, constructors = + (* Note: it would be incorrect to call [create_scope] *after* + [TyVarEnv.reset] or after [with_local_level] (see #10010). *) + let scope = Ctype.create_scope () in + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + 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 + (ttype_params, type_params, constructors) + end + ~post: begin fun (_, type_params, constructors) -> + (* 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; + end 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 -> @@ -1233,17 +1435,18 @@ let transl_type_extension extend env loc styext = (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 + let scope = Ctype.create_scope () in + Ctype.with_local_level + (fun () -> + TyVarEnv.reset(); + transl_extension_constructor ~scope env + Predef.path_exn [] [] Asttypes.Public sext) + ~post: begin 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; + end 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 -> @@ -1452,8 +1655,8 @@ let transl_value_decl env loc valdecl = 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(); + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); (* In the first part of this function, we typecheck the syntactic declaration [sdecl] in the outer environment [outer_env]. *) let env = outer_env in @@ -1463,8 +1666,8 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env 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 + let cty = transl_simple_type env ~closed:false ty in + let cty' = transl_simple_type env ~closed: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 @@ -1476,7 +1679,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env let (tman, man) = match sdecl.ptype_manifest with None -> None, None | Some sty -> - let cty = transl_simple_type env no_row sty in + let cty = transl_simple_type env ~closed:no_row sty in Some cty, Some cty.ctyp_type in (* In the second part, we check the consistency between the two @@ -1541,7 +1744,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env 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 + Typedecl_variance.compute_decl env ~check:(Some id) new_sig_decl required with Typedecl_variance.Error (loc, err) -> raise (Error (loc, Variance err)) in let new_type_immediate = @@ -1573,8 +1776,6 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env 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; @@ -1587,14 +1788,15 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env typ_private = sdecl.ptype_private; typ_attributes = sdecl.ptype_attributes; } + end + ~post:(fun ttyp -> generalize_decl ttyp.typ_type) (* 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 = + Ctype.with_local_level ~post:generalize_decl begin fun () -> { type_params = make_params arity; type_arity = arity; type_kind = Type_abstract; @@ -1609,10 +1811,8 @@ let abstract_type_decl ~injective arity = type_immediate = Unknown; type_unboxed_default = false; type_uid = Uid.internal_not_actually_unique; - } in - Ctype.end_def(); - generalize_decl decl; - decl + } + end let approx_type_decl sdecl_list = let scope = Ctype.create_scope () in @@ -1623,15 +1823,15 @@ let approx_type_decl sdecl_list = 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. *) +(* 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; + check_regularity ~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 @@ -1684,6 +1884,51 @@ let tys_of_constr_args = function | Types.Cstr_tuple tl -> tl | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls +module Reaching_path = struct + type t = reaching_type_path + + (* Simplify a reaching path before showing it in error messages. *) + let simplify path = + let rec simplify : t -> t = function + | Contains (ty1, _ty2) :: Contains (_ty2', ty3) :: rest -> + (* If t1 contains t2 and t2 contains t3, then t1 contains t3 + and we don't need to show t2. *) + simplify (Contains (ty1, ty3) :: rest) + | hd :: rest -> hd :: simplify rest + | [] -> [] + in simplify path + + (* See Printtyp.add_type_to_preparation. + + Note: it is better to call this after [simplify], otherwise some + type variable names may be used for types that are removed + by simplification and never actually shown to the user. + *) + let add_to_preparation path = + List.iter (function + | Contains (ty1, ty2) | Expands_to (ty1, ty2) -> + List.iter Printtyp.add_type_to_preparation [ty1; ty2] + ) path + + let pp ppf reaching_path = + let pp_step ppf = function + | Expands_to (ty, body) -> + Format.fprintf ppf "%a = %a" + Printtyp.prepared_type_expr ty + Printtyp.prepared_type_expr body + | Contains (outer, inner) -> + Format.fprintf ppf "%a contains %a" + Printtyp.prepared_type_expr outer + Printtyp.prepared_type_expr inner + in + let comma ppf () = Format.fprintf ppf ",@ " in + Format.(pp_print_list ~pp_sep:comma pp_step) ppf reaching_path + + let pp_colon ppf path = + Format.fprintf ppf ":@;<1 2>@[%a@]" + pp path +end + let report_error ppf = function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" @@ -1695,11 +1940,22 @@ let report_error ppf = function (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 "@[The definition of %s contains a cycle:@ %a@]" - s Printtyp.type_expr ty + | Recursive_abbrev (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Printtyp.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The type abbreviation %s is cyclic%a@]" + s + Reaching_path.pp_colon reaching_path + | Cycle_in_def (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Printtyp.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The definition of %s contains a cycle%a@]" + s + Reaching_path.pp_colon reaching_path | Definition_mismatch (ty, _env, None) -> fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" "This variant or record definition" "does not match that of type" @@ -1717,40 +1973,25 @@ let report_error ppf = function (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 + | Non_regular { definition; used_as; defined_as; reaching_path } -> + let reaching_path = Reaching_path.simplify reaching_path in Printtyp.prepare_for_printing [used_as; defined_as]; - Printtyp.Naming_context.reset (); - begin match expansions with - | [] -> - fprintf ppf - "@[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 Type defined_as) - !Oprint.out_type (Printtyp.tree_of_typexp Type used_as) - | _ :: _ -> - fprintf ppf - "@[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 Type defined_as) - !Oprint.out_type (Printtyp.tree_of_typexp Type used_as) - pp_expansions expansions - end + Reaching_path.add_to_preparation reaching_path; + fprintf ppf + "@[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%t\ + All uses need to match the definition for the recursive type \ + to be regular.@]" + (Path.name definition) + !Oprint.out_type (Printtyp.tree_of_typexp Type defined_as) + !Oprint.out_type (Printtyp.tree_of_typexp Type used_as) + (fun pp -> + let is_expansion = function Expands_to _ -> true | _ -> false in + if List.exists is_expansion reaching_path then + fprintf pp "@ after the following expansion(s)%a@ " + Reaching_path.pp_colon reaching_path + else fprintf pp ".@ ") | Inconsistent_constraint (env, err) -> fprintf ppf "@[The type constraints are not consistent.@ "; Printtyp.report_unification_error ppf env err @@ -1774,13 +2015,13 @@ let report_error ppf = function 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) - ) + 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) + 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 ^ ": ") @@ -1839,27 +2080,57 @@ let report_error ppf = function | false, false -> if inj = "" then "unrestricted" else inj 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_variable_error { error; variable; context } -> + Printtyp.prepare_for_printing [ variable ]; + begin match context with + | Type_declaration (id, decl) -> + Printtyp.add_type_declaration_to_preparation id decl; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the definition" + (Printtyp.prepared_type_declaration id) + decl + | Gadt_constructor c -> + Printtyp.add_constructor_to_preparation c; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the GADT constructor" + Printtyp.prepared_constructor + c + | Extension_constructor (id, e) -> + Printtyp.add_extension_constructor_to_preparation e; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the extension constructor" + (Printtyp.prepared_extension_constructor id) + e + end; + begin match error with + | Variance_not_reflected -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" + Printtyp.prepared_type_expr variable + "has a variance that" + "is not reflected by its occurrence in type parameters." + | No_variable -> + fprintf ppf "@[%s@ %a@ %s@ %s@]@]" + "the type variable" + Printtyp.prepared_type_expr variable + "cannot be deduced" + "from the type parameters." + | Variance_not_deducible -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" + Printtyp.prepared_type_expr variable + "has a variance that" + "cannot be deduced from the type parameters." + end | Variance_not_satisfied n -> - fprintf ppf "@[%s@ %s@ The %d%s type parameter" + fprintf ppf "@[@[%s@ %s@ The %d%s type parameter" "In this definition, expected parameter" "variances are not satisfied." n (Misc.ordinal_suffix n)); (match n with - | No_variable -> () + | Variance_variable_error { error = No_variable; _ } -> () | _ -> - fprintf ppf " was expected to be %s,@ but it is %s.@]" + 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 @@ -1916,7 +2187,8 @@ let report_error ppf = function "@[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.@]@,\ - @[@[Hint: If you intended to define a private type abbreviation,@ \ + @[@[@{Hint@}: If you intended to define a private \ + type abbreviation,@ \ write explicitly@]@;<1 2>private %a@]" Printtyp.type_expr ty Printtyp.type_expr ty diff --git a/src/ocaml/typing/typedecl.mli b/src/ocaml/typing/typedecl.mli index 0fb68edf42..013fae4300 100644 --- a/src/ocaml/typing/typedecl.mli +++ b/src/ocaml/typing/typedecl.mli @@ -60,13 +60,18 @@ val is_fixed_type : Parsetree.type_declaration -> bool type native_repr_kind = Unboxed | Untagged +type reaching_type_path = reaching_type_step list +and reaching_type_step = + | Expands_to of type_expr * type_expr + | Contains of type_expr * type_expr + 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 + | Recursive_abbrev of string * Env.t * reaching_type_path + | Cycle_in_def of string * Env.t * reaching_type_path | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option | Constraint_failed of Env.t * Errortrace.unification_error | Inconsistent_constraint of Env.t * Errortrace.unification_error @@ -75,7 +80,7 @@ type error = definition: Path.t; used_as: type_expr; defined_as: type_expr; - expansions: (type_expr * type_expr) list; + reaching_path: reaching_type_path; } | Null_arity_external | Missing_native_external diff --git a/src/ocaml/typing/typedecl_immediacy.ml b/src/ocaml/typing/typedecl_immediacy.ml index 4a57f37cf9..f1f0594f9a 100644 --- a/src/ocaml/typing/typedecl_immediacy.ml +++ b/src/ocaml/typing/typedecl_immediacy.ml @@ -29,7 +29,7 @@ let compute_decl env tdecl = | None -> Type_immediacy.Unknown | Some argrepr -> Ctype.immediacy env argrepr end - | (Type_variant (_ :: _ as cstrs, _), _) -> + | (Type_variant (cstrs, _), _) -> if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs) then Type_immediacy.Always diff --git a/src/ocaml/typing/typedecl_variance.ml b/src/ocaml/typing/typedecl_variance.ml index 05b0c2eba6..ca0521aec9 100644 --- a/src/ocaml/typing/typedecl_variance.ml +++ b/src/ocaml/typing/typedecl_variance.ml @@ -22,15 +22,27 @@ module TypeMap = Btype.TypeMap type surface_variance = bool * bool * bool +type variance_variable_context = + | Type_declaration of Ident.t * type_declaration + | Gadt_constructor of constructor_declaration + | Extension_constructor of Ident.t * extension_constructor + +type variance_variable_error = + | No_variable + | Variance_not_reflected + | Variance_not_deducible + type variance_error = -| Variance_not_satisfied of int -| No_variable -| Variance_not_reflected -| Variance_not_deducible + | Variance_not_satisfied of int + | Variance_variable_error of { + error : variance_variable_error; + context : variance_variable_context; + variable : type_expr + } type error = -| Bad_variance of variance_error * surface_variance * surface_variance -| Varying_anonymous + | Bad_variance of variance_error * surface_variance * surface_variance + | Varying_anonymous exception Error of Location.t * error @@ -50,13 +62,7 @@ let compute_variance env visited vari ty = let compute_same = compute_variance_rec vari in match get_desc ty 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_variance_rec (Variance.conjugate vari) ty1; compute_same ty2 | Ttuple tl -> List.iter compute_same tl @@ -65,25 +71,8 @@ let compute_variance env visited vari ty = 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) + (fun ty v -> compute_variance_rec (compose vari v) ty) tl decl.type_variance with Not_found -> List.iter (compute_variance_rec unknown) tl @@ -102,14 +91,7 @@ let compute_variance env visited vari ty = 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 *) + let v = Variance.(inter vari unknown) in (* cf PR#7269 *) List.iter (compute_variance_rec v) tyl | _ -> ()) (row_fields row); @@ -118,18 +100,16 @@ let compute_variance env visited vari 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 + let v = Variance.(compose vari full) 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))) + set_if p May_pos (set_if n May_neg (set_if i Inj null)) -let injective = Variance.(set Inj true null) +let injective = Variance.(set Inj null) let compute_variance_type env ~check (required, loc) decl tyl = (* Requirements *) @@ -177,7 +157,9 @@ let compute_variance_type env ~check (required, loc) decl tyl = try check ty; compute_variance env tvl injective ty with Exit -> ()) params; - if check then begin + begin match check with + | None -> () + | Some context -> (* Check variance of parameters *) let pos = ref 0 in List.iter2 @@ -219,15 +201,29 @@ let compute_variance_type env ~check (required, loc) decl tyl = 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.exists (eq_type 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 + let (c1,n1) = get_upper v1 and (c2,n2,i2) = get_lower v2 in + if c1 && not c2 || n1 && not n2 then begin + match List.find_opt (eq_type ty) fvl with + | Some variable -> + let error = + if not i2 then + No_variable + else if c2 || n2 then + Variance_not_reflected + else + Variance_not_deducible + in + let variance_error = + Variance_variable_error { error; context; variable } + in + raise + (Error (loc + , Bad_variance ( variance_error + , (c1,n1,false) + , (c2,n2,false)))) + | None -> + Btype.iter_type_expr check ty + end in List.iter (fun (_,ty) -> check ty) tyl; end; @@ -242,15 +238,9 @@ let compute_variance_type env ~check (required, loc) decl tyl = 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) + if not concr || Btype.is_Tvar ty then v else + union v + (if p then if n then full else covariant else conjugate covariant)) params required let add_false = List.map (fun ty -> false, ty) @@ -296,49 +286,78 @@ let compute_variance_gadt env ~check (required, loc as rloc) decl (for_constr tl) | _ -> assert false -let compute_variance_extension env ~check decl ext rloc = +let compute_variance_extension env decl ext rloc = + let check = + Some (Extension_constructor (ext.Typedtree.ext_id, ext.Typedtree.ext_type)) + in + let ext = ext.Typedtree.ext_type in compute_variance_gadt env ~check rloc {decl with type_params = ext.ext_type_params} (ext.ext_args, ext.ext_ret_type) +let compute_variance_gadt_constructor env ~check rloc decl tl = + let check = + match check with + | Some _ -> Some (Gadt_constructor tl) + | None -> None + in + compute_variance_gadt env ~check rloc decl + (tl.Types.cd_args, tl.Types.cd_res) + let compute_variance_decl env ~check decl (required, _ as rloc) = + let check = + Option.map (fun id -> Type_declaration (id, decl)) check + in 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) + else begin + let mn = + match decl.type_manifest with + None -> [] + | Some ty -> [ false, ty ] + in + let vari = + 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 vari = + List.map + (fun ty -> + compute_variance_type env ~check rloc + {decl with type_private = Private} + (add_false [ ty ]) + ) + (Option.to_list decl.type_manifest) + in + let constructor_variance = + List.map + (compute_variance_gadt_constructor env ~check rloc decl) + tll + in + match List.append vari constructor_variance with + | vari :: rem -> + List.fold_left (List.map2 Variance.union) vari rem + | _ -> 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) + in + if mn = [] || decl.type_kind <> Type_abstract then + List.map Variance.strengthen vari + else vari + end let is_hash id = let s = Ident.name id in @@ -346,14 +365,13 @@ let is_hash id = 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) + ignore (compute_variance_extension env decl ext 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)) +let check_decl env id decl req = + ignore (compute_variance_decl env ~check:(Some id) decl (req, decl.type_loc)) type prop = Variance.t list type req = surface_variance list @@ -366,11 +384,11 @@ let property : (prop, req) Typedecl_properties.property = 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 + compute_decl env ~check:None 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 + if is_hash id then () else check_decl env id decl req in { eq; merge; @@ -402,7 +420,7 @@ let update_decls env sdecls decls = let update_class_decls env cldecls = let decls, required = List.fold_right - (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) -> + (fun (obj_id, obj_abbr, _clty, _cltydef, ci) (decls, req) -> (obj_id, obj_abbr) :: decls, variance_of_params ci.Typedtree.ci_params :: req) cldecls ([],[]) @@ -410,9 +428,11 @@ let update_class_decls env cldecls = let decls = Typedecl_properties.compute_property property env decls required in List.map2 - (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) -> + (fun (_,decl) (_, _, 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})) + (decl, {clty with cty_variance = variance}, + {cltydef with + clty_variance = variance; + clty_hash_type = {cltydef.clty_hash_type with type_variance = variance} + })) decls cldecls diff --git a/src/ocaml/typing/typedecl_variance.mli b/src/ocaml/typing/typedecl_variance.mli index 941ab99299..6392e61dd1 100644 --- a/src/ocaml/typing/typedecl_variance.mli +++ b/src/ocaml/typing/typedecl_variance.mli @@ -29,15 +29,27 @@ type prop = Variance.t list type req = surface_variance list val property : (Variance.t list, req) property +type variance_variable_context = + | Type_declaration of Ident.t * type_declaration + | Gadt_constructor of constructor_declaration + | Extension_constructor of Ident.t * extension_constructor + +type variance_variable_error = + | No_variable + | Variance_not_reflected + | Variance_not_deducible + type variance_error = -| Variance_not_satisfied of int -| No_variable -| Variance_not_reflected -| Variance_not_deducible + | Variance_not_satisfied of int + | Variance_variable_error of { + error : variance_variable_error; + context : variance_variable_context; + variable : type_expr + } type error = -| Bad_variance of variance_error * surface_variance * surface_variance -| Varying_anonymous + | Bad_variance of variance_error * surface_variance * surface_variance + | Varying_anonymous exception Error of Location.t * error @@ -46,7 +58,7 @@ val check_variance_extension : Typedtree.extension_constructor -> req * Location.t -> unit val compute_decl : - Env.t -> check:bool -> type_declaration -> req -> prop + Env.t -> check:Ident.t option -> type_declaration -> req -> prop val update_decls : Env.t -> Parsetree.type_declaration list -> @@ -55,9 +67,9 @@ val update_decls : val update_class_decls : Env.t -> - (Ident.t * Typedecl_properties.decl * Types.type_declaration * + (Ident.t * Typedecl_properties.decl * Types.class_declaration * Types.class_type_declaration * 'a Typedtree.class_infos) list -> - (Typedecl_properties.decl * Types.type_declaration * + (Typedecl_properties.decl * 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 index 8b8b9a7145..f97d52a8d3 100644 --- a/src/ocaml/typing/typedtree.ml +++ b/src/ocaml/typing/typedtree.ml @@ -134,7 +134,7 @@ and expression_desc = Ident.t option * string option loc * Types.module_presence * module_expr * expression | Texp_letexception of extension_constructor * expression - | Texp_assert of expression + | Texp_assert of expression * Location.t | Texp_lazy of expression | Texp_object of class_structure * string list | Texp_pack of module_expr @@ -254,6 +254,7 @@ and module_expr_desc = | Tmod_structure of structure | Tmod_functor of functor_parameter * module_expr | Tmod_apply of module_expr * module_expr * module_coercion + | Tmod_apply_unit of module_expr | Tmod_constraint of module_expr * Types.module_type * module_type_constraint * module_coercion | Tmod_unpack of expression * Types.module_type @@ -615,7 +616,6 @@ and 'a class_infos = 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; @@ -850,6 +850,22 @@ let split_pattern pat = in split_pattern pat +(* Expressions are considered nominal if they can be used as the subject of a + sentence or action. In practice, we consider that an expression is nominal + if they satisfy one of: + - Similar to an identifier: words separated by '.' or '#'. + - Do not contain spaces when printed. + *) +let rec exp_is_nominal exp = + match exp.exp_desc with + | _ when exp.exp_attributes <> [] -> false + | Texp_ident _ | Texp_instvar _ | Texp_constant _ + | Texp_variant (_, None) + | Texp_construct (_, _, []) -> + true + | Texp_field (parent, _, _) | Texp_send (parent, _) -> exp_is_nominal parent + | _ -> false + (* Merlin specific *) let unpack_functor_me me = diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli index ba840ef71f..4f4ca2b5ae 100644 --- a/src/ocaml/typing/typedtree.mli +++ b/src/ocaml/typing/typedtree.mli @@ -69,6 +69,8 @@ and pat_extra = | Tpat_unpack (** (module P) { pat_desc = Tpat_var "P" ; pat_extra = (Tpat_unpack, _, _) :: ... } + (module _) { pat_desc = Tpat_any + ; pat_extra = (Tpat_unpack, _, _) :: ... } *) and 'k pattern_desc = @@ -270,7 +272,7 @@ and expression_desc = Ident.t option * string option loc * Types.module_presence * module_expr * expression | Texp_letexception of extension_constructor * expression - | Texp_assert of expression + | Texp_assert of expression * Location.t | Texp_lazy of expression | Texp_object of class_structure * string list | Texp_pack of module_expr @@ -397,6 +399,7 @@ and module_expr_desc = | Tmod_structure of structure | Tmod_functor of functor_parameter * module_expr | Tmod_apply of module_expr * module_expr * module_coercion + | Tmod_apply_unit of module_expr | Tmod_constraint of module_expr * Types.module_type * module_type_constraint * module_coercion (** ME (constraint = Tmodtype_implicit) @@ -762,7 +765,6 @@ and 'a class_infos = 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; @@ -833,6 +835,10 @@ val pat_bound_idents_full: val split_pattern: computation general_pattern -> pattern option * pattern option +(** Whether an expression looks nice as the subject of a sentence in a error + message. *) +val exp_is_nominal : expression -> bool + (* Merlin specific *) val unpack_functor_me : module_expr -> functor_parameter * module_expr diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml index d8a180482c..201b78c0fe 100644 --- a/src/ocaml/typing/typemod.ml +++ b/src/ocaml/typing/typemod.ml @@ -57,8 +57,9 @@ type error = | 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_module of module_type + | Non_generalizable of { vars : type_expr list; expression : type_expr } + | Non_generalizable_module of + { vars : type_expr list; item : value_description; mty : module_type } | Implementation_is_required of string | Interface_not_compiled of string | Not_allowed_in_functor_body @@ -85,6 +86,7 @@ let rec path_concat head p = Pident tail -> Pdot (Pident head, Ident.name tail) | Pdot (pre, s) -> Pdot (path_concat head pre, s) | Papply _ -> assert false + | Pextra_ty (p, extra) -> Pextra_ty (path_concat head p, extra) (* Extract a signature from a module type *) @@ -240,7 +242,7 @@ let check_type_decl env sg loc id row_id newdecl decl = 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))) + set_if p May_pos (set_if n May_neg (set_if i Inj null)) let rec iter_path_apply p ~f = match p with @@ -250,6 +252,7 @@ let rec iter_path_apply p ~f = iter_path_apply p1 ~f; iter_path_apply p2 ~f; f p1 p2 (* after recursing, so we know both paths are well typed *) + | Pextra_ty _ -> assert false let path_is_strict_prefix = let rec list_is_strict_prefix l ~prefix = @@ -905,14 +908,13 @@ and approx_sig env ssg = (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 decls, env = 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 @@ -1718,7 +1720,6 @@ and transl_signature ?(keep_warnings = false) env sg = 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; Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc; ) classes; res @@ -1730,8 +1731,8 @@ and transl_signature ?(keep_warnings = false) env sg = 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)] + Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported) + ] ) classes [rem] |> List.flatten in @@ -1754,7 +1755,6 @@ and transl_signature ?(keep_warnings = false) env sg = 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; Env.register_uid decl.clsty_ty_decl.clty_uid decl.clsty_ty_decl.clty_loc; @@ -1769,8 +1769,6 @@ and transl_signature ?(keep_warnings = false) env sg = [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 @@ -1929,7 +1927,9 @@ let rec path_of_module mexp = Papply(path_of_module funct, path_of_module arg) | Tmod_constraint (mexp, _, _, _) -> path_of_module mexp - | _ -> raise Not_a_path + | (Tmod_structure _ | Tmod_functor _ | Tmod_apply_unit _ | Tmod_unpack _ | + Tmod_apply _ | Tmod_hole) -> + raise Not_a_path let path_of_module mexp = try Some (path_of_module mexp) with Not_a_path -> None @@ -1938,12 +1938,12 @@ let path_of_module mexp = do not contain non-generalized type variable *) let rec nongen_modtype env = function - Mty_ident _ -> false - | Mty_alias _ -> false - | Mty_for_hole -> false + Mty_ident _ -> None + | Mty_alias _ -> None + | Mty_for_hole -> None | Mty_signature sg -> let env = Env.add_signature sg env in - List.exists (nongen_signature_item env) sg + List.find_map (nongen_signature_item env) sg | Mty_functor(arg_opt, body) -> let env = match arg_opt with @@ -1955,18 +1955,35 @@ let rec nongen_modtype env = function nongen_modtype env body and nongen_signature_item env = function - Sig_value(_id, desc, _) -> Ctype.nongen_schema env desc.val_type + | Sig_value(_id, desc, _) -> + Ctype.nongen_vars_in_schema env desc.val_type + |> Option.map (fun vars -> (vars, desc)) | Sig_module(_id, _, md, _, _) -> nongen_modtype env md.md_type - | _ -> false + | _ -> None + +let check_nongen_modtype env loc mty = + nongen_modtype env mty + |> Option.iter (fun (vars, item) -> + let vars = Btype.TypeSet.elements vars in + let error = + Non_generalizable_module { vars; item; mty } + in + raise(Error(loc, env, error)) + ) let check_nongen_signature_item env sig_item = match sig_item with Sig_value(_id, vd, _) -> - if Ctype.nongen_schema env vd.val_type then - raise (Error (vd.val_loc, env, Non_generalizable vd.val_type)) + Ctype.nongen_vars_in_schema env vd.val_type + |> Option.iter (fun vars -> + let vars = Btype.TypeSet.elements vars in + let error = + Non_generalizable { vars; expression = vd.val_type } + in + raise (Error (vd.val_loc, env, error)) + ) | Sig_module (_id, _, md, _, _) -> - if nongen_modtype env md.md_type then - raise(Error(md.md_loc, env, Non_generalizable_module md.md_type)) + check_nongen_modtype env md.md_loc md.md_type | _ -> () let check_nongen_signature env sg = @@ -2212,23 +2229,30 @@ let wrap_constraint_with_shape env mark arg mty (* Type a module value expression *) -(* Summary for F(X) *) +(* These describe the X in [F(X)] (which might be missing, for [F ()]) *) +type argument_summary = { + is_syntactic_unit: bool; + arg: Typedtree.module_expr; + path: Path.t option; + shape: Shape.t +} + 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; - shape: Shape.t + arg: argument_summary option (* None for () *) } -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 simplify_app_summary app_view = match app_view.arg with + | None -> + Includemod.Error.Unit, Mty_signature [] + | Some arg -> + let mty = arg.arg.mod_type in + match arg.is_syntactic_unit , arg.path with + | true , _ -> Includemod.Error.Empty_struct, 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 @@ -2342,7 +2366,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc }, Shape.abs funct_shape_param body_shape - | Pmod_apply _ -> + | Pmod_apply _ | Pmod_apply_unit _ -> type_application smod.pmod_loc sttn funct_body env smod | Pmod_constraint(sarg, smty) -> let arg, arg_shape = type_module ~alias true funct_body anchor env sarg in @@ -2374,12 +2398,11 @@ and type_module_aux ~alias sttn funct_body anchor env smod = | _ -> 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 exp = + Ctype.with_local_level_if_principal + (fun () -> Typecore.type_exp env sexp) + ~post:Typecore.generalize_structure_exp + in let mty = match get_desc (Ctype.expand_head env exp.exp_type) with Tpackage (p, fl) -> @@ -2419,61 +2442,96 @@ and type_module_aux ~alias sttn funct_body anchor env smod = 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) -> + | Pmod_apply (f, sarg) -> let arg, shape = 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 []; + let summary = { + loc = smod.pmod_loc; + attributes = smod.pmod_attributes; + f_loc = f.pmod_loc; + arg = Some { + is_syntactic_unit = sarg.pmod_desc = Pmod_structure []; arg; - arg_path = path_of_module arg; - shape + path = path_of_module arg; + shape; } - in + } in + extract_application funct_body env (summary::sargs) f + | Pmod_apply_unit f -> + let summary = { + loc = smod.pmod_loc; + attributes = smod.pmod_attributes; + f_loc = f.pmod_loc; + arg = None + } in extract_application funct_body env (summary::sargs) f | _ -> smod, sargs in let sfunct, args = extract_application funct_body env [] smod in let funct, funct_shape = - let strengthen = - strengthen && List.for_all (fun {arg_path;_} -> arg_path <> None) args + let has_path { arg } = match arg with + | None | Some { path = None } -> false + | Some { path = Some _ } -> true in + let strengthen = strengthen && List.for_all has_path 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, funct_shape) args and type_one_application ~ctx:(apply_loc,md_f,args) - funct_body env (funct, funct_shape) app_view = + funct_body env (funct, funct_shape) 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)); + begin match app_view.arg with + | None -> () + | Some arg -> + if arg.is_syntactic_unit then + (* this call to warning_scope allows e.g. + [ F (struct end [@warning "-73"]) ] + not to warn; useful when generating code that must + work over multiple versions of OCaml *) + Builtin_attributes.warning_scope arg.arg.mod_attributes @@ fun () -> + Location.prerr_warning arg.arg.mod_loc + Warnings.Generative_application_expects_unit + else + raise (Error (app_view.f_loc, env, Apply_generative)); + end; 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); + Msupport.raise_error + (Error (apply_loc, env, Not_allowed_in_functor_body)); + { mod_desc = Tmod_apply_unit funct; mod_type = mty_res; mod_env = env; mod_attributes = app_view.attributes; mod_loc = funct.mod_loc }, - Shape.app funct_shape ~arg:app_view.shape + Shape.app funct_shape ~arg:Shape.dummy_mod | Mty_functor (Named (param, mty_param), mty_res) as mty_functor -> + let apply_error () = + let args = List.map simplify_app_summary args in + let mty_f = md_f.mod_type in + let lid_app = None in + Includemod.Apply_error {loc=apply_loc;env;lid_app;mty_f;args} + in + begin match app_view with + | { arg = None; loc = app_loc; attributes = app_attributes; _ } -> + Msupport.raise_error (apply_error ()); + { mod_desc = Tmod_apply_unit(funct); + mod_type = mty_res; + mod_env = env; + mod_attributes = app_attributes; + mod_loc = app_loc }, + funct_shape + | { loc = app_loc; attributes = app_attributes; + arg = Some { shape = arg_shape; path = arg_path; arg } } -> 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)); + try Includemod.modtypes + ~loc:arg.mod_loc ~mark:Mark_both env arg.mod_type mty_param + with Includemod.Error _ -> + Msupport.raise_error (apply_error ()); Tcoerce_none in let mty_appl = - match app_view.arg_path with + match arg_path with | Some path -> let scope = Ctype.create_scope () in let subst = @@ -2489,22 +2547,21 @@ and type_one_application ~ctx:(apply_loc,md_f,args) | Some param -> let parent_env = env in let env = - Env.add_module ~arg:true param Mp_present - app_view.arg.mod_type env + Env.add_module ~arg:true param Mp_present arg.mod_type env in - check_well_formed_module env app_view.loc + check_well_formed_module env app_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)) + raise (Error(app_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 + ~loc:app_loc ~mark:Mark_neither env mty_res nondep_mty with | Tcoerce_none -> () | _ -> @@ -2520,12 +2577,13 @@ and type_one_application ~ctx:(apply_loc,md_f,args) 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_desc = Tmod_apply(funct, arg, coercion); mod_type = mty_appl; mod_env = env; - mod_attributes = app_view.attributes; - mod_loc = app_view.loc }, - Shape.app ~arg:app_view.shape funct_shape + mod_attributes = app_attributes; + mod_loc = app_loc }, + Shape.app ~arg:arg_shape funct_shape + end | Mty_alias path -> raise(Error(app_view.f_loc, env, Cannot_scrape_alias path)) | _ -> @@ -2867,13 +2925,11 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho 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; Env.register_uid cls.cls_decl.cty_uid loc; let map f id acc = f acc id cls.cls_decl.cty_uid in map Shape.Map.add_class cls.cls_id acc |> map Shape.Map.add_class_type cls.cls_ty_id |> map Shape.Map.add_type cls.cls_obj_id - |> map Shape.Map.add_type cls.cls_typesharp_id ) shape_map classes in Tstr_class @@ -2886,8 +2942,8 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho 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)]) + Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported) + ]) classes []), shape_map, new_env @@ -2899,12 +2955,10 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho 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; Env.register_uid decl.clsty_ty_decl.clty_uid loc; let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in map Shape.Map.add_class_type decl.clsty_ty_id acc |> map Shape.Map.add_type decl.clsty_obj_id - |> map Shape.Map.add_type decl.clsty_typesharp_id ) shape_map classes in Tstr_class_type @@ -2919,8 +2973,6 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho [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 []), shape_map, @@ -3035,8 +3087,7 @@ let type_module_type_of 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 nongen_modtype env mty then - raise(Error(smod.pmod_loc, env, Non_generalizable_module mty)); + check_nongen_modtype env smod.pmod_loc mty; tmty, mty (* For Typecore *) @@ -3079,12 +3130,16 @@ let lookup_type_in_sig sg = let type_package env m p fl = (* Same as Pexp_letmodule *) - (* remember original level *) - Ctype.begin_def (); - let context = Typetexp.narrow () in - let modl, _mod_shape = type_module env m in - let scope = Ctype.create_scope () in - Typetexp.widen context; + let modl, scope = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + (* type the module and create a scope in a raised level *) + Ctype.with_local_level begin fun () -> + let modl, _mod_shape = type_module env m in + let scope = Ctype.create_scope () in + modl, scope + end + end + in let fl', env = match fl with | [] -> [], env @@ -3125,8 +3180,6 @@ let type_package env m p 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' @@ -3429,14 +3482,36 @@ let report_error ~loc _env = function "@[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 -> + | Non_generalizable { vars; expression } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + prepare_for_printing vars; + add_type_to_preparation expression; Location.errorf ~loc "@[The type of this expression,@ %a,@ \ - contains type variables that cannot be generalized@]" type_scheme typ - | Non_generalizable_module mty -> - Location.errorf ~loc + contains the non-generalizable type variable(s): %a.@ %a@]" + prepared_type_scheme expression + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + prepared_type_scheme) vars + Misc.print_see_manual manual_ref + | Non_generalizable_module { vars; mty; item } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + prepare_for_printing vars; + add_type_to_preparation item.val_type; + let sub = + [ Location.msg ~loc:item.val_loc + "The type of this value,@ %a,@ \ + contains the non-generalizable type variable(s) %a." + prepared_type_scheme + item.val_type + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + prepared_type_scheme) vars + ] + in + Location.errorf ~loc ~sub "@[The type of this module,@ %a,@ \ - contains type variables that cannot be generalized@]" modtype mty + contains non-generalizable type variable(s).@ %a@]" + modtype mty + Misc.print_see_manual manual_ref | Implementation_is_required intf_name -> Location.errorf ~loc "@[The interface %a@ declares values, not just types.@ \ @@ -3480,28 +3555,41 @@ let report_error ~loc _env = function | Cannot_hide_id Illegal_shadowing { shadowed_item_kind; shadowed_item_id; shadowed_item_loc; shadower_id; user_id; user_kind; user_loc } -> + let shadowed = + Printtyp.namespaced_ident shadowed_item_kind shadowed_item_id + in + let shadower = + Printtyp.namespaced_ident shadowed_item_kind shadower_id + in let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in - Location.errorf ~loc - "@[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 + let shadowed_msg = + Location.msg ~loc:shadowed_item_loc + "@[%s %s came from this include.@]" + (String.capitalize_ascii shadowed_item_kind) + shadowed + in + let user_msg = + Location.msg ~loc:user_loc + "@[The %s %s has no valid type@ if %s is shadowed.@]" (Sig_component_kind.to_string user_kind) (Ident.name user_id) - Ident.print shadowed_item_id + shadowed + in + Location.errorf ~loc ~sub:[shadowed_msg; user_msg] + "Illegal shadowing of included %s %s@ by %s." + shadowed_item_kind shadowed shadower | 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 - "@[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 + let opened_id = Ident.name opened_item_id in + let user_msg = + Location.msg ~loc:user_loc + "@[The %s %s has no valid type@ if %s is hidden.@]" (Sig_component_kind.to_string user_kind) (Ident.name user_id) - Ident.print opened_item_id + opened_id + in + Location.errorf ~loc ~sub:[user_msg] + "The %s %s introduced by this open appears in the signature." + opened_item_kind opened_id | Invalid_type_subst_rhs -> Location.errorf ~loc "Only type synonyms are allowed on the right of :=" | Unpackable_local_modtype_subst p -> diff --git a/src/ocaml/typing/typemod.mli b/src/ocaml/typing/typemod.mli index 24bccb2cba..209f2a55fb 100644 --- a/src/ocaml/typing/typemod.mli +++ b/src/ocaml/typing/typemod.mli @@ -116,8 +116,9 @@ type error = | 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_module of module_type + | Non_generalizable of { vars : type_expr list; expression : type_expr } + | Non_generalizable_module of + { vars : type_expr list; item : value_description; mty : module_type } | Implementation_is_required of string | Interface_not_compiled of string | Not_allowed_in_functor_body diff --git a/src/ocaml/typing/types.ml b/src/ocaml/typing/types.ml index 1112c4a68d..f75034b73d 100644 --- a/src/ocaml/typing/types.ml +++ b/src/ocaml/typing/types.ml @@ -134,36 +134,70 @@ and method_privacy = | Mprivate of field_kind (* Variance *) +(* Variance forms a product lattice of the following partial orders: + 0 <= may_pos <= pos + 0 <= may_weak <= may_neg <= neg + 0 <= inj + Additionally, the following implications are valid + pos => inj + neg => inj + Examples: + type 'a t : may_pos + may_neg + may_weak + type 'a t = 'a : pos + type 'a t = 'a -> unit : neg + type 'a t = ('a -> unit) -> unit : pos + may_weak + type 'a t = A of (('a -> unit) -> unit) : pos + type +'a p = .. : may_pos + inj + type +!'a t : may_pos + inj + type -!'a t : may_neg + inj + type 'a t = A : inj + *) 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_neg -> 2 + 4 | May_weak -> 4 | Inj -> 8 - | Pos -> 16 - | Neg -> 32 - | Inv -> 64 + | Pos -> 16 + 8 + 1 + | Neg -> 32 + 8 + 4 + 2 + | Inv -> 63 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 set x v = union v (single x) + let set_if b x v = if b then set x v else v 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 full = single Inv + let covariant = single Pos + let swap f1 f2 v v' = + set_if (mem f2 v) f1 (set_if (mem f1 v) f2 v') + let conjugate v = + let v' = inter v (union (single Inj) (single May_weak)) in + swap Pos Neg v (swap May_pos May_neg v v') + let compose v1 v2 = + if mem Inv v1 && mem Inj v2 then full else + let mp = + mem May_pos v1 && mem May_pos v2 || mem May_neg v1 && mem May_neg v2 + and mn = + mem May_pos v1 && mem May_neg v2 || mem May_pos v1 && mem May_neg v2 + and mw = mem May_weak v1 && v2 <> null || v1 <> null && mem May_weak v2 + and inj = mem Inj v1 && mem Inj v2 + and pos = mem Pos v1 && mem Pos v2 || mem Neg v1 && mem Neg v2 + and neg = mem Pos v1 && mem Neg v2 || mem Neg v1 && mem Pos v2 in + List.fold_left (fun v (b,f) -> set_if b f v) null + [mp, May_pos; mn, May_neg; mw, May_weak; inj, Inj; pos, Pos; neg, Neg] + let strengthen v = + if mem May_neg v then v else v land (full - single May_weak) 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 get_lower v = (mem Pos v, mem Neg v, mem Inj v) let unknown_signature ~injective ~arity = - let v = if injective then set Inj true unknown else unknown in + let v = if injective then set Inj unknown else unknown in Misc.replicate_list v arity end @@ -293,6 +327,7 @@ type class_type_declaration = { clty_params: type_expr list; clty_type: class_type; clty_path: Path.t; + clty_hash_type: type_declaration; clty_variance: Variance.t list; clty_loc: Location.t; clty_attributes: Parsetree.attributes; diff --git a/src/ocaml/typing/types.mli b/src/ocaml/typing/types.mli index e087532159..ec8a13774c 100644 --- a/src/ocaml/typing/types.mli +++ b/src/ocaml/typing/types.mli @@ -418,11 +418,14 @@ module Variance : sig val inter : t -> t -> t val subset : t -> t -> bool val eq : t -> t -> bool - val set : f -> bool -> t -> t + val set : f -> t -> t + val set_if : bool -> f -> 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 compose : t -> t -> t + val strengthen : t -> t (* remove May_weak when possible *) + val get_upper : t -> bool * bool (* may_pos, may_neg *) + val get_lower : t -> bool * bool * bool (* pos, neg, inj *) val unknown_signature : injective:bool -> arity:int -> t list (** The most pessimistic variance for a completely unknown type. *) end @@ -494,6 +497,7 @@ and record_representation = | 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 *) + (* The argument is the path of the extension *) and variant_representation = Variant_regular (* Constant or boxed constructors *) @@ -562,6 +566,7 @@ type class_type_declaration = { clty_params: type_expr list; clty_type: class_type; clty_path: Path.t; + clty_hash_type: type_declaration; (* object type with an open row *) clty_variance: Variance.t list; clty_loc: Location.t; clty_attributes: Parsetree.attributes; diff --git a/src/ocaml/typing/typetexp.ml b/src/ocaml/typing/typetexp.ml index bc0007b09c..a104ba8d57 100644 --- a/src/ocaml/typing/typetexp.ml +++ b/src/ocaml/typing/typetexp.ml @@ -27,7 +27,8 @@ open Ctype exception Already_bound type error = - Unbound_type_variable of string + | Unbound_type_variable of string * string list + | No_type_wildcards | Undefined_type_constructor of Path.t | Type_arity_mismatch of Longident.t * int * int | Bound_type_variable of string @@ -51,33 +52,309 @@ 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 +module TyVarEnv : sig + val reset : unit -> unit + (* see mli file *) + val is_in_scope : string -> bool + + val add : string -> type_expr -> unit + (* add a global type variable to the environment *) + + val with_local_scope : (unit -> 'a) -> 'a + (* see mli file *) + + type poly_univars + val with_univars : poly_univars -> (unit -> 'a) -> 'a + (* evaluate with a locally extended set of univars *) + + val make_poly_univars : string list -> poly_univars + (* see mli file *) + + val check_poly_univars : Env.t -> Location.t -> poly_univars -> type_expr list + (* see mli file *) + + val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (* see mli file *) + + type policy + val fixed_policy : policy (* no wildcards allowed *) + val extensible_policy : policy (* common case *) + val univars_policy : policy (* fresh variables are univars (in methods) *) + val new_any_var : Location.t -> Env.t -> policy -> type_expr + (* create a new variable to represent a _; fails for fixed_policy *) + val new_var : ?name:string -> policy -> type_expr + (* create a new variable according to the given policy *) + + val add_pre_univar : type_expr -> policy -> unit + (* remember that a variable might become a univar if it isn't unified; + used for checking method types *) + + val collect_univars : (unit -> 'a) -> 'a * type_expr list + (* collect univars during a computation; returns the univars. + The wrapped computation should use [univars_policy]. + postcondition: the returned type_exprs are all Tunivar *) + + val reset_locals : ?univars:poly_univars -> unit -> unit + (* clear out the local type variable env't; call this when starting + a new e.g. type signature. Optionally pass some univars that + are in scope. *) + + val lookup_local : + row_context:type_expr option ref list -> string -> type_expr + (* look up a local type variable; throws Not_found if it isn't in scope *) + + val remember_used : string -> type_expr -> Location.t -> unit + (* remember that a given name is bound to a given type *) + + val globalize_used_variables : policy -> Env.t -> unit -> unit + (* after finishing with a type signature, used variables are unified to the + corresponding global type variables if they exist. Otherwise, in function + of the policy, fresh used variables are either + - added to the global type variable scope if they are not longer + variables under the {!fixed_policy} + - added to the global type variable scope under the {!extensible_policy} + - expected to be collected later by a call to `collect_univar` under the + {!universal_policy} + *) + +end = struct + (** Map indexed by type variable names. *) + module TyVarMap = Misc.String.Map + + let not_generic v = get_level v <> Btype.generic_level + + (* These are the "global" type variables: they were in scope before + we started processing the current type. + *) + let type_variables = ref (TyVarMap.empty : type_expr TyVarMap.t) + + (* These are variables that have been used in the currently-being-checked + type. + *) + let used_variables = + ref (TyVarMap.empty : (type_expr * Location.t) TyVarMap.t) + + (* These are variables we expect to become univars (they were introduced with + e.g. ['a .]), but we need to make sure they don't unify first. Why not + just birth them as univars? Because they might successfully unify with a + row variable in the ['a. < m : ty; .. > as 'a] idiom. They are like the + [used_variables], but will not be globalized in [globalize_used_variables]. + *) + type pending_univar = { + univar: type_expr (** the univar itself *); + mutable associated: type_expr option ref list + (** associated references to row variables that we want to generalize + if possible *) + } + + let univars = ref ([] : (string * pending_univar) list) + let assert_univars uvs = + assert (List.for_all (fun (_name, v) -> not_generic v.univar) uvs) + + (* These are variables that will become univars when we're done with the + current type. Used to force free variables in method types to become + univars. + *) + let pre_univars = ref ([] : type_expr list) + + let reset () = + reset_global_level (); + type_variables := TyVarMap.empty + + let is_in_scope name = + TyVarMap.mem name !type_variables + + let add name v = + assert (not_generic v); + type_variables := TyVarMap.add name v !type_variables + + let narrow () = + (increase_global_level (), !type_variables) + + let widen (gl, tv) = + restore_global_level gl; + type_variables := tv + + let with_local_scope f = + let context = narrow () in + Fun.protect + f + ~finally:(fun () -> widen context) + + (* throws Not_found if the variable is not in scope *) + let lookup_global_type_variable name = + TyVarMap.find name !type_variables -type variable_context = int * type_expr TyVarMap.t + let get_in_scope_names () = + let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in + TyVarMap.fold add_name !type_variables [] + + (*****) + type poly_univars = (string * pending_univar) list + + let with_univars new_ones f = + assert_univars new_ones; + let old_univars = !univars in + univars := new_ones @ !univars; + Fun.protect + f + ~finally:(fun () -> univars := old_univars) + + let make_poly_univars vars = + let make name = { univar=newvar ~name (); associated = [] } in + List.map (fun name -> name, make name ) vars + + let promote_generics_to_univars promoted vars = + List.fold_left + (fun acc v -> + match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name); + v :: acc + | _ -> acc + ) + promoted vars + + let check_poly_univars env loc vars = + vars |> List.iter (fun (_, p) -> generalize p.univar); + let univars = + vars |> List.map (fun (name, {univar=ty1; _ }) -> + let v = Btype.proxy ty1 in + begin match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name) + | _ -> + raise (Error (loc, env, Cannot_quantify(name, v))) + end; + v) + in + (* Since we are promoting variables to univars in + {!promote_generics_to_univars}, even if a row variable is associated with + multiple univars we will promote it once, when checking the nearest + univar associated to this row variable. + *) + let promote_associated acc (_,v) = + let enclosed_rows = List.filter_map (!) v.associated in + promote_generics_to_univars acc enclosed_rows + in + List.fold_left promote_associated univars vars + + let instance_poly_univars env loc vars = + let vs = check_poly_univars env loc vars in + vs |> List.iter (fun v -> + match get_desc v with + | Tunivar name -> + set_type_desc v (Tvar name) + | _ -> assert false); + vs + + (*****) + let reset_locals ?univars:(uvs=[]) () = + assert_univars uvs; + univars := uvs; + used_variables := TyVarMap.empty + + let associate row_context p = + let add l x = if List.memq x l then l else x :: l in + p.associated <- List.fold_left add row_context p.associated + + (* throws Not_found if the variable is not in scope *) + let lookup_local ~row_context name = + try + let p = List.assoc name !univars in + associate row_context p; + p.univar + with Not_found -> + instance (fst (TyVarMap.find name !used_variables)) + (* This call to instance might be redundant; all variables + inserted into [used_variables] are non-generic, but some + might get generalized. *) + + let remember_used name v loc = + assert (not_generic v); + used_variables := TyVarMap.add name (v, loc) !used_variables + + + type flavor = Unification | Universal + type extensibility = Extensible | Fixed + type policy = { flavor : flavor; extensibility : extensibility } + + let fixed_policy = { flavor = Unification; extensibility = Fixed } + let extensible_policy = { flavor = Unification; extensibility = Extensible } + let univars_policy = { flavor = Universal; extensibility = Extensible } + + let add_pre_univar tv = function + | { flavor = Universal } -> + assert (not_generic tv); + pre_univars := tv :: !pre_univars + | _ -> () + + let collect_univars f = + pre_univars := []; + let result = f () in + let univs = promote_generics_to_univars [] !pre_univars in + result, univs + + let new_var ?name policy = + let tv = Ctype.newvar ?name () in + add_pre_univar tv policy; + tv + + let new_any_var loc env = function + | { extensibility = Fixed } -> raise(Error(loc, env, No_type_wildcards)) + | policy -> new_var policy + + let globalize_used_variables { flavor; extensibility } env = + let r = ref [] in + TyVarMap.iter + (fun name (ty, loc) -> + if flavor = Unification || is_in_scope name then + 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, lookup_global_type_variable name) :: !r + with Not_found -> + if extensibility = Fixed && Btype.is_Tvar ty then + raise(Error(loc, env, + Unbound_type_variable ("'"^name, + get_in_scope_names ()))); + let v2 = new_global_var () in + r := (loc, v, v2) :: !r; + add name v2) + !used_variables; + used_variables := TyVarMap.empty; + fun () -> + List.iter + (function (loc, t1, t2) -> + try unify env t1 t2 with Unify err -> + raise (Error(loc, env, Type_mismatch err))) + !r +end (* 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, +let sort_constraints_no_duplicates loc env 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 + +let create_package_mty loc p l = List.fold_left - (fun mty (s, t) -> + (fun mty (s, _) -> 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_manifest = None; ptype_attributes = []; ptype_loc = loc} in Ast_helper.Mty.mk ~loc @@ -88,22 +365,7 @@ let create_package_mty fake loc env (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 generalize_ctyp typ = generalize typ.ctyp_type let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z') @@ -117,12 +379,6 @@ let new_global_var ?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] <> '_' @@ -135,15 +391,13 @@ let transl_type_param env styp = 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 -> + if TyVarEnv.is_in_scope name then + raise Already_bound; let v = new_global_var ~name () in - type_variables := TyVarMap.add name v !type_variables; - v + TyVarEnv.add name v; + v in { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env; ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } @@ -155,44 +409,12 @@ let transl_type_param env styp = 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 poly_univars = (string * type_expr) list -let make_poly_univars vars = - List.map (fun name -> name, newvar ~name ()) vars - -let check_poly_univars env loc vars = - vars |> List.iter (fun (_, v) -> generalize v); - vars |> List.map (fun (name, ty1) -> - let v = Btype.proxy ty1 in - begin match get_desc v with - | Tvar name when get_level v = Btype.generic_level -> - set_type_desc v (Tunivar name) - | _ -> - raise (Error (loc, env, Cannot_quantify(name, v))) - end; - v) - -let instance_poly_univars env loc vars = - let vs = check_poly_univars env loc vars in - vs |> List.iter (fun v -> - match get_desc v with - | Tunivar name -> - set_type_desc v (Tvar name) - | _ -> assert false); - vs - - -type policy = Fixed | Extensible | Univars - -let rec transl_type env policy styp = +let rec transl_type env ~policy ?(aliased=false) ~row_context styp = Msupport.with_saved_types ~warning_attribute:styp.ptyp_attributes ?save_part:None (fun () -> try - transl_type_aux env policy styp + transl_type_aux env ~policy ~aliased ~row_context styp with exn -> let ty = new_global_var () in Msupport.erroneous_type_register ty; @@ -205,7 +427,7 @@ let rec transl_type env policy styp = } ) -and transl_type_aux env policy styp = +and transl_type_aux env ~row_context ~aliased ~policy styp = let loc = styp.ptyp_loc in let ctyp ctyp_desc ctyp_type = { ctyp_desc; ctyp_type; ctyp_env = env; @@ -213,33 +435,24 @@ and transl_type_aux env policy styp = 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 + let ty = TyVarEnv.new_any_var styp.ptyp_loc env policy 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)) + TyVarEnv.lookup_local ~row_context:row_context name 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; + let v = TyVarEnv.new_var ~name policy in + TyVarEnv.remember_used name v styp.ptyp_loc; 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 cty1 = transl_type env ~policy ~row_context st1 in + let cty2 = transl_type env ~policy ~row_context st2 in let ty1 = cty1.ctyp_type in let ty1 = if Btype.is_optional l @@ -249,7 +462,7 @@ and transl_type_aux env policy styp = 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 ctys = List.map (transl_type env ~policy ~row_context) stl in let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in ctyp (Ttyp_tuple ctys) ty | Ptyp_constr(lid, stl) -> @@ -264,7 +477,7 @@ and transl_type_aux env policy styp = 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 args = List.map (transl_type env ~policy ~row_context) stl in let params = instance_list decl.type_params in let unify_param = match decl.type_manifest with @@ -283,45 +496,20 @@ and transl_type_aux env policy styp = 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 + let ty, fields = transl_fields env ~policy ~row_context 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 get_desc ty 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 + let (path, decl) = + let path, decl = Env.lookup_cltype ~loc:lid.loc lid.txt env in + (path, decl.clty_hash_type) 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 args = List.map (transl_type env ~policy ~row_context) stl in + let body = Option.get decl.type_manifest in + let (params, body) = instance_parameterized_type decl.type_params body in List.iter2 (fun (sty, cty) ty' -> try unify_var env ty' cty.ctyp_type with Unify err -> @@ -329,61 +517,41 @@ and transl_type_aux env policy styp = raise (Error(sty.ptyp_loc, env, Type_mismatch err)) ) (List.combine stl args) params; - let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in - let ty = Ctype.expand_head env (newconstr path ty_args) in + let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in + let ty = Ctype.apply ~use_current_level:true env params body ty_args in let ty = match get_desc ty with - Tvariant row -> - let fields = - List.map - (fun (l,f) -> l, - match row_field_repr f with - | Rpresent oty -> rf_either_of oty - | _ -> f) - (row_fields row) - in - (* NB: row is always non-static here; more is thus never Tnil *) - let more = - if policy = Univars then new_pre_univar () else newvar () in - let row = - create_row ~fields ~more - ~closed:true ~fixed:None ~name:(Some (path, ty_args)) in - newty (Tvariant row) - | Tobject (fi, _) -> - let _, tv = flatten_fields fi in - if policy = Univars then pre_univars := tv :: !pre_univars; - ty - | _ -> - assert false + | Tobject (fi, _) -> + let _, tv = flatten_fields fi in + TyVarEnv.add_pre_univar tv policy; + 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 + let t = TyVarEnv.lookup_local ~row_context alias in + let ty = transl_type env ~policy ~aliased:true ~row_context st in begin try unify_var env t ty.ctyp_type with Unify err -> let err = Errortrace.swap_unification_error err in raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) 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 err -> - let err = Errortrace.swap_unification_error err in - raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) - end; - if !Clflags.principal then begin - end_def (); - generalize_structure t; - end; + let t, ty = + with_local_level_if_principal begin fun () -> + let t = newvar () in + TyVarEnv.remember_used alias t styp.ptyp_loc; + let ty = transl_type env ~policy ~row_context st in + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) + end; + (t, ty) + end + ~post: (fun (t, _) -> generalize_structure t) + in let t = instance t in let px = Btype.proxy t in begin match get_desc px with @@ -414,7 +582,7 @@ and transl_type_aux env policy styp = with Not_found -> Hashtbl.add hfields h (l,f) in - let add_field field = + let add_field row_context field = let rf_loc = field.prf_loc in let rf_attributes = field.prf_attributes in let rf_desc = match field.prf_desc with @@ -422,7 +590,7 @@ and transl_type_aux env policy styp = name := None; let tl = Builtin_attributes.warning_scope rf_attributes - (fun () -> List.map (transl_type env policy) stl) + (fun () -> List.map (transl_type env ~policy ~row_context) stl) in let f = match present with Some present when not (List.mem l.txt present) -> @@ -438,7 +606,7 @@ and transl_type_aux env policy styp = add_typed_field styp.ptyp_loc l.txt f; Ttag (l,c,tl) | Rinherit sty -> - let cty = transl_type env policy sty in + let cty = transl_type env ~policy ~row_context sty in let ty = cty.ctyp_type in let nm = match get_desc cty.ctyp_type with @@ -470,7 +638,11 @@ and transl_type_aux env policy styp = in { rf_desc; rf_loc; rf_attributes; } in - let tfields = List.map add_field fields in + let more_slot = ref None in + let row_context = + if aliased then row_context else more_slot :: row_context + in + let tfields = List.map (add_field row_context) fields in let fields = List.rev (Hashtbl.fold (fun _ p l -> p :: l) hfields []) in begin match present with None -> () | Some present -> @@ -485,35 +657,39 @@ and transl_type_aux env policy styp = in let more = if Btype.static_row (make_row (newvar ())) then newty Tnil else - if policy = Univars then new_pre_univar () else newvar () + TyVarEnv.new_var policy in + more_slot := Some more; let ty = newty (Tvariant (make_row more)) 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 = make_poly_univars vars in - let old_univars = !univars in - univars := new_univars @ !univars; - let cty = transl_type env policy st in + let new_univars, cty = + with_local_level begin fun () -> + let new_univars = TyVarEnv.make_poly_univars vars in + let cty = TyVarEnv.with_univars new_univars begin fun () -> + transl_type env ~policy ~row_context st + end in + (new_univars, cty) + end + ~post:(fun (_,cty) -> generalize_ctyp cty) + in let ty = cty.ctyp_type in - univars := old_univars; - end_def(); - generalize ty; - let ty_list = check_poly_univars env styp.ptyp_loc new_univars in + let ty_list = TyVarEnv.check_poly_univars env styp.ptyp_loc new_univars in let ty_list = List.filter (fun v -> deep_occur v ty) ty_list in let ty' = Btype.newgenty (Tpoly(ty, 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 loc = styp.ptyp_loc in + let l = sort_constraints_no_duplicates loc env l in + let mty = create_package_mty loc p l in + let mty = + TyVarEnv.with_local_scope (fun () -> !transl_modtype env mty) in let ptys = List.map (fun (s, pty) -> - s, transl_type env policy pty + s, transl_type env ~policy ~row_context pty ) l in - let path = !transl_modtype_longident styp.ptyp_loc env p.txt in + let path = !transl_modtype_longident loc env p.txt in let ty = newty (Tpackage (path, List.map (fun (s, cty) -> (s.txt, cty.ctyp_type)) ptys)) in @@ -526,7 +702,7 @@ and transl_type_aux env policy styp = | Ptyp_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) -and transl_fields env policy o fields = +and transl_fields env ~policy ~row_context o fields = let hfields = Hashtbl.create 17 in let add_typed_field loc l ty = try @@ -544,14 +720,15 @@ and transl_fields env policy o fields = | Otag (s, ty1) -> begin let ty1 = Builtin_attributes.warning_scope of_attributes - (fun () -> transl_type env policy (Ast_helper.Typ.force_poly ty1)) + (fun () -> transl_type env ~policy ~row_context + (Ast_helper.Typ.force_poly 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 cty = transl_type env ~policy ~row_context sty in let nm = match get_desc cty.ctyp_type with Tconstr(p, _, _) -> Some p @@ -583,14 +760,16 @@ and transl_fields env policy o fields = 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 + match o with + | Closed -> newty Tnil + | Open -> TyVarEnv.new_var policy + in let ty = List.fold_left (fun ty (s, ty') -> newty (Tfield (s, field_public, ty', ty))) ty_init fields in ty, object_fields +let transl_type env policy styp = + transl_type env ~policy ~row_context:[] styp (* Make the rows "fixed" in this type, to make universal check easier *) let rec make_fixed_univars ty = @@ -620,103 +799,70 @@ 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 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 err -> - raise (Error(loc, env, Type_mismatch err))) - !r - -let transl_simple_type env ?univars:(uvs=[]) fixed styp = - univars := uvs; used_variables := TyVarMap.empty; - let typ = transl_type env (if fixed then Fixed else Extensible) styp in - globalize_used_variables env fixed (); +let transl_simple_type env ?univars ~closed styp = + TyVarEnv.reset_locals ?univars (); + let policy = TyVarEnv.(if closed then fixed_policy else extensible_policy) in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); 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 -> - match get_desc v with - Tvar name when get_level v = Btype.generic_level -> - set_type_desc v (Tunivar name); v :: acc - | _ -> acc) - [] !pre_univars - in + TyVarEnv.reset_locals (); + let typ, univs = + TyVarEnv.collect_univars begin fun () -> + with_local_level ~post:generalize_ctyp begin fun () -> + let policy = TyVarEnv.univars_policy in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); + typ + end + end 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; + TyVarEnv.reset_locals (); + let typ, force = + with_local_level begin fun () -> + let policy = TyVarEnv.extensible_policy in + let typ = transl_type env policy styp in + 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 = TyVarEnv.globalize_used_variables policy env in + (typ, force) + end + (* Generalize everything except the variables that were just globalized. *) + ~post:(fun (typ,_) -> generalize_ctyp typ) + in (typ, instance typ.ctyp_type, force) let transl_type_scheme env styp = - reset_type_variables(); match styp.ptyp_desc with | Ptyp_poly (vars, st) -> - begin_def(); let vars = List.map (fun v -> v.txt) vars in - let univars = make_poly_univars vars in - let typ = transl_simple_type env ~univars true st in - end_def(); - generalize typ.ctyp_type; - let _ = instance_poly_univars env styp.ptyp_loc univars in + let univars, typ = + with_local_level begin fun () -> + TyVarEnv.reset (); + let univars = TyVarEnv.make_poly_univars vars in + let typ = transl_simple_type env ~univars ~closed:true st in + (univars, typ) + end + ~post:(fun (_,typ) -> generalize_ctyp typ) + in + let _ = TyVarEnv.instance_poly_univars env styp.ptyp_loc univars in { ctyp_desc = Ttyp_poly (vars, typ); ctyp_type = typ.ctyp_type; ctyp_env = env; ctyp_loc = styp.ptyp_loc; ctyp_attributes = styp.ptyp_attributes } | _ -> - begin_def(); - let typ = transl_simple_type env false styp in - end_def(); - generalize typ.ctyp_type; - typ + with_local_level + (fun () -> TyVarEnv.reset (); transl_simple_type env ~closed:false styp) + ~post:generalize_ctyp (* Error report *) @@ -725,12 +871,12 @@ 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 + | Unbound_type_variable (name, in_scope_names) -> fprintf ppf "The type variable %s is unbound in this type declaration.@ %a" name - did_you_mean (fun () -> Misc.spellcheck names name ) + did_you_mean (fun () -> Misc.spellcheck in_scope_names name ) + | No_type_wildcards -> + fprintf ppf "A type wildcard \"_\" is not allowed in this type declaration." | Undefined_type_constructor p -> fprintf ppf "The type constructor@ %a@ is not yet completely defined" path p @@ -766,7 +912,7 @@ let report_error env ppf = function "@[@[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,@ \ + @[@{Hint@}: Either add `%s in the upper bound,@ \ or remove it@ from the lower bound.@]@]" l l | Constructor_mismatch (ty, ty') -> diff --git a/src/ocaml/typing/typetexp.mli b/src/ocaml/typing/typetexp.mli index c264ab599a..ca058a5cf0 100644 --- a/src/ocaml/typing/typetexp.mli +++ b/src/ocaml/typing/typetexp.mli @@ -17,24 +17,39 @@ open Types -val valid_tyvar_name : string -> bool +module TyVarEnv : sig + (* this is just the subset of [TyVarEnv] that is needed outside + of [Typetexp]. See the ml file for more. *) + + val reset : unit -> unit + (** removes all type variables from scope *) + + val with_local_scope : (unit -> 'a) -> 'a + (** Evaluate in a narrowed type-variable scope *) + + type poly_univars + val make_poly_univars : string list -> poly_univars + (** remember that a list of strings connotes univars; this must + always be paired with a [check_poly_univars]. *) + + val check_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (** Verify that the given univars are universally quantified, + and return the list of variables. The type in which the + univars are used must be generalised *) -type poly_univars -val make_poly_univars : string list -> poly_univars - (* Create a set of univars with given names *) -val check_poly_univars : - Env.t -> Location.t -> poly_univars -> type_expr list - (* Verify that the given univars are universally quantified, - and return the list of variables. The type in which the - univars are used must be generalised *) -val instance_poly_univars : - Env.t -> Location.t -> poly_univars -> type_expr list - (* Same as [check_poly_univars], but instantiates the resulting - type scheme (i.e. variables become Tvar rather than Tunivar) *) + val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (** Same as [check_poly_univars], but instantiates the resulting + type scheme (i.e. variables become Tvar rather than Tunivar) *) + +end + +val valid_tyvar_name : string -> bool val transl_simple_type: - Env.t -> ?univars:poly_univars -> bool -> Parsetree.core_type - -> Typedtree.core_type + Env.t -> ?univars:TyVarEnv.poly_univars -> closed: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 @@ -46,19 +61,14 @@ val transl_simple_type_delayed 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 + | Unbound_type_variable of string * string list + | No_type_wildcards | Undefined_type_constructor of Path.t | Type_arity_mismatch of Longident.t * int * int | Bound_type_variable of string @@ -87,7 +97,3 @@ 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 index a3fbeaf9d1..5bf911989a 100644 --- a/src/ocaml/typing/untypeast.ml +++ b/src/ocaml/typing/untypeast.ml @@ -97,20 +97,20 @@ let string_is_prefix sub str = 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) + | Path.Pdot (p, s) | Path.Pextra_ty (p, Pcstr_ty s) -> + Longident.Ldot (lident_of_path p, s) + | Path.Pextra_ty (p, _) -> lident_of_path p 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 + let name i = s ^ Int.to_string i in + let available i = not (Env.bound_value (name i) env) in + let first_i = Misc.find_first_mono available in + name first_i (** Extract the [n] patterns from the case of a letop *) let rec extract_letop_patterns n pat = @@ -494,7 +494,7 @@ let expression 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_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) @@ -672,7 +672,10 @@ let module_expr (sub : mapper) 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) + Pmod_apply (sub.module_expr sub mexp1, + sub.module_expr sub mexp2) + | Tmod_apply_unit mexp1 -> + Pmod_apply_unit (sub.module_expr sub mexp1) | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> Pmod_constraint (sub.module_expr sub mexpr, sub.module_type sub mtype) diff --git a/src/ocaml/utils/build_path_prefix_map.ml b/src/ocaml/utils/build_path_prefix_map.ml index 65d951f1c3..17cfac82e2 100644 --- a/src/ocaml/utils/build_path_prefix_map.ml +++ b/src/ocaml/utils/build_path_prefix_map.ml @@ -95,25 +95,24 @@ let decode_map str = | 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 +let make_target path : pair option -> path option = function | None -> None - | Some { source; target } -> + | Some { target; source } -> + let is_prefix = + String.length source <= String.length path + && String.equal source (String.sub path 0 (String.length source)) in + if is_prefix then Some (target ^ (String.sub path (String.length source) (String.length path - String.length source))) + else None + +let rewrite_first prefix_map path = + List.find_map (make_target path) (List.rev prefix_map) + +let rewrite_all prefix_map path = + List.filter_map (make_target path) (List.rev prefix_map) let rewrite prefix_map path = - match rewrite_opt prefix_map path with + match rewrite_first 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 index dbcc8dc16f..d8ec9caf4d 100644 --- a/src/ocaml/utils/build_path_prefix_map.mli +++ b/src/ocaml/utils/build_path_prefix_map.mli @@ -18,6 +18,9 @@ {b Warning:} this module is unstable and part of {{!Compiler_libs}compiler-libs}. + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} *) @@ -38,10 +41,21 @@ 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] +val rewrite_first : map -> path -> path option +(** [rewrite_first 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_all : map -> path -> path list +(** [rewrite_all map path] finds all sources in [map] + that are a prefix of the input [path]. For each matching + source, in priority order, it replaces this prefix with + the corresponding target and adds the result to + the returned list. + If there are no matches, it just returns [[]]. *) + val rewrite : map -> path -> path +(** [rewrite path] uses [rewrite_first] to try to find a + mapping for path. If found, it returns that, otherwise + it just returns [path]. *) diff --git a/src/ocaml/utils/clflags.ml b/src/ocaml/utils/clflags.ml index 8cf427497a..337ac0a3c4 100644 --- a/src/ocaml/utils/clflags.ml +++ b/src/ocaml/utils/clflags.ml @@ -10,7 +10,7 @@ let strict_sequence = ref false let applicative_functors = ref true let nopervasives = ref false -let strict_formats = ref false +let strict_formats = ref true let open_modules = ref [] let annotations = ref false diff --git a/src/ocaml/utils/config.ml b/src/ocaml/utils/config.ml index 78fab735d8..f1f93f2814 100644 --- a/src/ocaml/utils/config.ml +++ b/src/ocaml/utils/config.ml @@ -28,25 +28,25 @@ let version = Sys.ocaml_version let flambda = false -let exec_magic_number = "Caml1999X032" +let exec_magic_number = "Caml1999X033" (* exec_magic_number is duplicated in runtime/caml/exec.h *) -and cmi_magic_number = "Caml1999I032" -and cmo_magic_number = "Caml1999O032" -and cma_magic_number = "Caml1999A032" +and cmi_magic_number = "Caml1999I033" +and cmo_magic_number = "Caml1999O033" +and cma_magic_number = "Caml1999A033" and cmx_magic_number = if flambda then - "Caml1999y032" + "Caml1999y033" else - "Caml1999Y032" + "Caml1999Y033" and cmxa_magic_number = if flambda then - "Caml1999z032" + "Caml1999z033" else - "Caml1999Z032" -and ast_impl_magic_number = "Caml1999M032" -and ast_intf_magic_number = "Caml1999N032" -and cmxs_magic_number = "Caml1999D032" -and cmt_magic_number = "Caml1999T032" + "Caml1999Z033" +and ast_impl_magic_number = "Caml1999M033" +and ast_intf_magic_number = "Caml1999N033" +and cmxs_magic_number = "Caml1999D033" +and cmt_magic_number = "Caml1999T033" let interface_suffix = ref ".mli" diff --git a/src/ocaml/utils/consistbl.ml b/src/ocaml/utils/consistbl.ml index b3299114a4..29289201f6 100644 --- a/src/ocaml/utils/consistbl.ml +++ b/src/ocaml/utils/consistbl.ml @@ -56,8 +56,6 @@ end) = struct 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 = diff --git a/src/ocaml/utils/consistbl.mli b/src/ocaml/utils/consistbl.mli index 5067addfa7..acc89eb31d 100644 --- a/src/ocaml/utils/consistbl.mli +++ b/src/ocaml/utils/consistbl.mli @@ -47,11 +47,6 @@ end) : sig (* 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]. diff --git a/src/ocaml/utils/warnings.ml b/src/ocaml/utils/warnings.ml index 4f9fa0bede..4eb85d8a9e 100644 --- a/src/ocaml/utils/warnings.ml +++ b/src/ocaml/utils/warnings.ml @@ -65,7 +65,8 @@ type t = | 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 *) + (* [Module_linked_twice of string * string * string] (* 31 *) + was turned into a hard error *) | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) | Unused_type_declaration of string (* 34 *) @@ -107,6 +108,7 @@ type t = | Missing_mli (* 70 *) | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -146,7 +148,6 @@ let number = function | 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 @@ -188,12 +189,13 @@ let number = function | Missing_mli -> 70 | Unused_tmc_attribute -> 71 | Tmc_breaks_tailcall -> 72 + | Generative_application_expects_unit -> 73 ;; (* DO NOT REMOVE the ;; above: it is used by the testsuite/ests/warnings/mnemonics.mll test to determine where the definition of the number function above ends *) -let last_warning_number = 72 +let last_warning_number = 73 type description = { number : int; @@ -351,8 +353,10 @@ let descriptions = [ since = None }; { number = 31; names = ["module-linked-twice"]; - description = "A module is linked twice in the same executable."; - since = since 4 0 }; + description = + "A module is linked twice in the same executable.\n\ + \ Ignored: now a hard error (since 5.1)."; + since = None }; { number = 32; names = ["unused-value-declaration"]; description = "Unused value declaration."; @@ -525,6 +529,11 @@ let descriptions = [ description = "A tail call is turned into a non-tail call \ by the @tail_mod_cons transformation."; since = since 4 14 }; + { number = 73; + names = ["generative-application-expects-unit"]; + description = "A generative functor is applied to an empty structure \ + (struct end) rather than to ()."; + since = since 5 1 }; ] let name_to_number = @@ -862,7 +871,7 @@ let parse_options errflag s = (* 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 defaults_warn_error = "-a" let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] @@ -871,12 +880,6 @@ let () = ignore @@ parse_options true defaults_warn_error let () = List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts -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 = 13, 5 in - Printf.sprintf "(See manual section %d.%d)" chapter section - let message = function | Comment_start -> "this `(*' is the start of a comment.\n\ @@ -921,7 +924,11 @@ let message = function ("the following instance variables are overridden by the class" :: cname :: ":\n " :: slist) | Instance_variable_override [] -> assert false - | Illegal_backslash -> "illegal backslash escape in string." + | Illegal_backslash -> + "illegal backslash escape in string.\n\ + Hint: Single backslashes \\ are reserved for escape sequences\n\ + (\\n, \\r, ...). Did you check the list of OCaml escape sequences?\n\ + To get a backslash character, escape it with a second backslash: \\\\." | Implicit_public_methods l -> "the following private methods were made public implicitly:\n " ^ String.concat " " l ^ "." @@ -949,10 +956,6 @@ let message = function | 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 ^ "." @@ -1039,10 +1042,12 @@ let message = function Printf.sprintf "expected %s" (if b then "tailcall" else "non-tailcall") | Fragile_literal_pattern -> - Printf.sprintf + let[@manual.ref "ss:warn52"] ref_manual = [ 13; 5; 3 ] in + Format.asprintf "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 + and may change in future versions. %a" + Misc.print_see_manual ref_manual | Unreachable_case -> "this match case is unreachable.\n\ Consider replacing it with a refutation case ' -> .'" @@ -1055,6 +1060,7 @@ let message = function | Inlining_impossible reason -> Printf.sprintf "Cannot inline: %s" reason | Ambiguous_var_in_pattern_guard vars -> + let[@manual.ref "ss:warn57"] ref_manual = [ 13; 5; 4 ] in let vars = List.sort String.compare vars in let vars_explanation = let in_different_places = @@ -1067,12 +1073,12 @@ let message = function let vars = String.concat ", " vars in "variables " ^ vars ^ " appear " ^ in_different_places in - Printf.sprintf + Format.asprintf "Ambiguous or-pattern variables under guard;\n\ %s.\n\ Only the first match will be used to evaluate the guard expression.\n\ - %t" - vars_explanation ref_manual_explanation + %a" + vars_explanation Misc.print_see_manual ref_manual | No_cmx_file name -> Printf.sprintf "no cmx file was found in path for module %s, \ @@ -1128,12 +1134,15 @@ let message = function but is never applied in TMC position." | Tmc_breaks_tailcall -> "This call\n\ - is in tail-modulo-cons positionin a TMC function,\n\ + is in tail-modulo-cons position in a TMC function,\n\ but the function called is not itself specialized for TMC,\n\ so the call will not be transformed into a tail call.\n\ Please either mark the called function with the [@tail_mod_cons]\n\ attribute, or mark this call with the [@tailcall false] attribute\n\ to make its non-tailness explicit." + | Generative_application_expects_unit -> + "A generative functor\n\ + should be applied to '()'; using '(struct end)' is deprecated." ;; let nerrors = ref 0 diff --git a/src/ocaml/utils/warnings.mli b/src/ocaml/utils/warnings.mli index 7710356eed..08f30ac40a 100644 --- a/src/ocaml/utils/warnings.mli +++ b/src/ocaml/utils/warnings.mli @@ -70,7 +70,6 @@ type t = | 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 *) @@ -112,6 +111,7 @@ type t = | Missing_mli (* 70 *) | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) type alert = {kind:string; message:string; def:loc; use:loc} diff --git a/src/utils/misc.ml b/src/utils/misc.ml index 9b7d4b4170..fa9bafe3f7 100644 --- a/src/utils/misc.ml +++ b/src/utils/misc.ml @@ -112,7 +112,9 @@ let may_map f x = Option.map ~f x (* File functions *) let remove_file filename = - try Sys.remove filename + try + if Sys.is_regular_file filename + then Sys.remove filename with Sys_error _msg -> () let rec split_path path acc = @@ -391,8 +393,45 @@ module Int_literal_converter = struct let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string end +(* [find_first_mono p] assumes that there exists a natural number + N such that [p] is false on [0; N[ and true on [N; max_int], and + returns this N. (See misc.mli for the detailed specification.) *) +let find_first_mono = + let rec find p ~low ~jump ~high = + (* Invariants: + [low, jump, high] are non-negative with [low < high], + [p low = false], + [p high = true]. *) + if low + 1 = high then high + (* ensure that [low + jump] is in ]low; high[ *) + else if jump < 1 then find p ~low ~jump:1 ~high + else if jump >= high - low then find p ~low ~jump:((high - low) / 2) ~high + else if p (low + jump) then + (* We jumped too high: continue with a smaller jump and lower limit *) + find p ~low:low ~jump:(jump / 2) ~high:(low + jump) + else + (* we jumped too low: + continue from [low + jump] with a larger jump *) + let next_jump = max jump (2 * jump) (* avoid overflows *) in + find p ~low:(low + jump) ~jump:next_jump ~high + in + fun p -> + if p 0 then 0 + else find p ~low:0 ~jump:1 ~high:max_int + (* String operations *) +(* let split_null_terminated s = + let[@tail_mod_cons] rec discard_last_sep = function + | [] | [""] -> [] + | x :: xs -> x :: discard_last_sep xs + in + discard_last_sep (String.split_on_char ~sep:'' s) *) + +(* let concat_null_terminated = function + | [] -> "" + | l -> String.concat ~sep:"" (l @ [""]) *) + let chop_extension_if_any fname = try Filename.chop_extension fname with Invalid_argument _ -> fname @@ -610,7 +649,7 @@ let did_you_mean ppf get_choices = | [] -> () | choices -> let rest, last = split_last choices in - Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?" + Format.fprintf ppf "@\n@{Hint@}: Did you mean %s%s%s?@?" (String.concat ~sep:", " rest) (if rest = [] then "" else " or ") last @@ -677,12 +716,14 @@ module Color = struct error: style list; warning: style list; loc: style list; + hint:style list; } let default_styles = { warning = [Bold; FG Magenta]; error = [Bold; FG Red]; loc = [Bold]; + hint = [Bold; FG Blue]; } let cur_styles = ref default_styles @@ -695,6 +736,7 @@ module Color = struct | Format.String_tag "error" -> (!cur_styles).error | Format.String_tag "warning" -> (!cur_styles).warning | Format.String_tag "loc" -> (!cur_styles).loc + | Format.String_tag "hint" -> (!cur_styles).hint | Style s -> s | _ -> raise Not_found @@ -760,6 +802,12 @@ module Color = struct () end +let print_see_manual ppf manual_section = + let open Format in + fprintf ppf "(see manual section %a)" + (pp_print_list ~pp_sep:(fun f () -> pp_print_char f '.') pp_print_int) + manual_section + let time_spent () = let open Unix in let t = times () in diff --git a/src/utils/misc.mli b/src/utils/misc.mli index 3e0ee0208b..432f889fc6 100644 --- a/src/utils/misc.mli +++ b/src/utils/misc.mli @@ -15,10 +15,19 @@ (** Miscellaneous useful types and functions *) +(** {1 Reporting fatal errors} *) + val fatal_error: string -> 'a + (** Raise the [Fatal_error] exception with the given string. *) + val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a + (** Format the arguments according to the given format string + and raise [Fatal_error] with the resulting string. *) + exception Fatal_error of string * Printexc.raw_backtrace +(** {1 Exceptions and finalization} *) + val try_finally : ?always:(unit -> unit) -> ?exceptionally:(unit -> unit) -> @@ -58,23 +67,30 @@ 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. *) +(** {1 List operations} *) val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list - (* [map_end f l t] is [map f l @ t], just more efficient. *) + (** [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 *) + (** 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. + (** 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 + (** [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 + (** [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. *) + (** 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 @@ -90,15 +106,19 @@ val exact_file_exists : dirname:string -> basename:string -> bool 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. *) + (** 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. *) + (** 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. *) + (** 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]*) @@ -111,9 +131,12 @@ val split_path : string -> string list -> string list *) val remove_file: string -> unit - (* Delete the given file if it exists. Never raise an error. *) + (** Delete the given file if it exists and is a regular file. + Does nothing for other kinds of files. + Never raises an error. *) + val expand_directory: string -> string -> string - (* [expand_directory alt file] eventually expands a [+] at the + (** [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 @@ -170,6 +193,27 @@ module Int_literal_converter : sig val nativeint : string -> nativeint end +val find_first_mono : (int -> bool) -> int + (**[find_first_mono p] takes an integer predicate [p : int -> bool] + that we assume: + 1. is monotonic on natural numbers: + if [a <= b] then [p a] implies [p b], + 2. is satisfied for some natural numbers in range [0; max_int] + (this is equivalent to: [p max_int = true]). + + [find_first_mono p] is the smallest natural number N that satisfies [p], + computed in O(log(N)) calls to [p]. + + Our implementation supports two cases where the preconditions on [p] + are not respected: + - If [p] is always [false], we silently return [max_int] + instead of looping or crashing. + - If [p] is non-monotonic but eventually true, + we return some satisfying value. + *) + +(** {1 String operations} *) + val chop_extension_if_any: string -> string (* Like Filename.chop_extension but returns the initial file name if it has no extension *) @@ -342,6 +386,7 @@ module Color : sig error: style list; warning: style list; loc: style list; + hint:style list; } val default_styles: styles @@ -360,3 +405,6 @@ module Color : sig val set_color_tag_handling : Format.formatter -> unit (* adds functions to support color tags to the given formatter. *) end + +val print_see_manual : Format.formatter -> int list -> unit +(** See manual section *) diff --git a/tests/test-dirs/completion/kind.t/run.t b/tests/test-dirs/completion/kind.t/run.t index d6aefecb6b..a7f52707cb 100644 --- a/tests/test-dirs/completion/kind.t/run.t +++ b/tests/test-dirs/completion/kind.t/run.t @@ -44,7 +44,9 @@ certain path "filteri" "find" "find_all" + "find_index" "find_map" + "find_mapi" "find_opt" "flatten" "fold_left" diff --git a/tests/test-dirs/destruct/from_val.t b/tests/test-dirs/destruct/from_val.t index 43a4916545..6d157f20f0 100644 --- a/tests/test-dirs/destruct/from_val.t +++ b/tests/test-dirs/destruct/from_val.t @@ -118,11 +118,23 @@ FIXME > fun x -> x > EOF - $ $MERLIN single case-analysis -start 6:10 -end 6:10 -filename typ2.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + $ $MERLIN single case-analysis -start 6:11 -end 6:11 \ + > -filename typ2.ml _ | Add -> _ | App (_, _) -> _" + ], "notifications": [] } diff --git a/tests/test-dirs/dune b/tests/test-dirs/dune index aa9ad1dac5..41016b4f67 100755 --- a/tests/test-dirs/dune +++ b/tests/test-dirs/dune @@ -6,7 +6,12 @@ (cram (applies_to typing-recovery) - (enabled_if - (and + (enabled_if + (and (<> %{ocaml_version} 4.12.0+multicore) (<> %{ocaml_version} 4.12.0+domains)))) + +; FIXME: re-enable once ppxlib for 5.1 is released +(cram + (applies_to with-ppx) + (enabled_if false)) diff --git a/tests/test-dirs/errors/undefined-meth.t b/tests/test-dirs/errors/undefined-meth.t new file mode 100644 index 0000000000..50dca03bf0 --- /dev/null +++ b/tests/test-dirs/errors/undefined-meth.t @@ -0,0 +1,13 @@ + $ cat >main.ml < let o = object + > method a = 1 + > method b = 2 + > method cdefg = 2 + > end;; + > print_int o#a;; + > print_int o#cdef + > EOF + + $ $MERLIN single errors -filename main.ml tr '\r\n' ' ' | jq '.value[0].message' + "This expression has type < a : int; b : int; cdefg : int > It has no method cdef Hint: Did you mean cdefg?" 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 index cb1961cd94..c75ede8fb9 100644 --- a/tests/test-dirs/server-tests/locate-state/reset-file-switching.t +++ b/tests/test-dirs/server-tests/locate-state/reset-file-switching.t @@ -46,7 +46,7 @@ we trigger the bug "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.", + with the results returned by [f].", "notifications": [] } 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 index ce8a661416..96f7f744a4 100644 --- a/tests/test-dirs/server-tests/typer-cache/stamps.t/run.t +++ b/tests/test-dirs/server-tests/typer-cache/stamps.t/run.t @@ -8,31 +8,31 @@ 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/274\" - Tpat_var \"x/276\" + Tpat_var \"f/275\" + Tpat_var \"x/277\" $ 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/277\" - Tpat_var \"x/279\" + Tpat_var \"f/278\" + Tpat_var \"x/280\" $ 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/274\" - Tpat_var \"x/276\" + Tpat_var \"f/275\" + Tpat_var \"x/277\" $ 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/277\" - Tpat_var \"x/279\" + Tpat_var \"f/278\" + Tpat_var \"x/280\" $ echo "let f x = x" | \ > $MERLIN server dump -what browse -filename test.ml | \ > sed 's:\\n:\n:g' | grep Tpat_var - Tpat_var \"f/280\" - Tpat_var \"x/282\" + Tpat_var \"f/281\" + Tpat_var \"x/283\" $ $MERLIN server stop-server diff --git a/tests/test-dirs/short-paths.t/run.t b/tests/test-dirs/short-paths.t/run.t index 021729fe40..c721fed1d5 100644 --- a/tests/test-dirs/short-paths.t/run.t +++ b/tests/test-dirs/short-paths.t/run.t @@ -1,5 +1,7 @@ $ $OCAMLC -c dep.mli +FIXME: the signature mismatch appear to be a bit less precise after moving to +ocaml 5.1. Is that expected ? $ $MERLIN single errors -filename test.ml < test.ml { "class": "return", @@ -138,26 +140,23 @@ { "start": { "line": 82, - "col": 22 + "col": 13 }, "end": { "line": 86, - "col": 5 + "col": 6 }, "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 + "message": "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 + val foo : 'a -> string is not included in - val foo : int -> t + val foo : int -> t The type int -> string is not compatible with the type int -> t - Type string is not compatible with type t = int + Type string is not compatible with type t = int File \"test.ml\", line 72, characters 2-20: Expected declaration File \"test.ml\", line 85, characters 8-11: Actual declaration" }, @@ -317,26 +316,20 @@ { "start": { "line": 82, - "col": 22 + "col": 13 }, "end": { "line": 86, - "col": 5 + "col": 6 }, "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 + "message": "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 The type t -> string is not compatible with the type t -> t - Type string is not compatible with type t + Type string is not compatible with type t File \"test.ml\", line 72, characters 2-20: Expected declaration File \"test.ml\", line 85, characters 8-11: Actual declaration" }, diff --git a/tests/test-dirs/type-expr.t/run.t b/tests/test-dirs/type-expr.t/run.t index 65f1fff9b7..4be6e42ec6 100644 --- a/tests/test-dirs/type-expr.t/run.t +++ b/tests/test-dirs/type-expr.t/run.t @@ -78,6 +78,7 @@ val length : 'a list -> int val compare_lengths : 'a list -> 'b list -> int val compare_length_with : 'a list -> int -> int + val is_empty : 'a list -> bool val cons : 'a -> 'a list -> 'a list val hd : 'a list -> 'a val tl : 'a list -> 'a list @@ -98,14 +99,17 @@ 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 fold_left_map : + ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list + val fold_left : ('acc -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc + val fold_right : ('a -> 'acc -> 'acc) -> 'a list -> 'acc -> 'acc 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 fold_left2 : + ('acc -> 'a -> 'b -> 'acc) -> 'acc -> 'a list -> 'b list -> 'acc + val fold_right2 : + ('a -> 'b -> 'acc -> 'acc) -> 'a list -> 'b list -> 'acc -> 'acc 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 @@ -114,7 +118,9 @@ val memq : 'a -> 'a list -> bool val find : ('a -> bool) -> 'a list -> 'a val find_opt : ('a -> bool) -> 'a list -> 'a option + val find_index : ('a -> bool) -> 'a list -> int option val find_map : ('a -> 'b option) -> 'a list -> 'b option + val find_mapi : (int -> '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 diff --git a/tests/test-dirs/typing-recovery.t b/tests/test-dirs/typing-recovery.t index 53ab9694d6..d22de62fe8 100644 --- a/tests/test-dirs/typing-recovery.t +++ b/tests/test-dirs/typing-recovery.t @@ -67,7 +67,7 @@ structure_item (test.ml[1,0+0]..test.ml[1,0+14]) Tstr_type Rec [ - type_declaration t/274 (test.ml[1,0+0]..test.ml[1,0+14]) + type_declaration t/275 (test.ml[1,0+0]..test.ml[1,0+14]) ptype_params = [] ptype_cstrs = @@ -76,11 +76,11 @@ Ttype_variant [ (test.ml[1,0+9]..test.ml[1,0+10]) - A/275 + A/276 [] None (test.ml[1,0+11]..test.ml[1,0+14]) - B/276 + B/277 [] None ] @@ -93,7 +93,7 @@ [ pattern (test.ml[2,15+4]..test.ml[2,15+5]) - Tpat_var \"f/277\" + Tpat_var \"f/278\" expression (test.ml[2,15+6]..test.ml[6,69+12]) ghost Texp_function Nolabel @@ -103,15 +103,15 @@ extra Tpat_extra_constraint core_type (test.ml[2,15+11]..test.ml[2,15+12]) - Ttyp_constr \"t/274\" + Ttyp_constr \"t/275\" [] - Tpat_alias \"x/279\" + Tpat_alias \"x/280\" 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/279\" + Texp_ident \"x/280\" [ pattern (test.ml[4,46+4]..test.ml[4,46+5]) @@ -144,7 +144,7 @@ ] attribute \"merlin.loc\" [] - Texp_ident \"*type-error*/280\" + Texp_ident \"*type-error*/281\" pattern (test.ml[6,69+4]..test.ml[6,69+5]) Tpat_value @@ -164,7 +164,7 @@ ] attribute \"merlin.loc\" [] - Texp_ident \"*type-error*/281\" + Texp_ident \"*type-error*/282\" ] ] ] @@ -224,7 +224,7 @@ structure_item (test2.ml[1,0+0]..test2.ml[1,0+14]) Tstr_type Rec [ - type_declaration t/274 (test2.ml[1,0+0]..test2.ml[1,0+14]) + type_declaration t/275 (test2.ml[1,0+0]..test2.ml[1,0+14]) ptype_params = [] ptype_cstrs = @@ -233,11 +233,11 @@ Ttype_variant [ (test2.ml[1,0+9]..test2.ml[1,0+10]) - A/275 + A/276 [] None (test2.ml[1,0+11]..test2.ml[1,0+14]) - B/276 + B/277 [] None ] @@ -250,7 +250,7 @@ [ pattern (test2.ml[2,15+4]..test2.ml[2,15+5]) - Tpat_var \"f/277\" + Tpat_var \"f/278\" expression (test2.ml[2,15+6]..test2.ml[2,15+24]) ghost Texp_function Nolabel @@ -262,7 +262,7 @@ extra Tpat_extra_constraint core_type (test2.ml[2,15+11]..test2.ml[2,15+12]) - Ttyp_constr \"t/274\" + Ttyp_constr \"t/275\" [] Tpat_any expression (test2.ml[2,15+22]..test2.ml[2,15+24]) @@ -280,7 +280,7 @@ core_type (test2.ml[2,15+16]..test2.ml[2,15+19]) Ttyp_constr \"int/1!\" [] - Texp_ident \"*type-error*/279\" + Texp_ident \"*type-error*/280\" ] ] ] @@ -330,14 +330,14 @@ First a simple case: "value": "[ signature_item (test.mli[1,0+0]..test.mli[1,0+14]) Tsig_value - value_description foo1/274 (test.mli[1,0+0]..test.mli[1,0+14]) + value_description foo1/275 (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/275 (test.mli[3,16+0]..test.mli[3,16+21]) + value_description foo2/276 (test.mli[3,16+0]..test.mli[3,16+21]) core_type (test.mli[3,16+11]..test.mli[3,16+21]) Ttyp_tuple [ @@ -350,7 +350,7 @@ First a simple case: [] signature_item (test.mli[5,39+0]..test.mli[5,39+21]) Tsig_value - value_description foo3/276 (test.mli[5,39+0]..test.mli[5,39+21]) + value_description foo3/277 (test.mli[5,39+0]..test.mli[5,39+21]) core_type (test.mli[5,39+11]..test.mli[5,39+21]) Ttyp_tuple [ @@ -414,38 +414,38 @@ And now, with an error deep in a submodule: "value": "[ signature_item (test2.mli[1,0+0]..test2.mli[1,0+14]) Tsig_value - value_description foo1/274 (test2.mli[1,0+0]..test2.mli[1,0+14]) + value_description foo1/275 (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/280\" + Tsig_module \"M/281\" 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/275 (test2.mli[4,31+2]..test2.mli[4,31+17]) + value_description foo21/276 (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/279\" + Tsig_module \"N/280\" 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/276 (test2.mli[6,66+4]..test2.mli[6,66+20]) + value_description foo211/277 (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/277 (test2.mli[7,87+4]..test2.mli[7,87+27]) + value_description foo212/278 (test2.mli[7,87+4]..test2.mli[7,87+27]) core_type (test2.mli[7,87+17]..test2.mli[7,87+27]) Ttyp_tuple [ @@ -458,7 +458,7 @@ And now, with an error deep in a submodule: [] signature_item (test2.mli[8,115+4]..test2.mli[8,115+27]) Tsig_value - value_description foo213/278 (test2.mli[8,115+4]..test2.mli[8,115+27]) + value_description foo213/279 (test2.mli[8,115+4]..test2.mli[8,115+27]) core_type (test2.mli[8,115+17]..test2.mli[8,115+27]) Ttyp_tuple [ @@ -474,7 +474,7 @@ And now, with an error deep in a submodule: ] signature_item (test2.mli[12,154+0]..test2.mli[12,154+21]) Tsig_value - value_description foo3/281 (test2.mli[12,154+0]..test2.mli[12,154+21]) + value_description foo3/282 (test2.mli[12,154+0]..test2.mli[12,154+21]) core_type (test2.mli[12,154+11]..test2.mli[12,154+21]) Ttyp_tuple [ @@ -539,12 +539,12 @@ make sure we also handle that correctly in structures: pattern (test_ct.ml[1,0+4]..test_ct.ml[1,0+8]) extra 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!\" - [] - Tpat_var \"foo1/274\" + core_type (test_ct.ml[1,0+11]..test_ct.ml[1,0+14]) + Ttyp_constr \"int/1!\" + [] + Tpat_alias \"foo1/275\" + pattern (test_ct.ml[1,0+4]..test_ct.ml[1,0+8]) + Tpat_any expression (test_ct.ml[1,0+17]..test_ct.ml[1,0+18]) extra Texp_constraint @@ -560,18 +560,18 @@ make sure we also handle that correctly in structures: pattern (test_ct.ml[3,20+4]..test_ct.ml[3,20+8]) extra 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 - ] - Tpat_var \"foo2/275\" + 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 + ] + Tpat_alias \"foo2/276\" + pattern (test_ct.ml[3,20+4]..test_ct.ml[3,20+8]) + Tpat_any expression (test_ct.ml[3,20+24]..test_ct.ml[3,20+28]) extra Texp_constraint @@ -599,19 +599,19 @@ make sure we also handle that correctly in structures: pattern (test_ct.ml[5,50+4]..test_ct.ml[5,50+8]) extra 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!\" - [] - ] - Tpat_var \"foo3/276\" + 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!\" + [] + ] + Tpat_alias \"foo3/277\" + pattern (test_ct.ml[5,50+4]..test_ct.ml[5,50+8]) + Tpat_any expression (test_ct.ml[5,50+23]..test_ct.ml[5,50+27]) extra Texp_constraint From 84ca5dbc89c9f0d0736531cd698492d6945c1519 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 17 Apr 2023 18:06:23 -0300 Subject: [PATCH 046/130] Bump opam files to 5.1 --- merlin-lib.opam | 2 +- merlin.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/merlin-lib.opam b/merlin-lib.opam index b22d70774c..9f1e8f6d42 100644 --- a/merlin-lib.opam +++ b/merlin-lib.opam @@ -10,7 +10,7 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "ocaml" {>= "5.0" & < "5.1"} + "ocaml" {>= "5.1" & < "5.2"} "dune" {>= "2.9.0"} "csexp" {>= "1.5.1"} "menhir" {dev & >= "20201216"} diff --git a/merlin.opam b/merlin.opam index 9d6cdcff41..d036b83937 100644 --- a/merlin.opam +++ b/merlin.opam @@ -11,7 +11,7 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] depends: [ - "ocaml" {>= "5.0" & < "5.1"} + "ocaml" {>= "5.1" & < "5.2"} "dune" {>= "2.9.0"} "merlin-lib" {= version} "dot-merlin-reader" {>= "4.9"} From 7f00508ba54a6e40fd38df43f4598bbaf69c48d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 18 Apr 2023 11:08:51 -0300 Subject: [PATCH 047/130] Add a changelog entry --- CHANGES.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 15eb2110a9..5319989df3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -106,9 +106,11 @@ Thu Aug 24 17:17:42 CEST 2023 merlin 4.9 ========== -Fri May 26 15:23:42 CEST 2023 +unreleased + merlin binary + - Preview support for OCaml 5.1-alpha1. Short path is temporary disabled and + inline records might not behave as expected. - Allow monadic IO in dot protocol (#1581) - Add a `scope` option to the `occurrences` command in preparation for the upcoming `project-wide-occurrences` feature (#1596) From 9b0fd0b825633da5f1171d6a90e1be0cc375a5a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 9 Jun 2023 14:38:11 +0200 Subject: [PATCH 048/130] Prepare CI for 5.1 --- dot-merlin-reader.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dot-merlin-reader.opam b/dot-merlin-reader.opam index 9574afe0b7..7f38e94b6b 100644 --- a/dot-merlin-reader.opam +++ b/dot-merlin-reader.opam @@ -11,7 +11,7 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "ocaml" {>= "5.0" & < "6.0" } + "ocaml" {>= "5.1" & < "5.2" } "dune" {>= "2.9.0"} "merlin-lib" {>= "4.9"} "ocamlfind" {>= "1.6.0"} From 4276155ddb29bde01452da113163d3e0ec0f69af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 21 Sep 2023 16:46:47 +0200 Subject: [PATCH 049/130] Prepare for release 4.11-501 --- CHANGES.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 5319989df3..00fa74c777 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -59,6 +59,7 @@ merlin 4.11 Thu Sep 24 18:01:42 CEST 2023 + merlin binary + - Add support for OCaml 5.1 - Improve error messages for missing configuration reader (#1669) - Fix regression causing crash when using ppxes under Windows (#1673) - Fix confusion between aliased modules and module types (#1676, @@ -75,7 +76,7 @@ Thu Sep 24 18:01:42 CEST 2023 - emacs: remove use of obsolete `defadvice` macro (#1675) merlin 4.10 -========== +=========== Thu Aug 24 17:17:42 CEST 2023 + merlin binary From daf31eec7bbd78e1ddd71572355f7fc9deaf302c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 8 Nov 2023 17:37:10 +0100 Subject: [PATCH 050/130] Disable windows CI until Opam 2.2 is out :finger-crossed: --- .github/workflows/main.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index ef8c009e61..717ec32c44 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -38,7 +38,7 @@ jobs: os: - macos-latest - ubuntu-latest - - windows-latest + # - windows-latest ocaml-compiler: - 5.0.x # The type of runner that the job will run on @@ -51,12 +51,12 @@ jobs: # 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: Checkout tree + uses: actions/checkout@v4 - - name: Set up OCaml ${{ matrix.ocaml-compiler }} + - name: Set-up OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v2 with: - # Version of the OCaml compiler to initialise ocaml-compiler: ${{ matrix.ocaml-compiler }} - name: Install dependencies From 4012a91d331904d4f1900c4f6dd3047bb93aa8ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 21 Nov 2023 14:58:30 +0100 Subject: [PATCH 051/130] Add test illustrating #1703 Merlin has no use for the `-cmi-file` flag but should not reject it. --- tests/test-dirs/with-cmi.t | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 tests/test-dirs/with-cmi.t diff --git a/tests/test-dirs/with-cmi.t b/tests/test-dirs/with-cmi.t new file mode 100644 index 0000000000..05b5a26c7e --- /dev/null +++ b/tests/test-dirs/with-cmi.t @@ -0,0 +1,34 @@ +Since OCaml 5.1 the compiler support the -cmi-file flag: +> -cmi-file filename +> Use the given interface file to type-check the ML source file to compile. +> When this option is not specified, the compiler looks for a .mli file with +> the same base name than the implementation it is compiling and in the same +> directory. If such a file is found, the compiler looks for a corresponding +> .cmi file in the included directories and reports an error if it fails to +> find one. + + $ cat >main.mli <<'EOF' + > val f : unit -> int + > EOF + + $ $OCAMLC -c main.mli + $ rm main.mli + + + $ cat >main.ml <<'EOF' + > let f () = 42 + > EOF + + $ $OCAMLC -c -cmi-file main.cmi main.ml + +FIXME: Merlin should ignore the -cmi-file flag + $ $MERLIN single errors -cmi-file main.cmi -filename main.ml jq '.value' + [ + { + "type": "config", + "sub": [], + "valid": true, + "message": "unknown flag -cmi-file" + } + ] From 742f4848a86eb65a9c492c1d2fa88114da7f3e00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 21 Nov 2023 15:01:09 +0100 Subject: [PATCH 052/130] Add `-cmi-file` to the ignored flags. Fixes #1703 --- src/kernel/mconfig.ml | 2 +- tests/test-dirs/with-cmi.t | 11 ++--------- 2 files changed, 3 insertions(+), 10 deletions(-) diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index ad75d7aea5..e79b9c36fb 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -428,7 +428,7 @@ let ocaml_ignored_parametrized_flags = [ "-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"; "-dump-dir"; + "-error-style"; "-dump-dir"; "-cmi-file"; ] let ocaml_warnings_spec ~error = diff --git a/tests/test-dirs/with-cmi.t b/tests/test-dirs/with-cmi.t index 05b5a26c7e..bb0e9daa10 100644 --- a/tests/test-dirs/with-cmi.t +++ b/tests/test-dirs/with-cmi.t @@ -21,14 +21,7 @@ Since OCaml 5.1 the compiler support the -cmi-file flag: $ $OCAMLC -c -cmi-file main.cmi main.ml -FIXME: Merlin should ignore the -cmi-file flag +Merlin should ignore the -cmi-file flag $ $MERLIN single errors -cmi-file main.cmi -filename main.ml jq '.value' - [ - { - "type": "config", - "sub": [], - "valid": true, - "message": "unknown flag -cmi-file" - } - ] + [] From 80a6f5c47723214b73877a5b3e191eb9eadfa0e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 21 Nov 2023 15:07:48 +0100 Subject: [PATCH 053/130] Add change entry for 11710 --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 00fa74c777..e85fa6340c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -36,6 +36,8 @@ Fri Dec 1 15:00:42 CET 2023 - Fix a follow-up issue to the preference of non-ghost nodes introduced in #1660 (#1690, fixes #1689) - Add `-cache-lifespan` flag, that sets cache invalidation period. (#1698, #1705) + - Ignore the new 5.1 `cmi-file` flag instead of rejecting it (#1710, fixes + #1703) - Fix Merlin locate not fallbacking on the correct file in case of ambiguity (@goldfirere, #1699) - Fix Merlin reporting errors provoked by the recovery itself (#1709, fixes From 419becf0820aa02db89d0ed7f0bd8300ddcdbbad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 27 Nov 2023 14:32:53 +0100 Subject: [PATCH 054/130] Pull latest changes from upsteam (35fdd0226e2e05a1a8244ecfec780b563b23b59c) --- upstream/ocaml_501/base-rev.txt | 2 +- upstream/ocaml_501/file_formats/cmi_format.ml | 4 +- upstream/ocaml_501/file_formats/cmt_format.ml | 4 +- upstream/ocaml_501/typing/typedecl.ml | 47 ++++++++---- upstream/ocaml_501/typing/types.ml | 2 +- upstream/ocaml_501/utils/config.common.ml | 1 - upstream/ocaml_501/utils/config.ml | 76 +++++++------------ 7 files changed, 65 insertions(+), 71 deletions(-) diff --git a/upstream/ocaml_501/base-rev.txt b/upstream/ocaml_501/base-rev.txt index 9a1aca59eb..eebea0509a 100644 --- a/upstream/ocaml_501/base-rev.txt +++ b/upstream/ocaml_501/base-rev.txt @@ -1 +1 @@ -5717a14d0e3dc2b0e41ab94b82977d5761f70ea2 +35fdd0226e2e05a1a8244ecfec780b563b23b59c diff --git a/upstream/ocaml_501/file_formats/cmi_format.ml b/upstream/ocaml_501/file_formats/cmi_format.ml index aa3d6777a0..3b7a03828f 100644 --- a/upstream/ocaml_501/file_formats/cmi_format.ml +++ b/upstream/ocaml_501/file_formats/cmi_format.ml @@ -42,7 +42,7 @@ type cmi_infos = { } let input_cmi ic = - let (name, sign) = (input_value ic : header) in + let (name, sign) = (Compression.input_value ic : header) in let crcs = (input_value ic : crcs) in let flags = (input_value ic : flags) in { @@ -84,7 +84,7 @@ let read_cmi filename = let output_cmi filename oc cmi = (* beware: the provided signature must have been substituted for saving *) output_string oc Config.cmi_magic_number; - Marshal.(to_channel oc ((cmi.cmi_name, cmi.cmi_sign) : header) [Compression]); + Compression.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 diff --git a/upstream/ocaml_501/file_formats/cmt_format.ml b/upstream/ocaml_501/file_formats/cmt_format.ml index 8fa01e525b..16c3c287da 100644 --- a/upstream/ocaml_501/file_formats/cmt_format.ml +++ b/upstream/ocaml_501/file_formats/cmt_format.ml @@ -105,11 +105,11 @@ let clear_env binary_annots = exception Error of error -let input_cmt ic = (input_value ic : cmt_infos) +let input_cmt ic = (Compression.input_value ic : cmt_infos) let output_cmt oc cmt = output_string oc Config.cmt_magic_number; - Marshal.(to_channel oc (cmt : cmt_infos) [Compression]) + Compression.output_value oc (cmt : cmt_infos) let read filename = (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) diff --git a/upstream/ocaml_501/typing/typedecl.ml b/upstream/ocaml_501/typing/typedecl.ml index fcfbae876b..7abea49d06 100644 --- a/upstream/ocaml_501/typing/typedecl.ml +++ b/upstream/ocaml_501/typing/typedecl.ml @@ -95,7 +95,12 @@ 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) = +(* Add a dummy type declaration to the environment, with the given arity. + The [type_kind] is [Type_abstract], but there is a generic [type_manifest] + for abbreviations, to allow polymorphic expansion, except if + [abstract_abbrevs] is [true]. + This function is only used in [transl_type_decl]. *) +let enter_type ~abstract_abbrevs rec_flag env sdecl (id, uid) = let needed = match rec_flag with | Asttypes.Nonrecursive -> @@ -111,15 +116,17 @@ let enter_type rec_flag env sdecl (id, uid) = in let arity = List.length sdecl.ptype_params in if not needed then env else + let type_manifest = match sdecl.ptype_manifest, abstract_abbrevs with + | None, _ | Some _, true -> None + | Some _, false -> Some(Ctype.newvar ()) + in 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_manifest; type_variance = Variance.unknown_signature ~injective:false ~arity; type_separability = Types.Separability.default_signature ~arity; type_is_newtype = false; @@ -782,7 +789,7 @@ let check_abbrev env sdecl (id, decl) = - if -rectypes is not used, we only allow cycles in the type graph if they go through an object or polymorphic variant type *) -let check_well_founded env loc path to_check visited ty0 = +let check_well_founded ~abs_env env loc path to_check visited ty0 = let rec check parents trace ty = if TypeSet.mem ty parents then begin (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) @@ -798,8 +805,8 @@ let check_well_founded env loc path to_check visited ty0 = | trace -> List.rev trace, false in if rec_abbrev - then Recursive_abbrev (Path.name path, env, reaching_path) - else Cycle_in_def (Path.name path, env, reaching_path) + then Recursive_abbrev (Path.name path, abs_env, reaching_path) + else Cycle_in_def (Path.name path, abs_env, reaching_path) in raise (Error (loc, err)) end; let (fini, parents) = @@ -844,11 +851,11 @@ let check_well_founded env loc path to_check visited ty0 = (* Will be detected by check_regularity *) Btype.backtrack snap -let check_well_founded_manifest env loc path decl = +let check_well_founded_manifest ~abs_env env loc path decl = if decl.type_manifest = None then () else let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in let visited = ref TypeMap.empty in - check_well_founded env loc path (Path.same path) visited + check_well_founded ~abs_env env loc path (Path.same path) visited (Ctype.newconstr path args) (* Given a new type declaration [type t = ...] (potentially mutually-recursive), @@ -866,7 +873,7 @@ let check_well_founded_manifest env loc path decl = (we don't have an example at hand where it is necessary), but we are doing it anyway out of caution. *) -let check_well_founded_decl env loc path decl to_check = +let check_well_founded_decl ~abs_env env loc path decl to_check = let open Btype in (* We iterate on all subexpressions of the declaration to check "in depth" that no ill-founded type exists. *) @@ -885,7 +892,7 @@ let check_well_founded_decl env loc path decl to_check = {type_iterators with it_type_expr = (fun self ty -> if TypeSet.mem ty !checked then () else begin - check_well_founded env loc path to_check visited ty; + check_well_founded ~abs_env env loc path to_check visited ty; checked := TypeSet.add ty !checked; self.it_do_type_expr self ty end)} in @@ -1073,7 +1080,8 @@ let transl_type_decl env rec_flag sdecl_list = Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> (* Enter types. *) let temp_env = - List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in + List.fold_left2 (enter_type ~abstract_abbrevs:false rec_flag) + env sdecl_list ids_list in (* Translate each declaration. *) let current_slot = ref None in let warn_unused = @@ -1130,14 +1138,23 @@ let transl_type_decl env rec_flag sdecl_list = List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc)) ids_list sdecl_list in + (* Error messages cannot use the new environment, as this might result in + non-termination. Instead we use a completely abstract version of the + temporary environment, giving a reason for why abbreviations cannot be + expanded (#12645, #12649) *) + let abs_env = + List.fold_left2 + (enter_type ~abstract_abbrevs:true rec_flag) + env sdecl_list ids_list in List.iter (fun (id, decl) -> - check_well_founded_manifest new_env (List.assoc id id_loc_list) + check_well_founded_manifest ~abs_env 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) + check_well_founded_decl ~abs_env new_env (List.assoc id id_loc_list) + (Path.Pident id) decl to_check) decls; List.iter @@ -1818,7 +1835,7 @@ 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_well_founded_decl ~abs_env:env env loc path decl to_check; check_regularity ~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 *) diff --git a/upstream/ocaml_501/typing/types.ml b/upstream/ocaml_501/typing/types.ml index 45a4f896d6..c1dbdb6895 100644 --- a/upstream/ocaml_501/typing/types.ml +++ b/upstream/ocaml_501/typing/types.ml @@ -186,7 +186,7 @@ module Variance = struct let mp = mem May_pos v1 && mem May_pos v2 || mem May_neg v1 && mem May_neg v2 and mn = - mem May_pos v1 && mem May_neg v2 || mem May_pos v1 && mem May_neg v2 + mem May_pos v1 && mem May_neg v2 || mem May_neg v1 && mem May_pos v2 and mw = mem May_weak v1 && v2 <> null || v1 <> null && mem May_weak v2 and inj = mem Inj v1 && mem Inj v2 and pos = mem Pos v1 && mem Pos v2 || mem Neg v1 && mem Neg v2 diff --git a/upstream/ocaml_501/utils/config.common.ml b/upstream/ocaml_501/utils/config.common.ml index 9fa25b1dfa..d4850ffd50 100644 --- a/upstream/ocaml_501/utils/config.common.ml +++ b/upstream/ocaml_501/utils/config.common.ml @@ -122,7 +122,6 @@ let configuration_variables () = p_bool "supports_shared_libraries" supports_shared_libraries; p_bool "native_dynlink" native_dynlink; p_bool "naked_pointers" naked_pointers; - p_bool "compression_supported" (Marshal.compression_supported()); p "exec_magic_number" exec_magic_number; p "cmi_magic_number" cmi_magic_number; diff --git a/upstream/ocaml_501/utils/config.ml b/upstream/ocaml_501/utils/config.ml index cb65204acc..470944cf6a 100644 --- a/upstream/ocaml_501/utils/config.ml +++ b/upstream/ocaml_501/utils/config.ml @@ -27,13 +27,13 @@ let c_compiler = {|gcc|} let c_output_obj = {|-o |} let c_has_debug_prefix_map = true let as_has_debug_prefix_map = false -let ocamlc_cflags = {|-O2 -fno-strict-aliasing -fwrapv -pthread |} +let ocamlc_cflags = {| -O2 -fno-strict-aliasing -fwrapv -pthread -pthread|} let ocamlc_cppflags = {| -D_FILE_OFFSET_BITS=64 |} (* #7678: ocamlopt uses these only to compile .c files, and the behaviour for the two drivers should be identical. *) -let ocamlopt_cflags = {|-O2 -fno-strict-aliasing -fwrapv -pthread |} +let ocamlopt_cflags = {| -O2 -fno-strict-aliasing -fwrapv -pthread -pthread|} let ocamlopt_cppflags = {| -D_FILE_OFFSET_BITS=64 |} -let bytecomp_c_libraries = {| -L/opt/homebrew/Cellar/zstd/1.5.2/lib -lzstd -lm -lpthread|} +let bytecomp_c_libraries = {| -L/opt/homebrew/opt/zstd/lib -lzstd -lpthread|} (* 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 @@ -44,36 +44,17 @@ let bytecomp_c_compiler = c_compiler ^ " " ^ ocamlc_cflags ^ " " ^ ocamlc_cppflags let native_c_compiler = c_compiler ^ " " ^ ocamlopt_cflags ^ " " ^ ocamlopt_cppflags -let native_c_libraries = {| -L/opt/homebrew/Cellar/zstd/1.5.2/lib -lzstd -lm -lpthread|} +let native_c_libraries = {| -L/opt/homebrew/opt/zstd/lib -lzstd -lpthread|} +let native_ldflags = {||} let native_pack_linker = {|ld -r -o |} let default_rpath = {||} let mksharedlibrpath = {||} let ar = {|ar|} let supports_shared_libraries = true let native_dynlink = true -let mkdll, mkexe, mkmaindll = - if Sys.win32 || Sys.cygwin && supports_shared_libraries then - let flexlink = - let flexlink = - Option.value ~default:"flexlink" (Sys.getenv_opt "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 - in - let flexdll_chain = {||} in - let flexlink_flags = {||} in - let flags = " -chain " ^ flexdll_chain ^ " " ^ flexlink_flags in - flexlink ^ flags ^ {| |}, - flexlink ^ " -exe" ^ flags - ^ {| |} ^ {| |}, - flexlink ^ " -maindll" ^ flags ^ {| |} - else - {|gcc -shared -undefined dynamic_lookup -Wl,-w |}, - {|gcc -O2 -fno-strict-aliasing -fwrapv -pthread |}, - {|gcc -shared -undefined dynamic_lookup -Wl,-w|} +let mkdll = {|gcc -shared -undefined dynamic_lookup -Wl,-w |} +let mkexe = {|gcc -O2 -fno-strict-aliasing -fwrapv -pthread -pthread |} +let mkmaindll = {|gcc -shared -undefined dynamic_lookup -Wl,-w |} let flambda = false let with_flambda_invariants = false @@ -102,15 +83,18 @@ let ext_asm = "." ^ {|s|} let ext_lib = "." ^ {|a|} let ext_dll = "." ^ {|so|} -let host = {|aarch64-apple-darwin22.3.0|} -let target = {|aarch64-apple-darwin22.3.0|} +let host = {|aarch64-apple-darwin23.0.0|} +let target = {|aarch64-apple-darwin23.0.0|} let systhread_supported = true let flexdll_dirs = [] let ar_supports_response_files = true -#2 "utils/config.common.ml" + +let tsan = false +(* utils/config.common.ml. Generated from config.common.ml.in by configure. *) +#3 "utils/config.common.ml.in" (**************************************************************************) (* *) (* OCaml *) @@ -140,26 +124,18 @@ let standard_library = with Not_found -> standard_library_default -let exec_magic_number = "Caml1999X033" +let exec_magic_number = {magic|Caml1999X033|magic} (* exec_magic_number is duplicated in runtime/caml/exec.h *) -and cmi_magic_number = "Caml1999I033" -and cmo_magic_number = "Caml1999O033" -and cma_magic_number = "Caml1999A033" -and cmx_magic_number = - if flambda then - "Caml1999y033" - else - "Caml1999Y033" -and cmxa_magic_number = - if flambda then - "Caml1999z033" - else - "Caml1999Z033" -and ast_impl_magic_number = "Caml1999M033" -and ast_intf_magic_number = "Caml1999N033" -and cmxs_magic_number = "Caml1999D033" -and cmt_magic_number = "Caml1999T033" -and linear_magic_number = "Caml1999L033" +and cmi_magic_number = {magic|Caml1999I033|magic} +and cmo_magic_number = {magic|Caml1999O033|magic} +and cma_magic_number = {magic|Caml1999A033|magic} +and cmx_magic_number = {magic|Caml1999Y033|magic} +and cmxa_magic_number = {magic|Caml1999Z033|magic} +and ast_impl_magic_number = {magic|Caml1999M033|magic} +and ast_intf_magic_number = {magic|Caml1999N033|magic} +and cmxs_magic_number = {magic|Caml1999D033|magic} +and cmt_magic_number = {magic|Caml1999T033|magic} +and linear_magic_number = {magic|Caml1999L033|magic} let safe_string = true let default_safe_string = true @@ -204,6 +180,7 @@ let configuration_variables () = p "native_c_compiler" native_c_compiler; p "bytecomp_c_libraries" bytecomp_c_libraries; p "native_c_libraries" native_c_libraries; + p "native_ldflags" native_ldflags; p "native_pack_linker" native_pack_linker; p_bool "native_compiler" native_compiler; p "architecture" architecture; @@ -230,6 +207,7 @@ let configuration_variables () = p_bool "flat_float_array" flat_float_array; p_bool "function_sections" function_sections; p_bool "afl_instrument" afl_instrument; + p_bool "tsan" tsan; p_bool "windows_unicode" windows_unicode; p_bool "supports_shared_libraries" supports_shared_libraries; p_bool "native_dynlink" native_dynlink; From 95dc450209fba2c8329b449cbb87a9f89013b44d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 27 Nov 2023 14:33:16 +0100 Subject: [PATCH 055/130] Merge upstream changes to the vendored typer --- src/ocaml/typing/typedecl.ml | 47 ++++++++++++++++++++++++------------ src/ocaml/typing/types.ml | 2 +- 2 files changed, 33 insertions(+), 16 deletions(-) diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index e01e80e5f4..c3820f3aec 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/src/ocaml/typing/typedecl.ml @@ -98,7 +98,12 @@ let add_type ~long_path ~check id decl env = | true -> Env.add_type_long_path ~check id decl env | false -> Env.add_type ~check id decl env) -let enter_type rec_flag env sdecl (id, uid) = +(* Add a dummy type declaration to the environment, with the given arity. + The [type_kind] is [Type_abstract], but there is a generic [type_manifest] + for abbreviations, to allow polymorphic expansion, except if + [abstract_abbrevs] is [true]. + This function is only used in [transl_type_decl]. *) +let enter_type ~abstract_abbrevs rec_flag env sdecl (id, uid) = let needed = match rec_flag with | Asttypes.Nonrecursive -> @@ -114,15 +119,17 @@ let enter_type rec_flag env sdecl (id, uid) = in let arity = List.length sdecl.ptype_params in if not needed then env else + let type_manifest = match sdecl.ptype_manifest, abstract_abbrevs with + | None, _ | Some _, true -> None + | Some _, false -> Some(Ctype.newvar ()) + in 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_manifest; type_variance = Variance.unknown_signature ~injective:false ~arity; type_separability = Types.Separability.default_signature ~arity; type_is_newtype = false; @@ -789,7 +796,7 @@ let check_abbrev env sdecl (id, decl) = - if -rectypes is not used, we only allow cycles in the type graph if they go through an object or polymorphic variant type *) -let check_well_founded env loc path to_check visited ty0 = +let check_well_founded ~abs_env env loc path to_check visited ty0 = let rec check parents trace ty = if TypeSet.mem ty parents then begin (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) @@ -805,8 +812,8 @@ let check_well_founded env loc path to_check visited ty0 = | trace -> List.rev trace, false in if rec_abbrev - then Recursive_abbrev (Path.name path, env, reaching_path) - else Cycle_in_def (Path.name path, env, reaching_path) + then Recursive_abbrev (Path.name path, abs_env, reaching_path) + else Cycle_in_def (Path.name path, abs_env, reaching_path) in raise (Error (loc, err)) end; let (fini, parents) = @@ -851,11 +858,11 @@ let check_well_founded env loc path to_check visited ty0 = (* Will be detected by check_regularity *) Btype.backtrack snap -let check_well_founded_manifest env loc path decl = +let check_well_founded_manifest ~abs_env env loc path decl = if decl.type_manifest = None then () else let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in let visited = ref TypeMap.empty in - check_well_founded env loc path (Path.same path) visited + check_well_founded ~abs_env env loc path (Path.same path) visited (Ctype.newconstr path args) (* Given a new type declaration [type t = ...] (potentially mutually-recursive), @@ -873,7 +880,7 @@ let check_well_founded_manifest env loc path decl = (we don't have an example at hand where it is necessary), but we are doing it anyway out of caution. *) -let check_well_founded_decl env loc path decl to_check = +let check_well_founded_decl ~abs_env env loc path decl to_check = let open Btype in (* We iterate on all subexpressions of the declaration to check "in depth" that no ill-founded type exists. *) @@ -892,7 +899,7 @@ let check_well_founded_decl env loc path decl to_check = {type_iterators with it_type_expr = (fun self ty -> if TypeSet.mem ty !checked then () else begin - check_well_founded env loc path to_check visited ty; + check_well_founded ~abs_env env loc path to_check visited ty; checked := TypeSet.add ty !checked; self.it_do_type_expr self ty end)} in @@ -1080,7 +1087,8 @@ let transl_type_decl env rec_flag sdecl_list = Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> (* Enter types. *) let temp_env = - List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in + List.fold_left2 (enter_type ~abstract_abbrevs:false rec_flag) + env sdecl_list ids_list in (* Translate each declaration. *) let current_slot = ref None in let warn_unused = @@ -1137,14 +1145,23 @@ let transl_type_decl env rec_flag sdecl_list = List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc)) ids_list sdecl_list in + (* Error messages cannot use the new environment, as this might result in + non-termination. Instead we use a completely abstract version of the + temporary environment, giving a reason for why abbreviations cannot be + expanded (#12645, #12649) *) + let abs_env = + List.fold_left2 + (enter_type ~abstract_abbrevs:true rec_flag) + env sdecl_list ids_list in List.iter (fun (id, decl) -> - check_well_founded_manifest new_env (List.assoc id id_loc_list) + check_well_founded_manifest ~abs_env 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) + check_well_founded_decl ~abs_env new_env (List.assoc id id_loc_list) + (Path.Pident id) decl to_check) decls; List.iter @@ -1830,7 +1847,7 @@ 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_well_founded_decl ~abs_env:env env loc path decl to_check; check_regularity ~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 *) diff --git a/src/ocaml/typing/types.ml b/src/ocaml/typing/types.ml index f75034b73d..4bba370fbd 100644 --- a/src/ocaml/typing/types.ml +++ b/src/ocaml/typing/types.ml @@ -185,7 +185,7 @@ module Variance = struct let mp = mem May_pos v1 && mem May_pos v2 || mem May_neg v1 && mem May_neg v2 and mn = - mem May_pos v1 && mem May_neg v2 || mem May_pos v1 && mem May_neg v2 + mem May_pos v1 && mem May_neg v2 || mem May_neg v1 && mem May_pos v2 and mw = mem May_weak v1 && v2 <> null || v1 <> null && mem May_weak v2 and inj = mem Inj v1 && mem Inj v2 and pos = mem Pos v1 && mem Pos v2 || mem Neg v1 && mem Neg v2 From 7b0dcd60e4c3cc8e73762a69251942226765b4cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 27 Nov 2023 14:34:26 +0100 Subject: [PATCH 056/130] Use compiler-libs' compression for read cmi and cmt files --- src/ocaml/compression/dune | 4 ++++ src/ocaml/compression/ocaml_compression.ml | 3 +++ src/ocaml/typing/cmi_format.ml | 4 ++-- src/ocaml/typing/cmt_format.ml | 4 ++-- src/ocaml/typing/dune | 2 +- 5 files changed, 12 insertions(+), 5 deletions(-) create mode 100644 src/ocaml/compression/dune create mode 100644 src/ocaml/compression/ocaml_compression.ml diff --git a/src/ocaml/compression/dune b/src/ocaml/compression/dune new file mode 100644 index 0000000000..86c7f02108 --- /dev/null +++ b/src/ocaml/compression/dune @@ -0,0 +1,4 @@ +(library + (name ocaml_compression) + (public_name merlin-lib.ocaml_compression) + (libraries compiler-libs.common)) diff --git a/src/ocaml/compression/ocaml_compression.ml b/src/ocaml/compression/ocaml_compression.ml new file mode 100644 index 0000000000..464aa32bd3 --- /dev/null +++ b/src/ocaml/compression/ocaml_compression.ml @@ -0,0 +1,3 @@ + +(** We rely on [compiler-libs] for compression *) +include Compression diff --git a/src/ocaml/typing/cmi_format.ml b/src/ocaml/typing/cmi_format.ml index 01e27b7cd5..b4934e27e7 100644 --- a/src/ocaml/typing/cmi_format.ml +++ b/src/ocaml/typing/cmi_format.ml @@ -35,7 +35,7 @@ type cmi_infos = { } let input_cmi ic = - let (name, sign) = (input_value ic : header) in + let (name, sign) = (Ocaml_compression.input_value ic : header) in let crcs = (input_value ic : crcs) in let flags = (input_value ic : flags) in { @@ -76,7 +76,7 @@ let read_cmi filename = 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); + Ocaml_compression.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 diff --git a/src/ocaml/typing/cmt_format.ml b/src/ocaml/typing/cmt_format.ml index 49a629879f..6fbc314f0a 100644 --- a/src/ocaml/typing/cmt_format.ml +++ b/src/ocaml/typing/cmt_format.ml @@ -121,11 +121,11 @@ let clear_env binary_annots = exception Error of error -let input_cmt ic = (input_value ic : cmt_infos) +let input_cmt ic = (Ocaml_compression.input_value ic : cmt_infos) let output_cmt oc cmt = output_string oc Config.cmt_magic_number; - output_value oc (cmt : cmt_infos) + Ocaml_compression.output_value oc (cmt : cmt_infos) let read filename = (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) diff --git a/src/ocaml/typing/dune b/src/ocaml/typing/dune index bebe62fbb2..132d16157e 100644 --- a/src/ocaml/typing/dune +++ b/src/ocaml/typing/dune @@ -7,4 +7,4 @@ -open Merlin_utils (:standard -w -9)) (modules_without_implementation annot outcometree) - (libraries merlin_utils ocaml_parsing ocaml_utils)) + (libraries merlin_utils ocaml_compression ocaml_parsing ocaml_utils)) From 37132992ce88635e4e58d3c7c958f47e34d80984 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 27 Nov 2023 14:44:22 +0100 Subject: [PATCH 057/130] Bump minimal OCaml version --- .github/workflows/main.yml | 2 +- merlin-lib.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 717ec32c44..e259ad71d1 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -40,7 +40,7 @@ jobs: - ubuntu-latest # - windows-latest ocaml-compiler: - - 5.0.x + - 5.1.x # The type of runner that the job will run on runs-on: ${{ matrix.os }} diff --git a/merlin-lib.opam b/merlin-lib.opam index 9f1e8f6d42..6fefee90d1 100644 --- a/merlin-lib.opam +++ b/merlin-lib.opam @@ -10,7 +10,7 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "ocaml" {>= "5.1" & < "5.2"} + "ocaml" {>= "5.1.1" & < "5.2"} "dune" {>= "2.9.0"} "csexp" {>= "1.5.1"} "menhir" {dev & >= "20201216"} From 13e55cd44836572d16b9871acbbded366c83e76c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 1 Dec 2023 14:48:22 +0100 Subject: [PATCH 058/130] Update changelog --- CHANGES.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index e85fa6340c..2e5df8269f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -28,8 +28,8 @@ Thu Feb 22 14:00:42 CET 2024 - vim: load merlin under the ocamlinterface and ocamllex filetypes (#1340) - Fix merlinpp not using binary file open (#1725, fixes #1724) -merlin 4.13 -=========== +merlin 4.13.1 +============= Fri Dec 1 15:00:42 CET 2023 + merlin binary @@ -42,6 +42,7 @@ Fri Dec 1 15:00:42 CET 2023 (@goldfirere, #1699) - Fix Merlin reporting errors provoked by the recovery itself (#1709, fixes #1704) + - Add support for OCaml 5.1.1 (#1714) + editor modes - vim: load merlin when Vim is compiled with +python3/dyn (e.g. MacVim) - emacs: highlight only first error line by default (#1693, fixes #1663) From 4640531a144b82ddae2246af1d147b6a940fae2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 5 Feb 2024 14:24:16 +0100 Subject: [PATCH 059/130] upstream: fetch latest changes from 5.2 branch. rev: 02b39701d81ef4d4f5824a2d018e6387b1eeb5a7 --- upstream/ocaml_502/base-rev.txt | 1 + upstream/ocaml_502/file_formats/cmi_format.ml | 118 + .../ocaml_502/file_formats/cmi_format.mli | 50 + upstream/ocaml_502/file_formats/cmt_format.ml | 483 ++ .../ocaml_502/file_formats/cmt_format.mli | 125 + upstream/ocaml_502/parsing/ast_helper.ml | 648 ++ upstream/ocaml_502/parsing/ast_helper.mli | 499 ++ upstream/ocaml_502/parsing/ast_invariants.ml | 210 + upstream/ocaml_502/parsing/ast_invariants.mli | 23 + upstream/ocaml_502/parsing/ast_iterator.ml | 746 ++ upstream/ocaml_502/parsing/ast_iterator.mli | 87 + upstream/ocaml_502/parsing/ast_mapper.ml | 1170 +++ upstream/ocaml_502/parsing/ast_mapper.mli | 211 + upstream/ocaml_502/parsing/asttypes.mli | 67 + upstream/ocaml_502/parsing/attr_helper.ml | 57 + upstream/ocaml_502/parsing/attr_helper.mli | 38 + .../ocaml_502/parsing/builtin_attributes.ml | 388 + .../ocaml_502/parsing/builtin_attributes.mli | 186 + upstream/ocaml_502/parsing/depend.ml | 631 ++ upstream/ocaml_502/parsing/depend.mli | 46 + upstream/ocaml_502/parsing/docstrings.ml | 425 + upstream/ocaml_502/parsing/docstrings.mli | 223 + upstream/ocaml_502/parsing/lexer.mli | 65 + upstream/ocaml_502/parsing/lexer.mll | 907 +++ upstream/ocaml_502/parsing/location.ml | 996 +++ upstream/ocaml_502/parsing/location.mli | 359 + upstream/ocaml_502/parsing/longident.ml | 50 + upstream/ocaml_502/parsing/longident.mli | 58 + upstream/ocaml_502/parsing/parse.ml | 178 + upstream/ocaml_502/parsing/parse.mli | 110 + upstream/ocaml_502/parsing/parser.mly | 4100 ++++++++++ upstream/ocaml_502/parsing/parsetree.mli | 1119 +++ upstream/ocaml_502/parsing/pprintast.ml | 1751 +++++ upstream/ocaml_502/parsing/pprintast.mli | 61 + upstream/ocaml_502/parsing/printast.ml | 1011 +++ upstream/ocaml_502/parsing/printast.mli | 32 + upstream/ocaml_502/parsing/syntaxerr.ml | 52 + upstream/ocaml_502/parsing/syntaxerr.mli | 45 + upstream/ocaml_502/parsing/unit_info.ml | 119 + upstream/ocaml_502/parsing/unit_info.mli | 153 + upstream/ocaml_502/typing/annot.mli | 23 + upstream/ocaml_502/typing/btype.ml | 780 ++ upstream/ocaml_502/typing/btype.mli | 320 + upstream/ocaml_502/typing/cmt2annot.ml | 190 + upstream/ocaml_502/typing/cmt2annot.mli | 22 + upstream/ocaml_502/typing/ctype.ml | 5593 +++++++++++++ upstream/ocaml_502/typing/ctype.mli | 472 ++ upstream/ocaml_502/typing/datarepr.ml | 238 + upstream/ocaml_502/typing/datarepr.mli | 45 + upstream/ocaml_502/typing/env.ml | 3717 +++++++++ upstream/ocaml_502/typing/env.mli | 525 ++ upstream/ocaml_502/typing/envaux.ml | 117 + upstream/ocaml_502/typing/envaux.mli | 36 + upstream/ocaml_502/typing/errortrace.ml | 194 + upstream/ocaml_502/typing/errortrace.mli | 168 + upstream/ocaml_502/typing/ident.ml | 388 + upstream/ocaml_502/typing/ident.mli | 110 + upstream/ocaml_502/typing/includeclass.ml | 118 + upstream/ocaml_502/typing/includeclass.mli | 33 + upstream/ocaml_502/typing/includecore.ml | 1037 +++ upstream/ocaml_502/typing/includecore.mli | 139 + upstream/ocaml_502/typing/includemod.ml | 1245 +++ upstream/ocaml_502/typing/includemod.mli | 261 + .../typing/includemod_errorprinter.ml | 976 +++ .../typing/includemod_errorprinter.mli | 17 + upstream/ocaml_502/typing/mtype.ml | 565 ++ upstream/ocaml_502/typing/mtype.mli | 55 + upstream/ocaml_502/typing/oprint.ml | 869 +++ upstream/ocaml_502/typing/oprint.mli | 36 + upstream/ocaml_502/typing/outcometree.mli | 160 + upstream/ocaml_502/typing/parmatch.ml | 2380 ++++++ upstream/ocaml_502/typing/parmatch.mli | 137 + upstream/ocaml_502/typing/path.ml | 148 + upstream/ocaml_502/typing/path.mli | 80 + upstream/ocaml_502/typing/patterns.ml | 254 + upstream/ocaml_502/typing/patterns.mli | 109 + upstream/ocaml_502/typing/persistent_env.ml | 380 + upstream/ocaml_502/typing/persistent_env.mli | 105 + upstream/ocaml_502/typing/predef.ml | 252 + upstream/ocaml_502/typing/predef.mli | 87 + upstream/ocaml_502/typing/primitive.ml | 257 + upstream/ocaml_502/typing/primitive.mli | 79 + upstream/ocaml_502/typing/printpat.ml | 163 + upstream/ocaml_502/typing/printpat.mli | 27 + upstream/ocaml_502/typing/printtyp.ml | 2717 +++++++ upstream/ocaml_502/typing/printtyp.mli | 249 + upstream/ocaml_502/typing/printtyped.ml | 998 +++ upstream/ocaml_502/typing/printtyped.mli | 23 + upstream/ocaml_502/typing/shape.ml | 357 + upstream/ocaml_502/typing/shape.mli | 201 + upstream/ocaml_502/typing/shape_reduce.ml | 347 + upstream/ocaml_502/typing/shape_reduce.mli | 62 + upstream/ocaml_502/typing/signature_group.ml | 155 + upstream/ocaml_502/typing/signature_group.mli | 85 + upstream/ocaml_502/typing/stypes.ml | 195 + upstream/ocaml_502/typing/stypes.mli | 35 + upstream/ocaml_502/typing/subst.ml | 834 ++ upstream/ocaml_502/typing/subst.mli | 147 + upstream/ocaml_502/typing/tast_iterator.ml | 693 ++ upstream/ocaml_502/typing/tast_iterator.mli | 72 + upstream/ocaml_502/typing/tast_mapper.ml | 909 +++ upstream/ocaml_502/typing/tast_mapper.mli | 75 + upstream/ocaml_502/typing/type_immediacy.ml | 43 + upstream/ocaml_502/typing/type_immediacy.mli | 40 + upstream/ocaml_502/typing/typeclass.ml | 2208 ++++++ upstream/ocaml_502/typing/typeclass.mli | 138 + upstream/ocaml_502/typing/typecore.ml | 6932 +++++++++++++++++ upstream/ocaml_502/typing/typecore.mli | 263 + upstream/ocaml_502/typing/typedecl.ml | 2267 ++++++ upstream/ocaml_502/typing/typedecl.mli | 111 + .../ocaml_502/typing/typedecl_immediacy.ml | 68 + .../ocaml_502/typing/typedecl_immediacy.mli | 27 + .../ocaml_502/typing/typedecl_properties.ml | 73 + .../ocaml_502/typing/typedecl_properties.mli | 55 + .../ocaml_502/typing/typedecl_separability.ml | 668 ++ .../typing/typedecl_separability.mli | 132 + upstream/ocaml_502/typing/typedecl_unboxed.ml | 43 + .../ocaml_502/typing/typedecl_unboxed.mli | 20 + .../ocaml_502/typing/typedecl_variance.ml | 437 ++ .../ocaml_502/typing/typedecl_variance.mli | 75 + upstream/ocaml_502/typing/typedtree.ml | 910 +++ upstream/ocaml_502/typing/typedtree.mli | 919 +++ upstream/ocaml_502/typing/typemod.ml | 3458 ++++++++ upstream/ocaml_502/typing/typemod.mli | 143 + upstream/ocaml_502/typing/typeopt.ml | 227 + upstream/ocaml_502/typing/typeopt.mli | 42 + upstream/ocaml_502/typing/types.ml | 902 +++ upstream/ocaml_502/typing/types.mli | 735 ++ upstream/ocaml_502/typing/typetexp.ml | 995 +++ upstream/ocaml_502/typing/typetexp.mli | 104 + upstream/ocaml_502/typing/untypeast.ml | 943 +++ upstream/ocaml_502/typing/untypeast.mli | 87 + upstream/ocaml_502/typing/value_rec_check.ml | 1426 ++++ upstream/ocaml_502/typing/value_rec_check.mli | 20 + upstream/ocaml_502/typing/value_rec_types.mli | 42 + upstream/ocaml_502/utils/arg_helper.ml | 127 + upstream/ocaml_502/utils/arg_helper.mli | 68 + upstream/ocaml_502/utils/binutils.ml | 684 ++ upstream/ocaml_502/utils/binutils.mli | 30 + .../ocaml_502/utils/build_path_prefix_map.ml | 118 + .../ocaml_502/utils/build_path_prefix_map.mli | 61 + upstream/ocaml_502/utils/ccomp.ml | 216 + upstream/ocaml_502/utils/ccomp.mli | 40 + upstream/ocaml_502/utils/clflags.ml | 582 ++ upstream/ocaml_502/utils/clflags.mli | 276 + upstream/ocaml_502/utils/config.fixed.ml | 73 + upstream/ocaml_502/utils/config.mli | 270 + upstream/ocaml_502/utils/consistbl.ml | 95 + upstream/ocaml_502/utils/consistbl.mli | 77 + upstream/ocaml_502/utils/diffing.ml | 447 ++ upstream/ocaml_502/utils/diffing.mli | 147 + upstream/ocaml_502/utils/diffing_with_keys.ml | 208 + .../ocaml_502/utils/diffing_with_keys.mli | 77 + upstream/ocaml_502/utils/identifiable.ml | 249 + upstream/ocaml_502/utils/identifiable.mli | 113 + .../utils/int_replace_polymorphic_compare.ml | 8 + .../utils/int_replace_polymorphic_compare.mli | 8 + upstream/ocaml_502/utils/lazy_backtrack.ml | 87 + upstream/ocaml_502/utils/lazy_backtrack.mli | 34 + upstream/ocaml_502/utils/load_path.ml | 233 + upstream/ocaml_502/utils/load_path.mli | 120 + upstream/ocaml_502/utils/local_store.ml | 74 + upstream/ocaml_502/utils/local_store.mli | 66 + upstream/ocaml_502/utils/misc.ml | 1179 +++ upstream/ocaml_502/utils/misc.mli | 796 ++ upstream/ocaml_502/utils/numbers.ml | 88 + upstream/ocaml_502/utils/numbers.mli | 51 + upstream/ocaml_502/utils/profile.ml | 335 + upstream/ocaml_502/utils/profile.mli | 49 + .../utils/strongly_connected_components.ml | 195 + .../utils/strongly_connected_components.mli | 43 + upstream/ocaml_502/utils/targetint.ml | 104 + upstream/ocaml_502/utils/targetint.mli | 208 + upstream/ocaml_502/utils/terminfo.ml | 45 + upstream/ocaml_502/utils/terminfo.mli | 32 + upstream/ocaml_502/utils/warnings.ml | 1240 +++ upstream/ocaml_502/utils/warnings.mli | 170 + 177 files changed, 82335 insertions(+) create mode 100644 upstream/ocaml_502/base-rev.txt create mode 100644 upstream/ocaml_502/file_formats/cmi_format.ml create mode 100644 upstream/ocaml_502/file_formats/cmi_format.mli create mode 100644 upstream/ocaml_502/file_formats/cmt_format.ml create mode 100644 upstream/ocaml_502/file_formats/cmt_format.mli create mode 100644 upstream/ocaml_502/parsing/ast_helper.ml create mode 100644 upstream/ocaml_502/parsing/ast_helper.mli create mode 100644 upstream/ocaml_502/parsing/ast_invariants.ml create mode 100644 upstream/ocaml_502/parsing/ast_invariants.mli create mode 100644 upstream/ocaml_502/parsing/ast_iterator.ml create mode 100644 upstream/ocaml_502/parsing/ast_iterator.mli create mode 100644 upstream/ocaml_502/parsing/ast_mapper.ml create mode 100644 upstream/ocaml_502/parsing/ast_mapper.mli create mode 100644 upstream/ocaml_502/parsing/asttypes.mli create mode 100644 upstream/ocaml_502/parsing/attr_helper.ml create mode 100644 upstream/ocaml_502/parsing/attr_helper.mli create mode 100644 upstream/ocaml_502/parsing/builtin_attributes.ml create mode 100644 upstream/ocaml_502/parsing/builtin_attributes.mli create mode 100644 upstream/ocaml_502/parsing/depend.ml create mode 100644 upstream/ocaml_502/parsing/depend.mli create mode 100644 upstream/ocaml_502/parsing/docstrings.ml create mode 100644 upstream/ocaml_502/parsing/docstrings.mli create mode 100644 upstream/ocaml_502/parsing/lexer.mli create mode 100644 upstream/ocaml_502/parsing/lexer.mll create mode 100644 upstream/ocaml_502/parsing/location.ml create mode 100644 upstream/ocaml_502/parsing/location.mli create mode 100644 upstream/ocaml_502/parsing/longident.ml create mode 100644 upstream/ocaml_502/parsing/longident.mli create mode 100644 upstream/ocaml_502/parsing/parse.ml create mode 100644 upstream/ocaml_502/parsing/parse.mli create mode 100644 upstream/ocaml_502/parsing/parser.mly create mode 100644 upstream/ocaml_502/parsing/parsetree.mli create mode 100644 upstream/ocaml_502/parsing/pprintast.ml create mode 100644 upstream/ocaml_502/parsing/pprintast.mli create mode 100644 upstream/ocaml_502/parsing/printast.ml create mode 100644 upstream/ocaml_502/parsing/printast.mli create mode 100644 upstream/ocaml_502/parsing/syntaxerr.ml create mode 100644 upstream/ocaml_502/parsing/syntaxerr.mli create mode 100644 upstream/ocaml_502/parsing/unit_info.ml create mode 100644 upstream/ocaml_502/parsing/unit_info.mli create mode 100644 upstream/ocaml_502/typing/annot.mli create mode 100644 upstream/ocaml_502/typing/btype.ml create mode 100644 upstream/ocaml_502/typing/btype.mli create mode 100644 upstream/ocaml_502/typing/cmt2annot.ml create mode 100644 upstream/ocaml_502/typing/cmt2annot.mli create mode 100644 upstream/ocaml_502/typing/ctype.ml create mode 100644 upstream/ocaml_502/typing/ctype.mli create mode 100644 upstream/ocaml_502/typing/datarepr.ml create mode 100644 upstream/ocaml_502/typing/datarepr.mli create mode 100644 upstream/ocaml_502/typing/env.ml create mode 100644 upstream/ocaml_502/typing/env.mli create mode 100644 upstream/ocaml_502/typing/envaux.ml create mode 100644 upstream/ocaml_502/typing/envaux.mli create mode 100644 upstream/ocaml_502/typing/errortrace.ml create mode 100644 upstream/ocaml_502/typing/errortrace.mli create mode 100644 upstream/ocaml_502/typing/ident.ml create mode 100644 upstream/ocaml_502/typing/ident.mli create mode 100644 upstream/ocaml_502/typing/includeclass.ml create mode 100644 upstream/ocaml_502/typing/includeclass.mli create mode 100644 upstream/ocaml_502/typing/includecore.ml create mode 100644 upstream/ocaml_502/typing/includecore.mli create mode 100644 upstream/ocaml_502/typing/includemod.ml create mode 100644 upstream/ocaml_502/typing/includemod.mli create mode 100644 upstream/ocaml_502/typing/includemod_errorprinter.ml create mode 100644 upstream/ocaml_502/typing/includemod_errorprinter.mli create mode 100644 upstream/ocaml_502/typing/mtype.ml create mode 100644 upstream/ocaml_502/typing/mtype.mli create mode 100644 upstream/ocaml_502/typing/oprint.ml create mode 100644 upstream/ocaml_502/typing/oprint.mli create mode 100644 upstream/ocaml_502/typing/outcometree.mli create mode 100644 upstream/ocaml_502/typing/parmatch.ml create mode 100644 upstream/ocaml_502/typing/parmatch.mli create mode 100644 upstream/ocaml_502/typing/path.ml create mode 100644 upstream/ocaml_502/typing/path.mli create mode 100644 upstream/ocaml_502/typing/patterns.ml create mode 100644 upstream/ocaml_502/typing/patterns.mli create mode 100644 upstream/ocaml_502/typing/persistent_env.ml create mode 100644 upstream/ocaml_502/typing/persistent_env.mli create mode 100644 upstream/ocaml_502/typing/predef.ml create mode 100644 upstream/ocaml_502/typing/predef.mli create mode 100644 upstream/ocaml_502/typing/primitive.ml create mode 100644 upstream/ocaml_502/typing/primitive.mli create mode 100644 upstream/ocaml_502/typing/printpat.ml create mode 100644 upstream/ocaml_502/typing/printpat.mli create mode 100644 upstream/ocaml_502/typing/printtyp.ml create mode 100644 upstream/ocaml_502/typing/printtyp.mli create mode 100644 upstream/ocaml_502/typing/printtyped.ml create mode 100644 upstream/ocaml_502/typing/printtyped.mli create mode 100644 upstream/ocaml_502/typing/shape.ml create mode 100644 upstream/ocaml_502/typing/shape.mli create mode 100644 upstream/ocaml_502/typing/shape_reduce.ml create mode 100644 upstream/ocaml_502/typing/shape_reduce.mli create mode 100644 upstream/ocaml_502/typing/signature_group.ml create mode 100644 upstream/ocaml_502/typing/signature_group.mli create mode 100644 upstream/ocaml_502/typing/stypes.ml create mode 100644 upstream/ocaml_502/typing/stypes.mli create mode 100644 upstream/ocaml_502/typing/subst.ml create mode 100644 upstream/ocaml_502/typing/subst.mli create mode 100644 upstream/ocaml_502/typing/tast_iterator.ml create mode 100644 upstream/ocaml_502/typing/tast_iterator.mli create mode 100644 upstream/ocaml_502/typing/tast_mapper.ml create mode 100644 upstream/ocaml_502/typing/tast_mapper.mli create mode 100644 upstream/ocaml_502/typing/type_immediacy.ml create mode 100644 upstream/ocaml_502/typing/type_immediacy.mli create mode 100644 upstream/ocaml_502/typing/typeclass.ml create mode 100644 upstream/ocaml_502/typing/typeclass.mli create mode 100644 upstream/ocaml_502/typing/typecore.ml create mode 100644 upstream/ocaml_502/typing/typecore.mli create mode 100644 upstream/ocaml_502/typing/typedecl.ml create mode 100644 upstream/ocaml_502/typing/typedecl.mli create mode 100644 upstream/ocaml_502/typing/typedecl_immediacy.ml create mode 100644 upstream/ocaml_502/typing/typedecl_immediacy.mli create mode 100644 upstream/ocaml_502/typing/typedecl_properties.ml create mode 100644 upstream/ocaml_502/typing/typedecl_properties.mli create mode 100644 upstream/ocaml_502/typing/typedecl_separability.ml create mode 100644 upstream/ocaml_502/typing/typedecl_separability.mli create mode 100644 upstream/ocaml_502/typing/typedecl_unboxed.ml create mode 100644 upstream/ocaml_502/typing/typedecl_unboxed.mli create mode 100644 upstream/ocaml_502/typing/typedecl_variance.ml create mode 100644 upstream/ocaml_502/typing/typedecl_variance.mli create mode 100644 upstream/ocaml_502/typing/typedtree.ml create mode 100644 upstream/ocaml_502/typing/typedtree.mli create mode 100644 upstream/ocaml_502/typing/typemod.ml create mode 100644 upstream/ocaml_502/typing/typemod.mli create mode 100644 upstream/ocaml_502/typing/typeopt.ml create mode 100644 upstream/ocaml_502/typing/typeopt.mli create mode 100644 upstream/ocaml_502/typing/types.ml create mode 100644 upstream/ocaml_502/typing/types.mli create mode 100644 upstream/ocaml_502/typing/typetexp.ml create mode 100644 upstream/ocaml_502/typing/typetexp.mli create mode 100644 upstream/ocaml_502/typing/untypeast.ml create mode 100644 upstream/ocaml_502/typing/untypeast.mli create mode 100644 upstream/ocaml_502/typing/value_rec_check.ml create mode 100644 upstream/ocaml_502/typing/value_rec_check.mli create mode 100644 upstream/ocaml_502/typing/value_rec_types.mli create mode 100644 upstream/ocaml_502/utils/arg_helper.ml create mode 100644 upstream/ocaml_502/utils/arg_helper.mli create mode 100644 upstream/ocaml_502/utils/binutils.ml create mode 100644 upstream/ocaml_502/utils/binutils.mli create mode 100644 upstream/ocaml_502/utils/build_path_prefix_map.ml create mode 100644 upstream/ocaml_502/utils/build_path_prefix_map.mli create mode 100644 upstream/ocaml_502/utils/ccomp.ml create mode 100644 upstream/ocaml_502/utils/ccomp.mli create mode 100644 upstream/ocaml_502/utils/clflags.ml create mode 100644 upstream/ocaml_502/utils/clflags.mli create mode 100644 upstream/ocaml_502/utils/config.fixed.ml create mode 100644 upstream/ocaml_502/utils/config.mli create mode 100644 upstream/ocaml_502/utils/consistbl.ml create mode 100644 upstream/ocaml_502/utils/consistbl.mli create mode 100644 upstream/ocaml_502/utils/diffing.ml create mode 100644 upstream/ocaml_502/utils/diffing.mli create mode 100644 upstream/ocaml_502/utils/diffing_with_keys.ml create mode 100644 upstream/ocaml_502/utils/diffing_with_keys.mli create mode 100644 upstream/ocaml_502/utils/identifiable.ml create mode 100644 upstream/ocaml_502/utils/identifiable.mli create mode 100644 upstream/ocaml_502/utils/int_replace_polymorphic_compare.ml create mode 100644 upstream/ocaml_502/utils/int_replace_polymorphic_compare.mli create mode 100644 upstream/ocaml_502/utils/lazy_backtrack.ml create mode 100644 upstream/ocaml_502/utils/lazy_backtrack.mli create mode 100644 upstream/ocaml_502/utils/load_path.ml create mode 100644 upstream/ocaml_502/utils/load_path.mli create mode 100644 upstream/ocaml_502/utils/local_store.ml create mode 100644 upstream/ocaml_502/utils/local_store.mli create mode 100644 upstream/ocaml_502/utils/misc.ml create mode 100644 upstream/ocaml_502/utils/misc.mli create mode 100644 upstream/ocaml_502/utils/numbers.ml create mode 100644 upstream/ocaml_502/utils/numbers.mli create mode 100644 upstream/ocaml_502/utils/profile.ml create mode 100644 upstream/ocaml_502/utils/profile.mli create mode 100644 upstream/ocaml_502/utils/strongly_connected_components.ml create mode 100644 upstream/ocaml_502/utils/strongly_connected_components.mli create mode 100644 upstream/ocaml_502/utils/targetint.ml create mode 100644 upstream/ocaml_502/utils/targetint.mli create mode 100644 upstream/ocaml_502/utils/terminfo.ml create mode 100644 upstream/ocaml_502/utils/terminfo.mli create mode 100644 upstream/ocaml_502/utils/warnings.ml create mode 100644 upstream/ocaml_502/utils/warnings.mli diff --git a/upstream/ocaml_502/base-rev.txt b/upstream/ocaml_502/base-rev.txt new file mode 100644 index 0000000000..b7ed60003b --- /dev/null +++ b/upstream/ocaml_502/base-rev.txt @@ -0,0 +1 @@ +02b39701d81ef4d4f5824a2d018e6387b1eeb5a7 diff --git a/upstream/ocaml_502/file_formats/cmi_format.ml b/upstream/ocaml_502/file_formats/cmi_format.ml new file mode 100644 index 0000000000..f4d19fa0ee --- /dev/null +++ b/upstream/ocaml_502/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 + +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; + Marshal.(to_channel oc ((cmi.cmi_name, cmi.cmi_sign) : header) [Compression]); + 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 +module Style = Misc.Style + +let report_error ppf = function + | Not_an_interface filename -> + fprintf ppf "%a@ is not a compiled interface" + (Style.as_inline_code 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." + (Style.as_inline_code Location.print_filename) filename older_newer + | Corrupted_interface filename -> + fprintf ppf "Corrupted compiled interface@ %a" + (Style.as_inline_code 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_502/file_formats/cmi_format.mli b/upstream/ocaml_502/file_formats/cmi_format.mli new file mode 100644 index 0000000000..2a63deb3dc --- /dev/null +++ b/upstream/ocaml_502/file_formats/cmi_format.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* 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 + +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_502/file_formats/cmt_format.ml b/upstream/ocaml_502/file_formats/cmt_format.ml new file mode 100644 index 0000000000..65f2494c6f --- /dev/null +++ b/upstream/ocaml_502/file_formats/cmt_format.ml @@ -0,0 +1,483 @@ +(**************************************************************************) +(* *) +(* 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 : Load_path.paths; + 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; + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; + cmt_impl_shape : Shape.t option; (* None for mli *) + cmt_ident_occurrences : + (Longident.t Location.loc * Shape_reduce.result) list +} + +type error = + Not_a_typedtree of string + +let iter_on_parts (it : Tast_iterator.iterator) = function + | Partial_structure s -> it.structure it s + | Partial_structure_item s -> it.structure_item it s + | Partial_expression e -> it.expr it e + | Partial_pattern (_category, p) -> it.pat it p + | Partial_class_expr ce -> it.class_expr it ce + | Partial_signature s -> it.signature it s + | Partial_signature_item s -> it.signature_item it s + | Partial_module_type s -> it.module_type it s + +let iter_on_annots (it : Tast_iterator.iterator) = function + | Implementation s -> it.structure it s + | Interface s -> it.signature it s + | Packed _ -> () + | Partial_implementation array -> Array.iter (iter_on_parts it) array + | Partial_interface array -> Array.iter (iter_on_parts it) array + +let iter_on_declaration f decl = + match decl with + | Value vd -> f vd.val_val.val_uid decl; + | Value_binding vb -> + let bound_idents = let_bound_idents_full [vb] in + List.iter (fun (_, _, _, uid) -> f uid decl) bound_idents + | Type td -> + if not (Btype.is_row_name (Ident.name td.typ_id)) then + f td.typ_type.type_uid (Type td) + | Constructor cd -> f cd.cd_uid decl + | Extension_constructor ec -> f ec.ext_type.ext_uid decl; + | Label ld -> f ld.ld_uid decl + | Module md -> f md.md_uid decl + | Module_type mtd -> f mtd.mtd_uid decl + | Module_substitution ms -> f ms.ms_uid decl + | Module_binding mb -> f mb.mb_uid decl + | Class cd -> f cd.ci_decl.cty_uid decl + | Class_type ct -> f ct.ci_decl.cty_uid decl + +let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) = { + Tast_iterator.default_iterator with + item_declaration = (fun _sub decl -> iter_on_declaration f decl); +} + +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 + +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 + +(* Every typedtree node with a located longident corresponding to user-facing + syntax should be indexed. *) +let iter_on_occurrences + ~(f : namespace:Shape.Sig_component_kind.t -> + Env.t -> Path.t -> Longident.t Location.loc -> + unit) = + let path_in_type typ name = + match Types.get_desc typ with + | Tconstr (type_path, _, _) -> + Some (Path.Pdot (type_path, name)) + | _ -> None + in + let add_constructor_description env lid = + function + | { Types.cstr_tag = Cstr_extension (path, _); _ } -> + f ~namespace:Extension_constructor env path lid + | { Types.cstr_uid = Predef name; _} -> + let id = List.assoc name Predef.builtin_idents in + f ~namespace:Constructor env (Pident id) lid + | { Types.cstr_res; cstr_name; _ } -> + let path = path_in_type cstr_res cstr_name in + Option.iter (fun path -> f ~namespace:Constructor env path lid) path + in + let add_label env lid { Types.lbl_name; lbl_res; _ } = + let path = path_in_type lbl_res lbl_name in + Option.iter (fun path -> f ~namespace:Label env path lid) path + in + let with_constraint ~env (_path, _lid, with_constraint) = + match with_constraint with + | Twith_module (path', lid') | Twith_modsubst (path', lid') -> + f ~namespace:Module env path' lid' + | _ -> () + in + Tast_iterator.{ default_iterator with + + expr = (fun sub ({ exp_desc; exp_env; _ } as e) -> + (match exp_desc with + | Texp_ident (path, lid, _) -> + f ~namespace:Value exp_env path lid + | Texp_construct (lid, constr_desc, _) -> + add_constructor_description exp_env lid constr_desc + | Texp_field (_, lid, label_desc) + | Texp_setfield (_, lid, label_desc, _) -> + add_label exp_env lid label_desc + | Texp_new (path, lid, _) -> + f ~namespace:Class exp_env path lid + | Texp_record { fields; _ } -> + Array.iter (fun (label_descr, record_label_definition) -> + match record_label_definition with + | Overridden ( + { Location.txt; loc}, + {exp_loc; _}) + when not exp_loc.loc_ghost + && loc.loc_start = exp_loc.loc_start + && loc.loc_end = exp_loc.loc_end -> + (* In the presence of punning we want to index the label + even if it is ghosted *) + let lid = { Location.txt; loc = {loc with loc_ghost = false} } in + add_label exp_env lid label_descr + | Overridden (lid, _) -> add_label exp_env lid label_descr + | Kept _ -> ()) fields + | Texp_instvar (_self_path, path, name) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env path lid + | Texp_setinstvar (_self_path, path, name, _) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env path lid + | Texp_override (_self_path, modifs) -> + List.iter (fun (id, (name : string Location.loc), _exp) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env (Path.Pident id) lid) + modifs + | Texp_extension_constructor (lid, path) -> + f ~namespace:Extension_constructor exp_env path lid + | Texp_constant _ | Texp_let _ | Texp_function _ | Texp_apply _ + | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_variant _ | Texp_array _ + | Texp_ifthenelse _ | Texp_sequence _ | Texp_while _ | Texp_for _ + | Texp_send _ + | Texp_letmodule _ | Texp_letexception _ | Texp_assert _ | Texp_lazy _ + | Texp_object _ | Texp_pack _ | Texp_letop _ | Texp_unreachable + | Texp_open _ -> ()); + default_iterator.expr sub e); + + (* Remark: some types get iterated over twice due to how constraints are + encoded in the typedtree. For example, in [let x : t = 42], [t] is + present in both a [Tpat_constraint] and a [Texp_constraint] node) *) + typ = + (fun sub ({ ctyp_desc; ctyp_env; _ } as ct) -> + (match ctyp_desc with + | Ttyp_constr (path, lid, _ctyps) -> + f ~namespace:Type ctyp_env path lid + | Ttyp_package {pack_path; pack_txt} -> + f ~namespace:Module_type ctyp_env pack_path pack_txt + | Ttyp_class (path, lid, _typs) -> + (* Deprecated syntax to extend a polymorphic variant *) + f ~namespace:Type ctyp_env path lid + | Ttyp_open (path, lid, _ct) -> + f ~namespace:Module ctyp_env path lid + | Ttyp_any | Ttyp_var _ | Ttyp_arrow _ | Ttyp_tuple _ | Ttyp_object _ + | Ttyp_alias _ | Ttyp_variant _ | Ttyp_poly _ -> ()); + default_iterator.typ sub ct); + + pat = + (fun (type a) sub + ({ pat_desc; pat_extra; pat_env; _ } as pat : a general_pattern) -> + (match pat_desc with + | Tpat_construct (lid, constr_desc, _, _) -> + add_constructor_description pat_env lid constr_desc + | Tpat_record (fields, _) -> + List.iter (fun (lid, label_descr, pat) -> + let lid = + let open Location in + (* In the presence of punning we want to index the label + even if it is ghosted *) + if (not pat.pat_loc.loc_ghost + && lid.loc.loc_start = pat.pat_loc.loc_start + && lid.loc.loc_end = pat.pat_loc.loc_end) + then {lid with loc = {lid.loc with loc_ghost = false}} + else lid + in + add_label pat_env lid label_descr) + fields + | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _ + | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _ + | Tpat_exception _ | Tpat_or _ -> ()); + List.iter (fun (pat_extra, _, _) -> + match pat_extra with + | Tpat_open (path, lid, _) -> + f ~namespace:Module pat_env path lid + | Tpat_type (path, lid) -> + f ~namespace:Type pat_env path lid + | Tpat_constraint _ | Tpat_unpack -> ()) + pat_extra; + default_iterator.pat sub pat); + + binding_op = (fun sub ({bop_op_path; bop_op_name; bop_exp; _} as bop) -> + let lid = { bop_op_name with txt = Longident.Lident bop_op_name.txt } in + f ~namespace:Value bop_exp.exp_env bop_op_path lid; + default_iterator.binding_op sub bop); + + module_expr = + (fun sub ({ mod_desc; mod_env; _ } as me) -> + (match mod_desc with + | Tmod_ident (path, lid) -> f ~namespace:Module mod_env path lid + | Tmod_structure _ | Tmod_functor _ | Tmod_apply _ | Tmod_apply_unit _ + | Tmod_constraint _ | Tmod_unpack _ -> ()); + default_iterator.module_expr sub me); + + open_description = + (fun sub ({ open_expr = (path, lid); open_env; _ } as od) -> + f ~namespace:Module open_env path lid; + default_iterator.open_description sub od); + + module_type = + (fun sub ({ mty_desc; mty_env; _ } as mty) -> + (match mty_desc with + | Tmty_ident (path, lid) -> + f ~namespace:Module_type mty_env path lid + | Tmty_with (_mty, l) -> + List.iter (with_constraint ~env:mty_env) l + | Tmty_alias (path, lid) -> + f ~namespace:Module mty_env path lid + | Tmty_signature _ | Tmty_functor _ | Tmty_typeof _ -> ()); + default_iterator.module_type sub mty); + + class_expr = + (fun sub ({ cl_desc; cl_env; _} as ce) -> + (match cl_desc with + | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid + | Tcl_structure _ | Tcl_fun _ | Tcl_apply _ | Tcl_let _ + | Tcl_constraint _ | Tcl_open _ -> ()); + default_iterator.class_expr sub ce); + + class_type = + (fun sub ({ cltyp_desc; cltyp_env; _} as ct) -> + (match cltyp_desc with + | Tcty_constr (path, lid, _) -> f ~namespace:Class_type cltyp_env path lid + | Tcty_signature _ | Tcty_arrow _ | Tcty_open _ -> ()); + default_iterator.class_type sub ct); + + signature_item = + (fun sub ({ sig_desc; sig_env; _ } as sig_item) -> + (match sig_desc with + | Tsig_exception { + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> + f ~namespace:Extension_constructor sig_env path lid + | Tsig_modsubst { ms_manifest; ms_txt } -> + f ~namespace:Module sig_env ms_manifest ms_txt + | Tsig_typext { tyext_path; tyext_txt } -> + f ~namespace:Type sig_env tyext_path tyext_txt + | Tsig_value _ | Tsig_type _ | Tsig_typesubst _ | Tsig_exception _ + | Tsig_module _ | Tsig_recmodule _ | Tsig_modtype _ | Tsig_modtypesubst _ + | Tsig_open _ | Tsig_include _ | Tsig_class _ | Tsig_class_type _ + | Tsig_attribute _ -> ()); + default_iterator.signature_item sub sig_item); + + structure_item = + (fun sub ({ str_desc; str_env; _ } as str_item) -> + (match str_desc with + | Tstr_exception { + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> + f ~namespace:Extension_constructor str_env path lid + | Tstr_typext { tyext_path; tyext_txt } -> + f ~namespace:Type str_env tyext_path tyext_txt + | Tstr_eval _ | Tstr_value _ | Tstr_primitive _ | Tstr_type _ + | Tstr_exception _ | Tstr_module _ | Tstr_recmodule _ + | Tstr_modtype _ | Tstr_open _ | Tstr_class _ | Tstr_class_type _ + | Tstr_include _ | Tstr_attribute _ -> ()); + default_iterator.structure_item sub str_item) +} + +let index_declarations binary_annots = + let index : item_declaration Types.Uid.Tbl.t = Types.Uid.Tbl.create 16 in + let f uid fragment = Types.Uid.Tbl.add index uid fragment in + iter_on_annots (iter_on_declarations ~f) binary_annots; + index + +let index_occurrences binary_annots = + let index : (Longident.t Location.loc * Shape_reduce.result) list ref = + ref [] + in + let f ~namespace env path lid = + let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in + if not_ghost lid then + match Env.shape_of_path ~namespace env path with + | exception Not_found -> () + | { uid = Some (Predef _); _ } -> () + | path_shape -> + let result = Shape_reduce.local_reduce_for_uid env path_shape in + index := (lid, result) :: !index + in + iter_on_annots (iter_on_occurrences ~f) binary_annots; + !index + +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; + Marshal.(to_channel oc (cmt : cmt_infos) [Compression]) + +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 target binary_annots initial_env cmi shape = + if !Clflags.binary_annotations && not !Clflags.print_types then begin + Misc.output_to_file_via_temporary + ~mode:[Open_binary] (Unit_info.Artifact.filename target) + (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 sourcefile = Unit_info.Artifact.source_file target in + let cmt_ident_occurrences = + if !Clflags.store_occurrences then + index_occurrences binary_annots + else + [] + in + let cmt_annots = clear_env binary_annots in + let cmt_uid_to_decl = index_declarations cmt_annots in + let source_digest = Option.map Digest.file sourcefile in + let cmt = { + cmt_modname = Unit_info.Artifact.modname target; + cmt_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; + cmt_uid_to_decl; + cmt_impl_shape = shape; + cmt_ident_occurrences; + } in + output_cmt oc cmt) + end; + clear () diff --git a/upstream/ocaml_502/file_formats/cmt_format.mli b/upstream/ocaml_502/file_formats/cmt_format.mli new file mode 100644 index 0000000000..d27f56bccb --- /dev/null +++ b/upstream/ocaml_502/file_formats/cmt_format.mli @@ -0,0 +1,125 @@ +(**************************************************************************) +(* *) +(* 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 infos\} \{\} + where is the cmi file format: + := . + More precisely, the optional 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 : Load_path.paths; + cmt_source_digest : string option; + cmt_initial_env : Env.t; + cmt_imports : crcs; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; + cmt_impl_shape : Shape.t option; (* None for mli *) + cmt_ident_occurrences : + (Longident.t Location.loc * Shape_reduce.result) list +} + +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 : + Unit_info.Artifact.t -> + binary_annots -> + Env.t -> (* initial env *) + Cmi_format.cmi_infos option -> (* if a .cmi was generated *) + Shape.t option -> + 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_502/parsing/ast_helper.ml b/upstream/ocaml_502/parsing/ast_helper.ml new file mode 100644 index 0000000000..bc18f41be4 --- /dev/null +++ b/upstream/ocaml_502/parsing/ast_helper.ml @@ -0,0 +1,648 @@ +(**************************************************************************) +(* *) +(* 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 open_ ?loc ?attrs mod_ident t = mk ?loc ?attrs (Ptyp_open (mod_ident, t)) + + 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, alias) -> + check_variable var_names alias.loc alias.txt; + Ptyp_alias(loop core_type, alias) + | 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_open (mod_ident, core_type) -> + Ptyp_open (mod_ident, loop core_type) + | 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 function_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_function (a, b, c)) + 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 apply_unit ?loc ?attrs m1 = mk ?loc ?attrs (Pmod_apply_unit m1) + 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 = []) ?value_constraint pat expr = + { + pvb_pat = pat; + pvb_expr = expr; + pvb_constraint=value_constraint; + 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) + ?(vars = []) ?(args = Pcstr_tuple []) ?res name = + { + pcd_name = name; + pcd_vars = vars; + 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) ?(vars = []) ?(args = Pcstr_tuple []) ?res name = + { + pext_name = name; + pext_kind = Pext_decl(vars, 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_502/parsing/ast_helper.mli b/upstream/ocaml_502/parsing/ast_helper.mli new file mode 100644 index 0000000000..7004144cbc --- /dev/null +++ b/upstream/ocaml_502/parsing/ast_helper.mli @@ -0,0 +1,499 @@ +(**************************************************************************) +(* *) +(* 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 with_loc + -> 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 open_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type -> 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 function_ : ?loc:loc -> ?attrs:attrs -> function_param list + -> type_constraint option -> function_body + -> 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 -> + ?vars:str list -> ?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 -> + ?vars:str list -> ?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 apply_unit: ?loc:loc -> ?attrs:attrs -> 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 -> + ?value_constraint:value_constraint -> 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_502/parsing/ast_invariants.ml b/upstream/ocaml_502/parsing/ast_invariants.ml new file mode 100644 index 0000000000..f69b6a45bb --- /dev/null +++ b/upstream/ocaml_502/parsing/ast_invariants.ml @@ -0,0 +1,210 @@ +(**************************************************************************) +(* *) +(* 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 function_without_value_parameters loc = + err loc "Function without any value parameters" + +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 + | Pexp_function (params, _, Pfunction_body _) -> + if + List.for_all + (function + | { pparam_desc = Pparam_newtype _ } -> true + | { pparam_desc = Pparam_val _ } -> false) + params + then function_without_value_parameters loc + | _ -> () + 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 + let attribute self attr = + (* The change to `self` here avoids registering attributes within attributes + for the purposes of warning 53, while keeping all the other invariant + checks for attribute payloads. See comment on [current_phase] in + [builtin_attributes.mli]. *) + super.attribute { self with attribute = super.attribute } attr; + Builtin_attributes.(register_attr Invariant_check attr.attr_name) + 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 + ; attribute + } + +let structure st = iterator.structure iterator st +let signature sg = iterator.signature iterator sg diff --git a/upstream/ocaml_502/parsing/ast_invariants.mli b/upstream/ocaml_502/parsing/ast_invariants.mli new file mode 100644 index 0000000000..fdb56aa5ef --- /dev/null +++ b/upstream/ocaml_502/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_502/parsing/ast_iterator.ml b/upstream/ocaml_502/parsing/ast_iterator.ml new file mode 100644 index 0000000000..94d5806fb3 --- /dev/null +++ b/upstream/ocaml_502/parsing/ast_iterator.ml @@ -0,0 +1,746 @@ +(**************************************************************************) +(* *) +(* 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; + directive_argument: iterator -> directive_argument -> 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; + toplevel_directive: iterator -> toplevel_directive -> unit; + toplevel_phrase: iterator -> toplevel_phrase -> 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_open (mod_ident, t) -> + iter_loc sub mod_ident; + sub.typ sub t + | 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(vars, ctl, cto) -> + List.iter (iter_loc sub) vars; + 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_apply_unit m1 -> + sub.module_expr sub m1 + | 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_function_param sub { pparam_loc = loc; pparam_desc = desc } = + sub.location sub loc; + match desc with + | Pparam_val (_lab, def, p) -> + iter_opt (sub.expr sub) def; + sub.pat sub p + | Pparam_newtype ty -> + iter_loc sub ty + + let iter_body sub body = + match body with + | Pfunction_body e -> + sub.expr sub e + | Pfunction_cases (cases, loc, attrs) -> + sub.cases sub cases; + sub.location sub loc; + sub.attributes sub attrs + + let iter_constraint sub constraint_ = + match constraint_ with + | Pconstraint ty -> + sub.typ sub ty + | Pcoerce (ty1, ty2) -> + iter_opt (sub.typ sub) ty1; + sub.typ sub ty2 + + 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_function (params, constraint_, body) -> + List.iter (iter_function_param sub) params; + iter_opt (iter_constraint sub) constraint_; + iter_body sub body + | 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; pvb_constraint} -> + this.pat this pvb_pat; + this.expr this pvb_expr; + Option.iter (function + | Parsetree.Pvc_constraint {locally_abstract_univars=vars; typ} -> + List.iter (iter_loc this) vars; + this.typ this typ + | Pvc_coercion { ground; coercion } -> + Option.iter (this.typ this) ground; + this.typ this coercion; + ) pvb_constraint; + this.location this pvb_loc; + this.attributes this pvb_attributes + ); + + + constructor_declaration = + (fun this {pcd_name; pcd_vars; pcd_args; + pcd_res; pcd_loc; pcd_attributes} -> + iter_loc this pcd_name; + List.iter (iter_loc this) pcd_vars; + 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 + ); + + directive_argument = + (fun this a -> + this.location this a.pdira_loc + ); + + toplevel_directive = + (fun this d -> + iter_loc this d.pdir_name; + iter_opt (this.directive_argument this) d.pdir_arg; + this.location this d.pdir_loc + ); + + toplevel_phrase = + (fun this -> function + | Ptop_def s -> this.structure this s + | Ptop_dir d -> this.toplevel_directive this d + ); + } diff --git a/upstream/ocaml_502/parsing/ast_iterator.mli b/upstream/ocaml_502/parsing/ast_iterator.mli new file mode 100644 index 0000000000..6b02889163 --- /dev/null +++ b/upstream/ocaml_502/parsing/ast_iterator.mli @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** {!Ast_iterator.iterator} enables AST inspection using open recursion. A + typical mapper would be based on {!Ast_iterator.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; + directive_argument: iterator -> directive_argument -> 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; + toplevel_directive: iterator -> toplevel_directive -> unit; + toplevel_phrase: iterator -> toplevel_phrase -> 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_502/parsing/ast_mapper.ml b/upstream/ocaml_502/parsing/ast_mapper.ml new file mode 100644 index 0000000000..204fec4641 --- /dev/null +++ b/upstream/ocaml_502/parsing/ast_mapper.ml @@ -0,0 +1,1170 @@ +(**************************************************************************) +(* *) +(* 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. *) +*) + +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + +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; + directive_argument: mapper -> directive_argument -> directive_argument; + 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; + toplevel_directive: mapper -> toplevel_directive -> toplevel_directive; + toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase; + 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) -> + let s = map_loc sub s in + 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_open (mod_ident, t) -> + open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t) + | 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(vars, ctl, cto) -> + Pext_decl(List.map (map_loc sub) vars, + 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_apply_unit m1 -> + apply_unit ~loc ~attrs (sub.module_expr sub m1) + | 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_function_param sub { pparam_loc = loc; pparam_desc = desc } = + let loc = sub.location sub loc in + let desc = + match desc with + | Pparam_val (lab, def, p) -> + Pparam_val + (lab, + map_opt (sub.expr sub) def, + sub.pat sub p) + | Pparam_newtype ty -> + Pparam_newtype (map_loc sub ty) + in + { pparam_loc = loc; pparam_desc = desc } + + let map_function_body sub body = + match body with + | Pfunction_body e -> + Pfunction_body (sub.expr sub e) + | Pfunction_cases (cases, loc, attributes) -> + let cases = sub.cases sub cases in + let loc = sub.location sub loc in + let attributes = sub.attributes sub attributes in + Pfunction_cases (cases, loc, attributes) + + let map_constraint sub c = + match c with + | Pconstraint ty -> Pconstraint (sub.typ sub ty) + | Pcoerce (ty1, ty2) -> Pcoerce (map_opt (sub.typ sub) ty1, sub.typ sub ty2) + + 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_function (ps, c, b) -> + function_ ~loc ~attrs + (List.map (map_function_param sub) ps) + (map_opt (map_constraint sub) c) + (map_function_body sub b) + | 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_constraint; pvb_attributes; pvb_loc} -> + let map_ct (ct:Parsetree.value_constraint) = match ct with + | Pvc_constraint {locally_abstract_univars=vars; typ} -> + Pvc_constraint + { locally_abstract_univars = List.map (map_loc this) vars; + typ = this.typ this typ + } + | Pvc_coercion { ground; coercion } -> + Pvc_coercion { + ground = Option.map (this.typ this) ground; + coercion = this.typ this coercion + } + in + Vb.mk + (this.pat this pvb_pat) + (this.expr this pvb_expr) + ?value_constraint:(Option.map map_ct pvb_constraint) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes) + ); + + + constructor_declaration = + (fun this {pcd_name; pcd_vars; pcd_args; + pcd_res; pcd_loc; pcd_attributes} -> + Type.constructor + (map_loc this pcd_name) + ~vars:(List.map (map_loc this) pcd_vars) + ~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) + ); + + directive_argument = + (fun this a -> + { pdira_desc= a.pdira_desc + ; pdira_loc= this.location this a.pdira_loc} ); + + toplevel_directive = + (fun this d -> + { pdir_name= map_loc this d.pdir_name + ; pdir_arg= map_opt (this.directive_argument this) d.pdir_arg + ; pdir_loc= this.location this d.pdir_loc } ); + + toplevel_phrase = + (fun this -> function + | Ptop_def s -> Ptop_def (this.structure this s) + | Ptop_dir d -> Ptop_dir (this.toplevel_directive this d) ); + } + +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 Load_path.{ visible; hidden } = Load_path.get_paths () in + let fields = + [ + lid "tool_name", make_string tool_name; + lid "include_dirs", make_list make_string (!Clflags.include_dirs); + lid "hidden_include_dirs", + make_list make_string (!Clflags.hidden_include_dirs); + lid "load_path", + make_pair (make_list make_string) (make_list make_string) + (visible, hidden); + 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 false; (* kept for compatibility *) + 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 + | "hidden_include_dirs" -> + Clflags.hidden_include_dirs := get_list get_string payload + | "load_path" -> + (* Duplicates Compmisc.auto_include, since we can't reference Compmisc + from this module. *) + let auto_include find_in_dir fn = + if !Clflags.no_std_include then + raise Not_found + else + let alert = Location.auto_include_alert in + Load_path.auto_include_otherlibs alert find_in_dir fn + in + let visible, hidden = + get_pair (get_list get_string) (get_list get_string) payload + in + Load_path.init ~auto_include ~visible ~hidden + | "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 + | "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] \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_502/parsing/ast_mapper.mli b/upstream/ocaml_502/parsing/ast_mapper.mli new file mode 100644 index 0000000000..541c1f7dac --- /dev/null +++ b/upstream/ocaml_502/parsing/ast_mapper.mli @@ -0,0 +1,211 @@ +(**************************************************************************) +(* *) +(* 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 (Pconst_integer ("42", None)) + | 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; + directive_argument: mapper -> directive_argument -> directive_argument; + 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; + toplevel_directive: mapper -> toplevel_directive -> toplevel_directive; + toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase; + 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}, + {!Clflags.hidden_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_502/parsing/asttypes.mli b/upstream/ocaml_502/parsing/asttypes.mli new file mode 100644 index 0000000000..7a4f1c1913 --- /dev/null +++ b/upstream/ocaml_502/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_502/parsing/attr_helper.ml b/upstream/ocaml_502/parsing/attr_helper.ml new file mode 100644 index 0000000000..390124199b --- /dev/null +++ b/upstream/ocaml_502/parsing/attr_helper.ml @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* 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 + +module Style = Misc.Style + +type error = + | Multiple_attributes of string + | No_payload_expected of string + +exception Error of Location.t * error + +let get_no_payload_attribute nm attrs = + let actions = [(nm, Builtin_attributes.Return)] in + match Builtin_attributes.select_attributes actions 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 %a attributes" Style.inline_code name + | No_payload_expected name -> + fprintf ppf "Attribute %a does not accept a payload" Style.inline_code 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_502/parsing/attr_helper.mli b/upstream/ocaml_502/parsing/attr_helper.mli new file mode 100644 index 0000000000..a94042a290 --- /dev/null +++ b/upstream/ocaml_502/parsing/attr_helper.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* 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] argument of the following functions is the name of the + attribute we are looking for. If the argument is ["foo"], these functions + will find attributes with the name ["foo"] or ["ocaml.foo"] *) +val get_no_payload_attribute : string -> attributes -> string loc option +val has_no_payload_attribute : string -> attributes -> bool + +exception Error of Location.t * error + +val report_error: Format.formatter -> error -> unit diff --git a/upstream/ocaml_502/parsing/builtin_attributes.ml b/upstream/ocaml_502/parsing/builtin_attributes.ml new file mode 100644 index 0000000000..9863d8a569 --- /dev/null +++ b/upstream/ocaml_502/parsing/builtin_attributes.ml @@ -0,0 +1,388 @@ +(**************************************************************************) +(* *) +(* 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 +open Ast_helper + + +module Attribute_table = Hashtbl.Make (struct + type t = string with_loc + + let hash : t -> int = Hashtbl.hash + let equal : t -> t -> bool = (=) +end) +let unused_attrs = Attribute_table.create 128 +let mark_used t = Attribute_table.remove unused_attrs t + +(* [attr_order] is used to issue unused attribute warnings in the order the + attributes occur in the file rather than the random order of the hash table +*) +let attr_order a1 a2 = + match String.compare a1.loc.loc_start.pos_fname a2.loc.loc_start.pos_fname + with + | 0 -> Int.compare a1.loc.loc_start.pos_cnum a2.loc.loc_start.pos_cnum + | n -> n + +let warn_unused () = + let keys = List.of_seq (Attribute_table.to_seq_keys unused_attrs) in + let keys = List.sort attr_order keys in + List.iter (fun sloc -> + Location.prerr_warning sloc.loc (Warnings.Misplaced_attribute sloc.txt)) + keys + +(* These are the attributes that are tracked in the builtin_attrs table for + misplaced attribute warnings. *) +let builtin_attrs = + [ "alert" + ; "boxed" + ; "deprecated" + ; "deprecated_mutable" + ; "explicit_arity" + ; "immediate" + ; "immediate64" + ; "inline" + ; "inlined" + ; "noalloc" + ; "poll" + ; "ppwarning" + ; "specialise" + ; "specialised" + ; "tailcall" + ; "tail_mod_cons" + ; "unboxed" + ; "untagged" + ; "unrolled" + ; "warnerror" + ; "warning" + ; "warn_on_literal_pattern" + ] + +let builtin_attrs = + let tbl = Hashtbl.create 128 in + List.iter (fun attr -> Hashtbl.add tbl attr ()) builtin_attrs; + tbl + +let drop_ocaml_attr_prefix s = + let len = String.length s in + if String.starts_with ~prefix:"ocaml." s && len > 6 then + String.sub s 6 (len - 6) + else + s + +let is_builtin_attr s = Hashtbl.mem builtin_attrs (drop_ocaml_attr_prefix s) + +type current_phase = Parser | Invariant_check + +let register_attr current_phase name = + match current_phase with + | Parser when !Clflags.all_ppx <> [] -> () + | Parser | Invariant_check -> + if is_builtin_attr name.txt then + Attribute_table.replace unused_attrs name () + +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 attr_equals_builtin {attr_name = {txt; _}; _} s = + (* Check for attribute s or ocaml.s. Avoid allocating a fresh string. *) + txt = s || + ( String.length txt = 6 + String.length s + && String.starts_with ~prefix:"ocaml." txt + && String.ends_with ~suffix:s txt) + +let mark_alert_used a = + if attr_equals_builtin a "deprecated" || attr_equals_builtin a "alert" + then mark_used a.attr_name + +let mark_alerts_used l = List.iter mark_alert_used l + +let mark_warn_on_literal_pattern_used l = + List.iter (fun a -> + if attr_equals_builtin a "warn_on_literal_pattern" + then mark_used a.attr_name) + l + +let mark_deprecated_mutable_used l = + List.iter (fun a -> + if attr_equals_builtin a "deprecated_mutable" + then mark_used a.attr_name) + l + +let mark_payload_attrs_used payload = + let iter = + { Ast_iterator.default_iterator + with attribute = fun self a -> + mark_used a.attr_name; + Ast_iterator.default_iterator.attribute self a + } + in + iter.payload iter payload + +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 = + if attr_equals_builtin x "deprecated" then + Some (x, "deprecated", string_of_opt_payload x.attr_payload) + else if attr_equals_builtin x "alert" then + 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 + else 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 :: _ when attr_equals_builtin attr "deprecated_mutable" -> + Some (string_of_opt_payload attr.attr_payload) + | _ :: 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 warn_payload loc txt msg = + Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)) + +let warning_attribute ?(ppwarning = true) = + let process loc name errflag payload = + mark_used name; + 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 name.txt msg + end + | None -> + warn_payload loc name.txt "A single string literal is expected" + in + let process_alert loc name = function + | PStr[{pstr_desc= + Pstr_eval( + {pexp_desc=Pexp_constant(Pconst_string(s,_,_))}, + _) + }] -> + begin + mark_used name; + try Warnings.parse_alert_option s + with Arg.Bad msg -> warn_payload loc name.txt msg + end + | k -> + (* Don't [mark_used] in the [Some] cases - that happens in [Env] or + [type_mod] if they are in a valid place. Do [mark_used] in the + [None] case, which is just malformed and covered by the "Invalid + payload" warning. *) + match kind_and_message k with + | Some ("all", _) -> + warn_payload loc name.txt "The alert name 'all' is reserved" + | Some _ -> () + | None -> begin + mark_used name; + warn_payload loc name.txt "Invalid payload" + end + in + fun ({attr_name; attr_loc; attr_payload} as attr) -> + if attr_equals_builtin attr "warning" then + process attr_loc attr_name false attr_payload + else if attr_equals_builtin attr "warnerror" then + process attr_loc attr_name true attr_payload + else if attr_equals_builtin attr "alert" then + process_alert attr_loc attr_name attr_payload + else if ppwarning && attr_equals_builtin attr "ppwarning" then + begin match attr_payload with + | PStr [{ pstr_desc= + Pstr_eval({pexp_desc=Pexp_constant + (Pconst_string (s, _, _))},_); + pstr_loc }] -> + (mark_used attr_name; + Location.prerr_warning pstr_loc (Warnings.Preprocessor s)) + | _ -> + (mark_used attr_name; + warn_payload attr_loc attr_name.txt + "A single string literal is expected") + end + +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 has_attribute nm attrs = + List.exists + (fun a -> + if attr_equals_builtin a nm + then (mark_used a.attr_name; true) + else false) + attrs + +type attr_action = Mark_used_only | Return +let select_attributes actions attrs = + List.filter (fun a -> + List.exists (fun (nm, action) -> + attr_equals_builtin a nm && + begin + mark_used a.attr_name; + action = Return + end) + actions + ) attrs + +let warn_on_literal_pattern attrs = + has_attribute "warn_on_literal_pattern" attrs + +let explicit_arity attrs = has_attribute "explicit_arity" attrs + +let immediate attrs = has_attribute "immediate" attrs + +let immediate64 attrs = has_attribute "immediate64" attrs + +(* 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 has_unboxed attrs = has_attribute "unboxed" attrs + +let has_boxed attrs = has_attribute "boxed" attrs diff --git a/upstream/ocaml_502/parsing/builtin_attributes.mli b/upstream/ocaml_502/parsing/builtin_attributes.mli new file mode 100644 index 0000000000..4eb5ef91f2 --- /dev/null +++ b/upstream/ocaml_502/parsing/builtin_attributes.mli @@ -0,0 +1,186 @@ +(**************************************************************************) +(* *) +(* 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 the builtin attributes: + + - ocaml.alert + - ocaml.boxed + - ocaml.deprecated + - ocaml.deprecated_mutable + - ocaml.explicit_arity + - ocaml.immediate + - ocaml.immediate64 + - ocaml.inline + - ocaml.inlined + - ocaml.noalloc + - ocaml.poll + - ocaml.ppwarning + - ocaml.specialise + - ocaml.specialised + - ocaml.tailcall + - ocaml.tail_mod_cons + - ocaml.unboxed + - ocaml.untagged + - ocaml.unrolled + - ocaml.warnerror + - ocaml.warning + - ocaml.warn_on_literal_pattern + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +(** {2 Attribute tracking for warning 53} *) + +(** [register_attr] must be called on the locations of all attributes that + should be tracked for the purpose of misplaced attribute warnings. In + particular, it should be called on all attributes that are present in the + source program except those that are contained in the payload of another + attribute (because these may be left behind by a ppx and intentionally + ignored by the compiler). + + The [current_phase] argument indicates when this function is being called + - either when an attribute is created in the parser or when we see an + attribute while running the check in the [Ast_invariants] module. This is + used to ensure that we track only attributes from the final version of the + parse tree: we skip adding attributes seen at parse time if we can see that + a ppx will be run later, because the [Ast_invariants] check is always run on + the result of a ppx. + + Note that the [Ast_invariants] check is also run on parse trees created from + marshalled ast files if no ppx is being used, ensuring we don't miss + attributes in that case. +*) +type current_phase = Parser | Invariant_check +val register_attr : current_phase -> string Location.loc -> unit + +(** Marks the attributes hiding in the payload of another attribute used, for + the purposes of misplaced attribute warnings (see comment on + [current_phase] above). In the parser, it's simplest to add these to + the table and remove them later, rather than threading through state + tracking whether we're in an attribute payload. *) +val mark_payload_attrs_used : Parsetree.payload -> unit + +(** Issue misplaced attribute warnings for all attributes created with + [mk_internal] but not yet marked used. *) +val warn_unused : unit -> unit + +(** {3 Warning 53 helpers for environment attributes} + + Some attributes, like deprecation markers, do not affect the compilation of + the definition on which they appear, but rather result in warnings on future + uses of that definition. This is implemented by moving the raw attributes + into the environment, where they will be noticed on future accesses. + + To make misplaced attribute warnings work appropriately for these + attributes, we mark them "used" when they are moved into the environment. + This is done with the helper functions in this section. +*) + +(** Marks the attribute used for the purposes of misplaced attribute warnings if + it is an alert. Call this when moving things allowed to have alert + attributes into the environment. *) +val mark_alert_used : Parsetree.attribute -> unit + +(** The same as [List.iter mark_alert_used]. *) +val mark_alerts_used : Parsetree.attributes -> unit + +(** Marks "warn_on_literal_pattern" attributes used for the purposes of + misplaced attribute warnings. Call this when moving constructors into the + environment. *) +val mark_warn_on_literal_pattern_used : Parsetree.attributes -> unit + +(** Marks "deprecated_mutable" attributes used for the purposes of misplaced + attribute warnings. Call this when moving labels of mutable fields into the + environment. *) +val mark_deprecated_mutable_used : Parsetree.attributes -> unit + +(** {2 Helpers for alert and warning attributes} *) + +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 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 marked used for warning 53. 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. + *) + +(** {2 Helpers for searching for particular attributes} *) + +(** [has_attribute name attrs] is true if an attribute with name [name] or + ["ocaml." ^ name] is present in [attrs]. It marks that attribute used for + the purposes of misplaced attribute warnings. *) +val has_attribute : string -> Parsetree.attributes -> bool + +(** [select_attributes actions attrs] finds the elements of [attrs] that appear + in [actions] and either returns them or just marks them used, according to + the corresponding [attr_action]. + + Each element [(nm, action)] of the [actions] list is an attribute along with + an [attr_action] specifying what to do with that attribute. The action is + used to accommodate different compiler configurations. If an attribute is + used only in some compiler configurations, it's important that we still look + for it and mark it used when compiling with other configurations. + Otherwise, we would issue spurious misplaced attribute warnings. *) +type attr_action = Mark_used_only | Return +val select_attributes : + (string * attr_action) list -> Parsetree.attributes -> Parsetree.attributes + +(** [attr_equals_builtin attr s] is true if the name of the attribute is [s] or + ["ocaml." ^ s]. This is useful for manually inspecting attribute names, but + note that doing so will not result in marking the attribute used for the + purpose of warning 53, so it is usually preferrable to use [has_attribute] + or [select_attributes]. *) +val attr_equals_builtin : Parsetree.attribute -> string -> bool + +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_502/parsing/depend.ml b/upstream/ocaml_502/parsing/depend.ml new file mode 100644 index 0000000000..7d76e6fc92 --- /dev/null +++ b/upstream/ocaml_502/parsing/depend.ml @@ -0,0 +1,631 @@ +(**************************************************************************) +(* *) +(* 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 + +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_open (mod_ident, t) -> + let bv = open_module bv mod_ident.txt in + add_type bv t + | 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_function (params, constraint_, body) -> + let bv = List.fold_left add_function_param bv params in + add_opt add_constraint bv constraint_; + add_function_body bv body + | 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_function_param bv param = + match param.pparam_desc with + | Pparam_val (_, opte, pat) -> + add_opt add_expr bv opte; + add_pattern bv pat + | Pparam_newtype _ -> bv + +and add_function_body bv body = + match body with + | Pfunction_body e -> + add_expr bv e + | Pfunction_cases (cases, _, _) -> + add_cases bv cases + +and add_constraint bv constraint_ = + match constraint_ with + | Pconstraint ty -> + add_type bv ty + | Pcoerce (ty1, ty2) -> + add_opt add_type bv ty1; + add_type bv ty2 + +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 + let add_constraint = function + | Pvc_constraint {locally_abstract_univars=_; typ} -> + add_type bv typ + | Pvc_coercion { ground; coercion } -> + Option.iter (add_type bv) ground; + add_type bv coercion + in + let add_one_binding { pvb_pat= _ ; pvb_loc= _ ; pvb_constraint; pvb_expr } = + add_expr bv pvb_expr; + Option.iter add_constraint pvb_constraint + in + List.iter add_one_binding 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_apply_unit mod1 -> + add_module_expr bv mod1 + | 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_502/parsing/depend.mli b/upstream/ocaml_502/parsing/depend.mli new file mode 100644 index 0000000000..745cc722c7 --- /dev/null +++ b/upstream/ocaml_502/parsing/depend.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* 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 + +(** Collect free module identifiers in the a.s.t. *) +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_502/parsing/docstrings.ml b/upstream/ocaml_502/parsing/docstrings.ml new file mode 100644 index 0000000000..a39f75d259 --- /dev/null +++ b/upstream/ocaml_502/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_502/parsing/docstrings.mli b/upstream/ocaml_502/parsing/docstrings.mli new file mode 100644 index 0000000000..bf2508fdc4 --- /dev/null +++ b/upstream/ocaml_502/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_502/parsing/lexer.mli b/upstream/ocaml_502/parsing/lexer.mli new file mode 100644 index 0000000000..756ee95992 --- /dev/null +++ b/upstream/ocaml_502/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 is_keyword : string -> 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_502/parsing/lexer.mll b/upstream/ocaml_502/parsing/lexer.mll new file mode 100644 index 0000000000..df87f9a3c3 --- /dev/null +++ b/upstream/ocaml_502/parsing/lexer.mll @@ -0,0 +1,907 @@ +(**************************************************************************) +(* *) +(* 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_substring s ~pos ~len = Buffer.add_substring string_buffer s pos len + +let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf) +let store_normalized_newline newline = + (* #12502: we normalize "\r\n" to "\n" at lexing time, + to avoid behavior difference due to OS-specific + newline characters in string literals. + + (For example, Git for Windows will translate \n in versioned + files into \r\n sequences when checking out files on Windows. If + your code contains multiline quoted string literals, the raw + content of the string literal would be different between Git for + Windows users and all other users. Thanks to newline + normalization, the value of the literal as a string constant will + be the same no matter which programming tools are used.) + + Many programming languages use the same approach, for example + Java, Javascript, Kotlin, Python, Swift and C++. + *) + (* Our 'newline' regexp accepts \r*\n, but we only wish + to normalize \r?\n into \n -- see the discussion in #12502. + All carriage returns except for the (optional) last one + are reproduced in the output. We implement this by skipping + the first carriage return, if any. *) + let len = String.length newline in + if len = 1 + then store_string_char '\n' + else store_substring newline ~pos:1 ~len:(len - 1) + +(* 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 + "%a is a keyword, it cannot be used as label name" Style.inline_code 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'] +let raw_ident_escape = "\\#" + +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")) } + | "~" raw_ident_escape (lowercase identchar * as name) ':' + { LABEL name } + | "~" (lowercase identchar * as name) ':' + { check_label_name lexbuf name; + LABEL name } + | "~" (lowercase_latin1 identchar_latin1 * as name) ':' + { warn_latin1 lexbuf; + LABEL name } + | "?" + { QUESTION } + | "?" raw_ident_escape (lowercase identchar * as name) ':' + { OPTLABEL name } + | "?" (lowercase identchar * as name) ':' + { check_label_name lexbuf name; + OPTLABEL name } + | "?" (lowercase_latin1 identchar_latin1 * as name) ':' + { warn_latin1 lexbuf; + OPTLABEL name } + | raw_ident_escape (lowercase identchar * as name) + { LIDENT 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 as nl) "\'" + { update_loc lexbuf None 1 false 1; + store_string_char '\''; + store_normalized_newline nl; + store_string_char '\''; + 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 as nl + { update_loc lexbuf None 1 false 0; + store_normalized_newline nl; + comment lexbuf + } + | ident + { store_lexeme lexbuf; comment lexbuf } + | _ + { store_lexeme lexbuf; comment lexbuf } + +and string = parse + '\"' + { lexbuf.lex_start_p } + | '\\' (newline as nl) ([' ' '\t'] * as space) + { update_loc lexbuf None 1 false (String.length space); + if in_comment () then begin + store_string_char '\\'; + store_normalized_newline nl; + store_string space; + end; + 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 as nl + { update_loc lexbuf None 1 false 0; + store_normalized_newline nl; + 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 as nl + { update_loc lexbuf None 1 false 0; + store_normalized_newline nl; + 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_502/parsing/location.ml b/upstream/ocaml_502/parsing/location.ml new file mode 100644 index 0000000000..d51a7f03b4 --- /dev/null +++ b/upstream/ocaml_502/parsing/location.ml @@ -0,0 +1,996 @@ +(**************************************************************************) +(* *) +(* 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 = Warnings.ghost_loc_in_file + +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. + + We also use for {!is_first_report}, see below. +*) +let num_loc_lines = ref 0 + +(* We use [num_loc_lines] to determine if the report about to be + printed is the first or a follow-up report of the current + "batch" -- contiguous reports without user input in between, for + example for the current toplevel phrase. We use this to print + a blank line between messages of the same batch. +*) +let is_first_message () = + !num_loc_lines = 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 + +(* This is used by the toplevel and the report printers below. *) +let separate_new_message ppf = + if not (is_first_message ()) then begin + Format.pp_print_newline ppf (); + incr num_loc_lines + end + +(* 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_tags () = + Misc.Style.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 rewrite_find_first_existing path = + match Misc.get_build_path_prefix_map () with + | None -> + if Sys.file_exists path then Some path + else None + | Some prefix_map -> + match Build_path_prefix_map.rewrite_all prefix_map path with + | [] -> + if Sys.file_exists path then Some path + else None + | matches -> + Some (List.find Sys.file_exists matches) + +let rewrite_find_all_existing_dirs path = + let ok path = Sys.file_exists path && Sys.is_directory path in + match Misc.get_build_path_prefix_map () with + | None -> + if ok path then [path] + else [] + | Some prefix_map -> + match Build_path_prefix_map.rewrite_all prefix_map path with + | [] -> + if ok path then [path] + else [] + | matches -> + match (List.filter ok matches) with + | [] -> raise Not_found + | results -> results + +let absolute_path s = (* This function could go into Filename *) + let open Filename in + let s = if (is_relative s) then (concat (Sys.getcwd ()) s) else s in + let s = rewrite_absolute_path 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_tags (); + 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 "@{"; + + 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 "@["; + 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) ""; + (* Iterate up to [rightmost], which can be larger than the length of + the line because we may point to a location after the end of the + last token on the line, for instance: + {[ + token + ^ + Did you forget ... + ]} *) + for i = 0 to rightmost.pos_cnum - line_start_cnum - 1 do + let pos = line_start_cnum + i in + 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 if i < String.length line then begin + (* For alignment purposes, align using a tab for each tab in the + source code *) + if line.[i] = '\t' then Format.pp_print_char ppf '\t' + else Format.pp_print_char ppf ' ' + end; + 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 + +(* Attempt to get lines from the lexing buffer. *) +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 + +(* A [get_lines] function for [highlight_quote] that reads from the current + input. *) +let lines_around_from_current_input ~start_pos ~end_pos = + match !input_lexbuf, !input_phrase_buffer, !input_name with + | _, Some pb, "//toplevel//" -> + lines_around_from_phrasebuf pb ~start_pos ~end_pos + | Some lb, _, _ -> + lines_around_from_lexbuf lb ~start_pos ~end_pos + | None, _, _ -> + [] + +(******************************************************************************) +(* 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 "@[%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_tags (); + separate_new_message ppf; + (* 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 "@[%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@}" + | Report_warning w -> Format.fprintf ppf "@{Warning@} %s" w + | Report_warning_as_error w -> + Format.fprintf ppf "@{Error@} (warning %s)" w + | Report_alert w -> Format.fprintf ppf "@{Alert@} %s" w + | Report_alert_as_error w -> + Format.fprintf ppf "@{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_tags (); + (* 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 + +module Style = Misc.Style + +let auto_include_alert lib = + let message = Format.asprintf "\ + OCaml's lib directory layout changed in 5.0. The %a subdirectory has been \ + automatically added to the search path, but you should add %a to the \ + command-line to silence this alert (e.g. by adding %a to the list of \ + libraries in your dune file, or adding %a to your %a file for \ + ocamlbuild, or using %a for ocamlfind)." + Style.inline_code lib + Style.inline_code ("-I +" ^lib) + Style.inline_code lib + Style.inline_code ("use_"^lib) + Style.inline_code "_tags" + Style.inline_code ("-package " ^ lib) in + let alert = + {Warnings.kind="ocaml_deprecated_auto_include"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + +let deprecated_script_alert program = + let message = Format.asprintf "\ + Running %a where the first argument is an implicit basename with no \ + extension (e.g. %a) is deprecated. Either rename the script \ + (%a) or qualify the basename (%a)" + Style.inline_code program + Style.inline_code (program ^ " script-file") + Style.inline_code (program ^ " script-file.ml") + Style.inline_code (program ^ " ./script-file") + in + let alert = + {Warnings.kind="ocaml_deprecated_cli"; use=none; def=none; + message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} + in + prerr_alert none alert + +(******************************************************************************) +(* 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_502/parsing/location.mli b/upstream/ocaml_502/parsing/location.mli new file mode 100644 index 0000000000..85bae4ff76 --- /dev/null +++ b/upstream/ocaml_502/parsing/location.mli @@ -0,0 +1,359 @@ +(**************************************************************************) +(* *) +(* 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 separate_new_message: formatter -> unit +val reset: unit -> unit + + +(** {1 Rewriting path } *) + +val rewrite_absolute_path: string -> string +(** [rewrite_absolute_path path] rewrites [path] to honor the + BUILD_PATH_PREFIX_MAP variable + if it is set. It does not check whether [path] is absolute or not. + The result is as follows: + - If BUILD_PATH_PREFIX_MAP is not set, just return [path]. + - otherwise, rewrite using the mapping (and if there are no + matching prefixes that will just return [path]). + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +val rewrite_find_first_existing: string -> string option +(** [rewrite_find_first_existing path] uses a BUILD_PATH_PREFIX_MAP mapping + and tries to find a source in mapping + that maps to a result that exists in the file system. + There are the following return values: + - [None], means either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [path] does not exists, or} + {- no source prefixes of [path] in the mapping were found,}} + - [Some target], means [target] exists and either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [target] = [path], or} + {- [target] is the first file (in priority + order) that [path] mapped to that exists in the file system.}} + - [Not_found] raised, means some source prefixes in the map + were found that matched [path], but none of them existed + in the file system. The caller should catch this and issue + an appropriate error message. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +val rewrite_find_all_existing_dirs: string -> string list +(** [rewrite_find_all_existing_dirs dir] accumulates a list of existing + directories, [dirs], that are the result of mapping a potentially + abstract directory, [dir], over all the mapping pairs in the + BUILD_PATH_PREFIX_MAP environment variable, if any. The list [dirs] + will be in priority order (head as highest priority). + + The possible results are: + - [[]], means either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [dir] is not an existing + directory, or} + {- if set, then there were no matching prefixes of [dir].}} + - [Some dirs], means dirs are the directories found. Either + {ul {- BUILD_PATH_PREFIX_MAP is not set and [dirs = [dir]], or} + {- it was set and [dirs] are the mapped existing directories.}} + - Not_found raised, means some source prefixes in the map + were found that matched [dir], but none of mapping results + were existing directories (possibly due to misconfiguration). + The caller should catch this and issue an appropriate error + message. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} + *) + +val absolute_path: string -> string + (** [absolute_path path] first makes an absolute path, [s] from [path], + prepending the current working directory if [path] was relative. + Then [s] is rewritten using [rewrite_absolute_path]. + Finally the result is normalized by eliminating instances of + ['.'] or ['..']. *) + +(** {1 Printing locations} *) + +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. *) + +val auto_include_alert: string -> unit +(** Prints an alert that -I +lib has been automatically added to the load + path *) + +val deprecated_script_alert: string -> unit +(** [deprecated_script_alert command] prints an alert that [command foo] has + been deprecated in favour of [command ./foo] *) + +(** {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_502/parsing/longident.ml b/upstream/ocaml_502/parsing/longident.ml new file mode 100644 index 0000000000..eaafb02bee --- /dev/null +++ b/upstream/ocaml_502/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_502/parsing/longident.mli b/upstream/ocaml_502/parsing/longident.mli new file mode 100644 index 0000000000..8704a7780e --- /dev/null +++ b/upstream/ocaml_502/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_502/parsing/parse.ml b/upstream/ocaml_502/parsing/parse.ml new file mode 100644 index 0000000000..c4e14013b1 --- /dev/null +++ b/upstream/ocaml_502/parsing/parse.ml @@ -0,0 +1,178 @@ +(**************************************************************************) +(* *) +(* 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 module_type = wrap Parser.parse_module_type +let module_expr = wrap Parser.parse_module_expr + +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 *) + +module Style = Misc.Style + +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 %a might be unmatched" Style.inline_code opening + ] + "Syntax error: %a expected" Style.inline_code closing + + | Expecting (loc, nonterm) -> + Location.errorf ~loc "Syntax error: %a expected." + Style.inline_code nonterm + | Not_expecting (loc, nonterm) -> + Location.errorf ~loc "Syntax error: %a not expected." + Style.inline_code nonterm + | Applicative_path loc -> + Location.errorf ~loc + "Syntax error: applicative paths of the form %a \ + are not supported when the option %a is set." + Style.inline_code "F(X).t" + Style.inline_code "-no-app-func" + | Variable_in_scope (loc, var) -> + Location.errorf ~loc + "In this scoped type, variable %a \ + is reserved for the local type %a." + (Style.as_inline_code Pprintast.tyvar) var + Style.inline_code 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, ipt) -> + let invalid ppf ipt = match ipt with + | Syntaxerr.Parameterized_types -> + Format.fprintf ppf "parametrized types are not supported" + | Constrained_types -> + Format.fprintf ppf "constrained types are not supported" + | Private_types -> + Format.fprintf ppf "private types are not supported" + | Not_with_type -> + Format.fprintf ppf "only %a constraints are supported" + Style.inline_code "with type t =" + | Neither_identifier_nor_with_type -> + Format.fprintf ppf + "only module type identifier and %a constraints are supported" + Style.inline_code "with type" + in + Location.errorf ~loc "invalid package type: %a" invalid ipt + | Removed_string_set loc -> + Location.errorf ~loc + "Syntax error: strings are immutable, there is no assignment \ + syntax for them.\n\ + @{Hint@}: Mutable sequences of bytes are available in \ + the Bytes module.\n\ + @{Hint@}: Did you mean to use %a?" + Style.inline_code "Bytes.set" +let () = + Location.register_error_of_exn + (function + | Syntaxerr.Error err -> Some (prepare_error err) + | _ -> None + ) diff --git a/upstream/ocaml_502/parsing/parse.mli b/upstream/ocaml_502/parsing/parse.mli new file mode 100644 index 0000000000..0de6b48a13 --- /dev/null +++ b/upstream/ocaml_502/parsing/parse.mli @@ -0,0 +1,110 @@ +(**************************************************************************) +(* *) +(* 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 +val module_type : Lexing.lexbuf -> Parsetree.module_type +val module_expr : Lexing.lexbuf -> Parsetree.module_expr + +(** 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_502/parsing/parser.mly b/upstream/ocaml_502/parsing/parser.mly new file mode 100644 index 0000000000..f5908b2ebd --- /dev/null +++ b/upstream/ocaml_502/parsing/parser.mly @@ -0,0 +1,4100 @@ +/**************************************************************************/ +/* */ +/* 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 "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + +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]) + +let mk_attr ~loc name payload = + Builtin_attributes.(register_attr Parser name); + Attr.mk ~loc name payload + +(* 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_desc_constraint e t = + match t with + | Pconstraint t -> Pexp_constraint(e, t) + | Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) + +let mkexp_constraint ~loc e t = + mkexp ~loc (mkexp_desc_constraint e t) + +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 removed_string_set loc = + raise(Syntaxerr.Error(Syntaxerr.Removed_string_set(make_loc loc))) + +(* 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, <>] ] + * [ 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 -> + if assign then removed_string_set loc + else 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 lid = + let lid = loc_map (fun id -> Lident (Longident.last id)) lid in + Exp.mk ~loc:lid.loc (Pexp_ident lid) + +let exp_of_label lbl = + Exp.mk ~loc:lbl.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_constraint: value_constraint option; + 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, typ, is_pun) attrs = + { + lb_pattern = p; + lb_expression = e; + lb_constraint=typ; + 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) + ?value_constraint:lb.lb_constraint 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 + ?value_constraint:lb.lb_constraint 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 + ?value_constraint:lb.lb_constraint 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)) + +(* If all the parameters are [Pparam_newtype x], then return [Some xs] where + [xs] is the corresponding list of values [x]. This function is optimized for + the common case, where a list of parameters contains at least one value + parameter. +*) +let all_params_as_newtypes = + let is_newtype { pparam_desc; _ } = + match pparam_desc with + | Pparam_newtype _ -> true + | Pparam_val _ -> false + in + let as_newtype { pparam_desc; pparam_loc } = + match pparam_desc with + | Pparam_newtype x -> Some (x, pparam_loc) + | Pparam_val _ -> None + in + fun params -> + if List.for_all is_newtype params + then Some (List.filter_map as_newtype params) + else None + +(* Given a construct [fun (type a b c) : t -> e], we construct + [Pexp_newtype(a, Pexp_newtype(b, Pexp_newtype(c, Pexp_constraint(e, t))))] + rather than a [Pexp_function]. +*) +let mkghost_newtype_function_body newtypes body_constraint body = + let wrapped_body = + match body_constraint with + | None -> body + | Some body_constraint -> + let loc = { body.pexp_loc with loc_ghost = true } in + Exp.mk (mkexp_desc_constraint body body_constraint) ~loc + in + let expr = + List.fold_right + (fun (newtype, newtype_loc) e -> + (* Mints a ghost location that approximates the newtype's "extent" as + being from the start of the newtype param until the end of the + function body. + *) + let loc = (newtype_loc.Location.loc_start, body.pexp_loc.loc_end) in + ghexp (Pexp_newtype (newtype, e)) ~loc) + newtypes + wrapped_body + in + expr.pexp_desc + +let mkfunction params body_constraint body = + match body with + | Pfunction_cases _ -> Pexp_function (params, body_constraint, body) + | Pfunction_body body_exp -> + (* If all the params are newtypes, then we don't create a function node; + we create nested newtype nodes. *) + match all_params_as_newtypes params with + | None -> Pexp_function (params, body_constraint, body) + | Some newtypes -> + mkghost_newtype_function_body newtypes body_constraint body_exp + +(* 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 Syntaxerr.Parameterized_types; + if ptyp.ptype_cstrs <> [] then + err loc Syntaxerr.Constrained_types; + if ptyp.ptype_private <> Public then + err loc Syntaxerr.Private_types; + + (* 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 Not_with_type + 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 Neither_identifier_nor_with_type + +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 "'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 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 INFIXOP0 "!=" (* just an example *) +%token INFIXOP1 "@" (* just an example *) +%token INFIXOP2 "+!" (* chosen with care; see above *) +%token INFIXOP3 "land" (* just an example *) +%token INFIXOP4 "**" (* just an example *) +%token DOTOP ".+" +%token LETOP "let*" (* just an example *) +%token ANDOP "and*" (* just an example *) +%token INHERIT "inherit" +%token INITIALIZER "initializer" +%token INT "42" (* just an example *) +%token 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 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 OPTLABEL "?label:" (* just an example *) +%token OR "or" +/* %token PARSER "parser" */ +%token PERCENT "%" +%token PLUS "+" +%token PLUSDOT "+." +%token PLUSEQ "+=" +%token 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 HASHOP "##" (* just an example *) +%token SIG "sig" +%token STAR "*" +%token + STRING "\"hello\"" (* just an example *) +%token + QUOTED_STRING_EXPR "{%hello|world|}" (* just an example *) +%token + 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 UIDENT "UIdent" (* just an example *) +%token UNDERSCORE "_" +%token VAL "val" +%token VIRTUAL "virtual" +%token WHEN "when" +%token WHILE "while" +%token WITH "with" +%token COMMENT "(* comment *)" +%token 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 OBJECT + 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 implementation +/* BEGIN AVOID */ +%start interface /* for interface files */ +%type interface +/* END AVOID */ +%start toplevel_phrase /* for interactive use */ +%type toplevel_phrase +%start use_file /* for the #use directive */ +%type use_file +/* BEGIN AVOID */ +%start parse_module_type +%type parse_module_type +%start parse_module_expr +%type parse_module_expr +%start parse_core_type +%type parse_core_type +%start parse_expression +%type parse_expression +%start parse_pattern +%type parse_pattern +%start parse_constr_longident +%type parse_constr_longident +%start parse_val_longident +%type parse_val_longident +%start parse_mty_longident +%type parse_mty_longident +%start parse_mod_ext_longident +%type parse_mod_ext_longident +%start parse_mod_longident +%type parse_mod_longident +%start parse_any_longident +%type 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_nonempty_concat(X)] recognizes a nonempty sequence of [X]s (each of + which is a list), and produces an OCaml list of their concatenation in + reverse order -- that is, the last element of the last list in the input text + appears first in the list. +*) +reversed_nonempty_concat(X): + x = X + { List.rev x } +| xs = reversed_nonempty_concat(X) x = X + { List.rev_append x xs } + +(* [nonempty_concat(X)] recognizes a nonempty sequence of [X]s + (each of which is a list), and produces an OCaml list of their concatenation + in direct order -- that is, the first element of the first list in the input + text appears first in the list. +*) + +%inline nonempty_concat(X): + xs = rev(reversed_nonempty_concat(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_module_type: + module_type EOF + { $1 } +; + +parse_module_expr: + module_expr EOF + { $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 } +; +/* 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) } + | SIG error + { expecting $loc($1) "struct" } + | 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) } + | (* Functor applied to unit. *) + me = module_expr LPAREN RPAREN + { Pmod_apply_unit me } + | (* 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 } + | COLON error + { expecting $loc($1) "=" } + | 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) } + | STRUCT error + { expecting $loc($1) "sig" } + | 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 } + | LPAREN RPAREN MINUSGREATER module_type + { Pmty_functor(Unit, $4) } + | 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 } + | EQUAL error + { expecting $loc($1) ":" } + | 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 */ + +%inline or_function(EXPR): + | EXPR + { $1 } + | FUNCTION ext_attributes match_cases + { let loc = make_loc $sloc in + let cases = $3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:$sloc desc $2 + } +; + +(* [fun_seq_expr] (and [fun_expr]) are legal expression bodies of a function. + [seq_expr] (and [expr]) are expressions that appear in other contexts + (e.g. subexpressions of the expression body of a function). + + [fun_seq_expr] can't be a bare [function _ -> ...]. [seq_expr] can. + + This distinction exists because [function _ -> ...] is parsed as a *function + cases* body of a function, not an expression body. This so functions can be + parsed with the intended arity. +*) +fun_seq_expr: + | fun_expr %prec below_SEMI { $1 } + | fun_expr SEMI { $1 } + | mkexp(fun_expr SEMI seq_expr + { Pexp_sequence($1, $3) }) + { $1 } + | fun_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)) } +; +seq_expr: + | or_function(fun_seq_expr) { $1 } +; +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 }; + +fun_expr: + simple_expr %prec below_HASH + { $1 } + | fun_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}) } + | fun_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 } + | fun_expr attribute + { Exp.attr $1 $2 } +/* BEGIN AVOID */ + | UNDERSCORE + { not_expecting $loc($1) "wildcard \"_\"" } +/* END AVOID */ +; +%inline expr: + | or_function(fun_expr) { $1 } +; +%inline fun_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 } + /* Cf #5939: we used to accept (fun p when e0 -> e) */ + | FUN ext_attributes fun_params preceded(COLON, atomic_type)? + MINUSGREATER fun_body + { let body_constraint = Option.map (fun x -> Pconstraint x) $4 in + mkfunction $3 body_constraint $6, $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_done_expr + { Pexp_while($3, $4), $2 } + | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr + do_done_expr + { Pexp_for($3, $5, $7, $6, $8), $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 } +; +%inline do_done_expr: + | DO e = seq_expr DONE + { e } + | DO seq_expr error + { unclosed "do" $loc($1) "done" $loc($2) } +; +%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 = fun_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) } + | OBJECT ext_attributes class_structure END + { Pexp_object $3, $2 } + | OBJECT ext_attributes class_structure error + { unclosed "object" $loc($1) "end" $loc($4) } +; +%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) } + | TILDE LPAREN label = LIDENT ty = type_constraint RPAREN + { (Labelled label, mkexp_constraint ~loc:($startpos($2), $endpos) + (mkexpvar ~loc:$loc(label) label) ty) } + | 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, None) } + | let_ident type_constraint EQUAL seq_expr + { let v = $1 in (* PR#7344 *) + let t = + match $2 with + Pconstraint t -> + Pvc_constraint { locally_abstract_univars = []; typ=t } + | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion} + in + (v, $4, Some t) + } + | let_ident COLON poly(core_type) EQUAL seq_expr + { + let t = ghtyp ~loc:($loc($3)) $3 in + ($1, $5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) + } + | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr + { let constraint' = + Pvc_constraint { locally_abstract_univars=$4; typ = $6} + in + ($1, $8, Some constraint') } + | pattern_no_exn EQUAL seq_expr + { ($1, $3, None) } + | simple_pattern_not_ident COLON core_type EQUAL seq_expr + { ($1, $5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=$3 })) } +; +let_binding_body: + | let_binding_body_no_punning + { let p,e,c = $1 in (p,e,c,false) } +/* BEGIN AVOID */ + | val_ident %prec below_HASH + { (mkpatvar ~loc:$loc $1, mkexpvar ~loc:$loc $1, None, 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 } +; +strict_binding: + EQUAL seq_expr + { $2 } + | fun_params type_constraint? EQUAL fun_body + { ghexp ~loc:$sloc (mkfunction $1 $2 $4) + } +; +fun_body: + | FUNCTION ext_attributes match_cases + { let ext, attrs = $2 in + match ext with + | None -> Pfunction_cases ($3, make_loc $sloc, attrs) + | Some _ -> + (* function%foo extension nodes interrupt the arity *) + let cases = Pfunction_cases ($3, make_loc $sloc, []) in + Pfunction_body + (mkexp_attrs ~loc:$sloc (mkfunction [] None cases) $2) + } + | fun_seq_expr + { Pfunction_body $1 } +; +%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_param_as_list: + | LPAREN TYPE ty_params = lident_list RPAREN + { (* We desugar (type a b c) to (type a) (type b) (type c). + If we do this desugaring, the loc for each parameter is a ghost. + *) + let loc = + match ty_params with + | [] -> assert false (* lident_list is non-empty *) + | [_] -> make_loc $sloc + | _ :: _ :: _ -> ghost_loc $sloc + in + List.map + (fun x -> { pparam_loc = loc; pparam_desc = Pparam_newtype x }) + ty_params + } + | labeled_simple_pattern + { let a, b, c = $1 in + [ { pparam_loc = make_loc $sloc; pparam_desc = Pparam_val (a, b, c) } ] + } +; +fun_params: + | nonempty_concat(fun_param_as_list) { $1 } +; +%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 constraint_loc, label, e = + match eo with + | None -> + (* No pattern; this is a pun. Desugar it. *) + $sloc, make_ghost label, exp_of_longident label + | Some e -> + ($startpos(c), $endpos), label, e + in + label, mkexp_opt_constraint ~loc:constraint_loc 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 label, e = + match oe with + | None -> + (* No expression; this is a pun. Desugar it. *) + make_ghost label, exp_of_label label + | Some e -> + label, e + in + label, e } +; +%inline expr_semi_list: + es = separated_or_terminated_nonempty_list(SEMI, expr) + { es } +; +type_constraint: + COLON core_type { Pconstraint $2 } + | COLON core_type COLONGREATER core_type { Pcoerce (Some $2, $4) } + | COLONGREATER core_type { Pcoerce (None, $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 constraint_loc, 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). *) + $sloc, make_ghost label, pat_of_label label + | Some pat -> + ($startpos(octy), $endpos), label, pat + in + label, mkpat_opt_constraint ~loc:constraint_loc pat octy + } +; + +/* Value descriptions */ + +value_description: + VAL + ext = ext + attrs1 = attributes + id = mkrhs(val_ident) + COLON + ty = possibly_poly(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 = possibly_poly(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) + vars_args_res = generalized_constructor_arguments + attrs = attributes + { + let vars, args, res = vars_args_res in + let info = symbol_info $endpos in + let loc = make_loc $sloc in + cid, vars, args, res, attrs, loc, info + } +; +%inline constructor_declaration(opening): + d = generic_constructor_declaration(opening) + { + let cid, vars, args, res, attrs, loc, info = d in + Type.constructor cid ~vars ~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) + vars_args_res = generalized_constructor_arguments + attrs2 = attributes + attrs = post_item_attributes + { let vars, args, res = vars_args_res in + let loc = make_loc ($startpos, $endpos(attrs2)) in + let docs = symbol_docs $sloc in + Te.mk_exception ~attrs + (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) + , ext } +; +%inline let_exception_declaration: + mkrhs(constr_ident) generalized_constructor_arguments attributes + { let vars, args, res = $2 in + Te.decl $1 ~vars ~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 typevar_list DOT constructor_arguments MINUSGREATER atomic_type + %prec below_HASH + { ($2,$4,Some $6) } + | COLON atomic_type %prec below_HASH + { ([],Pcstr_tuple [],Some $2) } + | COLON typevar_list DOT atomic_type %prec below_HASH + { ($2,Pcstr_tuple [],Some $4) } +; + +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, vars, args, res, attrs, loc, info = d in + Te.decl cid ~vars ~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 ident + { mkrhs $2 $sloc } +; +%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 tyvar = typevar + { 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] + *) + + +(* + Delimited types: + - parenthesised type (type) + - first-class module types (module S) + - object types < x: t; ... > + - variant types [ `A ] + - extension [%foo ...] + + We support local opens on the following classes of types: + - parenthesised + - first-class module types + - variant types + + Object types are not support for local opens due to a potential + conflict with MetaOCaml syntax: + M.< x: t, y: t > + and quoted expressions: + .< e >. + + Extension types are not support for local opens merely as a precaution. +*) +delimited_type_supporting_local_open: + | LPAREN type_ = core_type RPAREN + { type_ } + | LPAREN MODULE attrs = ext_attributes package_type = package_type RPAREN + { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc package_type) attrs } + | mktyp( + LBRACKET field = tag_field RBRACKET + { Ptyp_variant([ field ], Closed, None) } + | LBRACKET BAR fields = row_field_list RBRACKET + { Ptyp_variant(fields, Closed, None) } + | LBRACKET field = row_field BAR fields = row_field_list RBRACKET + { Ptyp_variant(field :: fields, Closed, None) } + | LBRACKETGREATER BAR? fields = row_field_list RBRACKET + { Ptyp_variant(fields, Open, None) } + | LBRACKETGREATER RBRACKET + { Ptyp_variant([], Open, None) } + | LBRACKETLESS BAR? fields = row_field_list RBRACKET + { Ptyp_variant(fields, Closed, Some []) } + | LBRACKETLESS BAR? fields = row_field_list + GREATER + tags = name_tag_list + RBRACKET + { Ptyp_variant(fields, Closed, Some tags) } + ) + { $1 } +; + +object_type: + | mktyp( + LESS meth_list = meth_list GREATER + { let (f, c) = meth_list in Ptyp_object (f, c) } + | LESS GREATER + { Ptyp_object ([], Closed) } + ) + { $1 } +; + +extension_type: + | mktyp ( + ext = extension + { Ptyp_extension ext } + ) + { $1 } +; + +delimited_type: + | object_type + | extension_type + | delimited_type_supporting_local_open + { $1 } +; + +atomic_type: + | type_ = delimited_type + { type_ } + | mktyp( /* begin mktyp group */ + tys = actual_type_parameters + tid = mkrhs(type_longident) + { Ptyp_constr (tid, tys) } + | tys = actual_type_parameters + HASH + cid = mkrhs(clty_longident) + { Ptyp_class (cid, tys) } + | mod_ident = mkrhs(mod_ext_longident) + DOT + type_ = delimited_type_supporting_local_open + { Ptyp_open (mod_ident, type_) } + | QUOTE ident = ident + { Ptyp_var ident } + | UNDERSCORE + { Ptyp_any } + ) + { $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 attr_payload RBRACKET + { mk_attr ~loc:(make_loc $sloc) $2 $3 } +; +post_item_attribute: + LBRACKETATAT attr_id attr_payload RBRACKET + { mk_attr ~loc:(make_loc $sloc) $2 $3 } +; +floating_attribute: + LBRACKETATATAT attr_id attr_payload RBRACKET + { mark_symbol_docs $sloc; + mk_attr ~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) } +; +attr_payload: + payload + { Builtin_attributes.mark_payload_attrs_used $1; + $1 + } +; +%% diff --git a/upstream/ocaml_502/parsing/parsetree.mli b/upstream/ocaml_502/parsing/parsetree.mli new file mode 100644 index 0000000000..2f0a40c26c --- /dev/null +++ b/upstream/ocaml_502/parsing/parsetree.mli @@ -0,0 +1,1119 @@ +(**************************************************************************) +(* *) +(* 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 + (** Integer constants such as [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 (** Character such as ['c']. *) + | Pconst_string of string * Location.t * string option + (** Constant string such as ["constant"] or + [{delim|other constant|delim}]. + + The location span the content of the string, without the delimiters. + *) + | Pconst_float of string * char option + (** Float constant such as [3.4], [2e5] or [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; + } +(** Attributes such as [[\@id ARG]] and [[\@\@id ARG]]. + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. + *) + +and extension = string loc * payload +(** Extension points such as [[%id ARG] and [%%id ARG]]. + + Sub-language placeholder -- rejected by the typechecker. + *) + +and attributes = attribute list + +and payload = + | PStr of structure + | PSig of signature (** [: SIG] in an attribute or an extension point *) + | PTyp of core_type (** [: T] in an attribute or an extension point *) + | PPat of pattern * expression option + (** [? P] or [? P when E], in an attribute or an extension point *) + +(** {1 Core language} *) +(** {2 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 type variable such as ['a] *) + | Ptyp_arrow of arg_label * core_type * core_type + (** [Ptyp_arrow(lbl, T1, T2)] represents: + - [T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Labelled}[Labelled]}, + - [?l:T1 -> T2] when [lbl] is + {{!Asttypes.arg_label.Optional}[Optional]}. + *) + | Ptyp_tuple of core_type list + (** [Ptyp_tuple([T1 ; ... ; Tn])] + represents a product type [T1 * ... * Tn]. + + Invariant: [n >= 2]. + *) + | Ptyp_constr of Longident.t loc * core_type list + (** [Ptyp_constr(lident, l)] represents: + - [tconstr] when [l=[]], + - [T tconstr] when [l=[T]], + - [(T1, ..., Tn) tconstr] when [l=[T1 ; ... ; Tn]]. + *) + | Ptyp_object of object_field list * closed_flag + (** [Ptyp_object([ l1:T1; ...; ln:Tn ], flag)] represents: + - [< l1:T1; ...; ln:Tn >] when [flag] is + {{!Asttypes.closed_flag.Closed}[Closed]}, + - [< l1:T1; ...; ln:Tn; .. >] when [flag] is + {{!Asttypes.closed_flag.Open}[Open]}. + *) + | Ptyp_class of Longident.t loc * core_type list + (** [Ptyp_class(tconstr, l)] represents: + - [#tconstr] when [l=[]], + - [T #tconstr] when [l=[T]], + - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. + *) + | Ptyp_alias of core_type * string loc (** [T as 'a]. *) + | Ptyp_variant of row_field list * closed_flag * label list option + (** [Ptyp_variant([`A;`B], flag, labels)] represents: + - [[ `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [None], + - [[> `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]}, + and [labels] is [None], + - [[< `A|`B ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [Some []], + - [[< `A|`B > `X `Y ]] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]}, + and [labels] is [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 + {{!pattern_desc.Ppat_constraint}[Ppat_constraint]} node corresponding + to a constraint on a let-binding: + {[let x : 'a1 ... 'an. T = e ...]} + + - Under {{!class_field_kind.Cfk_virtual}[Cfk_virtual]} for methods + (not values). + + - As the {!core_type} of a + {{!class_type_field_desc.Pctf_method}[Pctf_method]} node. + + - As the {!core_type} of a {{!expression_desc.Pexp_poly}[Pexp_poly]} + node. + + - As the {{!label_declaration.pld_type}[pld_type]} field of a + {!label_declaration}. + + - As a {!core_type} of a {{!core_type_desc.Ptyp_object}[Ptyp_object]} + node. + + - As the {{!value_description.pval_type}[pval_type]} field of a + {!value_description}. + *) + | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_open of Longident.t loc * core_type (** [M.(T)] *) + | Ptyp_extension of extension (** [[%id]]. *) + +and package_type = Longident.t loc * (Longident.t loc * core_type) list +(** As {!package_type} typed values: + - [(S, [])] represents [(module S)], + - [(S, [(t1, T1) ; ... ; (tn, Tn)])] + represents [(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 + (** [Rtag(`A, b, l)] represents: + - [`A] when [b] is [true] and [l] is [[]], + - [`A of T] when [b] is [false] and [l] is [[T]], + - [`A of T1 & .. & Tn] when [b] is [false] and [l] is [[T1;...Tn]], + - [`A of & T1 & .. & Tn] when [b] is [true] and [l] is [[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 + +(** {2 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 (** The pattern [_]. *) + | Ppat_var of string loc (** A variable pattern such as [x] *) + | Ppat_alias of pattern * string loc + (** An alias pattern such as [P as 'a] *) + | Ppat_constant of constant + (** Patterns such as [1], ['a'], ["true"], [1.0], [1l], [1L], [1n] *) + | Ppat_interval of constant * constant + (** Patterns such as ['a'..'z']. + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list + (** Patterns [(P1, ..., Pn)]. + + Invariant: [n >= 2] + *) + | Ppat_construct of Longident.t loc * (string loc list * pattern) option + (** [Ppat_construct(C, args)] represents: + - [C] when [args] is [None], + - [C P] when [args] is [Some ([], P)] + - [C (P1, ..., Pn)] when [args] is + [Some ([], Ppat_tuple [P1; ...; Pn])] + - [C (type a b) P] when [args] is [Some ([a; b], P)] + *) + | Ppat_variant of label * pattern option + (** [Ppat_variant(`A, pat)] represents: + - [`A] when [pat] is [None], + - [`A P] when [pat] is [Some P] + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (** [Ppat_record([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: + - [{ l1=P1; ...; ln=Pn }] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]} + - [{ l1=P1; ...; ln=Pn; _}] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]} + + Invariant: [n > 0] + *) + | Ppat_array of pattern list (** Pattern [[| P1; ...; Pn |]] *) + | Ppat_or of pattern * pattern (** Pattern [P1 | P2] *) + | Ppat_constraint of pattern * core_type (** Pattern [(P : T)] *) + | Ppat_type of Longident.t loc (** Pattern [#tconst] *) + | Ppat_lazy of pattern (** Pattern [lazy P] *) + | Ppat_unpack of string option loc + (** [Ppat_unpack(s)] represents: + - [(module P)] when [s] is [Some "P"] + - [(module _)] when [s] is [None] + + Note: [(module P : S)] is represented as + [Ppat_constraint(Ppat_unpack(Some "P"), Ptyp_package S)] + *) + | Ppat_exception of pattern (** Pattern [exception P] *) + | Ppat_extension of extension (** Pattern [[%id]] *) + | Ppat_open of Longident.t loc * pattern (** Pattern [M.(P)] *) + +(** {2 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 + (** Identifiers such as [x] and [M.x] + *) + | Pexp_constant of constant + (** Expressions constant such as [1], ['a'], ["true"], [1.0], [1l], + [1L], [1n] *) + | Pexp_let of rec_flag * value_binding list * expression + (** [Pexp_let(flag, [(P1,E1) ; ... ; (Pn,En)], E)] represents: + - [let P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in E] + when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. + *) + | Pexp_function of + function_param list * type_constraint option * function_body + (** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct + involving [fun] or [function], including: + - [fun P1 ... Pn -> E] + when [body = Pfunction_body E] + - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] + when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] + + [C] represents a type constraint or coercion placed immediately before the + arrow, e.g. [fun P1 ... Pn : ty -> ...] when [C = Some (Pconstraint ty)]. + + A function must have parameters. [Pexp_function (params, _, body)] must + have non-empty [params] or a [Pfunction_cases _] body. + *) + | Pexp_apply of expression * (arg_label * expression) list + (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] + represents [E0 ~l1:E1 ... ~ln:En] + + [li] can be + {{!Asttypes.arg_label.Nolabel}[Nolabel]} (non labeled argument), + {{!Asttypes.arg_label.Labelled}[Labelled]} (labelled arguments) or + {{!Asttypes.arg_label.Optional}[Optional]} (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 + (** Expressions [(E1, ..., En)] + + Invariant: [n >= 2] + *) + | Pexp_construct of Longident.t loc * expression option + (** [Pexp_construct(C, exp)] represents: + - [C] when [exp] is [None], + - [C E] when [exp] is [Some E], + - [C (E1, ..., En)] when [exp] is [Some (Pexp_tuple[E1;...;En])] + *) + | Pexp_variant of label * expression option + (** [Pexp_variant(`A, exp)] represents + - [`A] when [exp] is [None] + - [`A E] when [exp] is [Some E] + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (** [Pexp_record([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents + - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] + - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [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 + (** [Pexp_for(i, E1, E2, direction, E3)] represents: + - [for i = E1 to E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Upto}[Upto]} + - [for i = E1 downto E2 do E3 done] + when [direction] is {{!Asttypes.direction_flag.Downto}[Downto]} + *) + | Pexp_constraint of expression * core_type (** [(E : T)] *) + | Pexp_coerce of expression * core_type option * core_type + (** [Pexp_coerce(E, from, T)] represents + - [(E :> T)] when [from] is [None], + - [(E : T0 :> T)] when [from] is [Some T0]. + *) + | 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 + {{!class_field_kind.Cfk_concrete}[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 ME, 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 = E0 in E1] + - [let* P0 = E00 and* P1 = E01 in E1] *) + | Pexp_extension of extension (** [[%id]] *) + | Pexp_unreachable (** [.] *) + +and case = + { + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; + } +(** Values of type {!case} represents [(P -> E)] or [(P when E0 -> E)] *) + +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; + } + +and function_param_desc = + | Pparam_val of arg_label * expression option * pattern + (** [Pparam_val (lbl, exp0, P)] represents the parameter: + - [P] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [~l:P] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [?l:P] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [?l:(P = E0)] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Note: If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + *) + | Pparam_newtype of string loc + (** [Pparam_newtype x] represents the parameter [(type x)]. + [x] carries the location of the identifier, whereas the [pparam_loc] + on the enclosing [function_param] node is the location of the [(type x)] + as a whole. + + Multiple parameters [(type a b c)] are represented as multiple + [Pparam_newtype] nodes, let's say: + + {[ [ { pparam_kind = Pparam_newtype a; pparam_loc = loc1 }; + { pparam_kind = Pparam_newtype b; pparam_loc = loc2 }; + { pparam_kind = Pparam_newtype c; pparam_loc = loc3 }; + ] + ]} + + Here, the first loc [loc1] is the location of [(type a b c)], and the + subsequent locs [loc2] and [loc3] are the same as [loc1], except marked as + ghost locations. The locations on [a], [b], [c], correspond to the + variables [a], [b], and [c] in the source code. + *) + +and function_param = + { pparam_loc : Location.t; + pparam_desc : function_param_desc; + } + +and function_body = + | Pfunction_body of expression + | Pfunction_cases of case list * Location.t * attributes + (** In [Pfunction_cases (_, loc, attrs)], the location extends from the + start of the [function] keyword to the end of the last case. The compiler + will only use typechecking-related attributes from [attrs], e.g. enabling + or disabling a warning. + *) +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + +and type_constraint = + | Pconstraint of core_type + | Pcoerce of core_type option * core_type +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + +(** {2 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; + } +(** Values of type {!value_description} represents: + - [val x: T], + when {{!value_description.pval_prim}[pval_prim]} is [[]] + - [external x: T = "s1" ... "sn"] + when {{!value_description.pval_prim}[pval_prim]} is [["s1";..."sn"]] +*) + +(** {2 Type declarations} *) + +and type_declaration = + { + ptype_name: string loc; + ptype_params: (core_type * (variance * injectivity)) list; + (** [('a1,...'an) t] *) + ptype_cstrs: (core_type * core_type * Location.t) list; + (** [... constraint T1=T1' ... constraint Tn=Tn'] *) + ptype_kind: type_kind; + ptype_private: private_flag; (** for [= private ...] *) + ptype_manifest: core_type option; (** represents [= T] *) + ptype_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + ptype_loc: Location.t; + } +(** + Here are type declarations and their representation, + for various {{!type_declaration.ptype_kind}[ptype_kind]} + and {{!type_declaration.ptype_manifest}[ptype_manifest]} values: + - [type t] when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [None], + - [type t = T0] + when [type_kind] is {{!type_kind.Ptype_abstract}[Ptype_abstract]}, + and [manifest] is [Some T0], + - [type t = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [None], + - [type t = T0 = C of T | ...] + when [type_kind] is {{!type_kind.Ptype_variant}[Ptype_variant]}, + and [manifest] is [Some T0], + - [type t = {l: T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [None], + - [type t = T0 = {l : T; ...}] + when [type_kind] is {{!type_kind.Ptype_record}[Ptype_record]}, + and [manifest] is [Some T0], + - [type t = ..] + when [type_kind] is {{!type_kind.Ptype_open}[Ptype_open]}, + and [manifest] is [None]. +*) + +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; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Immutable}[Immutable]}, + - [{ ...; mutable l: T; ... }] + when {{!label_declaration.pld_mutable}[pld_mutable]} + is {{!Asttypes.mutable_flag.Mutable}[Mutable]}. + + Note: [T] can be a {{!core_type_desc.Ptyp_poly}[Ptyp_poly]}. +*) + +and constructor_declaration = + { + pcd_name: string loc; + pcd_vars: string loc list; + 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 + (** Values of type {!constructor_declaration} + represents the constructor arguments of: + - [C of T1 * ... * Tn] when [res = None], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C: T0] when [res = Some T0], + and [args = Pcstr_tuple []], + - [C: T1 * ... * Tn -> T0] when [res = Some T0], + and [args = Pcstr_tuple [T1; ... ; Tn]], + - [C of {...}] when [res = None], + and [args = Pcstr_record [...]], + - [C: {...} -> T0] when [res = Some T0], + and [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] *) + } +(** + Definition of new extensions constructors for the extensive sum type [t] + ([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]] *) + } + +and type_exception = + { + ptyexn_constructor : extension_constructor; + ptyexn_loc : Location.t; + ptyexn_attributes : attributes; (** [... [\@\@id1] [\@\@id2]] *) + } +(** Definition of a new exception ([exception E]). *) + +and extension_constructor_kind = + | Pext_decl of string loc list * constructor_arguments * core_type option + (** [Pext_decl(existentials, c_args, t_opt)] + describes a new extension constructor. It can be: + - [C of T1 * ... * Tn] when: + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [None]}.} + - [C: T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[]],} + {- [t_opt] is [Some T0].}} + - [C: T1 * ... * Tn -> T0] when + {ul {- [existentials] is [[]],} + {- [c_args] is [[T1; ...; Tn]],} + {- [t_opt] is [Some T0].}} + - [C: 'a... . T1 * ... * Tn -> T0] when + {ul {- [existentials] is [['a;...]],} + {- [c_args] is [[T1; ... ; Tn]],} + {- [t_opt] is [Some T0].}} + *) + | Pext_rebind of Longident.t loc + (** [Pext_rebind(D)] re-export the constructor [D] with the new name [C] *) + +(** {1 Class language} *) +(** {2 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 + (** [Pcty_arrow(lbl, T, CT)] represents: + - [T -> CT] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}, + - [~l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]}, + - [?l:T -> CT] + when [lbl] is {{!Asttypes.arg_label.Optional}[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; + } +(** Values of type [class_signature] represents: + - [object('selfpat) ... end] + - [object ... end] when {{!class_signature.pcsig_self}[pcsig_self]} + is {{!core_type_desc.Ptyp_any}[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 {{!core_type_desc.Ptyp_poly}[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]] *) + } +(** Values of type [class_expr class_infos] represents: + - [class c = ...] + - [class ['a1,...,'an] c = ...] + - [class virtual c = ...] + + They are also used for "class type" declaration. +*) + +and class_description = class_type class_infos + +and class_type_declaration = class_type class_infos + +(** {2 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] and [['a1, ..., 'an] c] *) + | Pcl_structure of class_structure (** [object ... end] *) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (** [Pcl_fun(lbl, exp0, P, CE)] represents: + - [fun P -> CE] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None], + - [fun ~l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None], + - [fun ?l:P -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None], + - [fun ?l:(P = E0) -> CE] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0]. + *) + | Pcl_apply of class_expr * (arg_label * expression) list + (** [Pcl_apply(CE, [(l1,E1) ; ... ; (ln,En)])] + represents [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 + (** [Pcl_let(rec, [(P1, E1); ... ; (Pn, En)], CE)] represents: + - [let P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN in CE] + when [rec] is {{!Asttypes.rec_flag.Recursive}[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; + } +(** Values of type {!class_structure} represents: + - [object(selfpat) ... end] + - [object ... end] when {{!class_structure.pcstr_self}[pcstr_self]} + is {{!pattern_desc.Ppat_any}[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 + (** [Pcf_inherit(flag, CE, s)] represents: + - [inherit CE] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [None], + - [inherit CE as x] + when [flag] is {{!Asttypes.override_flag.Fresh}[Fresh]} + and [s] is [Some x], + - [inherit! CE] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [None], + - [inherit! CE as x] + when [flag] is {{!Asttypes.override_flag.Override}[Override]} + and [s] is [Some x] + *) + | Pcf_val of (label loc * mutable_flag * class_field_kind) + (** [Pcf_val(x,flag, kind)] represents: + - [val x = E] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Immutable}[Immutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + - [val mutable x = E] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_concrete}[Cfk_concrete(Fresh, E)]} + - [val mutable virtual x: T] + when [flag] is {{!Asttypes.mutable_flag.Mutable}[Mutable]} + and [kind] is {{!class_field_kind.Cfk_virtual}[Cfk_virtual(T)]} + *) + | Pcf_method of (label loc * private_flag * class_field_kind) + (** - [method x = E] + ([E] can be a {{!expression_desc.Pexp_poly}[Pexp_poly]}) + - [method virtual x: T] + ([T] can be a {{!core_type_desc.Ptyp_poly}[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} *) +(** {2 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 (** [Pmty_ident(S)] represents [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 + (** [Named(name, MT)] represents: + - [(X : MT)] when [name] is [Some X], + - [(_ : MT)] when [name] is [None] *) + +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] and [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] and [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; + } +(** Values of type [module_declaration] represents [S : MT] *) + +and module_substitution = + { + pms_name: string loc; + pms_manifest: Longident.t loc; + pms_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pms_loc: Location.t; + } +(** Values of type [module_substitution] represents [S := M] *) + +and module_type_declaration = + { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pmtd_loc: Location.t; + } +(** Values of type [module_type_declaration] represents: + - [S = MT], + - [S] for abstract module type declaration, + when {{!module_type_declaration.pmtd_type}[pmtd_type]} is [None]. +*) + +and 'a open_infos = + { + popen_expr: 'a; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } +(** Values of type ['a open_infos] represents: + - [open! X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Override}[Override]} + (silences the "used identifier shadowing" warning) + - [open X] when {{!open_infos.popen_override}[popen_override]} + is {{!Asttypes.override_flag.Fresh}[Fresh]} +*) + +and open_description = Longident.t loc open_infos +(** Values of type [open_description] represents: + - [open M.N] + - [open M(N).O] *) + +and open_declaration = module_expr open_infos +(** Values of type [open_declaration] represents: + - [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 +(** Values of type [include_description] represents [include MT] *) + +and include_declaration = module_expr include_infos +(** Values of type [include_declaration] represents [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] *) + +(** {2 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_apply_unit of module_expr (** [ME1()] *) + | 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 + (** [Pstr_value(rec, [(P1, E1 ; ... ; (Pn, En))])] represents: + - [let P1 = E1 and ... and Pn = EN] + when [rec] is {{!Asttypes.rec_flag.Nonrecursive}[Nonrecursive]}, + - [let rec P1 = E1 and ... and Pn = EN ] + when [rec] is {{!Asttypes.rec_flag.Recursive}[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_constraint = + | Pvc_constraint of { + locally_abstract_univars:string loc list; + typ:core_type; + } + | Pvc_coercion of {ground:core_type option; coercion:core_type } + (** + - [Pvc_constraint { locally_abstract_univars=[]; typ}] + is a simple type constraint on a value binding: [ let x : typ] + - More generally, in [Pvc_constraint { locally_abstract_univars; typ}] + [locally_abstract_univars] is the list of locally abstract type + variables in [ let x: type a ... . typ ] + - [Pvc_coercion { ground=None; coercion }] represents [let x :> typ] + - [Pvc_coercion { ground=Some g; coercion }] represents [let x : g :> typ] + *) + +and value_binding = + { + pvb_pat: pattern; + pvb_expr: expression; + pvb_constraint: value_constraint option; + pvb_attributes: attributes; + pvb_loc: Location.t; + }(** [let pat : type_constraint = exp] *) + +and module_binding = + { + pmb_name: string option loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; + } +(** Values of type [module_binding] represents [module X = ME] *) + +(** {1 Toplevel} *) + +(** {2 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_502/parsing/pprintast.ml b/upstream/ocaml_502/parsing/pprintast.ml new file mode 100644 index 0000000000..d7fea80a7c --- /dev/null +++ b/upstream/ocaml_502/parsing/pprintast.ml @@ -0,0 +1,1751 @@ +(**************************************************************************) +(* *) +(* 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 + +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 + +(* Turn an arbitrary variable name into a valid OCaml identifier by adding \# + in case it is a keyword, or parenthesis when it is an infix or prefix + operator. *) +let ident_of_name ppf txt = + let format : (_, _, _) format = + if Lexer.is_keyword txt then "\\#%s" + else if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in fprintf ppf format txt + +let ident_of_name_loc ppf s = ident_of_name ppf s.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 + | `btrue + | `bfalse ] + +let view_expr x = + match x.pexp_desc with + | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple + | Pexp_construct ( {txt= Lident "true"; _},_) -> `btrue + | Pexp_construct ( {txt= Lident "false"; _},_) -> `bfalse + | 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 _ | `btrue | `bfalse -> true + | `cons _ | `normal -> false + +let pp = fprintf + +type ctxt = { + pipe : bool; + semi : bool; + ifthenelse : bool; + functionrhs : bool; +} + +let reset_ctxt = { pipe=false; semi=false; ifthenelse=false; functionrhs=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 under_functionrhs ctxt = { ctxt with functionrhs = 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 -> ident_of_name 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_of_name s = + if String.length s >= 2 && s.[1] = '\'' then + (* without the space, this would be parsed as + a character literal *) + "' " ^ s + else if Lexer.is_keyword s then + "'\\#" ^ s + else if String.equal s "_" then + s + else + "'" ^ s + +let tyvar ppf s = + Format.fprintf ppf "%s" (tyvar_of_name s) + +let tyvar_loc f str = tyvar f str.txt +let string_quot f x = pp f "`%a" ident_of_name 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 "%a:%a" ident_of_name s (core_type1 ctxt) c + | Optional s -> pp f "?%a:%a" ident_of_name 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.txt + | Ptyp_poly ([], ct) -> + core_type ctxt f ct + | Ptyp_poly (sl, ct) -> + pp f "@[<2>%a%a@]" + (fun f l -> match l with + | [] -> () + | _ -> + pp f "%a@;.@;" + (list tyvar_loc ~sep:"@;") 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 "@[%a: %a@ %a@ @]" ident_of_name l.txt + (core_type ctxt) ct (attributes ctxt) x.pof_attributes + | Oinherit ct -> + pp f "@[%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 "@[<@ %a%a@ > @]" + (list core_field_type ~sep:";") l + field_var o (* Cf #7200 *) + | Ptyp_class (li, l) -> (*FIXME*) + pp f "@[%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 "@[(module@ %a)@]" longident_loc lid + |_ -> + pp f "@[(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 ident_of_name 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 "@[%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>`%a@;%a@]" ident_of_name l (simple_pattern ctxt) p + | Ppat_construct (({txt=Lident("()"|"[]"|"true"|"false");_}), _) -> + 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:"@ " ident_of_name_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 ("()"|"[]"|"true"|"false" as x);_}), None) -> + pp f "%s" x + | Ppat_any -> pp f "_"; + | Ppat_var ({txt = txt;_}) -> ident_of_name 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 "`%a" ident_of_name 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 ("()"|"[]"|"true"|"false");_}), 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 "?(%a=@;%a)@;" ident_of_name rest (expression ctxt) o + | None -> pp f "?%a@ " ident_of_name rest) + | _ -> + (match opt with + | Some o -> + pp f "?%a:(%a=@;%a)@;" + ident_of_name rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%a:%a@;" ident_of_name rest (simple_pattern ctxt) p) + end + | Labelled l -> match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = l -> + pp f "~%a@;" ident_of_name l + | _ -> pp f "~%a:%a@;" ident_of_name 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 "@[!%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 function_param ctxt f param = + match param.pparam_desc with + | Pparam_val (a, b, c) -> label_exp ctxt f (a, b, c) + | Pparam_newtype ty -> pp f "(type %s)@;" ty.txt + +and function_body ctxt f function_body = + match function_body with + | Pfunction_body body -> expression ctxt f body + | Pfunction_cases (cases, _, attrs) -> + pp f "@[function%a%a@]" + (item_attributes ctxt) attrs + (case_list ctxt) cases + +and type_constraint ctxt f constraint_ = + match constraint_ with + | Pconstraint ty -> + pp f ":@;%a" (core_type ctxt) ty + | Pcoerce (ty1, ty2) -> + pp f "%a:>@;%a" + (option ~first:":@;" (core_type ctxt)) ty1 + (core_type ctxt) ty2 + +and function_params_then_body ctxt f params constraint_ body ~delimiter = + pp f "%a%a%s@;%a" + (list (function_param ctxt) ~sep:"") params + (option (type_constraint ctxt)) constraint_ + delimiter + (function_body (under_functionrhs ctxt)) body + +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_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_newtype (lid, e) -> + pp f "@[<2>fun@;(type@;%a)@;->@;%a@]" ident_of_name lid.txt + (expression ctxt) e + | Pexp_function (params, c, body) -> + begin match params, c with + (* Omit [fun] if there are no params. *) + | [], None -> + (* If function cases are a direct body of a function, + the function node should be wrapped in parens so + it doesn't become part of the enclosing function. *) + let should_paren = + match body with + | Pfunction_cases _ -> ctxt.functionrhs + | Pfunction_body _ -> false + in + let ctxt' = if should_paren then reset_ctxt else ctxt in + pp f "@[<2>%a@]" (paren should_paren (function_body ctxt')) body + | [], Some c -> + pp f "@[<2>(%a@;%a)@]" + (function_body ctxt) body + (type_constraint ctxt) c + | _ :: _, _ -> + pp f "@[<2>fun@;%a@]" + (fun f () -> + function_params_then_body ctxt f params c body ~delimiter:"->") + (); + + end + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + (expression reset_ctxt) e (case_list ctxt) l + + | Pexp_try (e, l) -> + pp f "@[<0>@[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 "@[%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 ="@[@[<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 "@[%a@]" + (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new (li) -> + pp f "@[new@ %a@]" longident_loc li; + | Pexp_setinstvar (s, e) -> + pp f "@[%a@ <-@ %a@]" ident_of_name s.txt (expression ctxt) e + | Pexp_override l -> (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%a@ =@ %a@]" ident_of_name s.txt (expression ctxt) e in + pp f "@[{<%a>}@]" + (list string_x_expression ~sep:";" ) l; + | Pexp_letmodule (s, me, e) -> + pp f "@[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 "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) cd + (expression ctxt) e + | Pexp_assert e -> + pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy (e) -> + pp f "@[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 "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!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>`%a@;%a@]" ident_of_name l (simple_expr ctxt) eo + | Pexp_letop {let_; ands; body} -> + pp f "@[<2>@[%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 "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> + pp f "@[%a#%a@]" (simple_expr ctxt) e ident_of_name 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 "()" + | `btrue -> pp f "true" + | `bfalse -> pp f "false" + | `list xs -> + pp f "@[[%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 "@[(%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 "`%a" ident_of_name 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 "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%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 = + "@[@[@[<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 "@[%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 "@[exception@ %a@]%a" + (extension_constructor ctxt) x.ptyexn_constructor + (item_attributes ctxt) x.ptyexn_attributes + +and class_type_field ctxt 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%a@ :@ %a@]%a" + mutable_flag mf virtual_flag vf + ident_of_name s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_method (s, pf, vf, ct) -> + pp f "@[<2>method %a %a%a :@;%a@]%a" + private_flag pf virtual_flag vf + ident_of_name 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 + +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = + pp f "@[@[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 ctxt) ~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%a@ =@ %a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls + ident_of_name 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 "@[%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 %a" ident_of_name s.txt ) so + (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> + pp f "@[<2>val%s %a%a =@;%a@]%a" (override ovf) + mutable_flag mf + ident_of_name s.txt + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_virtual ct) -> + pp f "@[<2>method virtual %a %a :@;%a@]%a" + private_flag pf + ident_of_name 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%a :@ %a@]%a" + mutable_flag mf + ident_of_name 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_constraint=None; + 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 "%a :@;%a=@;%a" + ident_of_name 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 "@[@[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 "@[() ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (Named (s, mt1), mt2) -> + begin match s.txt with + | None -> + pp f "@[%a@ ->@ %a@]" + (module_type1 ctxt) mt1 (module_type ctxt) mt2 + | Some name -> + pp f "@[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 "@[%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)) -> + pp f "type@ %a %a =@ %a" + (type_params ctxt) 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)) -> + pp f "type@ %a %a :=@ %a" + (type_params ctxt) 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 "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) s (* FIXME wrong indentation*) + | Pmty_typeof me -> + pp f "@[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 + ident_of_name 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%a@;:@;%a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls + ident_of_name 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 "@[%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 "@[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 "@[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 "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt + longident_loc pms.pms_manifest + (item_attributes ctxt) pms.pms_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_expr + (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[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 "@[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 "@[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 "@ @[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 "@[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 "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") s; + | Pmod_constraint (me, mt) -> + pp f "@[(%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_apply_unit me1 -> + pp f "(%a)()" (module_expr ctxt) me1 + | 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_constraint = ct; _} = + (* .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_function (params, c, body) -> + function_params_then_body ctxt f params c body ~delimiter:"=" + | Pexp_newtype (str,e) -> + pp f "(type@ %a)@ %a" ident_of_name str.txt pp_print_pexp_function e + | _ -> pp f "=@;%a" (expression ctxt) x + in + match ct with + | Some (Pvc_constraint { locally_abstract_univars = []; typ }) -> + pp f "%a@;:@;%a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) typ (expression ctxt) x + | Some (Pvc_constraint { locally_abstract_univars = vars; typ }) -> + pp f "%a@;: type@;%a.@;%a@;=@;%a" + (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") + (List.map (fun x -> x.txt) vars) + (core_type ctxt) typ (expression ctxt) x + | Some (Pvc_coercion {ground=None; coercion }) -> + pp f "%a@;:>@;%a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) coercion (expression ctxt) x + | Some (Pvc_coercion {ground=Some ground; coercion }) -> + pp f "%a@;:%a@;:>@;%a@;=@;%a" + (simple_pattern ctxt) p + (core_type ctxt) ground + (core_type ctxt) coercion + (expression ctxt) x + | None -> begin + match p with + | {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 "@[%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 "@[;;%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 "@[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 "@[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 "@[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%a %a%a=@;%a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls + ident_of_name 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 "@[%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 "@[external@ %a@ :@ %a@]%a" + ident_of_name vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Pstr_include incl -> + pp f "@[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 "@[@ 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 "@[@ 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 "@[@[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 "@[@[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%a%s%a@]%a" kwd + nonrec_flag rf + (type_params ctxt) x.ptype_params + ident_of_name 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 "@[%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%a:@;%a@;%a@]" + mutable_flag pld.pld_mutable + ident_of_name 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_vars, + 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 "@[@ 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, vars, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s in + let pp_vars f vs = + match vs with + | [] -> () + | vs -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") vs 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@;%a" name + pp_vars vars + (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(v, l, r) -> + constructor_declaration ctxt f + (x.pext_name.txt, v, 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 "?%a" ident_of_name str + else + pp f "?%a:%a" ident_of_name str (simple_expr ctxt) e + | Labelled lbl -> + if Some lbl = simple_name then + pp f "~%a" ident_of_name lbl + else + pp f "~%a:%a" ident_of_name 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 "@[%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 "@[#%s@]" pdir_name.txt + | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} -> + pp f "@[#%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 module_type = module_type reset_ctxt +let class_field = class_field reset_ctxt +let class_type_field = class_type_field reset_ctxt +let class_expr = class_expr reset_ctxt +let class_type = class_type reset_ctxt +let structure_item = structure_item reset_ctxt +let signature_item = signature_item reset_ctxt +let binding = binding reset_ctxt +let payload = payload reset_ctxt diff --git a/upstream/ocaml_502/parsing/pprintast.mli b/upstream/ocaml_502/parsing/pprintast.mli new file mode 100644 index 0000000000..bbb15fef6b --- /dev/null +++ b/upstream/ocaml_502/parsing/pprintast.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* 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 class_field: Format.formatter -> Parsetree.class_field -> unit +val class_type_field: Format.formatter -> Parsetree.class_type_field -> unit +val class_expr: Format.formatter -> Parsetree.class_expr -> unit +val class_type: Format.formatter -> Parsetree.class_type -> unit +val module_type: Format.formatter -> Parsetree.module_type -> unit +val structure_item: Format.formatter -> Parsetree.structure_item -> unit +val signature_item: Format.formatter -> Parsetree.signature_item -> unit +val binding: Format.formatter -> Parsetree.value_binding -> unit +val payload: Format.formatter -> Parsetree.payload -> unit + +val tyvar_of_name : string -> string + (** Turn a type variable name into a valid identifier, taking care of the + special treatment required for the single quote character in second + position, or for keywords by escaping them with \#. No-op on "_". *) + +val tyvar: Format.formatter -> string -> unit + (** Print a type variable name as a valid identifier, taking care of the + special treatment required for the single quote character in second + position, or for keywords by escaping them with \#. No-op on "_". *) diff --git a/upstream/ocaml_502/parsing/printast.ml b/upstream/ocaml_502/parsing/printast.ml new file mode 100644 index 0000000000..2f5702e7d2 --- /dev/null +++ b/upstream/ocaml_502/parsing/printast.ml @@ -0,0 +1,1011 @@ +(**************************************************************************) +(* *) +(* 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 typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + +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.txt; + core_type i ppf ct; + | Ptyp_poly (sl, ct) -> + line i ppf "Ptyp_poly%a\n" typevars 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_open (mod_ident, t) -> + line i ppf "Ptyp_open \"%a\"\n" fmt_longident_loc mod_ident; + core_type i ppf t + | 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 (params, c, body) -> + line i ppf "Pexp_function\n"; + list i function_param ppf params; + option i type_constraint ppf c; + function_body i ppf body + | 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 function_param i ppf { pparam_desc = desc; pparam_loc = loc } = + match desc with + | Pparam_val (l, eo, p) -> + line i ppf "Pparam_val %a\n" fmt_location loc; + arg_label (i+1) ppf l; + option (i+1) expression ppf eo; + pattern (i+1) ppf p + | Pparam_newtype ty -> + line i ppf "Pparam_newtype \"%s\" %a\n" ty.txt fmt_location loc + +and function_body i ppf body = + match body with + | Pfunction_body e -> + line i ppf "Pfunction_body\n"; + expression (i+1) ppf e + | Pfunction_cases (cases, loc, attrs) -> + line i ppf "Pfunction_cases %a\n" fmt_location loc; + attributes (i+1) ppf attrs; + list (i+1) case ppf cases + +and type_constraint i ppf constraint_ = + match constraint_ with + | Pconstraint ty -> + line i ppf "Pconstraint\n"; + core_type (i+1) ppf ty + | Pcoerce (ty1, ty2) -> + line i ppf "Pcoerce\n"; + option (i+1) core_type ppf ty1; + core_type (i+1) ppf ty2 + +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 "\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(v, a, r) -> + line i ppf "Pext_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; + 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_apply_unit me1 -> + line i ppf "Pmod_apply_unit\n"; + module_expr i ppf me1 + | 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 " %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_vars; 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; + if pcd_vars <> [] then line (i+1) ppf "pcd_vars =%a\n" typevars pcd_vars; + 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 "\n"; + pattern (i+1) ppf pc_lhs; + begin match pc_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf pc_rhs; + +and value_binding i ppf x = + line i ppf "\n"; + attributes (i+1) ppf x.pvb_attributes; + pattern (i+1) ppf x.pvb_pat; + Option.iter (value_constraint (i+1) ppf) x.pvb_constraint; + expression (i+1) ppf x.pvb_expr + +and value_constraint i ppf x = + let pp_sep ppf () = Format.fprintf ppf "@ "; in + let pp_newtypes = Format.pp_print_list fmt_string_loc ~pp_sep in + match x with + | Pvc_constraint { locally_abstract_univars = []; typ } -> + core_type i ppf typ + | Pvc_constraint { locally_abstract_univars=newtypes; typ} -> + line i ppf " %a.\n" pp_newtypes newtypes; + core_type i ppf typ + | Pvc_coercion { ground; coercion} -> + line i ppf "\n"; + option i core_type ppf ground; + core_type i ppf coercion; + + +and binding_op i ppf x = + line i ppf " %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 " %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 "\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_502/parsing/printast.mli b/upstream/ocaml_502/parsing/printast.mli new file mode 100644 index 0000000000..5bc496182f --- /dev/null +++ b/upstream/ocaml_502/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_502/parsing/syntaxerr.ml b/upstream/ocaml_502/parsing/syntaxerr.ml new file mode 100644 index 0000000000..8a326c1104 --- /dev/null +++ b/upstream/ocaml_502/parsing/syntaxerr.ml @@ -0,0 +1,52 @@ +(**************************************************************************) +(* *) +(* 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 invalid_package_type = + | Parameterized_types + | Constrained_types + | Private_types + | Not_with_type + | Neither_identifier_nor_with_type + +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 * invalid_package_type + | Removed_string_set of Location.t + +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, _) + | Removed_string_set l -> l + + +let ill_formed_ast loc s = + raise (Error (Ill_formed_ast (loc, s))) diff --git a/upstream/ocaml_502/parsing/syntaxerr.mli b/upstream/ocaml_502/parsing/syntaxerr.mli new file mode 100644 index 0000000000..a84bc6664c --- /dev/null +++ b/upstream/ocaml_502/parsing/syntaxerr.mli @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* 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 invalid_package_type = + | Parameterized_types + | Constrained_types + | Private_types + | Not_with_type + | Neither_identifier_nor_with_type + +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 * invalid_package_type + | Removed_string_set of Location.t + +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_502/parsing/unit_info.ml b/upstream/ocaml_502/parsing/unit_info.ml new file mode 100644 index 0000000000..b2e081a221 --- /dev/null +++ b/upstream/ocaml_502/parsing/unit_info.ml @@ -0,0 +1,119 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed 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 modname = string +type filename = string +type file_prefix = string + +type t = { + source_file: filename; + prefix: file_prefix; + modname: modname; +} + +let source_file (x: t) = x.source_file +let modname (x: t) = x.modname +let prefix (x: t) = x.prefix + +let basename_chop_extensions basename = + match String.index basename '.' with + | dot_pos -> String.sub basename 0 dot_pos + | exception Not_found -> basename + +let modulize s = String.capitalize_ascii s + +(* We re-export the [Misc] definition *) +let normalize = Misc.normalized_unit_filename + +let modname_from_source source_file = + source_file |> Filename.basename |> basename_chop_extensions |> modulize + +let start_char = function + | 'A' .. 'Z' -> true + | _ -> false + +let is_identchar_latin1 = function + | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246' + | '\248'..'\255' | '\'' | '0'..'9' -> true + | _ -> false + +(* Check validity of module name *) +let is_unit_name name = + String.length name > 0 + && start_char name.[0] + && String.for_all is_identchar_latin1 name + +let check_unit_name file = + if not (is_unit_name (modname file)) then + Location.prerr_warning (Location.in_file (source_file file)) + (Warnings.Bad_module_name (modname file)) + +let make ?(check_modname=true) ~source_file prefix = + let modname = modname_from_source prefix in + let p = { modname; prefix; source_file } in + if check_modname then check_unit_name p; + p + +module Artifact = struct + type t = + { + source_file: filename option; + filename: filename; + modname: modname; + } + let source_file x = x.source_file + let filename x = x.filename + let modname x = x.modname + let prefix x = Filename.remove_extension (filename x) + + let from_filename filename = + let modname = modname_from_source filename in + { modname; filename; source_file = None } + +end + +let mk_artifact ext u = + { + Artifact.filename = u.prefix ^ ext; + modname = u.modname; + source_file = Some u.source_file; + } + +let companion_artifact ext x = + { x with Artifact.filename = Artifact.prefix x ^ ext } + +let cmi f = mk_artifact ".cmi" f +let cmo f = mk_artifact ".cmo" f +let cmx f = mk_artifact ".cmx" f +let obj f = mk_artifact Config.ext_obj f +let cmt f = mk_artifact ".cmt" f +let cmti f = mk_artifact ".cmti" f +let annot f = mk_artifact ".annot" f + +let companion_obj f = companion_artifact Config.ext_obj f +let companion_cmi f = companion_artifact ".cmi" f +let companion_cmt f = companion_artifact ".cmt" f + +let mli_from_artifact f = Artifact.prefix f ^ !Config.interface_suffix +let mli_from_source u = + let prefix = Filename.remove_extension (source_file u) in + prefix ^ !Config.interface_suffix + +let is_cmi f = Filename.check_suffix (Artifact.filename f) ".cmi" + +let find_normalized_cmi f = + let filename = modname f ^ ".cmi" in + let filename = Load_path.find_normalized filename in + { Artifact.filename; modname = modname f; source_file = Some f.source_file } diff --git a/upstream/ocaml_502/parsing/unit_info.mli b/upstream/ocaml_502/parsing/unit_info.mli new file mode 100644 index 0000000000..48acafc06d --- /dev/null +++ b/upstream/ocaml_502/parsing/unit_info.mli @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed 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 centralize the handling of compilation files and their metadata. + + Maybe more importantly, this module provides functions for deriving module + names from strings or filenames. +*) + +(** {1:modname_from_strings Module name convention and computation} *) + +type modname = string +type filename = string +type file_prefix = string + +(** [modulize s] capitalizes the first letter of [s]. *) +val modulize: string -> modname + +(** [normalize s] uncapitalizes the first letter of [s]. *) +val normalize: string -> string + +(** [modname_from_source filename] is [modulize stem] where [stem] is the + basename of the filename [filename] stripped from all its extensions. + For instance, [modname_from_source "/pa.th/x.ml.pp"] is ["X"]. *) +val modname_from_source: filename -> modname + +(** {2:module_name_validation Module name validation function}*) + +(** [is_unit_name ~strict name] is true only if [name] can be used as a + valid module name. *) +val is_unit_name : modname -> bool + + +(** {1:unit_info Metadata for compilation unit} *) + +type t +(** Metadata for a compilation unit: + - the module name associated to the unit + - the filename prefix (dirname + basename with all extensions stripped) + for compilation artifacts + - the input source file + For instance, when calling [ocamlopt dir/x.mli -o target/y.cmi], + - the input source file is [dir/x.mli] + - the module name is [Y] + - the prefix is [target/y] +*) + +(** [source_file u] is the source file of [u]. *) +val source_file: t -> filename + +(** [prefix u] is the filename prefix of the unit. *) +val prefix: t -> file_prefix + +(** [modname u] or [artifact_modname a] is the module name of the unit + or compilation artifact.*) +val modname: t -> modname + +(** [check_unit_name u] prints a warning if the derived module name [modname u] + should not be used as a module name as specified + by {!is_unit_name}[ ~strict:true]. *) +val check_unit_name : t -> unit + +(** [make ~check ~source_file prefix] associates both the + [source_file] and the module name {!modname_from_source}[ target_prefix] to + the prefix filesystem path [prefix]. + + If [check_modname=true], this function emits a warning if the derived module + name is not valid according to {!check_unit_name}. +*) +val make: ?check_modname:bool -> source_file:filename -> file_prefix -> t + +(** {1:artifact_function Build artifacts }*) +module Artifact: sig + type t +(** Metadata for a single compilation artifact: + - the module name associated to the artifact + - the filesystem path + - the input source file if it exists +*) + + (** [source_file a] is the source file of [a] if it exists. *) + val source_file: t -> filename option + + (** [prefix a] is the filename prefix of the compilation artifact. *) + val prefix: t -> file_prefix + + (** [filename u] is the filesystem path for a compilation artifact. *) + val filename: t -> filename + + (** [modname a] is the module name of the compilation artifact.*) + val modname: t -> modname + + (** [from_filename filename] reconstructs the module name + [modname_from_source filename] associated to the artifact [filename]. *) + val from_filename: filename -> t + +end + +(** {1:info_build_artifacts Derived build artifact metadata} *) + +(** Those functions derive a specific [artifact] metadata from an [unit] + metadata.*) +val cmi: t -> Artifact.t +val cmo: t -> Artifact.t +val cmx: t -> Artifact.t +val obj: t -> Artifact.t +val cmt: t -> Artifact.t +val cmti: t -> Artifact.t +val annot: t -> Artifact.t + +(** The functions below change the type of an artifact by updating the + extension of its filename. + Those functions purposefully do not cover all artifact kinds because we want + to track which artifacts are assumed to be bundled together. *) +val companion_cmi: Artifact.t -> Artifact.t +val companion_obj: Artifact.t -> Artifact.t +val companion_cmt: Artifact.t -> Artifact.t + + +(** {1:ml_mli_cmi_interaction Mli and cmi derived from implementation files } *) + +(** The compilation of module implementation changes in presence of mli and cmi + files, the function belows help to handle this. *) + +(** [mli_from_source u] is the interface source filename associated to the unit + [u]. The actual suffix depends on {!Config.interface_suffix}. +*) +val mli_from_source: t -> filename + +(** [mli_from_artifact t] is the name of the interface source file derived from + the artifact [t]. This variant is necessary when handling artifacts derived + from an unknown source files (e.g. packed modules). *) +val mli_from_artifact: Artifact.t -> filename + +(** Check if the artifact is a cmi *) +val is_cmi: Artifact.t -> bool + +(** [find_normalized_cmi u] finds in the load_path a file matching the module + name [modname u]. + @raise Not_found if no such cmi exists *) +val find_normalized_cmi: t -> Artifact.t diff --git a/upstream/ocaml_502/typing/annot.mli b/upstream/ocaml_502/typing/annot.mli new file mode 100644 index 0000000000..bbaade5b03 --- /dev/null +++ b/upstream/ocaml_502/typing/annot.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* 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_502/typing/btype.ml b/upstream/ocaml_502/typing/btype.ml new file mode 100644 index 0000000000..5b09a4e564 --- /dev/null +++ b/upstream/ocaml_502/typing/btype.ml @@ -0,0 +1,780 @@ +(**************************************************************************) +(* *) +(* 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 ****) + +let wrap_repr f ty = f (Transient_expr.repr ty) +let wrap_type_expr f tty = f (Transient_expr.type_expr tty) + +module TransientTypeSet = Set.Make(TransientTypeOps) +module TypeSet = struct + include TransientTypeSet + let add = wrap_repr add + let mem = wrap_repr mem + let singleton = wrap_repr singleton + let exists p = TransientTypeSet.exists (wrap_type_expr p) + let elements set = + List.map Transient_expr.type_expr (TransientTypeSet.elements set) +end +module TransientTypeMap = Map.Make(TransientTypeOps) +module TypeMap = struct + include TransientTypeMap + let add ty = wrap_repr add ty + let find ty = wrap_repr find ty + let singleton ty = wrap_repr singleton ty + let fold f = TransientTypeMap.fold (wrap_type_expr f) +end +module TransientTypeHash = Hashtbl.Make(TransientTypeOps) +module TypeHash = struct + include TransientTypeHash + let mem hash = wrap_repr (mem hash) + let add hash = wrap_repr (add hash) + let remove hash = wrap_repr (remove hash) + let find hash = wrap_repr (find hash) + let find_opt hash = wrap_repr (find_opt hash) + let iter f = TransientTypeHash.iter (wrap_type_expr f) +end +module TransientTypePairs = + Hashtbl.Make (struct + type t = transient_expr * transient_expr + let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') + let hash (t, t') = t.id + 93 * t'.id + end) +module TypePairs = struct + module H = TransientTypePairs + open Transient_expr + + type t = { + set : unit H.t; + mutable elems : (transient_expr * transient_expr) list; + (* elems preserves the (reversed) insertion order of elements *) + } + + let create n = + { elems = []; set = H.create n } + + let clear t = + t.elems <- []; + H.clear t.set + + let repr2 (t1, t2) = (repr t1, repr t2) + + let add t p = + let p = repr2 p in + if H.mem t.set p then () else begin + H.add t.set p (); + t.elems <- p :: t.elems + end + + let mem t p = H.mem t.set (repr2 p) + + let iter f t = + (* iterate in insertion order, not Hashtbl.iter order *) + List.rev t.elems + |> List.iter (fun (t1,t2) -> + f (type_expr t1, type_expr t2)) +end + +(**** 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 newgenty desc = newty2 ~level:generic_level desc +let newgenvar ?name () = newgenty (Tvar name) +let newgenstub ~scope = newty3 ~level:generic_level ~scope (Tvar None) + +(* +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 ty = match get_desc ty with Tvar _ -> true | _ -> false +let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false +let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false +let type_kind_is_abstract decl = + match decl.type_kind with Type_abstract _ -> true | _ -> false +let type_origin decl = + match decl.type_kind with + | Type_abstract origin -> origin + | Type_variant _ | Type_record _ | Type_open -> Definition + +let dummy_method = "*dummy method*" + +(**** Representative of a type ****) + +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 = + match row_fixed row with + | Some _ as x -> x + | None -> + let ty = row_more row in + match get_desc ty with + | Tvar _ | Tnil -> None + | Tunivar _ -> Some (Univar ty) + | Tconstr (p,_,_) -> Some (Reified p) + | _ -> assert false + +let is_fixed row = match row_fixed row with + | None -> false + | Some _ -> true + +let has_fixed_explanation row = fixed_explanation row <> None + +let static_row row = + row_closed row && + List.for_all + (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true) + (row_fields row) + +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 = + match get_desc ty with + | Tvariant row when not (static_row row) -> + row_more row + | Tobject (ty, _) -> + let rec proxy_obj ty = + match get_desc ty with + Tfield (_, _, _, ty) -> proxy_obj ty + | Tvar _ | Tunivar _ | Tconstr _ -> ty + | Tnil -> ty + | _ -> assert false + in proxy_obj ty + | _ -> ty + +(**** Utilities for fixed row private types ****) + +let row_of_type t = + match get_desc t with + Tobject(t,_) -> + let rec get_row t = + match get_desc t 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 get_desc t 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_static_row_name decl path = + match decl.type_manifest with + None -> () + | Some ty -> + match get_desc ty with + Tvariant row when static_row row -> + let row = + set_row_name row (Some (path, decl.type_params)) in + set_type_desc ty (Tvariant row) + | _ -> () + + + (**********************************) + (* Utilities for type traversal *) + (**********************************) + +let 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_fields row) + in + match get_desc (row_more row) with + | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil -> + begin match + Option.map (fun (_,l) -> List.fold_left f result l) (row_name row) + 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 get_desc ty 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 _ + | 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; + it.it_type_expr it cs.csig_self_row; + Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars; + Meths.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_meths + | 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 get_desc ty with + Tconstr (p, _, _) + | Tobject (_, {contents=Some (p, _)}) + | Tpackage (p, _) -> + it.it_path p + | Tvariant row -> + Option.iter (fun (p,_) -> it.it_path p) (row_name row) + | _ -> () + 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 Row {fields = orig_fields; fixed = orig_fixed; closed; name = orig_name} = + row_repr row in + let fields = List.map + (fun (l, fi) -> l, + match row_field_repr fi with + | Rpresent oty -> rf_present (Option.map f oty) + | Reither(c, tl, m) -> + let use_ext_of = if keep then Some fi else None in + let m = if is_fixed row then fixed else m in + let tl = List.map f tl in + rf_either tl ?use_ext_of ~no_arg:c ~matched:m + | Rabsent -> rf_absent) + orig_fields in + let name = + match orig_name with + | None -> None + | Some (path, tl) -> Some (path, List.map f tl) in + let fixed = if fixed then orig_fixed else None in + create_row ~fields ~more ~fixed ~closed ~name + +let copy_commu c = if is_commu_ok c then commu_ok else commu_var () + +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) -> + Tfield (p, field_kind_internal_repr k, f ty1, f ty2) + (* the kind is kept shared, with indirections removed for performance *) + | Tnil -> Tnil + | Tlink ty -> copy_type_desc f (get_desc ty) + | 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 redirect_desc: copy_scope -> type_expr -> type_desc -> unit + + val with_scope: (copy_scope -> 'a) -> 'a +end = struct + type copy_scope = { + mutable saved_desc : (transient_expr * type_desc) list; + (* Save association of generic nodes with their description. *) + } + + let redirect_desc copy_scope ty desc = + let ty = Transient_expr.repr ty in + copy_scope.saved_desc <- (ty, ty.desc) :: copy_scope.saved_desc; + Transient_expr.set_desc ty desc + + (* Restore type descriptions. *) + let cleanup { saved_desc; _ } = + List.iter (fun (ty, desc) -> Transient_expr.set_desc ty desc) saved_desc + + let with_scope f = + let scope = { saved_desc = [] } 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 +*) + +(* Re-export backtrack *) + +let snapshot = snapshot +let backtrack = backtrack ~cleanup_abbrev + + (**********************************) + (* 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 + + (*******************************) + (* 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 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 + +(* Fully expand the head of a class type *) +let rec scrape_class_type = + function + Cty_constr (_, _, cty) -> scrape_class_type cty + | cty -> cty + +let rec class_type_arity = + function + Cty_constr (_, _, cty) -> class_type_arity cty + | Cty_signature _ -> 0 + | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty + +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) + +let self_type cty = + (signature_of_class_type cty).csig_self + +let self_type_row cty = + (signature_of_class_type cty).csig_self_row + +(* Return the methods of a class signature *) +let methods sign = + Meths.fold + (fun name _ l -> name :: l) + sign.csig_meths [] + +(* Return the virtual methods of a class signature *) +let virtual_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_meths [] + +(* Return the concrete methods of a class signature *) +let concrete_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> MethSet.add name s) + sign.csig_meths MethSet.empty + +(* Return the public methods of a class signature *) +let public_methods sign = + Meths.fold + (fun name (priv, _vr, _ty) l -> + match priv with + | Mprivate _ -> l + | Mpublic -> name :: l) + sign.csig_meths [] + +(* Return the instance variables of a class signature *) +let instance_vars sign = + Vars.fold + (fun name _ l -> name :: l) + sign.csig_vars [] + +(* Return the virtual instance variables of a class signature *) +let virtual_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_vars [] + +(* Return the concrete instance variables of a class signature *) +let concrete_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> VarSet.add name s) + sign.csig_vars VarSet.empty + +let method_type label sign = + match Meths.find label sign.csig_meths with + | (_, _, ty) -> ty + | exception Not_found -> assert false + +let instance_variable_type label sign = + match Vars.find label sign.csig_vars with + | (_, _, ty) -> ty + | exception Not_found -> assert false + + (**********************************) + (* Utilities for level-marking *) + (**********************************) + +let not_marked_node ty = get_level ty >= lowest_level + (* type nodes with negative levels are "marked" *) + +let flip_mark_node ty = + let ty = Transient_expr.repr ty in + Transient_expr.set_level ty (pivot_level - ty.level) +let logged_mark_node ty = + set_level ty (pivot_level - get_level ty) + +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 = + 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 = + 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 = + if get_level ty < 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; + unmark_type sign.csig_self_row; + Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars; + Meths.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_meths + +let unmark_class_type cty = + unmark_iterators.it_class_type unmark_iterators cty + +(**** Type information getter ****) + +let cstr_type_path cstr = + match get_desc cstr.cstr_res with + | Tconstr (p, _, _) -> p + | _ -> assert false diff --git a/upstream/ocaml_502/typing/btype.mli b/upstream/ocaml_502/typing/btype.mli new file mode 100644 index 0000000000..077fb72652 --- /dev/null +++ b/upstream/ocaml_502/typing/btype.mli @@ -0,0 +1,320 @@ +(**************************************************************************) +(* *) +(* 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 : sig + include Set.S with type elt = transient_expr + val add: type_expr -> t -> t + val mem: type_expr -> t -> bool + val singleton: type_expr -> t + val exists: (type_expr -> bool) -> t -> bool + val elements: t -> type_expr list +end +module TransientTypeMap : Map.S with type key = transient_expr +module TypeMap : sig + include Map.S with type key = transient_expr + and type 'a t = 'a TransientTypeMap.t + val add: type_expr -> 'a -> 'a t -> 'a t + val find: type_expr -> 'a t -> 'a + val singleton: type_expr -> 'a -> 'a t + val fold: (type_expr -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end +module TypeHash : sig + include Hashtbl.S with type key = transient_expr + val mem: 'a t -> type_expr -> bool + val add: 'a t -> type_expr -> 'a -> unit + val remove: 'a t -> type_expr -> unit + val find: 'a t -> type_expr -> 'a + val find_opt: 'a t -> type_expr -> 'a option + val iter: (type_expr -> 'a -> unit) -> 'a t -> unit +end +module TypePairs : sig + type t + val create: int -> t + val clear: t -> unit + val add: t -> type_expr * type_expr -> unit + val mem: t -> type_expr * type_expr -> bool + val iter: (type_expr * type_expr -> unit) -> t -> unit +end + +(**** Levels ****) + +val generic_level: int + +val newgenty: type_desc -> type_expr + (* Create a generic type *) +val newgenvar: ?name:string -> unit -> type_expr + (* Return a fresh generic variable *) +val newgenstub: scope:int -> type_expr + (* Return a fresh generic node, to be instantiated + by [Transient_expr.set_stub_desc] *) + +(* 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 type_kind_is_abstract: type_declaration -> bool +val type_origin : type_declaration -> type_origin + +(**** polymorphic variants ****) + +val is_fixed: row_desc -> bool +(* Return whether the row is directly marked as fixed or not *) + +val has_fixed_explanation: row_desc -> bool +(* Return whether the row should be treated as fixed or not. + In particular, [is_fixed row] implies [has_fixed_explanation 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_static_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 *) +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) + + +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 + +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 redirect_desc: copy_scope -> type_expr -> type_desc -> unit + (* Temporarily change a type description *) + + 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 *) +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. + 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 *) + +(**** Backtracking ****) + +val snapshot: unit -> snapshot +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 *) + +(**** 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 class types ****) + +(* Get the class signature within a class type *) +val signature_of_class_type : class_type -> class_signature + +(* Get the body of a class type (i.e. without parameters) *) +val class_body : class_type -> class_type + +(* Fully expand the head of a class type *) +val scrape_class_type : class_type -> class_type + +(* Return the number of parameters of a class type *) +val class_type_arity : class_type -> int + +(* Given a path and type parameters, add an abbreviation to a class type *) +val abbreviate_class_type : + Path.t -> type_expr list -> class_type -> class_type + +(* Get the self type of a class *) +val self_type : class_type -> type_expr + +(* Get the row variable of the self type of a class *) +val self_type_row : class_type -> type_expr + +(* Return the methods of a class signature *) +val methods : class_signature -> string list + +(* Return the virtual methods of a class signature *) +val virtual_methods : class_signature -> string list + +(* Return the concrete methods of a class signature *) +val concrete_methods : class_signature -> MethSet.t + +(* Return the public methods of a class signature *) +val public_methods : class_signature -> string list + +(* Return the instance variables of a class signature *) +val instance_vars : class_signature -> string list + +(* Return the virtual instance variables of a class signature *) +val virtual_instance_vars : class_signature -> string list + +(* Return the concrete instance variables of a class signature *) +val concrete_instance_vars : class_signature -> VarSet.t + +(* Return the type of a method. + @raises [Assert_failure] if the class has no such method. *) +val method_type : label -> class_signature -> type_expr + +(* Return the type of an instance variable. + @raises [Assert_failure] if the class has no such method. *) +val instance_variable_type : label -> class_signature -> type_expr + +(**** Forward declarations ****) +val print_raw: (Format.formatter -> type_expr -> unit) ref + +(**** Type information getter ****) + +val cstr_type_path : constructor_description -> Path.t diff --git a/upstream/ocaml_502/typing/cmt2annot.ml b/upstream/ocaml_502/typing/cmt2annot.ml new file mode 100644 index 0000000000..e8850e503a --- /dev/null +++ b/upstream/ocaml_502/typing/cmt2annot.ml @@ -0,0 +1,190 @@ +(**************************************************************************) +(* *) +(* 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 bind_function_param loc fp = + match fp.fp_kind with + | Tparam_pat pat -> bind_variables loc pat + | Tparam_optional_default (pat, _) -> bind_variables loc pat + +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_try (_, f) -> + bind_cases f + | Texp_function (params, _) -> + List.iter (bind_function_param exp.exp_loc) params + | 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_502/typing/cmt2annot.mli b/upstream/ocaml_502/typing/cmt2annot.mli new file mode 100644 index 0000000000..2dfa8dec2a --- /dev/null +++ b/upstream/ocaml_502/typing/cmt2annot.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Sebastien Hinderer, projet Cambium, INRIA Paris *) +(* *) +(* Copyright 2022 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed 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. *) + +val gen_annot : + string option -> + sourcefile:string option -> + use_summaries:bool -> Cmt_format.binary_annots -> + unit diff --git a/upstream/ocaml_502/typing/ctype.ml b/upstream/ocaml_502/typing/ctype.ml new file mode 100644 index 0000000000..6202e8e65f --- /dev/null +++ b/upstream/ocaml_502/typing/ctype.ml @@ -0,0 +1,5593 @@ +(**************************************************************************) +(* *) +(* 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 knows 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 ****) + +(* There are two classes of errortrace-related exceptions: *traces* and + *errors*. The former, whose names end with [_trace], contain + [Errortrace.trace]s, representing traces that are currently being built; they + are local to this file. All the internal functions that implement + unification, type equality, and moregen raise trace exceptions. Once we are + done, in the top level functions such as [unify], [equal], and [moregen], we + catch the trace exceptions and transform them into the analogous error + exception. This indicates that we are done building the trace, and expect + the error to flow out of unification, type equality, or moregen into + surrounding code (with some few exceptions when these top-level functions are + used as building blocks elsewhere.) Only the error exceptions are exposed in + [ctype.mli]; the trace exceptions are an implementation detail. Any trace + exception that escapes from a function in this file is a bug. *) + +exception Unify_trace of unification trace +exception Equality_trace of comparison trace +exception Moregen_trace of comparison trace + +exception Unify of unification_error +exception Equality of equality_error +exception Moregen of moregen_error +exception Subtype of Subtype.error + +exception Escape of type_expr 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 trace) : 'a = + match tr_exn with + | Unify -> raise (Unify_trace tr) + | Equality -> raise (Equality_trace tr) + | Moregen -> raise (Moregen_trace 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 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') -> + let pp_tag ppf s = Format.fprintf ppf "`%s" s in + let inline_tag = Misc.Style.as_inline_code pp_tag in + Some + Location. + (errorf ~loc:(in_file !input_name) + "In this program,@ variant constructors@ %a and %a@ \ + have the same hash value.@ Change one of them." + inline_tag l inline_tag l' + ) + | _ -> None + ) + +exception Cannot_expand + +exception Cannot_apply + +exception Cannot_subst + +exception Cannot_unify_universal_variables + +exception Matches_failure of Env.t * unification_error + +exception Incompatible + +(**** Type level management ****) + +let current_level = s_ref 0 +let nongen_level = s_ref 0 +let global_level = s_ref 0 +let saved_level = s_ref [] + +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 wrap_end_def f = Misc.try_finally f ~always:end_def + +let with_local_level ?post f = + begin_def (); + let result = wrap_end_def f in + Option.iter (fun g -> g result) post; + result +let with_local_level_if cond f ~post = + if cond then with_local_level f ~post else f () +let with_local_level_iter f ~post = + begin_def (); + let result, l = wrap_end_def f in + List.iter post l; + result +let with_local_level_iter_if cond f ~post = + if cond then with_local_level_iter f ~post else fst (f ()) +let with_local_level_if_principal f ~post = + with_local_level_if !Clflags.principal f ~post +let with_local_level_iter_if_principal f ~post = + with_local_level_iter_if !Clflags.principal f ~post +let with_level ~level f = + begin_def (); init_def level; + let result = wrap_end_def f in + result +let with_level_if cond ~level f = + if cond then with_level ~level f else f () + +let with_local_level_for_class ?post f = + begin_class_def (); + let result = wrap_end_def f in + Option.iter (fun g -> g result) post; + result + +let with_raised_nongen_level f = + raise_nongen_level (); + wrap_end_def f + + +let reset_global_level () = + global_level := !current_level +let increase_global_level () = + let gl = !global_level in + global_level := !current_level; + gl +let restore_global_level gl = + global_level := gl + +(**** 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 tl abbrev = + if tl <> [] || !trace_gadt_instances || !Clflags.principal + then abbrev + else simple_abbrevs + +(**** Some type creators ****) + +(* Re-export generic type creators *) + +let newty desc = newty2 ~level:!current_level desc +let new_scoped_ty scope desc = newty3 ~level:!current_level ~scope desc + +let newvar ?name () = newty2 ~level:!current_level (Tvar name) +let newvar2 ?name level = newty2 ~level:level (Tvar name) +let new_global_var ?name () = newty2 ~level:!global_level (Tvar name) +let newstub ~scope = newty3 ~level:!current_level ~scope (Tvar None) + +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 *) + +(**** information for [Typecore.unify_pat_*] ****) + +module Pattern_env : sig + type t = private + { mutable env : Env.t; + equations_scope : int; + allow_recursive_equations : bool; } + val make: Env.t -> equations_scope:int -> allow_recursive_equations:bool -> t + val copy: ?equations_scope:int -> t -> t + val set_env: t -> Env.t -> unit +end = struct + type t = + { mutable env : Env.t; + equations_scope : int; + allow_recursive_equations : bool; } + let make env ~equations_scope ~allow_recursive_equations = + { env; + equations_scope; + allow_recursive_equations; } + let copy ?equations_scope penv = + let equations_scope = + match equations_scope with None -> penv.equations_scope | Some s -> s in + { penv with equations_scope } + let set_env penv env = penv.env <- env +end + +(**** unification mode ****) + +type equations_generation = + | Forbidden + | Allowed of { equated_types : TypePairs.t } + +type unification_environment = + | Expression of + { env : Env.t; + in_subst : bool; } + (* normal unification mode *) + | Pattern of + { penv : Pattern_env.t; + equations_generation : equations_generation; + assume_injective : bool; + unify_eq_set : TypePairs.t; } + (* GADT constraint unification mode: + only used for type indices of GADT constructors + during pattern matching. + This allows adding local constraints. *) + +let get_env = function + | Expression {env} -> env + | Pattern {penv} -> penv.env + +let set_env uenv env = + match uenv with + | Expression _ -> invalid_arg "Ctype.set_env" + | Pattern {penv} -> Pattern_env.set_env penv env + +let in_pattern_mode = function + | Expression _ -> false + | Pattern _ -> true + +let get_equations_scope = function + | Expression _ -> invalid_arg "Ctype.get_equations_scope" + | Pattern r -> r.penv.equations_scope + +let order_type_pair t1 t2 = + if get_id t1 <= get_id t2 then (t1, t2) else (t2, t1) + +let add_type_equality uenv t1 t2 = + match uenv with + | Expression _ -> invalid_arg "Ctype.add_type_equality" + | Pattern r -> TypePairs.add r.unify_eq_set (order_type_pair t1 t2) + +let unify_eq uenv t1 t2 = + eq_type t1 t2 || + match uenv with + | Expression _ -> false + | Pattern r -> TypePairs.mem r.unify_eq_set (order_type_pair t1 t2) + +(* unification during type constructor expansion: + This mode disables the propagation of the level and scope of + the row variable to the whole type during the unification. + (see unify_{row, fields} and PR #11771) *) +let in_subst_mode = function + | Expression {in_subst} -> in_subst + | Pattern _ -> false + +let can_generate_equations = function + | Expression _ | Pattern { equations_generation = Forbidden } -> false + | Pattern { equations_generation = Allowed _ } -> true + +(* Can only be called when generate_equations is true *) +let record_equation uenv t1 t2 = + match uenv with + | Expression _ | Pattern { equations_generation = Forbidden } -> + invalid_arg "Ctype.record_equation" + | Pattern { equations_generation = Allowed { equated_types } } -> + TypePairs.add equated_types (t1, t2) + +let can_assume_injective = function + | Expression _ -> false + | Pattern { assume_injective } -> assume_injective + +let in_counterexample uenv = + match uenv with + | Expression _ -> false + | Pattern { penv } -> penv.allow_recursive_equations + +let allow_recursive_equations uenv = + !Clflags.recursive_types || in_counterexample uenv + +(* Though without_* functions can be in a direct style, + CPS clarifies the structure of the code better. *) +let without_assume_injective uenv f = + match uenv with + | Expression _ as uenv -> f uenv + | Pattern r -> f (Pattern { r with assume_injective = false }) + +let without_generating_equations uenv f = + match uenv with + | Expression _ as uenv -> f uenv + | Pattern r -> f (Pattern { r with equations_generation = Forbidden }) + +(*** Checks for type definitions ***) + +let rec in_current_module = function + | Path.Pident _ -> true + | Path.Pdot _ | Path.Papply _ -> false + | Path.Pextra_ty (p, _) -> in_current_module p + +let in_pervasives p = + in_current_module p && + try ignore (Env.find_type p Env.initial); 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 get_desc ty with + Tobject (fields, _) -> fields + | _ -> assert false + +let flatten_fields ty = + let rec flatten l ty = + match get_desc ty 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) + +(**** Check whether an object is open ****) + +(* +++ The abbreviation should eventually be expanded *) +let rec object_row ty = + match get_desc ty with + Tobject (t, _) -> object_row t + | Tfield(_, _, _, t) -> object_row t + | _ -> ty + +let opened_object ty = + match get_desc (object_row ty) with + | Tvar _ | Tunivar _ | Tconstr _ -> true + | _ -> false + +let concrete_object ty = + match get_desc (object_row ty) with + | Tvar _ -> false + | _ -> true + +(**** Row variable of an object type ****) + +let rec fields_row_variable ty = + match get_desc ty with + | Tfield (_, _, _, ty) -> fields_row_variable ty + | Tvar _ -> ty + | _ -> assert false + +(**** Object name manipulation ****) +(* +++ Bientot obsolete *) + +let set_object_name id params ty = + match get_desc ty with + | Tobject (fi, nm) -> + let rv = fields_row_variable fi in + set_name nm (Some (Path.Pident id, rv::params)) + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.set_object_name" + +let remove_object_name ty = + match get_desc ty with + Tobject (_, nm) -> set_name nm None + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.remove_object_name" + + (*******************************************) + (* 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) when erase -> + link_row_field_ext ~inside:f rf_absent; fi + | _ -> p :: fi + + (**************************************) + (* Check genericity of type schemes *) + (**************************************) + +type variable_kind = Row_variable | Type_variable +exception Non_closed of type_expr * variable_kind + +(* [free_vars] collects the variables of the input type expression. It + is used for several different things in the type-checker, with the + following bells and whistles: + - If [env] 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 [variable_kind] to distinguish them. + - 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). + + [free_vars] returns a [(variable * bool) list], while + [free_variables] below drops the type/row information + and only returns a [variable list]. + *) +let free_vars ?env ty = + let rec fv ~kind acc ty = + if not (try_mark_node ty) then acc + else match get_desc ty, env with + | Tvar _, _ -> + (ty, kind) :: acc + | Tconstr (path, tl, _), Some env -> + let acc = + match Env.find_type_expansion path env with + | exception Not_found -> acc + | (_, body, _) -> + if get_level body = generic_level then acc + else (ty, kind) :: acc + in + List.fold_left (fv ~kind:Type_variable) acc tl + | Tobject (ty, _), _ -> + (* ignoring the second parameter of [Tobject] amounts to not + counting "virtual free variables". *) + fv ~kind:Row_variable acc ty + | Tfield (_, _, ty1, ty2), _ -> + let acc = fv ~kind:Type_variable acc ty1 in + fv ~kind:Row_variable acc ty2 + | Tvariant row, _ -> + let acc = fold_row (fv ~kind:Type_variable) acc row in + if static_row row then acc + else fv ~kind:Row_variable acc (row_more row) + | _ -> + fold_type_expr (fv ~kind) acc ty + in fv ~kind:Type_variable [] ty + +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 = { + free_variable: type_expr * variable_kind; + meth: string; + meth_ty: type_expr; +} +exception CCFailure of closed_class_failure + +let closed_class params sign = + List.iter mark_type params; + ignore (try_mark_node sign.csig_self_row); + try + Meths.iter + (fun lab (priv, _, ty) -> + if priv = Mpublic then begin + try closed_type ty with Non_closed (ty0, variable_kind) -> + raise (CCFailure { + free_variable = (ty0, variable_kind); + meth = lab; + meth_ty = ty; + }) + end) + sign.csig_meths; + List.iter unmark_type params; + unmark_class_signature sign; + None + with CCFailure reason -> + 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 level = get_level ty in + if (level > !current_level) && (level <> generic_level) then begin + set_level ty generic_level; + (* recur into abbrev for the speed *) + begin match get_desc ty 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 level = get_level ty in + if level <> generic_level then begin + if is_Tvar ty && level > !current_level then + set_level ty !current_level + else if level > !current_level then begin + begin match get_desc ty with + Tconstr (_, _, abbrev) -> + abbrev := Mnil + | _ -> () + end; + 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 level = get_level ty in + if level < !current_level || level = generic_level then () else + match get_desc ty 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 (_, tyl, memo) -> + 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 orig_level = get_level ty in + if try_logged_mark_node ty then begin + if level < get_scope ty then + raise_scope_escape_exn ty; + begin match get_desc ty 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 + (newty2 ~level: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 = + if get_scope ty < scope then begin + if get_level ty < 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 = + if get_level ty > level then begin + if level < get_scope ty then raise_scope_escape_exn ty; + match get_desc ty with + Tconstr(p, _tl, _abbrev) when level < Path.scope p -> + (* Try first to replace an abbreviation by its expansion. *) + begin try + let ty' = !forward_try_expand_safe env ty in + link_type ty 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 && get_level ty > level) + variance tl + in + begin try + if not needs_expand then raise Cannot_expand; + let ty' = !forward_try_expand_safe env ty in + link_type ty 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 -> + begin match row_name row with + | Some (p, _tl) when level < Path.scope p -> + set_type_desc ty (Tvariant (set_row_name row None)) + | _ -> () + end; + set_level ty level; + iter_type_expr (update_level env level expand) ty + | Tfield(lab, _, ty1, _) + when lab = dummy_method && level < get_scope ty1 -> + 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 = + if get_level ty > 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 must_visit = + get_level ty > var_level && + match Hashtbl.find visited (get_id ty) with + | done_contra -> contra && not done_contra + | exception Not_found -> true + in + if must_visit then begin + Hashtbl.add visited (get_id ty) contra; + let lower_rec = lower_contravariant env var_level visited in + match get_desc ty 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, + type_kind_is_abstract typ + 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_variables_only env level ty = + simple_abbrevs := Mnil; + lower_contravariant env level (Hashtbl.create 7) true ty + +let lower_contravariant env ty = + simple_abbrevs := Mnil; + lower_contravariant env !nongen_level (Hashtbl.create 7) false ty + +let rec generalize_class_type' gen = + function + Cty_constr (_, params, cty) -> + List.iter gen params; + generalize_class_type' gen cty + | Cty_signature csig -> + gen csig.csig_self; + gen csig.csig_self_row; + Vars.iter (fun _ (_, _, ty) -> gen ty) csig.csig_vars; + Meths.iter (fun _ (_, _, ty) -> gen ty) csig.csig_meths + | Cty_arrow (_, ty, cty) -> + gen ty; + generalize_class_type' gen cty + +let generalize_class_type cty = + generalize_class_type' generalize cty + +let generalize_class_type_structure cty = + generalize_class_type' generalize_structure cty + +(* 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 graph = TypeHash.create 17 in + let roots = ref [] in + + let rec inverse pty ty = + match TypeHash.find_opt graph ty with + | Some parents -> parents := pty @ !parents + | None -> + let level = get_level ty in + if level > !current_level then begin + TypeHash.add graph ty (ref pty); + (* XXX: why generic_level needs to be a root *) + if (level = generic_level) || eq_type ty ty0 then + roots := ty :: !roots; + iter_type_expr (inverse [ty]) ty + end + in + + let rec generalize_parents ~is_root ty = + if is_root || get_level ty <> generic_level then begin + set_level ty generic_level; + List.iter (generalize_parents ~is_root:false) !(TypeHash.find graph ty); + (* Special case for rows: must generalize the row variable *) + match get_desc ty with + Tvariant row -> + let more = row_more row in + let lv = get_level more in + if (TypeHash.mem graph more || lv > !current_level) + && lv <> generic_level then set_level more generic_level + | _ -> () + end + in + + inverse [] ty; + List.iter (generalize_parents ~is_root:true) !roots; + TypeHash.iter + (fun ty _ -> + if get_level ty <> generic_level then set_level ty !current_level) + graph + +let limited_generalize_class_type rv cty = + generalize_class_type' (limited_generalize rv) cty + +(* 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 = + 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 get_desc inv.inv_type with + Tpoly (_ty, tl) when List.memq (get_id univ) (List.map get_id 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 = + if not_marked_node ty then + if get_level ty = 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 result of copying a generic node is + "cached" in-place by temporarily mutating the node description by + a stub [Tsubst (newvar ())] using [For_copy.redirect_desc]. The + scope of this mutation is determined by the [copy_scope] parameter, + and the [For_copy.with_scope] helper is in charge of creating a new + scope and performing the necessary book-keeping -- in particular + reverting the in-place updates after the instantiation is done. *) + +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 copy_scope ty = + let copy = copy ?partial ?keep_names copy_scope in + match get_desc ty with + Tsubst (ty, _) -> ty + | desc -> + let level = get_level ty in + if 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 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 level else !current_level + else generic_level + in + if forget <> generic_level then newty2 ~level:forget (Tvar None) else + let t = newstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let desc' = + match desc with + | Tconstr (p, tl, _) -> + let abbrevs = proper_abbrevs tl !abbreviations in + begin match find_repr p !abbrevs with + Some ty when not (eq_type 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 row -> + let more = row_more row in + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + begin match mored with + Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + (* If the row variable is not generic, we must keep it *) + let keep = get_level more <> generic_level && partial = None in + let more' = + match mored with + Tsubst (ty, None) -> ty + (* TODO: is this case possible? + possibly an interaction with (copy more) below? *) + | Tconstr _ | Tnil -> + copy more + | Tvar _ | Tunivar _ -> + if keep then more else newty mored + | _ -> assert false + in + let row = + match get_desc more' with (* PR#6163 *) + Tconstr (x,_,_) when not (is_fixed row) -> + let Row {fields; more; closed; name} = row_repr row in + create_row ~fields ~more ~closed ~name + ~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 not_reither (_, f) = + match row_field_repr f with + Reither _ -> false + | _ -> true + in + let fields = row_fields row in + if row_closed row && not (is_fixed row) + && TypeSet.is_empty (free_univars ty) + && not (List.for_all not_reither fields) then + let more' = newvar () in + (more', + create_row ~fields:(List.filter not_reither fields) + ~more:more' ~closed:false ~fixed:None ~name:None) + else (more', row) + | _ -> (more', row) + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope more + (Tsubst(more', Some t)); + (* Return a new copy *) + Tvariant (copy_row copy true row keep more') + end + | Tobject (ty1, _) when partial <> None -> + Tobject (copy ty1, ref None) + | _ -> copy_type_desc ?keep_names copy desc + in + Transient_expr.set_stub_desc t desc'; + 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 copy_scope -> + copy ?partial copy_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 copy_scope -> + List.map (fun t -> copy copy_scope t) schl) + +(* Create unique names to new type constructors. + Used for existential types and local constraints. *) +let get_new_abstract_name env s = + let name index = + if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else + Printf.sprintf "%s%d" s index + in + let check index = + match Env.find_type_by_name (Longident.Lident (name index)) env with + | _ -> false + | exception Not_found -> true + in + let index = Misc.find_first_mono check in + name index + +let new_local_type ?(loc = Location.none) ?manifest_and_scope origin = + 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 origin; + 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 name_counter ty = + let name = + match get_desc ty with + | Tvar (Some name) -> name + | _ -> + let name = Misc.letter_of_int !name_counter in + incr name_counter; + name + in + "$" ^ name + +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of Pattern_env.t + +let instance_constructor existential_treatment cstr = + For_copy.with_scope (fun copy_scope -> + let name_counter = ref 0 in + let copy_existential = + match existential_treatment with + | Keep_existentials_flexible -> copy copy_scope + | Make_existentials_abstract penv -> + fun existential -> + let env = penv.env in + let fresh_constr_scope = penv.equations_scope in + let decl = new_local_type (Existential cstr.cstr_name) in + let name = existential_name name_counter existential in + let (id, new_env) = + Env.enter_type (get_new_abstract_name env name) decl env + ~scope:fresh_constr_scope in + Pattern_env.set_env penv new_env; + let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in + let tv = copy copy_scope existential in + assert (is_Tvar tv); + link_type tv to_unify; + tv + in + let ty_ex = List.map copy_existential cstr.cstr_existentials in + let ty_res = copy copy_scope cstr.cstr_res in + let ty_args = List.map (copy copy_scope) cstr.cstr_args in + (ty_args, ty_res, ty_ex) + ) + +let instance_parameterized_type ?keep_names sch_args sch = + For_copy.with_scope (fun copy_scope -> + let ty_args = List.map (fun t -> copy ?keep_names copy_scope t) sch_args in + let ty = copy copy_scope sch in + (ty_args, ty) + ) + +let map_kind f = function + | Type_abstract r -> Type_abstract r + | 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 copy_scope -> + {decl with type_params = List.map (copy copy_scope) decl.type_params; + type_manifest = Option.map (copy copy_scope) decl.type_manifest; + type_kind = map_kind (copy 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 copy_scope = function + | Cty_constr (path, tyl, cty) -> + let tyl' = List.map (copy copy_scope) tyl in + let cty' = copy_class_type copy_scope cty in + Cty_constr (path, tyl', cty') + | Cty_signature sign -> + Cty_signature + {csig_self = copy copy_scope sign.csig_self; + csig_self_row = copy copy_scope sign.csig_self_row; + csig_vars = + Vars.map + (function (m, v, ty) -> (m, v, copy copy_scope ty)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, ty) -> (p, v, copy copy_scope ty)) + sign.csig_meths} + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, copy copy_scope ty, copy_class_type copy_scope cty) + in + For_copy.with_scope (fun copy_scope -> + let params' = List.map (copy copy_scope) params in + let cty' = copy_class_type copy_scope cty in + (params', cty') + ) + +(**** Instantiation for types with free universal variables ****) + +(* [copy_sep] is used to instantiate first-class polymorphic types. + * It first makes a separate copy of the type as a graph, omitting nodes + that have no free univars. + * In this first pass, [visited] is used as a mapping for previously visited + nodes, and must already contain all the free univars in [ty]. + * The remaining (univar-closed) parts of the type are then instantiated + with [copy] using a common [copy_scope]. + The reason to work in two passes lies in recursive types such as: + [let h (x : < m : 'a. < n : 'a; p : 'b > > as 'b) = x#m] + The type of [x#m] should be: + [ < n : 'c; p : < m : 'a. < n : 'a; p : 'b > > as 'b > ] + I.e., the universal type variable ['a] is both instantiated as a fresh + type variable ['c] when outside of its binder, and kept as universal + when under its binder. + Assumption: in the first call to [copy_sep], all the free univars should + be bound by the same [Tpoly] node. This guarantees that they are only + bound when under this [Tpoly] node, which has no free univars, and as + such is not part of the separate copy. In turn, this allows the separate + copy to keep the sharing of the original type without breaking its + binding structure. + *) +let copy_sep ~copy_scope ~fixed ~(visited : type_expr TypeHash.t) sch = + let free = compute_univars sch in + let delayed_copies = ref [] in + let add_delayed_copy t ty = + delayed_copies := + (fun () -> Transient_expr.set_stub_desc t (Tlink (copy copy_scope ty))) :: + !delayed_copies + in + let rec copy_rec ~may_share (ty : type_expr) = + let univars = free ty in + if is_Tvar ty || may_share && TypeSet.is_empty univars then + if get_level ty <> generic_level then ty else + let t = newstub ~scope:(get_scope ty) in + add_delayed_copy t ty; + t + else try + TypeHash.find visited ty + with Not_found -> begin + let t = newstub ~scope:(get_scope ty) in + TypeHash.add visited ty t; + let desc' = + match get_desc ty with + | Tvariant row -> + let more = row_more row in + (* We shall really check the level on the row variable *) + let keep = is_Tvar more && get_level more <> generic_level in + (* In that case we should keep the original, but we still + call copy to correct the levels *) + if keep then (add_delayed_copy t ty; Tvar None) else + let more' = copy_rec ~may_share:false more in + let fixed' = fixed && (is_Tvar more || is_Tunivar more) in + let row = + copy_row (copy_rec ~may_share:true) fixed' row keep more' in + Tvariant row + | Tfield (p, k, ty1, ty2) -> + (* the kind is kept shared, see Btype.copy_type_desc *) + Tfield (p, field_kind_internal_repr k, + copy_rec ~may_share:true ty1, + copy_rec ~may_share:false ty2) + | desc -> copy_type_desc (copy_rec ~may_share:true) desc + in + Transient_expr.set_stub_desc t desc'; + t + end + in + let ty = copy_rec ~may_share:true sch in + List.iter (fun force -> force ()) !delayed_copies; + ty + +let instance_poly' copy_scope ~keep_names ~fixed univars sch = + (* In order to compute univars below, [sch] should not contain [Tsubst] *) + let copy_var ty = + match get_desc ty with + Tunivar name -> if keep_names then newty (Tvar name) else newvar () + | _ -> assert false + in + let vars = List.map copy_var univars in + let visited = TypeHash.create 17 in + List.iter2 (TypeHash.add visited) univars vars; + let ty = copy_sep ~copy_scope ~fixed ~visited sch in + vars, ty + +let instance_poly ?(keep_names=false) ~fixed univars sch = + For_copy.with_scope (fun copy_scope -> + instance_poly' copy_scope ~keep_names ~fixed univars sch + ) + +let instance_label ~fixed lbl = + For_copy.with_scope (fun copy_scope -> + let vars, ty_arg = + match get_desc lbl.lbl_arg with + Tpoly (ty, tl) -> + instance_poly' copy_scope ~keep_names:false ~fixed tl ty + | _ -> + [], copy copy_scope lbl.lbl_arg + in + (* call [copy] after [instance_poly] to avoid introducing [Tsubst] *) + let ty_res = copy copy_scope lbl.lbl_res in + (vars, ty_arg, ty_res) + ) + +(**** Instantiation with parameter substitution ****) + +(* NB: since this is [unify_var], it raises [Unify], not [Unify_trace] *) +let unify_var' = (* Forward declaration *) + ref (fun _env _ty1 _ty2 -> assert false) + +let subst env level priv abbrev oty 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 oty with + | None -> fun () -> () (* No abbreviation added *) + | Some ty -> + match get_desc ty with + Tconstr (path, tl, _) -> + let abbrev = proper_abbrevs 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; + let uenv = Expression {env; in_subst = true} in + try + !unify_var' uenv body0 body'; + List.iter2 (!unify_var' uenv) params' args; + current_level := old_level; + body' + with Unify _ -> + current_level := old_level; + undo_abbrev (); + raise Cannot_subst + +(* + Default to generic level. Usually, 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 ?(use_current_level = false) env params body args = + simple_abbrevs := Mnil; + let level = if use_current_level then !current_level else generic_level in + try + subst env level Public (ref Mnil) None params args body + with + Cannot_subst -> raise Cannot_apply + + (****************************) + (* Abbreviation expansion *) + (****************************) + +(* + If the environment has changed, memorized expansions might not + be correct anymore, and so we flush the cache. The test used + checks whether any of types, modules, or local constraints have + been changed. +*) +let previous_env = ref Env.empty +(*let string_of_kind = function Public -> "public" | Private -> "private"*) +let check_abbrev_env env = + if not (Env.same_type_declarations 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 = + let path, args, abbrev = match get_desc ty with + | Tconstr (path,args,abbrev) -> path, args, abbrev + | _ -> assert false + in + check_abbrev_env env; + let level = get_level ty in + let scope = get_scope ty in + let lookup_abbrev = proper_abbrevs args abbrev in + let expansion = + (* first look for an existing expansion *) + match find_expans kind path !lookup_abbrev with + | None -> None + | Some ty' -> try + (* prerr_endline + ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) + if level <> generic_level then update_level env level ty'; + update_scope scope ty'; + Some ty' + with Escape _ -> + (* in case of Escape, discard the stale expansion and re-expand *) + forget_abbrev lookup_abbrev path; + None + in + begin match expansion with + | Some ty' -> ty' + | None -> + (* attempt to (re-)expand *) + 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 (get_scope ty) in + update_scope scope ty; + update_scope scope ty'; + ty' + end + +(* 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 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 = + match get_desc ty with + Tconstr _ -> 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.t -> type_expr -> type_expr) 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 -> 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 -> 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 + *) + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + | Has_no_typedecl + | May_have_typedecl + +let rec extract_concrete_typedecl env ty = + match get_desc ty with + Tconstr (p, _, _) -> + begin match Env.find_type p env with + | exception Not_found -> May_have_typedecl + | decl -> + if not (type_kind_is_abstract decl) then Typedecl(p, p, decl) + else begin + match try_expand_safe env ty with + | exception Cannot_expand -> May_have_typedecl + | ty -> + match extract_concrete_typedecl env ty with + | Typedecl(_, p', decl) -> Typedecl(p, p', decl) + | Has_no_typedecl -> Has_no_typedecl + | May_have_typedecl -> May_have_typedecl + end + end + | Tpoly(ty, _) -> extract_concrete_typedecl env ty + | Tarrow _ | Ttuple _ | Tobject _ | Tfield _ | Tnil + | Tvariant _ | Tpackage _ -> Has_no_typedecl + | Tvar _ | Tunivar _ -> May_have_typedecl + | Tlink _ | Tsubst _ -> assert false + +(* 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 = + match get_desc ty with + Tconstr _ -> 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 -> 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 + try expand_head_unif env ty with Unify_trace _ -> + (* #10277: forget scopes when printing trace *) + with_level ~level:(get_level ty) begin fun () -> + (* 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 -> ty + end + else expand_head env ty + in + match get_desc ty with + Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar v -> + newty2 ~level:(get_level ty) (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 + get_level body = 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} -> + get_level body = 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 ty = + if eq_type ty ty0 then raise Occur; + match get_desc ty 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 uenv ty0 ty = + let env = get_env uenv in + let allow_recursive = allow_recursive_equations uenv in + let old = !type_changed in + try + while + type_changed := false; + if not (eq_type ty0 ty) then + 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 uenv t1 t2 = + try + occur uenv t1 t2 + with Occur -> raise_for tr_exn (Rec_occur(t1, t2)) + +let occur_in env ty0 t = + try occur (Expression {env; in_subst = false}) 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;*) + if not (List.memq (get_id ty) visited) then begin + match get_desc ty 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 = get_id 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 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 = get_id ty :: visited in + iter_type_expr + (local_non_recursive_abbrev ~allow_rec true visited env p) ty + end + +let local_non_recursive_abbrev uenv p ty = + let env = get_env uenv in + let allow_rec = allow_recursive_equations uenv 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 = + List.find_map (fun (t', r) -> + if eq_type t t' then Some r else None + ) cl + in + begin match find_univ t1 cl1, find_univ t2 cl2 with + Some {contents=Some t'2}, Some _ when eq_type t2 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 = + 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 get_desc ty with + Tunivar _ -> + if not (TypeSet.mem ty bound) then + raise_escape_exn (Univ ty) + | Tpoly (ty, tyl) -> + let bound = List.fold_right TypeSet.add 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 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 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 = + if TypeSet.mem t !visited then () else begin + visited := TypeSet.add t !visited; + match get_desc t with + Tpoly (t, tl) -> + if List.exists (fun t -> TypeSet.mem 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 + 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 copy_scope ty = + match get_desc ty with + | Tvar name when get_level ty = generic_level -> + let t = newty (Tunivar name) in + For_copy.redirect_desc copy_scope 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 copy_scope -> + let vars' = List.filter_map (subst_univar copy_scope) vars in + let ty = copy copy_scope ty in + let ty = newty2 ~level:(get_level ty) (Tpoly(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 ? *) +(* That's hard to do because it relies on the expansion machinery in Ctype, + but still might be nice. *) + +let expand_type env ty = + { ty = ty; + expanded = full_expand ~may_forget_scope:true env ty } + +let expand_any_trace map env trace = + map (expand_type env) 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 + +let expand_to_unification_error env trace = + unification_error ~trace:(expand_trace env trace) + +let expand_to_equality_error env trace subst = + equality_error ~trace:(expand_trace env trace) ~subst + +let expand_to_moregen_error env trace = + moregen_error ~trace:(expand_trace env trace) + +(* [expand_trace] and the [expand_to_*_error] functions take care of most of the + expansion in this file, but we occasionally need to build [Errortrace.error]s + in other ways/elsewhere, so we expose some machinery for doing so +*) + +(* Equivalent to [expand_trace env [Diff {got; expected}]] for a single + element *) +let expanded_diff env ~got ~expected = + Diff (map_diff (expand_type env) {got; expected}) + +(* Diff while transforming a [type_expr] into an [expanded_type] without + expanding *) +let unexpanded_diff ~got ~expected = + Diff (map_diff trivial_expansion {got; expected}) + +(**** Unification ****) + +(* Return whether [t0] occurs in [ty]. Objects are also traversed. *) +let deep_occur t0 ty = + let rec occur_rec ty = + if get_level ty >= get_level t0 && try_mark_node ty then begin + if eq_type 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 + + +(* 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. + This function is called only in [Pattern] mode. *) +let reify uenv t = + let fresh_constr_scope = get_equations_scope uenv in + let create_fresh_constr lev name = + let name = match name with Some s -> "$'"^s | _ -> "$" in + let decl = new_local_type Definition in + let env = get_env uenv in + let new_name = + (* unique names are needed only for error messages *) + if in_counterexample uenv then name else get_new_abstract_name env name + in + let (id, new_env) = + Env.enter_type new_name decl env ~scope:fresh_constr_scope in + let path = Path.Pident id in + let t = newty2 ~level:lev (Tconstr (path,[],ref Mnil)) in + set_env uenv new_env; + path, t + in + let visited = ref TypeSet.empty in + let rec iterator ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty with + Tvar o -> + let level = get_level ty in + let path, t = create_fresh_constr level o in + link_type ty t; + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) + | Tvariant r -> + if not (static_row r) then begin + if is_fixed r then iterator (row_more r) else + let m = row_more r in + match get_desc m with + Tvar o -> + let level = get_level m in + let path, t = create_fresh_constr level o in + let row = + let fixed = Some (Reified path) in + create_row ~fields:[] ~more:t ~fixed + ~name:(row_name r) ~closed:(row_closed r) in + link_type m (newty2 ~level (Tvariant row)); + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) + | _ -> assert false + end; + iter_row iterator r + | _ -> + iter_type_expr iterator ty + end + in + iterator t + +let find_expansion_scope env path = + match Env.find_type path env with + | { type_manifest = None ; _ } | exception Not_found -> generic_level + | decl -> decl.type_expansion_scope + +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 + type_kind_is_abstract decl && + decl.type_private = Public && + decl.type_arity = 0 && + decl.type_manifest = None && + not (non_aliasable p decl) + with Not_found -> false + + +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 = + match get_desc ty 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 eq_type t1 t2 then () else + match (get_desc t1, get_desc t2) 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... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') 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_unexplained_for Unify + | (_, Tconstr (_, [], _)) when has_injective_univars env t1' -> + raise_unexplained_for 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 = Fpublic) in + mcomp type_pairs env rest1 rest2; + if has_present miss1 && get_desc (object_row ty2) = Tnil + || has_present miss2 && get_desc (object_row ty1) = 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 + (Fpublic, Fabsent) + | (Fabsent, Fpublic) -> raise Incompatible + | _ -> () + +and mcomp_row type_pairs env row1 row2 = + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + let cannot_erase (_,f) = + match row_field_repr f with + Rpresent _ -> true + | Rabsent | Reither _ -> false + in + if row_closed row1 && List.exists cannot_erase r2 + || row_closed row2 && 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 = + if not_marked_node ty then begin + let level = get_level ty in + if level < !lowest then lowest := level; + flip_mark_node ty; + iter_type_expr find ty + end + in find ty; unmark_type ty; !lowest + +(* This function can be called only in [Pattern] mode. *) +let add_gadt_equation uenv source destination = + (* Format.eprintf "@[add_gadt_equation %s %a@]@." + (Path.name source) !Btype.print_raw destination; *) + let env = get_env uenv in + if has_free_univars env destination then + occur_univar ~inj_only:true env destination + else if local_non_recursive_abbrev uenv source destination then begin + let destination = duplicate_type destination in + let expansion_scope = + Int.max (Path.scope source) (get_equations_scope uenv) + in + let type_origin = + match Env.find_type source env with + | decl -> type_origin decl + | exception Not_found -> assert false + in + let decl = + new_local_type + ~manifest_and_scope:(destination, expansion_scope) + type_origin + in + set_env uenv (Env.add_local_constraint source decl env); + cleanup_abbrev () + end + +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 *) +(* Code smell: this could also be put in unification_environment. + Only modified by expand_head_rigid, but the corresponding unification + environment is built in subst. *) +let rigid_variants = ref false + +let unify1_var uenv t1 t2 = + assert (is_Tvar t1); + occur_for Unify uenv t1 t2; + let env = get_env uenv in + match occur_univar_for Unify env t2 with + | () -> + begin + try + update_level env (get_level t1) t2; + update_scope (get_scope t1) t2; + with Escape e -> + raise_for Unify (Escape e) + end; + link_type t1 t2; + true + | exception Unify_trace _ when in_pattern_mode uenv -> + false + +(* Called from unify3 *) +let unify3_var uenv t1' t2 t2' = + occur_for Unify uenv t1' t2; + match occur_univar_for Unify (get_env uenv) t2 with + | () -> link_type t1' t2 + | exception Unify_trace _ when in_pattern_mode uenv -> + reify uenv t1'; + reify uenv t2'; + if can_generate_equations uenv then begin + occur_univar ~inj_only:true (get_env uenv) t2'; + record_equation uenv 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 = ]). 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 uenv t1 t2 = + (* First step: special cases (optimizations) *) + if unify_eq uenv t1 t2 then () else + let reset_tracing = check_trace_gadt_instances (get_env uenv) in + + try + type_changed := true; + begin match (get_desc t1, get_desc t2) with + (Tvar _, Tconstr _) when deep_occur t1 t2 -> + unify2 uenv t1 t2 + | (Tconstr _, Tvar _) when deep_occur t2 t1 -> + unify2 uenv t1 t2 + | (Tvar _, _) -> + if unify1_var uenv t1 t2 then () else unify2 uenv t1 t2 + | (_, Tvar _) -> + if unify1_var uenv t2 t1 then () else unify2 uenv t1 t2 + | (Tunivar _, Tunivar _) -> + unify_univar_for Unify t1 t2 !univar_pairs; + update_level_for Unify (get_env uenv) (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) + when Path.same p1 p2 + (* 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 (get_env uenv) (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + | (Tconstr _, Tconstr _) when Env.has_local_constraints (get_env uenv) -> + unify2_rec uenv t1 t1 t2 t2 + | _ -> + unify2 uenv t1 t2 + end; + reset_trace_gadt_instances reset_tracing; + with Unify_trace trace -> + reset_trace_gadt_instances reset_tracing; + raise_trace_for Unify (Diff {got = t1; expected = t2} :: trace) + +and unify2 uenv t1 t2 = unify2_expand uenv t1 t1 t2 t2 + +and unify2_rec uenv t10 t1 t20 t2 = + if unify_eq uenv t1 t2 then () else + try match (get_desc t1, get_desc t2) with + | (Tconstr (p1, tl1, a1), Tconstr (p2, tl2, a2)) -> + if Path.same p1 p2 && tl1 = [] && tl2 = [] + && not (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) + then begin + update_level_for Unify (get_env uenv) (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2 + end else + let env = get_env uenv in + if find_expansion_scope env p1 > find_expansion_scope env p2 + then unify2_rec uenv t10 t1 t20 (try_expand_safe env t2) + else unify2_rec uenv t10 (try_expand_safe env t1) t20 t2 + | _ -> + raise Cannot_expand + with Cannot_expand -> + unify2_expand uenv t10 t1 t20 t2 + +and unify2_expand uenv t1 t1' t2 t2' = + (* Second step: expansion of abbreviations *) + (* Expansion may change the representative of the types. *) + let env = get_env uenv in + 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 (get_level t1') (get_level t2') in + let scope = Int.max (get_scope t1') (get_scope t2') 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 uenv t1' t2' then () else + + 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 get_desc t1 with Tconstr (_, [], _) -> t1' | _ -> t1), + (match get_desc t2 with Tconstr (_, [], _) -> t2' | _ -> t2) + else (t1, t2) + in + if unify_eq uenv t1 t1' || not (unify_eq uenv t2 t2') then + unify3 uenv t1 t1' t2 t2' + else + try unify3 uenv t2 t2' t1 t1' with Unify_trace trace -> + raise_trace_for Unify (swap_trace trace) + +and unify3 uenv t1 t1' t2 t2' = + (* Third step: truly unification *) + (* Assumes either [t1 == t1'] or [t2 != t2'] *) + let tt1' = Transient_expr.repr t1' in + let d1 = tt1'.desc and d2 = get_desc t2' in + let create_recursion = + (not (eq_type 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 uenv t1' t2 t2' + | (_, Tvar _) -> + unify3_var uenv t2' t1 t1' + | (Tfield _, Tfield _) -> (* special case for GADTs *) + unify_fields uenv t1' t2' + | _ -> + if in_pattern_mode uenv then + add_type_equality uenv t1' t2' + else begin + occur_for Unify uenv t1' t2; + link_type t1' t2 + end; + try + begin match (d1, d2) with + (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 || + (!Clflags.classic || in_pattern_mode uenv) && + not (is_optional l1 || is_optional l2) -> + unify uenv t1 t2; unify uenv u1 u2; + begin match is_commu_ok c1, is_commu_ok c2 with + | false, true -> set_commu_ok c1 + | true, false -> set_commu_ok c2 + | false, false -> link_commu ~inside:c1 c2 + | true, true -> () + end + | (Ttuple tl1, Ttuple tl2) -> + unify_list uenv tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> + if not (can_generate_equations uenv) then + unify_list uenv tl1 tl2 + else if can_assume_injective uenv then + without_assume_injective uenv (fun uenv -> unify_list uenv tl1 tl2) + else if in_current_module p1 (* || in_pervasives p1 *) + || List.exists (expands_to_datatype (get_env uenv)) [t1'; t1; t2] + then + unify_list uenv tl1 tl2 + else + let inj = + try List.map Variance.(mem Inj) + (Env.find_type p1 (get_env uenv)).type_variance + with Not_found -> List.map (fun _ -> false) tl1 + in + List.iter2 + (fun i (t1, t2) -> + if i then unify uenv t1 t2 else + without_generating_equations uenv + begin fun uenv -> + let snap = snapshot () in + try unify uenv t1 t2 with Unify_trace _ -> + backtrack snap; + reify uenv t1; + reify uenv t2 + end) + inj (List.combine tl1 tl2) + | (Tconstr (path,[],_), + Tconstr (path',[],_)) + when let env = get_env uenv in + is_instantiable env path && is_instantiable env path' + && can_generate_equations uenv -> + let source, destination = + if Path.scope path > Path.scope path' + then path , t2' + else path', t1' + in + record_equation uenv t1' t2'; + add_gadt_equation uenv source destination + | (Tconstr (path,[],_), _) + when is_instantiable (get_env uenv) path + && can_generate_equations uenv -> + reify uenv t2'; + record_equation uenv t1' t2'; + add_gadt_equation uenv path t2' + | (_, Tconstr (path,[],_)) + when is_instantiable (get_env uenv) path + && can_generate_equations uenv -> + reify uenv t1'; + record_equation uenv t1' t2'; + add_gadt_equation uenv path t1' + | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when in_pattern_mode uenv -> + reify uenv t1'; + reify uenv t2'; + if can_generate_equations uenv then ( + mcomp_for Unify (get_env uenv) t1' t2'; + record_equation uenv t1' t2' + ) + | (Tobject (fi1, nm1), Tobject (fi2, _)) -> + unify_fields uenv fi1 fi2; + (* Type [t2'] may have been instantiated by [unify_fields] *) + (* XXX One should do some kind of unification... *) + begin match get_desc t2' with + Tobject (_, {contents = Some (_, va::_)}) when + (match get_desc va with + Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () + | Tobject (_, nm2) -> set_name nm2 !nm1 + | _ -> () + end + | (Tvariant row1, Tvariant row2) -> + if not (in_pattern_mode uenv) then + unify_row uenv row1 row2 + else begin + let snap = snapshot () in + try unify_row uenv row1 row2 + with Unify_trace _ -> + backtrack snap; + reify uenv t1'; + reify uenv t2'; + if can_generate_equations uenv then ( + mcomp_for Unify (get_env uenv) t1' t2'; + record_equation uenv t1' t2' + ) + end + | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) -> + begin match field_kind_repr kind with + Fprivate when f <> dummy_method -> + link_kind ~inside:kind field_absent; + if d2 = Tnil then unify uenv rem t2' + else unify uenv (newgenty 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 uenv t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly_for Unify (get_env uenv) univar_pairs t1 tl1 t2 tl2 + (unify uenv) + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> + begin try + unify_package (get_env uenv) (unify_list uenv) + (get_level t1) p1 fl1 (get_level t2) p2 fl2 + with Not_found -> + if not (in_pattern_mode uenv) then raise_unexplained_for Unify; + List.iter (fun (_n, ty) -> reify uenv ty) (fl1 @ fl2); + (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) + end + | (Tnil, Tconstr _ ) -> + raise_for Unify (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> + raise_for Unify (Obj (Abstract_row First)) + | (_, _) -> raise_unexplained_for Unify + end; + (* XXX Commentaires + changer "create_recursion" + ||| Comments + change "create_recursion" *) + if create_recursion then + match get_desc t2 with + Tconstr (p, tl, abbrev) -> + forget_abbrev abbrev p; + let t2'' = expand_head_unif (get_env uenv) t2 in + if not (closed_parameterized_type tl t2'') then + link_type t2 t2' + | _ -> + () (* t2 has already been expanded by update_level *) + with Unify_trace trace -> + Transient_expr.set_desc tt1' 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 get_desc ty with + Tvar None -> set_type_desc ty (Tvar name) + | _ -> () + in + let name = + match get_desc rest1, get_desc rest2 with + Tvar (Some _ as name1), Tvar (Some _ as name2) -> + if get_level rest1 <= get_level rest2 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 newty2 ~level (Tvar name) + +and unify_fields uenv 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 = get_level ty1 and l2 = get_level ty2 in + let va = make_rowvar (Int.min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in + let tr1 = Transient_expr.repr rest1 and tr2 = Transient_expr.repr rest2 in + let d1 = tr1.desc and d2 = tr2.desc in + try + unify uenv (build_fields l1 miss1 va) rest2; + unify uenv rest1 (build_fields l2 miss2 va); + List.iter + (fun (name, k1, t1, k2, t2) -> + unify_kind k1 k2; + try + if !trace_gadt_instances && not (in_subst_mode uenv) then begin + (* in_subst_mode: see PR#11771 *) + update_level_for Unify (get_env uenv) (get_level va) t1; + update_scope_for Unify (get_scope va) t1 + end; + unify uenv t1 t2 + with Unify_trace trace -> + raise_trace_for Unify + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) + ) + pairs + with exn -> + Transient_expr.set_desc tr1 d1; + Transient_expr.set_desc tr2 d2; + raise exn + +and unify_kind k1 k2 = + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fprivate) -> link_kind ~inside:k2 k1 + | (Fpublic, Fpublic) -> () + | _ -> assert false + +and unify_row uenv row1 row2 = + let Row {fields = row1_fields; more = rm1; + closed = row1_closed; name = row1_name} = row_repr row1 in + let Row {fields = row2_fields; more = rm2; + closed = row2_closed; name = row2_name} = row_repr row2 in + if unify_eq uenv rm1 rm2 then () else + let r1, r2, pairs = merge_row_fields row1_fields row2_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 get_level rm2 < get_level rm1 then rm2 else rm1 + | Some _, None -> rm1 + | None, Some _ -> rm2 + | None, None -> + newty2 ~level:(Int.min (get_level rm1) (get_level rm2)) (Tvar None) + in + let fixed = merge_fixed_explanation fixed1 fixed2 + and closed = row1_closed || row2_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_closed) && (empty r2 || row1_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_name <> None && (row1_closed || empty r2) && + (not row2_closed || keep (fun f1 f2 -> f1, f2) && empty r1) + then row1_name + else if row2_name <> None && (row2_closed || empty r1) && + (not row1_closed || keep (fun f1 f2 -> f2, f1) && empty r2) + then row2_name + else None + in + let set_more pos row rest = + let rest = + if closed then + filter_row_fields (row_closed row) rest + else rest in + begin match fixed_explanation row with + | None -> + if rest <> [] && row_closed row then + raise_for Unify (Variant (No_tags(pos,rest))) + | Some fixed -> + if closed && not (row_closed row) 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 && not (in_subst_mode uenv) then + (* in_subst_mode: see PR#11771 *) + update_level_for Unify (get_env uenv) (get_level rm) + (newgenty (Tvariant row)); + if has_fixed_explanation row then + if eq_type more rm then () else + if is_Tvar rm then link_type rm more else unify uenv rm more + else + let ty = + newgenty (Tvariant + (create_row ~fields:rest ~more ~closed ~fixed ~name)) + in + update_level_for Unify (get_env uenv) (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty; + link_type rm ty + in + let tm1 = Transient_expr.repr rm1 and tm2 = Transient_expr.repr rm2 in + let md1 = tm1.desc and md2 = tm2.desc in + begin try + set_more Second row2 r1; + set_more First row1 r2; + List.iter + (fun (l,f1,f2) -> + try unify_row_field uenv fixed1 fixed2 rm1 rm2 l f1 f2 + with Unify_trace 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 ~level:(get_level rm) Tnil) + end + with exn -> + Transient_expr.set_desc tm1 md1; + Transient_expr.set_desc tm2 md2; + raise exn + end + +and unify_row_field uenv fixed1 fixed2 rm1 rm2 l f1 f2 = + 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 row_field_repr f1, row_field_repr f2 with + Rpresent(Some t1), Rpresent(Some t2) -> unify uenv t1 t2 + | Rpresent None, Rpresent None -> () + | Reither(c1, tl1, m1), Reither(c2, tl2, m2) -> + if eq_row_field_ext f1 f2 then () else + let no_arg = c1 || c2 and matched = m1 || m2 in + if either_fixed && not no_arg + && List.length tl1 = List.length tl2 then begin + (* PR#7496 *) + let f = rf_either [] ~no_arg ~matched in + link_row_field_ext ~inside:f1 f; link_row_field_ext ~inside:f2 f; + List.iter2 (unify uenv) 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 no_arg then raise_unexplained_for Unify; + Types.changed_row_field_exts [f1;f2] (fun () -> + List.iter (unify uenv t1) tl + ) + end in + if redo then unify_row_field uenv fixed1 fixed2 rm1 rm2 l f1 f2 else + let remq tl = + List.filter (fun ty -> not (List.exists (eq_type ty) tl)) in + let tl1' = remq tl2 tl1 and tl2' = remq tl1 tl2 in + (* PR#6744 *) + let env = get_env uenv in + 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 uenv tu1) (tlu1@tlu2) + | (tu::_, []) | ([], tu::_) -> + occur_univar_for Unify env tu + end; + (* Is this handling of levels really principal? *) + let update_levels rm = + let env = get_env uenv in + List.iter + (fun ty -> + update_level_for Unify env (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty) + in + update_levels rm2 tl1'; + update_levels rm1 tl2'; + let f1' = rf_either tl2' ~no_arg ~matched in + let f2' = rf_either tl1' ~use_ext_of:f1' ~no_arg ~matched in + link_row_field_ext ~inside:f1 f1'; link_row_field_ext ~inside:f2 f2'; + | Reither(_, _, false), Rabsent -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rabsent, Reither(_, _, false) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | Rabsent, Rabsent -> () + | Reither(false, tl, _), Rpresent(Some t2) -> + if_not_fixed first (fun () -> + let s = snapshot () in + link_row_field_ext ~inside:f1 f2; + update_level_for Unify (get_env uenv) (get_level rm1) t2; + update_scope_for Unify (get_scope rm1) t2; + (try List.iter (fun t1 -> unify uenv t1 t2) tl + with exn -> undo_first_change_after s; raise exn) + ) + | Rpresent(Some t1), Reither(false, tl, _) -> + if_not_fixed second (fun () -> + let s = snapshot () in + link_row_field_ext ~inside:f2 f1; + update_level_for Unify (get_env uenv) (get_level rm2) t1; + update_scope_for Unify (get_scope rm2) t1; + (try List.iter (unify uenv t1) tl + with exn -> undo_first_change_after s; raise exn) + ) + | Reither(true, [], _), Rpresent None -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rpresent None, Reither(true, [], _) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | Rabsent, (Rpresent _ | Reither(_,_,true)) -> + raise_trace_for Unify [Variant(No_tags(First, [l,f1]))] + | (Rpresent _ | Reither (_,_,true)), Rabsent -> + raise_trace_for Unify [Variant(No_tags(Second, [l,f2]))] + | (Rpresent (Some _) | Reither(false,_,_)), + (Rpresent None | Reither(true,_,_)) + | (Rpresent None | Reither(true,_,_)), + (Rpresent (Some _) | Reither(false,_,_)) -> + (* constructor arity mismatch: 0 <> 1 *) + raise_unexplained_for Unify + | Reither(true, _ :: _, _ ), Rpresent _ + | Rpresent _ , Reither(true, _ :: _, _ ) -> + (* inconsistent conjunction on a non-absent field *) + raise_unexplained_for Unify + +let unify uenv ty1 ty2 = + let snap = Btype.snapshot () in + try + unify uenv ty1 ty2 + with + Unify_trace trace -> + undo_compress snap; + raise (Unify (expand_to_unification_error (get_env uenv) trace)) + +let unify_gadt (penv : Pattern_env.t) ty1 ty2 = + univar_pairs := []; + let equated_types = TypePairs.create 0 in + let equations_generation = Allowed { equated_types } in + let uenv = Pattern + { penv; + equations_generation; + assume_injective = true; + unify_eq_set = TypePairs.create 11; } + in + unify uenv ty1 ty2; + equated_types + +let unify_var uenv t1 t2 = + if eq_type t1 t2 then () else + match get_desc t1, get_desc t2 with + Tvar _, Tconstr _ when deep_occur t1 t2 -> + unify uenv t1 t2 + | Tvar _, _ -> + let env = get_env uenv in + let reset_tracing = check_trace_gadt_instances env in + begin try + occur_for Unify uenv t1 t2; + update_level_for Unify env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; + link_type t1 t2; + reset_trace_gadt_instances reset_tracing; + with Unify_trace trace -> + reset_trace_gadt_instances reset_tracing; + raise (Unify (expand_to_unification_error + env + (Diff { got = t1; expected = t2 } :: trace))) + end + | _ -> + unify uenv t1 t2 + +let _ = unify_var' := unify_var + +(* the final versions of unification functions *) +let unify_var env ty1 ty2 = + unify_var (Expression {env; in_subst = false}) ty1 ty2 + +let unify_pairs env ty1 ty2 pairs = + univar_pairs := pairs; + unify (Expression {env; in_subst = false}) ty1 ty2 + +let unify env ty1 ty2 = + unify_pairs env ty1 ty2 [] + +(* Lower the level of a type to the current level *) +let enforce_current_level env ty = unify_var env (newvar ()) ty + + +(**** 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 +*) + +type filter_arrow_failure = + | Unification_error of unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +let filter_arrow env t l = + let function_type level = + let t1 = newvar2 level and t2 = newvar2 level in + let t' = newty2 ~level (Tarrow (l, t1, t2, commu_ok)) in + t', t1, t2 + in + let t = + try expand_head_trace env t + with Unify_trace trace -> + let t', _, _ = function_type (get_level t) in + raise (Filter_arrow_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = t'; expected = t } :: trace)))) + in + match get_desc t with + | Tvar _ -> + let t', t1, t2 = function_type (get_level t) in + link_type t t'; + (t1, t2) + | Tarrow(l', t1, t2, _) -> + if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') + then (t1, t2) + else raise (Filter_arrow_failed + (Label_mismatch + { got = l; expected = l'; expected_type = t })) + | _ -> + raise (Filter_arrow_failed Not_a_function) + +type filter_method_failure = + | Unification_error of unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + +(* Used by [filter_method]. *) +let rec filter_method_field env name ty = + let method_type ~level = + let ty1 = newvar2 level and ty2 = newvar2 level in + let ty' = newty2 ~level (Tfield (name, field_public, ty1, ty2)) in + ty', ty1 + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let ty', _ = method_type ~level in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let ty', ty1 = method_type ~level in + link_type ty ty'; + ty1 + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + unify_kind kind field_public; + ty1 + end else + filter_method_field env name ty2 + | _ -> + raise (Filter_method_failed Not_a_method) + +(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) +let filter_method env name ty = + let object_type ~level ~scope = + let ty1 = newvar2 level in + let ty' = newty3 ~level ~scope (Tobject (ty1, ref None)) in + let ty_meth = filter_method_field env name ty1 in + (ty', ty_meth) + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let scope = get_scope ty in + let ty', _ = object_type ~level ~scope in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let scope = get_scope ty in + let ty', ty_meth = object_type ~level ~scope in + link_type ty ty'; + ty_meth + | Tobject(f, _) -> + filter_method_field env name f + | _ -> + raise (Filter_method_failed (Not_an_object ty)) + +exception Filter_method_row_failed + +let rec filter_method_row env name priv ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let field = newvar2 level in + let row = newvar2 level in + let kind, priv = + match priv with + | Private -> + let kind = field_private () in + kind, Mprivate kind + | Public -> + field_public, Mpublic + in + let ty' = newty2 ~level (Tfield (name, kind, field, row)) in + link_type ty ty'; + priv, field, row + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + let priv = + match priv with + | Public -> + unify_kind kind field_public; + Mpublic + | Private -> Mprivate kind + in + priv, ty1, ty2 + end else begin + let level = get_level ty in + let priv, field, row = filter_method_row env name priv ty2 in + let row = newty2 ~level (Tfield (n, kind, ty1, row)) in + priv, field, row + end + | Tnil -> + if name = Btype.dummy_method then raise Filter_method_row_failed + else begin + match priv with + | Public -> raise Filter_method_row_failed + | Private -> + let level = get_level ty in + let kind = field_absent in + Mprivate kind, newvar2 level, ty + end + | _ -> + raise Filter_method_row_failed + +(* Operations on class signatures *) + +let new_class_signature () = + let row = newvar () in + let self = newobj row in + { csig_self = self; + csig_self_row = row; + csig_vars = Vars.empty; + csig_meths = Meths.empty; } + +let add_dummy_method env ~scope sign = + let _, ty, row = + filter_method_row env dummy_method Private sign.csig_self_row + in + unify env ty (new_scoped_ty scope (Ttuple [])); + sign.csig_self_row <- row + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +let add_method env label priv virt ty sign = + let meths = sign.csig_meths in + let priv, virt = + match Meths.find label meths with + | (priv', virt', ty') -> begin + let priv = + match priv' with + | Mpublic -> Mpublic + | Mprivate k -> + match priv with + | Public -> + begin match field_kind_repr k with + | Fpublic -> () + | Fprivate -> link_kind ~inside:k field_public + | Fabsent -> assert false + end; + Mpublic + | Private -> priv' + in + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + match unify env ty ty' with + | () -> priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + | exception Not_found -> begin + let priv, ty', row = + match filter_method_row env label priv sign.csig_self_row with + | priv, ty', row -> + priv, ty', row + | exception Filter_method_row_failed -> + raise (Add_method_failed Unexpected_method) + in + match unify env ty ty' with + | () -> + sign.csig_self_row <- row; + priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + in + let meths = Meths.add label (priv, virt, ty) meths in + sign.csig_meths <- meths + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +let check_mutability mut mut' = + match mut, mut' with + | Mutable, Mutable -> () + | Immutable, Immutable -> () + | Mutable, Immutable | Immutable, Mutable -> + raise (Add_instance_variable_failed (Mutability_mismatch mut)) + +let add_instance_variable ~strict env label mut virt ty sign = + let vars = sign.csig_vars in + let virt = + match Vars.find label vars with + | (mut', virt', ty') -> + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + if strict then begin + check_mutability mut mut'; + match unify env ty ty' with + | () -> () + | exception Unify trace -> + raise (Add_instance_variable_failed (Type_mismatch trace)) + end; + virt + | exception Not_found -> virt + in + let vars = Vars.add label (mut, virt, ty) vars in + sign.csig_vars <- vars + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +let unify_self_types env sign1 sign2 = + let self_type1 = sign1.csig_self in + let self_type2 = sign2.csig_self in + match unify env self_type1 self_type2 with + | () -> () + | exception Unify err -> begin + match err.trace with + | Errortrace.Diff _ :: Errortrace.Incompatible_fields {name; _} :: rem -> + let err = Errortrace.unification_error ~trace:rem in + let failure = Method (name, Type_mismatch err) in + raise (Inherit_class_signature_failed failure) + | _ -> + raise (Inherit_class_signature_failed (Self_type_mismatch err)) + end + +(* Unify components of sign2 into sign1 *) +let inherit_class_signature ~strict env sign1 sign2 = + unify_self_types env sign1 sign2; + Meths.iter + (fun label (priv, virt, ty) -> + let priv = + match priv with + | Mpublic -> Public + | Mprivate kind -> + assert (field_kind_repr kind = Fabsent); + Private + in + match add_method env label priv virt ty sign1 with + | () -> () + | exception Add_method_failed failure -> + let failure = Method(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_meths; + Vars.iter + (fun label (mut, virt, ty) -> + match add_instance_variable ~strict env label mut virt ty sign1 with + | () -> () + | exception Add_instance_variable_failed failure -> + let failure = Instance_variable(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_vars + +let update_class_signature env sign = + let self = expand_head env sign.Types.csig_self in + let fields, row = flatten_fields (object_fields self) in + let meths, implicitly_public, implicitly_declared = + List.fold_left + (fun (meths, implicitly_public, implicitly_declared) (lab, k, ty) -> + if lab = dummy_method then + meths, implicitly_public, implicitly_declared + else begin + match Meths.find lab meths with + | priv, virt, ty' -> + let meths, implicitly_public = + match priv, field_kind_repr k with + | Mpublic, _ -> meths, implicitly_public + | Mprivate _, Fpublic -> + let meths = Meths.add lab (Mpublic, virt, ty') meths in + let implicitly_public = lab :: implicitly_public in + meths, implicitly_public + | Mprivate _, _ -> meths, implicitly_public + in + meths, implicitly_public, implicitly_declared + | exception Not_found -> + let meths, implicitly_declared = + match field_kind_repr k with + | Fpublic -> + let meths = Meths.add lab (Mpublic, Virtual, ty) meths in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fprivate -> + let meths = + Meths.add lab (Mprivate k, Virtual, ty) meths + in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fabsent -> meths, implicitly_declared + in + meths, implicitly_public, implicitly_declared + end) + (sign.csig_meths, [], []) fields + in + sign.csig_meths <- meths; + sign.csig_self_row <- row; + implicitly_public, implicitly_declared + +let hide_private_methods env sign = + let self = expand_head env sign.Types.csig_self in + let fields, _ = flatten_fields (object_fields self) in + List.iter + (fun (_, k, _) -> + match field_kind_repr k with + | Fprivate -> link_kind ~inside:k field_absent + | _ -> ()) + fields + +let close_class_signature env sign = + let rec close env ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + link_type ty (newty2 ~level Tnil); true + | Tfield(lab, _, _, _) when lab = dummy_method -> + false + | Tfield(_, _, _, ty') -> close env ty' + | Tnil -> true + | _ -> assert false + in + let self = expand_head env sign.csig_self in + close env (object_fields self) + +let generalize_class_signature_spine env sign = + (* Generalize the spine of methods *) + let meths = sign.csig_meths in + Meths.iter (fun _ (_, _, ty) -> generalize_spine ty) meths; + let new_meths = + Meths.map + (fun (priv, virt, ty) -> (priv, virt, generic_instance ty)) + meths + in + (* But keep levels correct on the type of self *) + Meths.iter + (fun _ (_, _, ty) -> unify_var env (newvar ()) ty) + meths; + sign.csig_meths <- new_meths + + (***********************************) + (* 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 lv = get_level ty in + if lv <= level then () else + if is_Tvar ty && lv >= 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 = + let level = get_level t1 in + if inst_nongen then level <> generic_level - 1 + else level = generic_level + +let rec moregen inst_nongen type_pairs env t1 t2 = + if eq_type t1 t2 then () else + + try + match (get_desc t1, get_desc t2) with + (Tvar _, _) when may_instantiate inst_nongen t1 -> + moregen_occur env (get_level t1) t2; + update_scope_for Moregen (get_scope t1) t2; + occur_for Moregen (Expression {env; in_subst = false}) 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... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, _) when may_instantiate inst_nongen t1' -> + moregen_occur env (get_level t1') t2; + update_scope_for Moregen (get_scope t1') 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) + (get_level t1') p1 fl1 (get_level t2') 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 trace -> + raise_trace_for Moregen (Diff {got = t1; expected = 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 (get_level ty2) miss2 rest2); + List.iter + (fun (name, 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 trace -> + raise_trace_for Moregen + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) + ) + pairs + +and moregen_kind k1 k2 = + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fpublic) -> () + | (Fpublic, Fprivate) -> raise Public_method_to_private_method + | (Fabsent, _) | (_, Fabsent) -> assert false + +and moregen_row inst_nongen type_pairs env row1 row2 = + let Row {fields = row1_fields; more = rm1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = rm2; closed = row2_closed; + fixed = row2_fixed} = row_repr row2 in + if eq_type rm1 rm2 then () else + let may_inst = + is_Tvar rm1 && may_instantiate inst_nongen rm1 || get_desc rm1 = Tnil in + let r1, r2, pairs = merge_row_fields row1_fields row2_fields in + let r1, r2 = + if row2_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_closed then begin + match row2_closed, r2 with + | false, _ -> raise_for Moregen (Variant (Openness Second)) + | _, _ :: _ -> raise_for Moregen (Variant (No_tags (First, r2))) + | _, [] -> () + end; + let md1 = get_desc rm1 (* This lets us undo a following [link_type] *) in + begin match md1, get_desc rm2 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 + (create_row ~fields:r2 ~more:rm2 ~name:None + ~fixed:row2_fixed ~closed:row2_closed)) + in + moregen_occur env (get_level rm1) ext; + update_scope_for Moregen (get_scope rm1) ext; + (* This [link_type] has to be undone if the rest of the function fails *) + link_type rm1 ext + | Tconstr _, Tconstr _ -> + moregen inst_nongen type_pairs env rm1 rm2 + | _ -> raise_unexplained_for Moregen + end; + try + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + moregen inst_nongen type_pairs env t1 t2 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both [Reither] *) + | Reither(c1, tl1, _), Reither(c2, tl2, m2) -> begin + try + if not (eq_row_field_ext f1 f2) then begin + if c1 && not c2 then raise_unexplained_for Moregen; + let f2' = + rf_either [] ~use_ext_of:f2 ~no_arg:c2 ~matched:m2 in + link_row_field_ext ~inside:f1 f2'; + 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 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + (* Generalizing [Reither] *) + | Reither(false, tl1, _), Rpresent(Some t2) when may_inst -> begin + try + link_row_field_ext ~inside:f1 f2; + List.iter + (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Reither(true, [], _), Rpresent None when may_inst -> + link_row_field_ext ~inside:f1 f2 + | Reither(_, _, _), Rabsent when may_inst -> + link_row_field_ext ~inside:f1 f2 + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) -> + raise_for Moregen (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Moregen (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Moregen (Variant (No_tags (Second, [l, f1])))) + pairs + with exn -> + (* Undo [link_type] if we failed *) + set_type_desc rm1 md1; raise exn + +(* 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_inst = instance subj_sch in + let subj = duplicate_type subj_inst in + current_level := generic_level; + (* Duplicate generic variables *) + let patt = instance pat_sch in + + Misc.try_finally + (fun () -> + try + moregen inst_nongen (TypePairs.create 13) env patt subj + with Moregen_trace trace -> + (* Moregen splits the generic level into two finer levels: + [generic_level] and [generic_level - 1]. In order to properly + detect and print weak variables when printing this error, we need to + merge them back together, by regeneralizing the levels of the types + after they were instantiated at [generic_level - 1] above. Because + [moregen] does some unification that we need to preserve for more + legible error messages, we have to manually perform the + regeneralization rather than backtracking. *) + current_level := generic_level - 2; + generalize subj_inst; + raise (Moregen (expand_to_moregen_error env trace))) + ~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 = + if try_mark_node ty then + begin match get_desc ty with + | Tvar _ -> + if not (TypeSet.mem ty !vars) then vars := TypeSet.add ty !vars + | Tvariant row -> + let Row {more; name; closed} = row_repr row in + if is_Tvar more && not (has_fixed_explanation row) then begin + let more' = newty2 ~level:(get_level more) (get_desc more) in + let row' = + create_row ~fixed:(Some Rigid) ~fields:[] ~more:more' + ~name ~closed + in link_type more (newty2 ~level:(get_level ty) (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 TypeSet.empty in + rigidify_rec vars ty; + unmark_type ty; + TypeSet.elements !vars + +let all_distinct_vars env vars = + let tys = ref TypeSet.empty in + List.for_all + (fun ty -> + let ty = expand_head env ty in + if TypeSet.mem ty !tys then false else + (tys := TypeSet.add ty !tys; is_Tvar ty)) + vars + +let matches ~expand_error_trace 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; + let diff = + if expand_error_trace + then expanded_diff env ~got:ty ~expected:ty' + else unexpanded_diff ~got:ty ~expected:ty' + in + raise (Matches_failure (env, unification_error ~trace:[diff])) + end; + backtrack snap + | exception Unify err -> + backtrack snap; + raise (Matches_failure (env, err)) + +let does_match env ty ty' = + match matches ~expand_error_trace:false 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 eqtype_subst type_pairs subst t1 t2 = + if List.exists + (fun (t,t') -> + let found1 = eq_type t1 t in + let found2 = eq_type t2 t' in + if found1 && found2 then true else + if found1 || found2 then raise_unexplained_for Equality else false) + !subst + then () + else begin + subst := (t1, t2) :: !subst; + TypePairs.add type_pairs (t1, t2) + end + +let rec eqtype rename type_pairs subst env t1 t2 = + if eq_type t1 t2 then () else + + try + match (get_desc t1, get_desc t2) with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1 t2 + | (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... *) + if eq_type t1' t2' then () else + if not (TypePairs.mem type_pairs (t1', t2')) then begin + TypePairs.add type_pairs (t1', t2'); + match (get_desc t1', get_desc t2') with + (Tvar _, Tvar _) when rename -> + eqtype_subst type_pairs subst t1' t2' + | (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) + (get_level t1') p1 fl1 (get_level t2') 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 trace -> + raise_trace_for Equality (Diff {got = t1; expected = 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 = + eq_type rest1 rest2 || TypePairs.mem type_pairs (rest1,rest2) + in + if same_row then () else + (* Try expansion, needed when called from Includecore.type_manifest *) + match get_desc (expand_head_rigid env rest2) with + 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 (name, k1, t1, k2, t2) -> + eqtype_kind k1 k2; + try + eqtype rename type_pairs subst env t1 t2; + with Equality_trace trace -> + raise_trace_for Equality + (incompatible_fields ~name ~got:t1 ~expected: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 + | (Fprivate, Fprivate) + | (Fpublic, Fpublic) -> () + | _ -> raise_unexplained_for Unify + (* It's probably not possible to hit this case with + real OCaml code *) + +and eqtype_row rename type_pairs subst env row1 row2 = + (* Try expansion, needed when called from Includecore.type_manifest *) + match get_desc (expand_head_rigid env (row_more row2)) with + Tvariant row2 -> eqtype_row rename type_pairs subst env row1 row2 + | _ -> + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + if row_closed row1 <> row_closed row2 then begin + raise_for Equality + (Variant (Openness (if row_closed row2 then First else Second))) + end; + if not (row_closed row1) 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 (row_more row1) (row_more row2); + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + eqtype rename type_pairs subst env t1 t2 + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both matching [Reither]s *) + | Reither(c1, [], _), Reither(c2, [], _) when c1 = c2 -> () + | Reither(c1, t1::tl1, _), Reither(c2, t2::tl2, _) + when c1 = c2 -> begin + try + 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 + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) + | Reither _, Reither _ -> + raise_for Equality (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Equality (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Equality (Variant (No_tags (Second, [l, f1])))) + 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 = + let subst = ref [] in + try eqtype_list rename (TypePairs.create 11) subst env tyl1 tyl2 + with Equality_trace trace -> + raise (Equality (expand_to_equality_error env trace !subst)) + +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 = + CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of int * Env.t * equality_error + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of int * Env.t * moregen_error + | CM_Val_type_mismatch of string * Env.t * comparison_error + | CM_Meth_type_mismatch of string * Env.t * comparison_error + | 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 match_class_sig_shape ~strict sign1 sign2 = + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> CM_Missing_method lab::err + | (priv', vr', _) -> + match priv', priv with + | Mpublic, Mprivate _ -> CM_Public_method lab::err + | Mprivate _, Mpublic when strict -> CM_Private_method lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Virtual_method lab::err + | _, _ -> err) + sign2.csig_meths [] + in + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + if Meths.mem lab sign2.csig_meths then err + else begin + let err = + match priv with + | Mpublic -> CM_Hide_public lab :: err + | Mprivate _ -> err + in + match vr with + | Virtual -> CM_Hide_virtual ("method", lab) :: err + | Concrete -> err + end) + sign1.csig_meths errors + in + let errors = + Vars.fold + (fun lab (mut, vr, _) err -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> CM_Missing_value lab::err + | (mut', vr', _) -> + match mut', mut with + | Immutable, Mutable -> CM_Non_mutable_value lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Non_concrete_value lab::err + | _, _ -> err) + sign2.csig_vars errors + in + 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 errors + +(* [arrow_index] is the number of [Cty_arrow] + constructors we've seen so far. *) +let rec moregen_clty ~arrow_index trace type_pairs env cty1 cty2 = + try + match cty1, cty2 with + | Cty_constr (_, _, cty1), _ -> + moregen_clty ~arrow_index true type_pairs env cty1 cty2 + | _, Cty_constr (_, _, cty2) -> + moregen_clty ~arrow_index true type_pairs env cty1 cty2 + | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 -> + let arrow_index = arrow_index + 1 in + begin + try moregen true type_pairs env ty1 ty2 with Moregen_trace trace -> + raise (Failure [ + CM_Parameter_mismatch + (arrow_index, env, expand_to_moregen_error env trace)]) + end; + moregen_clty ~arrow_index false type_pairs env cty1' cty2' + | Cty_signature sign1, Cty_signature sign2 -> + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error env trace))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error env trace))])) + sign2.csig_vars + | _ -> + raise (Failure []) + with + Failure error when trace || error = [] -> + raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) + +let moregen_clty trace type_pairs env cty1 cty2 = + moregen_clty ~arrow_index:0 trace type_pairs env cty1 cty2 + +let match_class_types ?(trace=true) env pat_sch subj_sch = + let sign1 = signature_of_class_type pat_sch in + let sign2 = signature_of_class_type subj_sch in + let errors = match_class_sig_shape ~strict:false sign1 sign2 in + match errors with + | [] -> + 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 type_pairs = TypePairs.create 53 in + let sign1 = signature_of_class_type patt in + let sign2 = signature_of_class_type subj in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + moregen true type_pairs env row1 row2; + let res = + match moregen_clty trace type_pairs env patt subj with + | () -> [] + | exception Failure res -> + (* We've found an error. Moregen splits the generic level into two + finer levels: [generic_level] and [generic_level - 1]. In order + to properly detect and print weak variables when printing this + error, we need to merge them back together, by regeneralizing the + levels of the types after they were instantiated at + [generic_level - 1] above. Because [moregen] does some + unification that we need to preserve for more legible error + messages, we have to manually perform the regeneralization rather + than backtracking. *) + current_level := generic_level - 2; + generalize_class_type subj_inst; + res + in + current_level := old_level; + res + | errors -> + CM_Class_type_mismatch (env, pat_sch, subj_sch) :: errors + +let equal_clsig trace type_pairs subst env sign1 sign2 = + try + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + 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 sign1 = signature_of_class_type patt_type in + let sign2 = signature_of_class_type subj_type in + let errors = match_class_sig_shape ~strict:true sign1 sign2 in + match errors with + | [] -> begin + try + let subst = ref [] in + let type_pairs = TypePairs.create 53 in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + eqtype true type_pairs subst env row1 row2; + 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)]); + Stdlib.List.iteri2 (fun n p s -> + try eqtype true type_pairs subst env p s with Equality_trace trace -> + raise (Failure + [CM_Type_parameter_mismatch + (n+1, env, expand_to_equality_error env trace !subst)])) + 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 get_desc ty 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 : transient_expr list) + (loops : (int * type_expr) list) posi level t = + match get_desc t with + Tvar _ -> + if posi then + try + let t' = List.assq (get_id t) loops in + warn := true; + (t', Equiv) + with Not_found -> + (t, Unchanged) + else + (t, Unchanged) + | Tarrow(l, t1, t2, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: 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', commu_ok)), c) + else (t, Unchanged) + | Ttuple tlist -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: 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' = expand_abbrev env t in + let level' = pred_expand level in + begin try match get_desc t' 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 ty1, tl1 = + match get_desc ty 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 = (get_id ty, t'') :: loops in + (* May discard [visited] as level is going down *) + let (ty1', c) = + build_subtype env [Transient_expr.repr 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 *) + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: 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 tt = Transient_expr.repr t in + if memq_warn tt visited || not (static_row row) then (t, Unchanged) else + let level' = pred_enlarge level in + let visited = + tt :: if level' < level then [] else filter_visited visited in + let fields = filter_row_fields false (row_fields row) in + let fields = + List.map + (fun (l,f as orig) -> match row_field_repr f with + Rpresent None -> + if posi then + (l, rf_either_of 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 rf_either_of (Some t') + else rf_present (Some t') + in (l, f), c + | _ -> assert false) + fields + in + let c = collect fields in + let row = + create_row ~fields:(List.map fst fields) ~more:(newvar ()) + ~closed:posi ~fixed:None + ~name:(if c > Unchanged then None else row_name row) + in + (newty (Tvariant row), Changed) + | Tobject (t1, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited || opened_object t1 then (t, Unchanged) else + let level' = pred_enlarge level in + let visited = + tt :: 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, field_public, 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 ~unification_trace = + raise (Subtype (Subtype.error + ~trace:(expand_subtype_trace env (List.rev trace)) + ~unification_trace)) + +let rec subtype_rec env trace t1 t2 cstrs = + if eq_type t1 t2 then cstrs else + + if TypePairs.mem subtypes (t1, t2) then + cstrs + else begin + TypePairs.add subtypes (t1, t2); + match (get_desc t1, get_desc t2) 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 {got = t2; expected = t1} :: trace) + t2 t1 + cstrs + in + subtype_rec + env + (Subtype.Diff {got = u1; expected = 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 ~level:(get_level t1) (Ttuple[t1]), + newty2 ~level:(get_level t2) (Ttuple[t2]), !univar_pairs) + :: cstrs + else + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + else + if cn + then + subtype_rec + env + (Subtype.Diff {got = t2; expected = 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 ~fixed: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 (get_level t1) (Mty_ident p1) fl1 + and ntl2 = + complete_type_list env fl1 (get_level t2) (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 ~unification_trace:[]; + List.fold_left2 + (fun cstrs t1 t2 -> + subtype_rec + env + (Subtype.Diff { got = t1; expected = 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 get_desc rest2 = Tnil then cstrs else + if miss1 = [] then + subtype_rec + env + (Subtype.Diff {got = rest1; expected = rest2} :: trace) + rest1 rest2 + cstrs + else + (trace, build_fields (get_level ty1) miss1 rest1, rest2, + !univar_pairs) :: cstrs + in + let cstrs = + if miss2 = [] then cstrs else + (trace, rest1, build_fields (get_level ty2) 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 {got = t1; expected = t2} :: trace) + t1 t2 + cstrs) + cstrs pairs + +and subtype_row env trace row1 row2 cstrs = + let Row {fields = row1_fields; more = more1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = more2; closed = row2_closed} = + row_repr row2 in + let r1, r2, pairs = + merge_row_fields row1_fields row2_fields in + let r1 = if row2_closed then filter_row_fields false r1 else r1 in + let r2 = if row1_closed then filter_row_fields false r2 else r2 in + match get_desc more1, get_desc more2 with + Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> + subtype_rec + env + (Subtype.Diff {got = more1; expected = more2} :: trace) + more1 more2 + cstrs + | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) + when row1_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 {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Reither(false, t1::_, _), Rpresent(Some t2) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Rabsent, _ -> cstrs + | _ -> raise Exit) + cstrs pairs + | Tunivar _, Tunivar _ + when row1_closed = row2_closed && r1 = [] && r2 = [] -> + let cstrs = + subtype_rec + env + (Subtype.Diff {got = more1; expected = 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 {got = t1; expected = 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 {got = ty1; expected = ty2}] ty1 ty2 [] + in + TypePairs.clear subtypes; + (* Enforce constraints. *) + function () -> + List.iter + (function (trace0, t1, t2, pairs) -> + try unify_pairs env t1 t2 pairs with Unify {trace} -> + subtype_error ~env ~trace:trace0 ~unification_trace:(List.tl trace)) + (List.rev cstrs) + + (*******************) + (* Miscellaneous *) + (*******************) + +(* Utility for printing. The resulting type is not used in computation. *) +let rec unalias_object ty = + let level = get_level ty in + match get_desc ty with + Tfield (s, k, t1, t2) -> + newty2 ~level (Tfield (s, k, t1, unalias_object t2)) + | Tvar _ | Tnil as desc -> + newty2 ~level desc + | Tunivar _ -> + ty + | Tconstr _ -> + newvar2 level + | _ -> + assert false + +let unalias ty = + let level = get_level ty in + match get_desc ty with + Tvar _ | Tunivar _ -> + ty + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + newty2 ~level + (Tvariant + (create_row ~fields ~name ~fixed ~closed ~more: + (newty2 ~level:(get_level more) (get_desc more)))) + | Tobject (ty, nm) -> + newty2 ~level (Tobject (unalias_object ty, nm)) + | desc -> + newty2 ~level desc + +(* Return the arity (as for curried functions) of the given type. *) +let rec arity ty = + match get_desc ty with + Tarrow(_, _t1, t2, _) -> 1 + arity t2 + | _ -> 0 + +(* Check for non-generalizable type variables *) +let add_nongen_vars_in_schema = + let rec loop env ((visited, weak_set) as acc) ty = + if TypeSet.mem ty visited + then acc + else begin + let visited = TypeSet.add ty visited in + match get_desc ty with + | Tvar _ when get_level ty <> generic_level -> + visited, TypeSet.add ty weak_set + | Tconstr _ -> + let (_, unexpanded_candidate) as unexpanded_candidate' = + fold_type_expr + (loop env) + (visited, weak_set) + ty + in + (* Using `==` is okay because `loop` will return the original set + when it does not change it. Similarly, `TypeSet.add` will return + the original set if the element is already present. *) + if unexpanded_candidate == weak_set + then (visited, weak_set) + else begin + match + loop env (visited, weak_set) + (try_expand_head try_expand_safe env ty) + with + | exception Cannot_expand -> unexpanded_candidate' + | expanded_result -> expanded_result + end + | Tfield(_, kind, t1, t2) -> + let visited, weak_set = + match field_kind_repr kind with + | Fpublic -> loop env (visited, weak_set) t1 + | _ -> visited, weak_set + in + loop env (visited, weak_set) t2 + | Tvariant row -> + let visited, weak_set = + fold_row (loop env) (visited, weak_set) row + in + if not (static_row row) + then loop env (visited, weak_set) (row_more row) + else (visited, weak_set) + | _ -> + fold_type_expr (loop env) (visited, weak_set) ty + end + in + fun env acc ty -> + let _, result = loop env (TypeSet.empty, acc) ty in + result + +(* Return all non-generic variables of [ty]. *) +let nongen_vars_in_schema env ty = + let result = add_nongen_vars_in_schema env TypeSet.empty ty in + if TypeSet.is_empty result + then None + else Some result + +(* Check that all type variables are generalizable *) +(* Use Env.empty to prevent expansion of recursively defined object types; + cf. typing-poly/poly.ml *) +let nongen_class_type = + let add_nongen_vars_in_schema' ty weak_set = + add_nongen_vars_in_schema Env.empty weak_set ty + in + let add_nongen_vars_in_schema_fold fold m weak_set = + let f _key (_,_,ty) weak_set = + add_nongen_vars_in_schema Env.empty weak_set ty + in + fold f m weak_set + in + let rec nongen_class_type cty weak_set = + match cty with + | Cty_constr (_, params, _) -> + List.fold_left + (add_nongen_vars_in_schema Env.empty) + weak_set + params + | Cty_signature sign -> + weak_set + |> add_nongen_vars_in_schema' sign.csig_self + |> add_nongen_vars_in_schema' sign.csig_self_row + |> add_nongen_vars_in_schema_fold Meths.fold sign.csig_meths + |> add_nongen_vars_in_schema_fold Vars.fold sign.csig_vars + | Cty_arrow (_, ty, cty) -> + add_nongen_vars_in_schema' ty weak_set + |> nongen_class_type cty + in + nongen_class_type + +let nongen_class_declaration cty = + List.fold_left + (add_nongen_vars_in_schema Env.empty) + TypeSet.empty + cty.cty_params + |> nongen_class_type cty.cty_type + +let nongen_vars_in_class_declaration cty = + let result = nongen_class_declaration cty in + if TypeSet.is_empty result + then None + else Some result + +(* Normalize a type before printing, saving... *) +(* Cannot use mark_type because deep_occur uses it too *) +let rec normalize_type_rec visited ty = + 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 get_desc tm 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 get_desc ty with + | Tvariant row -> + let Row {fields = orig_fields; more; name; fixed; closed} = + row_repr row in + let fields = List.map + (fun (l,f) -> + l, + match row_field_repr f with Reither(b, ty::(_::_ as tyl), m) -> + let tyl' = + List.fold_left + (fun tyl ty -> + if List.exists + (fun ty' -> is_equal Env.empty false [ty] [ty']) + tyl + then tyl + else ty::tyl) + [ty] tyl + in + if List.length tyl' <= List.length tyl then + rf_either (List.rev tyl') ~use_ext_of:f ~no_arg:b ~matched:m + else f + | _ -> f) + orig_fields in + let fields = + List.sort (fun (p,_) (q,_) -> compare p q) + (List.filter (fun (_,fi) -> row_field_repr fi <> Rabsent) fields) in + set_type_desc ty (Tvariant + (create_row ~fields ~more ~name ~fixed ~closed)) + | 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 + begin match get_desc v with + | Tvar _ | Tunivar _ -> () + | Tnil -> set_type_desc ty (Tconstr (n, l, ref Mnil)) + | _ -> set_name nm None + end + | _ -> + fatal_error "Ctype.normalize_type_rec" + end; + let level = get_level fi in + if level < lowest_level then () else + let fields, row = flatten_fields fi in + let fi' = build_fields level fields row in + set_type_desc fi (get_desc fi') + | _ -> () + 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 get_desc ty with + Tvar _ | Tunivar _ -> ty + | _ -> try TypeHash.find nondep_hash ty + with Not_found -> + let ty' = newgenstub ~scope:(get_scope ty) in + TypeHash.add nondep_hash ty ty'; + match + match get_desc ty with + | Tconstr(p, tl, _abbrev) as desc -> + 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 ~level:(get_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 more = row_more row 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_name row with + Some (p, _tl) when Path.exists_free ids p -> + Tvariant (set_row_name row None) + | _ -> Tvariant row + end + | desc -> copy_type_desc (nondep_type_rec env ids) desc + with + | desc -> + Transient_expr.set_stub_desc ty' desc; + ty' + | exception e -> + TypeHash.remove nondep_hash ty; + raise e + +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 Definition + 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 get_desc ty' 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_self_row = nondep_type_rec env id sign.csig_self_row; + csig_vars = + Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) + sign.csig_vars; + csig_meths = + Meths.map (function (p, v, t) -> (p, v, nondep_type_rec env id t)) + sign.csig_meths } + +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_hash_type = nondep_type_decl env ids false decl.clty_hash_type ; + 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 id = get_id ty in + if List.memq id visited then () else + let visited = id :: visited in + match get_desc ty with + Tvariant row -> + List.iter + (fun (_l,fi) -> + match row_field_repr fi with + Reither (_c, t1::(_::_ as tl), _m) -> + List.iter (unify env t1) tl + | _ -> + ()) + (row_fields row); + 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 get_desc t1, get_desc t2 with + | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2 + | _ -> false + +let () = + Env.same_constr := same_constr + +let immediacy env typ = + match get_desc typ 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 -> + (* if all labels are devoid of arguments, not a pointer *) + if + not (row_closed row) + || List.exists + (fun (_, f) -> match row_field_repr f with + | Rpresent (Some _) | Reither (false, _, _) -> true + | _ -> false) + (row_fields row) + then + Type_immediacy.Unknown + else + Type_immediacy.Always + | _ -> Type_immediacy.Unknown diff --git a/upstream/ocaml_502/typing/ctype.mli b/upstream/ocaml_502/typing/ctype.mli new file mode 100644 index 0000000000..78d991facf --- /dev/null +++ b/upstream/ocaml_502/typing/ctype.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. *) +(* *) +(**************************************************************************) + +(* Operations on core types *) + +open Asttypes +open Types + +exception Unify of Errortrace.unification_error +exception Equality of Errortrace.equality_error +exception Moregen of Errortrace.moregen_error +exception Subtype of Errortrace.Subtype.error + +exception Escape of type_expr Errortrace.escape + +exception Tags of label * label +exception Cannot_expand +exception Cannot_apply +exception Matches_failure of Env.t * Errortrace.unification_error + (* Raised from [matches], hence the odd name *) +exception Incompatible + (* Raised from [mcomp] *) + +(* All the following wrapper functions revert to the original level, + even in case of exception. *) +val with_local_level: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* [with_local_level (fun () -> cmd) ~post] evaluates [cmd] at a + raised level. + If given, [post] is applied to the result, at the original level. + It is expected to contain only level related post-processing. *) +val with_local_level_if: bool -> (unit -> 'a) -> post:('a -> unit) -> 'a + (* Same as [with_local_level], but only raise the level conditionally. + [post] also is only called if the level is raised. *) +val with_local_level_iter: (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Variant of [with_local_level], where [post] is iterated on the + returned list. *) +val with_local_level_iter_if: + bool -> (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Conditional variant of [with_local_level_iter] *) +val with_level: level: int -> (unit -> 'a) -> 'a + (* [with_level ~level (fun () -> cmd)] evaluates [cmd] with + [current_level] set to [level] *) +val with_level_if: bool -> level: int -> (unit -> 'a) -> 'a + (* Conditional variant of [with_level] *) +val with_local_level_if_principal: (unit -> 'a) -> post:('a -> unit) -> 'a +val with_local_level_iter_if_principal: + (unit -> 'a * 'b list) -> post:('b -> unit) -> 'a + (* Applications of [with_local_level_if] and [with_local_level_iter_if] + to [!Clflags.principal] *) + +val with_local_level_for_class: ?post:('a -> unit) -> (unit -> 'a) -> 'a + (* Variant of [with_local_level], where the current level is raised but + the nongen level is not touched *) +val with_raised_nongen_level: (unit -> 'a) -> 'a + (* Variant of [with_local_level], + raises the nongen level to the current level *) + +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 *) + +val create_scope : unit -> int + +val newty: type_desc -> type_expr +val new_scoped_ty: int -> 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 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 set_object_name: + Ident.t -> type_expr list -> type_expr -> unit +val remove_object_name: 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 lower_variables_only: Env.t -> int -> type_expr -> unit + (* Lower all variables to the given level *) +val enforce_current_level: Env.t -> type_expr -> unit + (* Lower whole type to !current_level *) +val generalize_structure: type_expr -> unit + (* Generalize the structure of a type, lowering variables + to !current_level *) +val generalize_class_type : class_type -> unit + (* Generalize the components of a class type *) +val generalize_class_type_structure : class_type -> unit + (* Generalize the structure of the components of a class type *) +val generalize_class_signature_spine : Env.t -> class_signature -> unit + (* Special function to generalize methods 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 limited_generalize_class_type: type_expr -> class_type -> unit + (* Same, but for class types *) + +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) -> + type_origin -> type_declaration + +module Pattern_env : sig + type t = private + { mutable env : Env.t; + equations_scope : int; + (* scope for local type declarations *) + allow_recursive_equations : bool; + (* true iff checking counter examples *) + } + val make: Env.t -> equations_scope:int -> allow_recursive_equations:bool -> t + val copy: ?equations_scope:int -> t -> t + val set_env: t -> Env.t -> unit +end + +type existential_treatment = + | Keep_existentials_flexible + | Make_existentials_abstract of Pattern_env.t + +val instance_constructor: existential_treatment -> + 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_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 -> fixed: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: + fixed:bool -> + label_description -> type_expr list * type_expr * type_expr + (* Same, for a label *) +val apply: + ?use_current_level:bool -> + Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr + (* [apply [p1...pN] t [a1...aN]] applies the type function + [fun p1 ... pN -> t] to the arguments [a1...aN] and returns the + resulting instance of [t]. + New nodes default to generic level except if [use_current_level] is + set to true. + 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. *) + +(** Expansion of types for error traces; lives here instead of in [Errortrace] + because the expansion machinery lives here. *) + +(** Create an [Errortrace.Diff] by expanding the two types *) +val expanded_diff : + Env.t -> + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +(** Create an [Errortrace.Diff] by *duplicating* the two types, so that each + one's expansion is identical to itself. Despite the name, does create + [Errortrace.expanded_type]s. *) +val unexpanded_diff : + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +val full_expand: may_forget_scope:bool -> Env.t -> type_expr -> type_expr + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + (* The original path of the types, and the first concrete + type declaration found expanding it. *) + | Has_no_typedecl + | May_have_typedecl + +val extract_concrete_typedecl: + Env.t -> type_expr -> typedecl_extraction_result + +val unify: Env.t -> type_expr -> type_expr -> unit + (* Unify the two types given. Raise [Unify] if not possible. *) +val unify_gadt: + Pattern_env.t -> type_expr -> type_expr -> Btype.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]. Raises + [Filter_arrow_failed] instead of [Unify]. *) +val filter_method: Env.t -> string -> type_expr -> type_expr + (* A special case of unification (with {m : 'a; 'b}). Raises + [Filter_method_failed] instead of [Unify]. *) +val occur_in: Env.t -> type_expr -> type_expr -> bool +val deep_occur: type_expr -> type_expr -> bool +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: expand_error_trace:bool -> Env.t -> type_expr -> type_expr -> unit + (* Same as [moregeneral false], implemented using the two above + functions and backtracking. Ignore levels. The [expand_error_trace] + flag controls whether the error raised performs expansion; this + should almost always be [true]. *) +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. *) + +(* Exceptions for special cases of unify *) + +type filter_arrow_failure = + | Unification_error of Errortrace.unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +type filter_method_failure = + | Unification_error of Errortrace.unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + +type class_match_failure = + CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of int * Env.t * Errortrace.equality_error + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of int * Env.t * Errortrace.moregen_error + | CM_Val_type_mismatch of string * Env.t * Errortrace.comparison_error + | CM_Meth_type_mismatch of string * Env.t * Errortrace.comparison_error + | 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. *) + +(* Operations on class signatures *) + +val new_class_signature : unit -> class_signature +val add_dummy_method : Env.t -> scope:int -> class_signature -> unit + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +val add_method : Env.t -> + label -> private_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +val add_instance_variable : strict:bool -> Env.t -> + label -> mutable_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +val inherit_class_signature : strict:bool -> Env.t -> + class_signature -> class_signature -> unit + +val update_class_signature : + Env.t -> class_signature -> label list * label list + +val hide_private_methods : Env.t -> class_signature -> unit + +val close_class_signature : Env.t -> class_signature -> bool + +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 nongen_vars_in_schema: Env.t -> type_expr -> Btype.TypeSet.t option + (* Return any non-generic variables in the type scheme *) + +val nongen_vars_in_class_declaration:class_declaration -> Btype.TypeSet.t option + (* Return any non-generic variables in the class type. + Uses the empty environment. *) + +type variable_kind = Row_variable | Type_variable +type closed_class_failure = { + free_variable: type_expr * variable_kind; + meth: string; + meth_ty: type_expr; +} + +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 +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 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 immediacy : Env.t -> type_expr -> Type_immediacy.t + +(* 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_502/typing/datarepr.ml b/upstream/ocaml_502/typing/datarepr.ml new file mode 100644 index 0000000000..9213fe8337 --- /dev/null +++ b/upstream/ocaml_502/typing/datarepr.ml @@ -0,0 +1,238 @@ +(**************************************************************************) +(* *) +(* 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 = + if try_mark_node ty then + match get_desc ty with + | Tvar _ -> + ret := TypeSet.add ty !ret + | Tvariant row -> + iter_row loop row; + if not (static_row row) then begin + match get_desc (row_more row) with + | Tvar _ when param -> ret := TypeSet.add ty !ret + | _ -> loop (row_more row) + 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 in + List.iter + (fun {cd_args; _} -> + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts) + 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.(Pextra_ty (ty_path, Pcstr_ty 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_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.(Pextra_ty (path_ext, Pext_ty)) (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_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 = + create_expr (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_502/typing/datarepr.mli b/upstream/ocaml_502/typing/datarepr.mli new file mode 100644 index 0000000000..38f05f74f0 --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/env.ml b/upstream/ocaml_502/typing/env.ml new file mode 100644 index 0000000000..5748afd8dc --- /dev/null +++ b/upstream/ocaml_502/typing/env.ml @@ -0,0 +1,3717 @@ +(**************************************************************************) +(* *) +(* 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 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 is_mutating_label_usage = function + | Mutation -> true + | (Projection | Construct | Exported_private | Exported) -> false + +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 find_all_idents name tbl () = + let current = + Ident.find_all_seq name tbl.current + |> Seq.map (fun (id, _) -> Some id) + in + let next () = + match tbl.layer with + | Nothing -> Seq.Nil + | Open { next; components; _ } -> + if NameMap.mem name components then + Seq.Cons(None, find_all_idents name next) + else + find_all_idents name next () + | Map {next; _ } -> find_all_idents name next () + in + Seq.append current 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_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_prefixing_subst: Subst.t; + cm_path: Path.t; + cm_addr: address_lazy; + cm_mty: Subst.Lazy.modtype; + cm_shape: Shape.t; +} + +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_shape: Shape.t; + 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; + vda_shape : Shape.t } + +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; + cda_shape: Shape.t; } + +and label_data = label_description + +and type_data = + { tda_declaration : type_declaration; + tda_descriptions : type_descriptions; + tda_shape : Shape.t; } + +and module_data = + { mda_declaration : Subst.Lazy.module_decl; + mda_components : module_components; + mda_address : address_lazy; + mda_shape: Shape.t; } + +and module_entry = + | Mod_local of module_data + | Mod_persistent + | Mod_unbound of module_unbound_reason + +and modtype_data = + { mtda_declaration : Subst.Lazy.modtype_declaration; + mtda_shape : Shape.t; } + +and class_data = + { clda_declaration : class_declaration; + clda_address : address_lazy; + clda_shape : Shape.t } + +and cltype_data = + { cltda_declaration : class_type_declaration; + cltda_shape : Shape.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_type_declarations e1 e2 = + e1.types == e2.types && + e1.modules == e2.modules && + e1.local_constraints == e2.local_constraints + +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 (Val_unbound _, _)) -> None + | `Value (Some (_, _)) -> Some "value" + | `Type (Some _) -> Some "type" + | `Module (Some (Mod_unbound _, _)) -> None + | `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 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_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, _)} -> begin + match p with + | Pident _ -> true + | Pdot _ | Papply _ | Pextra_ty _ -> false + end + | _ -> 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 -> Subst.Lazy.modtype -> + Path.t -> Subst.Lazy.modtype) + +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 _ | Pextra_ty _ -> 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 ps path addr mty shape = + { + alerts; + uid; + comps = Lazy_backtrack.create { + cm_env = env; + cm_prefixing_subst = ps; + cm_path = path; + cm_addr = addr; + cm_mty = mty; + cm_shape = shape; + } + } + +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 = + Subst.(Lazy.module_decl Make_local identity (Lazy.of_module_decl md)) + in + let mda_shape = Shape.for_persistent_unit name in + let mda_components = + let mty = Subst.Lazy.of_modtype (Mty_signature sign) in + let mty = + if freshen then + Subst.Lazy.modtype (Subst.Rescope (Path.scope path)) + Subst.identity mty + else mty + in + components_of_module ~alerts ~uid:md.md_uid + empty Subst.identity + path mda_address mty mda_shape + in + { + mda_declaration; + mda_components; + mda_address; + mda_shape; + } + +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 cmi = + Persistent_env.read !persistent_env read_sign_of_cmi cmi + +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 ~allow_hidden:true (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 + | Pextra_ty _ -> raise Not_found + +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 + Subst.Lazy.force_module_decl data.mda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + Subst.Lazy.force_module_decl 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) + | Pextra_ty _ -> raise Not_found + +let find_module_lazy ~alias path env = + match path with + | Pident id -> + let data = find_ident_module id env in + data.mda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + let data = NameMap.find s sc.comp_modules in + data.mda_declaration + | Papply(p1, p2) -> + let fc = find_functor_components p1 env in + let md = + if alias then md (fc.fcomp_res) + else md (modtype_of_functor_appl fc p1 p2) + in + Subst.Lazy.of_module_decl md + | Pextra_ty _ -> raise Not_found + +let find_strengthened_module ~aliasable path env = + let md = find_module_lazy ~alias:true path env in + let mty = !strengthen ~aliasable env md.mdl_type path in + Subst.Lazy.force_modtype mty + +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 _ | Pextra_ty _ -> raise Not_found + +let find_extension_full path env = + match path with + | Pident id -> TycompTbl.find_same id env.constrs + | Pdot(p, s) -> begin + let comps = find_structure_components p env in + let cstrs = NameMap.find s comps.comp_constrs in + let exts = List.filter is_ext cstrs in + match exts with + | [cda] -> cda + | _ -> raise Not_found + end + | Papply _ | Pextra_ty _ -> raise Not_found + +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); + tda_shape = Shape.leaf decl.type_uid; + } + | _ -> assert false + end + | _ -> assert false + +let rec find_type_data path env = + match Path.Map.find path env.local_constraints with + | decl -> + { + tda_declaration = decl; + tda_descriptions = Type_abstract (Btype.type_origin decl); + tda_shape = Shape.leaf decl.type_uid; + } + | exception Not_found -> begin + 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 + | Pextra_ty (p, extra) -> begin + match extra with + | Pcstr_ty s -> + let cstr = find_cstr p s env in + type_of_cstr path cstr + | Pext_ty -> + let cda = find_extension_full p env in + type_of_cstr path cda.cda_description + end + end +and find_cstr path name env = + let tda = find_type_data path env in + match tda.tda_descriptions with + | Type_variant (cstrs, _) -> + List.find (fun cstr -> cstr.cstr_name = name) cstrs + | Type_record _ | Type_abstract _ | Type_open -> raise Not_found + + + +let find_modtype_lazy path env = + match path with + | Pident id -> (IdTbl.find_same id env.modtypes).mtda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_modtypes).mtda_declaration + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_modtype path env = + Subst.Lazy.force_modtype_decl (find_modtype_lazy path env) + +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 _ | Pextra_ty _ -> raise Not_found + +let find_cltype path env = + match path with + | Pident id -> (IdTbl.find_same id env.cltypes).cltda_declaration + | Pdot(p, s) -> + let sc = find_structure_components p env in + (NameMap.find s sc.comp_cltypes).cltda_declaration + | Papply _ | Pextra_ty _ -> 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 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 _ | Pextra_ty _ -> 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 _ | Pextra_ty _ -> raise Not_found + +let find_hash_type path env = + match path with + | Pident id -> + let name = Ident.name id in + let _, cltda = + IdTbl.find_name wrap_identity ~mark:false name env.cltypes + in + cltda.cltda_declaration.clty_hash_type + | Pdot(p, name) -> + let c = find_structure_components p env in + let cltda = NameMap.find name c.comp_cltypes in + cltda.cltda_declaration.clty_hash_type + | Papply _ | Pextra_ty _ -> raise Not_found + +let find_shape env (ns : Shape.Sig_component_kind.t) id = + match ns with + | Type -> + (IdTbl.find_same id env.types).tda_shape + | Constructor -> + Shape.leaf ((TycompTbl.find_same id env.constrs).cda_description.cstr_uid) + | Label -> + Shape.leaf ((TycompTbl.find_same id env.labels).lbl_uid) + | Extension_constructor -> + (TycompTbl.find_same id env.constrs).cda_shape + | Value -> + begin match IdTbl.find_same id env.values with + | Val_bound x -> x.vda_shape + | Val_unbound _ -> raise Not_found + end + | Module -> + begin match IdTbl.find_same id env.modules with + | Mod_local { mda_shape; _ } -> mda_shape + | Mod_persistent -> Shape.for_persistent_unit (Ident.name id) + | Mod_unbound _ -> + (* Only present temporarily while approximating the environment for + recursive modules. + [find_shape] is only ever called after the environment gets + properly populated. *) + assert false + | exception Not_found + when Ident.persistent id && not (Current_unit_name.is_ident id) -> + Shape.for_persistent_unit (Ident.name id) + end + | Module_type -> + (IdTbl.find_same id env.modtypes).mtda_shape + | Class -> + (IdTbl.find_same id env.classes).clda_shape + | Class_type -> + (IdTbl.find_same id env.cltypes).cltda_shape + +let shape_of_path ~namespace env = + Shape.of_path ~namespace ~find_shape:(find_shape env) + +let shape_or_leaf uid = function + | None -> Shape.leaf uid + | Some shape -> shape + +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 + | Pextra_ty _ -> assert false + +and expand_module_path lax env path = + try match find_module_lazy ~alias:true path env with + {mdl_type=MtyL_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 rec 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 + | Pextra_ty (p, extra) -> + let p2 = normalize_path_prefix oloc env p in + if p == p2 then path else Pextra_ty (p2, extra) + | Papply _ -> + assert false + +let normalize_type_path = normalize_path_prefix + +let normalize_value_path = normalize_path_prefix + +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_lazy path env).mtdl_type with + | Some (MtyL_ident path) -> normalize_modtype_path env path + | _ | exception Not_found -> path + +let find_module path env = + find_module ~alias:false path env + +let find_module_lazy path env = + find_module_lazy ~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 + || not (Btype.type_kind_is_abstract decl) + || 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_lazy path env = + match (find_modtype_lazy path env).mtdl_type with + | None -> raise Not_found + | Some mty -> mty + +let find_modtype_expansion path env = + Subst.Lazy.force_modtype (find_modtype_expansion_lazy path env) + +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, _) | Pextra_ty (p, _) -> 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 (get_id t) + with Not_found -> + let t2 = Subst.type_expr Subst.identity t in + Hashtbl.add memo (get_id t) 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} + ) + +(* 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 mty = + let open Subst.Lazy in + match mty with + | MtyL_alias path -> begin + match 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 (find_module_lazy path env).mdl_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; _ } -> + scrape_alias_for_visit env 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 -> String.Set.add s r) + String.Set.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 _ | Pextra_ty _ -> [] + +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 _ | Pextra_ty _ -> [] + +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 ?path mty = + let open Subst.Lazy in + match mty, path with + MtyL_ident p, _ -> + begin try + scrape_alias env (find_modtype_expansion_lazy p env) ?path + with Not_found -> + mty + end + | MtyL_alias path, _ -> + begin try + scrape_alias env ((find_module_lazy path env).mdl_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 prefixing_sub sg = + let open Subst.Lazy in + let rec prefix_idents root items_and_paths prefixing_sub = + function + | [] -> (List.rev items_and_paths, prefixing_sub) + | SigL_value(id, _, _) as item :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((item, p) :: items_and_paths) prefixing_sub rem + | SigL_type(id, td, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_type(id, td, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_typext(id, ec, es, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + (* we extend the substitution in case of an inlined record *) + prefix_idents root + ((SigL_typext(id, ec, es, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_module(id, pres, md, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_module(id, pres, md, rs, vis), p) :: items_and_paths) + (Subst.add_module id p prefixing_sub) + rem + | SigL_modtype(id, mtd, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_modtype(id, mtd, vis), p) :: items_and_paths) + (Subst.add_modtype id (Mty_ident p) prefixing_sub) + rem + | SigL_class(id, cd, rs, vis) :: rem -> + (* pretend this is a type, cf. PR#6650 *) + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_class(id, cd, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + | SigL_class_type(id, ctd, rs, vis) :: rem -> + let p = Pdot(root, Ident.name id) in + prefix_idents root + ((SigL_class_type(id, ctd, rs, vis), p) :: items_and_paths) + (Subst.add_type id p prefixing_sub) + rem + in + let sg = Subst.Lazy.force_signature_once sg in + prefix_idents root [] 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 + let open Subst.Lazy in + match md.mdl_type with + | MtyL_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_prefixing_subst; + cm_path; cm_addr; cm_mty; cm_shape} : _ result = + match scrape_alias cm_env cm_mty with + MtyL_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, sub = + prefix_idents cm_path 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 + List.iter (fun ((item : Subst.Lazy.signature_item), path) -> + match item with + SigL_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_shape = Shape.proj cm_shape (Shape.Item.value id) in + let vda = + { vda_description = decl'; vda_address = addr; vda_shape } + in + c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values; + | SigL_type(id, decl, _, _) -> + let final_decl = Subst.type_declaration sub decl in + Btype.set_static_row_name final_decl + (Subst.type_path 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_shape = Shape.leaf descr.cstr_uid in + let cda = { + cda_description = descr; + cda_address = None; + cda_shape } + 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 r -> Type_abstract r + | Type_open -> Type_open + in + let shape = Shape.proj cm_shape (Shape.Item.type_ id) in + let tda = + { tda_declaration = final_decl; + tda_descriptions = descrs; + tda_shape = shape; } + in + c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types; + env := store_type_infos ~tda_shape:shape id decl !env + | SigL_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_shape = + Shape.proj cm_shape (Shape.Item.extension_constructor id) + in + let cda = + { cda_description = descr; cda_address = Some addr; cda_shape } + in + c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs + | SigL_module(id, pres, md, _, _) -> + let md' = + (* The prefixed items get the same scope as [cm_path], which is + the prefix. *) + Subst.Lazy.module_decl + (Subst.Rescope (Path.scope cm_path)) sub md + in + let addr = + match pres with + | Mp_absent -> begin + match md.mdl_type with + | MtyL_alias path -> + Lazy_backtrack.create (ModAlias {env = !env; path}) + | _ -> assert false + end + | Mp_present -> next_address () + in + let alerts = + Builtin_attributes.alerts_of_attrs md.mdl_attributes + in + let shape = Shape.proj cm_shape (Shape.Item.module_ id) in + let comps = + components_of_module ~alerts ~uid:md.mdl_uid !env + sub path addr md.mdl_type shape + in + let mda = + { mda_declaration = md'; + mda_components = comps; + mda_address = addr; + mda_shape = shape; } + in + c.comp_modules <- + NameMap.add (Ident.name id) mda c.comp_modules; + env := + store_module ~update_summary:false ~check:None + id addr pres md shape !env + | SigL_modtype(id, decl, _) -> + let final_decl = + (* The prefixed items get the same scope as [cm_path], which is + the prefix. *) + Subst.Lazy.modtype_decl (Rescope (Path.scope cm_path)) + sub decl + in + let shape = Shape.proj cm_shape (Shape.Item.module_type id) in + let mtda = + { mtda_declaration = final_decl; + mtda_shape = shape; } + in + c.comp_modtypes <- + NameMap.add (Ident.name id) mtda c.comp_modtypes; + env := store_modtype ~update_summary:false id decl shape !env + | SigL_class(id, decl, _, _) -> + let decl' = Subst.class_declaration sub decl in + let addr = next_address () in + let shape = Shape.proj cm_shape (Shape.Item.class_ id) in + let clda = + { clda_declaration = decl'; + clda_address = addr; + clda_shape = shape; } + in + c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes + | SigL_class_type(id, decl, _, _) -> + let decl' = Subst.cltype_declaration sub decl in + let shape = Shape.proj cm_shape (Shape.Item.class_type id) in + let cltda = { cltda_declaration = decl'; cltda_shape = shape } in + c.comp_cltypes <- + NameMap.add (Ident.name id) cltda c.comp_cltypes) + items_and_paths; + Ok (Structure_comps c) + | MtyL_functor(arg, ty_res) -> + let sub = cm_prefixing_subst in + let scoping = Subst.Rescope (Path.scope cm_path) in + let open Subst.Lazy 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, force_modtype (modtype scoping sub ty_arg))); + fcomp_res = force_modtype (modtype scoping sub ty_res); + fcomp_shape = cm_shape; + fcomp_cache = Hashtbl.create 17; + fcomp_subst_cache = Hashtbl.create 17 }) + | MtyL_ident _ -> Error No_components_abstract + | MtyL_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 shape env = + check_value_name (Ident.name id) decl.val_loc; + Builtin_attributes.mark_alerts_used decl.val_attributes; + 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; + vda_shape = shape } + 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 = + Builtin_attributes.warning_scope cstr.cstr_attributes (fun () -> + 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); + Builtin_attributes.mark_alerts_used cstr.cstr_attributes; + Builtin_attributes.mark_warn_on_literal_pattern_used cstr.cstr_attributes; + let cda_shape = Shape.leaf cstr.cstr_uid in + { env with + constrs = + TycompTbl.add cstr_id + { cda_description = cstr; cda_address = None; cda_shape } env.constrs; + } + +and store_label ~check type_decl type_id lbl_id lbl env = + Builtin_attributes.warning_scope lbl.lbl_attributes (fun () -> + 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); + Builtin_attributes.mark_alerts_used lbl.lbl_attributes; + if lbl.lbl_mut = Mutable then + Builtin_attributes.mark_deprecated_mutable_used lbl.lbl_attributes; + { env with + labels = TycompTbl.add lbl_id lbl env.labels; + } + +and store_type ~check id info shape 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 r -> Type_abstract r, env + | Type_open -> Type_open, env + in + let tda = + { tda_declaration = info; + tda_descriptions = descrs; + tda_shape = shape } + in + Builtin_attributes.mark_alerts_used info.type_attributes; + { env with + types = IdTbl.add id tda env.types; + summary = Env_type(env.summary, id, info) } + +and store_type_infos ~tda_shape 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 (Btype.type_origin info); + tda_shape + } + 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 shape 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; + cda_shape = shape } + in + Builtin_attributes.mark_alerts_used ext.ext_attributes; + Builtin_attributes.mark_warn_on_literal_pattern_used ext.ext_attributes; + Builtin_attributes.warning_scope ext.ext_attributes (fun () -> + 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 ?(update_summary=true) ~check + id addr presence md shape env = + let open Subst.Lazy in + let loc = md.mdl_loc in + Option.iter + (fun f -> check_usage loc id md.mdl_uid f !module_declarations) check; + Builtin_attributes.mark_alerts_used md.mdl_attributes; + let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in + let comps = + components_of_module ~alerts ~uid:md.mdl_uid + env Subst.identity (Pident id) addr md.mdl_type shape + in + let mda = + { mda_declaration = md; + mda_components = comps; + mda_address = addr; + mda_shape = shape } + in + let summary = + if not update_summary then env.summary + else Env_module (env.summary, id, presence, force_module_decl md) in + { env with + modules = IdTbl.add id (Mod_local mda) env.modules; + summary } + +and store_modtype ?(update_summary=true) id info shape env = + Builtin_attributes.mark_alerts_used info.Subst.Lazy.mtdl_attributes; + let mtda = { mtda_declaration = info; mtda_shape = shape } in + let summary = + if not update_summary then env.summary + else Env_modtype (env.summary, id, Subst.Lazy.force_modtype_decl info) in + { env with + modtypes = IdTbl.add id mtda env.modtypes; + summary } + +and store_class id addr desc shape env = + Builtin_attributes.mark_alerts_used desc.cty_attributes; + let clda = + { clda_declaration = desc; + clda_address = addr; + clda_shape = shape; } + in + { env with + classes = IdTbl.add id clda env.classes; + summary = Env_class(env.summary, id, desc) } + +and store_cltype id desc shape env = + Builtin_attributes.mark_alerts_used desc.clty_attributes; + let cltda = { cltda_declaration = desc; cltda_shape = shape } in + { env with + cltypes = IdTbl.add id cltda env.cltypes; + summary = Env_cltype(env.summary, id, desc) } + +let scrape_alias env mty = scrape_alias env 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 shape_arg = + shape_of_path ~namespace:Shape.Sig_component_kind.Module env arg + in + let shape = Shape.app f_comp.fcomp_shape ~arg:shape_arg in + let comps = + components_of_module ~alerts:Misc.Stdlib.String.Map.empty + ~uid:Uid.internal_not_actually_unique + (*???*) + env Subst.identity p addr (Subst.Lazy.of_modtype mty) shape + 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 ?shape id desc env = + let addr = value_declaration_address env id desc in + let shape = shape_or_leaf desc.val_uid shape in + store_value ?check id addr desc shape env + +let add_type ~check ?shape id info env = + let shape = shape_or_leaf info.type_uid shape in + store_type ~check id info shape env + +and add_extension ~check ?shape ~rebind id ext env = + let addr = extension_declaration_address env id ext in + let shape = shape_or_leaf ext.ext_uid shape in + store_extension ~check ~rebind id addr ext shape env + +and add_module_declaration ?(arg=false) ?shape ~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 md = Subst.Lazy.of_module_decl md in + let addr = module_declaration_address env id presence md in + let shape = shape_or_leaf md.mdl_uid shape in + let env = store_module ~check id addr presence md shape env in + if arg then add_functor_arg id env else env + +and add_module_declaration_lazy ~update_summary id presence md env = + let addr = module_declaration_address env id presence md in + let shape = Shape.leaf md.Subst.Lazy.mdl_uid in + let env = + store_module ~update_summary ~check:None id addr presence md shape env + in + env + +and add_modtype ?shape id info env = + let shape = shape_or_leaf info.mtd_uid shape in + store_modtype id (Subst.Lazy.of_modtype_decl info) shape env + +and add_modtype_lazy ~update_summary id info env = + let shape = Shape.leaf info.Subst.Lazy.mtdl_uid in + store_modtype ~update_summary id info shape env + +and add_class ?shape id ty env = + let addr = class_declaration_address env id ty in + let shape = shape_or_leaf ty.cty_uid shape in + store_class id addr ty shape env + +and add_cltype ?shape id ty env = + let shape = shape_or_leaf ty.clty_uid shape in + store_cltype id ty shape env + +let add_module ?arg ?shape id presence mty env = + add_module_declaration ~check:false ?arg ?shape id presence (md mty) env + +let add_module_lazy ~update_summary id presence mty env = + let md = Subst.Lazy.{mdl_type = mty; + mdl_attributes = []; + mdl_loc = Location.none; + mdl_uid = Uid.internal_not_actually_unique} + in + add_module_declaration_lazy ~update_summary id presence md env + +let add_local_constraint path info env = + { env with + local_constraints = Path.Map.add path info env.local_constraints } + +(* Non-lazy version of scrape_alias *) +let scrape_alias t mty = + mty |> Subst.Lazy.of_modtype |> scrape_alias t |> Subst.Lazy.force_modtype + +(* 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 (Shape.leaf desc.val_uid) 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 (Shape.leaf info.type_uid) 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 shape = Shape.leaf ext.ext_uid in + let env = store_extension ~check:true ~rebind id addr ext shape env in + (id, env) + +let enter_module_declaration ~scope ?arg ?shape s presence md env = + let id = Ident.create_scoped ~scope s in + (id, add_module_declaration ?arg ?shape ~check:true id presence md env) + +let enter_modtype ~scope name mtd env = + let id = Ident.create_scoped ~scope name in + let shape = Shape.leaf mtd.mtd_uid in + let env = store_modtype id (Subst.Lazy.of_modtype_decl mtd) shape 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 (Shape.leaf desc.cty_uid) 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 (Shape.leaf desc.clty_uid) 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 (map, mod_shape) comp env = + let proj_shape item = + match mod_shape with + | None -> map, None + | Some mod_shape -> + let shape = Shape.proj mod_shape item in + Shape.Map.add map item shape, Some shape + in + match comp with + | Sig_value(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.value id) in + map, add_value ?shape id decl env + | Sig_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.type_ id) in + map, add_type ~check:false ?shape id decl env + | Sig_typext(id, ext, _, _) -> + let map, shape = proj_shape (Shape.Item.extension_constructor id) in + map, add_extension ~check:false ?shape ~rebind:false id ext env + | Sig_module(id, presence, md, _, _) -> + let map, shape = proj_shape (Shape.Item.module_ id) in + map, add_module_declaration ~check:false ?shape id presence md env + | Sig_modtype(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.module_type id) in + map, add_modtype ?shape id decl env + | Sig_class(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_ id) in + map, add_class ?shape id decl env + | Sig_class_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_type id) in + map, add_cltype ?shape id decl env + +let rec add_signature (map, mod_shape) sg env = + match sg with + [] -> map, env + | comp :: rem -> + let map, env = add_item (map, mod_shape) comp env in + add_signature (map, mod_shape) rem env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + let sg = Subst.signature (Rescope scope) Subst.identity sg in + let shape, env = add_signature (parent_shape, mod_shape) sg env in + sg, shape, env + +let enter_signature ?mod_shape ~scope sg env = + let sg, _, env = + enter_signature_and_shape ~scope ~parent_shape:Shape.Map.empty + mod_shape sg env + in + sg, env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env + +let add_value = add_value ?shape:None +let add_class = add_class ?shape:None +let add_cltype = add_cltype ?shape:None +let add_modtype = add_modtype ?shape:None +let add_signature sg env = + let _, env = add_signature (Shape.Map.empty, None) sg env in + 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 u = + let mda = read_pers_mod u in + let md = Subst.Lazy.force_module_decl mda.mda_declaration in + match md.md_type with + | Mty_signature sg -> sg + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false + + +let unit_name_of_filename fn = + match Filename.extension fn with + | ".cmi" -> + let modname = Unit_info.modname_from_source fn in + if Unit_info.is_unit_name modname then Some modname + else None + | _ -> 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 cmi_info = + 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 + (Unit_info.Artifact.modname cmi_info) sg alerts + |> cmi_transform in + let filename = Unit_info.Artifact.filename cmi_info in + let pers_sig = + Persistent_env.Persistent_signature.{ cmi; filename; visibility = Visible } + in + let pm = save_sign_of_cmi pers_sig in + Persistent_env.save_cmi !persistent_env pers_sig pm; + cmi + +let save_signature ~alerts sg cmi = + save_signature_with_transform (fun cmi -> cmi) ~alerts sg cmi + +let save_signature_with_imports ~alerts sg cmi imports = + let with_imports cmi = { cmi with cmi_crcs = imports } in + save_signature_with_transform with_imports ~alerts sg cmi + +(* Make the initial environment *) +let initial = + 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 = Btype.cstr_type_path cstr 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 get_desc lbl.lbl_res with + | 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 = + let open Subst.Lazy in + if use then begin + mark_modtype_used desc.mtdl_uid; + Builtin_attributes.check_alerts loc desc.mtdl_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; + if is_mutating_label_usage usage then + Builtin_attributes.check_deprecated_mutable 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 ~allow_hidden:false ~loc s; + path, (() : a) + | Load -> begin + match find_pers_mod ~allow_hidden:false 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) -> + use_modtype ~use ~loc path data.mtda_declaration; + (path, data.mtda_declaration) + | 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, cltda -> + use_cltype ~use ~loc path cltda.cltda_declaration; + path, cltda.cltda_declaration + | 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 = Subst.Lazy.force_module_decl data.mda_declaration in + path, md + | Ldot(l, s) -> + let path, data = lookup_dot_module ~errors ~use ~loc l s env in + let md = Subst.Lazy.force_module_decl 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 + | mta -> + let path = Pdot(p, s) in + use_modtype ~use ~loc path mta.mtda_declaration; + (path, mta.mtda_declaration) + | 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 + | cltda -> + let path = Pdot(p, s) in + use_cltype ~use ~loc path cltda.cltda_declaration; + (path, cltda.cltda_declaration) + | 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 + | _ -> + 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_lazy ~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_modtype ~errors ~use ~loc lid env = + let (path, mt) = lookup_modtype_lazy ~errors ~use ~loc lid env in + path, Subst.Lazy.force_modtype_decl mt + +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 + +(* Stable name lookup for printing *) + +let find_index_tbl ident tbl = + let lbs = IdTbl.find_all_idents (Ident.name ident) tbl in + let find_ident (n,p) = match p with + | Some id -> if Ident.same ident id then Some n else None + | _ -> None + in + Seq.find_map find_ident @@ Seq.mapi (fun i x -> i,x) lbs + +let find_value_index id env = find_index_tbl id env.values +let find_type_index id env = find_index_tbl id env.types +let find_module_index id env = find_index_tbl id env.modules +let find_modtype_index id env = find_index_tbl id env.modtypes +let find_class_index id env = find_index_tbl id env.classes +let find_cltype_index id env = find_index_tbl id env.cltypes + +(* 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_modtype_path ?(use=true) ~loc lid env = + fst (lookup_modtype_lazy ~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 ~allow_hidden:false 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 = + Subst.Lazy.force_module_decl 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 = + Subst.Lazy.force_module_decl 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 = + Subst.Lazy.force_module_decl 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 = + let f l path data acc = f l path (Subst.Lazy.force_modtype_decl data) acc in + find_all wrap_identity + (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + (fun k p mta acc -> f k p mta.mtda_declaration acc) +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) + (fun k p cltda acc -> f k p cltda.cltda_declaration acc) + +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 [] + +module Style = Misc.Style + +let report_lookup_error _loc env ppf = function + | Unbound_value(lid, hint) -> begin + fprintf ppf "Unbound value %a" + (Style.as_inline_code !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 + "@.@[@{Hint@}: If this is a recursive definition,@ \ + you should add the %a keyword on line %i@]" + Style.inline_code "rec" + line + end + | Unbound_type lid -> + fprintf ppf "Unbound type constructor %a" + (Style.as_inline_code !print_longident) lid; + spellcheck ppf extract_types env lid; + | Unbound_module lid -> begin + fprintf ppf "Unbound module %a" + (Style.as_inline_code !print_longident) lid; + match find_modtype_by_name lid env with + | exception Not_found -> spellcheck ppf extract_modules env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a module type named %a, %s@]" + (Style.as_inline_code !print_longident) lid + "but module types are not modules" + end + | Unbound_constructor lid -> + fprintf ppf "Unbound constructor %a" + (Style.as_inline_code !print_longident) lid; + spellcheck ppf extract_constructors env lid; + | Unbound_label lid -> + fprintf ppf "Unbound record field %a" + (Style.as_inline_code !print_longident) lid; + spellcheck ppf extract_labels env lid; + | Unbound_class lid -> begin + fprintf ppf "Unbound class %a" + (Style.as_inline_code !print_longident) lid; + match find_cltype_by_name lid env with + | exception Not_found -> spellcheck ppf extract_classes env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a class type named %a, %s@]" + (Style.as_inline_code !print_longident) lid + "but classes are not class types" + end + | Unbound_modtype lid -> begin + fprintf ppf "Unbound module type %a" + (Style.as_inline_code !print_longident) lid; + match find_module_by_name lid env with + | exception Not_found -> spellcheck ppf extract_modtypes env lid; + | _ -> + fprintf ppf + "@.@[@{Hint@}: There is a module named %a, %s@]" + (Style.as_inline_code !print_longident) lid + "but modules are not module types" + end + | Unbound_cltype lid -> + fprintf ppf "Unbound class type %a" + (Style.as_inline_code !print_longident) lid; + spellcheck ppf extract_cltypes env lid; + | Unbound_instance_variable s -> + fprintf ppf "Unbound instance variable %a" Style.inline_code s; + spellcheck_name ppf extract_instance_variables env s; + | Not_an_instance_variable s -> + fprintf ppf "The value %a is not an instance variable" + Style.inline_code 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" + (Style.as_inline_code !print_longident) lid + | Masked_self_variable lid -> + fprintf ppf + "The self variable %a@ \ + cannot be accessed from the definition of an instance variable" + (Style.as_inline_code !print_longident) lid + | Masked_ancestor_variable lid -> + fprintf ppf + "The ancestor variable %a@ \ + cannot be accessed from the definition of an instance variable" + (Style.as_inline_code !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@]" + (Style.as_inline_code !print_longident) lid + | Abstract_used_as_functor lid -> + fprintf ppf "@[The module %a is abstract, it cannot be applied@]" + (Style.as_inline_code !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@]" + (Style.as_inline_code !print_longident) lid + | Generative_used_as_applicative lid -> + fprintf ppf "@[The functor %a is generative,@ it@ cannot@ be@ \ + applied@ in@ type@ expressions@]" + (Style.as_inline_code !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" + (Style.as_inline_code !print_longident) lid + (Style.as_inline_code !print_path) p cause + +let report_error ppf = function + | Missing_module(_, path1, path2) -> + fprintf ppf "@[@["; + if Path.same path1 path2 then + fprintf ppf "Internal path@ %a@ is dangling." + Style.inline_code (Path.name path1) + else + fprintf ppf "Internal path@ %a@ expands to@ %a@ which is dangling." + Style.inline_code (Path.name path1) + Style.inline_code (Path.name path2); + fprintf ppf "@]@ @[%s@ %a@ %s.@]@]" + "The compiled interface for module" + Style.inline_code (Ident.name (Path.head path2)) + "was not found" + | Illegal_value_name(_loc, name) -> + fprintf ppf "%a is not a valid value identifier." + Style.inline_code 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_502/typing/env.mli b/upstream/ocaml_502/typing/env.mli new file mode 100644 index 0000000000..fa82444a11 --- /dev/null +++ b/upstream/ocaml_502/typing/env.mli @@ -0,0 +1,525 @@ +(**************************************************************************) +(* *) +(* 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: t +val diff: t -> t -> Ident.t list + +(* approximation to the preimage equivalence class of [find_type] *) +val same_type_declarations: t -> t -> bool + +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 -> Stdlib.String.Set.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_strengthened_module: + aliasable:bool -> Path.t -> t -> module_type + +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_modtype_expansion_lazy: Path.t -> t -> Subst.Lazy.modtype + +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 shape_of_path: + namespace:Shape.Sig_component_kind.t -> t -> Path.t -> Shape.t + +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_value_path: Location.t option -> t -> Path.t -> Path.t +(* Normalize the prefix part of the value path *) + +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_modtype_path: + ?use:bool -> loc:Location.t -> 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 + +(** The [find_*_index] functions computes a "namespaced" De Bruijn index + of an identifier in a given environment. In other words, it returns how many + times an identifier has been shadowed by a more recent identifiers with the + same name in a given environment. + Those functions return [None] when the identifier is not bound in the + environment. This behavior is there to facilitate the detection of + inconsistent printing environment, but should disappear in the long term. +*) +val find_value_index: Ident.t -> t -> int option +val find_type_index: Ident.t -> t -> int option +val find_module_index: Ident.t -> t -> int option +val find_modtype_index: Ident.t -> t -> int option +val find_class_index: Ident.t -> t -> int option +val find_cltype_index: Ident.t -> t -> int option + +(* 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 -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t +val add_extension: + check:bool -> ?shape:Shape.t -> rebind:bool -> Ident.t -> + extension_constructor -> t -> t +val add_module: ?arg:bool -> ?shape:Shape.t -> + Ident.t -> module_presence -> module_type -> t -> t +val add_module_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.modtype -> t -> t +val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> + Ident.t -> module_presence -> module_declaration -> t -> t +val add_module_declaration_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.module_decl -> t -> t +val add_modtype: Ident.t -> modtype_declaration -> t -> t +val add_modtype_lazy: update_summary:bool -> + Ident.t -> Subst.Lazy.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_constraint: 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_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 -> ?shape:Shape.t -> 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: ?mod_shape:Shape.t -> scope:int -> signature -> t -> + signature * t + +(* Same as [enter_signature] but also extends the shape map ([parent_shape]) + with all the the items from the signature, their shape being a projection + from the given shape. *) +val enter_signature_and_shape: scope:int -> parent_shape:Shape.Map.t -> + Shape.t -> signature -> t -> signature * Shape.Map.t * 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: Unit_info.Artifact.t -> signature + (* Arguments: module name, file name. Results: signature. *) +val save_signature: + alerts:alerts -> Types.signature -> Unit_info.Artifact.t + -> Cmi_format.cmi_infos + (* Arguments: signature, module name, file name. *) +val save_signature_with_imports: + alerts:alerts -> signature -> Unit_info.Artifact.t -> 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 -> Subst.Lazy.modtype -> + Path.t -> Subst.Lazy.modtype) 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_502/typing/envaux.ml b/upstream/ocaml_502/typing/envaux.ml new file mode 100644 index 0000000000..90e0da92c4 --- /dev/null +++ b/upstream/ocaml_502/typing/envaux.ml @@ -0,0 +1,117 @@ +(**************************************************************************) +(* *) +(* 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_constraint (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 +module Style = Misc.Style + +let report_error ppf = function + | Module_not_found p -> + fprintf ppf "@[Cannot find module %a@].@." + (Style.as_inline_code 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_502/typing/envaux.mli b/upstream/ocaml_502/typing/envaux.mli new file mode 100644 index 0000000000..2869890a14 --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/errortrace.ml b/upstream/ocaml_502/typing/errortrace.ml new file mode 100644 index 0000000000..ec380329be --- /dev/null +++ b/upstream/ocaml_502/typing/errortrace.ml @@ -0,0 +1,194 @@ +(**************************************************************************) +(* *) +(* 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 expanded_type = { ty: type_expr; expanded: type_expr } + +let trivial_expansion ty = { ty; expanded = ty } + +type 'a diff = { got: 'a; expected: 'a } + +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 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 map_escape f esc = + {esc with kind = match esc.kind with + | Equation eq -> Equation (f eq) + | (Constructor _ | Univ _ | Self | Module_type _ | Constraint) as c -> c} + +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 *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | 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 ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +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 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 + +type unification_error = { trace : unification error } [@@unboxed] + +type equality_error = + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = { trace : comparison error } [@@unboxed] + +let unification_error ~trace : unification_error = + assert (trace <> []); + { trace } + +let equality_error ~trace ~subst : equality_error = + assert (trace <> []); + { trace; subst } + +let moregen_error ~trace : moregen_error = + assert (trace <> []); + { trace } + +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +let swap_unification_error ({trace} : unification_error) = + ({trace = swap_trace trace} : unification_error) + +module Subtype = struct + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = + { trace : error_trace + ; unification_trace : unification error } + + let error ~trace ~unification_trace = + assert (trace <> []); + { trace; unification_trace } + + let map_elt f = function + | Diff x -> Diff (map_diff f x) + + let map f t = List.map (map_elt f) t +end diff --git a/upstream/ocaml_502/typing/errortrace.mli b/upstream/ocaml_502/typing/errortrace.mli new file mode 100644 index 0000000000..90148893fe --- /dev/null +++ b/upstream/ocaml_502/typing/errortrace.mli @@ -0,0 +1,168 @@ +(**************************************************************************) +(* *) +(* 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 expanded_type = { ty: type_expr; expanded: type_expr } + +(** [trivial_expansion ty] creates an [expanded_type] whose expansion is also + [ty]. Usually, you want [Ctype.expand_type] instead, since the expansion + carries useful information; however, in certain circumstances, the error is + about the expansion of the type, meaning that actually performing the + expansion produces more confusing or inaccurate output. *) +val trivial_expansion : type_expr -> expanded_type + +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 map_escape : ('a -> 'b) -> 'a escape -> 'b escape + +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 *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | 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 ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +val map : ('a -> 'b) -> ('a, 'variety) t -> ('b, 'variety) t + +val incompatible_fields : + name:string -> got:type_expr -> expected:type_expr -> (type_expr, _) elt + +val swap_trace : ('a, 'variety) t -> ('a, 'variety) t + +(** The traces (['variety t]) are the core error types. However, we bundle them + up into three "top-level" error types, which are used elsewhere: + [unification_error], [equality_error], and [moregen_error]. In the case of + [equality_error], this has to bundle in extra information; in general, it + distinguishes the three types of errors and allows us to distinguish traces + that are being built (or processed) from those that are complete and have + become the final error. These error types have the invariants that their + traces are nonempty; we ensure that through three smart constructors with + matching names. *) + +type unification_error = private { trace : unification error } [@@unboxed] + +type equality_error = private + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = private { trace : comparison error } [@@unboxed] + +val unification_error : trace:unification error -> unification_error + +val equality_error : + trace:comparison error -> subst:(type_expr * type_expr) list -> equality_error + +val moregen_error : trace:comparison error -> moregen_error + +(** Wraps up the two different kinds of [comparison] errors in one type *) +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +(** Lift [swap_trace] to [unification_error] *) +val swap_unification_error : unification_error -> unification_error + +module Subtype : sig + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + (** Just as outside [Subtype], we split traces, completed traces, and complete + errors. However, in a minor asymmetry, the name [Subtype.error_trace] + corresponds to the outside [error] type, and [Subtype.error] corresponds + to the outside [*_error] types (e.g., [unification_error]). This [error] + type has the invariant that the subtype trace is nonempty; note that no + such invariant is imposed on the unification trace. *) + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = private + { trace : error_trace + ; unification_trace : unification error } + + val error : + trace:error_trace -> unification_trace:unification_error_trace -> error + + val map : ('a -> 'b) -> 'a t -> 'b t +end diff --git a/upstream/ocaml_502/typing/ident.ml b/upstream/ocaml_502/typing/ident.ml new file mode 100644 index 0000000000..287c0ac86d --- /dev/null +++ b/upstream/ocaml_502/typing/ident.ml @@ -0,0 +1,388 @@ +(**************************************************************************) +(* *) +(* 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 + "_", 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 + +(* For the documentation of ['a Ident.tbl], see ident.mli. + + The implementation is a copy-paste specialization of + a balanced-tree implementation similar to Map. + ['a tbl] + is a slightly more compact version of + [(Ident.t * 'a) list Map.Make(String)] + + This implementation comes from Caml Light where duplication was + unavoidable in absence of functors. It works well enough, and so + far we have not had strong incentives to do the deduplication work + (implementation, tests, benchmarks, etc.). +*) +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 get_all_seq k () = + Seq.unfold (Option.map (fun k -> (k.ident, k.data), k.previous)) + k () + +let rec find_all_seq n tbl () = + match tbl with + | Empty -> Seq.Nil + | Node(l, k, r, _) -> + let c = String.compare n (name k.ident) in + if c = 0 then + Seq.Cons((k.ident, k.data), get_all_seq k.previous) + else + find_all_seq 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_502/typing/ident.mli b/upstream/ocaml_502/typing/ident.mli new file mode 100644 index 0000000000..4132b1fbef --- /dev/null +++ b/upstream/ocaml_502/typing/ident.mli @@ -0,0 +1,110 @@ +(**************************************************************************) +(* *) +(* 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 +(** ['a tbl] represents association tables from identifiers to values + of type ['a]. + + ['a tbl] plays the role of map, but bindings can be looked up + from either the full Ident using [find_same], or just its + user-visible name using [find_name]. In general the two lookups may + not return the same result, as an identifier may have been shadowed + in the environment by a distinct identifier with the same name. + + [find_all] returns the bindings for all idents of a given name, + most recently introduced first. + + In other words, + ['a tbl] + corresponds to + [(Ident.t * 'a) list Map.Make(String)] + and the implementation is very close to that representation. + + Note in particular that searching among idents of the same name + takes linear time, and that [add] simply extends the list without + checking for duplicates. So it is not a good idea to implement + union by repeated [add] calls, which may result in many duplicated + identifiers and poor [find_same] performance. It is even possible + to build overly large same-name lists such that non-recursive + functions like [find_all] or [fold_all] blow the stack. + + You should probably use [Map.Make(Ident)] instead, unless you + really need to query bindings by user-visible name, not just by + unique identifiers. +*) + +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 find_all_seq: string -> 'a tbl -> (t * 'a) Seq.t +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_502/typing/includeclass.ml b/upstream/ocaml_502/typing/includeclass.ml new file mode 100644 index 0000000000..39f00f9cf5 --- /dev/null +++ b/upstream/ocaml_502/typing/includeclass.ml @@ -0,0 +1,118 @@ +(**************************************************************************) +(* *) +(* 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 mode 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 (n, env, err) -> + Printtyp.report_equality_error ppf mode env err + (function ppf -> + fprintf ppf "The %d%s type parameter has type" + n (Misc.ordinal_suffix n)) + (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 (n, env, err) -> + Printtyp.report_moregen_error ppf mode env err + (function ppf -> + fprintf ppf "The %d%s parameter has type" + n (Misc.ordinal_suffix n)) + (function ppf -> + fprintf ppf "but is expected to have type") + | CM_Val_type_mismatch (lab, env, err) -> + Printtyp.report_comparison_error ppf mode env err + (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, err) -> + Printtyp.report_comparison_error ppf mode env err + (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 mode ppf = function + | [] -> () + | err :: errs -> + let print_errs ppf errs = + List.iter (fun err -> fprintf ppf "@ %a" (include_err mode) err) errs in + fprintf ppf "@[%a%a@]" (include_err mode) err print_errs errs diff --git a/upstream/ocaml_502/typing/includeclass.mli b/upstream/ocaml_502/typing/includeclass.mli new file mode 100644 index 0000000000..84de6212c4 --- /dev/null +++ b/upstream/ocaml_502/typing/includeclass.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* 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 : + Printtyp.type_or_scheme -> formatter -> class_match_failure list -> unit diff --git a/upstream/ocaml_502/typing/includecore.ml b/upstream/ocaml_502/typing/includecore.ml new file mode 100644 index 0000000000..595c07e935 --- /dev/null +++ b/upstream/ocaml_502/typing/includecore.ml @@ -0,0 +1,1037 @@ +(**************************************************************************) +(* *) +(* 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 Errortrace.moregen_error + +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 err -> raise (Dont_match (Type err)) + | () -> 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 manifest types (particularly for private row types) *) + +let is_absrow env ty = + match get_desc ty with + | Tconstr(Pident _, _, _) -> + (* This function is checking for an abstract row on the side that is being + included into (usually numbered with "2" in this file). In this case, + the abstract row variable has been substituted for an object or variant + type. *) + begin match get_desc (Ctype.expand_head env ty) with + | 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 + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type type_kind = + | Kind_abstract + | Kind_record + | Kind_variant + | Kind_open + +let of_kind = function + | Type_abstract _ -> Kind_abstract + | Type_record (_, _) -> Kind_record + | Type_variant (_, _) -> Kind_variant + | Type_open -> Kind_open + +type kind_mismatch = type_kind * type_kind + +type label_mismatch = + | Type of Errortrace.equality_error + | Mutability of position + +type record_change = + (Types.label_declaration, Types.label_declaration, label_mismatch) + Diffing_with_keys.change + +type record_mismatch = + | Label_mismatch of record_change list + | Unboxed_float_representation of position + +type constructor_mismatch = + | Type of Errortrace.equality_error + | Arity + | Inline_record of record_change list + | Kind of position + | Explicit_return_type of position + +type extension_constructor_mismatch = + | Constructor_privacy + | Constructor_mismatch of Ident.t + * Types.extension_constructor + * Types.extension_constructor + * constructor_mismatch + +type private_variant_mismatch = + | Only_outer_closed (* It's only dangerous in one direction *) + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type variant_change = + (Types.constructor_declaration as 'l, 'l, constructor_mismatch) + Diffing_with_keys.change + +type type_mismatch = + | Arity + | Privacy of privacy_mismatch + | Kind of kind_mismatch + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | 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_change list + | Unboxed_representation of position + | Immediate of Type_immediacy.Violation.t + +module Style = Misc.Style + +let report_primitive_mismatch first second ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : primitive_mismatch) with + | Name -> + pr "The names of the primitives are not the same" + | Arity -> + pr "The syntactic arities of these primitives were not the same.@ \ + (They must have the same number of arrows present in the source.)" + | No_alloc ord -> + pr "%s primitive is %a but %s is not" + (String.capitalize_ascii (choose ord first second)) + Style.inline_code "[@@noalloc]" + (choose_other ord first second) + | Native_name -> + pr "The native names of the primitives are not the same" + | Result_repr -> + pr "The two primitives' results have different representations" + | Argument_repr n -> + pr "The two primitives' %d%s arguments have different representations" + n (Misc.ordinal_suffix n) + +let report_value_mismatch first second env ppf err = + let pr fmt = Format.fprintf ppf fmt in + pr "@ "; + match (err : value_mismatch) with + | Primitive_mismatch pm -> + report_primitive_mismatch first second ppf pm + | Not_a_primitive -> + pr "The implementation is not a primitive." + | Type trace -> + Printtyp.report_moregen_error ppf Type_scheme env trace + (fun ppf -> Format.fprintf ppf "The type") + (fun ppf -> Format.fprintf ppf "is not compatible with the type") + +let report_type_inequality env ppf err = + Printtyp.report_equality_error ppf Type_scheme env err + (fun ppf -> Format.fprintf ppf "The type") + (fun ppf -> Format.fprintf ppf "is not equal to the type") + +let report_privacy_mismatch ppf err = + let singular, item = + match err with + | Private_type_abbreviation -> true, "type abbreviation" + | Private_variant_type -> false, "variant constructor(s)" + | Private_record_type -> true, "record constructor" + | Private_extensible_variant -> true, "extensible variant" + | Private_row_type -> true, "row type" + in Format.fprintf ppf "%s %s would be revealed." + (if singular then "A private" else "Private") + item + +let report_label_mismatch first second env ppf err = + match (err : label_mismatch) with + | Type err -> + report_type_inequality env ppf err + | Mutability ord -> + Format.fprintf ppf "%s is mutable and %s is not." + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + +let pp_record_diff first second prefix decl env ppf (x : record_change) = + match x with + | Delete cd -> + Format.fprintf ppf "%aAn extra field, %a, is provided in %s %s." + prefix x Style.inline_code (Ident.name cd.delete.ld_id) first decl + | Insert cd -> + Format.fprintf ppf "%aA field, %a, is missing in %s %s." + prefix x Style.inline_code (Ident.name cd.insert.ld_id) first decl + | Change Type {got=lbl1; expected=lbl2; reason} -> + Format.fprintf ppf + "@[%aFields do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + (Style.as_inline_code Printtyp.label) lbl1 + (Style.as_inline_code Printtyp.label) lbl2 + (report_label_mismatch first second env) reason + | Change Name n -> + Format.fprintf ppf "%aFields have different names, %a and %a." + prefix x + Style.inline_code n.got + Style.inline_code n.expected + | Swap sw -> + Format.fprintf ppf "%aFields %a and %a have been swapped." + prefix x + Style.inline_code sw.first + Style.inline_code sw.last + | Move {name; got; expected } -> + Format.fprintf ppf + "@[<2>%aField %a has been moved@ from@ position %d@ to %d.@]" + prefix x Style.inline_code name expected got + +let report_patch pr_diff first second decl env ppf patch = + let nl ppf () = Format.fprintf ppf "@," in + let no_prefix _ppf _ = () in + match patch with + | [ elt ] -> + Format.fprintf ppf "@[%a@]" + (pr_diff first second no_prefix decl env) elt + | _ -> + let pp_diff = pr_diff first second Diffing_with_keys.prefix decl env in + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list ~pp_sep:nl pp_diff) patch + +let report_record_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match err with + | Label_mismatch patch -> + report_patch pp_record_diff first second decl env ppf patch + | Unboxed_float_representation ord -> + pr "@[Their internal representations differ:@ %s %s %s.@]" + (choose ord first second) decl + "uses unboxed float representation" + +let report_constructor_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : constructor_mismatch) with + | Type err -> report_type_inequality env ppf err + | Arity -> pr "They have different arities." + | Inline_record err -> + report_patch pp_record_diff first second decl env 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 pp_variant_diff first second prefix decl env ppf (x : variant_change) = + match x with + | Delete cd -> + Format.fprintf ppf "%aAn extra constructor, %a, is provided in %s %s." + prefix x Style.inline_code (Ident.name cd.delete.cd_id) first decl + | Insert cd -> + Format.fprintf ppf "%aA constructor, %a, is missing in %s %s." + prefix x Style.inline_code (Ident.name cd.insert.cd_id) first decl + | Change Type {got; expected; reason} -> + Format.fprintf ppf + "@[%aConstructors do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + (Style.as_inline_code Printtyp.constructor) got + (Style.as_inline_code Printtyp.constructor) expected + (report_constructor_mismatch first second decl env) reason + | Change Name n -> + Format.fprintf ppf + "%aConstructors have different names, %a and %a." + prefix x + Style.inline_code n.got + Style.inline_code n.expected + | Swap sw -> + Format.fprintf ppf + "%aConstructors %a and %a have been swapped." + prefix x + Style.inline_code sw.first + Style.inline_code sw.last + | Move {name; got; expected} -> + Format.fprintf ppf + "@[<2>%aConstructor %a has been moved@ from@ position %d@ to %d.@]" + prefix x Style.inline_code name expected got + +let report_extension_constructor_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : extension_constructor_mismatch) with + | Constructor_privacy -> + pr "Private extension constructor(s) would be revealed." + | Constructor_mismatch (id, ext1, ext2, err) -> + let constructor = + Style.as_inline_code (Printtyp.extension_only_constructor id) + in + pr "@[Constructors do not match:@;<1 2>%a@ is not the same as:\ + @;<1 2>%a@ %a@]" + constructor ext1 + constructor ext2 + (report_constructor_mismatch first second decl env) err + + +let report_private_variant_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + let pp_tag ppf x = Format.fprintf ppf "`%s" x in + match (err : private_variant_mismatch) with + | Only_outer_closed -> + (* It's only dangerous in one direction, so we don't have a position *) + pr "%s is private and closed, but %s is not closed" + (String.capitalize_ascii second) first + | Missing (ord, name) -> + pr "The constructor %a is only present in %s %s." + Style.inline_code name (choose ord first second) decl + | Presence s -> + pr "The tag %a is present in the %s %s,@ but might not be in the %s" + (Style.as_inline_code pp_tag) s second decl first + | Incompatible_types_for s -> pr "Types for tag `%s are incompatible" s + | Types err -> + report_type_inequality env ppf err + +let report_private_object_mismatch env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : private_object_mismatch) with + | Missing s -> + pr "The implementation is missing the method %a" Style.inline_code s + | Types err -> report_type_inequality env ppf err + +let report_kind_mismatch first second ppf (kind1, kind2) = + let pr fmt = Format.fprintf ppf fmt in + let kind_to_string = function + | Kind_abstract -> "abstract" + | Kind_record -> "a record" + | Kind_variant -> "a variant" + | Kind_open -> "an extensible variant" in + pr "%s is %s, but %s is %s." + (String.capitalize_ascii first) + (kind_to_string kind1) + second + (kind_to_string kind2) + +let report_type_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + pr "@ "; + match err with + | Arity -> + pr "They have different arities." + | Privacy err -> + report_privacy_mismatch ppf err + | Kind err -> + report_kind_mismatch first second ppf err + | Constraint err -> + (* This error can come from implicit parameter disagreement or from + explicit `constraint`s. Both affect the parameters, hence this choice + of explanatory text *) + pr "Their parameters differ@,"; + report_type_inequality env ppf err + | Manifest err -> + report_type_inequality env ppf err + | Private_variant (_ty1, _ty2, mismatch) -> + report_private_variant_mismatch first second decl env ppf mismatch + | Private_object (_ty1, _ty2, mismatch) -> + report_private_object_mismatch env ppf mismatch + | Variance -> + pr "Their variances do not agree." + | Record_mismatch err -> + report_record_mismatch first second decl env ppf err + | Variant_mismatch err -> + report_patch pp_variant_diff first second decl env 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 + +module Record_diffing = struct + + let 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 + 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 err -> + Some (Type err : label_mismatch) + | () -> None + + let rec equal ~loc env params1 params2 + (labels1 : Types.label_declaration list) + (labels2 : Types.label_declaration list) = + match labels1, labels2 with + | [], [] -> true + | _ :: _ , [] | [], _ :: _ -> false + | ld1 :: rem1, ld2 :: rem2 -> + if Ident.name ld1.ld_id <> Ident.name ld2.ld_id + then false + 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 _ -> false + (* add arguments to the parameters, cf. PR#7378 *) + | None -> + equal ~loc env + (ld1.ld_type::params1) (ld2.ld_type::params2) + rem1 rem2 + end + + module Defs = struct + type left = Types.label_declaration + type right = left + type diff = label_mismatch + type state = type_expr list * type_expr list + end + module Diff = Diffing_with_keys.Define(Defs) + + let update (d:Diff.change) (params1,params2 as st) = + match d with + | Insert _ | Change _ | Delete _ -> st + | Keep (x,y,_) -> + (* We need to add equality between existential type parameters + (in inline records) *) + x.data.ld_type::params1, y.data.ld_type::params2 + + let test _loc env (params1,params2) + ({pos; data=lbl1}: Diff.left) + ({data=lbl2; _ }: Diff.right) + = + let name1, name2 = Ident.name lbl1.ld_id, Ident.name lbl2.ld_id in + if name1 <> name2 then + let types_match = + match compare_labels env params1 params2 lbl1 lbl2 with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_labels env params1 params2 lbl1 lbl2 with + | Some reason -> + Error ( + Diffing_with_keys.Type {pos; got=lbl1; expected=lbl2; reason} + ) + | None -> Ok () + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name t ) -> + if t.types_match then 10 else 15 + | Change _ -> 10 + + + + let key (x: Defs.left) = Ident.name x.ld_id + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let module Compute = Diff.Simple(struct + let key_left = key + let key_right = key + let update = update + let test = test loc env + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + + let compare_with_representation ~loc env params1 params2 l r rep1 rep2 = + if not (equal ~loc env params1 params2 l r) then + let patch = diffing loc env params1 params2 l r in + Some (Record_mismatch (Label_mismatch patch)) + else + 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 + +end + + +module Variant_diffing = struct + + let 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 err -> Some (Type err) + | () -> None + end + | Types.Cstr_record l1, Types.Cstr_record l2 -> + Option.map + (fun rec_err -> Inline_record rec_err) + (Record_diffing.compare env ~loc params1 params2 l1 l2) + | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch) + | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch) + + let 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 err -> Some (Type err) + | () -> 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 + + let equal ~loc env params1 params2 + (cstrs1 : Types.constructor_declaration list) + (cstrs2 : Types.constructor_declaration list) = + List.length cstrs1 = List.length cstrs2 && + List.for_all2 (fun (cd1:Types.constructor_declaration) + (cd2:Types.constructor_declaration) -> + Ident.name cd1.cd_id = Ident.name cd2.cd_id + && + 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 _ -> false + | None -> true + end) cstrs1 cstrs2 + + module Defs = struct + type left = Types.constructor_declaration + type right = left + type diff = constructor_mismatch + type state = type_expr list * type_expr list + end + module D = Diffing_with_keys.Define(Defs) + + let update _ st = st + + let weight: D.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name t) -> + if t.types_match then 10 else 15 + | Change _ -> 10 + + + let test loc env (params1,params2) + ({pos; data=cd1}: D.left) + ({data=cd2; _}: D.right) = + let name1, name2 = Ident.name cd1.cd_id, Ident.name cd2.cd_id in + if name1 <> name2 then + let types_match = + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some reason -> + Error (Diffing_with_keys.Type {pos; got=cd1; expected=cd2; reason}) + | None -> Ok () + + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let key (x:Defs.left) = Ident.name x.cd_id in + let module Compute = D.Simple(struct + let key_left = key + let key_right = key + let test = test loc env + let update = update + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + let compare_with_representation ~loc env params1 params2 + cstrs1 cstrs2 rep1 rep2 + = + let err = compare ~loc env params1 params2 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) +end + +(* Inclusion between "private" annotations *) +let privacy_mismatch env decl1 decl2 = + match decl1.type_private, decl2.type_private with + | Private, Public -> begin + match decl1.type_kind, decl2.type_kind with + | Type_record _, Type_record _ -> Some Private_record_type + | Type_variant _, Type_variant _ -> Some Private_variant_type + | Type_open, Type_open -> Some Private_extensible_variant + | Type_abstract _, Type_abstract _ + when Option.is_some decl2.type_manifest -> begin + match decl1.type_manifest with + | Some ty1 -> begin + let ty1 = Ctype.expand_head env ty1 in + match get_desc ty1 with + | Tvariant row when Btype.is_constr_row ~allow_ident:true + (row_more row) -> + Some Private_row_type + | Tobject (fi, _) when Btype.is_constr_row ~allow_ident:true + (snd (Ctype.flatten_fields fi)) -> + Some Private_row_type + | _ -> + Some Private_type_abbreviation + end + | None -> + None + end + | _, _ -> + None + end + | _, _ -> + None + +let private_variant env row1 params1 row2 params2 = + let r1, r2, pairs = + Ctype.merge_row_fields (row_fields row1) (row_fields row2) + in + let row1_closed = row_closed row1 in + let row2_closed = row_closed row2 in + let err = + if row2_closed && not row1_closed then Some Only_outer_closed + else begin + match row2_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 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 err -> + Some (Types err : private_variant_mismatch) + | () -> None + end + | (s, f1, f2) :: pairs -> begin + match row_field_repr f1, 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 err -> Some (Types err) + | () -> None + end + +let type_manifest env ty1 params1 ty2 params2 priv2 kind2 = + let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in + match get_desc ty1', get_desc ty2' with + | Tvariant row1, Tvariant row2 + when is_absrow env (row_more row2) -> begin + assert (Ctype.is_equal env true (ty1::params1) (row_more row2::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 + let is_private_abbrev_2 = + match priv2, kind2 with + | Private, Type_abstract _ -> begin + (* Same checks as the [when] guards from above, inverted *) + match get_desc ty2' with + | Tvariant row -> + not (is_absrow env (row_more row)) + | Tobject (fi, _) -> + not (is_absrow env (snd (Ctype.flatten_fields fi))) + | _ -> true + end + | _, _ -> false + in + match + if is_private_abbrev_2 then + Ctype.equal_private env params1 ty1 params2 ty2 + else + Ctype.equal env true (params1 @ [ty1]) (params2 @ [ty2]) + with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> 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 + let err = + match privacy_mismatch env decl1 decl2 with + | Some err -> Some (Privacy err) + | None -> None + in + if err <> None then err 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 err -> Some (Constraint err) + | () -> None + end + | (Some ty1, Some ty2) -> + type_manifest env ty1 decl1.type_params ty2 decl2.type_params + decl2.type_private decl2.type_kind + | (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 err -> Some (Constraint err) + | () -> + match Ctype.equal env false [ty1] [ty2] with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> 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; + Variant_diffing.compare_with_representation ~loc env + decl1.type_params + decl2.type_params + 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; + Record_diffing.compare_with_representation ~loc env + decl1.type_params decl2.type_params + labels1 labels2 + rep1 rep2 + | (Type_open, Type_open) -> None + | (_, _) -> Some (Kind (of_kind decl1.type_kind, of_kind decl2.type_kind)) + in + if err <> None then err else + let abstr = Btype.type_kind_is_abstract decl2 && 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 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,j1) = get_lower v1 and (p2,n2,j2) = get_lower v2 in + imp abstr (imp p2 p1 && imp n2 n1 && 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 err -> + Some (Constructor_mismatch (id, ext1, ext2, Type err)) + | () -> + let r = + Variant_diffing.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_502/typing/includecore.mli b/upstream/ocaml_502/typing/includecore.mli new file mode 100644 index 0000000000..50825976ce --- /dev/null +++ b/upstream/ocaml_502/typing/includecore.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. *) +(* *) +(**************************************************************************) + +(* 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 Errortrace.moregen_error + +exception Dont_match of value_mismatch + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type type_kind = + | Kind_abstract + | Kind_record + | Kind_variant + | Kind_open + +type kind_mismatch = type_kind * type_kind + +type label_mismatch = + | Type of Errortrace.equality_error + | Mutability of position + +type record_change = + (Types.label_declaration as 'ld, 'ld, label_mismatch) Diffing_with_keys.change + +type record_mismatch = + | Label_mismatch of record_change list + | Unboxed_float_representation of position + +type constructor_mismatch = + | Type of Errortrace.equality_error + | Arity + | Inline_record of record_change list + | Kind of position + | Explicit_return_type of position + +type extension_constructor_mismatch = + | Constructor_privacy + | Constructor_mismatch of Ident.t + * extension_constructor + * extension_constructor + * constructor_mismatch +type variant_change = + (Types.constructor_declaration as 'cd, 'cd, constructor_mismatch) + Diffing_with_keys.change + +type private_variant_mismatch = + | Only_outer_closed + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type type_mismatch = + | Arity + | Privacy of privacy_mismatch + | Kind of kind_mismatch + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | 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_change list + | 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_value_mismatch : + string -> string -> + Env.t -> + Format.formatter -> value_mismatch -> unit + +val report_type_mismatch : + string -> string -> string -> + Env.t -> + Format.formatter -> type_mismatch -> unit + +val report_extension_constructor_mismatch : + string -> string -> string -> + Env.t -> + Format.formatter -> extension_constructor_mismatch -> unit diff --git a/upstream/ocaml_502/typing/includemod.ml b/upstream/ocaml_502/typing/includemod.ml new file mode 100644 index 0000000000..c806691483 --- /dev/null +++ b/upstream/ocaml_502/typing/includemod.ml @@ -0,0 +1,1245 @@ +(**************************************************************************) +(* *) +(* 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 + | Empty_struct + (** For backward compatibility's sake, an empty struct can be implicitly + converted to an unit module *) + + 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, Includecore.value_mismatch) 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; + leftovers: (signature_item * signature_item * int) 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 (diff vd1 vd2 err))) + +(* 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 ~strengthen env path = + match + if strengthen then Env.find_strengthened_module ~aliasable:true path env + else (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 ~strengthen:false 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. *) + +(* When computing a signature difference, we need to distinguish between + recoverable errors at the value level and unrecoverable errors at the type + level that require us to stop the computation of the difference due to + incoherent types. +*) +type 'a recoverable_error = { error: 'a; recoverable:bool } +let mark_error_as_recoverable r = + Result.map_error (fun error -> { error; recoverable=true}) r +let mark_error_as_unrecoverable r = + Result.map_error (fun error -> { error; recoverable=false}) r + + +module Sign_diff = struct + type t = { + runtime_coercions: (int * Typedtree.module_coercion) list; + shape_map: Shape.Map.t; + deep_modifications:bool; + errors: (Ident.t * Error.sigitem_symptom) list; + leftovers: ((Types.signature_item as 'it) * 'it * int) list + } + + let empty = { + runtime_coercions = []; + shape_map = Shape.Map.empty; + deep_modifications = false; + errors = []; + leftovers = [] + } + + let merge x y = + { + runtime_coercions = x.runtime_coercions @ y.runtime_coercions; + shape_map = y.shape_map; + (* the shape map is threaded the map during the difference computation, + the last shape map contains all previous elements. *) + deep_modifications = x.deep_modifications || y.deep_modifications; + errors = x.errors @ y.errors; + leftovers = x.leftovers @ y.leftovers + } +end + +(** + In the group of mutual functions below, the [~in_eq] argument is [true] when + we are in fact checking equality of module types. + + The module subtyping relation [A <: B] checks that [A.T = B.T] when [A] + and [B] define a module type [T]. The relation [A.T = B.T] is equivalent + to [(A.T <: B.T) and (B.T <: A.T)], but checking both recursively would lead + to an exponential slowdown (see #10598 and #10616). + To avoid this issue, when [~in_eq] is [true], we compute a coarser relation + [A << B] which is the same as [A <: B] except that module types [T] are + checked only for [A.T << B.T] and not the reverse. + Thus, we can implement a cheap module type equality check [A.T = B.T] by + computing [(A.T << B.T) and (B.T << A.T)], avoiding the exponential slowdown + described above. +*) + +let rec modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape = + match try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape 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 ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = + 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, orig_shape) + | (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 ~strengthen:false env p1 with + | Error e -> Error (Error.Mt_core e) + | Ok mty1 -> + match strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark + subst mty1 p1 mty2 orig_shape + 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, orig_shape) + else + begin match expand_modtype_path env p1, expand_modtype_path env p2 with + | Some mty1, Some mty2 -> + try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape + | 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 ~in_eq ~loc env ~mark subst p1 mty2 orig_shape + | 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 ~in_eq ~loc env ~mark subst mty1 p2 orig_shape + | 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 ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape + 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 ~in_eq ~loc env ~mark:(negate_mark mark) + subst param1 param2 + in + let var, res_shape = + match Shape.decompose_abs orig_shape with + | Some (var, res_shape) -> var, res_shape + | None -> + (* Using a fresh variable with a placeholder uid here is fine: users + will never try to jump to the definition of that variable. + If they try to jump to the parameter from inside the functor, + they will use the variable shape that is stored in the local + environment. *) + let var, shape_var = + Shape.fresh_var Uid.internal_not_actually_unique + in + var, Shape.app orig_shape ~arg:shape_var + in + let cc_res = modtypes ~in_eq ~loc env ~mark subst res1 res2 res_shape in + begin match cc_arg, cc_res with + | Ok Tcoerce_none, Ok (Tcoerce_none, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_none, final_shape) + | Ok cc_arg, Ok (cc_res, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_functor(cc_arg, cc_res), final_shape) + | _, 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 ~in_eq ~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 ~in_eq ~loc env ~mark Subst.identity arg2' arg1 + Shape.dummy_mod + with + | Ok (cc, _) -> Ok cc + | Error err -> Error (Error.Mismatch err) + in + let env, subst = equate_one_functor_param subst env arg2' name1 name2 in + cc_arg, env, subst + | _, _ -> + Error (Error.Incompatible_params (param1, param2)), env, subst + +and equate_one_functor_param subst env arg2' name1 name2 = + match name1, name2 with + | Some id1, Some id2 -> + (* two matching abstract parameters: we add one identifier to the + environment and record the equality between the two identifiers + in the substitution *) + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | None, Some id2 -> + let id1 = Ident.rename id2 in + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | Some id1, None -> + Env.add_module id1 Mp_present arg2' env, subst + | None, None -> + env, subst + +and strengthened_modtypes ~in_eq ~loc ~aliasable env ~mark + subst mty1 path1 mty2 shape = + match mty1, mty2 with + | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> + Ok (Tcoerce_none, shape) + | _, _ -> + let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in + modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape + +and strengthened_module_decl ~loc ~aliasable env ~mark + subst md1 path1 md2 shape = + 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, shape) + | _, _ -> + let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in + modtypes ~in_eq:false ~loc env ~mark subst md1.md_type md2.md_type shape + +(* Inclusion between signatures *) + +and signatures ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = + (* 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 nb_exported pos tbl = function + [] -> nb_exported, pos, tbl + | item :: rem -> + let pos, nextpos = + if is_runtime_component item then pos, pos + 1 + else -1, pos + in + match item_visibility item with + | Hidden -> + (* do not pair private items. *) + build_component_table nb_exported nextpos tbl rem + | Exported -> + let (id, _loc, name) = item_ident_name item in + build_component_table (nb_exported + 1) nextpos + (FieldMap.add name (id, item, pos) tbl) rem + in + let exported_len1, runtime_len1, comps1 = + build_component_table 0 0 FieldMap.empty sig1 + in + let exported_len2, runtime_len2 = + List.fold_left (fun (el, rl) i -> + let el = match item_visibility i with Hidden -> el | Exported -> el + 1 in + let rl = if is_runtime_component i then rl + 1 else rl in + el, rl + ) (0, 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 open Sign_diff in + let d = + signature_components ~in_eq ~loc env ~mark new_env subst mod_shape + Shape.Map.empty + (List.rev paired) + in + begin match unpaired, d.errors, d.runtime_coercions, d.leftovers with + | [], [], cc, [] -> + let shape = + if not d.deep_modifications && exported_len1 = exported_len2 + then mod_shape + else Shape.str ?uid:mod_shape.Shape.uid d.shape_map + in + if runtime_len1 = runtime_len2 then (* see PR#5098 *) + Ok (simplify_structure_coercion cc id_pos_list, shape) + else + Ok (Tcoerce_structure (cc, id_pos_list), shape) + | missings, incompatibles, runtime_coercions, leftovers -> + Error { + Error.env=new_env; + missings; + incompatibles; + oks=runtime_coercions; + leftovers; + } + 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 match FieldMap.find name2 comps1 with + | (id1, item1, pos1) -> + 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 + | exception 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 ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map paired = + match paired with + | [] -> Sign_diff.{ empty with shape_map } + | (sigi1, sigi2, pos) :: rem -> + let shape_modified = ref false in + let id, item, shape_map, 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 item = mark_error_as_recoverable item in + let present_at_runtime = match valdecl2.val_kind with + | Val_prim _ -> false + | _ -> true + in + let shape_map = Shape.Map.add_value_proj shape_map id1 orig_shape in + id1, item, shape_map, 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 + let item = mark_error_as_unrecoverable item in + (* Right now we don't filter hidden constructors / labels from the + shape. *) + let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in + id1, item, shape_map, false + | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> + let item = + extension_constructors ~loc env ~mark subst id1 ext1 ext2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_extcons_proj shape_map id1 orig_shape + in + id1, item, shape_map, true + | Sig_module(id1, pres1, mty1, _, _), Sig_module(_, pres2, mty2, _, _) + -> begin + let orig_shape = + Shape.(proj orig_shape (Item.module_ id1)) + in + let item = + module_declarations ~in_eq ~loc env ~mark subst id1 mty1 mty2 + orig_shape + in + let item, shape_map = + match item with + | Ok (cc, shape) -> + if shape != orig_shape then shape_modified := true; + let mod_shape = Shape.set_uid_if_none shape mty1.md_uid in + Ok cc, Shape.Map.add_module shape_map id1 mod_shape + | Error diff -> + Error (Error.Module_type diff), + (* We add the original shape to the map, even though + there is a type error. + It could still be useful for merlin. *) + Shape.Map.add_module shape_map id1 orig_shape + 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 + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, present_at_runtime + end + | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) -> + let item = + modtype_infos ~in_eq ~loc env ~mark subst id1 info1 info2 + in + let shape_map = + Shape.Map.add_module_type_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, false + | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) -> + let item = + class_declarations ~old_env env subst decl1 decl2 + in + let shape_map = + Shape.Map.add_class_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, true + | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) -> + let item = + class_type_declarations ~loc ~old_env env subst info1 info2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_class_type_proj shape_map id1 orig_shape + in + id1, item, shape_map, false + | _ -> + assert false + in + let deep_modifications = !shape_modified in + let first = + match item with + | Ok x -> + let runtime_coercions = + if present_at_runtime then [pos,x] else [] + in + Sign_diff.{ empty with deep_modifications; runtime_coercions } + | Error { error; recoverable=_ } -> + Sign_diff.{ empty with errors=[id,error]; deep_modifications } + in + let continue = match item with + | Ok _ -> true + | Error x -> x.recoverable + in + let rest = + if continue then + signature_components ~in_eq ~loc old_env ~mark env subst + orig_shape shape_map rem + else Sign_diff.{ empty with leftovers=rem } + in + Sign_diff.merge first rest + +and module_declarations ~in_eq ~loc env ~mark subst id1 md1 md2 orig_shape = + 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 ~in_eq ~loc ~aliasable:true env ~mark subst + md1.md_type p1 md2.md_type orig_shape + +(* Inclusion between module type specifications *) + +and modtype_infos ~in_eq ~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 ~in_eq ~loc env ~mark mty1 mty2 + | (None, Some mty2) -> + let mty1 = Mty_ident(Path.Pident id) in + check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 in + match r with + | Ok _ as ok -> ok + | Error e -> Error Error.(Module_type_declaration (diff info1 info2 e)) + +and check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 = + let c1 = + modtypes ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2 Shape.dummy_mod + in + let c2 = + (* For nested module type paths, we check only one side of the equivalence: + the outer module type is the one responsible for checking the other side + of the equivalence. + *) + if in_eq then None + else + let mark = negate_mark mark in + Some ( + modtypes ~in_eq:true ~loc env ~mark Subst.identity + mty2 mty1 Shape.dummy_mod + ) + in + match c1, c2 with + | Ok (Tcoerce_none, _), (Some Ok (Tcoerce_none, _)|None) -> Ok Tcoerce_none + | Ok (c1, _), (Some Ok _ | None) -> + (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." + print_coercion _c1 print_coercion _c2; *) + Error Error.(Illegal_permutation c1) + | Ok _, Some Error e -> Error Error.(Not_greater_than e) + | Error e, (Some Ok _ | None) -> Error Error.(Not_less_than e) + | Error less_than, Some 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, _) | Path.Pextra_ty (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 + +type application_name = + | Anonymous_functor + | Full_application_path of Longident.t + | Named_leftmost_functor of Longident.t +exception Apply_error of { + loc : Location.t ; + env : Env.t ; + app_name : application_name ; + 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 ~in_eq:false ~loc ~aliasable env ~mark:Mark_both + Subst.identity mty1 path1 mty2 Shape.dummy_mod + |> Result.map fst + +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 app_name = Full_application_path lid_whole_app in + raise (Apply_error {loc; env; app_name; 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 unit_shape = + match + signatures ~in_eq:false ~loc:(Location.in_file impl_name) env ~mark + Subst.identity impl_sig intf_sig unit_shape + 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 + + module Defs = struct + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state = { + res: module_type option; + env: Env.t; + subst: Subst.t; + } + end + open Defs + + module Diff = Diffing.Define(Defs) + + let param_name = function + | Named(x,_) -> x + | Unit -> None + + let weight: Diff.change -> _ = 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 + + + + 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 + + (* Whenever we have a named parameter that doesn't match it anonymous + counterpart, we add it to the typing environment because it may + contain useful abbreviations, but without adding any equations *) + let bind id arg state = + let arg' = Subst.modtype Keep state.subst arg in + let env = Env.add_module id Mp_present arg' state.env in + { state with env } + + let rec update (d:Diff.change) st = + match d with + | Insert (Unit | Named (None,_)) + | Delete (Unit | Named (None,_)) + | Keep (Unit,_,_) + | Keep (_,Unit,_) -> + (* No named abstract parameters: we keep the same environment *) + st, [||] + | Insert (Named (Some id, arg)) | Delete (Named (Some id, arg)) -> + (* one named parameter to bind *) + st |> bind id arg |> expand_params + | Change (delete, insert, _) -> + (* Change should be delete + insert: we add both abstract parameters + to the environment without equating them. *) + let st, _expansion = update (Diffing.Delete delete) st in + update (Diffing.Insert insert) st + | Keep (Named (name1, _), Named (name2, arg2), _) -> + let arg = Subst.modtype Keep st.subst arg2 in + let env, subst = + equate_one_functor_param st.subst st.env arg name1 name2 + in + expand_params { st with env; subst } + + let diff env (l1,res1) (l2,_) = + let module Compute = Diff.Left_variadic(struct + let test st mty1 mty2 = + let loc = Location.none in + let res, _, _ = + functor_param ~in_eq:false ~loc st.env ~mark:Mark_neither + st.subst mty1 mty2 + in + res + let update = update + let weight = weight + end) + 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 + Compute.diff state param1 param2 + +end + +module Functor_app_diff = struct + module I = Functor_inclusion_diff + module Defs= struct + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state = I.Defs.state + end + module Diff = Diffing.Define(Defs) + + let weight: Diff.change -> _ = 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 | Empty_struct | 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 | Empty_struct | Anonymous), Some _ -> 1 + end + + let update (d: Diff.change) (st:Defs.state) = + let open Error in + match d with + | Insert (Unit|Named(None,_)) + | Delete _ (* delete is a concrete argument, not an abstract parameter*) + | Keep ((Unit,_),_,_) (* Keep(Unit,_) implies Keep(Unit,Unit) *) + | Keep (_,(Unit|Named(None,_)),_) + | Change (_,(Unit|Named (None,_)), _ ) -> + (* no abstract parameters to add, nor any equations *) + st, [||] + | Insert(Named(Some param, param_ty)) + | Change(_, Named(Some param, param_ty), _ ) -> + (* Change is Delete + Insert: we add the Inserted parameter to the + environment to track equalities with external components that the + parameter might add. *) + let mty = Subst.modtype Keep st.subst param_ty in + let env = Env.add_module ~arg:true param Mp_present mty st.env in + I.expand_params { st with env } + | Keep ((Named arg, _mty) , Named (Some param, _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 } + | Keep (((Anonymous|Empty_struct), mty), + Named (Some param, _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} + + let diff env ~f ~args = + let params, res = retrieve_functor_params env f in + let module Compute = Diff.Right_variadic(struct + let update = update + let test (state:Defs.state) (arg,arg_mty) param = + let loc = Location.none in + let res = match (arg:Error.functor_arg_descr), param with + | (Unit|Empty_struct), Unit -> Ok Tcoerce_none + | Unit, Named _ | (Anonymous | Named _), Unit -> + Result.Error (Error.Incompatible_params(arg,param)) + | ( Anonymous | Named _ | Empty_struct ), Named (_, param) -> + match + modtypes ~in_eq:false ~loc state.env ~mark:Mark_neither + state.subst arg_mty param Shape.dummy_mod + with + | Error mty -> Result.Error (Error.Mismatch mty) + | Ok (cc, _) -> Ok cc + in + res + let weight = weight + end) + in + let args = Array.of_list args in + let params = Array.of_list params in + let state : Defs.state = + { env; subst = Subst.identity; res = I.keep_expansible_param res } + in + Compute.diff state args params + +end + +(* Hide the context and substitution parameters to the outside world *) + +let modtypes_with_shape ~shape ~loc env ~mark mty1 mty2 = + match modtypes ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 shape + with + | Ok (cc, shape) -> cc, shape + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let modtypes ~loc env ~mark mty1 mty2 = + match modtypes ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let signatures env ~mark sig1 sig2 = + match signatures ~in_eq:false ~loc:Location.none env ~mark + Subst.identity sig1 sig2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | 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 Shape.dummy_mod with + | Ok (x, _shape) -> x + | Error mdiff -> + raise (Error(env,Error.(In_Module_type mdiff))) + +let expand_module_alias ~strengthen env path = + match expand_module_alias ~strengthen 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 ~in_eq:false ~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_502/typing/includemod.mli b/upstream/ocaml_502/typing/includemod.mli new file mode 100644 index 0000000000..a57d51b67c --- /dev/null +++ b/upstream/ocaml_502/typing/includemod.mli @@ -0,0 +1,261 @@ +(**************************************************************************) +(* *) +(* 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 + | Empty_struct + (** For backward compatibility's sake, an empty struct can be implicitly + converted to an unit module. *) + + type core_sigitem_symptom = + | Value_descriptions of + (Types.value_description, Includecore.value_mismatch) 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; + leftovers: ((Types.signature_item as 'it) * 'it * int) list + (** signature items that could not be compared due to type divergence *) + } + 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 modtypes_with_shape: + shape:Shape.t -> loc:Location.t -> Env.t -> mark:mark -> + module_type -> module_type -> module_coercion * Shape.t + +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 -> Shape.t -> module_coercion * Shape.t + +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 + +type application_name = + | Anonymous_functor (** [(functor (_:sig end) -> struct end)(Int)] *) + | Full_application_path of Longident.t (** [F(G(X).P)(Y)] *) + | Named_leftmost_functor of Longident.t (** [F(struct end)...(...)] *) + +exception Apply_error of { + loc : Location.t ; + env : Env.t ; + app_name : application_name ; + mty_f : module_type ; + args : (Error.functor_arg_descr * Types.module_type) list ; + } + +val expand_module_alias: strengthen:bool -> Env.t -> Path.t -> Types.module_type + +module Functor_inclusion_diff: sig + module Defs: sig + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state + end + val diff: Env.t -> + Types.functor_parameter list * Types.module_type -> + Types.functor_parameter list * Types.module_type -> + Diffing.Define(Defs).patch +end + +module Functor_app_diff: sig + module Defs: sig + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state + end + val diff: + Env.t -> + f:Types.module_type -> + args:(Error.functor_arg_descr * Types.module_type) list -> + Diffing.Define(Defs).patch +end diff --git a/upstream/ocaml_502/typing/includemod_errorprinter.ml b/upstream/ocaml_502/typing/includemod_errorprinter.ml new file mode 100644 index 0000000000..5c538592fa --- /dev/null +++ b/upstream/ocaml_502/typing/includemod_errorprinter.ml @@ -0,0 +1,976 @@ +(**************************************************************************) +(* *) +(* 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 Style = Misc.Style + +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 "" + 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," + (Style.as_inline_code Printtyp.path) (path_of_context cxt) + else + Format.fprintf ppf "@[at position@ %a,@]" + (Style.as_inline_code 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:@ " + (Style.as_inline_code Printtyp.path) (path_of_context cxt) + else + Format.fprintf ppf "@[At position@ %a@]@ " + (Style.as_inline_code 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 %a" + (Includemod.kind_of_field_desc kind) + Style.inline_code (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 + "@[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 *) + open Diffing + 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 + | Insert mty -> + Insert (add_shorthand Expected pos mty) + | Delete mty -> + Delete (add_shorthand (elide_if_app ctx Got) pos mty) + | Change (g, e, p) -> + Change + (add_shorthand Got pos g, + add_shorthand Expected pos e, p) + | Keep (g, e, p) -> + 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 "()" + | Empty_struct -> Format.dprintf "(struct end)" + | 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 "()" + | Empty_struct -> Format.dprintf "(struct end)" + | 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 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 = Diffing.(style @@ classify x) in + Format.dprintf "%a%t%a" + Format.pp_open_stag (Style.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: _ Diffing.change -> _ = function + | Insert mty + | Keep(_,mty,_) + | Change (_,mty,_) as x -> + Some (param_id mty,(x, mty)) + | 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: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (param_id mty,(x,mty)) + | 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: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (None,(x,mty)) + | 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" + | Empty_struct -> + (* an empty structure can be used in both applicative and generative + context *) + assert false + end + + let subcase sub ~expansion_token env (pos, diff) = + Location.msg "%a%a%a%a@[%t@]%a" + Format.pp_print_tab () + Format.pp_open_tbox () + Diffing.prefix (pos, Diffing.classify 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@[%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 env id x = + match x with + | Err.Value_descriptions diff -> + Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + "Values do not match" + !Oprint.out_sig_item + (Printtyp.tree_of_value_description id diff.got) + "is not included in" + !Oprint.out_sig_item + (Printtyp.tree_of_value_description id diff.expected) + (Includecore.report_value_mismatch + "the first" "the second" env) diff.symptom + show_locs (diff.got.val_loc, diff.expected.val_loc) + Printtyp.Conflicts.print_explanations + | Err.Type_declarations diff -> + Format.dprintf "@[@[%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" env) diff.symptom + show_locs (diff.got.type_loc, diff.expected.type_loc) + Printtyp.Conflicts.print_explanations + | Err.Extension_constructors diff -> + Format.dprintf "@[@[%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" env) diff.symptom + show_locs (diff.got.ext_loc, diff.expected.ext_loc) + Printtyp.Conflicts.print_explanations + | Err.Class_type_declarations diff -> + Format.dprintf + "@[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 Type_scheme) 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 + "@[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 Type_scheme) 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) + (Style.as_inline_code Printtyp.ident) id + (show_loc "Expected declaration") loc + +let module_types {Err.got=mty1; expected=mty2} = + Format.dprintf + "@[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 + "@[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 + "@[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 %a@ does not match the interface %a:@ " + Style.inline_code diff.got Style.inline_code 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" + (Style.as_inline_code 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 = + match diff.symptom with + | Mt_core _ -> + (* In those cases, the refined error messages for the current error + will at most add some minor comments on the current error. + It is thus better to avoid eliding the current error message. + *) + dwith_context ctx (inner diff) + | _ -> 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" + (Style.as_inline_code 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 + "@[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 env 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 (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.Inclusion.insert mty + | Delete mty -> Functor_suberror.Inclusion.delete mty + | Keep (x, y, _) -> Functor_suberror.Inclusion.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.Inclusion.incompatible i + | 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 (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.App.insert mty + | Delete mty -> Functor_suberror.App.delete mty + | Keep (x, y, _) -> Functor_suberror.App.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.App.incompatible i + | 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 env 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 (app_name, mty_f, args) = + 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 *) + | [ _, Change (_, _, Err.Incompatible_params (i,_)) ] -> + Location.errorf ~loc "%t" (Functor_suberror.App.incompatible i) + | [ _, 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 not_functor = + List.for_all (function _, Diffing.Delete _ -> true | _ -> false) d + in + if not_functor then + match app_name with + | Includemod.Named_leftmost_functor lid -> + Location.errorf ~loc + "@[The module %a is not a functor, it cannot be applied.@]" + (Style.as_inline_code Printtyp.longident) lid + | Includemod.Anonymous_functor + | Includemod.Full_application_path _ + (* The "non-functor application in term" case is directly handled in + [Env] and it is the only case where we have a full application + path at hand. Thus this case of the or-pattern is currently + unreachable and we don't try to specialize the corresponding error + message. *) -> + Location.errorf ~loc + "@[This module is not a functor, it cannot be applied.@]" + else + let intro ppf = + match app_name with + | Includemod.Anonymous_functor -> + Format.fprintf ppf "This functor application is ill-typed." + | Includemod.Full_application_path lid -> + Format.fprintf ppf "The functor application %a is ill-typed." + (Style.as_inline_code Printtyp.longident) lid + | Includemod.Named_leftmost_functor lid -> + Format.fprintf ppf + "This application of the functor %a is ill-typed." + (Style.as_inline_code Printtyp.longident) lid + in + 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 + "@[%t@ \ + These arguments:@;<1 2>@[%t@]@ \ + do not match these parameters:@;<1 2>@[functor@ %t@ -> ...@]@]" + intro + actual expected + +let register () = + Location.register_error_of_exn + (function + | Includemod.Error err -> Some (report_error err) + | Includemod.Apply_error {loc; env; app_name; mty_f; args} -> + Some (Printtyp.wrap_printing_env env ~error:true (fun () -> + report_apply_error ~loc env (app_name, mty_f, args)) + ) + | _ -> None + ) diff --git a/upstream/ocaml_502/typing/includemod_errorprinter.mli b/upstream/ocaml_502/typing/includemod_errorprinter.mli new file mode 100644 index 0000000000..12ea2169b0 --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/mtype.ml b/upstream/ocaml_502/typing/mtype.ml new file mode 100644 index 0000000000..43fced07ab --- /dev/null +++ b/upstream/ocaml_502/typing/mtype.ml @@ -0,0 +1,565 @@ +(**************************************************************************) +(* *) +(* 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_lazy env mty = + let open Subst.Lazy in + match mty with + MtyL_ident p -> + begin try + scrape_lazy env (Env.find_modtype_expansion_lazy p env) + with Not_found -> + mty + end + | _ -> mty + +let scrape env mty = + match mty with + Mty_ident p -> + Subst.Lazy.force_modtype (scrape_lazy env (MtyL_ident p)) + | _ -> mty + +let freshen ~scope mty = + Subst.modtype (Rescope scope) Subst.identity mty + +let rec strengthen_lazy ~aliasable env mty p = + let open Subst.Lazy in + match scrape_lazy env mty with + MtyL_signature sg -> + MtyL_signature(strengthen_lazy_sig ~aliasable env sg p) + | MtyL_functor(Named (Some param, arg), res) + when !Clflags.applicative_functors -> + let env = + Env.add_module_lazy ~update_summary:false param Mp_present arg env + in + MtyL_functor(Named (Some param, arg), + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) + | MtyL_functor(Named (None, arg), res) + when !Clflags.applicative_functors -> + let param = Ident.create_scoped ~scope:(Path.scope p) "Arg" in + MtyL_functor(Named (Some param, arg), + strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) + | mty -> + mty + +and strengthen_lazy_sig' ~aliasable env sg p = + let open Subst.Lazy in + match sg with + [] -> [] + | (SigL_value(_, _, _) as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | SigL_type(id, {type_kind=Type_abstract _}, _, _) :: rem + when Btype.is_row_name (Ident.name id) -> + strengthen_lazy_sig' ~aliasable env rem p + | SigL_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 Btype.type_kind_is_abstract decl then + { decl with type_private = Public; type_manifest = manif } + else + { decl with type_manifest = manif } + in + SigL_type(id, newdecl, rs, vis) :: + strengthen_lazy_sig' ~aliasable env rem p + | (SigL_typext _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | SigL_module(id, pres, md, rs, vis) :: rem -> + let str = + strengthen_lazy_decl ~aliasable env md (Pdot(p, Ident.name id)) + in + let env = + Env.add_module_declaration_lazy ~update_summary:false id pres md env in + SigL_module(id, pres, str, rs, vis) + :: strengthen_lazy_sig' ~aliasable env rem p + (* Need to add the module in case it defines manifest module types *) + | SigL_modtype(id, decl, vis) :: rem -> + let newdecl = + match decl.mtdl_type with + | Some _ when not aliasable -> + (* [not alisable] condition needed because of recursive modules. + See [Typemod.check_recmodule_inclusion]. *) + decl + | _ -> + {decl with mtdl_type = Some(MtyL_ident(Pdot(p,Ident.name id)))} + in + let env = Env.add_modtype_lazy ~update_summary:false id decl env in + SigL_modtype(id, newdecl, vis) :: + strengthen_lazy_sig' ~aliasable env rem p + (* Need to add the module type in case it is manifest *) + | (SigL_class _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + | (SigL_class_type _ as sigelt) :: rem -> + sigelt :: strengthen_lazy_sig' ~aliasable env rem p + +and strengthen_lazy_sig ~aliasable env sg p = + let sg = Subst.Lazy.force_signature_once sg in + let sg = strengthen_lazy_sig' ~aliasable env sg p in + Subst.Lazy.of_signature_items sg + +and strengthen_lazy_decl ~aliasable env md p = + let open Subst.Lazy in + match md.mdl_type with + | MtyL_alias _ -> md + | _ when aliasable -> {md with mdl_type = MtyL_alias p} + | mty -> {md with mdl_type = strengthen_lazy ~aliasable env mty p} + +let () = Env.strengthen := strengthen_lazy + +let strengthen ~aliasable env mty p = + let mty = strengthen_lazy ~aliasable env (Subst.Lazy.of_modtype mty) p in + Subst.Lazy.force_modtype mty + +let strengthen_decl ~aliasable env md p = + let md = strengthen_lazy_decl ~aliasable env + (Subst.Lazy.of_module_decl md) p in + Subst.Lazy.force_module_decl md + +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, _) | Pextra_ty (p, _) + -> Path.Set.add p (get_prefixes p) + +let rec get_arg_paths = function + | Pident _ -> Path.Set.empty + | Pdot (p, _) | Pextra_ty (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)) + | Pextra_ty (p1, extra) -> + let p1' = rollback_path subst p1 in + if Path.same p1 p1' then p + else rollback_path subst (Pextra_ty (p1', extra)) + +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 = + match get_desc ty with + Tvar _ -> + let level = get_level ty in + 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_502/typing/mtype.mli b/upstream/ocaml_502/typing/mtype.mli new file mode 100644 index 0000000000..68d290b36f --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/oprint.ml b/upstream/ocaml_502/typing/oprint.ml new file mode 100644 index 0000000000..70d5a0dc99 --- /dev/null +++ b/upstream/ocaml_502/typing/oprint.ml @@ -0,0 +1,869 @@ +(**************************************************************************) +(* *) +(* 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 when Lexer.is_keyword s -> fprintf ppf "\\#%s" s + | 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 if Lexer.is_keyword 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_constr ppf name = + match name with + | Oide_ident {printed_name = ("true" | "false") as c} -> + (* despite being keywords, these are constructor names + and should not be escaped *) + fprintf ppf "%s" c + | _ -> print_ident ppf name + +let print_out_value ppf tree = + let rec print_tree_1 ppf = + function + | Oval_constr (name, [param]) -> + fprintf ppf "@[<1>%a@ %a@]" print_constr name print_constr_param param + | Oval_constr (name, (_ :: _ as params)) -> + fprintf ppf "@[<1>%a@ (%a)@]" print_constr name + (print_tree_list print_tree_1 ",") params + | Oval_variant (name, Some param) -> + fprintf ppf "@[<2>`%a@ %a@]" print_lident name print_constr_param param + | Oval_lazy param -> + fprintf ppf "@[<2>lazy@ %a@]" 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 maxlen = max maxlen 8 in (* always show a little prefix *) + 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 "" + 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_constr ppf name + | Oval_variant (name, None) -> fprintf ppf "`%a" print_lident 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 ty_var ~non_gen ppf s = + pr_var ppf (if non_gen then "_" ^ s else s) + +let pr_vars = + print_list pr_var (fun ppf -> fprintf ppf "@ ") + +let print_arg_label ppf (lbl : Asttypes.arg_label) = + match lbl with + | Nolabel -> () + | Labelled s -> fprintf ppf "%a:" print_lident s + | Optional s -> fprintf ppf "?%a:" print_lident s + +let rec print_out_type ppf = + function + | Otyp_alias {non_gen; aliased; alias } -> + fprintf ppf "@[%a@ as %a@]" + print_out_type aliased + (ty_var ~non_gen) alias + | Otyp_poly (sl, ty) -> + fprintf ppf "@[%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; + print_arg_label ppf lab; + 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 (id, tyl) -> + fprintf ppf "@[%a#%a@]" print_typargs tyl 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; open_row} -> + fprintf ppf "@[<2>< %a >@]" (print_fields open_row) fields + | Otyp_stuff s -> pp_print_string ppf s + | Otyp_var (non_gen, s) -> ty_var ~non_gen ppf s + | Otyp_variant (row_fields, closed, tags) -> + let print_present ppf = + function + None | Some [] -> () + | Some l -> fprintf ppf "@;<1 -2>> @[%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@[@[%a@]%a@]@ ]@]" + (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 open_row ppf = + function + [] -> + if open_row then fprintf ppf ".."; + | [s, t] -> + fprintf ppf "%a : %a" print_lident s print_out_type t; + if open_row then fprintf ppf ";@ "; + print_fields open_row ppf [] + | (s, t) :: l -> + fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields open_row) 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 "@[`%a%t%a@]" print_lident 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%a :@ %a@];" (if mut then "mutable " else "") + print_lident name + print_out_type arg + +let out_label = ref print_out_label + +let out_type = ref print_out_type + +let out_type_args = ref print_typargs + +(* Class types *) + +let print_type_parameter ?(non_gen=false) ppf s = + if s = "_" then fprintf ppf "_" else ty_var ~non_gen ppf s + +let type_parameter ppf {ot_non_gen=non_gen; ot_name=ty; ot_variance=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 ~non_gen) 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 "@[%a%a ->@ %a@]" print_arg_label lab + 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 "@[@[<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%a :@ %a@]" + (if priv then "private " else "") (if virt then "virtual " else "") + print_lident name !out_type ty + | Ocsg_value (name, mut, vr, ty) -> + fprintf ppf "@[<2>val %s%s%a :@ %a@]" + (if mut then "mutable " else "") + (if vr then "virtual " else "") + print_lident 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 constructor_of_extension_constructor + (ext : out_extension_constructor) : out_constructor += + { + ocstr_name = ext.oext_name; + ocstr_args = ext.oext_args; + ocstr_return_type = ext.oext_ret_type; + } + +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 "@[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 + (constructor_of_extension_constructor ext :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [constructor_of_extension_constructor ext] + 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%a@ :@ %a@]" + (if rs = Orec_next then "and" else "class") + (if vir_flag then " virtual" else "") print_out_class_params params + print_lident name !out_class_type clt + | Osig_class_type (vir_flag, name, params, clt, rs) -> + fprintf ppf "@[<2>%s%s@ %a%a@ =@ %a@]" + (if rs = Orec_next then "and" else "class type") + (if vir_flag then " virtual" else "") print_out_class_params params + print_lident name !out_class_type clt + | Osig_typext (ext, Oext_exception) -> + fprintf ppf "@[<2>exception %a@]" + print_out_constr (constructor_of_extension_constructor ext) + | 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 + [] -> print_lident ppf td.otype_name + | [param] -> + fprintf ppf "@[%a@ %a@]" type_parameter param + print_lident td.otype_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %a@]" + (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) + td.otype_params + print_lident 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>@[%t%a@]%t%t%t@]" + print_name_params + print_out_tkind ty + print_constraints + print_immediate + print_unboxed + +and print_out_constr ppf constr = + let { + ocstr_name = name; + ocstr_args = tyl; + ocstr_return_type = return_type; + } = constr in + let name = + match name with + | "::" -> "(::)" (* #7200 *) + | s -> s + in + match return_type 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 "%a" print_lident ext.oext_type_name + | [ty_param] -> + fprintf ppf "@[%a@ %a@]" + (print_type_parameter ~non_gen:false) + ty_param + print_lident ext.oext_type_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %a@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + ext.oext_type_params + print_lident ext.oext_type_name + in + fprintf ppf "@[type %t +=%s@;<1 2>%a@]" + print_extended_type + (if ext.oext_private = Asttypes.Private then " private" else "") + print_out_constr + (constructor_of_extension_constructor ext) + +and print_out_type_extension ppf te = + let print_extended_type ppf = + match te.otyext_params with + [] -> fprintf ppf "%a" print_lident te.otyext_name + | [param] -> + fprintf ppf "@[%a@ %a@]" + (print_type_parameter ~non_gen:false) param + print_lident te.otyext_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %a@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + te.otyext_params + print_lident te.otyext_name + in + fprintf ppf "@[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 + (constructor_of_extension_constructor ext :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [constructor_of_extension_constructor ext] + 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 "@[%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_502/typing/oprint.mli b/upstream/ocaml_502/typing/oprint.mli new file mode 100644 index 0000000000..31dad9a906 --- /dev/null +++ b/upstream/ocaml_502/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_type_args : (formatter -> out_type list -> unit) ref +val out_constr : (formatter -> out_constructor -> 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_502/typing/outcometree.mli b/upstream/ocaml_502/typing/outcometree.mli new file mode 100644 index 0000000000..93449f9ec6 --- /dev/null +++ b/upstream/ocaml_502/typing/outcometree.mli @@ -0,0 +1,160 @@ +(**************************************************************************) +(* *) +(* 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 + | Oval_lazy of out_value + +type out_type_param = { + ot_non_gen: bool; + ot_name: string; + ot_variance: Asttypes.variance * Asttypes.injectivity +} + +type out_type = + | Otyp_abstract + | Otyp_open + | Otyp_alias of {non_gen:bool; aliased:out_type; alias:string} + | Otyp_arrow of Asttypes.arg_label * out_type * out_type + | Otyp_class of out_ident * out_type list + | Otyp_constr of out_ident * out_type list + | Otyp_manifest of out_type * out_type + | Otyp_object of { fields: (string * out_type) list; open_row:bool} + | Otyp_record of (string * bool * out_type) list + | Otyp_stuff of string + | Otyp_sum of out_constructor list + | Otyp_tuple of out_type list + | Otyp_var of bool * string + | Otyp_variant of 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_constructor = { + ocstr_name: string; + ocstr_args: out_type list; + ocstr_return_type: out_type option; +} + +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 Asttypes.arg_label * 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: out_constructor 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_502/typing/parmatch.ml b/upstream/ocaml_502/typing/parmatch.ml new file mode 100644 index 0000000000..f6337d467c --- /dev/null +++ b/upstream/ocaml_502/typing/parmatch.ml @@ -0,0 +1,2380 @@ +(**************************************************************************) +(* *) +(* 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 + +type 'pattern parmatch_case = + { pattern : 'pattern; + has_guard : bool; + needs_refute : bool; + } + +let typed_case { c_lhs; c_guard; c_rhs } = + { pattern = c_lhs; + has_guard = Option.is_some c_guard; + needs_refute = (c_rhs.exp_desc = Texp_unreachable); + } + +let untyped_case { Parsetree.pc_lhs; pc_guard; pc_rhs } = + { pattern = pc_lhs; + has_guard = Option.is_some pc_guard; + needs_refute = (pc_rhs.pexp_desc = Parsetree.Pexp_unreachable); + } + +(*************************************) +(* 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 "+", + Uid.internal_not_actually_unique)) + 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 = row_field_repr (get_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 get_level ty = Btype.generic_level then ty + else Subst.type_expr Subst.identity ty + +let get_constructor_type_path ty tenv = + let ty = Ctype.expand_head tenv (clean_copy ty) in + match get_desc ty 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 + let args = if erase_mutable then omegas else args 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 *) +| {pat_desc = (Tpat_var _ | Tpat_alias _ | Tpat_or _); _} -> + 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 {fields; more; name=orig_name; closed; fixed} = row_repr row in + let name, static = + List.fold_left + (fun (nm, static) (_tag,f) -> + match row_field_repr f with + | Reither(_, _, false) -> + (* fixed=false means that this tag is not explicitly matched *) + link_row_field_ext ~inside:f rf_absent; + (None, static) + | Reither (_, _, true) -> (nm, false) + | Rabsent | Rpresent _ -> (nm, static)) + (orig_name, true) fields in + if not closed || name != orig_name then begin + let more' = if static then Btype.newgenty Tnil else Btype.newgenvar () in + (* this unification cannot fail *) + Ctype.unify env more + (Btype.newgenty + (Tvariant + (create_row ~fields:[] ~more:more' + ~closed:true ~name ~fixed))) + 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.has_fixed_explanation row) then + (* closing=true, we are considering the variant as closed *) + List.for_all + (fun (tag,f) -> + match 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_fields row) + else + row_closed row && + List.for_all + (fun (tag,f) -> + row_field_repr f = Rabsent || List.mem tag fields) + (row_fields row) + | 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 env ty = + match Ctype.extract_concrete_typedecl env ty with + | Typedecl (_, path, {type_kind = Type_variant _ | Type_record _}) -> + begin match Env.find_type_descrs path env with + | Type_variant (cstrs,_) when 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] + | _ -> [omega] + end + | Has_no_typedecl -> + begin match get_desc (Ctype.expand_head env ty) with + Ttuple tl -> + [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] + | _ -> [omega] + end + | Typedecl (_, _, {type_kind = Type_abstract _ | Type_open}) + | May_have_typedecl -> [omega] + +let get_variant_constructors env ty = + match Ctype.extract_concrete_typedecl env ty with + | Typedecl (_, path, {type_kind = Type_variant _}) -> + begin match Env.find_type_descrs path env with + | Type_variant (cstrs,_) -> cstrs + | _ -> 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 = "" + +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}, + Uid.internal_not_actually_unique)) + 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 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_fields row) + with + [] -> + let tag = + if Btype.has_fixed_explanation 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.has_fixed_explanation 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 partitioned, 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] removes the elements that are followed by a smaller element. + An element that is preceded by a smaller element may stay in the list. + We thus do two passes on the list, which is returned reversed + the first time. *) + 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 + [] -> [] + | {has_guard=true} :: rem -> initial_matrix rem + | {has_guard=false; pattern=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 + | [] -> [] + | { has_guard = false; _} :: rem -> + initial_only_guarded rem + | { pattern = pat; _ } :: rem -> + [pat] :: initial_only_guarded rem + + +(************************) +(* Exhaustiveness check *) +(************************) + +(* Whether the counter-example contains an extension pattern *) +let contains_extension pat = + exists_pattern + (function + | {pat_desc=Tpat_var (_, {txt="*extension*"}, _)} -> true + | _ -> false) + pat + +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 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 + Format.fprintf fmt "%a@?" Printpat.pretty_pat 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.pattern) + [] 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 vc -> vc.needs_refute) casel then + let rec do_rec pref = function + | [] -> () + | {pattern=q; has_guard; needs_refute=refute} :: 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 + (* 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 = {u with pat_loc = q.pat_loc} in + match pred refute 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 has_guard 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 _ + | 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. +*) + +let all_rhs_idents exp = + let ids = ref Ident.Set.empty 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 + 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_502/typing/parmatch.mli b/upstream/ocaml_502/typing/parmatch.mli new file mode 100644 index 0000000000..6f09ad5e37 --- /dev/null +++ b/upstream/ocaml_502/typing/parmatch.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. *) +(* *) +(**************************************************************************) + +(** Detection of partial matches and unused match cases. *) + +open Asttypes +open Typedtree +open Types + +(** Most checks in this file need not access all information about a case, + and just need a few pieces of information. [parmatch_case] is those + few pieces of information. +*) +type 'pattern parmatch_case = + { pattern : 'pattern; + has_guard : bool; + needs_refute : bool; + (** true if the program text claims the case is unreachable, a la + [function _ -> .] + *) + } + +type 'category typed_case := 'category general_pattern parmatch_case + +val typed_case : 'category case -> 'category typed_case +val untyped_case : Parsetree.case -> Parsetree.pattern parmatch_case + +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 + +(** [pats_of_type] builds a list of patterns from a given expected type, + for explosion of wildcard patterns in Typecore.type_pat. + + There are four interesting cases: + - the type is empty ([]) + - no further explosion is necessary ([Pat_any]) + - a single pattern is generated, from a record or tuple type + or a single-variant type ([tp]) + - a list of patterns, in the case that all branches + are GADT constructors ([tp1; ..; tpn]). + *) +val pats_of_type : Env.t -> type_expr -> pattern list + +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: + (pattern -> pattern option) -> Location.t -> value typed_case list + -> partial + +val check_unused: + (bool -> pattern -> pattern option) -> value typed_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_502/typing/path.ml b/upstream/ocaml_502/typing/path.ml new file mode 100644 index 0000000000..4b44b0b2f0 --- /dev/null +++ b/upstream/ocaml_502/typing/path.ml @@ -0,0 +1,148 @@ +(**************************************************************************) +(* *) +(* 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 + | Pextra_ty of t * extra_ty +and extra_ty = + | Pcstr_ty of string + | Pext_ty + +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 + | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> + let same_extra = match t1, t2 with + | (Pcstr_ty s1, Pcstr_ty s2) -> s1 = s2 + | (Pext_ty, Pext_ty) -> true + | ((Pcstr_ty _ | Pext_ty), _) -> false + in same_extra && same p1 p2 + | (_, _) -> 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 + | (Pextra_ty (p1, t1), Pextra_ty (p2, t2)) -> + let h = compare_extra t1 t2 in + if h <> 0 then h else compare p1 p2 + | (Pident _, (Pdot _ | Papply _ | Pextra_ty _)) + | (Pdot _, (Papply _ | Pextra_ty _)) + | (Papply _, Pextra_ty _) + -> -1 + | ((Pextra_ty _ | Papply _ | Pdot _), Pident _) + | ((Pextra_ty _ | Papply _) , Pdot _) + | (Pextra_ty _, Papply _) + -> 1 +and compare_extra t1 t2 = + match (t1, t2) with + Pcstr_ty s1, Pcstr_ty s2 -> String.compare s1 s2 + | (Pext_ty, Pext_ty) + -> 0 + | (Pcstr_ty _, Pext_ty) + -> -1 + | (Pext_ty, Pcstr_ty _) + -> 1 + +let rec find_free_opt ids = function + Pident id -> List.find_opt (Ident.same id) ids + | Pdot(p, _) | Pextra_ty (p, _) -> find_free_opt ids p + | Papply(p1, p2) -> begin + match find_free_opt ids p1 with + | None -> find_free_opt ids p2 + | Some _ as res -> res + end + +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, _) | Pextra_ty (p, _) -> scope p + | Papply(p1, p2) -> Int.max (scope p1) (scope p2) + +let kfalse _ = false + +let maybe_escape s = + if Lexer.is_keyword s then "\\#" ^ s else s + +let rec name ?(paren=kfalse) = function + Pident id -> maybe_escape (Ident.name id) + | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> + let s = maybe_escape s in + name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s + | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" + | Pextra_ty (p, Pext_ty) -> name ~paren p + +let rec print ppf = function + | Pident id -> Ident.print_with_scope ppf id + | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> + Format.fprintf ppf "%a.%s" print p s + | Papply(p1, p2) -> Format.fprintf ppf "%a(%a)" print p1 print p2 + | Pextra_ty (p, Pext_ty) -> print ppf p + +let rec head = function + Pident id -> id + | Pdot(p, _) | Pextra_ty (p, _) -> head p + | Papply _ -> assert false + +let flatten = + let rec flatten acc = function + | Pident id -> `Ok (id, acc) + | Pdot (p, s) | Pextra_ty (p, Pcstr_ty s) -> flatten (s :: acc) p + | Papply _ -> `Contains_apply + | Pextra_ty (p, Pext_ty) -> flatten acc p + in + fun t -> flatten [] t + +let heads p = + let rec heads p acc = match p with + | Pident id -> id :: acc + | Pdot (p, _) | Pextra_ty (p, _) -> 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) | Pextra_ty (_, Pcstr_ty s) -> s + | Papply(_, p) | Pextra_ty (p, Pext_ty) -> last p + +let is_constructor_typath p = + match p with + | Pident _ | Pdot _ | Papply _ -> false + | Pextra_ty _ -> 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_502/typing/path.mli b/upstream/ocaml_502/typing/path.mli new file mode 100644 index 0000000000..39e76a3727 --- /dev/null +++ b/upstream/ocaml_502/typing/path.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. *) +(* *) +(**************************************************************************) + +(* Access paths *) + +type t = + | Pident of Ident.t + (** Examples: x, List, int *) + | Pdot of t * string + (** Examples: List.map, Float.Array *) + | Papply of t * t + (** Examples: Set.Make(Int), Map.Make(Set.Make(Int)) *) + | Pextra_ty of t * extra_ty + (** [Pextra_ty (p, extra)] are additional paths of types + introduced by specific OCaml constructs. See below. + *) +and extra_ty = + | Pcstr_ty of string + (** [Pextra_ty (p, Pcstr_ty c)] is the type of the inline record for + constructor [c] inside type [p]. + + For example, in + {[ + type 'a t = Nil | Cons of {hd : 'a; tl : 'a t} + ]} + + The inline record type [{hd : 'a; tl : 'a t}] cannot + be named by the user in the surface syntax, but internally + it has the path + [Pextra_ty (Pident `t`, Pcstr_ty "Cons")]. + *) + | Pext_ty + (** [Pextra_ty (p, Pext_ty)] is the type of the inline record for + the extension constructor [p]. + + For example, in + {[ + type exn += Error of {loc : loc; msg : string} + ]} + + The inline record type [{loc : loc; msg : string}] cannot + be named by the user in the surface syntax, but internally + it has the path + [Pextra_ty (Pident `Error`, Pext_ty)]. + *) + +val same: t -> t -> bool +val compare: t -> t -> int +val compare_extra: extra_ty -> extra_ty -> 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_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_502/typing/patterns.ml b/upstream/ocaml_502/typing/patterns.ml new file mode 100644 index 0000000000..456f8dff33 --- /dev/null +++ b/upstream/ocaml_502/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 * Uid.t + | `Alias of pattern * Ident.t * string loc * Uid.t + ] + type pattern = view pattern_data + + let view_desc = function + | Tpat_any -> + `Any + | Tpat_var (id, str, uid) -> + `Var (id, str, uid) + | Tpat_alias (p, id, str, uid) -> + `Alias (p, id, str, uid) + | 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, uid) -> Tpat_var (id, str, uid) + | `Alias (p, id, str, uid) -> Tpat_alias (p, id, str, uid) + | `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 get_desc (Ctype.expand_head q.pat_env q.pat_type) with + | Tvariant type_row -> 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_502/typing/patterns.mli b/upstream/ocaml_502/typing/patterns.mli new file mode 100644 index 0000000000..2ad645b0d0 --- /dev/null +++ b/upstream/ocaml_502/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 * Uid.t + | `Alias of pattern * Ident.t * string loc * Uid.t + ] + 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_502/typing/persistent_env.ml b/upstream/ocaml_502/typing/persistent_env.ml new file mode 100644 index 0000000000..5e59b995d5 --- /dev/null +++ b/upstream/ocaml_502/typing/persistent_env.ml @@ -0,0 +1,380 @@ +(**************************************************************************) +(* *) +(* 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 + +exception Error of error +let error err = raise (Error err) + +module Persistent_signature = struct + type t = + { filename : string; + cmi : Cmi_format.cmi_infos; + visibility : Load_path.visibility } + + let load = ref (fun ~allow_hidden ~unit_name -> + match Load_path.find_normalized_with_visibility (unit_name ^ ".cmi") with + | filename, visibility when allow_hidden -> + Some { filename; cmi = read_cmi filename; visibility} + | filename, Visible -> + Some { filename; cmi = read_cmi filename; visibility = Visible} + | _, Hidden + | 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; + ps_visibility: Load_path.visibility; +} + +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 _ -> () + | Opaque -> register_import_as_opaque penv modname) + ps.ps_flags; + Consistbl.check 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; visibility } = 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; + ps_visibility = visibility; + } 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)) + | 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 cmi = + let modname = Unit_info.Artifact.modname cmi in + let filename = Unit_info.Artifact.filename cmi in + add_import penv modname; + let cmi = read_cmi filename in + let pers_sig = { Persistent_signature.filename; cmi; visibility = Visible } 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 ~allow_hidden 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) when allow_hidden || ps.ps_visibility = Load_path.Visible -> + (ps, pm) + | Found _ -> raise Not_found + | 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 ~allow_hidden ~unit_name:name with + | Some psig -> psig + | None -> + if allow_hidden then 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) + +module Style = Misc.Style +(* Emits a warning if there is no valid cmi for name *) +let check_pers_struct ~allow_hidden penv f ~loc name = + try + ignore (find_pers_struct ~allow_hidden 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 @ \ + %a when %a was expected" + (Style.as_inline_code Location.print_filename) filename + Style.inline_code ps_name + Style.inline_code name + | Inconsistent_import _ -> assert false + | Need_recursive_types name -> + Format.asprintf + "%a uses recursive types" + Style.inline_code name + in + let warn = Warnings.No_cmi_file(name, Some msg) in + Location.prerr_warning loc warn + +let read penv f a = + snd (read_pers_struct penv f true a) + +let find ~allow_hidden penv f name = + snd (find_pers_struct ~allow_hidden penv f true name) + +let check ~allow_hidden 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 ~allow_hidden penv f ~loc name) + end + +let crc_of_unit penv f name = + let (ps, _pm) = find_pers_struct ~allow_hidden:true 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 []; + [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; visibility } = 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; + ps_visibility = visibility + } 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@ \ + %a when %a was expected" + (Style.as_inline_code Location.print_filename) filename + Style.inline_code ps_name + Style.inline_code modname + | Inconsistent_import(name, source1, source2) -> fprintf ppf + "@[The files %a@ and %a@ \ + make inconsistent assumptions@ over interface %a@]" + (Style.as_inline_code Location.print_filename) source1 + (Style.as_inline_code Location.print_filename) source2 + Style.inline_code name + | Need_recursive_types(import) -> + fprintf ppf + "@[Invalid import of %a, which uses recursive types.@ \ + The compilation flag %a is required@]" + Style.inline_code import + Style.inline_code "-rectypes" + +let () = + Location.register_error_of_exn + (function + | Error err -> + Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/upstream/ocaml_502/typing/persistent_env.mli b/upstream/ocaml_502/typing/persistent_env.mli new file mode 100644 index 0000000000..136da7f881 --- /dev/null +++ b/upstream/ocaml_502/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 + +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; + visibility : Load_path.visibility + } + + (** 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 : (allow_hidden:bool -> 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) -> Unit_info.Artifact.t -> 'a +val find : allow_hidden:bool -> 'a t -> (Persistent_signature.t -> 'a) + -> modname -> 'a + +val find_in_cache : 'a t -> modname -> 'a option + +val check : allow_hidden:bool -> '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_502/typing/predef.ml b/upstream/ocaml_502/typing/predef.ml new file mode 100644 index 0000000000..7344be15fc --- /dev/null +++ b/upstream/ocaml_502/typing/predef.ml @@ -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. *) +(* *) +(**************************************************************************) + +(* 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 Definition) 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 build_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 Definition) 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 + let variant constrs = Type_variant (constrs, Variant_regular) in + empty_env + (* Predefined types - alphabetical order *) + |> add_type1 ident_array + ~variance:Variance.full + ~separability:Separability.Ind + |> add_type ident_bool + ~immediate:Always + ~kind:(variant [cstr ident_false []; cstr ident_true []]) + |> add_type ident_char ~immediate:Always + |> add_type ident_exn ~kind:Type_open + |> add_type ident_extension_constructor + |> add_type ident_float + |> add_type ident_floatarray + |> add_type ident_int ~immediate:Always + |> add_type ident_int32 + |> add_type ident_int64 + |> add_type1 ident_lazy_t + ~variance:Variance.covariant + ~separability:Separability.Ind + |> add_type1 ident_list + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]) + |> add_type ident_nativeint + |> add_type1 ident_option + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_none []; cstr ident_some [tvar]]) + |> add_type ident_string + |> add_type ident_bytes + |> add_type ident_unit + ~immediate:Always + ~kind:(variant [cstr ident_void []]) + (* Predefined exceptions - alphabetical order *) + |> add_extension ident_assert_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_division_by_zero [] + |> add_extension ident_end_of_file [] + |> add_extension ident_failure [type_string] + |> add_extension ident_invalid_argument [type_string] + |> add_extension ident_match_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_not_found [] + |> add_extension ident_out_of_memory [] + |> add_extension ident_stack_overflow [] + |> add_extension ident_sys_blocked_io [] + |> add_extension ident_sys_error [type_string] + |> add_extension ident_undefined_recursive_module + [newgenty (Ttuple[type_string; type_int; type_int])] + +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_502/typing/predef.mli b/upstream/ocaml_502/typing/predef.mli new file mode 100644 index 0000000000..4fde9cce6b --- /dev/null +++ b/upstream/ocaml_502/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 + +(* 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_502/typing/primitive.ml b/upstream/ocaml_502/typing/primitive.ml new file mode 100644 index 0000000000..f8e964cce1 --- /dev/null +++ b/upstream/ocaml_502/typing/primitive.ml @@ -0,0 +1,257 @@ +(**************************************************************************) +(* *) +(* 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_immediate + +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_immediate -> false + +let is_unboxed = function + | Same_as_ocaml_repr + | Untagged_immediate -> false + | Unboxed_float + | Unboxed_integer _ -> true + +let is_untagged = function + | Untagged_immediate -> 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" 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_immediate -> 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_immediate) -> false + | Unboxed_float, Unboxed_float -> true + | Unboxed_float, + (Same_as_ocaml_repr | Unboxed_integer _ | Untagged_immediate) -> false + | Unboxed_integer bi1, Unboxed_integer bi2 -> equal_boxed_integer bi1 bi2 + | Unboxed_integer _, + (Same_as_ocaml_repr | Unboxed_float | Untagged_immediate) -> false + | Untagged_immediate, Untagged_immediate -> true + | Untagged_immediate, + (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] <> '%' + +module Style = Misc.Style + +let report_error ppf err = + match err with + | Old_style_float_with_native_repr_attribute -> + Format.fprintf ppf "Cannot use %a in conjunction with %a/%a." + Style.inline_code "float" + Style.inline_code "[@unboxed]" + Style.inline_code "[@untagged]" + | Old_style_noalloc_with_noalloc_attribute -> + Format.fprintf ppf "Cannot use %a in conjunction with %a." + Style.inline_code "noalloc" + Style.inline_code "[@@noalloc]" + | No_native_primitive_with_repr_attribute -> + Format.fprintf ppf + "@[The native code version of the primitive is mandatory@ \ + when attributes %a or %a are present.@]" + Style.inline_code "[@untagged]" + Style.inline_code "[@unboxed]" + +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_502/typing/primitive.mli b/upstream/ocaml_502/typing/primitive.mli new file mode 100644 index 0000000000..3d3ae8854c --- /dev/null +++ b/upstream/ocaml_502/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_immediate + +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_502/typing/printpat.ml b/upstream/ocaml_502/typing/printpat.ml new file mode 100644 index 0000000000..bc3578ce41 --- /dev/null +++ b/upstream/ocaml_502/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], 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 pretty_pat ppf p = + fprintf ppf "@[%a@]" pretty_val p + +type 'k matrix = 'k general_pattern list list + +let pretty_line ppf line = + Format.fprintf ppf "@["; + List.iter (fun p -> + Format.fprintf ppf "<%a>@ " + pretty_val p + ) line; + Format.fprintf ppf "@]" + +let pretty_matrix ppf (pss : 'k matrix) = + Format.fprintf ppf "@[ %a@]" + (Format.pp_print_list ~pp_sep:Format.pp_print_cut pretty_line) + pss diff --git a/upstream/ocaml_502/typing/printpat.mli b/upstream/ocaml_502/typing/printpat.mli new file mode 100644 index 0000000000..1f03508c2d --- /dev/null +++ b/upstream/ocaml_502/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 pretty_val : Format.formatter -> 'k Typedtree.general_pattern -> unit + +val pretty_pat + : Format.formatter -> '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_502/typing/printtyp.ml b/upstream/ocaml_502/typing/printtyp.ml new file mode 100644 index 0000000000..8c480b7954 --- /dev/null +++ b/upstream/ocaml_502/typing/printtyp.ml @@ -0,0 +1,2717 @@ +(**************************************************************************) +(* *) +(* 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 +module Sig_component_kind = Shape.Sig_component_kind +module Style = Misc.Style + +(* Print a long identifier *) +let longident = Pprintast.longident + +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 +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 + + type namespace = Sig_component_kind.t = + | Value + | Type + | Constructor + | Label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + +module Namespace = struct + + let id = function + | Type -> 0 + | Module -> 1 + | Module_type -> 2 + | Class -> 3 + | Class_type -> 4 + | Extension_constructor | Value | Constructor | Label -> 5 + (* we do not handle those component *) + + let size = 1 + id Value + + + let pp ppf x = + Format.pp_print_string ppf (Shape.Sig_component_kind.to_string 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 + | Some Type -> to_lookup Env.find_type_by_name + | Some Module -> to_lookup Env.find_module_by_name + | Some Module_type -> to_lookup Env.find_modtype_by_name + | Some Class -> to_lookup Env.find_class_by_name + | Some Class_type -> to_lookup Env.find_cltype_by_name + | None | Some(Value|Extension_constructor|Constructor|Label) -> + fun _ -> raise Not_found + + let location namespace id = + let path = Path.Pident id in + try Some ( + match namespace with + | Some Type -> (in_printing_env @@ Env.find_type path).type_loc + | Some Module -> (in_printing_env @@ Env.find_module path).md_loc + | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc + | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc + | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc + | Some (Extension_constructor|Value|Constructor|Label) | None -> + Location.none + ) with Not_found -> None + + let best_class_namespace = function + | Papply _ | Pdot _ -> Some Module + | Pextra_ty _ -> assert false (* Only in type path *) + | Pident c -> + match location (Some Class) c with + | Some _ -> Some Class + | None -> Some 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 add namespace name id = + match Namespace.location (Some namespace) id with + | None -> () + | Some location -> + let explanation = + { kind = namespace; location; name; root_name=Ident.name id} + in + explanations := M.add name explanation !explanations + + let collect_explanation namespace id ~name = + let root_name = Ident.name id in + (* if [name] is of the form "root_name/%d", we register both + [id] and the identifier in scope for [root_name]. + *) + if root_name <> name && not (M.mem name !explanations) then + begin + add namespace name id; + if not (M.mem root_name !explanations) then + (* lookup the identifier in scope with name [root_name] and + add it too + *) + match Namespace.lookup (Some namespace) root_name with + | Pident root_id -> add namespace root_name root_id + | exception Not_found | _ -> () + end + + let pp_explanation ppf r= + Format.fprintf ppf "@[%a:@,Definition of %s %a@]" + Location.print_loc r.location (Sig_component_kind.to_string r.kind) + Style.inline_code r.name + + let print_located_explanations ppf l = + Format.fprintf ppf "@[%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 %a 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 + Style.inline_code 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 Style.inline_code) + (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 + +(* Names bound in recursive definitions should be considered as bound + in the environment when printing identifiers but not when trying + to find shortest path. + For instance, if we define + [{ + module Avoid__me = struct + type t = A + end + type t = X + type u = [` A of t * t ] + module M = struct + type t = A of [ u | `B ] + type r = Avoid__me.t + end + }] + It is is important that in the definition of [t] that the outer type [t] is + printed as [t/2] reserving the name [t] to the type being defined in the + current recursive definition. + Contrarily, in the definition of [r], one should not shorten the + path [Avoid__me.t] to [r] until the end of the definition of [r]. + The [bound_in_recursion] bridges the gap between those two slightly different + notions of printing environment. +*) +let bound_in_recursion = ref M.empty + +(* When dealing with functor arguments, identity becomes fuzzy because the same + syntactic argument may be represented by different identifiers 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 = M.add (Ident.name id.ident) id.ident m in + let updated = List.fold_left update !bound_in_recursion ids in + protect_refs [ R(bound_in_recursion, updated )] f + +let human_id id index = + (* The identifier with index [k] is the (k+1)-th most recent identifier in + the printing environment. We print them as [name/(k+1)] except for [k=0] + which is printed as [name] rather than [name/1]. + *) + if index = 0 then + Ident.name id + else + let ordinal = index + 1 in + String.concat "/" [Ident.name id; string_of_int ordinal] + +let indexed_name namespace id = + let find namespace id env = match namespace with + | Type -> Env.find_type_index id env + | Module -> Env.find_module_index id env + | Module_type -> Env.find_modtype_index id env + | Class -> Env.find_class_index id env + | Class_type-> Env.find_cltype_index id env + | Value | Extension_constructor | Constructor | Label -> None + in + let index = + match M.find_opt (Ident.name id) !bound_in_recursion with + | Some rec_bound_id -> + (* the identifier name appears in the current group of recursive + definition *) + if Ident.same rec_bound_id id then + Some 0 + else + (* the current recursive definition shadows one more time the + previously existing identifier with the same name *) + Option.map succ (in_printing_env (find namespace id)) + | None -> + in_printing_env (find namespace id) + in + let index = + (* If [index] is [None] at this point, it might indicate that + the identifier id is not defined in the environment, while there + are other identifiers in scope that share the same name. + Currently, this kind of partially incoherent environment happens + within functor error messages where the left and right hand side + have a different views of the environment at the source level. + Printing the source-level by using a default index of `0` + seems like a reasonable compromise in this situation however.*) + Option.value index ~default:0 + in + human_id id index + +let ident_name namespace id = + match namespace, !enabled with + | None, _ | _, false -> Out_name.create (Ident.name id) + | Some namespace, true -> + if fuzzy_id namespace id then Out_name.create (Ident.name id) + else + let name = indexed_name namespace id in + Conflicts.collect_explanation namespace id ~name; + Out_name.create name +end +let ident_name = Naming_context.ident_name + +let ident ppf id = pp_print_string ppf + (Out_name.print (Naming_context.ident_name None id)) + +let namespaced_ident namespace id = + Out_name.print (Naming_context.ident_name (Some namespace) id) + + +(* Print a path *) + +let ident_stdlib = Ident.create_persistent "Stdlib" + +let non_shadowed_stdlib namespace = function + | Pdot(Pident id, s) as path -> + Ident.same id ident_stdlib && + (match Namespace.lookup namespace 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) + | Pextra_ty (p, extra) -> + Pextra_ty (rewrite_double_underscore_paths env p, extra) + | 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), + Unit_info.modulize + (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 ?(disambiguation=true) namespace p = + let tree_of_path namespace p = tree_of_path ~disambiguation namespace p in + let namespace = if disambiguation then namespace else None in + match p with + | Pident id -> + Oide_ident (ident_name namespace id) + | Pdot(_, s) as path when non_shadowed_stdlib namespace path -> + Oide_ident (Out_name.create s) + | Pdot(p, s) -> + Oide_dot (tree_of_path (Some Module) p, s) + | Papply(p1, p2) -> + let t1 = tree_of_path (Some Module) p1 in + let t2 = tree_of_path (Some Module) p2 in + Oide_apply (t1, t2) + | Pextra_ty (p, extra) -> begin + (* inline record types are syntactically prevented from escaping their + binding scope, and are never shown to users. *) + match extra with + Pcstr_ty s -> + Oide_dot (tree_of_path (Some Type) p, s) + | Pext_ty -> + tree_of_path None p + end + +let tree_of_path ?disambiguation namespace p = + tree_of_path ?disambiguation namespace + (rewrite_double_underscore_paths !printing_env p) + +let path ppf p = + !Oprint.out_ident ppf (tree_of_path None p) + +let string_of_path p = + Format.asprintf "%a" path p + +let strings_of_paths namespace p = + 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 string_of_field_kind v = + match field_kind_repr v with + | Fpublic -> "Fpublic" + | Fabsent -> "Fabsent" + | Fprivate -> "Fprivate" + +let rec safe_repr v t = + match Transient_expr.coerce t with + {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 "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" + (string_of_label l) raw_type t1 raw_type t2 + (if is_commu_ok c then "Cok" else "Cunknown") + | Ttuple tl -> + fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl + | Tconstr (p, tl, abbrev) -> + fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p + raw_type_list tl + (raw_list path) (list_of_memo !abbrev) + | Tobject (t, nm) -> + fprintf ppf "@[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 "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f + (string_of_field_kind 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 "@[Tpoly(@,%a,@,%a)@]" + raw_type t + raw_type_list tl + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + fprintf ppf + "@[{@[%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)) + fields + "row_more=" raw_type more + "row_closed=" closed + "row_fixed=" raw_row_fixed fixed + "row_name=" + (fun ppf -> + match 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 "@[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 rf = + match_row_field + ~absent:(fun _ -> fprintf ppf "RFabsent") + ~present:(function + | None -> + fprintf ppf "RFpresent None" + | Some t -> + fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) + ~either:(fun c tl m e -> + fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c + raw_type_list tl m + (fun ppf -> + match e with None -> fprintf ppf " RFnone" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) + rf + +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 String.Set.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 rec index l x = + match l with + [] -> raise Not_found + | a :: l -> if eq_type x a then 0 else 1 + index l x + +let rec uniq = function + [] -> true + | a :: l -> not (List.memq (a : int) l) && uniq l + +let rec normalize_type_path ?(cache=false) env p = + try + let (params, ty, _) = Env.find_type_expansion p env in + match get_desc ty with + Tconstr (p1, tyl, _) -> + if List.length params = List.length tyl + && List.for_all2 eq_type params tyl + then normalize_type_path ~cache env p1 + else if cache || List.length params <= List.length tyl + || not (uniq (List.map get_id 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) + | _ -> + (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, _) | Pextra_ty (p, Pcstr_ty _) -> + 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) + | Pextra_ty (p, _) -> path_size p + +let same_printing_env env = + let used_pers = Env.used_persistent () in + Env.same_types !printing_old env && String.Set.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; + 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) | Path.Pextra_ty (p1, Pcstr_ty s) -> + Longident.Ldot (lid_of_path p1, s) + | Path.Papply (p1, p2) -> + Longident.Lapply (lid_of_path p1, lid_of_path p2) + | Path.Pextra_ty (p, Pext_ty) -> lid_of_path p + +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) + +(* When building a tree for a best type path, we should not disambiguate + identifiers whenever the short-path algorithm detected a better path than + the original one.*) +let tree_of_best_type_path p p' = + if Path.same p p' then tree_of_path (Some Type) p' + else tree_of_path ~disambiguation:false None p' + +(* Print a type expression *) + +let proxy ty = Transient_expr.repr (proxy ty) + +(* When printing a type scheme, we print weak names. When printing a plain + type, we do not. This type controls that behavior *) +type type_or_scheme = Type | Type_scheme + +let is_non_gen mode ty = + match mode with + | Type_scheme -> is_Tvar ty && get_level ty <> generic_level + | Type -> false + +let nameable_row row = + row_name row <> None && + List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither(c, l, _) -> + row_closed row && if c then l = [] else List.length l = 1 + | _ -> true) + (row_fields row) + +(* This specialized version of [Btype.iter_type_expr] normalizes and + short-circuits the traversal of the [type_expr], so that it covers only the + subterms that would be printed by the type printer. *) +let printer_iter_type_expr f ty = + match get_desc ty with + | Tconstr(p, tyl, _) -> + let (_p', s) = best_type_path p in + List.iter f (apply_subst s tyl) + | Tvariant row -> begin + match row_name row with + | Some(_p, tyl) when nameable_row row -> + List.iter f tyl + | _ -> + iter_row f row + end + | Tobject (fi, nm) -> begin + match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpublic then + f ty) + fields + | Some (_, l) -> + List.iter f (List.tl l) + end + | Tfield(_, kind, ty1, ty2) -> + if field_kind_repr kind = Fpublic then + f ty1; + f ty2 + | _ -> + Btype.iter_type_expr f ty + +module Internal_names : sig + + val reset : unit -> unit + + val add : Path.t -> unit + + val print_explanations : Env.t -> Format.formatter -> unit + +end = struct + + let names = ref Ident.Set.empty + + let reset () = + names := Ident.Set.empty + + let add p = + match p with + | Pident id -> + let name = Ident.name id in + if String.length name > 0 && name.[0] = '$' then begin + names := Ident.Set.add id !names + end + | Pdot _ | Papply _ | Pextra_ty _ -> () + + let print_explanations env ppf = + let constrs = + Ident.Set.fold + (fun id acc -> + let p = Pident id in + match Env.find_type p env with + | exception Not_found -> acc + | decl -> + match type_origin decl with + | Existential constr -> + let prev = String.Map.find_opt constr acc in + let prev = Option.value ~default:[] prev in + String.Map.add constr (tree_of_path None p :: prev) acc + | Definition | Rec_check_regularity -> acc) + !names String.Map.empty + in + String.Map.iter + (fun constr out_idents -> + match out_idents with + | [] -> () + | [out_ident] -> + fprintf ppf + "@ @[<2>@{Hint@}:@ %a@ is an existential type@ \ + bound by the constructor@ %a.@]" + (Style.as_inline_code !Oprint.out_ident) out_ident + Style.inline_code constr + | out_ident :: out_idents -> + fprintf ppf + "@ @[<2>@{Hint@}:@ %a@ and %a@ are existential types@ \ + bound by the constructor@ %a.@]" + (Format.pp_print_list + ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") + (Style.as_inline_code !Oprint.out_ident)) + (List.rev out_idents) + (Style.as_inline_code !Oprint.out_ident) out_ident + Style.inline_code constr) + constrs + +end + +module Names : sig + val reset_names : unit -> unit + + val add_named_vars : type_expr -> unit + val add_subst : (type_expr * type_expr) list -> unit + + val new_name : unit -> string + val new_var_name : non_gen:bool -> type_expr -> unit -> string + + val name_of_type : (unit -> string) -> transient_expr -> string + val check_name_of_type : non_gen:bool -> transient_expr -> unit + + val remove_names : transient_expr list -> unit + + val with_local_names : (unit -> 'a) -> 'a + + (* Refresh the weak variable map in the toplevel; for [print_items], which is + itself for the toplevel *) + val refresh_weak : unit -> unit +end = struct + (* We map from types to names, but not directly; we also store a substitution, + which maps from types to types. The lookup process is + "type -> apply substitution -> find name". The substitution is presumed to + be acyclic. *) + let names = ref ([] : (transient_expr * string) list) + let name_subst = ref ([] : (transient_expr * transient_expr) list) + let name_counter = ref 0 + let named_vars = ref ([] : string list) + let visited_for_named_vars = ref ([] : transient_expr 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_subst := []; + name_counter := 0; + named_vars := []; + visited_for_named_vars := [] + + let add_named_var tty = + match tty.desc with + Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else + named_vars := name :: !named_vars + | _ -> () + + let rec add_named_vars ty = + let tty = Transient_expr.repr ty in + let px = proxy ty in + if not (List.memq px !visited_for_named_vars) then begin + visited_for_named_vars := px :: !visited_for_named_vars; + match tty.desc with + | Tvar _ | Tunivar _ -> + add_named_var tty + | _ -> + printer_iter_type_expr add_named_vars ty + end + + let rec substitute ty = + match List.assq ty !name_subst with + | ty' -> substitute ty' + | exception Not_found -> ty + + let add_subst subst = + name_subst := + List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) + subst + @ !name_subst + + 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 = Misc.letter_of_int !name_counter 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 new_var_name ~non_gen ty () = + if non_gen then new_weak_name ty () + else new_name () + + 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. *) + let t = substitute t in + try List.assq t !names with Not_found -> + try TransientTypeMap.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 available name = + List.for_all + (fun (_, name') -> name <> name') + !names + in + if available name then name + else + let suffixed i = name ^ Int.to_string i in + let i = Misc.find_first_mono (fun i -> available (suffixed i)) in + suffixed i + | _ -> + (* 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 ~non_gen px = + let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in + ignore(name_of_type name_gen px) + + let remove_names tyl = + let tyl = List.map substitute tyl in + names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names + + let with_local_names f = + let old_names = !names in + let old_subst = !name_subst in + names := []; + name_subst := []; + try_finally + ~always:(fun () -> + names := old_names; + name_subst := old_subst) + f + + let refresh_weak () = + let refresh t name (m,s) = + if is_non_gen Type_scheme 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 +end + +let reserve_names ty = + normalize_type ty; + Names.add_named_vars ty + +let visited_objects = ref ([] : transient_expr list) +let aliased = ref ([] : transient_expr list) +let delayed = ref ([] : transient_expr list) +let printed_aliases = ref ([] : transient_expr list) + +(* [printed_aliases] is a subset of [aliased] that records only those aliased + types that have actually been printed; this allows us to avoid naming loops + that the user will never see. *) + +let add_delayed t = + if not (List.memq t !delayed) then delayed := t :: !delayed + +let is_aliased_proxy px = List.memq px !aliased + +let add_alias_proxy px = + if not (is_aliased_proxy px) then + aliased := px :: !aliased + +let add_alias ty = add_alias_proxy (proxy ty) + +let add_printed_alias_proxy ~non_gen px = + Names.check_name_of_type ~non_gen px; + printed_aliases := px :: !printed_aliases + +let add_printed_alias ty = add_printed_alias_proxy (proxy ty) + +let aliasable ty = + match get_desc ty with + Tvar _ | Tunivar _ | Tpoly _ -> false + | Tconstr (p, _, _) -> + not (is_nth (snd (best_type_path p))) + | _ -> true + +let should_visit_object ty = + match get_desc ty with + | Tvariant row -> not (static_row row) + | Tobject _ -> opened_object ty + | _ -> false + +let rec mark_loops_rec visited ty = + let px = proxy ty in + if List.memq px visited && aliasable ty then add_alias_proxy px else + let tty = Transient_expr.repr ty in + let visited = px :: visited in + match tty.desc with + | Tvariant _ | Tobject _ -> + if List.memq px !visited_objects then add_alias_proxy px else begin + if should_visit_object ty then + visited_objects := px :: !visited_objects; + printer_iter_type_expr (mark_loops_rec visited) ty + end + | Tpoly(ty, tyl) -> + List.iter add_alias tyl; + mark_loops_rec visited ty + | _ -> + printer_iter_type_expr (mark_loops_rec visited) ty + +let mark_loops ty = + mark_loops_rec [] ty + +let prepare_type ty = + reserve_names ty; + mark_loops ty + +let reset_loop_marks () = + visited_objects := []; aliased := []; delayed := []; printed_aliases := [] + +let reset_except_context () = + Names.reset_names (); reset_loop_marks (); Internal_names.reset () + +let reset () = + Conflicts.reset (); + reset_except_context () + +let prepare_for_printing tyl = + reset_except_context (); + List.iter prepare_type tyl + +let add_type_to_preparation = prepare_type + +(* Disabled in classic mode when printing an unification error *) +let print_labels = ref true + +let alias_nongen_row mode px ty = + match get_desc ty with + | Tvariant _ | Tobject _ -> + if is_non_gen mode (Transient_expr.type_expr px) then + add_alias_proxy px + | _ -> () + +let rec tree_of_typexp mode ty = + let px = proxy ty in + if List.memq px !printed_aliases && not (List.memq px !delayed) then + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + let name = Names.name_of_type (Names.new_var_name ~non_gen ty) px in + Otyp_var (non_gen, name) else + + let pr_typ () = + let tty = Transient_expr.repr ty in + match tty.desc with + | Tvar _ -> + let non_gen = is_non_gen mode ty in + let name_gen = Names.new_var_name ~non_gen ty in + Otyp_var (non_gen, Names.name_of_type name_gen tty) + | Tarrow(l, ty1, ty2, _) -> + let lab = + if !print_labels || is_optional l then l else Nolabel + in + let t1 = + if is_optional l then + match get_desc ty1 with + | Tconstr(path, [ty], _) + when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty1 in + Otyp_arrow (lab, t1, tree_of_typexp mode ty2) + | Ttuple tyl -> + Otyp_tuple (tree_of_typlist mode 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 mode (List.hd tyl') + else begin + Internal_names.add p'; + Otyp_constr (tree_of_best_type_path p p', tree_of_typlist mode tyl') + end + | Tvariant row -> + let Row {fields; name; closed; _} = row_repr row in + let fields = + if closed then + List.filter (fun (_, f) -> row_field_repr f <> Rabsent) + fields + else 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 name with + | Some(p, tyl) when nameable_row row -> + let (p', s) = best_type_path p in + let id = tree_of_best_type_path p p' in + let args = tree_of_typlist mode (apply_subst s tyl) in + let out_variant = + if is_nth s then List.hd args else Otyp_constr (id, args) in + if closed && all_present then + out_variant + else + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_typ out_variant, closed, tags) + | _ -> + let fields = List.map (tree_of_row_field mode) fields in + let tags = + if all_present then None else Some (List.map fst present) in + Otyp_variant (Ovar_fields fields, closed, tags) + end + | Tobject (fi, nm) -> + tree_of_typobject mode fi !nm + | Tnil | Tfield _ -> + tree_of_typobject mode ty None + | Tsubst _ -> + (* This case should only happen when debugging the compiler *) + Otyp_stuff "" + | Tlink _ -> + fatal_error "Printtyp.tree_of_typexp" + | Tpoly (ty, []) -> + tree_of_typexp mode ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + if tyl = [] then tree_of_typexp mode ty else begin + let tyl = List.map Transient_expr.repr tyl in + 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 (Names.name_of_type Names.new_name) tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode ty) in + (* Forget names when we leave scope *) + Names.remove_names tyl; + delayed := old_delayed; tr + end + | Tunivar _ -> + Otyp_var (false, Names.name_of_type Names.new_name tty) + | Tpackage (p, fl) -> + let fl = + List.map + (fun (li, ty) -> ( + String.concat "." (Longident.flatten li), + tree_of_typexp mode ty + )) fl in + Otyp_module (tree_of_path (Some Module_type) p, fl) + in + if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; + alias_nongen_row mode px ty; + if is_aliased_proxy px && aliasable ty then begin + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in + add_printed_alias_proxy ~non_gen px; + (* add_printed_alias chose a name, thus the name generator + doesn't matter.*) + let alias = Names.name_of_type (Names.new_var_name ~non_gen ty) px in + Otyp_alias {non_gen; aliased = pr_typ (); alias } end + else pr_typ () + +and tree_of_row_field mode (l, f) = + match row_field_repr f with + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) + | Reither(c, tyl, _) -> + if c (* contradiction: constant constructor with an argument *) + then (l, true, tree_of_typlist mode tyl) + else (l, false, tree_of_typlist mode tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode) tyl + +and tree_of_typobject mode 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 + | Fpublic -> (n, t) :: l + | _ -> l) + fields [] in + let sorted_fields = + List.sort + (fun (n, _) (n', _) -> String.compare n n') present_fields in + tree_of_typfields mode rest sorted_fields in + let (fields, open_row) = pr_fields fi in + Otyp_object {fields; open_row} + | Some (p, _ty :: tyl) -> + let args = tree_of_typlist mode tyl in + let (p', s) = best_type_path p in + assert (s = Id); + Otyp_class (tree_of_best_type_path p p', args) + | _ -> + fatal_error "Printtyp.tree_of_typobject" + end + +and tree_of_typfields mode rest = function + | [] -> + let open_row = + match get_desc rest with + | Tvar _ | Tunivar _ | Tconstr _-> true + | Tnil -> false + | _ -> fatal_error "typfields (1)" + in + ([], open_row) + | (s, t) :: l -> + let field = (s, tree_of_typexp mode t) in + let (fields, rest) = tree_of_typfields mode rest l in + (field :: fields, rest) + +let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) + +let prepared_type_expr ppf ty = typexp Type 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 *) + prepare_for_printing [ty]; + prepared_type_expr ppf ty + +(* "Half-prepared" type expression: [ty] should have had its names reserved, but + should not have had its loops marked. *) +let type_expr_with_reserved_names ppf ty = + reset_loop_marks (); + mark_loops ty; + prepared_type_expr ppf ty + +let shared_type_scheme ppf ty = + prepare_type ty; + typexp Type_scheme ppf ty + +let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty + +let type_scheme ppf ty = + prepare_for_printing [ty]; + prepared_type_scheme 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_best_type_path p p'' in + !Oprint.out_ident ppf t + +let tree_of_type_scheme ty = + prepare_for_printing [ty]; + tree_of_typexp Type_scheme 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 Type_scheme ty in + (tr, tree_of_typexp Type_scheme ty') :: list + else list) + params [] + +let filter_params tyl = + let params = + List.fold_left + (fun tyl ty -> + if List.exists (eq_type ty) tyl + then newty2 ~level:generic_level (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 prepare_type_constructor_arguments = function + | Cstr_tuple l -> List.iter prepare_type l + | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l + +let tree_of_label l = + (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp Type l.ld_type) + +let tree_of_constructor_arguments = function + | Cstr_tuple l -> tree_of_typlist Type l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] + +let tree_of_single_constructor cd = + let name = Ident.name cd.cd_id in + let ret = Option.map (tree_of_typexp Type) cd.cd_res in + let args = tree_of_constructor_arguments cd.cd_args in + { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } + +(* When printing GADT constructor, we need to forget the naming decision we took + for the type parameters and constraints. Indeed, in + {[ + type 'a t = X: 'a -> 'b t + ]} + It is fine to print both the type parameter ['a] and the existentially + quantified ['a] in the definition of the constructor X as ['a] + *) +let tree_of_constructor_in_decl cd = + match cd.cd_res with + | None -> tree_of_single_constructor cd + | Some _ -> Names.with_local_names (fun () -> tree_of_single_constructor cd) + +let prepare_decl id decl = + let params = filter_params decl.type_params in + begin match decl.type_manifest with + | Some ty -> + let vars = free_variables ty in + List.iter + (fun ty -> + if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + params + | None -> () + end; + List.iter add_alias params; + List.iter prepare_type params; + List.iter (add_printed_alias ~non_gen:false) params; + let ty_manifest = + match decl.type_manifest with + | None -> None + | Some ty -> + let ty = + (* Special hack to hide variant name *) + match get_desc ty with + Tvariant row -> + begin match row_name row with + Some (Pident id', _) when Ident.same id id' -> + newgenty (Tvariant (set_row_name row None)) + | _ -> ty + end + | _ -> ty + in + prepare_type ty; + Some ty + in + begin match decl.type_kind with + | Type_abstract _ -> () + | Type_variant (cstrs, _rep) -> + List.iter + (fun c -> + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) + cstrs + | Type_record(l, _rep) -> + List.iter (fun l -> prepare_type l.ld_type) l + | Type_open -> () + end; + ty_manifest, params + +let tree_of_type_decl id decl = + let ty_manifest, params = prepare_decl id decl in + let type_param ot_variance = + function + | Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} + 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 ty in + if abstr || not is_var then + let inj = + type_kind_is_abstract decl && 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 cocn (tree_of_typexp Type ty)) + params vari) + in + let tree_of_manifest ty1 = + match ty_manifest with + | None -> ty1 + | Some ty -> Otyp_manifest (tree_of_typexp Type 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 Type ty, decl.type_private, false + end + | Type_variant (cstrs, rep) -> + tree_of_manifest + (Otyp_sum (List.map tree_of_constructor_in_decl 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 } + +let add_type_decl_to_preparation id decl = + ignore @@ prepare_decl id decl + +let tree_of_prepared_type_decl id decl = + tree_of_type_decl id decl + +let tree_of_type_decl id decl = + reset_except_context(); + tree_of_type_decl id decl + +let add_constructor_to_preparation c = + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res + +let prepared_constructor ppf c = + !Oprint.out_constr ppf (tree_of_single_constructor c) + +let constructor ppf c = + reset_except_context (); + add_constructor_to_preparation c; + prepared_constructor ppf c + +let label ppf l = + reset_except_context (); + prepare_type l.ld_type; + !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 tree_of_prepared_type_declaration id decl rs = + Osig_type (tree_of_prepared_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 add_type_declaration_to_preparation id decl = + add_type_decl_to_preparation id decl + +let prepared_type_declaration id ppf decl = + !Oprint.out_sig_item ppf + (tree_of_prepared_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 = + let ret = Option.map (tree_of_typexp Type) ext_ret_type in + let args = tree_of_constructor_arguments ext_args in + (args, ret) + +(* When printing extension constructor, it is important to ensure that +after printing the constructor, we are still in the scope of the constructor. +For GADT constructor, this can be done by printing the type parameters inside +their own isolated scope. This ensures that in +{[ + type 'b t += A: 'b -> 'b any t +]} +the type parameter `'b` is not bound when printing the type variable `'b` from +the constructor definition from the type parameter. + +Contrarily, for non-gadt constructor, we must keep the same scope for +the type parameters and the constructor because a type constraint may +have changed the name of the type parameter: +{[ +type -'a t = .. constraint 'a> = 'a +(* the universal 'a is here to steal the name 'a from the type parameter *) +type 'a t = X of 'a +]} *) + + +let add_extension_constructor_to_preparation ext = + let ty_params = filter_params ext.ext_type_params in + List.iter add_alias ty_params; + List.iter prepare_type ty_params; + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type + +let prepared_tree_of_extension_constructor + id ext es + = + let ty_name = Path.name ext.ext_type_path in + let ty_params = filter_params ext.ext_type_params in + let type_param = + function + | Otyp_var (_, id) -> id + | _ -> "?" + in + let param_scope f = + match ext.ext_ret_type with + | None -> + (* normal constructor: same scope for parameters and the constructor *) + f () + | Some _ -> + (* gadt constructor: isolated scope for the type parameters *) + Names.with_local_names f + in + let ty_params = + param_scope + (fun () -> + List.iter (add_printed_alias ~non_gen:false) ty_params; + List.map (fun ty -> type_param (tree_of_typexp Type 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 tree_of_extension_constructor id ext es = + reset_except_context (); + add_extension_constructor_to_preparation ext; + prepared_tree_of_extension_constructor id ext es + +let extension_constructor id ppf ext = + !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) + +let prepared_extension_constructor id ppf ext = + !Oprint.out_sig_item ppf + (prepared_tree_of_extension_constructor id ext Text_first) + +let extension_only_constructor id ppf ext = + reset_except_context (); + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type; + 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 "@[%a@]" + !Oprint.out_constr { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = 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 priv ty = + match priv, get_desc ty with + | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) + | _ , _ -> (ty, []) + +let prepare_method _lab (priv, _virt, ty) = + let ty, _ = method_type priv ty in + prepare_type ty + +let tree_of_method mode (lab, priv, virt, ty) = + let (ty, tyl) = method_type priv ty in + let tty = tree_of_typexp mode ty in + Names.remove_names (List.map Transient_expr.repr tyl); + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, tty) + +let rec prepare_class_type params = function + | Cty_constr (_p, tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects + || not (List.for_all is_Tvar params) + || List.exists (deep_occur row) tyl + then prepare_class_type params cty + else List.iter prepare_type tyl + | Cty_signature sign -> + (* Self may have a name *) + let px = proxy sign.csig_self_row in + if List.memq px !visited_objects then add_alias_proxy px + else visited_objects := px :: !visited_objects; + Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; + Meths.iter prepare_method sign.csig_meths + | Cty_arrow (_, ty, cty) -> + prepare_type ty; + prepare_class_type params cty + +let rec tree_of_class_type mode params = + function + | Cty_constr (p', tyl, cty) -> + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects + || not (List.for_all is_Tvar params) + then + tree_of_class_type mode params cty + else + let namespace = Namespace.best_class_namespace p' in + Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl) + | Cty_signature sign -> + let px = proxy sign.csig_self_row in + let self_ty = + if is_aliased_proxy px then + Some + (Otyp_var (false, Names.name_of_type Names.new_name px)) + else None + 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 mode t) + :: csil) + csil all_vars + in + let all_meths = + Meths.fold + (fun l (p, v, t) all -> (l, p, v, t) :: all) + sign.csig_meths [] + in + let all_meths = List.rev all_meths in + let csil = + List.fold_left + (fun csil meth -> tree_of_method mode meth :: csil) + csil all_meths + in + Octy_signature (self_ty, List.rev csil) + | Cty_arrow (l, ty, cty) -> + let lab = + if !print_labels || is_optional l then l else Nolabel + in + let tr = + if is_optional l then + match get_desc ty with + | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> + tree_of_typexp mode ty + | _ -> Otyp_stuff "" + else tree_of_typexp mode ty in + Octy_arrow (lab, tr, tree_of_class_type mode params cty) + +let class_type ppf cty = + reset (); + prepare_class_type [] cty; + !Oprint.out_class_type ppf (tree_of_class_type Type [] cty) + +let tree_of_class_param param variance = + let ot_variance = + if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) else variance in + match tree_of_typexp Type_scheme param with + Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} + | _ -> {ot_non_gen=false; ot_name="?"; ot_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 px = proxy (Btype.self_type_row cl.cty_type) in + List.iter prepare_type params; + + List.iter (add_printed_alias ~non_gen:false) params; + if is_aliased_proxy px then add_printed_alias_proxy ~non_gen:false px; + + 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 Type_scheme 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 = cl.clty_params in + + reset_except_context (); + List.iter add_alias params; + prepare_class_type params cl.clty_type; + let px = proxy (Btype.self_type_row cl.clty_type) in + List.iter prepare_type params; + + List.iter (add_printed_alias ~non_gen:false) params; + if is_aliased_proxy px then (add_printed_alias_proxy ~non_gen:false) px; + + let sign = Btype.signature_of_class_type cl.clty_type in + let has_virtual_vars = + Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_vars false + in + let has_virtual_meths = + Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_meths false + in + Osig_class_type + (has_virtual_vars || has_virtual_meths, Ident.name id, + List.map2 tree_of_class_param params (class_variance cl.clty_variance), + tree_of_class_type Type_scheme 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 Definition; + 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 (Some 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 (Some 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 = + 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? *) + +let print_items showval env x = + Names.refresh_weak(); + 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 "@[%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 (); + 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 + +(* Trace-specific printing *) + +(* 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" + +(* Print a unification error *) + +let same_path t t' = + eq_type t t' || + match get_desc t, get_desc t' 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 eq_type tl tl' + | _ -> false + end + | _ -> + false + +type 'a diff = Same of 'a | Diff of 'a * 'a + +let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = + reset_loop_marks (); + mark_loops t; + if same_path t t' + then begin add_delayed (proxy t); Same (tree_of_typexp mode t) end + else begin + mark_loops t'; + 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 mode t in + let second = tree_of_typexp mode t' in + if first = second then Same first + else Diff(first,second) + end + +let type_expansion ppf = function + | Same t -> Style.as_inline_code !Oprint.out_type ppf t + | Diff(t,t') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + (Style.as_inline_code !Oprint.out_type) t + (Style.as_inline_code !Oprint.out_type) t' + +let trees_of_trace mode = + List.map (Errortrace.map_diff (trees_of_type_expansion mode)) + +let trees_of_type_path_expansion (tp,tp') = + if Path.same tp tp' then Same(tree_of_path (Some Type) tp) else + Diff(tree_of_path (Some Type) tp, tree_of_path (Some Type) tp') + +let type_path_expansion ppf = function + | Same p -> Style.as_inline_code !Oprint.out_ident ppf p + | Diff(p,p') -> + fprintf ppf "@[<2>%a@ =@ %a@]" + (Style.as_inline_code !Oprint.out_ident) p + (Style.as_inline_code !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 = {ty = t1; expanded = t1'}; + expected = {ty = t2; expanded = 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 + +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.map f tr) + +(** Keep elements that are [Diff _ ] and take the decision + for the last element, require a prepared trace *) +let rec filter_trace 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 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 get_desc t with + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + if name = None then t else + newty2 ~level:(get_level t) + (Tvariant + (create_row ~fields ~fixed ~closed ~name:None + ~more:(newvar2 (get_level more)))) + | _ -> t + +let prepare_expansion Errortrace.{ty; expanded} = + let expanded = hide_variant_name expanded in + reserve_names ty; + if not (same_path ty expanded) then reserve_names expanded; + Errortrace.{ty; expanded} + +let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = + match get_desc expanded with + Tvariant _ | Tobject _ when compact -> + reserve_names ty; Errortrace.{ty; expanded = ty} + | _ -> prepare_expansion ty_exp + +let print_path p = + Format.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p) + +let print_tag ppf s = Style.inline_code 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 get_desc (Ctype.expand_head env ty) 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 get_desc t3, get_desc t4 with + | Tarrow (_, ty1, ty2, _), _ + when is_unit env ty1 && unifiable env ty2 t4 -> + Some (fun ppf -> + fprintf ppf + "@,@[@{Hint@}: Did you forget to provide %a as argument?@]" + Style.inline_code "()" + ) + | _, 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 \ + %a?@]" + Style.inline_code "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 -> + reserve_names x; + dprintf "The %a variant type is bound to the universal type variable %a" + Errortrace.print_pos pos + (Style.as_inline_code type_expr_with_reserved_names) x + | Reified p -> + dprintf "The %a variant type is bound to %a" + Errortrace.print_pos pos + (Style.as_inline_code + (fun ppf p -> + Internal_names.add p; + print_path p ppf)) + p + | Rigid -> ignore + +let explain_variant (type variety) : variety Errortrace.variant -> _ = function + (* Common *) + | Errortrace.Incompatible_types_for s -> + Some(dprintf "@,Types for tag %a are incompatible" + print_tag 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)@ @[%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.Presence_not_guaranteed_for (pos, s) -> Some( + dprintf + "@,@[The tag %a is guaranteed to be present in the %a variant type,\ + @ but not in the %a@]" + print_tag s + Errortrace.print_pos (Errortrace.swap_position pos) + Errortrace.print_pos pos + ) + | 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 -> + reserve_names u; + Some( + dprintf "%t@,The universal variable %a would escape its scope" + pre + (Style.as_inline_code type_expr_with_reserved_names) u + ) + | Errortrace.Constructor p -> Some( + dprintf + "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + pre (Style.as_inline_code path) p + ) + | Errortrace.Module_type p -> Some( + dprintf + "%t@,@[The module type@;<1 2>%a@ would escape its scope@]" + pre (Style.as_inline_code path) p + ) + | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> + reserve_names t; + Some( + dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" + pre + (Style.as_inline_code type_expr_with_reserved_names) 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 %a@]" + Errortrace.print_pos pos Style.inline_code 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 explain_incompatible_fields name (diff: Types.type_expr Errortrace.diff) = + reserve_names diff.got; + reserve_names diff.expected; + dprintf "@,@[The method %a has type@ %a,@ \ + but the expected method type was@ %a@]" + Style.inline_code name + (Style.as_inline_code type_expr_with_reserved_names) diff.got + (Style.as_inline_code type_expr_with_reserved_names) diff.expected + +let explanation (type variety) intro prev env + : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function + | Errortrace.Diff {got; expected} -> + explanation_diff env got.expanded expected.expanded + | Errortrace.Escape {kind; context} -> + let pre = + match context, kind, prev with + | Some ctx, _, _ -> + reserve_names ctx; + dprintf "@[%t@;<1 2>%a@]" intro + (Style.as_inline_code type_expr_with_reserved_names) ctx + | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> + explain_incompatible_fields name diff + | _ -> ignore + in + explain_escape pre kind + | Errortrace.Incompatible_fields { name; diff} -> + Some(explain_incompatible_fields name diff) + | Errortrace.Variant v -> + explain_variant v + | Errortrace.Obj o -> + explain_object o + | Errortrace.Rec_occur(x,y) -> + reserve_names x; + reserve_names y; + begin match get_desc x with + | Tvar _ | Tunivar _ -> + Some(fun ppf -> + reset_loop_marks (); + mark_loops x; + mark_loops y; + dprintf "@,@[The type variable %a occurs inside@ %a@]" + (Style.as_inline_code prepared_type_expr) x + (Style.as_inline_code prepared_type_expr) y + ppf) + | _ -> + (* 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 get_desc t with + | Tconstr (p,_,_) -> + begin match Env.find_type p env with + | exception Not_found -> + fprintf ppf + "@,@[Type %a is abstract because@ no corresponding\ + @ cmi file@ was found@ in path.@]" (Style.as_inline_code path) p + | { type_manifest = Some _; _ } -> () + | { type_manifest = None; _ } as decl -> + match type_origin decl with + | Rec_check_regularity -> + fprintf ppf + "@,@[Type %a was considered abstract@ when checking\ + @ constraints@ in this@ recursive type definition.@]" + (Style.as_inline_code path) p + | Definition | Existential _ -> () + 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 mode txt_got txt_but = function + | None -> ignore + | Some d -> + let d = Errortrace.map_diff (trees_of_type_expansion mode) 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 = {ty=te1; expanded=_}; + expected = {ty=te2; expanded=_} } -> + warn_on_missing_def env ppf te1; + warn_on_missing_def env ppf te2 + +(* [subst] comes out of equality, and is [[]] otherwise *) +let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = + reset (); + (* We want to substitute in the opposite order from [Eqtype] *) + Names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); + let tr = + prepare_trace + (fun ty_exp -> + Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) + 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 (Errortrace.map_diff prepare_expansion) tr in + let head_error = head_error_printer mode txt1 txt2 head in + let tr = trees_of_trace mode tr in + fprintf ppf + "@[\ + @[%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; + Internal_names.print_explanations env ppf; + Conflicts.print_explanations ppf; + print_labels := true + with exn -> + print_labels := true; + raise exn + +let report_error trace_format ppf mode env tr + ?(subst = []) + ?(type_expected_explanation = fun _ -> ()) + txt1 txt2 = + wrap_printing_env ~error:true env (fun () -> + error trace_format mode subst env tr txt1 ppf txt2 + type_expected_explanation) + +let report_unification_error + ppf env ({trace} : Errortrace.unification_error) = + report_error Unification ppf Type env + ?subst:None trace + +let report_equality_error + ppf mode env ({subst; trace} : Errortrace.equality_error) = + report_error Equality ppf mode env + ~subst ?type_expected_explanation:None trace + +let report_moregen_error + ppf mode env ({trace} : Errortrace.moregen_error) = + report_error Moregen ppf mode env + ?subst:None ?type_expected_explanation:None trace + +let report_comparison_error ppf mode env = function + | Errortrace.Equality_error error -> report_equality_error ppf mode env error + | Errortrace.Moregen_error error -> report_moregen_error ppf mode env error + +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.map 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 Type + @@ 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 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 Type) diff) + | _ -> None + + let subtype_get_diff = function + | Errortrace.Subtype.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + + let report_error + ppf + env + (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) + txt1 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tr_sub = prepare_trace prepare_expansion tr_sub in + let tr_unif = prepare_unification_trace prepare_expansion tr_unif in + let keep_first = match tr_unif with + | [Obj _ | Variant _ | Escape _ ] | [] -> true + | _ -> false in + fprintf ppf "@[%a" + (trace filter_subtype_trace subtype_get_diff true keep_first txt1) + tr_sub; + if tr_unif = [] then fprintf ppf "@]" else + let mis = mismatch (dprintf "Within this type") env tr_unif in + fprintf ppf "%a%t%t@]" + (trace filter_trace unification_get_diff false + (mis = None) "is not compatible with type") tr_unif + (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>@[%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 None +let tree_of_modtype = tree_of_modtype ~ellipsis:false +let type_expansion mode ppf ty_exp = + type_expansion ppf (trees_of_type_expansion mode ty_exp) +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_502/typing/printtyp.mli b/upstream/ocaml_502/typing/printtyp.mli new file mode 100644 index 0000000000..838a54f362 --- /dev/null +++ b/upstream/ocaml_502/typing/printtyp.mli @@ -0,0 +1,249 @@ +(**************************************************************************) +(* *) +(* 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 namespaced_ident: Shape.Sig_component_kind.t -> Ident.t -> string +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 := Shape.Sig_component_kind.t option + +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. *) +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: Shape.Sig_component_kind.t; + 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 + +(** Print out a type. This will pick names for type variables, and will not + reuse names for common type variables shared across multiple type + expressions. (It will also reset the printing state, which matters for + other type formatters such as [prepared_type_expr].) If you want multiple + types to use common names for type variables, see [prepare_for_printing] and + [prepared_type_expr]. *) +val type_expr: formatter -> type_expr -> unit + +(** [prepare_for_printing] resets the global printing environment, a la [reset], + and prepares the types for printing by reserving names and marking loops. + Any type variables that are shared between multiple types in the input list + will be given the same name when printed with [prepared_type_expr]. *) +val prepare_for_printing: type_expr list -> unit + +(** [add_type_to_preparation ty] extend a previous type expression preparation + to the type expression [ty] +*) +val add_type_to_preparation: type_expr -> unit + +val prepared_type_expr: formatter -> type_expr -> unit +(** The function [prepared_type_expr] is a less-safe but more-flexible version + of [type_expr] that should only be called on [type_expr]s that have been + passed to [prepare_for_printing]. Unlike [type_expr], this function does no + extra work before printing a type; in particular, this means that any loops + in the type expression may cause a stack overflow (see #8860) since this + function does not mark any loops. The benefit of this is that if multiple + type expressions are prepared simultaneously and then printed with + [prepared_type_expr], they will use the same names for the same type + variables. *) + +val constructor_arguments: formatter -> constructor_arguments -> unit +val tree_of_type_scheme: type_expr -> out_type +val type_scheme: formatter -> type_expr -> unit +val prepared_type_scheme: formatter -> type_expr -> unit +val shared_type_scheme: formatter -> type_expr -> unit +(** [shared_type_scheme] is very similar to [type_scheme], but does not reset + the printing context first. This is intended to be used in cases where the + printing should have a particularly wide context, such as documentation + generators; most use cases, such as error messages, have narrower contexts + for which [type_scheme] is better suited. *) + +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 add_constructor_to_preparation : constructor_declaration -> unit +val prepared_constructor : formatter -> constructor_declaration -> unit +val constructor : formatter -> constructor_declaration -> unit +val tree_of_type_declaration: + Ident.t -> type_declaration -> rec_status -> out_sig_item +val add_type_declaration_to_preparation : + Ident.t -> type_declaration -> unit +val prepared_type_declaration: Ident.t -> formatter -> type_declaration -> unit +val type_declaration: Ident.t -> formatter -> type_declaration -> unit +val tree_of_extension_constructor: + Ident.t -> extension_constructor -> ext_status -> out_sig_item +val add_extension_constructor_to_preparation : + extension_constructor -> unit +val prepared_extension_constructor: + Ident.t -> formatter -> extension_constructor -> unit +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 + +type type_or_scheme = Type | Type_scheme + +val tree_of_signature: Types.signature -> out_sig_item list +val tree_of_typexp: type_or_scheme -> 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_or_scheme -> Format.formatter -> Errortrace.expanded_type -> unit +val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type +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_error -> + ?type_expected_explanation:(formatter -> unit) -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_equality_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.equality_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_moregen_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.moregen_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_comparison_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.comparison_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +module Subtype : sig + val report_error : + formatter -> + Env.t -> + Errortrace.Subtype.error -> + string -> + 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_502/typing/printtyped.ml b/upstream/ocaml_502/typing/printtyped.ml new file mode 100644 index 0000000000..25b6e6c6d4 --- /dev/null +++ b/upstream/ocaml_502/typing/printtyped.ml @@ -0,0 +1,998 @@ +(**************************************************************************) +(* *) +(* 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) | Path.(Pextra_ty (y, Pcstr_ty 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 + | Path.Pextra_ty (y, Pext_ty) -> fmt_path_aux f y + +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 fmt_partiality f x = + match x with + | Total -> () + | Partial -> fprintf f " (Partial)" + +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 typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + +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.txt; + 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; + | Ttyp_open (path, _mod_ident, t) -> + line i ppf "Ttyp_open %a\n" fmt_path path; + core_type i ppf t + +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 + begin match x.pat_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (pattern_extra (i+1) ppf) extra; + end; + 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 function_body i ppf (body : function_body) = + match[@warning "+9"] body with + | Tfunction_body e -> + line i ppf "Tfunction_body\n"; + expression (i+1) ppf e + | Tfunction_cases + { cases; loc; exp_extra; attributes = attrs; param = _; partial } + -> + line i ppf "Tfunction_cases%a %a\n" + fmt_partiality partial + fmt_location loc; + attributes (i+1) ppf attrs; + Option.iter (fun e -> expression_extra (i+1) ppf e []) exp_extra; + list (i+1) case ppf cases + +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 = i+1 in + begin match x.exp_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (fun (x, _, attrs) -> expression_extra (i+1) ppf x attrs) extra; + end; + 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 (params, body) -> + line i ppf "Texp_function\n"; + list i function_param ppf params; + function_body i ppf body; + | 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%a\n" + fmt_partiality partial; + 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) -> + line i ppf "Texp_send \"%s\"\n" s; + expression i ppf e + | Texp_send (e, Tmeth_val s) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e + | Texp_send (e, Tmeth_ancestor(s, _)) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e + | 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%a" + fmt_partiality partial; + 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 function_param i ppf x = + let p = x.fp_arg_label in + arg_label i ppf p; + match x.fp_kind with + | Tparam_pat pat -> + line i ppf "Param_pat%a\n" + fmt_partiality x.fp_partial; + pattern (i+1) ppf pat + | Tparam_optional_default (pat, expr) -> + line i ppf "Param_optional_default%a\n" + fmt_partiality x.fp_partial; + pattern (i+1) ppf pat; + expression (i+1) ppf expr + +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(v, a, r) -> + line i ppf "Text_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; + 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_apply_unit me1 -> + line i ppf "Tmod_apply_unit\n"; + module_expr i ppf me1; + | 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 " %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_vars; + 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; + if cd_vars <> [] then line (i+1) ppf "cd_vars =%a\n" typevars cd_vars; + 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 "\n"; + pattern (i+1) ppf c_lhs; + begin match c_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf c_rhs; + +and value_binding i ppf x = + line i ppf "\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 " \"%a\"\n" fmt_ident 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 "" + +and label_x_expression i ppf (l, e) = + line i ppf "\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 " \"%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_502/typing/printtyped.mli b/upstream/ocaml_502/typing/printtyped.mli new file mode 100644 index 0000000000..43539ead9d --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/shape.ml b/upstream/ocaml_502/typing/shape.ml new file mode 100644 index 0000000000..c58bdaecfb --- /dev/null +++ b/upstream/ocaml_502/typing/shape.ml @@ -0,0 +1,357 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* 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 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 "" + | Predef name -> Format.fprintf fmt "" 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 + +module Sig_component_kind = struct + type t = + | Value + | Type + | Constructor + | Label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + let to_string = function + | Value -> "value" + | Type -> "type" + | Constructor -> "constructor" + | Label -> "label" + | Module -> "module" + | Module_type -> "module type" + | Extension_constructor -> "extension constructor" + | Class -> "class" + | Class_type -> "class type" + + let can_appear_in_types = function + | Value + | Extension_constructor -> + false + | Type + | Constructor + | Label + | Module + | Module_type + | Class + | Class_type -> + true +end + +module Item = struct + module T = struct + type t = string * Sig_component_kind.t + let compare = compare + + let name (name, _) = name + let kind (_, kind) = kind + + let make str ns = str, ns + + let value id = Ident.name id, Sig_component_kind.Value + let type_ id = Ident.name id, Sig_component_kind.Type + let constr id = Ident.name id, Sig_component_kind.Constructor + let label id = Ident.name id, Sig_component_kind.Label + let module_ id = Ident.name id, Sig_component_kind.Module + let module_type id = Ident.name id, Sig_component_kind.Module_type + let extension_constructor id = + Ident.name id, Sig_component_kind.Extension_constructor + let class_ id = + Ident.name id, Sig_component_kind.Class + let class_type id = + Ident.name id, Sig_component_kind.Class_type + + let print fmt (name, ns) = + Format.fprintf fmt "%S[%s]" + name + (Sig_component_kind.to_string ns) + end + + include T + + module Map = Map.Make(T) +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc; approximated: bool } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Alias of t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + | Error of string + +let print fmt t = + let print_uid_opt = + Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print) + in + let rec aux fmt { uid; desc } = + match desc with + | Var id -> + Format.fprintf fmt "%s%a" (Ident.name id) print_uid_opt uid + | Abs (id, t) -> + let rec collect_idents = function + | { uid = None; desc = Abs(id, t) } -> + let (ids, body) = collect_idents t in + id :: ids, body + | body -> + ([], body) + in + let (other_idents, body) = collect_idents t in + let pp_idents fmt idents = + let idents_names = List.map Ident.name idents in + let pp_sep fmt () = Format.fprintf fmt ",@ " in + Format.pp_print_list ~pp_sep Format.pp_print_string fmt idents_names + in + Format.fprintf fmt "Abs@[%a@,(@[%a,@ @[%a@]@])@]" + print_uid_opt uid pp_idents (id :: other_idents) aux body + | App (t1, t2) -> + Format.fprintf fmt "@[%a(@,%a)%a@]" aux t1 aux t2 + print_uid_opt uid + | Leaf -> + Format.fprintf fmt "<%a>" (Format.pp_print_option Uid.print) uid + | Proj (t, item) -> + begin match uid with + | None -> + Format.fprintf fmt "@[%a@ .@ %a@]" + aux t + Item.print item + | Some uid -> + Format.fprintf fmt "@[(%a@ .@ %a)<%a>@]" + aux t + Item.print item + Uid.print uid + end + | Comp_unit name -> Format.fprintf fmt "CU %s" name + | Struct map -> + let print_map fmt = + Item.Map.iter (fun item t -> + Format.fprintf fmt "@[%a ->@ %a;@]@," + Item.print item + aux t + ) + in + if Item.Map.is_empty map then + Format.fprintf fmt "@[{%a}@]" print_uid_opt uid + else + Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + | Alias t -> + Format.fprintf fmt "Alias@[(@[%a@,%a@])@]" print_uid_opt uid aux t + | Error s -> + Format.fprintf fmt "Error %s" s + in + if t.approximated then + Format.fprintf fmt "@[(approx)@ %a@]@;" aux t + else + Format.fprintf fmt "@[%a@]@;" aux t + +let rec strip_head_aliases = function + | { desc = Alias t; _ } -> strip_head_aliases t + | t -> t + +let fresh_var ?(name="shape-var") uid = + let var = Ident.create_local name in + var, { uid = Some uid; desc = Var var; approximated = false } + +let for_unnamed_functor_param = Ident.create_local "()" + +let var uid id = + { uid = Some uid; desc = Var id; approximated = false } + +let abs ?uid var body = + { uid; desc = Abs (var, body); approximated = false } + +let str ?uid map = + { uid; desc = Struct map; approximated = false } + +let alias ?uid t = + { uid; desc = Alias t; approximated = false} + +let leaf uid = + { uid = Some uid; desc = Leaf; approximated = false } + +let approx t = { t with approximated = true} + +let proj ?uid t item = + match t.desc with + | Leaf -> + (* When stuck projecting in a leaf we propagate the leaf + as a best effort *) + approx t + | Struct map -> + begin try Item.Map.find item map + with Not_found -> approx t (* ill-typed program *) + end + | _ -> + { uid; desc = Proj (t, item); approximated = false } + +let app ?uid f ~arg = + { uid; desc = App (f, arg); approximated = false } + +let decompose_abs t = + match t.desc with + | Abs (x, t) -> Some (x, t) + | _ -> None + +let dummy_mod = + { uid = None; desc = Struct Item.Map.empty; approximated = false } + +let of_path ~find_shape ~namespace path = + (* We need to handle the following cases: + Path of constructor: + M.t.C + Path of label: + M.t.lbl + Path of label of inline record: + M.t.C.lbl *) + let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function + | Pident id -> find_shape ns id + | Pdot (path, name) -> + let namespace : Sig_component_kind.t = + match (ns : Sig_component_kind.t) with + | Constructor -> Type + | Label -> Type + | _ -> Module + in + proj (aux namespace path) (name, ns) + | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) + | Pextra_ty (path, extra) -> begin + match extra with + Pcstr_ty name -> proj (aux Type path) (name, Constructor) + | Pext_ty -> aux Extension_constructor path + end + in + aux namespace path + +let for_persistent_unit s = + { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s)); + desc = Comp_unit s; approximated = false } + +let leaf_for_unpack = { uid = None; desc = Leaf; approximated = false } + +let set_uid_if_none t uid = + match t.uid with + | None -> { t with uid = Some uid } + | _ -> t + +module Map = struct + type shape = t + type nonrec t = t Item.Map.t + + let empty = Item.Map.empty + + let add t item shape = Item.Map.add item shape t + + let add_value t id uid = Item.Map.add (Item.value id) (leaf uid) t + let add_value_proj t id shape = + let item = Item.value id in + Item.Map.add item (proj shape item) t + + let add_type t id shape = Item.Map.add (Item.type_ id) shape t + let add_type_proj t id shape = + let item = Item.type_ id in + Item.Map.add item (proj shape item) t + + let add_constr t id shape = Item.Map.add (Item.constr id) shape t + let add_constr_proj t id shape = + let item = Item.constr id in + Item.Map.add item (proj shape item) t + + let add_label t id uid = Item.Map.add (Item.label id) (leaf uid) t + let add_label_proj t id shape = + let item = Item.label id in + Item.Map.add item (proj shape item) t + + let add_module t id shape = Item.Map.add (Item.module_ id) shape t + let add_module_proj t id shape = + let item = Item.module_ id in + Item.Map.add item (proj shape item) t + + let add_module_type t id uid = + Item.Map.add (Item.module_type id) (leaf uid) t + let add_module_type_proj t id shape = + let item = Item.module_type id in + Item.Map.add item (proj shape item) t + + let add_extcons t id shape = + Item.Map.add (Item.extension_constructor id) shape t + let add_extcons_proj t id shape = + let item = Item.extension_constructor id in + Item.Map.add item (proj shape item) t + + let add_class t id uid = Item.Map.add (Item.class_ id) (leaf uid) t + let add_class_proj t id shape = + let item = Item.class_ id in + Item.Map.add item (proj shape item) t + + let add_class_type t id uid = Item.Map.add (Item.class_type id) (leaf uid) t + let add_class_type_proj t id shape = + let item = Item.class_type id in + Item.Map.add item (proj shape item) t +end diff --git a/upstream/ocaml_502/typing/shape.mli b/upstream/ocaml_502/typing/shape.mli new file mode 100644 index 0000000000..25852be12f --- /dev/null +++ b/upstream/ocaml_502/typing/shape.mli @@ -0,0 +1,201 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Shapes are an abstract representation of modules' implementations which + allow the tracking of definitions through functor applications and other + module-level operations. + + The Shape of a compilation unit is elaborated during typing, partially + reduced (without loading external shapes) and written to the [cmt] file. + + External tools can retrieve the definition of any value (or type, or module, + etc) by following this procedure: + + - Build the Shape corresponding to the value's path: + [let shape = Env.shape_of_path ~namespace env path] + + - Instantiate the [Shape_reduce.Make] functor with a way to load shapes from + external units and to looks for shapes in the environment (usually using + [Env.shape_of_path]). + + - Completely reduce the shape: + [let shape = My_reduce.(weak_)reduce env shape] + + - The [Uid.t] stored in the reduced shape should be the one of the + definition. However, if the [approximate] field of the reduced shape is + [true] then the [Uid.t] will not correspond to the definition, but to the + closest parent module's uid. This happens when Shape reduction gets stuck, + for example when hitting first-class modules. + + - The location of the definition can be easily found with the + [cmt_format.cmt_uid_to_decl] table of the corresponding compilation unit. + + See: + - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling } + the design document} + - {{: https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf } + a talk about the reduction strategy +*) + +(** A [Uid.t] is associated to every declaration in signatures and + implementations. They uniquely identify bindings in the program. When + associated with these bindings' locations they are useful to external tools + when trying to jump to an identifier's declaration or definition. They are + stored to that effect in the [uid_to_decl] table of cmt files. *) +module Uid : sig + type t = private + | Compilation_unit of string + | Item of { comp_unit: string; id: int } + | Internal + | Predef of string + + 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 + +module Sig_component_kind : sig + type t = + | Value + | Type + | Constructor + | Label + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + val to_string : t -> string + + (** Whether the name of a component of that kind can appear in a type. *) + val can_appear_in_types : t -> bool +end + +(** Shape's items are elements of a structure or, in the case of constructors + and labels, elements of a record or variants definition seen as a structure. + These structures model module components and nested types' constructors and + labels. *) +module Item : sig + type t = string * Sig_component_kind.t + val name : t -> string + val kind : t -> Sig_component_kind.t + + val make : string -> Sig_component_kind.t -> t + + val value : Ident.t -> t + val type_ : Ident.t -> t + val constr : Ident.t -> t + val label : Ident.t -> t + val module_ : Ident.t -> t + val module_type : Ident.t -> t + val extension_constructor : Ident.t -> t + val class_ : Ident.t -> t + val class_type : Ident.t -> t + + val print : Format.formatter -> t -> unit + + module Map : Map.S with type key = t +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc; approximated: bool } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Alias of t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + | Error of string + +val print : Format.formatter -> t -> unit + +val strip_head_aliases : t -> t + +(* Smart constructors *) + +val for_unnamed_functor_param : var +val fresh_var : ?name:string -> Uid.t -> var * t + +val var : Uid.t -> Ident.t -> t +val abs : ?uid:Uid.t -> var -> t -> t +val app : ?uid:Uid.t -> t -> arg:t -> t +val str : ?uid:Uid.t -> t Item.Map.t -> t +val alias : ?uid:Uid.t -> t -> t +val proj : ?uid:Uid.t -> t -> Item.t -> t +val leaf : Uid.t -> t + +val decompose_abs : t -> (var * t) option + +val for_persistent_unit : string -> t +val leaf_for_unpack : t + +module Map : sig + type shape = t + type nonrec t = t Item.Map.t + + val empty : t + + val add : t -> Item.t -> shape -> t + + val add_value : t -> Ident.t -> Uid.t -> t + val add_value_proj : t -> Ident.t -> shape -> t + + val add_type : t -> Ident.t -> shape -> t + val add_type_proj : t -> Ident.t -> shape -> t + + val add_constr : t -> Ident.t -> shape -> t + val add_constr_proj : t -> Ident.t -> shape -> t + + val add_label : t -> Ident.t -> Uid.t -> t + val add_label_proj : t -> Ident.t -> shape -> t + + val add_module : t -> Ident.t -> shape -> t + val add_module_proj : t -> Ident.t -> shape -> t + + val add_module_type : t -> Ident.t -> Uid.t -> t + val add_module_type_proj : t -> Ident.t -> shape -> t + + val add_extcons : t -> Ident.t -> shape -> t + val add_extcons_proj : t -> Ident.t -> shape -> t + + val add_class : t -> Ident.t -> Uid.t -> t + val add_class_proj : t -> Ident.t -> shape -> t + + val add_class_type : t -> Ident.t -> Uid.t -> t + val add_class_type_proj : t -> Ident.t -> shape -> t +end + +val dummy_mod : t + +(** This function returns the shape corresponding to a given path. It requires a + callback to find shapes in the environment. It is generally more useful to + rely directly on the [Env.shape_of_path] function to get the shape + associated with a given path. *) +val of_path : + find_shape:(Sig_component_kind.t -> Ident.t -> t) -> + namespace:Sig_component_kind.t -> Path.t -> t + +val set_uid_if_none : t -> Uid.t -> t diff --git a/upstream/ocaml_502/typing/shape_reduce.ml b/upstream/ocaml_502/typing/shape_reduce.ml new file mode 100644 index 0000000000..718b212133 --- /dev/null +++ b/upstream/ocaml_502/typing/shape_reduce.ml @@ -0,0 +1,347 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* Nathanaëlle Courant, OCamlPro *) +(* Gabriel Scherer, projet Picube, 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. *) +(* *) +(**************************************************************************) + +open Shape + +type result = + | Resolved of Uid.t + | Resolved_alias of Uid.t list + | Unresolved of t + | Approximated of Uid.t option + | Internal_error_missing_uid + +let print_result fmt result = + match result with + | Resolved uid -> + Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid + | Resolved_alias uids -> + Format.fprintf fmt "@[Resolved_alias: %a@]@;" + Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ -> ") + Uid.print) uids + | Unresolved shape -> + Format.fprintf fmt "@[Unresolved: %a@]@;" print shape + | Approximated (Some uid) -> + Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid + | Approximated None -> + Format.fprintf fmt "@[Approximated: No uid@]@;" + | Internal_error_missing_uid -> + Format.fprintf fmt "@[Missing uid@]@;" + + +let find_shape env id = + let namespace = Shape.Sig_component_kind.Module in + Env.shape_of_path ~namespace env (Pident id) + +module Make(Params : sig + val fuel : int + val read_unit_shape : unit_name:string -> t option +end) = struct + (* We implement a strong call-by-need reduction, following an + evaluator from Nathanaelle Courant. *) + + type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool } + and nf_desc = + | NVar of var + | NApp of nf * nf + | NAbs of local_env * var * t * delayed_nf + | NStruct of delayed_nf Item.Map.t + | NAlias of delayed_nf + | NProj of nf * Item.t + | NLeaf + | NComp_unit of string + | NError of string + + (* A type of normal forms for strong call-by-need evaluation. + The normal form of an abstraction + Abs(x, t) + is a closure + NAbs(env, x, t, dnf) + when [env] is the local environment, and [dnf] is a delayed + normal form of [t]. + + A "delayed normal form" is morally equivalent to (nf Lazy.t), but + we use a different representation that is compatible with + memoization (lazy values are not hashable/comparable by default + comparison functions): we represent a delayed normal form as + just a not-yet-computed pair [local_env * t] of a term in a + local environment -- we could also see this as a term under + an explicit substitution. This delayed thunked is "forced" + by calling the normalization function as usual, but duplicate + computations are precisely avoided by memoization. + *) + and delayed_nf = Thunk of local_env * t + + and local_env = delayed_nf option Ident.Map.t + (* When reducing in the body of an abstraction [Abs(x, body)], we + bind [x] to [None] in the environment. [Some v] is used for + actual substitutions, for example in [App(Abs(x, body), t)], when + [v] is a thunk that will evaluate to the normal form of [t]. *) + + let approx_nf nf = { nf with approximated = true } + + let in_memo_table memo_table memo_key f arg = + match Hashtbl.find memo_table memo_key with + | res -> res + | exception Not_found -> + let res = f arg in + Hashtbl.replace memo_table memo_key res; + res + + type env = { + fuel: int ref; + global_env: Env.t; + local_env: local_env; + reduce_memo_table: (local_env * t, nf) Hashtbl.t; + read_back_memo_table: (nf, t) Hashtbl.t; + } + + let bind env var shape = + { env with local_env = Ident.Map.add var shape env.local_env } + + let rec reduce_ env t = + let local_env = env.local_env in + let memo_key = (local_env, t) in + in_memo_table env.reduce_memo_table memo_key (reduce__ env) t + (* Memoization is absolutely essential for performance on this + problem, because the normal forms we build can in some real-world + cases contain an exponential amount of redundancy. Memoization + can avoid the repeated evaluation of identical subterms, + providing a large speedup, but even more importantly it + implicitly shares the memory of the repeated results, providing + much smaller normal forms (that blow up again if printed back + as trees). A functor-heavy file from Irmin has its shape normal + form decrease from 100Mio to 2.5Mio when memoization is enabled. + + Note: the local environment is part of the memoization key, while + it is defined using a type Ident.Map.t of non-canonical balanced + trees: two maps could have exactly the same items, but be + balanced differently and therefore hash differently, reducing + the effectivenss of memoization. + This could in theory happen, say, with the two programs + (fun x -> fun y -> ...) + and + (fun y -> fun x -> ...) + having "the same" local environments, with additions done in + a different order, giving non-structurally-equal trees. Should we + define our own hash functions to provide robust hashing on + environments? + + We believe that the answer is "no": this problem does not occur + in practice. We can assume that identifiers are unique on valid + typedtree fragments (identifier "stamps" distinguish + binding positions); in particular the two program fragments above + in fact bind *distinct* identifiers x (with different stamps) and + different identifiers y, so the environments are distinct. If two + environments are structurally the same, they must correspond to + the evaluation evnrionments of two sub-terms that are under + exactly the same scope of binders. So the two environments were + obtained by the same term traversal, adding binders in the same + order, giving the same balanced trees: the environments have the + same hash. +*) + + and reduce__ + ({fuel; global_env; local_env; _} as env) (t : t) = + let reduce env t = reduce_ env t in + let delay_reduce env t = Thunk (env.local_env, t) in + let force (Thunk (local_env, t)) = reduce { env with local_env } t in + let return desc = { uid = t.uid; desc; approximated = t.approximated } in + let rec force_aliases nf = match nf.desc with + | NAlias delayed_nf -> + let nf = force delayed_nf in + force_aliases nf + | _ -> nf + in + let reset_uid_if_new_binding t' = + match t.uid with + | None -> t' + | Some _ as uid -> { t' with uid } + in + if !fuel < 0 then approx_nf (return (NError "NoFuelLeft")) + else + match t.desc with + | Comp_unit unit_name -> + begin match Params.read_unit_shape ~unit_name with + | Some t -> reduce env t + | None -> return (NComp_unit unit_name) + end + | App(f, arg) -> + let f = reduce env f |> force_aliases in + begin match f.desc with + | NAbs(clos_env, var, body, _body_nf) -> + let arg = delay_reduce env arg in + let env = bind { env with local_env = clos_env } var (Some arg) in + reduce env body |> reset_uid_if_new_binding + | _ -> + let arg = reduce env arg in + return (NApp(f, arg)) + end + | Proj(str, item) -> + let str = reduce env str |> force_aliases in + let nored () = return (NProj(str, item)) in + begin match str.desc with + | NStruct (items) -> + begin match Item.Map.find item items with + | exception Not_found -> nored () + | nf -> force nf |> reset_uid_if_new_binding + end + | _ -> + nored () + end + | Abs(var, body) -> + let body_nf = delay_reduce (bind env var None) body in + return (NAbs(local_env, var, body, body_nf)) + | Var id -> + begin match Ident.Map.find id local_env with + (* Note: instead of binding abstraction-bound variables to + [None], we could unify it with the [Some v] case by + binding the bound variable [x] to [NVar x]. + + One reason to distinguish the situations is that we can + provide a different [Uid.t] location; for bound + variables, we use the [Uid.t] of the bound occurrence + (not the binding site), whereas for bound values we use + their binding-time [Uid.t]. *) + | None -> return (NVar id) + | Some def -> + begin match force def with + | { uid = Some _; _ } as nf -> nf + (* This var already has a binding uid *) + | { uid = None; _ } as nf -> { nf with uid = t.uid } + (* Set the var's binding uid *) + end + | exception Not_found -> + match find_shape global_env id with + | exception Not_found -> return (NVar id) + | res when res = t -> return (NVar id) + | res -> + decr fuel; + reduce env res + end + | Leaf -> return NLeaf + | Struct m -> + let mnf = Item.Map.map (delay_reduce env) m in + return (NStruct mnf) + | Alias t -> return (NAlias (delay_reduce env t)) + | Error s -> approx_nf (return (NError s)) + + and read_back env (nf : nf) : t = + in_memo_table env.read_back_memo_table nf (read_back_ env) nf + (* The [nf] normal form we receive may contain a lot of internal + sharing due to the use of memoization in the evaluator. We have + to memoize here again, otherwise the sharing is lost by mapping + over the term as a tree. *) + + and read_back_ env (nf : nf) : t = + { uid = nf.uid ; + desc = read_back_desc env nf.desc; + approximated = nf.approximated } + + and read_back_desc env desc = + let read_back nf = read_back env nf in + let read_back_force (Thunk (local_env, t)) = + read_back (reduce_ { env with local_env } t) in + match desc with + | NVar v -> + Var v + | NApp (nft, nfu) -> + App(read_back nft, read_back nfu) + | NAbs (_env, x, _t, nf) -> + Abs(x, read_back_force nf) + | NStruct nstr -> + Struct (Item.Map.map read_back_force nstr) + | NAlias nf -> Alias (read_back_force nf) + | NProj (nf, item) -> + Proj (read_back nf, item) + | NLeaf -> Leaf + | NComp_unit s -> Comp_unit s + | NError s -> Error s + + (* Sharing the memo tables is safe at the level of a compilation unit since + idents should be unique *) + let reduce_memo_table = Local_store.s_table Hashtbl.create 42 + let read_back_memo_table = Local_store.s_table Hashtbl.create 42 + + let reduce global_env t = + let fuel = ref Params.fuel in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table = !reduce_memo_table; + read_back_memo_table = !read_back_memo_table; + local_env; + } in + reduce_ env t |> read_back env + + let rec is_stuck_on_comp_unit (nf : nf) = + match nf.desc with + | NVar _ -> + (* This should not happen if we only reduce closed terms *) + false + | NApp (nf, _) | NProj (nf, _) -> is_stuck_on_comp_unit nf + | NStruct _ | NAbs _ -> false + | NAlias _ -> false + | NComp_unit _ -> true + | NError _ -> false + | NLeaf -> false + + let get_aliases_uids (t : t) = + let rec aux acc (t : t) = match t with + | { uid = Some uid; desc = Alias t; _ } -> aux (uid::acc) t + | { uid = Some uid; _ } -> Resolved_alias (List.rev (uid::acc)) + | _ -> Internal_error_missing_uid + in + aux [] t + + let reduce_for_uid global_env t = + let fuel = ref Params.fuel in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table = !reduce_memo_table; + read_back_memo_table = !read_back_memo_table; + local_env; + } in + let nf = reduce_ env t in + if is_stuck_on_comp_unit nf then + Unresolved (read_back env nf) + else match nf with + | { desc = NAlias _; approximated = false; _ } -> + get_aliases_uids (read_back env nf) + | { uid = Some uid; approximated = false; _ } -> + Resolved uid + | { uid; approximated = true; _ } -> + Approximated uid + | { uid = None; approximated = false; _ } -> + (* A missing Uid after a complete reduction means the Uid was first + missing in the shape which is a code error. Having the + [Missing_uid] reported will allow Merlin (or another tool working + with the index) to ask users to report the issue if it does happen. + *) + Internal_error_missing_uid +end + +module Local_reduce = + Make(struct + let fuel = 10 + let read_unit_shape ~unit_name:_ = None + end) + +let local_reduce = Local_reduce.reduce +let local_reduce_for_uid = Local_reduce.reduce_for_uid diff --git a/upstream/ocaml_502/typing/shape_reduce.mli b/upstream/ocaml_502/typing/shape_reduce.mli new file mode 100644 index 0000000000..5e409c3cd7 --- /dev/null +++ b/upstream/ocaml_502/typing/shape_reduce.mli @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* Nathanaëlle Courant, OCamlPro *) +(* Gabriel Scherer, projet Picube, 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. *) +(* *) +(**************************************************************************) + +(** The result of reducing a shape and looking for its uid *) +type result = + | Resolved of Shape.Uid.t (** Shape reduction succeeded and a uid was found *) + | Resolved_alias of Shape.Uid.t list (** Reduction led to an alias chain *) + | Unresolved of Shape.t (** Result still contains [Comp_unit] terms *) + | Approximated of Shape.Uid.t option + (** Reduction failed: it can arrive with first-clsss modules for example *) + | Internal_error_missing_uid + (** Reduction succeeded but no uid was found, this should never happen *) + +val print_result : Format.formatter -> result -> unit + +(** The [Make] functor is used to generate a reduction function for + shapes. + + It is parametrized by: + - a function to load the shape of an external compilation unit + - some fuel, which is used to bound recursion when dealing with recursive + shapes introduced by recursive modules. (FTR: merlin currently uses a + fuel of 10, which seems to be enough for most practical examples) + + Usage warning: To ensure good performances, every reduction made with the + same instance of that functor share the same ident-based memoization tables. + Such an instance should only be used to perform reduction inside a unique + compilation unit to prevent conflicting entries in these memoization tables. +*) +module Make(_ : sig + val fuel : int + + val read_unit_shape : unit_name:string -> Shape.t option + end) : sig + val reduce : Env.t -> Shape.t -> Shape.t + + (** Perform weak reduction and return the head's uid if any. If reduction was + incomplete the partially reduced shape is returned. *) + val reduce_for_uid : Env.t -> Shape.t -> result +end + +(** [local_reduce] will not reduce shapes that require loading external + compilation units. *) +val local_reduce : Env.t -> Shape.t -> Shape.t + +(** [local_reduce_for_uid] will not reduce shapes that require loading external + compilation units. *) +val local_reduce_for_uid : Env.t -> Shape.t -> result diff --git a/upstream/ocaml_502/typing/signature_group.ml b/upstream/ocaml_502/typing/signature_group.ml new file mode 100644 index 0000000000..b98a9eb67f --- /dev/null +++ b/upstream/ocaml_502/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 + syntactic 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 type [c] *) + begin match q with + | ct::t::q -> [ct;t], q + | _ -> assert false + end + | Types.Sig_class_type _ -> + (* a class type declaration for [ct] is followed by the ghost + declaration of type [ct] *) + begin match q with + | t::q -> [t], 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/upstream/ocaml_502/typing/signature_group.mli b/upstream/ocaml_502/typing/signature_group.mli new file mode 100644 index 0000000000..0b736a5b45 --- /dev/null +++ b/upstream/ocaml_502/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 + syntactic 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/upstream/ocaml_502/typing/stypes.ml b/upstream/ocaml_502/typing/stypes.ml new file mode 100644 index 0000000000..c3db19a552 --- /dev/null +++ b/upstream/ocaml_502/typing/stypes.ml @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* 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; + Format.pp_print_string Format.str_formatter " "; + Printtyp.wrap_printing_env ~error:false env + (fun () -> Printtyp.shared_type_scheme 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_502/typing/stypes.mli b/upstream/ocaml_502/typing/stypes.mli new file mode 100644 index 0000000000..3a86d27a57 --- /dev/null +++ b/upstream/ocaml_502/typing/stypes.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* 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_502/typing/subst.ml b/upstream/ocaml_502/typing/subst.ml new file mode 100644 index 0000000000..87b6ec6e97 --- /dev/null +++ b/upstream/ocaml_502/typing/subst.ml @@ -0,0 +1,834 @@ +(**************************************************************************) +(* *) +(* 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) + | Pextra_ty _ -> + fatal_error "Subst.module_path" + +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 _ | Pextra_ty _ -> + fatal_error "Subst.modtype_path" + | Pident _ -> path + +(* For values, extension constructors, classes and class types *) +let value_path s path = + match path with + | Pident _ -> path + | Pdot(p, n) -> Pdot(module_path s p, n) + | Papply _ | Pextra_ty _ -> fatal_error "Subst.value_path" + +let rec 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" + | Pextra_ty (p, extra) -> + match extra with + | Pcstr_ty _ -> Pextra_ty (type_path s p, extra) + | Pext_ty -> Pextra_ty (value_path s p, extra) + +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; + create_expr + 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 apply_type_function params args body = + For_copy.with_scope (fun copy_scope -> + List.iter2 + (fun param arg -> + For_copy.redirect_desc copy_scope param (Tsubst (arg, None))) + params args; + let rec copy ty = + assert (get_level ty = generic_level); + match get_desc ty with + | Tsubst (ty, _) -> ty + | Tvariant row -> + let t = newgenstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let more = row_more row in + assert (get_level more = generic_level); + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + let desc' = + match mored with + | Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + let more' = + match mored with + Tsubst (ty, None) -> ty + (* TODO: is this case possible? + possibly an interaction with (copy more) below? *) + | Tconstr _ | Tnil -> + copy more + | Tvar _ | Tunivar _ -> + newgenty mored + | _ -> assert false + in + let row = + match get_desc more' with (* PR#6163 *) + Tconstr (x,_,_) when not (is_fixed row) -> + let Row {fields; more; closed; name} = row_repr row in + create_row ~fields ~more ~closed ~name + ~fixed:(Some (Reified x)) + | _ -> row + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope more + (Tsubst(more', Some t)); + (* Return a new copy *) + Tvariant (copy_row copy true row false more') + in + Transient_expr.set_stub_desc t desc'; + t + | desc -> + let t = newgenstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let desc' = copy_type_desc copy desc in + Transient_expr.set_stub_desc t desc'; + t + in + copy body) + + +(* Similar to [Ctype.nondep_type_rec]. *) +let rec typexp copy_scope s ty = + let desc = get_desc ty in + match desc with + Tvar _ | Tunivar _ -> + if s.for_saving || get_id ty < 0 then + let ty' = + if s.for_saving then newpersty (norm desc) + else newty2 ~level:(get_level ty) desc + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + ty' + else ty + | Tsubst (ty, _) -> + ty + | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method + && field_kind_repr k <> Fabsent && get_level ty < 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 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 newgenstub ~scope:(get_scope ty) + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + let desc = + if has_fixed_row then + match get_desc tm 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 (apply_type_function params args body) + 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 more = row_more row in + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + begin match mored with + Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + let dup = + s.for_saving || get_level more = generic_level || + static_row row || is_Tconstr more in + (* Various cases for the row variable *) + let more' = + match mored with + Tsubst (ty, None) -> ty + | Tconstr _ | Tnil -> typexp copy_scope s more + | Tunivar _ | Tvar _ -> + if s.for_saving then newpersty (norm mored) + else if dup && is_Tvar more then newgenty mored + else more + | _ -> assert false + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope 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_name row with + | Some (p, tl) -> + let name = + if to_subst_by_type_function s p then None + else Some (type_path s p, tl) + in + Tvariant (set_row_name row name) + | 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 + in + Transient_expr.set_stub_desc ty' desc; + 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 r -> Type_abstract r + | 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_self_row = typexp copy_scope s sign.csig_self_row; + csig_vars = + Vars.map + (function (m, v, t) -> (m, v, typexp copy_scope s t)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, t) -> (p, v, typexp copy_scope s t)) + sign.csig_meths; + } + +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_hash_type = type_declaration' copy_scope s decl.clty_hash_type ; + 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) + + +(* 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 }) + +type scoping = + | Keep + | Make_local + | Rescope of int + +module Lazy_types = struct + + type module_decl = + { + mdl_type: modtype; + mdl_attributes: Parsetree.attributes; + mdl_loc: Location.t; + mdl_uid: Uid.t; + } + + and modtype = + | MtyL_ident of Path.t + | MtyL_signature of signature + | MtyL_functor of functor_parameter * modtype + | MtyL_alias of Path.t + + and modtype_declaration = + { + mtdl_type: modtype option; + mtdl_attributes: Parsetree.attributes; + mtdl_loc: Location.t; + mtdl_uid: Uid.t; + } + + and signature' = + | S_eager of Types.signature + | S_lazy of signature_item list + + and signature = + (scoping * t * signature', signature') Lazy_backtrack.t + + and signature_item = + SigL_value of Ident.t * value_description * visibility + | SigL_type of Ident.t * type_declaration * rec_status * visibility + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility + | SigL_module of + Ident.t * module_presence * module_decl * rec_status * visibility + | SigL_modtype of Ident.t * modtype_declaration * visibility + | SigL_class of Ident.t * class_declaration * rec_status * visibility + | SigL_class_type of Ident.t * class_type_declaration * + rec_status * visibility + + and functor_parameter = + | Unit + | Named of Ident.t option * modtype + +end +open Lazy_types + +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 + | SigL_type(id, td, rs, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_type id (Pident id') s) + (SigL_type(id', td, rs, vis) :: sg) + rest + | SigL_module(id, pres, md, rs, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_module id (Pident id') s) + (SigL_module (id', pres, md, rs, vis) :: sg) + rest + | SigL_modtype(id, mtd, vis) :: rest -> + let id' = rename id in + rename_bound_idents + (add_modtype id (Mty_ident(Pident id')) s) + (SigL_modtype(id', mtd, vis) :: sg) + rest + | SigL_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) + (SigL_class(id', cd, rs, vis) :: sg) + rest + | SigL_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) + (SigL_class_type(id', ctd, rs, vis) :: sg) + rest + | SigL_value(id, vd, vis) :: rest -> + (* scope doesn't matter for value identifiers. *) + let id' = Ident.rename id in + rename_bound_idents s (SigL_value(id', vd, vis) :: sg) rest + | SigL_typext(id, ec, es, vis) :: rest -> + let id' = rename id in + rename_bound_idents s (SigL_typext(id',ec,es,vis) :: sg) rest + in + rename_bound_idents s [] sg + +let rec lazy_module_decl md = + { mdl_type = lazy_modtype md.md_type; + mdl_attributes = md.md_attributes; + mdl_loc = md.md_loc; + mdl_uid = md.md_uid } + +and subst_lazy_module_decl scoping s md = + let mdl_type = subst_lazy_modtype scoping s md.mdl_type in + { mdl_type; + mdl_attributes = attrs s md.mdl_attributes; + mdl_loc = loc s md.mdl_loc; + mdl_uid = md.mdl_uid } + +and force_module_decl md = + let md_type = force_modtype md.mdl_type in + { md_type; + md_attributes = md.mdl_attributes; + md_loc = md.mdl_loc; + md_uid = md.mdl_uid } + +and lazy_modtype = function + | Mty_ident p -> MtyL_ident p + | Mty_signature sg -> + MtyL_signature (Lazy_backtrack.create_forced (S_eager sg)) + | Mty_functor (Unit, mty) -> MtyL_functor (Unit, lazy_modtype mty) + | Mty_functor (Named (id, arg), res) -> + MtyL_functor (Named (id, lazy_modtype arg), lazy_modtype res) + | Mty_alias p -> MtyL_alias p + +and subst_lazy_modtype scoping s = function + | MtyL_ident p -> + begin match Path.Map.find p s.modtypes with + | mty -> lazy_modtype mty + | exception Not_found -> + begin match p with + | Pident _ -> MtyL_ident p + | Pdot(p, n) -> + MtyL_ident(Pdot(module_path s p, n)) + | Papply _ | Pextra_ty _ -> + fatal_error "Subst.modtype" + end + end + | MtyL_signature sg -> + MtyL_signature(subst_lazy_signature scoping s sg) + | MtyL_functor(Unit, res) -> + MtyL_functor(Unit, subst_lazy_modtype scoping s res) + | MtyL_functor(Named (None, arg), res) -> + MtyL_functor(Named (None, (subst_lazy_modtype scoping s) arg), + subst_lazy_modtype scoping s res) + | MtyL_functor(Named (Some id, arg), res) -> + let id' = Ident.rename id in + MtyL_functor(Named (Some id', (subst_lazy_modtype scoping s) arg), + subst_lazy_modtype scoping (add_module id (Pident id') s) res) + | MtyL_alias p -> + MtyL_alias (module_path s p) + +and force_modtype = function + | MtyL_ident p -> Mty_ident p + | MtyL_signature sg -> Mty_signature (force_signature sg) + | MtyL_functor (param, res) -> + let param : Types.functor_parameter = + match param with + | Unit -> Unit + | Named (id, mty) -> Named (id, force_modtype mty) in + Mty_functor (param, force_modtype res) + | MtyL_alias p -> Mty_alias p + +and lazy_modtype_decl mtd = + let mtdl_type = Option.map lazy_modtype mtd.mtd_type in + { mtdl_type; + mtdl_attributes = mtd.mtd_attributes; + mtdl_loc = mtd.mtd_loc; + mtdl_uid = mtd.mtd_uid } + +and subst_lazy_modtype_decl scoping s mtd = + { mtdl_type = Option.map (subst_lazy_modtype scoping s) mtd.mtdl_type; + mtdl_attributes = attrs s mtd.mtdl_attributes; + mtdl_loc = loc s mtd.mtdl_loc; + mtdl_uid = mtd.mtdl_uid } + +and force_modtype_decl mtd = + let mtd_type = Option.map force_modtype mtd.mtdl_type in + { mtd_type; + mtd_attributes = mtd.mtdl_attributes; + mtd_loc = mtd.mtdl_loc; + mtd_uid = mtd.mtdl_uid } + +and subst_lazy_signature scoping s sg = + match Lazy_backtrack.get_contents sg with + | Left (scoping', s', sg) -> + let scoping = + match scoping', scoping with + | sc, Keep -> sc + | _, (Make_local|Rescope _) -> scoping + in + let s = compose s' s in + Lazy_backtrack.create (scoping, s, sg) + | Right sg -> + Lazy_backtrack.create (scoping, s, sg) + +and force_signature sg = + List.map force_signature_item (force_signature_once sg) + +and force_signature_once sg = + lazy_signature' (Lazy_backtrack.force force_signature_once' sg) + +and lazy_signature' = function + | S_lazy sg -> sg + | S_eager sg -> List.map lazy_signature_item sg + +and force_signature_once' (scoping, s, sg) = + let sg = lazy_signature' sg in + (* 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 -> + S_lazy (List.rev_map (subst_lazy_signature_item' copy_scope scoping s') sg') + ) + +and lazy_signature_item = function + | Sig_value(id, d, vis) -> + SigL_value(id, d, vis) + | Sig_type(id, d, rs, vis) -> + SigL_type(id, d, rs, vis) + | Sig_typext(id, ext, es, vis) -> + SigL_typext(id, ext, es, vis) + | Sig_module(id, res, d, rs, vis) -> + SigL_module(id, res, lazy_module_decl d, rs, vis) + | Sig_modtype(id, d, vis) -> + SigL_modtype(id, lazy_modtype_decl d, vis) + | Sig_class(id, d, rs, vis) -> + SigL_class(id, d, rs, vis) + | Sig_class_type(id, d, rs, vis) -> + SigL_class_type(id, d, rs, vis) + +and subst_lazy_signature_item' copy_scope scoping s comp = + match comp with + SigL_value(id, d, vis) -> + SigL_value(id, value_description' copy_scope s d, vis) + | SigL_type(id, d, rs, vis) -> + SigL_type(id, type_declaration' copy_scope s d, rs, vis) + | SigL_typext(id, ext, es, vis) -> + SigL_typext(id, extension_constructor' copy_scope s ext, es, vis) + | SigL_module(id, pres, d, rs, vis) -> + SigL_module(id, pres, subst_lazy_module_decl scoping s d, rs, vis) + | SigL_modtype(id, d, vis) -> + SigL_modtype(id, subst_lazy_modtype_decl scoping s d, vis) + | SigL_class(id, d, rs, vis) -> + SigL_class(id, class_declaration' copy_scope s d, rs, vis) + | SigL_class_type(id, d, rs, vis) -> + SigL_class_type(id, cltype_declaration' copy_scope s d, rs, vis) + +and force_signature_item = function + | SigL_value(id, vd, vis) -> Sig_value(id, vd, vis) + | SigL_type(id, d, rs, vis) -> Sig_type(id, d, rs, vis) + | SigL_typext(id, ext, es, vis) -> Sig_typext(id, ext, es, vis) + | SigL_module(id, pres, d, rs, vis) -> + Sig_module(id, pres, force_module_decl d, rs, vis) + | SigL_modtype(id, d, vis) -> + Sig_modtype (id, force_modtype_decl d, vis) + | SigL_class(id, d, rs, vis) -> Sig_class(id, d, rs, vis) + | SigL_class_type(id, d, rs, vis) -> Sig_class_type(id, d, rs, vis) + +and modtype scoping s t = + t |> lazy_modtype |> subst_lazy_modtype scoping s |> force_modtype + +(* Composition of substitutions: + apply (compose s1 s2) x = apply s2 (apply s1 x) *) + +and compose s1 s2 = + if s1 == identity then s2 else + if s2 == identity then s1 else + { 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; + } + + +let subst_lazy_signature_item scoping s comp = + For_copy.with_scope + (fun copy_scope -> subst_lazy_signature_item' copy_scope scoping s comp) + +module Lazy = struct + include Lazy_types + + let of_module_decl = lazy_module_decl + let of_modtype = lazy_modtype + let of_modtype_decl = lazy_modtype_decl + let of_signature sg = Lazy_backtrack.create_forced (S_eager sg) + let of_signature_items sg = Lazy_backtrack.create_forced (S_lazy sg) + let of_signature_item = lazy_signature_item + + let module_decl = subst_lazy_module_decl + let modtype = subst_lazy_modtype + let modtype_decl = subst_lazy_modtype_decl + let signature = subst_lazy_signature + let signature_item = subst_lazy_signature_item + + let force_module_decl = force_module_decl + let force_modtype = force_modtype + let force_modtype_decl = force_modtype_decl + let force_signature = force_signature + let force_signature_once = force_signature_once + let force_signature_item = force_signature_item +end + +let signature sc s sg = + Lazy.(sg |> of_signature |> signature sc s |> force_signature) + +let signature_item sc s comp = + Lazy.(comp|> of_signature_item |> signature_item sc s |> force_signature_item) + +let modtype_declaration sc s decl = + Lazy.(decl |> of_modtype_decl |> modtype_decl sc s |> force_modtype_decl) + +let module_declaration scoping s decl = + Lazy.(decl |> of_module_decl |> module_decl scoping s |> force_module_decl) diff --git a/upstream/ocaml_502/typing/subst.mli b/upstream/ocaml_502/typing/subst.mli new file mode 100644 index 0000000000..8812d2a51d --- /dev/null +++ b/upstream/ocaml_502/typing/subst.mli @@ -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. *) +(* *) +(**************************************************************************) + +(* 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 + +module Lazy : sig + type module_decl = + { + mdl_type: modtype; + mdl_attributes: Parsetree.attributes; + mdl_loc: Location.t; + mdl_uid: Uid.t; + } + + and modtype = + | MtyL_ident of Path.t + | MtyL_signature of signature + | MtyL_functor of functor_parameter * modtype + | MtyL_alias of Path.t + + and modtype_declaration = + { + mtdl_type: modtype option; (* Note: abstract *) + mtdl_attributes: Parsetree.attributes; + mtdl_loc: Location.t; + mtdl_uid: Uid.t; + } + + and signature + + and signature_item = + SigL_value of Ident.t * value_description * visibility + | SigL_type of Ident.t * type_declaration * rec_status * visibility + | SigL_typext of Ident.t * extension_constructor * ext_status * visibility + | SigL_module of + Ident.t * module_presence * module_decl * rec_status * visibility + | SigL_modtype of Ident.t * modtype_declaration * visibility + | SigL_class of Ident.t * class_declaration * rec_status * visibility + | SigL_class_type of Ident.t * class_type_declaration * + rec_status * visibility + + and functor_parameter = + | Unit + | Named of Ident.t option * modtype + + + val of_module_decl : Types.module_declaration -> module_decl + val of_modtype : Types.module_type -> modtype + val of_modtype_decl : Types.modtype_declaration -> modtype_declaration + val of_signature : Types.signature -> signature + val of_signature_items : signature_item list -> signature + val of_signature_item : Types.signature_item -> signature_item + + val module_decl : scoping -> t -> module_decl -> module_decl + val modtype : scoping -> t -> modtype -> modtype + val modtype_decl : scoping -> t -> modtype_declaration -> modtype_declaration + val signature : scoping -> t -> signature -> signature + val signature_item : scoping -> t -> signature_item -> signature_item + + val force_module_decl : module_decl -> Types.module_declaration + val force_modtype : modtype -> Types.module_type + val force_modtype_decl : modtype_declaration -> Types.modtype_declaration + val force_signature : signature -> Types.signature + val force_signature_once : signature -> signature_item list + val force_signature_item : signature_item -> Types.signature_item +end diff --git a/upstream/ocaml_502/typing/tast_iterator.ml b/upstream/ocaml_502/typing/tast_iterator.ml new file mode 100644 index 0000000000..98a76c66b2 --- /dev/null +++ b/upstream/ocaml_502/typing/tast_iterator.ml @@ -0,0 +1,693 @@ +(**************************************************************************) +(* *) +(* 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 = + { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attributes -> unit; + 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; + location: iterator -> Location.t -> 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; + item_declaration: iterator -> item_declaration -> unit; + } + +let iter_snd f (_, y) = f y +let iter_loc sub {loc; _} = sub.location sub loc + +let location _sub _l = () + +let attribute sub x = + let iterator = { + Ast_iterator.default_iterator + with location = fun _this x -> sub.location sub x + } in + iter_loc sub x.Parsetree.attr_name; + iterator.payload iterator x.Parsetree.attr_payload; + sub.location sub x.Parsetree.attr_loc + +let attributes sub l = List.iter (attribute sub) l + +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 = + sub.location sub x.ci_loc; + sub.attributes sub x.ci_attributes; + iter_loc sub x.ci_id_name; + List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params; + f x.ci_expr + +let module_type_declaration sub x = + sub.item_declaration sub (Module_type x); + sub.location sub x.mtd_loc; + sub.attributes sub x.mtd_attributes; + iter_loc sub x.mtd_name; + Option.iter (sub.module_type sub) x.mtd_type + +let module_declaration sub md = + let {md_loc; md_name; md_type; md_attributes; _} = md in + sub.item_declaration sub (Module md); + sub.location sub md_loc; + sub.attributes sub md_attributes; + iter_loc sub md_name; + sub.module_type sub md_type + +let module_substitution sub ms = + let {ms_loc; ms_name; ms_txt; ms_attributes; _} = ms in + sub.item_declaration sub (Module_substitution ms); + sub.location sub ms_loc; + sub.attributes sub ms_attributes; + iter_loc sub ms_name; + iter_loc sub ms_txt + +let include_infos sub f {incl_loc; incl_mod; incl_attributes; _} = + sub.location sub incl_loc; + sub.attributes sub incl_attributes; + f incl_mod + +let class_type_declaration sub x = + sub.item_declaration sub (Class_type x); + class_infos sub (sub.class_type sub) x + +let class_declaration sub x = + sub.item_declaration sub (Class x); + class_infos sub (sub.class_expr sub) x + +let structure_item sub {str_loc; str_desc; str_env; _} = + sub.location sub str_loc; + sub.env sub str_env; + match str_desc with + | Tstr_eval (exp, attrs) -> sub.expr sub exp; sub.attributes sub attrs + | 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 (_, s, cltd) -> + iter_loc sub s; sub.class_type_declaration sub cltd) list + | Tstr_include incl -> include_infos sub (sub.module_expr sub) incl + | Tstr_open od -> sub.open_declaration sub od + | Tstr_attribute attr -> sub.attribute sub attr + +let value_description sub x = + sub.item_declaration sub (Value x); + sub.location sub x.val_loc; + sub.attributes sub x.val_attributes; + iter_loc sub x.val_name; + sub.typ sub x.val_desc + +let label_decl sub ({ld_loc; ld_name; ld_type; ld_attributes; _} as ld) = + sub.item_declaration sub (Label ld); + sub.location sub ld_loc; + sub.attributes sub ld_attributes; + iter_loc sub ld_name; + 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 x = + sub.item_declaration sub (Constructor x); + sub.location sub x.cd_loc; + sub.attributes sub x.cd_attributes; + iter_loc sub x.cd_name; + List.iter (iter_loc sub) x.cd_vars; + constructor_args sub x.cd_args; + Option.iter (sub.typ sub) x.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 x = + sub.item_declaration sub (Type x); + sub.location sub x.typ_loc; + sub.attributes sub x.typ_attributes; + iter_loc sub x.typ_name; + List.iter + (fun (c1, c2, loc) -> + sub.typ sub c1; + sub.typ sub c2; + sub.location sub loc) + x.typ_cstrs; + sub.type_kind sub x.typ_kind; + Option.iter (sub.typ sub) x.typ_manifest; + List.iter (fun (c, _) -> sub.typ sub c) x.typ_params + +let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list + +let type_extension sub x = + sub.location sub x.tyext_loc; + sub.attributes sub x.tyext_attributes; + iter_loc sub x.tyext_txt; + List.iter (fun (c, _) -> sub.typ sub c) x.tyext_params; + List.iter (sub.extension_constructor sub) x.tyext_constructors + +let type_exception sub {tyexn_loc; tyexn_constructor; tyexn_attributes; _} = + sub.location sub tyexn_loc; + sub.attributes sub tyexn_attributes; + sub.extension_constructor sub tyexn_constructor + +let extension_constructor sub ec = + let {ext_loc; ext_name; ext_kind; ext_attributes; _} = ec in + sub.item_declaration sub (Extension_constructor ec); + sub.location sub ext_loc; + sub.attributes sub ext_attributes; + iter_loc sub ext_name; + match ext_kind with + | Text_decl (ids, ctl, cto) -> + List.iter (iter_loc sub) ids; + constructor_args sub ctl; + Option.iter (sub.typ sub) cto + | Text_rebind (_, lid) -> iter_loc sub lid + +let pat_extra sub (e, loc, attrs) = + sub.location sub loc; + sub.attributes sub attrs; + match e with + | Tpat_type (_, lid) -> iter_loc sub lid + | Tpat_unpack -> () + | Tpat_open (_, lid, env) -> iter_loc sub lid; sub.env sub env + | Tpat_constraint ct -> sub.typ sub ct + +let pat + : type k . iterator -> k general_pattern -> unit + = fun sub {pat_loc; pat_extra=extra; pat_desc; pat_env; pat_attributes; _} -> + sub.location sub pat_loc; + sub.attributes sub pat_attributes; + sub.env sub pat_env; + List.iter (pat_extra sub) extra; + match pat_desc with + | Tpat_any -> () + | Tpat_var (_, s, _) -> iter_loc sub s + | Tpat_constant _ -> () + | Tpat_tuple l -> List.iter (sub.pat sub) l + | Tpat_construct (lid, _, l, vto) -> + iter_loc sub lid; + List.iter (sub.pat sub) l; + Option.iter (fun (ids, ct) -> + List.iter (iter_loc sub) ids; sub.typ sub ct) vto + | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po + | Tpat_record (l, _) -> + List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l + | Tpat_array l -> List.iter (sub.pat sub) l + | Tpat_alias (p, _, s, _) -> sub.pat sub p; iter_loc sub s + | 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 extra sub = 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 + +let function_param sub fp = + sub.location sub fp.fp_loc; + match fp.fp_kind with + | Tparam_pat pat -> sub.pat sub pat + | Tparam_optional_default (pat, default_arg) -> + sub.pat sub pat; + sub.expr sub default_arg + +let function_body sub body = + match[@warning "+9"] body with + | Tfunction_body body -> + sub.expr sub body + | Tfunction_cases + { cases; loc; exp_extra; attributes; partial = _; param = _ } + -> + List.iter (sub.case sub) cases; + sub.location sub loc; + Option.iter (extra sub) exp_extra; + sub.attributes sub attributes + +let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = + let extra x = extra sub x in + sub.location sub exp_loc; + sub.attributes sub exp_attributes; + List.iter (fun (e, loc, _) -> extra e; sub.location sub loc) exp_extra; + sub.env sub exp_env; + match exp_desc with + | Texp_ident (_, lid, _) -> iter_loc sub lid + | Texp_constant _ -> () + | Texp_let (rec_flag, list, exp) -> + sub.value_bindings sub (rec_flag, list); + sub.expr sub exp + | Texp_function (params, body) -> + List.iter (function_param sub) params; + function_body sub body + | 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 (lid, _, args) -> + iter_loc sub lid; + 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 (lid, exp) -> iter_loc sub lid; sub.expr sub exp) + fields; + Option.iter (sub.expr sub) extended_expression; + | Texp_field (exp, lid, _) -> + iter_loc sub lid; + sub.expr sub exp + | Texp_setfield (exp1, lid, _, exp2) -> + iter_loc sub lid; + 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, _) -> + sub.expr sub exp + | Texp_new (_, lid, _) -> iter_loc sub lid + | Texp_instvar (_, _, s) -> iter_loc sub s + | Texp_setinstvar (_, _, s, exp) -> + iter_loc sub s; + sub.expr sub exp + | Texp_override (_, list) -> + List.iter (fun (_, s, e) -> iter_loc sub s; sub.expr sub e) list + | Texp_letmodule (_, s, _, mexpr, exp) -> + iter_loc sub s; + 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 (lid, _) -> iter_loc sub lid + | Texp_open (od, e) -> + sub.open_declaration sub od; + sub.expr sub e + + +let package_type sub {pack_fields; pack_txt; _} = + List.iter (fun (lid, p) -> iter_loc sub lid; sub.typ sub p) pack_fields; + iter_loc sub pack_txt + +let binding_op sub {bop_loc; bop_op_name; bop_exp; _} = + sub.location sub bop_loc; + iter_loc sub bop_op_name; + 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_loc; sig_desc; sig_env; _} = + sub.location sub sig_loc; + 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 (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 = + sub.item_declaration sub (Class_type x); + class_infos sub (sub.class_type sub) x + +let functor_parameter sub = function + | Unit -> () + | Named (_, s, mtype) -> iter_loc sub s; sub.module_type sub mtype + +let module_type sub {mty_loc; mty_desc; mty_env; mty_attributes; _} = + sub.location sub mty_loc; + sub.attributes sub mty_attributes; + sub.env sub mty_env; + match mty_desc with + | Tmty_ident (_, lid) -> iter_loc sub lid + | Tmty_alias (_, lid) -> iter_loc sub lid + | 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 (_, lid, e) -> + iter_loc sub lid; 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 (_, lid) -> iter_loc sub lid + | Twith_modsubst (_, lid) -> iter_loc sub lid + | Twith_modtype mty -> sub.module_type sub mty + | Twith_modtypesubst mty -> sub.module_type sub mty + + +let open_description sub {open_loc; open_expr; open_env; open_attributes; _} = + sub.location sub open_loc; + sub.attributes sub open_attributes; + iter_snd (iter_loc sub) open_expr; + sub.env sub open_env + +let open_declaration sub {open_loc; open_expr; open_env; open_attributes; _} = + sub.location sub open_loc; + sub.attributes sub open_attributes; + 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_loc; pc_env; _} -> + sub.location sub pc_loc; + sub.env sub pc_env + +let module_expr sub {mod_loc; mod_desc; mod_env; mod_attributes; _} = + sub.location sub mod_loc; + sub.attributes sub mod_attributes; + sub.env sub mod_env; + match mod_desc with + | Tmod_ident (_, lid) -> iter_loc sub lid + | 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_apply_unit mexp1 -> + sub.module_expr sub mexp1; + | 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_loc; mb_name; mb_expr; mb_attributes; _} as mb) = + sub.item_declaration sub (Module_binding mb); + sub.location sub mb_loc; + sub.attributes sub mb_attributes; + iter_loc sub mb_name; + sub.module_expr sub mb_expr + +let class_expr sub {cl_loc; cl_desc; cl_env; cl_attributes; _} = + sub.location sub cl_loc; + sub.attributes sub cl_attributes; + 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 (_, lid, tyl) -> + iter_loc sub lid; + 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_loc; cltyp_desc; cltyp_env; cltyp_attributes; _} = + sub.location sub cltyp_loc; + sub.attributes sub cltyp_attributes; + sub.env sub cltyp_env; + match cltyp_desc with + | Tcty_signature csg -> sub.class_signature sub csg + | Tcty_constr (_, lid, list) -> + iter_loc sub lid; + 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_loc; ctf_desc; ctf_attributes; _} = + sub.location sub ctf_loc; + sub.attributes sub ctf_attributes; + 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 attr -> sub.attribute sub attr + +let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = + sub.location sub ctyp_loc; + sub.attributes sub ctyp_attributes; + 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 (_, lid, list) -> + iter_loc sub lid; + List.iter (sub.typ sub) list + | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list + | Ttyp_class (_, lid, list) -> + iter_loc sub lid; + 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 + | Ttyp_open (_, mod_ident, t) -> + iter_loc sub mod_ident; + sub.typ sub t + +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_loc; rf_desc; rf_attributes; _} = + sub.location sub rf_loc; + sub.attributes sub rf_attributes; + match rf_desc with + | Ttag (s, _, list) -> iter_loc sub s; List.iter (sub.typ sub) list + | Tinherit ct -> sub.typ sub ct + +let object_field sub {of_loc; of_desc; of_attributes; _} = + sub.location sub of_loc; + sub.attributes sub of_attributes; + match of_desc with + | OTtag (s, ct) -> iter_loc sub s; 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_loc; cf_desc; cf_attributes; _} = + sub.location sub cf_loc; + sub.attributes sub cf_attributes; + 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 (s, _, _, k, _) -> iter_loc sub s; class_field_kind sub k + | Tcf_method (s, _, k) -> iter_loc sub s;class_field_kind sub k + | Tcf_initializer exp -> sub.expr sub exp + | Tcf_attribute attr -> sub.attribute sub attr + +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_loc; vb_pat; vb_expr; vb_attributes; _} as vb) = + sub.item_declaration sub (Value_binding vb); + sub.location sub vb_loc; + sub.attributes sub vb_attributes; + sub.pat sub vb_pat; + sub.expr sub vb_expr + +let env _sub _ = () + +let item_declaration _sub _ = () + +let default_iterator = + { + attribute; + attributes; + 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; + location; + 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; + item_declaration; + } diff --git a/upstream/ocaml_502/typing/tast_iterator.mli b/upstream/ocaml_502/typing/tast_iterator.mli new file mode 100644 index 0000000000..38cd4eac94 --- /dev/null +++ b/upstream/ocaml_502/typing/tast_iterator.mli @@ -0,0 +1,72 @@ +(**************************************************************************) +(* *) +(* 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 = + { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attributes -> unit; + 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; + location: iterator -> Location.t -> 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; + item_declaration: iterator -> item_declaration -> unit; + } + +val default_iterator: iterator diff --git a/upstream/ocaml_502/typing/tast_mapper.ml b/upstream/ocaml_502/typing/tast_mapper.ml new file mode 100644 index 0000000000..ec416e3f60 --- /dev/null +++ b/upstream/ocaml_502/typing/tast_mapper.ml @@ -0,0 +1,909 @@ +(**************************************************************************) +(* *) +(* 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 extension, + include_declaration, include_description *) + +type mapper = + { + attribute : mapper -> attribute -> attribute; + attributes : mapper -> attributes -> attributes; + 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; + location: mapper -> Location.t -> Location.t; + 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 map_loc sub {loc; txt} = {loc=sub.location sub loc; txt} + +let location _sub l = l + +let attribute sub x = + let mapper = { + Ast_mapper.default_mapper + with location = fun _this x -> sub.location sub x + } in + Parsetree.{ + attr_name = map_loc sub x.attr_name; + attr_payload = mapper.payload mapper x.attr_payload; + attr_loc = sub.location sub x.attr_loc + } + +let attributes sub l = List.map (attribute sub) l + +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_loc = sub.location sub x.ci_loc; + ci_id_name = map_loc sub x.ci_id_name; + ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params; + ci_expr = f x.ci_expr; + ci_attributes = sub.attributes sub x.ci_attributes; + } + +let module_type_declaration sub x = + let mtd_loc = sub.location sub x.mtd_loc in + let mtd_name = map_loc sub x.mtd_name in + let mtd_type = Option.map (sub.module_type sub) x.mtd_type in + let mtd_attributes = sub.attributes sub x.mtd_attributes in + {x with mtd_loc; mtd_name; mtd_type; mtd_attributes} + +let module_declaration sub x = + let md_loc = sub.location sub x.md_loc in + let md_name = map_loc sub x.md_name in + let md_type = sub.module_type sub x.md_type in + let md_attributes = sub.attributes sub x.md_attributes in + {x with md_loc; md_name; md_type; md_attributes} + +let module_substitution sub x = + let ms_loc = sub.location sub x.ms_loc in + let ms_name = map_loc sub x.ms_name in + let ms_txt = map_loc sub x.ms_txt in + let ms_attributes = sub.attributes sub x.ms_attributes in + {x with ms_loc; ms_name; ms_txt; ms_attributes} + +let include_infos sub f x = + let incl_loc = sub.location sub x.incl_loc in + let incl_attributes = sub.attributes sub x.incl_attributes in + {x with incl_loc; incl_attributes; 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_loc; str_desc; str_env} = + let str_loc = sub.location sub str_loc in + 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, sub.attributes sub 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 (map_loc sub) (sub.class_type_declaration sub)) list) + | Tstr_include incl -> + Tstr_include (include_infos sub (sub.module_expr sub) incl) + | Tstr_open od -> Tstr_open (sub.open_declaration sub od) + | Tstr_attribute attr -> Tstr_attribute (sub.attribute sub attr) + in + {str_desc; str_env; str_loc} + +let value_description sub x = + let val_loc = sub.location sub x.val_loc in + let val_name = map_loc sub x.val_name in + let val_desc = sub.typ sub x.val_desc in + let val_attributes = sub.attributes sub x.val_attributes in + {x with val_loc; val_name; val_desc; val_attributes} + +let label_decl sub x = + let ld_loc = sub.location sub x.ld_loc in + let ld_name = map_loc sub x.ld_name in + let ld_type = sub.typ sub x.ld_type in + let ld_attributes = sub.attributes sub x.ld_attributes in + {x with ld_loc; ld_name; ld_type; ld_attributes} + +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_loc = sub.location sub cd.cd_loc in + let cd_name = map_loc sub cd.cd_name in + let cd_vars = List.map (map_loc sub) cd.cd_vars in + let cd_args = constructor_args sub cd.cd_args in + let cd_res = Option.map (sub.typ sub) cd.cd_res in + let cd_attributes = sub.attributes sub cd.cd_attributes in + {cd with cd_loc; cd_name; cd_vars; cd_args; cd_res; cd_attributes} + +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_loc = sub.location sub x.typ_loc in + let typ_name = map_loc sub x.typ_name in + let typ_cstrs = + List.map + (tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + 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 + let typ_attributes = sub.attributes sub x.typ_attributes in + {x with typ_loc; typ_name; typ_cstrs; typ_kind; typ_manifest; typ_params; + typ_attributes} + +let type_declarations sub (rec_flag, list) = + (rec_flag, List.map (sub.type_declaration sub) list) + +let type_extension sub x = + let tyext_loc = sub.location sub x.tyext_loc in + let tyext_txt = map_loc sub x.tyext_txt in + 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 + let tyext_attributes = sub.attributes sub x.tyext_attributes in + {x with tyext_loc; tyext_txt; tyext_constructors; tyext_params; + tyext_attributes} + +let type_exception sub x = + let tyexn_loc = sub.location sub x.tyexn_loc in + let tyexn_constructor = + sub.extension_constructor sub x.tyexn_constructor + in + let tyexn_attributes = sub.attributes sub x.tyexn_attributes in + {tyexn_loc; tyexn_constructor; tyexn_attributes} + +let extension_constructor sub x = + let ext_loc = sub.location sub x.ext_loc in + let ext_name = map_loc sub x.ext_name in + let ext_kind = + match x.ext_kind with + Text_decl(ids, ctl, cto) -> + Text_decl( + List.map (map_loc sub) ids, + constructor_args sub ctl, + Option.map (sub.typ sub) cto + ) + | Text_rebind (path, lid) -> + Text_rebind (path, map_loc sub lid) + in + let ext_attributes = sub.attributes sub x.ext_attributes in + {x with ext_loc; ext_name; ext_kind; ext_attributes} + +let pat_extra sub = function + | Tpat_unpack as d -> d + | Tpat_type (path,loc) -> Tpat_type (path, map_loc sub loc) + | Tpat_open (path,loc,env) -> + Tpat_open (path, map_loc sub 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_loc = sub.location sub x.pat_loc in + let pat_env = sub.env sub x.pat_env in + let pat_extra = + List.map (tuple3 (pat_extra sub) id (sub.attributes sub)) x.pat_extra in + let pat_desc : k pattern_desc = + match x.pat_desc with + | Tpat_any + | Tpat_constant _ -> x.pat_desc + | Tpat_var (id, s, uid) -> Tpat_var (id, map_loc sub s, uid) + | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) + | Tpat_construct (loc, cd, l, vto) -> + let vto = Option.map (fun (vl,cty) -> + List.map (map_loc sub) vl, sub.typ sub cty) vto in + Tpat_construct (map_loc sub 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 (map_loc sub) id (sub.pat sub)) l, closed) + | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) + | Tpat_alias (p, id, s, uid) -> + Tpat_alias (sub.pat sub p, id, map_loc sub s, uid) + | 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 + let pat_attributes = sub.attributes sub x.pat_attributes in + {x with pat_loc; pat_extra; pat_desc; pat_env; pat_attributes} + +let function_param sub fp = + let fp_kind = + match fp.fp_kind with + | Tparam_pat pat -> Tparam_pat (sub.pat sub pat) + | Tparam_optional_default (pat, expr) -> + let pat = sub.pat sub pat in + let expr = sub.expr sub expr in + Tparam_optional_default (pat, expr) + in + let fp_loc = sub.location sub fp.fp_loc in + { fp_kind; + fp_param = fp.fp_param; + fp_arg_label = fp.fp_arg_label; + fp_partial = fp.fp_partial; + fp_newtypes = fp.fp_newtypes; + fp_loc; + } + +let extra sub = 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) + +let function_body sub body = + match body with + | Tfunction_body body -> + Tfunction_body (sub.expr sub body) + | Tfunction_cases { cases; partial; param; loc; exp_extra; attributes } -> + let loc = sub.location sub loc in + let cases = List.map (sub.case sub) cases in + let exp_extra = Option.map (extra sub) exp_extra in + let attributes = sub.attributes sub attributes in + Tfunction_cases { cases; partial; param; loc; exp_extra; attributes } + +let expr sub x = + let extra x = extra sub x in + let exp_loc = sub.location sub x.exp_loc in + let exp_extra = List.map (tuple3 extra (sub.location sub) 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 (path, lid, vd) -> + Texp_ident (path, map_loc sub lid, vd) + | 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 (params, body) -> + let params = List.map (function_param sub) params in + let body = function_body sub body in + Texp_function (params, body) + | 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 (map_loc sub 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, mut) -> label, Kept (t, mut) + | label, Overridden (lid, exp) -> + label, Overridden (map_loc sub 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, map_loc sub lid, ld) + | Texp_setfield (exp1, lid, ld, exp2) -> + Texp_setfield ( + sub.expr sub exp1, + map_loc sub 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) -> + Texp_send + ( + sub.expr sub exp, + meth + ) + | Texp_new (path, lid, cd) -> + Texp_new ( + path, + map_loc sub lid, + cd + ) + | Texp_instvar (path1, path2, id) -> + Texp_instvar ( + path1, + path2, + map_loc sub id + ) + | Texp_setinstvar (path1, path2, id, exp) -> + Texp_setinstvar ( + path1, + path2, + map_loc sub id, + sub.expr sub exp + ) + | Texp_override (path, list) -> + Texp_override ( + path, + List.map (tuple3 id (map_loc sub) (sub.expr sub)) list + ) + | Texp_letmodule (id, s, pres, mexpr, exp) -> + Texp_letmodule ( + id, + map_loc sub 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, loc) -> + Texp_assert (sub.expr sub exp, loc) + | 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 (lid, path) -> + Texp_extension_constructor (map_loc sub lid, path) + | Texp_open (od, e) -> + Texp_open (sub.open_declaration sub od, sub.expr sub e) + in + let exp_attributes = sub.attributes sub x.exp_attributes in + {x with exp_loc; exp_extra; exp_desc; exp_env; exp_attributes} + + +let package_type sub x = + let pack_txt = map_loc sub x.pack_txt in + let pack_fields = List.map + (tuple2 (map_loc sub) (sub.typ sub)) x.pack_fields in + {x with pack_txt; pack_fields} + +let binding_op sub x = + let bop_loc = sub.location sub x.bop_loc in + let bop_op_name = map_loc sub x.bop_op_name in + { x with bop_loc; bop_op_name; 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_loc = sub.location sub x.sig_loc in + 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 (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 attr -> Tsig_attribute (sub.attribute sub attr) + in + {sig_loc; 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, map_loc sub s, sub.module_type sub mtype) + +let module_type sub x = + let mty_loc = sub.location sub x.mty_loc in + let mty_env = sub.env sub x.mty_env in + let mty_desc = + match x.mty_desc with + | Tmty_ident (path, lid) -> Tmty_ident (path, map_loc sub lid) + | Tmty_alias (path, lid) -> Tmty_alias (path, map_loc sub lid) + | 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 (map_loc sub) (sub.with_constraint sub)) list + ) + | Tmty_typeof mexpr -> + Tmty_typeof (sub.module_expr sub mexpr) + in + let mty_attributes = sub.attributes sub x.mty_attributes in + {x with mty_loc; mty_desc; mty_env; mty_attributes} + +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_modtype mty -> Twith_modtype (sub.module_type sub mty) + | Twith_modtypesubst mty -> Twith_modtypesubst (sub.module_type sub mty) + | Twith_module (path, lid) -> Twith_module (path, map_loc sub lid) + | Twith_modsubst (path, lid) -> Twith_modsubst (path, map_loc sub lid) + +let open_description sub od = + {od with open_loc = sub.location sub od.open_loc; + open_expr = tuple2 id (map_loc sub) od.open_expr; + open_env = sub.env sub od.open_env; + open_attributes = sub.attributes sub od.open_attributes} + +let open_declaration sub od = + {od with open_loc = sub.location sub od.open_loc; + open_expr = sub.module_expr sub od.open_expr; + open_env = sub.env sub od.open_env; + open_attributes = sub.attributes sub od.open_attributes} + +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_loc = sub.location sub pc.pc_loc; + pc_env = sub.env sub pc.pc_env} + +let module_expr sub x = + let mod_loc = sub.location sub x.mod_loc in + let mod_env = sub.env sub x.mod_env in + let mod_desc = + match x.mod_desc with + | Tmod_ident (path, lid) -> Tmod_ident (path, map_loc sub lid) + | 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_apply_unit mexp1 -> + Tmod_apply_unit (sub.module_expr sub mexp1) + | 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 + let mod_attributes = sub.attributes sub x.mod_attributes in + {x with mod_loc; mod_desc; mod_env; mod_attributes} + +let module_binding sub x = + let mb_loc = sub.location sub x.mb_loc in + let mb_name = map_loc sub x.mb_name in + let mb_expr = sub.module_expr sub x.mb_expr in + let mb_attributes = sub.attributes sub x.mb_attributes in + {x with mb_loc; mb_name; mb_expr; mb_attributes} + +let class_expr sub x = + let cl_loc = sub.location sub x.cl_loc in + 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, map_loc sub lid, List.map (sub.typ sub) tyl) + | Tcl_open (od, e) -> + Tcl_open (sub.open_description sub od, sub.class_expr sub e) + in + let cl_attributes = sub.attributes sub x.cl_attributes in + {x with cl_loc; cl_desc; cl_env; cl_attributes} + +let class_type sub x = + let cltyp_loc = sub.location sub x.cltyp_loc in + 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, + map_loc sub 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 + let cltyp_attributes = sub.attributes sub x.cltyp_attributes in + {x with cltyp_loc; cltyp_desc; cltyp_env; cltyp_attributes} + +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_loc = sub.location sub x.ctf_loc in + 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 attr -> + Tctf_attribute (sub.attribute sub attr) + in + let ctf_attributes = sub.attributes sub x.ctf_attributes in + {ctf_loc; ctf_desc; ctf_attributes} + +let typ sub x = + let ctyp_loc = sub.location sub x.ctyp_loc in + 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, map_loc sub 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, + map_loc sub 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) + | Ttyp_open (path, mod_ident, t) -> + Ttyp_open (path, map_loc sub mod_ident, sub.typ sub t) + in + let ctyp_attributes = sub.attributes sub x.ctyp_attributes in + {x with ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes} + +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_loc = sub.location sub x.rf_loc in + let rf_desc = match x.rf_desc with + | Ttag (label, b, list) -> + Ttag (map_loc sub label, b, List.map (sub.typ sub) list) + | Tinherit ct -> Tinherit (sub.typ sub ct) + in + let rf_attributes = sub.attributes sub x.rf_attributes in + {rf_loc; rf_desc; rf_attributes} + +let object_field sub x = + let of_loc = sub.location sub x.of_loc in + let of_desc = match x.of_desc with + | OTtag (label, ct) -> + OTtag (map_loc sub label, (sub.typ sub ct)) + | OTinherit ct -> OTinherit (sub.typ sub ct) + in + let of_attributes = sub.attributes sub x.of_attributes in + {of_loc; of_desc; of_attributes} + +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_loc = sub.location sub x.cf_loc in + 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 (map_loc sub s, mf, id, class_field_kind sub k, b) + | Tcf_method (s, priv, k) -> + Tcf_method (map_loc sub s, priv, class_field_kind sub k) + | Tcf_initializer exp -> + Tcf_initializer (sub.expr sub exp) + | Tcf_attribute attr -> + Tcf_attribute (sub.attribute sub attr) + in + let cf_attributes = sub.attributes sub x.cf_attributes in + {cf_loc; cf_desc; cf_attributes} + +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_loc = sub.location sub x.vb_loc in + let vb_pat = sub.pat sub x.vb_pat in + let vb_expr = sub.expr sub x.vb_expr in + let vb_attributes = sub.attributes sub x.vb_attributes in + let vb_rec_kind = x.vb_rec_kind in + {vb_loc; vb_pat; vb_expr; vb_attributes; vb_rec_kind} + +let env _sub x = x + +let default = + { + attribute; + attributes; + 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; + location; + 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_502/typing/tast_mapper.mli b/upstream/ocaml_502/typing/tast_mapper.mli new file mode 100644 index 0000000000..f54cef2b06 --- /dev/null +++ b/upstream/ocaml_502/typing/tast_mapper.mli @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* 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 = + { + attribute : mapper -> attribute -> attribute; + attributes : mapper -> attributes -> attributes; + 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; + location: mapper -> Location.t -> Location.t; + 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_502/typing/type_immediacy.ml b/upstream/ocaml_502/typing/type_immediacy.ml new file mode 100644 index 0000000000..557ed4271a --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/type_immediacy.mli b/upstream/ocaml_502/typing/type_immediacy.mli new file mode 100644 index 0000000000..3fc2e3b4f9 --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/typeclass.ml b/upstream/ocaml_502/typing/typeclass.ml new file mode 100644 index 0000000000..90301394f2 --- /dev/null +++ b/upstream/ocaml_502/typing/typeclass.ml @@ -0,0 +1,2208 @@ +(**************************************************************************) +(* *) +(* 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_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_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; + arity: int; + pub_meths: string list; + coe: Warnings.loc list; + req: 'a Typedtree.class_infos; +} + +type kind = + | Object + | Class + | Class_type + +type final = + | Final + | Not_final + +let kind_of_final = function + | Final -> Object + | Not_final -> Class + +type error = + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string + | 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_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of Errortrace.unification_error + | Bad_parameters of Ident.t * type_expr list * type_expr list + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list + | 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 + { id : Ident.t + ; clty : Types.class_declaration + ; nongen_vars : type_expr list + } + | Cannot_coerce_self of type_expr + | Non_collapsable_conjunction of + Ident.t * Types.class_declaration * Errortrace.unification_error + | Self_clash of Errortrace.unification_error + | Mutability_mismatch of string * mutable_flag + | No_overriding of string * string + | Duplicate of string * string + | Closing_self_type of class_signature + +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 = [] } + +(* + 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 *) + (************************************) + +let extract_constraints cty = + let sign = Btype.signature_of_class_type cty in + (Btype.instance_vars sign, + Btype.methods sign, + Btype.concrete_methods sign) + +(* Record a class type *) +let rc node = + Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); + node + +let update_class_signature loc env ~warn_implicit_public virt kind sign = + let implicit_public, implicit_declared = + Ctype.update_class_signature env sign + in + if implicit_declared <> [] then begin + match virt with + | Virtual -> () (* Should perhaps emit warning 17 here *) + | Concrete -> + raise (Error(loc, env, Undeclared_methods(kind, implicit_declared))) + end; + if warn_implicit_public && implicit_public <> [] then begin + Location.prerr_warning + loc (Warnings.Implicit_public_methods implicit_public) + end + +let complete_class_signature loc env virt kind sign = + update_class_signature loc env ~warn_implicit_public:false virt kind sign; + Ctype.hide_private_methods env sign + +let complete_class_type loc env virt kind typ = + let sign = Btype.signature_of_class_type typ in + complete_class_signature loc env virt kind sign + +let check_virtual loc env virt kind sign = + match virt with + | Virtual -> () + | Concrete -> + match Btype.virtual_methods sign, Btype.virtual_instance_vars sign with + | [], [] -> () + | meths, vars -> + raise(Error(loc, env, Virtual_class(kind, meths, vars))) + +let rec check_virtual_clty loc env virt kind clty = + match clty with + | Cty_constr(_, _, clty) | Cty_arrow(_, _, clty) -> + check_virtual_clty loc env virt kind clty + | Cty_signature sign -> + check_virtual loc env virt kind sign + +(* 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, commu_ok)) + + (***********************************) + (* Primitives for typing classes *) + (***********************************) + +let raise_add_method_failure loc env label sign failure = + match (failure : Ctype.add_method_failure) with + | Ctype.Unexpected_method -> + raise(Error(loc, env, Unexpected_field (sign.Types.csig_self, label))) + | Ctype.Type_mismatch trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +let raise_add_instance_variable_failure loc env label failure = + match (failure : Ctype.add_instance_variable_failure) with + | Ctype.Mutability_mismatch mut -> + raise (Error(loc, env, Mutability_mismatch(label, mut))) + | Ctype.Type_mismatch trace -> + raise (Error(loc, env, + Field_type_mismatch("instance variable", label, trace))) + +let raise_inherit_class_signature_failure loc env sign = function + | Ctype.Self_type_mismatch trace -> + raise(Error(loc, env, Self_clash trace)) + | Ctype.Method(label, failure) -> + raise_add_method_failure loc env label sign failure + | Ctype.Instance_variable(label, failure) -> + raise_add_instance_variable_failure loc env label failure + +let add_method loc env label priv virt ty sign = + match Ctype.add_method env label priv virt ty sign with + | () -> () + | exception Ctype.Add_method_failed failure -> + raise_add_method_failure loc env label sign failure + +let add_instance_variable ~strict loc env label mut virt ty sign = + match Ctype.add_instance_variable ~strict env label mut virt ty sign with + | () -> () + | exception Ctype.Add_instance_variable_failed failure -> + raise_add_instance_variable_failure loc env label failure + +let inherit_class_signature ~strict loc env sign1 sign2 = + match Ctype.inherit_class_signature ~strict env sign1 sign2 with + | () -> () + | exception Ctype.Inherit_class_signature_failed failure -> + raise_inherit_class_signature_failure loc env sign1 failure + +let inherit_class_type ~strict loc env sign1 cty2 = + let sign2 = + match Btype.scrape_class_type cty2 with + | Cty_signature sign2 -> sign2 + | _ -> + raise(Error(loc, env, Structure_expected cty2)) + in + inherit_class_signature ~strict loc env sign1 sign2 + +let unify_delayed_method_type loc env label ty expected_ty= + match Ctype.unify env ty expected_ty with + | () -> () + | exception Ctype.Unify trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +let type_constraint val_env sty sty' loc = + let cty = transl_simple_type val_env ~closed:false sty in + let ty = cty.ctyp_type in + let cty' = transl_simple_type val_env ~closed:false sty' in + let ty' = cty'.ctyp_type in + begin + try Ctype.unify val_env ty ty' with Ctype.Unify err -> + raise(Error(loc, val_env, Unconsistent_constraint err)); + end; + (cty, cty') + +let make_method loc cl_num expr = + let open Ast_helper in + let mkid s = mkloc s loc in + let pat = + Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)) + in + Exp.function_ ~loc:expr.pexp_loc + [ { pparam_desc = Pparam_val (Nolabel, None, pat); + pparam_loc = pat.ppat_loc; + } + ] + None (Pfunction_body expr) + +(*******************************) + +let delayed_meth_specs = ref [] + +let rec class_type_field env sign self_scope ctf = + let loc = ctf.pctf_loc in + let mkctf desc = + { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } + in + let mkctf_with_attrs f = + Builtin_attributes.warning_scope ctf.pctf_attributes + (fun () -> mkctf (f ())) + in + match ctf.pctf_desc with + | Pctf_inherit sparent -> + mkctf_with_attrs + (fun () -> + let parent = class_type env Virtual self_scope sparent in + complete_class_type parent.cltyp_loc + env Virtual Class_type parent.cltyp_type; + inherit_class_type ~strict:false loc env sign parent.cltyp_type; + Tctf_inherit parent) + | Pctf_val ({txt=lab}, mut, virt, sty) -> + mkctf_with_attrs + (fun () -> + let cty = transl_simple_type env ~closed:false sty in + let ty = cty.ctyp_type in + add_instance_variable ~strict:false loc env lab mut virt ty sign; + Tctf_val (lab, mut, virt, cty)) + + | Pctf_method ({txt=lab}, priv, virt, sty) -> + mkctf_with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + match sty.ptyp_desc, priv with + | Ptyp_poly ([],sty'), Public -> + let expected_ty = Ctype.newvar () in + add_method loc env lab priv virt expected_ty sign; + let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) env loc in + delayed_meth_specs := + Warnings.mk_lazy (fun () -> + let cty = transl_simple_type_univars env sty' in + let ty = cty.ctyp_type in + unify_delayed_method_type loc env lab ty expected_ty; + returned_cty.ctyp_desc <- Ttyp_poly ([], cty); + returned_cty.ctyp_type <- ty; + ) :: !delayed_meth_specs; + Tctf_method (lab, priv, virt, returned_cty) + | _ -> + let cty = transl_simple_type env ~closed:false sty in + let ty = cty.ctyp_type in + add_method loc env lab priv virt ty sign; + Tctf_method (lab, priv, virt, cty)) + + | Pctf_constraint (sty, sty') -> + mkctf_with_attrs + (fun () -> + let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in + Tctf_constraint (cty, cty')) + + | Pctf_attribute x -> + Builtin_attributes.warning_attribute x; + mkctf (Tctf_attribute x) + + | Pctf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_signature virt env pcsig self_scope loc = + let {pcsig_self=sty; pcsig_fields=psign} = pcsig in + let sign = Ctype.new_class_signature () in + (* Introduce a dummy method preventing self type from being closed. *) + Ctype.add_dummy_method env ~scope:self_scope sign; + + let self_cty = transl_simple_type env ~closed:false sty in + let self_type = self_cty.ctyp_type in + begin try + Ctype.unify env self_type sign.csig_self + with Ctype.Unify _ -> + raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type)) + end; + + (* Class type fields *) + let fields = + Builtin_attributes.warning_scope [] + (fun () -> List.map (class_type_field env sign self_scope) psign) + in + check_virtual loc env virt Class_type sign; + { csig_self = self_cty; + csig_fields = fields; + csig_type = sign; } + +and class_type env virt self_scope scty = + Builtin_attributes.warning_scope scty.pcty_attributes + (fun () -> class_type_aux env virt self_scope scty) + +and class_type_aux env virt self_scope 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 + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method env ~scope:self_scope + (Btype.signature_of_class_type clty); + 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 ~closed:false sty in + let ty' = cty'.ctyp_type in + begin + try Ctype.unify env ty' ty with Ctype.Unify err -> + raise(Error(sty.ptyp_loc, env, Parameter_mismatch err)) + end; + cty' + ) styl params + in + let typ = Cty_constr (path, params, clty) in + (* Check for unexpected virtual methods *) + check_virtual_clty scty.pcty_loc env virt Class_type typ; + cltyp (Tcty_constr ( path, lid , ctys)) typ + + | Pcty_signature pcsig -> + let clsig = class_signature virt env pcsig self_scope scty.pcty_loc 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 ~closed: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 virt self_scope 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 virt self_scope 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 virt self_scope scty = + delayed_meth_specs := []; + let cty = class_type env virt self_scope scty in + List.iter Lazy.force (List.rev !delayed_meth_specs); + delayed_meth_specs := []; + cty + +(*******************************) + +let enter_ancestor_val name val_env = + Env.enter_unbound_value name Val_unbound_ancestor val_env + +let enter_self_val name val_env = + Env.enter_unbound_value name Val_unbound_self val_env + +let enter_instance_var_val name val_env = + Env.enter_unbound_value name Val_unbound_instance_variable val_env + +let enter_ancestor_met ~loc name ~sign ~meths ~cl_num ~ty ~attrs met_env = + let check s = Warnings.Unused_ancestor s in + let kind = Val_anc (sign, meths, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.enter_value ~check name desc met_env + +let add_self_met loc id sign self_var_kind vars cl_num + as_var ty attrs met_env = + let check = + if as_var then (fun s -> Warnings.Unused_var s) + else (fun s -> Warnings.Unused_var_strict s) + in + let kind = Val_self (sign, self_var_kind, vars, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.add_value ~check id desc met_env + +let add_instance_var_met loc label id sign cl_num attrs met_env = + let mut, ty = + match Vars.find label sign.csig_vars with + | (mut, _, ty) -> mut, ty + | exception Not_found -> assert false + in + let kind = Val_ivar (mut, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.add_value id desc met_env + +let add_instance_vars_met loc vars sign cl_num met_env = + List.fold_left + (fun met_env (label, id) -> + add_instance_var_met loc label id sign cl_num [] met_env) + met_env vars + +type intermediate_class_field = + | Inherit of + { override : override_flag; + parent : class_expr; + super : string option; + inherited_vars : (string * Ident.t) list; + super_meths : (string * Ident.t) list; + loc : Location.t; + attributes : attribute list; } + | Virtual_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + cty : core_type; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Concrete_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + override : override_flag; + definition : expression; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Virtual_method of + { label : string loc; + priv : private_flag; + cty : core_type; + loc : Location.t; + attributes : attribute list; } + | Concrete_method of + { label : string loc; + priv : private_flag; + override : override_flag; + sdefinition : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Constraint of + { cty1 : core_type; + cty2 : core_type; + loc : Location.t; + attributes : attribute list; } + | Initializer of + { sexpr : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Attribute of + { attribute : attribute; + loc : Location.t; + attributes : attribute list; } + +type first_pass_accummulater = + { rev_fields : intermediate_class_field list; + val_env : Env.t; + par_env : Env.t; + concrete_meths : MethSet.t; + concrete_vals : VarSet.t; + local_meths : MethSet.t; + local_vals : VarSet.t; + vars : Ident.t Vars.t; } + +let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = + let { rev_fields; val_env; par_env; concrete_meths; concrete_vals; + local_meths; local_vals; vars } = acc + in + let loc = cf.pcf_loc in + let attributes = cf.pcf_attributes in + let with_attrs f = Builtin_attributes.warning_scope attributes f in + match cf.pcf_desc with + | Pcf_inherit (override, sparent, super) -> + with_attrs + (fun () -> + let parent = + class_expr cl_num val_env par_env + Virtual self_scope sparent + in + complete_class_type parent.cl_loc + par_env Virtual Class parent.cl_type; + inherit_class_type ~strict:true loc val_env sign parent.cl_type; + let parent_sign = Btype.signature_of_class_type parent.cl_type in + let new_concrete_meths = Btype.concrete_methods parent_sign in + let new_concrete_vals = Btype.concrete_instance_vars parent_sign in + let over_meths = MethSet.inter new_concrete_meths concrete_meths in + let over_vals = VarSet.inter new_concrete_vals concrete_vals in + begin match override with + | Fresh -> + let cname = + match parent.cl_type with + | Cty_constr (p, _, _) -> Path.name p + | _ -> "inherited" + in + if not (MethSet.is_empty over_meths) then + Location.prerr_warning loc + (Warnings.Method_override + (cname :: MethSet.elements over_meths)); + if not (VarSet.is_empty over_vals) then + Location.prerr_warning loc + (Warnings.Instance_variable_override + (cname :: VarSet.elements over_vals)); + | Override -> + if MethSet.is_empty over_meths && VarSet.is_empty over_vals then + raise (Error(loc, val_env, No_overriding ("",""))) + end; + let concrete_vals = VarSet.union new_concrete_vals concrete_vals in + let concrete_meths = + MethSet.union new_concrete_meths concrete_meths + in + let val_env, par_env, inherited_vars, vars = + Vars.fold + (fun label _ (val_env, par_env, inherited_vars, vars) -> + let val_env = enter_instance_var_val label val_env in + let par_env = enter_instance_var_val label par_env in + let id = Ident.create_local label in + let inherited_vars = (label, id) :: inherited_vars in + let vars = Vars.add label id vars in + (val_env, par_env, inherited_vars, vars)) + parent_sign.csig_vars (val_env, par_env, [], vars) + in + (* Methods available through super *) + let super_meths = + MethSet.fold + (fun label acc -> (label, Ident.create_local label) :: acc) + new_concrete_meths [] + in + (* Super *) + let (val_env, par_env, super) = + match super with + | None -> (val_env, par_env, None) + | Some {txt=name} -> + let val_env = enter_ancestor_val name val_env in + let par_env = enter_ancestor_val name par_env in + (val_env, par_env, Some name) + in + let field = + Inherit + { override; parent; super; inherited_vars; + super_meths; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; + concrete_meths; concrete_vals; vars }) + | Pcf_val (label, mut, Cfk_virtual styp) -> + with_attrs + (fun () -> + let cty = + Ctype.with_local_level_if_principal + (fun () -> Typetexp.transl_simple_type val_env + ~closed:false styp) + ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type) + in + add_instance_variable ~strict:true loc val_env + label.txt mut Virtual cty.ctyp_type sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Virtual_val + { label; mut; id; cty; already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; vars }) + | Pcf_val (label, mut, Cfk_concrete (override, sdefinition)) -> + with_attrs + (fun () -> + if VarSet.mem label.txt local_vals then + raise(Error(loc, val_env, + Duplicate ("instance variable", label.txt))); + if VarSet.mem label.txt concrete_vals then begin + if override = Fresh then + Location.prerr_warning label.loc + (Warnings.Instance_variable_override[label.txt]) + end else begin + if override = Override then + raise(Error(loc, val_env, + No_overriding ("instance variable", label.txt))) + end; + let definition = + Ctype.with_local_level_if_principal + ~post:Typecore.generalize_structure_exp + (fun () -> type_exp val_env sdefinition) + in + add_instance_variable ~strict:true loc val_env + label.txt mut Concrete definition.exp_type sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Concrete_val + { label; mut; id; override; definition; + already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_vals = VarSet.add label.txt concrete_vals in + let local_vals = VarSet.add label.txt local_vals in + { acc with rev_fields; val_env; par_env; + concrete_vals; local_vals; vars }) + + | Pcf_method (label, priv, Cfk_virtual sty) -> + with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = transl_simple_type val_env ~closed:false sty in + let ty = cty.ctyp_type in + add_method loc val_env label.txt priv Virtual ty sign; + let field = + Virtual_method { label; priv; cty; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_method (label, priv, Cfk_concrete (override, expr)) -> + with_attrs + (fun () -> + if MethSet.mem label.txt local_meths then + raise(Error(loc, val_env, Duplicate ("method", label.txt))); + if MethSet.mem label.txt concrete_meths then begin + if override = Fresh then begin + Location.prerr_warning loc + (Warnings.Method_override [label.txt]) + end + end else begin + if override = Override then begin + raise(Error(loc, val_env, No_overriding("method", label.txt))) + end + end; + let expr = + match expr.pexp_desc with + | Pexp_poly _ -> expr + | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None + in + let sbody, sty = + match expr.pexp_desc with + | Pexp_poly (sbody, sty) -> sbody, sty + | _ -> assert false + in + let ty = + match sty with + | None -> Ctype.newvar () + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty' = + Typetexp.transl_simple_type val_env ~closed:false sty + in + cty'.ctyp_type + in + add_method loc val_env label.txt priv Concrete ty sign; + begin + try + match get_desc ty 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 ~fixed:false tl ty1 in + let ty2 = type_approx val_env sbody in + Ctype.unify val_env ty2 ty1' + | _ -> assert false + with Ctype.Unify err -> + raise(Error(loc, val_env, + Field_type_mismatch ("method", label.txt, err))) + end; + let sdefinition = make_method self_loc cl_num expr in + let warning_state = Warnings.backup () in + let field = + Concrete_method + { label; priv; override; sdefinition; + warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_meths = MethSet.add label.txt concrete_meths in + let local_meths = MethSet.add label.txt local_meths in + { acc with rev_fields; concrete_meths; local_meths }) + + | Pcf_constraint (sty1, sty2) -> + with_attrs + (fun () -> + let (cty1, cty2) = type_constraint val_env sty1 sty2 loc in + let field = + Constraint { cty1; cty2; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_initializer sexpr -> + with_attrs + (fun () -> + let sexpr = make_method self_loc cl_num sexpr in + let warning_state = Warnings.backup () in + let field = + Initializer { sexpr; warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + | Pcf_attribute attribute -> + Builtin_attributes.warning_attribute attribute; + let field = Attribute { attribute; loc; attributes } in + let rev_fields = field :: rev_fields in + { acc with rev_fields } + | Pcf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env cfs = + let rev_fields = [] in + let concrete_meths = MethSet.empty in + let concrete_vals = VarSet.empty in + let local_meths = MethSet.empty in + let local_vals = VarSet.empty in + let vars = Vars.empty in + let init_acc = + { rev_fields; val_env; par_env; + concrete_meths; concrete_vals; + local_meths; local_vals; vars } + in + let acc = + Builtin_attributes.warning_scope [] + (fun () -> + List.fold_left + (class_field_first_pass self_loc cl_num sign self_scope) + init_acc cfs) + in + List.rev acc.rev_fields, acc.vars + +and class_field_second_pass cl_num sign met_env field = + let mkcf desc loc attrs = + { cf_desc = desc; cf_loc = loc; cf_attributes = attrs } + in + match field with + | Inherit { override; parent; super; + inherited_vars; super_meths; loc; attributes } -> + let met_env = + add_instance_vars_met loc inherited_vars sign cl_num met_env + in + let met_env = + match super with + | None -> met_env + | Some name -> + let meths = + List.fold_left + (fun acc (label, id) -> Meths.add label id acc) + Meths.empty super_meths + in + let ty = Btype.self_type parent.cl_type in + let attrs = [] in + let _id, met_env = + enter_ancestor_met ~loc name ~sign ~meths + ~cl_num ~ty ~attrs met_env + in + met_env + in + let desc = + Tcf_inherit(override, parent, super, inherited_vars, super_meths) + in + met_env, mkcf desc loc attributes + | Virtual_val { label; mut; id; cty; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end + in + let kind = Tcfk_virtual cty in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Concrete_val { label; mut; id; override; + definition; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end + in + let kind = Tcfk_concrete(override, definition) in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Virtual_method { label; priv; cty; loc; attributes } -> + let kind = Tcfk_virtual cty in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes + | Concrete_method { label; priv; override; + sdefinition; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + let ty = Btype.method_type label.txt sign in + let self_type = sign.Types.csig_self in + let meth_type = + mk_expected + (Btype.newgenty (Tarrow(Nolabel, self_type, ty, commu_ok))) + in + let texp = + Ctype.with_raised_nongen_level + (fun () -> type_expect met_env sdefinition meth_type) in + let kind = Tcfk_concrete (override, texp) in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes) + | Constraint { cty1; cty2; loc; attributes } -> + let desc = Tcf_constraint(cty1, cty2) in + met_env, mkcf desc loc attributes + | Initializer { sexpr; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + let unit_type = Ctype.instance Predef.type_unit in + let self_type = sign.Types.csig_self in + let meth_type = + mk_expected + (Ctype.newty (Tarrow (Nolabel, self_type, unit_type, commu_ok))) + in + let texp = + Ctype.with_raised_nongen_level + (fun () -> type_expect met_env sexpr meth_type) in + let desc = Tcf_initializer texp in + met_env, mkcf desc loc attributes) + | Attribute { attribute; loc; attributes; } -> + let desc = Tcf_attribute attribute in + met_env, mkcf desc loc attributes + +and class_fields_second_pass cl_num sign met_env fields = + let _, rev_cfs = + List.fold_left + (fun (met_env, cfs) field -> + let met_env, cf = + class_field_second_pass cl_num sign met_env field + in + met_env, cf :: cfs) + (met_env, []) fields + in + List.rev rev_cfs + +(* 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 virt self_scope 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 sign = Ctype.new_class_signature () in + + (* Adding a dummy method to the signature prevents it from being closed / + escaping. That isn't needed for objects though. *) + begin match final with + | Not_final -> Ctype.add_dummy_method val_env ~scope:self_scope sign; + | Final -> () + end; + + (* Self binder *) + let (self_pat, self_pat_vars) = type_self_pattern val_env spat in + let val_env, par_env = + List.fold_right + (fun {pv_id; _} (val_env, par_env) -> + let name = Ident.name pv_id in + let val_env = enter_self_val name val_env in + let par_env = enter_self_val name par_env in + val_env, par_env) + self_pat_vars (val_env, par_env) + in + + (* Check that the binder has a correct type *) + begin try Ctype.unify val_env self_pat.pat_type sign.csig_self with + Ctype.Unify _ -> + raise(Error(spat.ppat_loc, val_env, + Pattern_type_clash self_pat.pat_type)) + end; + + (* Typing of class fields *) + let (fields, vars) = + class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env str + in + let kind = kind_of_final final in + + (* Check for unexpected virtual methods *) + check_virtual loc val_env virt kind sign; + + (* Update the class signature *) + update_class_signature loc val_env + ~warn_implicit_public:false virt kind sign; + + let meths = + Meths.fold + (fun label _ meths -> + Meths.add label (Ident.create_local label) meths) + sign.csig_meths Meths.empty + in + + (* Close the signature if it is final *) + begin match final with + | Not_final -> () + | Final -> + if not (Ctype.close_class_signature val_env sign) then + raise(Error(loc, val_env, Closing_self_type sign)); + end; + (* Typing of method bodies *) + Ctype.generalize_class_signature_spine val_env sign; + let self_var_kind = + match virt with + | Virtual -> Self_virtual(ref meths) + | Concrete -> Self_concrete meths + in + let met_env = + List.fold_right + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} met_env -> + add_self_met pv_loc pv_id sign self_var_kind vars + cl_num pv_as_var pv_type pv_attributes met_env) + self_pat_vars met_env + in + let fields = + class_fields_second_pass cl_num sign met_env fields + in + + (* Update the class signature and warn about public methods made private *) + update_class_signature loc val_env + ~warn_implicit_public:true virt kind sign; + + let meths = + match self_var_kind with + | Self_virtual meths_ref -> !meths_ref + | Self_concrete meths -> meths + in + { cstr_self = self_pat; + cstr_fields = fields; + cstr_type = sign; + cstr_meths = meths; } + +and class_expr cl_num val_env met_env virt self_scope scl = + Builtin_attributes.warning_scope scl.pcl_attributes + (fun () -> class_expr_aux cl_num val_env met_env virt self_scope scl) + +and class_expr_aux cl_num val_env met_env virt self_scope 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 ~closed:false sty) + styl + in + let (params, clty) = + Ctype.instance_class decl.cty_params decl.cty_type + in + let clty' = Btype.abbreviate_class_type path params clty in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type clty'); + 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 err -> + raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch err))) + tyl params; + (* Check for unexpected virtual methods *) + check_virtual_clty scl.pcl_loc val_env virt Class clty'; + 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 = + class_structure cl_num virt self_scope Not_final + 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 desc.cstr_type; + 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 virt self_scope sfun + | Pcl_fun (l, None, spat, scl') -> + let (pat, pv, val_env', met_env) = + Ctype.with_local_level_if_principal + (fun () -> + Typecore.type_class_arg_pattern cl_num val_env met_env l spat) + ~post: begin fun (pat, _, _, _) -> + let gen {pat_type = ty} = Ctype.generalize_structure ty in + iter_pattern gen pat + end + in + 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 + let cl = + Ctype.with_raised_nongen_level + (fun () -> class_expr cl_num val_env' met_env virt self_scope scl') in + 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 <> []); + let cl = + Ctype.with_local_level_if_principal + (fun () -> class_expr cl_num val_env met_env virt self_scope scl') + ~post:(fun cl -> Ctype.generalize_class_type_structure cl.cl_type) + in + 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, _uid) (vals, met_env) -> + let path = Pident id in + (* do not mark the value as used *) + let vd = Env.find_value path val_env in + let ty = + Ctype.with_local_level ~post:Ctype.generalize + (fun () -> Ctype.instance vd.val_type) + in + let expr = + {exp_desc = + Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd); + exp_loc = Location.none; exp_extra = []; + exp_type = ty; + exp_attributes = []; + exp_env = val_env; + } + in + 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 virt self_scope scl' in + let defs = match rec_flag with + | Recursive -> annotate_recursive_bindings val_env defs + | Nonrecursive -> 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) -> + let cl, clty = + Ctype.with_local_level_for_class begin fun () -> + let cl = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let cl = class_expr cl_num val_env met_env virt self_scope scl' in + complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type; + cl + end + and clty = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let clty = class_type val_env virt self_scope scty in + complete_class_type + clty.cltyp_loc val_env virt Class clty.cltyp_type; + clty + end + in + cl, clty + end + ~post: begin fun ({cl_type=cl}, {cltyp_type=clty}) -> + Ctype.limited_generalize_class_type (Btype.self_type_row cl) cl; + Ctype.limited_generalize_class_type (Btype.self_type_row clty) clty; + end + in + 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 + let ty = snd (Ctype.instance_class [] clty.cltyp_type) in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type ty); + rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); + cl_loc = scl.pcl_loc; + cl_type = ty; + 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 virt self_scope 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, commu_ok)) + | 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, commu_ok)) + | _ -> Ctype.newvar () + +(*******************************) + +let temp_abbrev loc 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 ty_td = + {type_params = !params; + type_arity = arity; + type_kind = Type_abstract Definition; + 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; + } + in + (!params, ty, ty_td) + +let initial_env define_class approx + (res, env) (cl, id, ty_id, obj_id, uid) = + (* Temporary abbreviations *) + let arity = List.length cl.pci_params in + let (obj_params, obj_ty, obj_td) = temp_abbrev cl.pci_loc arity uid in + let env = Env.add_type ~check:true obj_id obj_td env in + let (cl_params, cl_ty, cl_td) = temp_abbrev cl.pci_loc arity uid in + + (* Temporary type for the class constructor *) + let constr_type = + Ctype.with_local_level_if_principal (fun () -> approx cl.pci_expr) + ~post:Ctype.generalize_structure + in + let dummy_cty = Cty_signature (Ctype.new_class_signature ()) 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_hash_type = cl_td; (* Dummy value *) + 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_params, cl_ty, cl_td, + constr_type, + dummy_class)::res, + env) + +let class_infos define_class kind + (cl, id, ty_id, + obj_id, obj_params, obj_ty, + cl_params, cl_ty, cl_td, + constr_type, + dummy_class) + (res, env) = + + let ci_params, params, coercion_locs, expr, typ, sign = + Ctype.with_local_level_for_class begin fun () -> + TyVarEnv.reset (); + (* 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_virt cl.pci_expr in + Typecore.self_coercion := List.tl !Typecore.self_coercion; + res + with exn -> + Typecore.self_coercion := []; raise exn + in + let sign = Btype.signature_of_class_type typ in + (ci_params, params, coercion_locs, expr, typ, sign) + end + ~post: begin fun (_, params, _, _, typ, sign) -> + (* Generalize the row variable *) + List.iter (Ctype.limited_generalize sign.csig_self_row) params; + Ctype.limited_generalize_class_type sign.csig_self_row typ; + end + in + (* 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 row = Btype.self_type_row obj_type in + Ctype.unify env row (Ctype.newty Tnil); + begin try + List.iter2 (Ctype.unify env) obj_params obj_params' + with Ctype.Unify _ -> + raise(Error(cl.pci_loc, env, + Bad_parameters (obj_id, obj_params, obj_params'))) + end; + let ty = Btype.self_type obj_type in + 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; + + Ctype.set_object_name obj_id params (Btype.self_type typ); + + (* Check the other temporary abbreviation (#-type) *) + begin + let (cl_params', cl_type) = Ctype.instance_class params typ in + let ty = Btype.self_type cl_type in + begin try + List.iter2 (Ctype.unify env) cl_params cl_params' + with Ctype.Unify _ -> + raise(Error(cl.pci_loc, env, + Bad_class_type_parameters (ty_id, cl_params, cl_params'))) + end; + begin try + Ctype.unify env ty cl_ty + with Ctype.Unify _ -> + let ty_expanded = Ctype.object_fields ty in + raise(Error(cl.pci_loc, env, Abbrev_type_clash (ty, ty_expanded, 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 err -> + raise(Error(cl.pci_loc, env, + Constructor_type_mismatch (cl.pci_name.txt, err))) + 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 = Btype.class_body typ; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_hash_type = cl_td; + 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 + + (* Misc. *) + let arity = Btype.class_type_arity typ in + let pub_meths = Btype.public_methods sign in + + (* Final definitions *) + let (params', typ') = Ctype.instance_class params typ in + let 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 Definition; + 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 (Btype.self_type typ) + in + Ctype.set_object_name obj_id cl_params cl_ty; + let cl_abbr = + { cl_td with + type_params = cl_params; + type_manifest = Some cl_ty + } + in + let cltydef = + {clty_params = params'; clty_type = Btype.class_body typ'; + clty_variance = cty_variance; + clty_path = Path.Pident obj_id; + clty_hash_type = cl_abbr; + clty_loc = cl.pci_loc; + clty_attributes = cl.pci_attributes; + clty_uid = dummy_class.cty_uid; + } + in + ((cl, id, clty, ty_id, cltydef, obj_id, obj_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, ci_params, + arity, pub_meths, coe, expr) = + let cl_abbr = cltydef.clty_hash_type in + + begin try Ctype.collapse_conj_params env clty.cty_params + with Ctype.Unify err -> + raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, err))) + end; + + List.iter Ctype.generalize clty.cty_params; + Ctype.generalize_class_type 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; + + Ctype.nongen_vars_in_class_declaration clty + |> Option.iter (fun vars -> + let nongen_vars = Btype.TypeSet.elements vars in + raise(Error(cl.pci_loc, env + , Non_generalizable_class { id; clty; nongen_vars })); + ); + + begin match + Ctype.closed_class clty.cty_params + (Btype.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; 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_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_params, cl_ty, cl_td, + 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_params, cl_ty, cl_td, + constr_type, + dummy_class) + (res, env) + ) + +let extract_type_decls { clty; cltydef; obj_id; obj_abbr; req} decls = + (obj_id, obj_abbr, clty, cltydef, req) :: decls + +let merge_type_decls decl (obj_abbr, clty, cltydef) = + {decl with obj_abbr; clty; cltydef} + +let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_abbr; } = + (* Add definitions after cleaning them *) + Env.add_type ~check:true obj_id + (Subst.type_declaration Subst.identity obj_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; + arity; pub_meths; coe; req } = + let cl_abbr = cltydef.clty_hash_type in + 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 err -> + raise(Typecore.Error(loc, env, Typecore.Not_subtype err)) + 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_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, + Uid.mk ~current_unit:(Env.get_unit_name ()) + )) + cls + in + let res, env = + Ctype.with_local_level_for_class begin fun () -> + 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 + res, env + end + in + 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 virt sexpr = + incr class_num; + let self_scope = Ctype.get_current_level () in + let expr = + class_expr (Int.to_string !class_num) env env virt self_scope sexpr + in + complete_class_type expr.cl_loc env virt Class expr.cl_type; + (expr, expr.cl_type) + +let class_description env virt sexpr = + let self_scope = Ctype.get_current_level () in + let expr = class_type env virt self_scope sexpr in + complete_class_type expr.cltyp_loc env virt Class_type expr.cltyp_type; + (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_abbr = decl.cls_abbr; + clsty_info = decl.cls_info}) + decls, + env) + +let type_object env loc s = + incr class_num; + let desc = + class_structure (Int.to_string !class_num) + Concrete Btype.lowest_level Final env env loc s + in + complete_class_signature loc env Concrete Object desc.cstr_type; + let meths = Btype.public_methods desc.cstr_type in + (desc, meths) + +let () = + Typecore.type_object := type_object + +(*******************************) + +(* Check that there is no references through recursive modules (GPR#6491) *) +let rec check_recmod_class_type env cty = + match cty.pcty_desc with + | Pcty_constr(lid, _) -> + ignore (Env.lookup_cltype ~use:false ~loc:lid.loc lid.txt env) + | Pcty_extension _ -> () + | Pcty_arrow(_, _, cty) -> + check_recmod_class_type env cty + | Pcty_open(od, cty) -> + let _, env = !type_open_descr env od in + check_recmod_class_type env cty + | Pcty_signature csig -> + check_recmod_class_sig env csig + +and check_recmod_class_sig env csig = + List.iter + (fun ctf -> + match ctf.pctf_desc with + | Pctf_inherit cty -> check_recmod_class_type env cty + | Pctf_val _ | Pctf_method _ + | Pctf_constraint _ | Pctf_attribute _ | Pctf_extension _ -> ()) + csig.pcsig_fields + +let check_recmod_decl env sdecl = + check_recmod_class_type env sdecl.pci_expr + +(* 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 = + let decls, env = class_type_declarations env (List.map approx_class sdecls) in + List.iter (check_recmod_decl env) sdecls; + decls, env + +(*******************************) + +(* Error report *) + +open Format + +let non_virtual_string_of_kind : kind -> string = function + | Object -> "object" + | Class -> "non-virtual class" + | Class_type -> "non-virtual class type" + +module Style=Misc.Style + +let report_error env ppf = + let pp_args ppf args = + let args = List.map (Printtyp.tree_of_typexp Type) args in + Style.as_inline_code !Oprint.out_type_args ppf args + in + function + | Repeated_parameter -> + fprintf ppf "A type parameter occurs several times" + | Unconsistent_constraint err -> + fprintf ppf "@[The class constraints are not consistent.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type"); + fprintf ppf "@]" + | Field_type_mismatch (k, m, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The %s %a@ has type" k Style.inline_code m) + (function ppf -> + fprintf ppf "but is expected to have type") + | Unexpected_field (ty, lab) -> + fprintf ppf + "@[@[<2>This object is expected to have type :@ %a@]\ + @ This type does not have a method %a." + (Style.as_inline_code Printtyp.type_expr) ty + Style.inline_code lab + | Structure_expected clty -> + fprintf ppf + "@[This class expression is not a class structure; it has type@ %a@]" + (Style.as_inline_code 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 ppf = function + | Nolabel -> fprintf ppf "without label" + | l -> fprintf ppf "with label %a" + Style.inline_code (Btype.prefixed_label_name l) + in + fprintf ppf "This argument cannot be applied %a" 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" + (Style.as_inline_code Printtyp.type_expr) ty + | Unbound_class_2 cl -> + fprintf ppf "@[The class@ %a@ is not yet completely defined@]" + (Style.as_inline_code Printtyp.longident) cl + | Unbound_class_type_2 cl -> + fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" + (Style.as_inline_code Printtyp.longident) cl + | Abbrev_type_clash (abbrev, actual, expected) -> + (* XXX Afficher une trace ? | Print a trace? *) + Printtyp.prepare_for_printing [abbrev; actual; expected]; + fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ + but is used with type@ %a@]" + (Style.as_inline_code !Oprint.out_type) + (Printtyp.tree_of_typexp Type abbrev) + (Style.as_inline_code !Oprint.out_type) + (Printtyp.tree_of_typexp Type actual) + (Style.as_inline_code !Oprint.out_type) + (Printtyp.tree_of_typexp Type expected) + | Constructor_type_mismatch (c, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The expression %a has type" + Style.inline_code ("new " ^ c) + ) + (function ppf -> + fprintf ppf "but is used with type") + | Virtual_class (kind, mets, vals) -> + let kind = non_virtual_string_of_kind kind in + let missings = + match mets, vals with + [], _ -> "variables" + | _, [] -> "methods" + | _ -> "methods and variables" + in + fprintf ppf + "@[This %s has virtual %s.@ \ + @[<2>The following %s are virtual : %a@]@]" + kind missings missings + (pp_print_list ~pp_sep:pp_print_space Style.inline_code) (mets @ vals) + | Undeclared_methods(kind, mets) -> + let kind = non_virtual_string_of_kind kind in + fprintf ppf + "@[This %s has undeclared virtual methods.@ \ + @[<2>The following methods were not declared : %a@]@]" + kind (pp_print_list ~pp_sep:pp_print_space Style.inline_code) mets + | 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)@]" + (Style.as_inline_code Printtyp.longident) lid expected provided + | Parameter_mismatch err -> + Printtyp.report_unification_error ppf env err + (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.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The abbreviation %a@ is used with parameter(s)@ %a@ \ + which are incompatible with constraint(s)@ %a@]" + (Style.as_inline_code Printtyp.ident) id + pp_args params + pp_args cstrs + | Bad_class_type_parameters (id, params, cstrs) -> + let pp_hash ppf id = fprintf ppf "#%a" Printtyp.ident id in + Printtyp.prepare_for_printing (params @ cstrs); + fprintf ppf + "@[The class type %a@ is used with parameter(s)@ %a,@ \ + whereas the class type definition@ constrains@ \ + those parameters to be@ %a@]" + (Style.as_inline_code pp_hash) id + pp_args params + pp_args cstrs + | Class_match_failure error -> + Includeclass.report_error Type ppf error + | Unbound_val lab -> + fprintf ppf "Unbound instance variable %a" Style.inline_code lab + | Unbound_type_var (printer, reason) -> + let print_reason ppf { Ctype.free_variable; meth; meth_ty; } = + let (ty0, kind) = free_variable in + let ty1 = + match kind with + | Type_variable -> ty0 + | Row_variable -> Btype.newgenty(Tobject(ty0, ref None)) + in + Printtyp.add_type_to_preparation meth_ty; + Printtyp.add_type_to_preparation ty1; + let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in + fprintf ppf + "The method %a@ has type@;<1 2>%a@ where@ %a@ is unbound" + Style.inline_code meth + pp_type (Printtyp.tree_of_typexp Type meth_ty) + pp_type (Printtyp.tree_of_typexp Type ty0) + in + fprintf ppf + "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ + @[%a@]@]" + printer print_reason reason + | Non_generalizable_class {id; clty; nongen_vars } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in + Printtyp.prepare_for_printing nongen_vars; + fprintf ppf + "@[The type of this class,@ %a,@ \ + contains the non-generalizable type variable(s): %a.@ %a@]" + (Style.as_inline_code @@ Printtyp.class_declaration id) clty + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + (Style.as_inline_code Printtyp.prepared_type_scheme) + ) nongen_vars + Misc.print_see_manual manual_ref + + | 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@]" + (Style.as_inline_code Printtyp.type_scheme) ty + | Non_collapsable_conjunction (id, clty, err) -> + fprintf ppf + "@[The type of this class,@ %a,@ \ + contains non-collapsible conjunctive types in constraints.@ %t@]" + (Style.as_inline_code @@ Printtyp.class_declaration id) clty + (fun ppf -> Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type") + ) + | Self_clash err -> + Printtyp.report_unification_error ppf env err + (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 methods@ \ + or instance variables@ but is explicitly marked as@ \ + overriding with %a.@]" + Style.inline_code "!" + | No_overriding (kind, name) -> + fprintf ppf "@[The %s %a@ has no previous definition@]" kind + Style.inline_code name + | Duplicate (kind, name) -> + fprintf ppf "@[The %s %a@ has multiple definitions in this object@]" + kind Style.inline_code name + | Closing_self_type sign -> + 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.@]" + (Style.as_inline_code Printtyp.type_scheme) sign.csig_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_502/typing/typeclass.mli b/upstream/ocaml_502/typing/typeclass.mli new file mode 100644 index 0000000000..cdecc8dfb7 --- /dev/null +++ b/upstream/ocaml_502/typing/typeclass.mli @@ -0,0 +1,138 @@ +(**************************************************************************) +(* *) +(* 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_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_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 * Env.t + +(* +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 kind = + | Object + | Class + | Class_type + +type error = + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string + | 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_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list + | Parameter_arity_mismatch of Longident.t * int * int + | Parameter_mismatch of Errortrace.unification_error + | Bad_parameters of Ident.t * type_expr list * type_expr list + | Bad_class_type_parameters of Ident.t * type_expr list * type_expr list + | 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 + { id : Ident.t + ; clty : Types.class_declaration + ; nongen_vars : type_expr list + } + | Cannot_coerce_self of type_expr + | Non_collapsable_conjunction of + Ident.t * Types.class_declaration * Errortrace.unification_error + | Self_clash of Errortrace.unification_error + | Mutability_mismatch of string * mutable_flag + | No_overriding of string * string + | Duplicate of string * string + | Closing_self_type of class_signature + +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_502/typing/typecore.ml b/upstream/ocaml_502/typing/typecore.ml new file mode 100644 index 0000000000..35d057aaea --- /dev/null +++ b/upstream/ocaml_502/typing/typecore.ml @@ -0,0 +1,6932 @@ +(**************************************************************************) +(* *) +(* 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 *) + +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + +open Misc +open Asttypes +open Parsetree +open Types +open Typedtree +open Btype +open Ctype + +module Style = Misc.Style + +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 wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +type contains_gadt = + | Contains_gadt + | No_gadt + +let wrong_kind_sort_of_constructor (lid : Longident.t) = + match lid with + | Lident "true" | Lident "false" | Ldot(_, "true") | Ldot(_, "false") -> + Boolean + | Lident "[]" | Lident "::" | Ldot(_, "[]") | Ldot(_, "::") -> List + | Lident "()" | Ldot(_, "()") -> Unit + | _ -> Constructor + +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_error + | Pattern_type_clash : + Errortrace.unification_error * Parsetree.pattern_desc option -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * type_forcing_context option + * Parsetree.expression_desc option + | Function_arity_type_clash of + { syntactic_arity : int; + type_constraint : type_expr; + trace : Errortrace.unification_error; + } + (* [Function_arity_type_clash { syntactic_arity = n; type_constraint; trace }] + is the type error for the specific case where an n-ary function is + constrained at a type with an arity less than n, e.g.: + {[ + type (_, _) eq = Eq : ('a, 'a) eq + let bad : type a. ?opt:(a, int -> int) eq -> unit -> a = + fun ?opt:(Eq = assert false) () x -> x + 1 + ]} + + [type_constraint] is the user-written polymorphic type (in this example + [?opt:(a, int -> int) eq -> unit -> a]) that causes this type clash, and + [trace] is the unification error that signaled the issue. + *) + | Apply_non_function of { + funct : Typedtree.expression; + func_ty : type_expr; + res_ty : type_expr; + previous_arg_loc : Location.t; + extra_arg_loc : Location.t; + } + | 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 + | Not_an_object of type_expr * type_forcing_context option + | Undefined_method of type_expr * string * string list option + | Undefined_self_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.error + | Outside_class + | Value_multiply_overridden of string + | Coercion_failure of + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } + | Scoping_let_module of string * type_expr + | Not_a_polymorphic_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * Errortrace.unification_error + | Modules_not_allowed + | Cannot_infer_signature + | Not_a_packed_module of type_expr + | Unexpected_existential of existential_restriction * string + | 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_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + +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 * Shape.t) + +(* 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 * 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 get_desc (expand_head env ty) with + Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty + | _ -> assert false + +let protect_expansion env ty = + if Env.has_local_constraints env then generic_instance ty else ty + +type record_extraction_result = + | Record_type of Path.t * Path.t * Types.label_declaration list + | Not_a_record_type + | Maybe_a_record_type + +let extract_concrete_typedecl_protected env ty = + extract_concrete_typedecl env (protect_expansion env ty) + +let extract_concrete_record env ty = + match extract_concrete_typedecl_protected env ty with + | Typedecl(p0, p, {type_kind=Type_record (fields, _)}) -> + Record_type (p0, p, fields) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_record_type + | May_have_typedecl -> Maybe_a_record_type + +type variant_extraction_result = + | Variant_type of Path.t * Path.t * Types.constructor_declaration list + | Not_a_variant_type + | Maybe_a_variant_type + +let extract_concrete_variant env ty = + match extract_concrete_typedecl_protected env ty with + | Typedecl(p0, p, {type_kind=Type_variant (cstrs, _)}) -> + Variant_type (p0, p, cstrs) + | Typedecl(p0, p, {type_kind=Type_open}) -> + Variant_type (p0, p, []) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_variant_type + | May_have_typedecl -> Maybe_a_variant_type + +let extract_label_names env ty = + match extract_concrete_record env ty with + | Record_type (_, _,fields) -> List.map (fun l -> l.Types.ld_id) fields + | Not_a_record_type | Maybe_a_record_type -> assert false + +let is_principal ty = + not !Clflags.principal || get_level ty = generic_level + +(* 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 err -> + raise(Error(loc, env, Expr_type_clash(err, None, None))) + | Tags(l1,l2) -> + raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) + +(* helper notation for Pattern_env.t *) +let (!!) (penv : Pattern_env.t) = penv.env + +(* Unification inside type_pat *) +let unify_pat_types loc env ty ty' = + try unify env ty ty' with + | Unify err -> + raise(Error(loc, env, Pattern_type_clash(err, None))) + | Tags(l1,l2) -> + raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) + +(* GADT unification inside solve_Ppat_construct and check_counter_example_pat *) +let nothing_equated = TypePairs.create 0 +let unify_pat_types_return_equated_pairs ~refine loc penv ty ty' = + try + if refine then unify_gadt penv ty ty' + else (unify !!penv ty ty'; nothing_equated) + with + | Unify err -> + raise(Error(loc, !!penv, Pattern_type_clash(err, None))) + | Tags(l1,l2) -> + raise(Typetexp.Error(loc, !!penv, Typetexp.Variant_tags (l1, l2))) + +let unify_pat_types_refine ~refine loc penv ty ty' = + ignore (unify_pat_types_return_equated_pairs ~refine loc penv ty ty') + +(** [sdesc_for_hint] is used by error messages to report literals in their + original formatting *) +let unify_pat ?sdesc_for_hint env pat expected_ty = + try unify_pat_types pat.pat_loc env pat.pat_type expected_ty + with Error (loc, env, Pattern_type_clash(err, None)) -> + raise(Error(loc, env, Pattern_type_clash(err, sdesc_for_hint))) + +(* unification of a type with a Tconstr with freshly created arguments *) +let unify_head_only ~refine loc penv ty constr = + let path = cstr_type_path constr in + let decl = Env.find_type path !!penv in + let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in + unify_pat_types_refine ~refine loc penv 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 get_desc (expand_head pat.pat_env pat.pat_type) with + Tvariant row -> r := row; row + | _ -> assert false + in + let f = get_row_field tag row in + begin match row_field_repr f with + | Rabsent -> () (* assert false *) + | Reither (true, [], _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present None) + | Reither (false, ty::tl, _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present (Some ty)); + begin match opat with None -> assert false + | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) + end + | Reither (c, _l, true) when not (has_fixed_explanation row) -> + link_row_field_ext ~inside:f (rf_either [] ~no_arg:c ~matched:false) + | _ -> () + 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 + +(* [type_pat_state] and related types for pattern environment; + these should not be confused with Pattern_env.t, which is a part of the + interface to unification functions in [Ctype] *) +type pattern_variable = + { + pv_id: Ident.t; + pv_type: type_expr; + pv_loc: Location.t; + pv_as_var: bool; + pv_attributes: attributes; + pv_uid : Uid.t; + } + +type module_variable = + { + mv_id: Ident.t; + mv_name: string Location.loc; + mv_loc: Location.t; + mv_uid: Uid.t + } + +(* Whether or not patterns of the form (module M) are accepted. (If they are, + the idents will be created at the provided scope.) When module patterns are + allowed, the caller should take care to check that the introduced module + bindings' types don't escape their scope; see the callsites in [type_let] + and [type_cases] for examples. + [Modules_ignored] indicates that the typing of patterns should not accumulate + a list of module patterns to unpack. It's no different than using + [Modules_allowed] and then ignoring the accumulated [module_variables] list, + but signals more clearly that the module patterns aren't used in an + interesting way. +*) +type module_patterns_restriction = + | Modules_allowed of { scope: int } + | Modules_rejected + | Modules_ignored + +(* A parallel type to [module_patterns_restriction], though also + tracking the module variables encountered. +*) +type module_variables = + | Modvars_allowed of + { scope: int; + module_variables: module_variable list; + } + | Modvars_rejected + | Modvars_ignored + +type type_pat_state = + { mutable tps_pattern_variables: pattern_variable list; + mutable tps_pattern_force: (unit -> unit) list; + mutable tps_module_variables: module_variables; + (* Mutation will not change the constructor of [tps_module_variables], just + the contained [module_variables] list. [module_variables] could be made + mutable instead, but we felt this made the code more awkward. + *) + } + +let create_type_pat_state allow_modules = + let tps_module_variables = + match allow_modules with + | Modules_allowed { scope } -> + Modvars_allowed { scope; module_variables = [] } + | Modules_ignored -> Modvars_ignored + | Modules_rejected -> Modvars_rejected + in + { tps_pattern_variables = []; + tps_module_variables; + tps_pattern_force = []; + } + +(* Copy mutable fields. Used in typechecking or-patterns. *) +let copy_type_pat_state + { tps_pattern_variables; + tps_module_variables; + tps_pattern_force; + } + = + { tps_pattern_variables; + tps_module_variables; + tps_pattern_force; + } + +let blit_type_pat_state ~src ~dst = + dst.tps_pattern_variables <- src.tps_pattern_variables; + dst.tps_module_variables <- src.tps_module_variables; + dst.tps_pattern_force <- src.tps_pattern_force; +;; + +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) tps loc name ty + attrs = + if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt) + tps.tps_pattern_variables + then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt)); + let id = + if is_module then begin + (* Unpack patterns result in both a module declaration and a value + variable of the same name being entered into the environment. (The + module is via [tps_module_variables], and the variable is via + [tps_pattern_variables].) *) + match tps.tps_module_variables with + | Modvars_ignored -> Ident.create_local name.txt + | Modvars_rejected -> + raise (Error (loc, Env.empty, Modules_not_allowed)); + | Modvars_allowed { scope; module_variables } -> + let id = Ident.create_scoped name.txt ~scope in + let module_variables = + { mv_id = id; + mv_name = name; + mv_loc = loc; + mv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + } :: module_variables + in + tps.tps_module_variables <- + Modvars_allowed { scope; module_variables; }; + id + end else + Ident.create_local name.txt + in + let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + tps.tps_pattern_variables <- + {pv_id = id; + pv_type = ty; + pv_loc = loc; + pv_as_var = is_as_variable; + pv_attributes = attrs; + pv_uid} :: tps.tps_pattern_variables; + id, pv_uid + +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 err -> + raise(Error(loc, env, Or_pattern_type_clash(x1, err))) + 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 : Env.t) p = + build_as_type_extra env p p.pat_extra + +and build_as_type_extra env p = function + | [] -> build_as_type_aux env p + | ((Tpat_type _ | Tpat_open _ | Tpat_unpack), _, _) :: rest -> + build_as_type_extra env p rest + | (Tpat_constraint {ctyp_type = ty; _}, _, _) :: rest -> + (* If the type constraint is ground, then this is the best type + we can return, so just return an instance (cf. #12313) *) + if free_variables ty = [] then instance ty else + (* Otherwise we combine the inferred type for the pattern with + then non-ground constraint in a non-ambivalent way *) + let as_ty = build_as_type_extra env p rest in + (* [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]. *) + let ty = + with_local_level ~post:generalize_structure (fun () -> instance ty) + in + (* This call to unify may only fail due to missing GADT equations *) + unify_pat_types p.pat_loc env (instance as_ty) (instance ty); + ty + +and build_as_type_aux (env : Env.t) 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 Keep_existentials_flexible 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 + let fields = [l, rf_present ty] in + newty (Tvariant (create_row ~fields ~more:(newvar()) + ~name:None ~fixed:None ~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 ~fixed: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 get_desc lbl.lbl_arg 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 ~fixed:false lbl in + unify_pat_types p.pat_loc 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 {fields; fixed; name} = row_repr row in + newty (Tvariant (create_row ~fields ~fixed ~name + ~closed:false ~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 tps env loc sty expected_ty = + let cty, ty, force = Typetexp.transl_simple_type_delayed env sty in + unify_pat_types loc env ty (instance expected_ty); + tps.tps_pattern_force <- force :: tps.tps_pattern_force; + match get_desc ty with + | Tpoly (body, tyl) -> + let _, ty' = + with_level ~level:generic_level + (fun () -> instance_poly ~keep_names:true ~fixed:false tyl body) + in + (cty, ty, ty') + | _ -> assert false + +let solve_Ppat_alias env pat = + with_local_level ~post:generalize (fun () -> build_as_type env pat) + +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 ~refine loc env ty expected_ty; + vars + +let solve_constructor_annotation + tps (penv : Pattern_env.t) name_list sty ty_args ty_ex = + let expansion_scope = penv.equations_scope in + let ids = + List.map + (fun name -> + let decl = new_local_type ~loc:name.loc Definition in + let (id, new_env) = + Env.enter_type ~scope:expansion_scope name.txt decl !!penv in + Pattern_env.set_env penv new_env; + {name with txt = id}) + name_list + in + let cty, ty, force = + with_local_level ~post:(fun (_,ty,_) -> generalize_structure ty) + (fun () -> Typetexp.transl_simple_type_delayed !!penv sty) + in + tps.tps_pattern_force <- force :: tps.tps_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 !!penv ty1 ty_arg; + [ty2] + | _ -> + unify_pat_types cty.ctyp_loc !!penv ty1 (newty (Ttuple ty_args)); + match get_desc (expand_head !!penv ty2) with + 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 get_desc tv with + Tconstr(Path.Pident id, [], _) when List.mem id rem -> + list_remove id rem + | _ -> + raise (Error (cty.ctyp_loc, !!penv, + Unbound_existential (ids, ty)))) + ids ty_ex + in + if rem <> [] then + raise (Error (cty.ctyp_loc, !!penv, + Unbound_existential (ids, ty))) + end; + ty_args, Some (ids, cty) + +let solve_Ppat_construct ~refine tps penv 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 penv (instance expected_ty) constr; + + (* PR#7214: do not use gadt unification for toplevel lets *) + let unify_res ty_res expected_ty = + let refine = + refine || constr.cstr_generalized && no_existentials = None in + unify_pat_types_return_equated_pairs ~refine loc penv ty_res expected_ty + in + + let ty_args, equated_types, existential_ctyp = + with_local_level_iter ~post: generalize_structure begin fun () -> + let expected_ty = instance expected_ty in + let ty_args, ty_res, equated_types, existential_ctyp = + match existential_styp with + None -> + let ty_args, ty_res, _ = + instance_constructor (Make_existentials_abstract penv) constr + in + ty_args, ty_res, unify_res ty_res expected_ty, None + | Some (name_list, sty) -> + let existential_treatment = + if name_list = [] then + Make_existentials_abstract penv + else + (* we will unify them (in solve_constructor_annotation) with the + local types provided by the user *) + Keep_existentials_flexible + in + let ty_args, ty_res, ty_ex = + instance_constructor existential_treatment constr + in + let equated_types = unify_res ty_res expected_ty in + let ty_args, existential_ctyp = + solve_constructor_annotation tps penv name_list sty ty_args ty_ex + in + ty_args, ty_res, equated_types, existential_ctyp + in + if constr.cstr_existentials <> [] then + lower_variables_only !!penv penv.Pattern_env.equations_scope ty_res; + ((ty_args, equated_types, existential_ctyp), + expected_ty :: ty_res :: ty_args) + end + in + if !Clflags.principal && not refine then begin + (* Do not warn for counter-examples *) + 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 penv label label_lid record_ty = + with_local_level_iter ~post:generalize_structure begin fun () -> + let (_, ty_arg, ty_res) = instance_label ~fixed:false label in + begin try + unify_pat_types_refine ~refine loc penv ty_res (instance record_ty) + with Error(_loc, _env, Pattern_type_clash(err, _)) -> + raise(Error(label_lid.loc, !!penv, + Label_mismatch(label_lid.txt, err))) + end; + (ty_arg, [ty_res; ty_arg]) + end + +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 ~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 ~refine loc env (Predef.type_lazy_t nv) + (generic_instance expected_ty); + nv + +let solve_Ppat_constraint tps loc env sty expected_ty = + let cty, ty, force = + with_local_level ~post:(fun (_, ty, _) -> generalize_structure ty) + (fun () -> Typetexp.transl_simple_type_delayed env sty) + in + tps.tps_pattern_force <- force :: tps.tps_pattern_force; + let ty, expected_ty' = instance ty, ty in + unify_pat_types loc env ty (instance expected_ty); + (cty, ty, expected_ty') + +let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = + let arg_type = if no_arg then [] else [newgenvar()] in + let fields = [tag, rf_either ~no_arg arg_type ~matched:true] in + let make_row more = + create_row ~fields ~closed:false ~more ~fixed:None ~name:None + in + let row = make_row (newgenvar ()) 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 ~refine loc env (newgenty(Tvariant row)) expected_ty; + (arg_type, make_row (newvar ()), 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 get_desc ty with + Tvariant row when static_row row -> row + | _ -> raise(Error(lid.loc, env, Not_a_polymorphic_variant_type lid.txt)) + in + let pats, fields = + List.fold_left + (fun (pats,fields) (l,f) -> + match row_field_repr f with + Rpresent None -> + let f = rf_either [] ~no_arg:true ~matched:true in + (l,None) :: pats, + (l, f) :: fields + | Rpresent (Some ty) -> + let f = rf_either [ty] ~no_arg:false ~matched:true in + (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; + pat_type=ty; pat_extra=[]; pat_attributes=[]}) + :: pats, + (l, f) :: fields + | _ -> pats, fields) + ([],[]) (row_fields row0) in + let fields = List.rev fields in + let name = Some (path, tyl) in + let make_row more = + create_row ~fields ~more ~closed:false ~fixed:None ~name in + let ty = newty (Tvariant (make_row (newvar()))) in + let gloc = {loc with Location.loc_ghost=true} in + let row' = ref (make_row (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_polymorphic_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 }) + +(* 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 get_desc ty with + 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 get_desc ty 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 (Some 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 = + if Warnings.is_active (Ambiguous_name ([],[],false,"")) then begin + 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)) + end + + (* 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 = + if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin + 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)) + end + + (* 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 = + (* If one label is qualified [{ foo = ...; M.bar = ... }], + we will disambiguate all labels using one of the qualifying modules, + as if the user had written [{ M.foo = ...; M.bar = ... }]. + + #11630: It is important to process first the + user-qualified labels, instead of processing all labels in + order, so that error messages coming from the lookup of + M (maybe no such module/path exists) are shown to the user + in context of a qualified field [M.bar] they wrote + themselves, instead of the "ghost" qualification [M.foo] + that does not come from the source program. *) + let lbl_list = + List.map (fun (lid, _) -> + match lid.txt with + | Longident.Ldot _ -> Some (process_label lid) + | _ -> None + ) lid_a_list + in + (* Find a module prefix (if any) to qualify unqualified labels *) + let qual = + List.find_map (function + | {txt = Longident.Ldot (modname, _); _}, _ -> Some modname + | _ -> None + ) lid_a_list + in + (* Prefix unqualified labels with [qual] and resolve them. + + Prefixing unqualified labels does not change the final + disambiguation result, it restricts the set of candidates + without removing any valid choice. + It matters if users activated warnings for ambiguous or + out-of-scope resolutions -- they get less warnings by + qualifying at least one of the fields. *) + List.map2 (fun lid_a lbl -> + match lbl, lid_a with + | Some lbl, (lid, a) -> lid, lbl, a + | None, (lid, a) -> + let qual_lid = + match qual, lid.txt with + | Some modname, Longident.Lident s -> + {lid with txt = Longident.Ldot (modname, s)} + | _ -> lid + in + lid, process_label qual_lid, a + ) lid_a_list lbl_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 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 loc closed env usage type_lbl_a expected_type lid_a_list = + let lbl_a_list = + 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 + List.map type_lbl_a lbl_a_list + +(* 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 *) + +(* "untyped" cases are prior to checking the pattern. *) +type untyped_case = Parsetree.pattern Parmatch.parmatch_case + +(* "half typed" cases are produced in [map_half_typed_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, 'case_data) half_typed_case = + { typed_pat: 'case_pattern; + pat_type_for_unif: type_expr; + untyped_case : untyped_case; + case_data : 'case_data; + branch_env: Env.t; + pat_vars: pattern_variable list; + module_vars: module_variables; + contains_gadt: bool; } + +(* Used to split patterns into value cases and exception cases. *) +let split_half_typed_cases env zipped_cases = + let add_case lst htc data = function + | None -> lst + | Some split_pat -> + ({ htc.untyped_case with pattern = split_pat }, data) :: lst + in + List.fold_right (fun (htc, data) (vals, exns) -> + let pat = htc.typed_pat in + match split_pattern pat with + | Some _, Some _ when htc.untyped_case.has_guard -> + raise (Error (pat.pat_loc, env, + Mixed_value_and_exception_patterns_under_guard)) + | vp, ep -> add_case vals htc data vp, add_case exns htc data ep + ) zipped_cases ([], []) + +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 esc -> + (* We don't expand the type here because if we do, we might expand to the + type that escaped, leading to confusing error messages. *) + let trace = Errortrace.[Escape (map_escape trivial_expansion esc)] in + raise (Error(loc, + env, + Pattern_type_clash(Errortrace.unification_error ~trace, None))) + + +(** 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, and + unification may update the typing environment. *) +let rec type_pat + : type k . type_pat_state -> k pattern_category -> + no_existentials: existential_restriction option -> + penv: Pattern_env.t -> Parsetree.pattern -> type_expr -> + k general_pattern + = fun tps category ~no_existentials ~penv sp expected_ty -> + Builtin_attributes.warning_scope sp.ppat_attributes + (fun () -> + type_pat_aux tps category ~no_existentials ~penv sp expected_ty + ) + +and type_pat_aux + : type k . type_pat_state -> k pattern_category -> no_existentials:_ -> + penv:Pattern_env.t -> _ -> _ -> k general_pattern + = fun tps category ~no_existentials ~penv sp expected_ty -> + let type_pat tps category ?(penv=penv) = + type_pat tps category ~no_existentials ~penv + in + let loc = sp.ppat_loc in + let solve_expected (x : pattern) : pattern = + unify_pat ~sdesc_for_hint:sp.ppat_desc !!penv x (instance expected_ty); + x + in + let crp (x : k general_pattern) : k general_pattern = + match category with + | Value -> rp x + | Computation -> rcp x + in + (* record {general,value,computation} pattern *) + let rp = crp + and rvp x = crp (pure category x) + and rcp x = crp (only_impure category x) in + match sp.ppat_desc with + Ppat_any -> + rvp { + pat_desc = Tpat_any; + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_var name -> + let ty = instance expected_ty in + let id, uid = enter_variable tps loc name ty sp.ppat_attributes in + rvp { + pat_desc = Tpat_var (id, name, uid); + pat_loc = loc; pat_extra=[]; + pat_type = ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_unpack name -> + let t = instance expected_ty in + begin match name.txt with + | None -> + rvp { + 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 = !!penv } + | Some s -> + let v = { name with txt = s } in + (* We're able to pass ~is_module:true here without an error because + [Ppat_unpack] is a case identified by [may_contain_modules]. See + the comment on [may_contain_modules]. *) + let id, uid = + enter_variable tps loc v t ~is_module:true sp.ppat_attributes + in + rvp { + pat_desc = Tpat_var (id, v, uid); + pat_loc = sp.ppat_loc; + pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; + pat_type = t; + pat_attributes = []; + pat_env = !!penv } + end + | Ppat_constraint( + {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs}, + ({ptyp_desc=Ptyp_poly _} as sty)) -> + (* explicitly polymorphic type *) + let cty, ty, ty' = + solve_Ppat_poly_constraint tps !!penv lloc sty expected_ty in + let id, uid = enter_variable tps lloc name ty' attrs in + rvp { pat_desc = Tpat_var (id, name, uid); + pat_loc = lloc; + pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes]; + pat_type = ty; + pat_attributes = []; + pat_env = !!penv } + | Ppat_alias(sq, name) -> + let q = type_pat tps Value sq expected_ty in + let ty_var = solve_Ppat_alias !!penv q in + let id, uid = + enter_variable + ~is_as_variable:true tps name.loc name ty_var sp.ppat_attributes + in + rvp { pat_desc = Tpat_alias(q, id, name, uid); + pat_loc = loc; pat_extra=[]; + pat_type = q.pat_type; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_constant cst -> + let cst = constant_or_raise !!penv loc cst in + rvp @@ solve_expected { + pat_desc = Tpat_constant cst; + pat_loc = loc; pat_extra=[]; + pat_type = type_constant cst; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | 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 tps category p expected_ty + (* TODO: record 'extra' to remember about interval *) + | Ppat_interval _ -> + raise (Error (loc, !!penv, Invalid_interval)) + | Ppat_tuple spl -> + assert (List.length spl >= 2); + let expected_tys = + solve_Ppat_tuple ~refine:false loc penv spl expected_ty in + let pl = List.map2 (type_pat tps Value) spl expected_tys in + rvp { + 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 = !!penv } + | Ppat_construct(lid, sarg) -> + let expected_type = + match extract_concrete_variant !!penv expected_ty with + | Variant_type(p0, p, _) -> + Some (p0, p, is_principal expected_ty) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let error = Wrong_expected_kind(srt, Pattern, expected_ty) in + raise (Error (loc, !!penv, error)) + in + let constr = + let candidates = + Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !!penv in + wrap_disambiguate "This variant pattern is expected to have" + (mk_expected expected_ty) + (Constructor.disambiguate Env.Pattern lid !!penv expected_type) + candidates + in + begin match no_existentials, constr.cstr_existentials with + | None, _ | _, [] -> () + | Some r, (_ :: _) -> + let name = constr.cstr_name in + raise (Error (loc, !!penv, Unexpected_existential (r, name))) + 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, !!penv, 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, !!penv, Constructor_arity_mismatch(lid.txt, + constr.cstr_arity, List.length sargs))); + + let (ty_args, existential_ctyp) = + solve_Ppat_construct ~refine:false tps penv 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, !!penv, 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; + + let args = List.map2 (type_pat tps Value) sargs ty_args in + rvp { 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 = !!penv } + | Ppat_variant(tag, sarg) -> + assert (tag <> Parmatch.some_private_tag); + let constant = (sarg = None) in + let arg_type, row, pat_type = + solve_Ppat_variant ~refine:false loc penv tag constant expected_ty in + let arg = + (* PR#6235: propagate type information *) + match sarg, arg_type with + Some sp, [ty] -> Some (type_pat tps Value sp ty) + | _ -> None + in + rvp { + pat_desc = Tpat_variant(tag, arg, ref row); + pat_loc = loc; pat_extra = []; + pat_type = pat_type; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_record(lid_sp_list, closed) -> + assert (lid_sp_list <> []); + let expected_type, record_ty = + match extract_concrete_record !!penv expected_ty with + | Record_type(p0, p, _) -> + let ty = generic_instance expected_ty in + Some (p0, p, is_principal expected_ty), ty + | Maybe_a_record_type -> None, newvar () + | Not_a_record_type -> + let error = Wrong_expected_kind(Record, Pattern, expected_ty) in + raise (Error (loc, !!penv, error)) + in + let type_label_pat (label_lid, label, sarg) = + let ty_arg = + solve_Ppat_record_field ~refine:false loc penv label label_lid + record_ty in + (label_lid, label, type_pat tps Value sarg ty_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 = !!penv; + } + in + let lbl_a_list = + wrap_disambiguate "This record pattern is expected to have" + (mk_expected expected_ty) + (type_label_a_list loc false !!penv Env.Projection + type_label_pat expected_type) + lid_sp_list + in + rvp @@ solve_expected (make_record_pat lbl_a_list) + | Ppat_array spl -> + let ty_elt = solve_Ppat_array ~refine:false loc penv expected_ty in + let pl = List.map (fun p -> type_pat tps Value p ty_elt) spl in + rvp { + pat_desc = Tpat_array pl; + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_or(sp1, sp2) -> + (* Reset pattern forces for just [tps2] because later we append [tps1] and + [tps2]'s pattern forces, and we don't want to duplicate [tps]'s pattern + forces. *) + let tps1 = copy_type_pat_state tps in + let tps2 = {(copy_type_pat_state tps) with tps_pattern_force = []} in + (* Introduce a new scope using with_local_level without generalizations *) + let env1, p1, env2, p2 = + with_local_level begin fun () -> + let type_pat_rec tps penv sp = + type_pat tps category sp expected_ty ~penv + in + let penv1 = + Pattern_env.copy ~equations_scope:(get_current_level ()) penv in + let penv2 = Pattern_env.copy penv1 in + let p1 = type_pat_rec tps1 penv1 sp1 in + let p2 = type_pat_rec tps2 penv2 sp2 in + (penv1.env, p1, penv2.env, p2) + end + in + let p1_variables = tps1.tps_pattern_variables in + let p2_variables = tps2.tps_pattern_variables in + (* Make sure no variable with an ambiguous type gets added to the + environment. *) + let outer_lev = get_current_level () in + List.iter (fun { pv_type; pv_loc; _ } -> + check_scope_escape pv_loc env1 outer_lev pv_type + ) p1_variables; + List.iter (fun { pv_type; pv_loc; _ } -> + check_scope_escape pv_loc env2 outer_lev pv_type + ) p2_variables; + let alpha_env = + enter_orpat_variables loc !!penv p1_variables p2_variables in + (* Propagate the outcome of checking the or-pattern back to + the type_pat_state that the caller passed in. + *) + blit_type_pat_state + ~src: + { tps_pattern_variables = tps1.tps_pattern_variables; + (* We want to propagate all pattern forces, regardless of + which branch they were found in. + *) + tps_pattern_force = + tps2.tps_pattern_force @ tps1.tps_pattern_force; + tps_module_variables = tps1.tps_module_variables; + } + ~dst:tps; + let p2 = alpha_pat alpha_env p2 in + rp { pat_desc = Tpat_or (p1, p2, None); + pat_loc = loc; pat_extra = []; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_lazy sp1 -> + let nv = solve_Ppat_lazy ~refine:false loc penv expected_ty in + let p1 = type_pat tps Value sp1 nv in + rvp { + pat_desc = Tpat_lazy p1; + pat_loc = loc; pat_extra=[]; + pat_type = instance expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv } + | Ppat_constraint(sp, sty) -> + (* Pretend separate = true *) + let cty, ty, expected_ty' = + solve_Ppat_constraint tps loc !!penv sty expected_ty in + let p = type_pat tps category sp expected_ty' in + let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in + begin match category, (p : k general_pattern) with + | Value, {pat_desc = Tpat_var (id,s,uid); _} -> + { p with + pat_type = ty; + pat_desc = + Tpat_alias + ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s, uid); + pat_extra = [extra]; + } + | _, p -> + { p with pat_type = ty; pat_extra = extra::p.pat_extra } + end + | Ppat_type lid -> + let (path, p) = build_or_pat !!penv loc lid in + pure category @@ solve_expected + { 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 !!penv sp.ppat_loc lid in + Pattern_env.set_env penv new_env; + let p = type_pat tps category ~penv p expected_ty in + let new_env = !!penv in + begin match Env.remove_last_open path new_env with + | None -> assert false + | Some closed_env -> Pattern_env.set_env penv closed_env + end; + { p with pat_extra = (Tpat_open (path,lid,new_env), + loc, sp.ppat_attributes) :: p.pat_extra } + | Ppat_exception p -> + let p_exn = type_pat tps Value p Predef.type_exn in + rcp { + pat_desc = Tpat_exception p_exn; + pat_loc = sp.ppat_loc; + pat_extra = []; + pat_type = expected_ty; + pat_env = !!penv; + pat_attributes = sp.ppat_attributes; + } + | Ppat_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +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; pv_uid} 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 = pv_uid; + } env + ) + pv env + +let add_module_variables env module_variables = + let module_variables_as_list = + match module_variables with + | Modvars_allowed mvs -> mvs.module_variables + | Modvars_ignored | Modvars_rejected -> [] + in + List.fold_left (fun env { mv_id; mv_loc; mv_name; mv_uid } -> + Typetexp.TyVarEnv.with_local_scope begin fun () -> + (* This code is parallel to the typing of Pexp_letmodule. However we + omit the call to [Mtype.lower_nongen] as it's not necessary here. + For Pexp_letmodule, the call to [type_module] is done in a raised + level and so needs to be modified to have the correct, outer level. + Here, on the other hand, we're calling [type_module] outside the + raised level, so there's no extra step to take. + *) + let modl, md_shape = + !type_module env + Ast_helper.( + Mod.unpack ~loc:mv_loc + (Exp.ident ~loc:mv_name.loc + (mkloc (Longident.Lident mv_name.txt) + mv_name.loc))) + in + let pres = + match modl.mod_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let md = + { md_type = modl.mod_type; md_attributes = []; + md_loc = mv_name.loc; + md_uid = mv_uid; } + in + Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md env + end + ) env module_variables_as_list + +let type_pat tps category ?no_existentials penv = + type_pat tps category ~no_existentials ~penv + +let type_pattern category ~lev env spat expected_ty allow_modules = + let tps = create_type_pat_state allow_modules in + let new_penv = Pattern_env.make env + ~equations_scope:lev ~allow_recursive_equations:false in + let pat = type_pat tps category new_penv spat expected_ty in + let { tps_pattern_variables = pvs; + tps_module_variables = mvs; + tps_pattern_force = pattern_forces; + } = tps in + (pat, !!new_penv, pattern_forces, pvs, mvs) + +let type_pattern_list + category no_existentials env spatl expected_tys allow_modules + = + let tps = create_type_pat_state allow_modules in + let equations_scope = get_current_level () in + let new_penv = Pattern_env.make env + ~equations_scope ~allow_recursive_equations:false in + let type_pat (attrs, pat) ty = + Builtin_attributes.warning_scope ~ppwarning:false attrs + (fun () -> + type_pat tps category ~no_existentials new_penv pat ty + ) + in + let patl = List.map2 type_pat spatl expected_tys in + let { tps_pattern_variables = pvs; + tps_module_variables = mvs; + tps_pattern_force = pattern_forces; + } = tps in + (patl, !!new_penv, pattern_forces, pvs, mvs) + +let type_class_arg_pattern cl_num val_env met_env l spat = + let tps = create_type_pat_state Modules_rejected in + let nv = newvar () in + let equations_scope = get_current_level () in + let new_penv = Pattern_env.make val_env + ~equations_scope ~allow_recursive_equations:false in + let pat = + type_pat tps Value ~no_existentials:In_class_args new_penv spat nv in + if has_variants pat then begin + Parmatch.pressure_variants val_env [pat]; + finalize_variants pat; + end; + List.iter (fun f -> f()) tps.tps_pattern_force; + if is_optional l then unify_pat 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)) + tps.tps_pattern_variables ([], val_env, met_env) + in + (pat, pv, val_env, met_env) + +let type_self_pattern env spat = + let open Ast_helper in + let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in + let tps = create_type_pat_state Modules_rejected in + let nv = newvar() in + let equations_scope = get_current_level () in + let new_penv = Pattern_env.make env + ~equations_scope ~allow_recursive_equations:false in + let pat = + type_pat tps Value ~no_existentials:In_self_pattern new_penv spat nv in + List.iter (fun f -> f()) tps.tps_pattern_force; + pat, tps.tps_pattern_variables + + +(** In [check_counter_example_pat], we will check a counter-example candidate + produced by Parmatch. This is a 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 [check_counter_example_pat] is to refine this untyped 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}) + *) + +type counter_example_checking_info = { + explosion_fuel: int; + splitting_mode: splitting_mode; + } +(** + [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. + *) + +(** 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, + [check_counter_example_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 [check_counter_example_pat], + 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 [check_counter_example_pat]. + 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). + In the GADT mode, [env] may be extended by unification, + and therefore it needs to be saved along with a [snapshot]. *) +type unification_state = + { snapshot: snapshot; + env: Env.t; } +let save_state penv = + { snapshot = Btype.snapshot (); + env = !!penv; } +let set_state s penv = + Btype.backtrack s.snapshot; + Pattern_env.set_env penv 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.pat_desc with + | Tpat_or(p1,p2,_) -> + (try find_valid_alternative f p1 with + | Empty_branch | Error _ -> find_valid_alternative f p2 + ) + | _ -> f pat + +let no_explosion info = { info with explosion_fuel = 0 } + +let enter_nonsplit_or 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 { info with splitting_mode } + +let rec check_counter_example_pat + ~info ~(penv : Pattern_env.t) type_pat_state tp expected_ty k = + let check_rec ?(info=info) ?(penv=penv) = + check_counter_example_pat ~info ~penv type_pat_state in + let loc = tp.pat_loc in + let refine = true in + let solve_expected (x : pattern) : pattern = + unify_pat_types_refine ~refine x.pat_loc penv x.pat_type + (instance expected_ty); + x + in + (* "make pattern" and "make pattern then continue" *) + let mp ?(pat_type = expected_ty) desc = + { pat_desc = desc; pat_loc = loc; pat_extra=[]; + pat_type = instance pat_type; pat_attributes = []; pat_env = !!penv } in + let mkp k ?pat_type desc = k (mp ?pat_type desc) in + let must_backtrack_on_gadt = + match info.splitting_mode with + | Backtrack_or -> false + | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or + in + match tp.pat_desc with + Tpat_any | Tpat_var _ -> + let k' () = mkp k tp.pat_desc in + if info.explosion_fuel <= 0 then k' () else + let decrease n = {info with explosion_fuel = info.explosion_fuel - n} in + begin match Parmatch.pats_of_type !!penv expected_ty with + | [] -> raise Empty_branch + | [{pat_desc = Tpat_any}] -> k' () + | [tp] -> check_rec ~info:(decrease 1) tp expected_ty k + | tp :: tpl -> + if must_backtrack_on_gadt then raise Need_backtrack; + let tp = + List.fold_left + (fun tp tp' -> {tp with pat_desc = Tpat_or (tp, tp', None)}) + tp tpl + in + check_rec ~info:(decrease 5) tp expected_ty k + end + | Tpat_alias (p, _, _, _) -> check_rec ~info p expected_ty k + | Tpat_constant cst -> + let cst = constant_or_raise !!penv loc (Untypeast.constant cst) in + k @@ solve_expected (mp (Tpat_constant cst) ~pat_type:(type_constant cst)) + | Tpat_tuple tpl -> + assert (List.length tpl >= 2); + let expected_tys = solve_Ppat_tuple ~refine loc penv tpl expected_ty in + let tpl_ann = List.combine tpl expected_tys in + map_fold_cont (fun (p,t) -> check_rec p t) tpl_ann (fun pl -> + mkp k (Tpat_tuple pl) + ~pat_type:(newty (Ttuple(List.map (fun p -> p.pat_type) pl)))) + | Tpat_construct(cstr_lid, constr, targs, _) -> + if constr.cstr_generalized && must_backtrack_on_gadt then + raise Need_backtrack; + let (ty_args, existential_ctyp) = + solve_Ppat_construct + ~refine type_pat_state penv loc constr None None expected_ty + in + map_fold_cont + (fun (p,t) -> check_rec p t) + (List.combine targs ty_args) + (fun args -> + mkp k (Tpat_construct(cstr_lid, constr, args, existential_ctyp))) + | Tpat_variant(tag, targ, _) -> + let constant = (targ = None) in + let arg_type, row, pat_type = + solve_Ppat_variant ~refine loc penv tag constant expected_ty in + let k arg = + mkp k ~pat_type (Tpat_variant(tag, arg, ref row)) + in begin + (* PR#6235: propagate type information *) + match targ, arg_type with + Some p, [ty] -> check_rec p ty (fun p -> k (Some p)) + | _ -> k None + end + | Tpat_record(fields, closed) -> + let record_ty = generic_instance expected_ty in + let type_label_pat (label_lid, label, targ) k = + let ty_arg = + solve_Ppat_record_field ~refine loc penv label label_lid record_ty in + check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) + in + map_fold_cont type_label_pat fields + (fun fields -> mkp k (Tpat_record (fields, closed))) + | Tpat_array tpl -> + let ty_elt = solve_Ppat_array ~refine loc penv expected_ty in + map_fold_cont (fun p -> check_rec p ty_elt) tpl + (fun pl -> mkp k (Tpat_array pl)) + | Tpat_or(tp1, tp2, _) -> + (* We are in counter-example mode, but try to avoid backtracking *) + let must_split = + match info.splitting_mode with + | Backtrack_or -> true + | Refine_or _ -> false in + let state = save_state penv in + let split_or tp = + let type_alternative pat = + set_state state penv; check_rec pat expected_ty k in + find_valid_alternative type_alternative tp + in + if must_split then split_or tp else + let check_rec_result penv tp : (_, abort_reason) result = + let info = enter_nonsplit_or info in + match check_rec ~info tp expected_ty ~penv (fun x -> x) with + | res -> Ok res + | exception Need_backtrack -> Error Adds_constraints + | exception Empty_branch -> Error Empty + in + let p1 = check_rec_result (Pattern_env.copy penv) tp1 in + let p2 = check_rec_result (Pattern_env.copy penv) tp2 in + 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 info.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 tp + | Ok p, Error _ + | Error _, Ok p -> + k p + | Ok p1, Ok p2 -> + mkp k (Tpat_or (p1, p2, None)) + end + | Tpat_lazy tp1 -> + let nv = solve_Ppat_lazy ~refine loc penv expected_ty in + (* do not explode under lazy: PR#7421 *) + check_rec ~info:(no_explosion info) tp1 nv + (fun p1 -> mkp k (Tpat_lazy p1)) + +let check_counter_example_pat ~counter_example_args penv tp expected_ty = + (* [check_counter_example_pat] doesn't use [type_pat_state] in an interesting + way -- one of the functions it calls writes an entry into + [tps_pattern_forces] -- so we can just ignore module patterns. *) + let type_pat_state = create_type_pat_state Modules_ignored in + check_counter_example_pat + ~info:counter_example_args ~penv type_pat_state tp 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 p = + let penv = Pattern_env.make env + ~equations_scope:lev ~allow_recursive_equations:true in + let state = save_state penv in + let counter_example_args = + { + splitting_mode; + explosion_fuel = explode; + } in + try + let typed_p = + check_counter_example_pat ~counter_example_args penv p expected_ty + in + set_state state penv; + (* types are invalidated but we don't need them here *) + Some typed_p + with Error _ | Empty_branch -> + set_state state penv; + 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 pat -> + match + partial_pred ~lev ~splitting_mode:Backtrack_or ~explode:5 + env expected_ty pat + with + Some pat' when refute -> + raise (Error (pat.pat_loc, env, Unrefuted_pattern pat')) + | r -> r) + cases + +(** Some delayed checks, to be executed after typing the whole + compilation unit or toplevel phrase *) +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) -> Btype.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 _ | Tmod_apply_unit _ -> false + +and is_nonexpansive_opt = function + | None -> true + | Some e -> is_nonexpansive e + +let maybe_expansive e = not (is_nonexpansive e) + +let annotate_recursive_bindings env valbinds = + let ids = let_bound_idents valbinds in + List.map + (fun {vb_pat; vb_expr; vb_rec_kind = _; vb_attributes; vb_loc} -> + match (Value_rec_check.is_valid_recursive_expression ids vb_expr) with + | None -> + raise(Error(vb_expr.exp_loc, env, Illegal_letrec_expr)) + | Some vb_rec_kind -> + { vb_pat; vb_expr; vb_rec_kind; vb_attributes; vb_loc}) + valbinds + +let check_recursive_class_bindings env ids exprs = + List.iter + (fun expr -> + if not (Value_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, commu_ok)) + | 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 type_pattern_approx env spat = + match spat.ppat_desc with + | Ppat_constraint (_, sty) -> approx_type env sty + | _ -> newvar () + +let type_approx_fun env label default spat ret_ty = + let ty = type_pattern_approx env spat in + let ty = + match label, default with + | (Nolabel | Labelled _), _ -> ty + | Optional _, None -> + unify_pat_types spat.ppat_loc env ty (type_option (newvar ())); + ty + | Optional _, Some _ -> + type_option ty + in + newty (Tarrow (label, ty, ret_ty, commu_ok)) + +let type_approx_constraint env ty constraint_ ~loc = + match constraint_ with + | Pconstraint constrain -> + let ty_constrain = approx_type env constrain in + begin try unify env ty ty_constrain with Unify err -> + raise (Error (loc, env, Expr_type_clash (err, None, None))) + end; + ty_constrain + | Pcoerce (constrain, coerce) -> + let approx_ty_opt = function + | None -> newvar () + | Some sty -> approx_type env sty + in + let ty_constrain = approx_ty_opt constrain + and ty_coerce = approx_type env coerce in + begin try unify env ty ty_constrain with Unify err -> + raise (Error (loc, env, Expr_type_clash (err, None, None))) + end; + ty_coerce + +let type_approx_constraint_opt env ty constraint_ ~loc = + match constraint_ with + | None -> ty + | Some constraint_ -> type_approx_constraint env ty constraint_ ~loc + +let rec type_approx env sexp = + let loc = sexp.pexp_loc in + match sexp.pexp_desc with + Pexp_let (_, _, e) -> type_approx env e + | Pexp_function (params, c, body) -> + type_approx_function env params c body ~loc + | 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 + type_approx_constraint env ty (Pconstraint sty) ~loc + | Pexp_coerce (e, sty1, sty2) -> + let ty = type_approx env e in + type_approx_constraint env ty (Pcoerce (sty1, sty2)) ~loc + | _ -> newvar () + +and type_approx_function env params c body ~loc = + (* We can approximate types up to the first newtype parameter, whereupon + we give up. + *) + match params with + | { pparam_desc = Pparam_val (label, default, pat) } :: params -> + type_approx_fun env label default pat + (type_approx_function env params c body ~loc) + | { pparam_desc = Pparam_newtype _ } :: _ -> + newvar () + | [] -> + let body_ty = + match body with + | Pfunction_body body -> + type_approx env body + | Pfunction_cases ({pc_rhs = e} :: _, _, _) -> + newty (Tarrow (Nolabel, newvar (), type_approx env e, commu_ok)) + | Pfunction_cases ([], _, _) -> + newvar () + in + type_approx_constraint_opt env body_ty c ~loc + +(* 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 TypeSet.mem ty visited then + List.rev ls, false + else match get_desc ty with + Tarrow (l, _, ty_res, _) -> + list_labels_aux env (TypeSet.add 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 TypeSet.empty []) 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 + let exp_ty, vars = + with_local_level_iter ~post:generalize begin fun () -> + match get_desc pty with + Tpoly (body, tl) -> + (* Enforce scoping for type_let: + since body is not generic, instance_poly only makes + copies of nodes that have a Tunivar as descendant *) + let _, ty' = instance_poly ~fixed: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), exp_ty::vars) + | _ -> assert false + end + in + 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.unification_error + ~trace:[Ctype.expanded_diff env + ~got:ty ~expected: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 + +(* [check_statement] implements the [non-unit-statement] check. + + This check is called in contexts where the value of the expression is known + to be discarded (eg. the lhs of a sequence). We check that [exp] has type + unit, or has an explicit type annotation; otherwise we raise the + [non-unit-statement] warning. *) + +let check_statement exp = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () + | Tvar _ -> () + | _ -> + 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 + + +(* [check_partial_application] implements the [ignored-partial-application] + warning (and if [statement] is [true], also [non-unit-statement]). + + If [exp] has a function type, we check that it is not syntactically the + result of a function application, as this is often a bug in certain contexts + (eg the rhs of a let-binding or in the argument of [ignore]). For example, + [ignore (List.map print_int)] written by mistake instead of [ignore (List.map + print_int li)]. + + The check can be disabled by explicitly annotating the expression with a type + constraint, eg [(e : _ -> _)]. + + If [statement] is [true] and the [ignored-partial-application] is {em not} + triggered, then the [non-unit-statement] check is performed (see + [check_statement]). + + If the type of [exp] is not known at the time this function is called, the + check is retried again after typechecking. *) + +let check_partial_application ~statement exp = + let check_statement () = if statement then check_statement exp in + let doit () = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty 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 + | _ -> + check_statement () + in + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tvar _ -> + (* The type of [exp] is not known. Delay the check until after + typechecking in order to give a chance for the type to become known + through unification. *) + add_delayed_check doit + | _ -> + doit () + +let pattern_needs_partial_application_check p = + let rec check : type a. a general_pattern -> bool = fun p -> + not (List.exists (function (Tpat_constraint _, _, _) -> true | _ -> false) + p.pat_extra) && + match p.pat_desc with + | Tpat_any -> true + | Tpat_exception _ -> true + | Tpat_or (p1, p2, _) -> check p1 && check p2 + | Tpat_value p -> check (p :> value general_pattern) + | _ -> false + in + check p + +(* Check that a type is generalizable at some level *) +let generalizable level ty = + let rec check ty = + if not_marked_node ty then + if get_level ty <= 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 = + if try_mark_node ty then + begin match get_desc ty with + Tvariant row -> + if not (is_fixed row) then + List.iter + (fun (_,f) -> + match row_field_repr f with Reither _ -> raise Exit | _ -> ()) + (row_fields row); + 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 + +(* There are various things that we need to do in presence of module patterns + that aren't required if there are none. Most notably, we need to ensure the + modules are entered at the appropriate scope. The caller should use + [may_contain_modules] as an indication to set up the proper scope handling + code (via [allow_modules]) to permit module patterns. + The class of patterns identified here should stay in sync with the patterns + whose typing involves [enter_variable ~is_module:true], as these calls + will error if the scope handling isn't set up. +*) +let may_contain_modules p = + exists_ppat + (function + | {ppat_desc = Ppat_unpack _} -> 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 in + if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent) + (row_fields row) + || 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 fields = [s, rf_either ty_arg ~no_arg:(arg=None) ~matched:true] in + let row' = + create_row ~fields + ~more:(newvar ()) ~closed:false ~fixed:None ~name:None in + (* Should fail *) + unify_pat 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 *) + +(** [sdesc_for_hint] is used by error messages to report literals in their + original formatting *) +let unify_exp ?sdesc_for_hint 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(err, tfc, None)) -> + raise (Error(loc, env, Expr_type_clash(err, tfc, sdesc_for_hint))) + +(* 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 get_desc typ with + | Tarrow (Nolabel,a,b,_) -> + begin match get_desc b with + | Tarrow(Nolabel,c,d,_) -> + let f, x, res = + match prim with + | Apply -> a, c, d + | Revapply -> c, a, d + in + begin match get_desc f with + | Tarrow(Nolabel,fl,fr,_) -> + is_Tvar fl && is_Tvar fr && is_Tvar x && is_Tvar res + && Types.eq_type fl x && Types.eq_type 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(err', None, exp')) + when not loc'.Location.loc_ghost -> + let err = Expr_type_clash(err', Some explanation, exp') in + raise (Error (loc', env', err)) + +(* Generalize expressions *) +let generalize_structure_exp exp = generalize_structure exp.exp_type +let may_lower_contravariant_then_generalize env exp = + if maybe_expansive exp then lower_contravariant env exp.exp_type; + generalize exp.exp_type + +(* value binding elaboration *) + +let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; _ } = + let open Ast_helper in + match ct with + | None -> expr + | Some (Pvc_constraint { locally_abstract_univars=[]; typ }) -> + begin match typ.ptyp_desc with + | Ptyp_poly _ -> expr + | _ -> + let loc = { expr.pexp_loc with Location.loc_ghost = true } in + Exp.constraint_ ~loc expr typ + end + | Some (Pvc_coercion { ground; coercion}) -> + let loc = { expr.pexp_loc with Location.loc_ghost = true } in + Exp.coerce ~loc expr ground coercion + | Some (Pvc_constraint { locally_abstract_univars=vars;typ}) -> + let loc_start = pat.ppat_loc.Location.loc_start in + let loc = { expr.pexp_loc with loc_start; loc_ghost=true } in + let expr = Exp.constraint_ ~loc expr typ in + List.fold_right (Exp.newtype ~loc) vars expr + +let vb_pat_constraint ({pvb_pat=pat; pvb_expr = exp; _ } as vb) = + vb.pvb_attributes, + let open Ast_helper in + match vb.pvb_constraint, pat.ppat_desc, exp.pexp_desc with + | Some (Pvc_constraint {locally_abstract_univars=[]; typ} + | Pvc_coercion { coercion=typ; _ }), + _, _ -> + Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat typ + | Some (Pvc_constraint {locally_abstract_univars=vars; typ }), _, _ -> + let varified = Typ.varify_constructors vars typ in + let t = Typ.poly ~loc:typ.ptyp_loc vars varified in + let loc_end = typ.ptyp_loc.Location.loc_end in + let loc = { pat.ppat_loc with loc_end; loc_ghost=true } in + Pat.constraint_ ~loc pat t + | None, (Ppat_any | Ppat_constraint _), _ -> pat + | None, _, Pexp_coerce (_, _, sty) + | None, _, Pexp_constraint (_, sty) when !Clflags.principal -> + (* propagate type annotation to pattern, + to allow it to be generalized in -principal mode *) + Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat sty + | _ -> pat + +(** The body of a constraint or coercion. The "body" may be either an expression + or a list of function cases. This type is polymorphic in the data returned + out of typing so that typing an expression body can return an expression + and typing a function cases body can return the cases. +*) +type 'ret constraint_arg = + { type_without_constraint: Env.t -> 'ret * type_expr; + (** [type_without_constraint] types a body (e :> t) where there is no + constraint. + *) + type_with_constraint: Env.t -> type_expr -> 'ret; + (** [type_with_constraint] types a body (e : t) or (e : t :> t') in + the presence of a constraint. + *) + is_self: 'ret -> bool; + (** Whether the thing being constrained is a [Val_self] ident. *) + } + +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, structural nodes of [type_expected_explained] may be + at [generic_level] (but its variables no higher than [!current_level]). + *) + +and type_expect ?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_ ?recarg env sexp ty_expected_explained + ) + in + Cmt_format.set_saved_types + (Cmt_format.Partial_expression exp :: previous_saved_types); + exp + +and type_expect_ + ?(recarg=Rejected) + env sexp ty_expected_explained = + let { ty = ty_expected; explanation } = ty_expected_explained in + let loc = sexp.pexp_loc in + let desc = sexp.pexp_desc in + (* Record the expression type before unifying it with the expected type *) + let with_explanation = with_explanation explanation in + (* Unify the result with [ty_expected], enforcing the current level *) + let rue exp = + with_explanation (fun () -> + unify_exp ~sdesc_for_hint:desc env (re exp) (instance ty_expected)); + exp + in + match 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 (protect_expansion env ty_expected) in + let fmt6_path = + Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"), + "format6")) + in + let is_format = match get_desc ty_exp with + | Tconstr(path, _, _) when Path.same path fmt6_path -> + if !Clflags.principal && get_level ty_exp <> 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 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_attributes=[]; _ } as vb], sbody) + when may_contain_gadts spat -> + (* TODO: allow non-empty attributes? *) + let sval = vb_exp_constraint vb in + type_expect 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 may_contain_modules = + List.exists (fun pvb -> may_contain_modules pvb.pvb_pat) spat_sexp_list + in + let outer_level = get_current_level () in + let (pat_exp_list, body, _new_env) = + (* If the patterns contain module unpacks, there is a possibility that + the types of the let body or bound expressions mention types + introduced by those unpacks. The below code checks for scope escape + via both of these pathways (body, bound expressions). + *) + with_local_level_if may_contain_modules begin fun () -> + let allow_modules = + if may_contain_modules + then + let scope = create_scope () in + Modules_allowed { scope } + else Modules_rejected + in + let (pat_exp_list, new_env) = + type_let existential_context env rec_flag spat_sexp_list + allow_modules + in + let body = type_expect new_env sbody ty_expected_explained in + let pat_exp_list = match rec_flag with + | Recursive -> annotate_recursive_bindings env pat_exp_list + | Nonrecursive -> pat_exp_list + in + (* The "bound expressions" component of the scope escape check. + + This kind of scope escape is relevant only for recursive + module definitions. + *) + if rec_flag = Recursive && may_contain_modules then begin + List.iter + (fun vb -> + (* [type_let] already generalized bound expressions' types + in-place. We first take an instance before checking scope + escape at the outer level to avoid losing generality of + types added to [new_env]. + *) + let bound_exp = vb.vb_expr in + generalize_structure_exp bound_exp; + let bound_exp_type = Ctype.instance bound_exp.exp_type in + let loc = proper_exp_loc bound_exp in + let outer_var = newvar2 outer_level in + (* Checking unification within an environment extended with the + module bindings allows us to correctly accept more programs. + This environment allows unification to identify more cases + where a type introduced by the module is equal to a type + introduced at an outer scope. *) + unify_exp_types loc new_env bound_exp_type outer_var) + pat_exp_list + end; + (pat_exp_list, body, new_env) + end + ~post:(fun (_pat_exp_list, body, new_env) -> + (* The "body" component of the scope escape check. *) + unify_exp new_env body (newvar ())) + 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_function (params, body_constraint, body) -> + let in_function = ty_expected_explained, loc in + let exp_type, params, body, newtypes, contains_gadt = + type_function env params body_constraint body ty_expected ~in_function + ~first:true + in + (* Require that the n-ary function is known to have at least n arrows + in the type. This prevents GADT equations introduced by the parameters + from hiding arrows from the resulting type. + + Performance hack: Only do this check when any of [params] contains a + GADT, as this is the only opportunity for arrows to be hidden from the + resulting type. + *) + begin match contains_gadt with + | No_gadt -> () + | Contains_gadt -> + let ty_function = + List.fold_right + (fun param rest_ty -> + newty + (Tarrow (param.fp_arg_label, newvar (), rest_ty, commu_ok))) + params + (match body with + | Tfunction_body _ -> newvar () + | Tfunction_cases _ -> + newty (Tarrow (Nolabel, newvar (), newvar (), commu_ok))) + in + try unify env ty_function exp_type + with Unify trace -> + let syntactic_arity = + List.length params + + (match body with + | Tfunction_body _ -> 0 + | Tfunction_cases _ -> 1) + in + let err = + Function_arity_type_clash + { syntactic_arity; + type_constraint = exp_type; + trace; + } + in + raise (Error (loc, env, err)) + end; + re + { exp_desc = Texp_function (params, body); + exp_loc = loc; + exp_extra = + List.map (fun { txt; loc } -> Texp_newtype txt, loc, []) newtypes; + exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_apply(sfunct, sargs) -> + assert (sargs <> []); + let rec lower_args seen ty_fun = + let ty = expand_head env ty_fun in + if TypeSet.mem ty seen then () else + match get_desc ty with + Tarrow (_l, ty_arg, ty_fun, _com) -> + (try enforce_current_level env ty_arg + with Unify _ -> assert false); + lower_args (TypeSet.add ty seen) ty_fun + | _ -> () + in + let type_sfunct sfunct = + (* one more level for warning on non-returning functions *) + with_local_level_iter + begin fun () -> + let funct = + with_local_level_if_principal (fun () -> type_exp env sfunct) + ~post: generalize_structure_exp + in + let ty = instance funct.exp_type in + (funct, [ty]) + end + ~post:(wrap_trace_gadt_instances env (lower_args TypeSet.empty)) + 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 + let (args, ty_res) = type_application env funct sargs in + 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) -> + let arg = + with_local_level (fun () -> type_exp env sarg) + ~post:(may_lower_contravariant_then_generalize env) + in + let cases, partial = + type_cases Computation env + arg.exp_type ty_expected_explained + ~check_if_total:true loc caselist in + if + List.for_all (fun c -> pattern_needs_partial_application_check c.c_lhs) + cases + then check_partial_application ~statement:false arg; + 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 + ~check_if_total: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_expected1 = protect_expansion env ty_expected in + let ty_expected0 = instance ty_expected in + begin try match + sarg, get_desc (expand_head env ty_expected1), + get_desc (expand_head env ty_expected0) + with + | Some sarg, Tvariant row, Tvariant row0 -> + begin match + row_field_repr (get_row_field l row), + row_field_repr (get_row_field l row0) + 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 Exit + end + | _ -> raise Exit + with Exit -> + let arg = Option.map (type_exp env) sarg in + let arg_type = Option.map (fun arg -> arg.exp_type) arg in + let row = + create_row + ~fields: [l, rf_present arg_type] + ~more: (newvar ()) + ~closed: false + ~fixed: None + ~name: None + in + rue { + exp_desc = Texp_variant(l, arg); + exp_loc = loc; exp_extra = []; + exp_type = newty (Tvariant row); + 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 -> + let exp = + with_local_level_if_principal + (fun () -> type_exp ~recarg env sexp) + ~post: generalize_structure_exp + in + Some exp + in + let ty_record, expected_type = + let expected_opath = + match extract_concrete_record env ty_expected with + | Record_type (p0, p, _) -> Some (p0, p, is_principal ty_expected) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = + Wrong_expected_kind(Record, Expression explanation, ty_expected) + in + raise (Error (loc, env, error)) + in + let opt_exp_opath = + match opt_exp with + | None -> None + | Some exp -> + match extract_concrete_record env exp.exp_type with + | Record_type (p0, p, _) -> Some (p0, p, is_principal exp.exp_type) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type exp.exp_type in + raise (Error (exp.exp_loc, env, error)) + in + match expected_opath, opt_exp_opath with + | None, None -> newvar (), None + | Some _, None -> ty_expected, expected_opath + | Some(_, _, true), Some _ -> ty_expected, expected_opath + | (None | Some (_, _, false)), Some (_, p', _) -> + let decl = Env.find_type p' env in + let ty = + with_local_level ~post:generalize_structure + (fun () -> newconstr p' (instance_list decl.type_params)) + in + ty, opt_exp_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 + (type_label_exp true env loc ty_record) + expected_type) + lid_sexp_list + 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 ~fixed: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 ~fixed: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, lbl.lbl_mut) + 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 ~fixed: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 exp_type = + match cond.exp_desc with + | Texp_construct(_, {cstr_name="true"}, _) -> instance ty_expected + | _ -> instance Predef.type_unit + 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; + 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) -> + let (ty, exp_extra) = type_constraint env sty in + let arg = type_argument env sarg ty (instance ty) in + rue { + exp_desc = arg.exp_desc; + exp_loc = arg.exp_loc; + exp_type = instance ty; + exp_attributes = arg.exp_attributes; + exp_env = env; + exp_extra = (exp_extra, loc, sexp.pexp_attributes) :: arg.exp_extra; + } + | Pexp_coerce(sarg, sty, sty') -> + let arg, ty', exp_extra = + type_coerce (expression_constraint sarg) env loc sty sty' + ~loc_arg:sarg.pexp_loc + 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 = (exp_extra, loc, sexp.pexp_attributes) :: arg.exp_extra; + } + | Pexp_send (e, {txt=met}) -> + let (obj,meth,typ) = + with_local_level_if_principal + (fun () -> type_send env loc explanation e met) + ~post:(fun (_,_,typ) -> generalize_structure typ) + in + let typ = + match get_desc typ with + | Tpoly (ty, []) -> + instance ty + | Tpoly (ty, tl) -> + if !Clflags.principal && get_level typ <> generic_level then + Location.prerr_warning loc + (Warnings.Not_principal "this use of a polymorphic method"); + snd (instance_poly ~fixed:false tl ty) + | Tvar _ -> + let ty' = newvar () in + unify env (instance typ) (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_loc = loc; exp_extra = []; + exp_type = typ; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | 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 (sign, _, vars, _)}), + (path_self, _) -> + let type_override (lab, snewval) = + begin try + let id = Vars.find lab.txt vars in + let ty = Btype.instance_variable_type lab.txt sign in + (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 lv = get_current_level () in + let (id, pres, modl, _, body) = + with_local_level begin fun () -> + let modl, pres, id, new_env = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + let modl, md_shape = !type_module env smodl in + Mtype.lower_nongen lv modl.mod_type; + let pres = + match modl.mod_type with + | Mty_alias _ -> Mp_absent + | _ -> Mp_present + in + let scope = create_scope () in + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let md_shape = Shape.set_uid_if_none md_shape md_uid in + let md = + { md_type = modl.mod_type; md_attributes = []; + md_loc = name.loc; + md_uid; } + in + let (id, new_env) = + match name.txt with + | None -> None, env + | Some name -> + let id, env = + Env.enter_module_declaration + ~scope ~shape:md_shape name pres md env + in + Some id, env + in + modl, pres, id, new_env + end + 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 new_env sbody ty_expected_explained in + (id, pres, modl, new_env, body) + end + ~post: begin fun (_id, _pres, _modl, new_env, body) -> + (* Ensure that local definitions do not leak. *) + (* required for implicit unpack *) + enforce_current_level new_env body.exp_type + end + in + re { + exp_desc = Texp_letmodule(id, name, pres, modl, body); + exp_loc = loc; exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Pexp_letexception(cd, sbody) -> + let (cd, newenv, _shape) = 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 + let rec innermost_location loc_stack = + match loc_stack with + | [] -> loc + | [l] -> l + | _ :: s -> innermost_location s + in + rue { + exp_desc = Texp_assert (cond, innermost_location sexp.pexp_loc_stack); + 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, meths = !type_object env loc s in + rue { + exp_desc = Texp_object (desc, meths); + exp_loc = loc; exp_extra = []; + exp_type = desc.cstr_type.csig_self; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_poly(sbody, sty) -> + let ty, cty = + with_local_level_if_principal + ~post:(fun (ty,_) -> generalize_structure ty) + begin fun () -> + match sty with None -> protect_expansion env ty_expected, None + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = Typetexp.transl_simple_type env ~closed:false sty in + cty.ctyp_type, Some cty + end + in + if sty <> None then + with_explanation (fun () -> + unify_exp_types loc env (instance ty) (instance ty_expected)); + let exp = + match get_desc (expand_head env ty) 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 *) + let (exp,_) = + with_local_level begin fun () -> + let vars, ty'' = + with_local_level_if_principal + (fun () -> instance_poly ~fixed:true tl ty') + ~post:(fun (_,ty'') -> generalize_structure ty'') + in + let exp = type_expect env sbody (mk_expected ty'') in + (exp, vars) + end + ~post: begin fun (exp,vars) -> + generalize_and_check_univars env "method" exp ty_expected vars + end + in + { 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 body, ety = type_newtype loc env name (fun env -> + let expr = type_exp env sbody in + expr, expr.exp_type) + in + (* 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 get_desc (Ctype.expand_head env (instance ty_expected)) with + Tpackage (p, fl) -> + if !Clflags.principal && + get_level (Ctype.expand_head env + (protect_expansion env ty_expected)) + < Btype.generic_level + then + Location.prerr_warning loc + (Warnings.Not_principal "this module packing"); + (p, fl) + | 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 + let op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops = + with_local_level_iter_if_principal + ~post:generalize_structure begin fun () -> + 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, commu_ok)) 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, commu_ok)), commu_ok)) + in + begin try + unify env op_type ty_op + with Unify err -> + raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err))) + end; + ((op_path, op_desc, op_type, spat_params, ty_params, + ty_func_result, ty_result, ty_andops), + [ty_andops; ty_params; ty_func_result; ty_result]) + end + in + 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) + ~check_if_total: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 expression_constraint pexp = + { type_without_constraint = (fun env -> + let expr = type_exp env pexp in + expr, expr.exp_type); + type_with_constraint = + (fun env ty -> type_argument env pexp ty (instance ty)); + is_self = + (fun expr -> + match expr.exp_desc with + | Texp_ident (_, _, { val_kind = Val_self _ }) -> true + | _ -> false); + } + +(** Types a body in the scope of a coercion (with an optional constraint) + and returns the inferred type. See the comment on {!constraint_arg} for + an explanation of how this typechecking is polymorphic in the body. +*) +and type_coerce + : type a. a constraint_arg -> _ -> _ -> _ -> _ -> loc_arg:_ + -> a * type_expr * exp_extra = + fun constraint_arg env loc sty sty' ~loc_arg -> + (* 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 { is_self; type_with_constraint; type_without_constraint } = + constraint_arg + in + match sty with + | None -> + let (cty', ty', force) = + Typetexp.transl_simple_type_delayed env sty' + in + let arg, arg_type, gen = + let lv = get_current_level () in + with_local_level begin fun () -> + let arg, arg_type = type_without_constraint env in + arg, arg_type, generalizable lv arg_type + end + ~post:(fun (_, arg_type, _) -> enforce_current_level env arg_type) + in + begin match !self_coercion, get_desc ty' with + | ((path, r) :: _, Tconstr (path', _, _)) + when is_self arg && Path.same path path' -> + (* prerr_endline "self coercion"; *) + r := loc :: !r; + force () + | _ when free_variables ~env arg_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_type ty; true + with Unify _ -> + backtrack snap; false + then () + else begin try + let force' = subtype env arg_type ty' in + force (); force' (); + if not gen && !Clflags.principal then + Location.prerr_warning loc + (Warnings.Not_principal "this ground coercion"); + with Subtype err -> + (* prerr_endline "coercion failed"; *) + raise (Error (loc, env, Not_subtype err)) + end; + | _ -> + let ty, b = enlarge_type env ty' in + force (); + begin try Ctype.unify env arg_type ty with Unify err -> + let expanded = full_expand ~may_forget_scope:true env ty' in + raise(Error(loc_arg, env, + Coercion_failure ({ ty = ty'; expanded }, err, b))) + end + end; + (arg, ty', Texp_coerce (None, cty')) + | Some sty -> + let cty, ty, force, cty', ty', force' = + with_local_level_iter ~post:generalize_structure begin fun () -> + let (cty, ty, force) = + Typetexp.transl_simple_type_delayed env sty + and (cty', ty', force') = + Typetexp.transl_simple_type_delayed env sty' + in + ((cty, ty, force, cty', ty', force'), + [ ty; ty' ]) + end + in + begin try + let force'' = subtype env (instance ty) (instance ty') in + force (); force' (); force'' () + with Subtype err -> + raise (Error (loc, env, Not_subtype err)) + end; + (type_with_constraint env ty, + instance ty', Texp_coerce (Some cty, cty')) + +and type_constraint env sty = + (* Pretend separate = true, 1% slowdown for lablgtk *) + let cty = + with_local_level begin fun () -> + Typetexp.transl_simple_type env ~closed:false sty + end + ~post:(fun cty -> generalize_structure cty.ctyp_type) + in + cty.ctyp_type, Texp_constraint cty + +(** Types a body in the scope of a coercion (:>) or a constraint (:), and + unifies the inferred type with the expected type. + + @param loc the location of the overall constraint + @param loc_arg the location of the thing being constrained +*) +and type_constraint_expect + : type a. a constraint_arg -> _ -> _ -> loc_arg:_ -> _ -> _ -> a * _ * _ = + fun constraint_arg env loc ~loc_arg constraint_ ty_expected -> + let ret, ty, exp_extra = + match constraint_ with + | Pcoerce (ty_constrain, ty_coerce) -> + type_coerce constraint_arg env loc ty_constrain ty_coerce ~loc_arg + | Pconstraint ty_constrain -> + let ty, exp_extra = type_constraint env ty_constrain in + constraint_arg.type_with_constraint env ty, ty, exp_extra + in + unify_exp_types loc env ty (instance ty_expected); + ret, ty, exp_extra + +(** Typecheck the body of a newtype. The "body" of a newtype may be: + - an expression + - a suffix of function parameters together with a function body + That's why this function is polymorphic over the body. + + @param type_body A function that produces a type for the body given the + environment. When typechecking an expression, this is [type_exp]. + @return The type returned by [type_body] but with the Tconstr + nodes for the newtype properly linked. +*) +and type_newtype + : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr = + fun loc env name type_body -> + let ty = + if Typetexp.valid_tyvar_name name then + newvar ~name () + else + newvar () + in + (* Use [with_local_level] just for scoping *) + with_local_level begin fun () -> + (* Create a fake abstract type declaration for [name]. *) + let decl = new_local_type ~loc Definition in + let scope = create_scope () in + let (id, new_env) = Env.enter_type ~scope name decl env in + + let result, exp_type = type_body new_env 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 (get_id t) then () + else begin + Hashtbl.add seen (get_id t) (); + match get_desc t 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 exp_type in + replace ety; + (result, ety) + end + +and type_ident env ?(recarg=Rejected) lid = + let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in + let is_recarg = + match get_desc desc.val_type with + | Tconstr(p, _, _) -> Path.is_constructor_typath p + | _ -> false + in + begin match is_recarg, recarg, get_desc desc.val_type 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 + +(** Returns the argument type and then the return type. + + @param first Whether the parameter corresponding to the argument of + [ty_expected] is the first parameter to the (n-ary) function. This only + affects error messages. + @param in_function Information about the [Pexp_function] node that's in the + process of being typechecked (its overall type and its location). Again, + this is only used to improve error messages. +*) +and split_function_ty env ty_expected ~arg_label ~first ~in_function = + let { ty = ty_fun; explanation }, loc = in_function in + let separate = !Clflags.principal || Env.has_local_constraints env in + with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + let ty_arg, ty_res = + try filter_arrow env (instance ty_expected) arg_label + with Filter_arrow_failed err -> + let err = match err with + | Unification_error unif_err -> + Expr_type_clash (unif_err, explanation, None) + | Label_mismatch { got; expected; expected_type } -> + Abstract_wrong_label { got; expected; expected_type; explanation } + | Not_a_function -> + if first + then Not_a_function (ty_fun, explanation) + else Too_many_arguments (ty_fun, explanation) + in + raise (Error(loc, env, err)) + 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 + (ty_arg, ty_res), [ ty_arg; ty_res ] + end + +(* Typecheck parameters one at a time followed by the body. Later parameters + are checked in the scope of earlier ones. That's necessary to support + constructs like [fun (type a) (x : a) -> ...] and + [fun (module M : S) (x : M.t) -> ...]. + + Operates like [type_expect] in that it unifies the "type of the remaining + function params + body" with [ty_expected], and returns out the inferred + type. + + See [split_function_ty] for the meaning of [first] and [in_function]. + + Returns (inferred_ty, params, body, newtypes, contains_gadt), where: + - [newtypes] are the newtypes immediately bound by the prefix of function + parameters. These should be added to an [exp_extra] node. + - [contains_gadt] is whether any of [params] contains a GADT. Note + this does not indicate whether [body] contains a GADT (if it's + [Tfunction_cases]). +*) +and type_function + env params_suffix body_constraint body ty_expected ~first ~in_function + = + let ty_fun, (loc_function : Location.t) = in_function in + (* The "rest of the function" extends from the start of the first parameter + to the end of the overall function. The parser does not construct such + a location so we forge one for type errors. + *) + let loc : Location.t = + match params_suffix, body with + | param :: _, _ -> + { loc_start = param.pparam_loc.loc_start; + loc_end = loc_function.loc_end; + loc_ghost = true; + } + | [], Pfunction_body pexp -> pexp.pexp_loc + | [], Pfunction_cases (_, loc_cases, _) -> loc_cases + in + match params_suffix with + | { pparam_desc = Pparam_newtype newtype; pparam_loc = _ } :: rest -> + (* Check everything else in the scope of (type a). *) + let (params, body, newtypes, contains_gadt), exp_type = + type_newtype loc env newtype.txt (fun env -> + let exp_type, params, body, newtypes, contains_gadt = + (* mimic the typing of Pexp_newtype by minting a new type var, + like [type_exp]. + *) + type_function env rest body_constraint body (newvar ()) + ~first:false ~in_function + in + (params, body, newtypes, contains_gadt), exp_type) + in + with_explanation ty_fun.explanation (fun () -> + unify_exp_types loc env exp_type (instance ty_expected)); + exp_type, params, body, newtype :: newtypes, contains_gadt + | { pparam_desc = Pparam_val (arg_label, default_arg, pat); pparam_loc } + :: rest + -> + let ty_arg, ty_res = + split_function_ty env ty_expected ~arg_label ~first ~in_function + in + (* [ty_arg_internal] is the type of the parameter viewed internally + to the function. This is different than [ty_arg] exactly for + optional arguments with defaults, where the external [ty_arg] + is optional and the internal view is not optional. + *) + let ty_arg_internal, default_arg = + match default_arg with + | None -> ty_arg, None + | Some default -> + assert (is_optional arg_label); + let ty_default = newvar () in + begin + try unify env (type_option ty_default) ty_arg + with Unify _ -> assert false; + end; + (* Issue#12668: Retain type-directed disambiguation of + ?x:(y : Variant.t = Constr) + *) + let default = + match pat.ppat_desc with + | Ppat_constraint (_, sty) -> + let gloc = { default.pexp_loc with loc_ghost = true } in + Ast_helper.Exp.constraint_ default sty ~loc:gloc + | _ -> default + in + let default = type_expect env default (mk_expected ty_default) in + ty_default, Some default + in + let (pat, params, body, newtypes, contains_gadt), partial = + (* Check everything else in the scope of the parameter. *) + map_half_typed_cases Value env ty_arg_internal ty_res pat.ppat_loc + ~check_if_total:true + (* We don't make use of [case_data] here so we pass unit. *) + [ { pattern = pat; has_guard = false; needs_refute = false }, () ] + ~type_body:begin + fun () pat ~ext_env ~ty_expected ~ty_infer:_ + ~contains_gadt:param_contains_gadt -> + let _, params, body, newtypes, suffix_contains_gadt = + type_function ext_env rest body_constraint body + ty_expected ~first:false ~in_function + in + let contains_gadt = + if param_contains_gadt then + Contains_gadt + else + suffix_contains_gadt + in + (pat, params, body, newtypes, contains_gadt) + end + |> function + (* The result must be a singleton because we passed a singleton + list above. *) + | [ result ], partial -> result, partial + | ([] | _ :: _ :: _), _ -> assert false + in + let exp_type = + instance (newgenty (Tarrow (arg_label, ty_arg, ty_res, commu_ok))) + in + (* This is quadratic, as it operates over the entire tail of the + type for each new parameter. Now that functions are n-ary, we + could possibly run this once. + *) + with_explanation ty_fun.explanation (fun () -> + unify_exp_types loc env exp_type (instance ty_expected)); + (* This is quadratic, as it extracts all of the parameters from an arrow + type for each parameter that's added. Now that functions are n-ary, + there might be an opportunity to improve this. + *) + 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 + pat.pat_loc + Warnings.Unerasable_optional_argument; + let fp_kind, fp_param = + match default_arg with + | None -> + let param = name_pattern "param" [ pat ] in + Tparam_pat pat, param + | Some default_arg -> + let param = Ident.create_local "*opt*" in + Tparam_optional_default (pat, default_arg), param + in + let param = + { fp_kind; + fp_arg_label = arg_label; + fp_param; + fp_partial = partial; + fp_newtypes = newtypes; + fp_loc = pparam_loc; + } + in + exp_type, param :: params, body, [], contains_gadt + | [] -> + let exp_type, body = + match body with + | Pfunction_body body -> + let body = + match body_constraint with + | None -> type_expect env body (mk_expected ty_expected) + | Some constraint_ -> + let body_loc = body.pexp_loc in + let body, exp_type, exp_extra = + type_constraint_expect (expression_constraint body) + env body_loc ~loc_arg:body_loc constraint_ ty_expected + in + { body with + exp_extra = (exp_extra, body_loc, []) :: body.exp_extra; + exp_type; + } + in + body.exp_type, Tfunction_body body + | Pfunction_cases (cases, _, attributes) -> + let type_cases_expect env ty_expected = + type_function_cases_expect + env ty_expected loc cases attributes ~first ~in_function + in + let (cases, partial, exp_type), exp_extra = + match body_constraint with + | None -> type_cases_expect env ty_expected, None + | Some constraint_ -> + (* The typing of function case coercions/constraints is + analogous to the typing of expression coercions/constraints. + + - [type_with_constraint]: If there is a constraint, then call + [type_argument] on the cases, and discard the cases' + inferred type in favor of the constrained type. (Function + cases aren't inferred, so [type_argument] would just call + [type_expect] straightaway, so we do the same here.) + - [type_without_constraint]: If there is just a coercion and + no constraint, call [type_exp] on the cases and surface the + cases' inferred type to [type_constraint_expect]. *) + let function_cases_constraint_arg = + { is_self = (fun _ -> false); + type_with_constraint = (fun env ty -> + let cases, partial, _ = type_cases_expect env ty in + cases, partial); + type_without_constraint = (fun env -> + let cases, partial, ty_fun = + (* The analogy to [type_exp] for expressions. *) + type_cases_expect env (newvar ()) + in + (cases, partial), ty_fun); + } + in + let (cases, partial), exp_type, exp_extra = + type_constraint_expect function_cases_constraint_arg + env loc constraint_ ty_expected ~loc_arg:loc + in + (cases, partial, exp_type), Some exp_extra + in + let param = name_cases "param" cases in + let body = + Tfunction_cases + { cases; partial; param; loc; exp_extra; attributes } + in + exp_type, body + in + (* [No_gadt] is fine because this return value is only meant to indicate + whether [params] (here, the empty list) contains any GADT, not whether + the body is a [Tfunction_cases] whose patterns include a GADT. + *) + exp_type, [], body, [], No_gadt + + +and type_label_access env srecord usage lid = + let record = + with_local_level_if_principal ~post:generalize_structure_exp + (fun () -> type_exp ~recarg:Allowed env srecord) + in + let ty_exp = record.exp_type in + let expected_type = + match extract_concrete_record env ty_exp with + | Record_type(p0, p, _) -> + Some(p0, p, is_principal ty_exp) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type ty_exp in + raise (Error (record.exp_loc, env, error)) + 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 *) + let separate = !Clflags.principal || Env.has_local_constraints env in + (* #4682: we try two type-checking approaches for [arg] using backtracking: + - first try: we try with [ty_arg] as expected type; + - second try; if that fails, we backtrack and try without + *) + let (vars, ty_arg, snap, arg) = + (* try the first approach *) + with_local_level begin fun () -> + let (vars, ty_arg) = + with_local_level_iter_if separate begin fun () -> + let (vars, ty_arg, ty_res) = + with_local_level_iter_if separate ~post:generalize_structure + begin fun () -> + let ((_, ty_arg, ty_res) as r) = + instance_label ~fixed:true label in + (r, [ty_arg; ty_res]) + end + in + begin try + unify env (instance ty_res) (instance ty_expected) + with Unify err -> + raise (Error(lid.loc, env, Label_mismatch(lid.txt, err))) + end; + (* Instantiate so that we can generalize internal nodes *) + let ty_arg = instance ty_arg in + ((vars, ty_arg), [ty_arg]) + end + ~post:generalize_structure + in + + 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 snap = if vars = [] then None else Some (Btype.snapshot ()) in + let arg = type_argument env sarg ty_arg (instance ty_arg) in + (vars, ty_arg, snap, arg) + end + (* Note: there is no generalization logic here as could be expected, + because it is part of the backtracking logic below. *) + in + let arg = + try + if (vars = []) then arg + else begin + (* We detect if the first try failed here, + during generalization. *) + 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 first_try_exn when maybe_expansive arg -> try + (* backtrack and try the second approach *) + Option.iter Btype.backtrack snap; + let arg = with_local_level (fun () -> type_exp env sarg) + ~post:(fun arg -> lower_contravariant env arg.exp_type) + in + let arg = + with_local_level begin fun () -> + let arg = {arg with exp_type = instance arg.exp_type} in + unify_exp env arg (instance ty_arg); + arg + end + ~post: begin fun arg -> + generalize_and_check_univars env "field value" arg label.lbl_arg vars + end + in + {arg with exp_type = instance arg.exp_type} + with Error (_, _, Less_general _) as e -> raise e + | _ -> raise first_try_exn + 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 () = + let te = expand_head env ty_expected' in + match get_desc te with + Tarrow(Nolabel,_,ty_res0,_) -> + Some (no_labels ty_res0, get_level te) + | _ -> 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 *) + let texp = + with_local_level_if_principal ~post:generalize_structure_exp + (fun () -> type_exp env sarg) + in + let rec make_args args ty_fun = + match get_desc (expand_head env ty_fun) 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 || get_level ty_fun' <> generic_level) + and ty_fun = instance ty_fun' in + let ty_arg, ty_res = + match get_desc (expand_head env ty_expected) with + 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, desc.val_uid); + 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 cases_loc = { texp.exp_loc with loc_ghost = true } in + let param = name_cases "param" cases in + { texp with exp_type = ty_fun; exp_desc = + Texp_function ([], + Tfunction_cases + { cases; partial = Total; param; loc = cases_loc; + exp_extra = None; attributes = []; + }) + } + 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; vb_rec_kind = Not_recursive; + }], + 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 ~level:lv (Tarrow(l,ty,ty_fun,commu_ok))) + 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 get_desc ty_fun with + | Tvar _ -> + let t1 = newvar () and t2 = newvar () in + if get_level ty_fun >= get_level t1 && + 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,commu_var ()))); + (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 get_desc ty_res 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)) + | _ -> + let previous_arg_loc = + (* [typed_args] is the arguments typed until now, in reverse + order of appearance. Not all arguments have a location + attached (eg. an optional argument that is not passed). *) + typed_args + |> List.find_map + (function (_, Some (_, loc)) -> loc | _ -> None) + |> Option.value ~default:funct.exp_loc + in + raise(Error(funct.exp_loc, env, Apply_non_function { + funct; + func_ty = expand_head env funct.exp_type; + res_ty = expand_head env ty_res; + previous_arg_loc; + extra_arg_loc = sarg.pexp_loc; })) + 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, Some sarg.pexp_loc)) :: 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 + (* [args] remember the location of each argument in sources. *) + let rec type_args args ty_fun ty_fun0 sargs = + let type_unknown_args () = + (* 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, _loc) -> l, Some (f ())) + (List.rev typed_args) + in + let result_ty = instance (result_type !omitted_parameters ty_fun) in + args, result_ty + in + if sargs = [] then type_unknown_args () else + let ty_fun' = expand_head env ty_fun in + match get_desc ty_fun', get_desc (expand_head env ty_fun0) with + | Tarrow (l, ty, ty_fun, com), Tarrow (_, ty0, ty_fun0, _) + when is_commu_ok com -> + let lv = get_level ty_fun' in + 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' = + 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; + (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, Some (use_arg sarg l', Some sarg.pexp_loc)) + else if + optional && + not (List.exists (fun (l, _) -> name = label_name l) + remaining_sargs) && + List.exists (function (Nolabel, _) -> true | _ -> false) + sargs + then + (sargs, Some (eliminate_optional_arg (), Some sarg.pexp_loc)) + 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, Some (use_arg sarg l', Some sarg.pexp_loc) + | None -> + sargs, + if optional && List.mem_assoc Nolabel sargs then + Some (eliminate_optional_arg (), None) + 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 + | _ -> + type_unknown_args () + in + let is_ignore funct = + is_prim ~name:"%ignore" funct && + (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true + with Filter_arrow_failed _ -> false) + in + (* Extra scope to check for non-returning functions *) + with_local_level begin fun () -> + 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 ~statement:false exp; + ([Nolabel, Some exp], ty_res) + | _ -> + let ty = funct.exp_type in + type_args [] ty (instance ty) sargs + end + +and type_construct env loc lid sarg ty_expected_explained attrs = + let { ty = ty_expected; explanation } = ty_expected_explained in + let expected_type = + match extract_concrete_variant env ty_expected with + | Variant_type(p0, p,_) -> + Some(p0, p, is_principal ty_expected) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let ctx = Expression explanation in + let error = Wrong_expected_kind(srt, ctx, ty_expected) in + raise (Error (loc, env, error)) + 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 + let ty_args, ty_res, texp = + with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + let ty_args, ty_res, texp = + with_local_level_if separate begin fun () -> + let (ty_args, ty_res, _) = + instance_constructor Keep_existentials_flexible 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 + (ty_args, ty_res, texp) + end + ~post: begin fun (_, ty_res, texp) -> + generalize_structure ty_res; + with_explanation explanation (fun () -> + unify_exp env {texp with exp_type = instance ty_res} + (instance ty_expected)); + end + in + ((ty_args, ty_res, texp), ty_res::ty_args) + end + in + 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 = + (* OCaml 5.2.0 changed the type of 'while' to give 'while true do e done' + a polymorphic type. The change has the potential to trigger a + nonreturning-statement warning in existing code that follows + 'while true' with some other statement, e.g. + + while true do e done; assert false + + To avoid this issue, we disable the warning in this particular case. + We might consider re-enabling it at a point when most users have + migrated to OCaml 5.2.0 or later. *) + let allow_polymorphic e = match e.exp_desc with + | Texp_while _ -> true + | _ -> false + in + (* Raise the current level to detect non-returning functions *) + let exp = with_local_level (fun () -> type_exp env sexp) in + let subexp = final_subexpression exp in + let ty = expand_head env exp.exp_type in + if is_Tvar ty + && get_level ty > get_current_level () + && not (allow_polymorphic subexp) then + Location.prerr_warning + subexp.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 ~statement:true exp; + enforce_current_level env ty; + exp + end + +(* Most of the arguments are the same as [type_cases]. + + Takes a callback which is responsible for typing the body of the case. + The arguments are documented inline in the type signature. + + It takes a callback rather than returning the half-typed cases directly + because the typing of the body must take place at an increased level. + + The overall function returns: + - The data returned by the callback + - Whether the cases' patterns are partial or total +*) +and map_half_typed_cases + : type k ret case_data. + ?additional_checks_for_split_cases:((_ * ret) list -> unit) + -> k pattern_category -> _ -> _ -> _ -> _ + -> (untyped_case * case_data) list + -> type_body:( + case_data + -> k general_pattern (* the typed pattern *) + -> ext_env:_ (* environment with module variables / pattern variables *) + -> ty_expected:_ (* type to check body in scope of *) + -> ty_infer:_ (* type to infer for body *) + -> contains_gadt:_ (* whether the pattern contains a GADT *) + -> ret) + -> check_if_total:bool (* if false, assume Partial right away *) + -> ret list * partial + = fun ?additional_checks_for_split_cases + category env ty_arg ty_res loc caselist ~type_body ~check_if_total -> + (* ty_arg is _fully_ generalized *) + let patterns = List.map (fun ((x : untyped_case), _) -> x.pattern) 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 may_contain_modules = List.exists may_contain_modules patterns in + let create_inner_level = may_contain_gadts || may_contain_modules 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 + [ ({ needs_refute = true }, _) ] -> true + | [ ({ pattern }, _) ] when is_var pattern -> false + | _ -> true + in + let outer_level = get_current_level () in + with_local_level_iter_if create_inner_level begin fun () -> + let lev = get_current_level () in + let allow_modules = + if may_contain_modules + then + (* The corresponding check for scope escape is done together with + the check for GADT-induced existentials by + [with_local_level_iter_if create_inner_level]. + *) + Modules_allowed { scope = lev } + else Modules_rejected + in + let take_partial_instance = + if erase_either + then Some false else None + in + let half_typed_cases, ty_res, do_copy_types, ty_arg' = + (* propagation of the argument *) + with_local_level begin fun () -> + 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 ({ Parmatch.pattern; _ } as untyped_case, case_data) -> + let htc = + with_local_level_if_principal begin fun () -> + let ty_arg = + (* propagation of pattern *) + with_local_level ~post:generalize_structure + (fun () -> instance ?partial:take_partial_instance ty_arg) + in + let (pat, ext_env, force, pvs, mvs) = + type_pattern category ~lev env pattern ty_arg allow_modules + in + pattern_force := force @ !pattern_force; + { typed_pat = pat; + pat_type_for_unif = ty_arg; + untyped_case; + case_data; + branch_env = ext_env; + pat_vars = pvs; + module_vars = mvs; + contains_gadt = contains_gadt (as_comp_pattern category pat); + } + end + ~post: begin fun htc -> + iter_pattern_variables_type generalize_structure htc.pat_vars; + end + in + (* Ensure that no ambivalent pattern type escapes its branch *) + check_scope_escape htc.typed_pat.pat_loc env outer_level + htc.pat_type_for_unif; + let pat = htc.typed_pat in + {htc with typed_pat = { pat with pat_type = instance pat.pat_type }} + ) + 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 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 (enforce_current_level env) pat_vars + ) half_typed_cases; + (half_typed_cases, ty_res, do_copy_types, ty_arg') + end + ~post: begin fun (half_typed_cases, _, _, ty_arg') -> + generalize ty_arg'; + List.iter (fun { pat_vars; _ } -> + iter_pattern_variables_type generalize pat_vars + ) half_typed_cases + end + in + (* type bodies *) + let ty_res' = instance ty_res in + let result = with_local_level_if_principal ~post:ignore begin fun () -> + List.map + (fun { typed_pat = pat; branch_env = ext_env; + pat_vars = pvs; module_vars = mvs; + case_data; contains_gadt; _ } + -> + let ext_env = + if contains_gadt then + do_copy_types ext_env + else + ext_env + in + (* Before handing off the cases to the callback, first set up the the + branch environments by adding the variables (and module variables) + from the patterns. + *) + 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 ext_env = add_module_variables ext_env mvs in + let ty_expected = + if contains_gadt && not !Clflags.principal then + (* Take a generic copy of [ty_res] again to allow propagation of + type information from preceding branches *) + correct_levels ty_res + else ty_res in + type_body case_data pat ~ext_env ~ty_expected ~ty_infer:ty_res' + ~contains_gadt) + half_typed_cases + end in + 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 + (* Split the cases into val and exn cases so we can do the appropriate checks + for exhaustivity and unused variables. + + The caller of this function can define custom checks. For some of these + checks, the half-typed case doesn't provide enough info on its own -- for + instance, the check for ambiguous bindings in when guards needs to know the + case body's expression -- so the code pairs each case with its + corresponding element in [result] before handing it off to the caller's + custom checks. + *) + let val_cases_with_result, exn_cases_with_result = + match category with + | Value -> + let val_cases = + List.map2 + (fun htc res -> + { htc.untyped_case with pattern = htc.typed_pat }, res) + half_typed_cases + result + in + (val_cases : (pattern Parmatch.parmatch_case * ret) list), [] + | Computation -> + split_half_typed_cases env (List.combine half_typed_cases result) + in + let val_cases = List.map fst val_cases_with_result in + let exn_cases = List.map fst exn_cases_with_result in + if val_cases = [] && exn_cases <> [] then + raise (Error (loc, env, No_value_clauses)); + let partial = + if check_if_total 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; + with_level_if delayed ~level:lev begin fun () -> + check_unused ~lev env ty_arg_check val_cases ; + check_unused ~lev env Predef.type_exn exn_cases ; + end; + 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; + begin + match additional_checks_for_split_cases with + | None -> () + | Some check -> + check val_cases_with_result; + check exn_cases_with_result; + end; + (result, partial), [ty_res'] + end + (* Ensure that existential types do not escape *) + ~post:(fun ty_res' -> unify_exp_types loc env ty_res' (newvar ())) + +(* Typing of match cases *) +and type_cases + : type k . k pattern_category -> + _ -> _ -> _ -> check_if_total:bool -> _ -> Parsetree.case list -> + k case list * partial + = fun category env + ty_arg ty_res_explained ~check_if_total loc caselist -> + let { ty = ty_res; explanation } = ty_res_explained in + let caselist = + List.map (fun case -> Parmatch.untyped_case case, case) caselist + in + (* Most of the work is done by [map_half_typed_cases]. All that's left + is to typecheck the guards and the cases, and then to check for some + warnings that can fire in the presence of guards. + *) + map_half_typed_cases category env ty_arg ty_res loc caselist ~check_if_total + ~type_body:begin + fun { pc_guard; pc_rhs } pat ~ext_env ~ty_expected ~ty_infer + ~contains_gadt:_ -> + let guard = + match pc_guard with + | None -> None + | Some scond -> + Some + (type_expect ext_env scond + (mk_expected ~explanation:When_guard Predef.type_bool)) + in + let exp = + type_expect ext_env pc_rhs (mk_expected ?explanation ty_expected) + in + { + c_lhs = pat; + c_guard = guard; + c_rhs = {exp with exp_type = ty_infer} + } + end + ~additional_checks_for_split_cases:(fun cases -> + let cases = + List.map + (fun (case_with_pat, case) -> + { case with c_lhs = case_with_pat.Parmatch.pattern }) cases + in + Parmatch.check_ambiguous_bindings cases) + + +(** A version of [type_expect], but that operates over function cases instead + of expressions. The input type is like the [ty_expected] argument to + [type_expect], and the returned type is like the [exp_type] of the + expression returned by [type_expect]. + + See [split_function_ty] for the meaning of [first] and [in_function]. +*) +and type_function_cases_expect + env ty_expected loc cases attrs ~first ~in_function = + Builtin_attributes.warning_scope attrs begin fun () -> + let ty_arg, ty_res = + split_function_ty env ty_expected ~arg_label:Nolabel ~first ~in_function + in + let cases, partial = + type_cases Value env ty_arg (mk_expected ty_res) + ~check_if_total:true loc cases + in + let ty_fun = + instance (newgenty (Tarrow (Nolabel, ty_arg, ty_res, commu_ok))) + in + unify_exp_types loc env ty_fun (instance ty_expected); + cases, partial, ty_fun + end + +(* Typing of let bindings *) + +and type_let ?check ?check_strict + existential_context env rec_flag spat_sexp_list allow_modules = + let spatl = List.map vb_pat_constraint spat_sexp_list in + let attrs_list = List.map fst spatl in + let is_recursive = (rec_flag = Recursive) in + + let (pat_list, exp_list, new_env, mvs, _pvs) = + with_local_level begin fun () -> + if existential_context = At_toplevel then Typetexp.TyVarEnv.reset (); + let (pat_list, new_env, force, pvs, mvs) = + with_local_level_if_principal begin fun () -> + let nvs = List.map (fun _ -> newvar ()) spatl in + let (pat_list, _new_env, _force, _pvs, _mvs as res) = + type_pattern_list + Value existential_context env spatl nvs allow_modules in + (* If recursive, first unify with an approximation of the + expression *) + if is_recursive then + List.iter2 + (fun pat binding -> + let pat = + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + {pat with pat_type = + snd (instance_poly ~keep_names:true ~fixed:false tl ty)} + | _ -> pat + in + let bound_expr = vb_exp_constraint binding in + unify_pat env pat (type_approx env bound_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; + res + end + ~post: begin fun (pat_list, _, _, pvs, _) -> + (* Generalize the structure *) + iter_pattern_variables_type generalize_structure pvs; + List.iter (fun pat -> generalize_structure pat.pat_type) pat_list + end + in + (* Note [add_module_variables after checking expressions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Don't call [add_module_variables] here, because its use of + [type_module] will fail until after we have type-checked the expression + of the let. Example: [let m : (module S) = ... in let (module M) = m in + ...] We learn the signature [S] from the type of [m] in the RHS of the + second let, and we need that knowledge for [type_module] to succeed. If + we type-checked expressions before patterns, then we could call + [add_module_variables] here. + *) + let new_env = add_pattern_variables new_env pvs in + let pat_list = + List.map + (fun pat -> {pat with pat_type = instance pat.pat_type}) + pat_list + in + (* Only bind pattern variables after generalizing *) + List.iter (fun f -> f()) force; + + let exp_list = + (* See Note [add_module_variables after checking expressions] + We can't defer type-checking module variables with recursive + definitions, so things like [let rec (module M) = m in ...] always + fail, even if the type of [m] is known. + *) + let exp_env = + if is_recursive then add_module_variables new_env mvs else env + in + type_let_def_wrap_warnings ?check ?check_strict ~is_recursive + ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs + (fun exp_env ({pvb_attributes; _} as vb) pat -> + let sexp = vb_exp_constraint vb in + match get_desc pat.pat_type with + | Tpoly (ty, tl) -> + let vars, ty' = + with_local_level_if_principal + ~post:(fun (_,ty') -> generalize_structure ty') + (fun () -> instance_poly ~keep_names:true ~fixed:true tl ty) + in + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp (mk_expected ty')) + in + exp, Some vars + | _ -> + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect exp_env sexp (mk_expected pat.pat_type)) + in + exp, None) + in + List.iter2 + (fun pat (attrs, exp) -> + Builtin_attributes.warning_scope ~ppwarning:false attrs + (fun () -> + let case = Parmatch.typed_case (case pat exp) in + ignore(check_partial env pat.pat_type pat.pat_loc + [case] : Typedtree.partial) + ) + ) + pat_list + (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list); + (pat_list, exp_list, new_env, mvs, + List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs) + end + ~post: begin fun (pat_list, exp_list, _, _, pvs) -> + 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 = + ]} + 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 + end + in + let l = List.combine pat_list exp_list in + let l = + List.map2 + (fun (p, (e, _)) pvb -> + (* vb_rec_kind will be computed later for recursive bindings *) + {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes; + vb_loc=pvb.pvb_loc; vb_rec_kind = Not_recursive; + }) + 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 (fun vb -> + if pattern_needs_partial_application_check vb.vb_pat then + check_partial_application ~statement:false vb.vb_expr + ) l; + (* See Note [add_module_variables after checking expressions] *) + let new_env = add_module_variables new_env mvs in + (l, new_env) + +and type_let_def_wrap_warnings + ?(check = fun s -> Warnings.Unused_var s) + ?(check_strict = fun s -> Warnings.Unused_var_strict s) + ~is_recursive ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs + type_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 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 sexp_is_fun { pvb_expr = sexp; _ } = + match sexp.pexp_desc with + | Pexp_function _ -> true + | _ -> false + in + let exp_env = + if not is_recursive && 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 exp_env pvs + | _ -> assert false + end + else exp_env + in + (* 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. + *) + let current_slot = ref None in + let rec_needed = ref false in + let pat_slot_list = + 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 case (pat, slot) -> + if is_recursive then current_slot := slot; + type_def exp_env case pat) + 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; + exp_list + +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 -> + let op_path, op_desc, op_type, ty_arg, ty_rest, ty_result = + with_local_level_iter_if_principal begin fun () -> + 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, commu_ok)) in + let ty_op = + newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, commu_ok)) in + begin try + unify env op_type ty_op + with Unify err -> + raise(Error(sop.loc, env, Andop_type_clash(sop.txt, err))) + end; + ((op_path, op_desc, op_type, ty_arg, ty_rest, ty_result), + [ty_rest; ty_arg; ty_result]) + end + ~post:generalize_structure + in + 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 err -> + raise(Error(loc, env, Bindings_type_clash(err))) + 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 method call *) +and type_send env loc explanation e met = + let obj = type_exp env e in + let (meth, typ) = + match obj.exp_desc with + | Texp_ident(_, _, {val_kind = Val_self(sign, meths, _, _)}) -> + let id, typ = + match meths with + | Self_concrete meths -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (Error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + id, typ + | Self_virtual meths_ref -> begin + match Meths.find met !meths_ref with + | id -> id, Btype.method_type met sign + | exception Not_found -> + let id = Ident.create_local met in + let ty = newvar () in + meths_ref := Meths.add met id !meths_ref; + add_method env met Private Virtual ty sign; + Location.prerr_warning loc + (Warnings.Undeclared_virtual_method met); + id, ty + end + in + Tmeth_val id, typ + | Texp_ident(_, _, {val_kind = Val_anc (sign, meths, cl_num)}) -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (Error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + let (self_path, _) = + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env + in + Tmeth_ancestor(id, self_path), typ + | _ -> + let ty = + match filter_method env met obj.exp_type with + | ty -> ty + | exception Filter_method_failed err -> + let error = + match err with + | Unification_error err -> + Expr_type_clash(err, explanation, None) + | Not_an_object ty -> + Not_an_object(ty, explanation) + | Not_a_method -> + let valid_methods = + match get_desc (expand_head env obj.exp_type) with + | Tobject (fields, _) -> + let (fields, _) = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if field_kind_repr meth_kind = Fpublic + then meth::li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None + in + Undefined_method(obj.exp_type, met, valid_methods) + in + raise (Error(e.pexp_loc, env, error)) + in + Tmeth_name met, ty + in + (obj,meth,typ) + +(* Typing of toplevel bindings *) + +let type_binding env rec_flag spat_sexp_list = + let (pat_exp_list, new_env) = + 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 Modules_rejected + in + (pat_exp_list, new_env) + +let type_let existential_ctx env rec_flag spat_sexp_list = + let (pat_exp_list, new_env) = + type_let existential_ctx env rec_flag spat_sexp_list Modules_rejected in + (pat_exp_list, new_env) + +(* Typing of toplevel expressions *) + +let type_expression env sexp = + let exp = + with_local_level begin fun () -> + Typetexp.TyVarEnv.reset(); + type_exp env sexp + end + ~post:(may_lower_contravariant_then_generalize env) + in + 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 + | Pconst_integer (s, _) -> Some s + | _ -> 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 + let pp_const ppf (c,s) = Format.fprintf ppf "%s%c" c s in + match const_str, suffix with + | Some c, Some s -> [ + Location.msg + "@[@{Hint@}: Did you mean %a?@]" + (Style.as_inline_code pp_const) (c,s) + ] + | _, _ -> [] + +let report_literal_type_constraint const = function + | Some tr -> + begin match get_desc Errortrace.(tr.expected.ty) with + Tconstr (typ, [], _) -> + report_literal_type_constraint typ const + | _ -> [] + end + | None -> [] + +let report_partial_application = function + | Some tr -> begin + match get_desc tr.Errortrace.got.Errortrace.expanded with + | Tarrow _ -> + [ Location.msg + "@[@{Hint@}: This function application is partial,@ \ + maybe some arguments are missing.@]" ] + | _ -> [] + end + | None -> [] + +let report_expr_type_clash_hints exp diff = + match exp with + | Some (Pexp_constant const) -> report_literal_type_constraint const diff + | Some (Pexp_apply _) -> report_partial_application diff + | _ -> [] + +let report_pattern_type_clash_hints pat diff = + match pat with + | Some (Ppat_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 err + ?type_expected_explanation txt1 txt2 = + Location.error_of_printer ~loc ?sub (fun ppf () -> + Printtyp.report_unification_error ppf env err + ?type_expected_explanation txt1 txt2 + ) () + +let report_this_function ppf funct = + if Typedtree.exp_is_nominal funct then + let pexp = Untypeast.untype_expression funct in + Format.fprintf ppf "The function %a" + (Style.as_inline_code Pprintast.expression) pexp + else Format.fprintf ppf "This function" + +let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc = + let open Location in + let cnum_offset off (pos : Lexing.position) = + { pos with pos_cnum = pos.pos_cnum + off } + in + let app_loc = + (* Span the application, including the extra argument. *) + { loc_start = loc.loc_start; + loc_end = extra_arg_loc.loc_end; + loc_ghost = false } + and tail_loc = + (* Possible location for a ';'. The location is widened to overlap the end + of the argument. *) + let arg_end = previous_arg_loc.loc_end in + { loc_start = cnum_offset ~-1 arg_end; + loc_end = cnum_offset ~+1 arg_end; + loc_ghost = false } + in + let hint_semicolon = if returns_unit then [ + msg ~loc:tail_loc "@{Hint@}: Did you forget a ';'?"; + ] else [] in + let sub = hint_semicolon @ [ + msg ~loc:extra_arg_loc "This extra argument is not expected."; + ] in + errorf ~loc:app_loc ~sub + "@[@[<2>%a has type@ %a@]\ + @ It is applied to too many arguments@]" + report_this_function funct Printtyp.type_expr func_ty + +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)@]" + (Style.as_inline_code longident) lid expected provided + | Label_mismatch(lid, err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "The record field %a@ belongs to the type" + (Style.as_inline_code longident) lid) + (function ppf -> + fprintf ppf "but is mixed here with fields of type") + | Pattern_type_clash (err, pat) -> + let diff = type_clash_of_trace err.trace in + let sub = report_pattern_type_clash_hints pat diff in + report_unification_error ~loc ~sub env err + (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, err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "The variable %a on the left-hand side of this \ + or-pattern has type" Style.inline_code (Ident.name id)) + (function ppf -> + fprintf ppf "but on the right-hand side it has type") + | Multiply_bound_variable name -> + Location.errorf ~loc + "Variable %a is bound several times in this matching" + Style.inline_code name + | Orpat_vars (id, valid_idents) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf + "Variable %a must occur on both sides of this %a pattern" + Style.inline_code (Ident.name id) + Style.inline_code "|" + ; + spellcheck_idents ppf id valid_idents + ) () + | Expr_type_clash (err, explanation, exp) -> + let diff = type_clash_of_trace err.trace in + let sub = report_expr_type_clash_hints exp diff in + report_unification_error ~loc ~sub env err + ~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"); + | Function_arity_type_clash { + syntactic_arity; type_constraint; trace = { trace }; + } -> + (* The last diff's expected type will be the locally-abstract type + that the GADT pattern introduced an equation on. + *) + let type_with_local_equation = + let last_diff = + List.find_map + (function Errortrace.Diff diff -> Some diff | _ -> None) + (List.rev trace) + in + match last_diff with + | None -> None + | Some diff -> Some diff.expected.ty + in + (* [syntactic_arity>1] for this error, so "arguments" is always plural. *) + Location.errorf ~loc + "@[\ + @[\ + The syntactic arity of the function doesn't match the type constraint:@ \ + @[<2>\ + This function has %d syntactic arguments, but its type is constrained \ + to@ %a.\ + @]@ \ + @]@ \ + @[\ + @[<2>@{Hint@}: \ + consider splitting the function definition into@ %a@ \ + where %a is the pattern with the GADT constructor that@ \ + introduces the local type equation%t.\ + @]" + syntactic_arity + (Style.as_inline_code Printtyp.type_expr) type_constraint + Style.inline_code "fun ... gadt_pat -> fun ..." + Style.inline_code "gadt_pat" + (fun ppf -> + Option.iter + (fprintf ppf " on %a" (Style.as_inline_code Printtyp.type_expr)) + type_with_local_equation) + | Apply_non_function { + funct; func_ty; res_ty; previous_arg_loc; extra_arg_loc + } -> + begin match get_desc func_ty with + Tarrow _ -> + let returns_unit = match get_desc res_ty with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + in + report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc + ~extra_arg_loc ~returns_unit loc + | _ -> + Location.errorf ~loc "@[@[<2>This expression has type@ %a@]@ %s@]" + (Style.as_inline_code Printtyp.type_expr) func_ty + "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 %a" + Style.inline_code (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 + "@[@[<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_label ppf lbl = Style.inline_code ppf (Ident.name lbl) in + let print_labels ppf = List.iter (fprintf ppf "@ %a" print_label) in + Location.errorf ~loc "@[Some record fields are undefined:%a@]" + print_labels labels + | Label_not_mutable lid -> + Location.errorf ~loc "The record field %a is not mutable" + (Style.as_inline_code 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 %a is not part of the record \ + argument for the %a constructor@]" + Style.inline_code name.txt + (Style.as_inline_code Printtyp.type_path) type_path; + end else begin + fprintf ppf + "@[@[<2>%s type@ %a%t@]@ \ + There is no %s %a within type %a@]" + eorp (Style.as_inline_code Printtyp.type_expr) ty + (report_type_expected_explanation_opt explanation) + (Datatype_kind.label_name kind) + Style.inline_code name.txt + (Style.as_inline_code 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 (Style.as_inline_code longident) lid + type_name) + (function ppf -> + fprintf ppf "The %s %a@ belongs to one of the following %s types:" + name (Style.as_inline_code 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 + | Not_an_object (ty, explanation) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "This expression is not an object;@ \ + it has type %a" + (Style.as_inline_code Printtyp.type_expr) ty; + report_type_expected_explanation_opt explanation ppf + ) () + | Undefined_method (ty, me, valid_methods) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.wrap_printing_env ~error:true env (fun () -> + fprintf ppf + "@[@[This expression has type@;<1 2>%a@]@,\ + It has no method %a@]" + (Style.as_inline_code Printtyp.type_expr) ty + Style.inline_code me; + begin match valid_methods with + | None -> () + | Some valid_methods -> spellcheck ppf me valid_methods + end + )) () + | Undefined_self_method (me, valid_methods) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "This expression has no method %a" Style.inline_code me; + spellcheck ppf me valid_methods; + ) () + | Virtual_class cl -> + Location.errorf ~loc "Cannot instantiate the virtual class %a" + (Style.as_inline_code longident) cl + | Unbound_instance_variable (var, valid_vars) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "Unbound instance variable %a" Style.inline_code var; + spellcheck ppf var valid_vars; + ) () + | Instance_variable_not_mutable v -> + Location.errorf ~loc "The instance variable %a is not mutable" + Style.inline_code v + | Not_subtype err -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.Subtype.report_error ppf env err "is not a subtype of" + ) () + | Outside_class -> + Location.errorf ~loc + "This object duplication occurs outside a method definition" + | Value_multiply_overridden v -> + Location.errorf ~loc + "The instance variable %a is overridden several times" + Style.inline_code v + | Coercion_failure (ty_exp, err, b) -> + Location.error_of_printer ~loc (fun ppf () -> + Printtyp.report_unification_error ppf env err + (function ppf -> + let ty_exp = Printtyp.prepare_expansion ty_exp in + fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \ + it has type" + (Style.as_inline_code @@ Printtyp.type_expansion Type) ty_exp) + (function ppf -> + fprintf ppf "but is here used with type"); + if b then + fprintf ppf + ".@.@[This simple coercion was not fully general.@ \ + @{Hint@}: Consider using a fully explicit coercion@ \ + of the form: %a@]" + Style.inline_code "(foo : ty1 :> ty2)" + ) () + | Not_a_function (ty, explanation) -> + Location.errorf ~loc + "This expression should not be a function,@ \ + the expected type is@ %a%t" + (Style.as_inline_code Printtyp.type_expr) ty + (report_type_expected_explanation_opt explanation) + | Too_many_arguments (ty, explanation) -> + Location.errorf ~loc + "This function expects too many arguments,@ \ + it should have type@ %a%t" + (Style.as_inline_code Printtyp.type_expr) ty + (report_type_expected_explanation_opt explanation) + | Abstract_wrong_label {got; expected; expected_type; explanation} -> + let label ~long ppf = function + | Nolabel -> fprintf ppf "unlabeled" + | l -> + if long then + fprintf ppf "labeled %a" Style.inline_code (prefixed_label_name l) + else + Style.inline_code ppf (prefixed_label_name l) + in + let second_long = match got, expected with + | Nolabel, _ | _, Nolabel -> true + | _ -> false + in + Location.errorf ~loc + "@[@[<2>This function should have type@ %a%t@]@,\ + @[but its first argument is %a@ instead of %s%a@]@]" + (Style.as_inline_code Printtyp.type_expr) expected_type + (report_type_expected_explanation_opt explanation) + (label ~long:true) got + (if second_long then "being " else "") + (label ~long:second_long) expected + | Scoping_let_module(id, ty) -> + Location.errorf ~loc + "This %a expression has type@ %a@ \ + In this type, the locally bound module name %a escapes its scope" + Style.inline_code "let module" + (Style.as_inline_code Printtyp.type_expr) ty + Style.inline_code id + | Private_type ty -> + Location.errorf ~loc "Cannot create values of the private type %a" + (Style.as_inline_code Printtyp.type_expr) ty + | Private_label (lid, ty) -> + Location.errorf ~loc "Cannot assign field %a of the private type %a" + (Style.as_inline_code longident) lid + (Style.as_inline_code Printtyp.type_expr) ty + | Private_constructor (constr, ty) -> + Location.errorf ~loc + "Cannot use private constructor %a to create values of type %a" + Style.inline_code constr.cstr_name + (Style.as_inline_code Printtyp.type_expr) ty + | Not_a_polymorphic_variant_type lid -> + Location.errorf ~loc "The type %a@ is not a variant type" + (Style.as_inline_code 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, err) -> + report_unification_error ~loc env err + (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" + (Style.as_inline_code Printtyp.type_expr) ty + | Unexpected_existential (reason, name) -> + let reason_str = + match reason with + | In_class_args -> + dprintf "Existential types are not allowed in class arguments" + | In_class_def -> + dprintf "Existential types are not allowed in bindings inside \ + class definition" + | In_self_pattern -> + dprintf "Existential types are not allowed in self patterns" + | At_toplevel -> + dprintf "Existential types are not allowed in toplevel bindings" + | In_group -> + dprintf "Existential types are not allowed in %a bindings" + Style.inline_code "let ... and ..." + | In_rec -> + dprintf "Existential types are not allowed in recursive bindings" + | With_attributes -> + dprintf + "Existential types are not allowed in presence of attributes" + in + Location.errorf ~loc + "%t,@ but the constructor %a introduces existential types." + reason_str Style.inline_code name + | 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 %a are allowed.@]" + Style.inline_code "_" + | No_value_clauses -> + Location.errorf ~loc + "None of the patterns in this %a expression match values." + Style.inline_code "match" + | 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:" + (Style.as_inline_code Printpat.pretty_val) pat + | Invalid_extension_constructor_payload -> + Location.errorf ~loc + "Invalid %a payload, a constructor is expected." + Style.inline_code "[%extension_constructor]" + | 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 %a" + Style.inline_code ty + | Unknown_literal (n, m) -> + let pp_lit ppf (n,m) = fprintf ppf "%s%c" n m in + Location.errorf ~loc "Unknown modifier %a for literal %a" + (Style.as_inline_code pp_print_char) m + (Style.as_inline_code pp_lit) (n,m) + | Illegal_letrec_pat -> + Location.errorf ~loc + "Only variables are allowed as left-hand side of %a" + Style.inline_code "let rec" + | Illegal_letrec_expr -> + Location.errorf ~loc + "This kind of expression is not allowed as right-hand side of %a" + Style.inline_code "let rec" + | Illegal_class_expr -> + Location.errorf ~loc + "This kind of recursive class expression is not allowed" + | Letop_type_clash(name, err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "The operator %a has type" Style.inline_code name) + (function ppf -> + fprintf ppf "but it was expected to have type") + | Andop_type_clash(name, err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "The operator %a has type" Style.inline_code name) + (function ppf -> + fprintf ppf "but it was expected to have type") + | Bindings_type_clash(err) -> + report_unification_error ~loc env err + (function ppf -> + fprintf ppf "These bindings have type") + (function ppf -> + fprintf ppf "but bindings were expected of type") + | Unbound_existential (ids, ty) -> + let pp_ident ppf id = pp_print_string ppf (Ident.name id) in + let pp_type ppf (ids,ty)= + fprintf ppf "@[type %a.@ %a@]@]" + (pp_print_list ~pp_sep:pp_print_space pp_ident) ids + Printtyp.type_expr ty + in + Location.errorf ~loc + "@[<2>%s:@ %a@]" + "This type does not bind all existentials in the constructor" + (Style.as_inline_code pp_type) (ids, 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." + | Wrong_expected_kind(sort, ctx, ty) -> + let ctx, explanation = + match ctx with + | Expression explanation -> "expression", explanation + | Pattern -> "pattern", None + in + let sort = + match sort with + | Constructor -> "constructor" + | Boolean -> "boolean literal" + | List -> "list literal" + | Unit -> "unit literal" + | Record -> "record" + in + Location.errorf ~loc + "This %s should not be a %s,@ \ + the expected type is@ %a%t" + ctx sort (Style.as_inline_code Printtyp.type_expr) ty + (report_type_expected_explanation_opt explanation) + | Expr_not_a_record_type ty -> + Location.errorf ~loc + "This expression has type %a@ \ + which is not a record type." + (Style.as_inline_code Printtyp.type_expr) ty + +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 the need to call [Parmatch.typed_case] from the external API *) +let check_partial ?lev a b c cases = + check_partial ?lev a b c (List.map Parmatch.typed_case cases) + +(* drop ?recarg argument from the external API *) +let type_expect env e ty = type_expect 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_502/typing/typecore.mli b/upstream/ocaml_502/typing/typecore.mli new file mode 100644 index 0000000000..072acd3f6b --- /dev/null +++ b/upstream/ocaml_502/typing/typecore.mli @@ -0,0 +1,263 @@ +(**************************************************************************) +(* *) +(* 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; +} + +(* Variables in patterns *) +type pattern_variable = + { + pv_id: Ident.t; + pv_type: type_expr; + pv_loc: Location.t; + pv_as_var: bool; + pv_attributes: Typedtree.attributes; + pv_uid : Uid.t; + } + +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 wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +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: + Env.t -> Parsetree.pattern -> + Typedtree.pattern * pattern_variable list +val check_partial: + ?lev:int -> Env.t -> type_expr -> + Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial +val type_expect: + 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 generalize_structure_exp: Typedtree.expression -> unit +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_error + | Pattern_type_clash : + Errortrace.unification_error * Parsetree.pattern_desc option + -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of + Errortrace.unification_error * type_forcing_context option + * Parsetree.expression_desc option + | Function_arity_type_clash of + { syntactic_arity : int; + type_constraint : type_expr; + trace : Errortrace.unification_error; + } + | Apply_non_function of { + funct : Typedtree.expression; + func_ty : type_expr; + res_ty : type_expr; + previous_arg_loc : Location.t; + extra_arg_loc : Location.t; + } + | 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 + | Not_an_object of type_expr * type_forcing_context option + | Undefined_method of type_expr * string * string list option + | Undefined_self_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.error + | Outside_class + | Value_multiply_overridden of string + | Coercion_failure of + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } + | Scoping_let_module of string * type_expr + | Not_a_polymorphic_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * Errortrace.unification_error + | Modules_not_allowed + | Cannot_infer_signature + | Not_a_packed_module of type_expr + | Unexpected_existential of existential_restriction * string + | 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_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + +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 * Shape.t) 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 * 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 annotate_recursive_bindings : + Env.t -> Typedtree.value_binding list -> Typedtree.value_binding list +val check_recursive_class_bindings : + Env.t -> Ident.t list -> Typedtree.class_expr list -> unit diff --git a/upstream/ocaml_502/typing/typedecl.ml b/upstream/ocaml_502/typing/typedecl.ml new file mode 100644 index 0000000000..b42e990a53 --- /dev/null +++ b/upstream/ocaml_502/typing/typedecl.ml @@ -0,0 +1,2267 @@ +(**************************************************************************) +(* *) +(* 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 + +(* Our static analyses explore the set of type expressions "reachable" + from a type declaration, by expansion of definitions or by the + subterm relation (a type expression is syntactically contained + in another). *) +type reaching_type_path = reaching_type_step list +and reaching_type_step = + | Expands_to of type_expr * type_expr + | Contains of type_expr * type_expr + +type error = + Repeated_parameter + | Duplicate_constructor of string + | Too_many_constructors + | Duplicate_label of string + | Recursive_abbrev of string * Env.t * reaching_type_path + | Cycle_in_def of string * Env.t * reaching_type_path + | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error + | Non_regular of { + definition: Path.t; + used_as: type_expr; + defined_as: type_expr; + reaching_path: reaching_type_path; + } + | 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 * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error + | 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 ?shape id decl env = + Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes + (fun () -> Env.add_type ~check ?shape id decl env) + +(* Add a dummy type declaration to the environment, with the given arity. + The [type_kind] is [Type_abstract], but there is a generic [type_manifest] + for abbreviations, to allow polymorphic expansion, except if + [abstract_abbrevs] is given along with a reason for not allowing expansion. + This function is only used in [transl_type_decl]. *) +let enter_type ?abstract_abbrevs 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 abstract_source, type_manifest = + match sdecl.ptype_manifest, abstract_abbrevs with + | None, _ -> Definition, None + | Some _, None -> Definition, Some (Btype.newgenvar ()) + | Some _, Some reason -> reason, None + in + let decl = + { type_params = + List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; + type_arity = arity; + type_kind = Type_abstract abstract_source; + type_private = sdecl.ptype_private; + type_manifest = type_manifest; + 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 + +(* Determine if a type's values are represented by floats at run-time. *) +let is_float env ty = + match Typedecl_unboxed.get_unboxed_type_representation env ty with + Some ty' -> + begin match get_desc ty' with + Tconstr(p, _, _) -> Path.same p Predef.path_float + | _ -> false + end + | _ -> 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 get_desc tm with + Tvariant row -> + let Row {fields; more; closed; name} = row_repr row in + set_type_desc tm + (Tvariant (create_row ~fields ~more ~closed ~name + ~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 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 + 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 univars 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 ?univars ~closed arg in + {ld_id = Ident.create_local name.txt; + ld_name = name; + ld_uid = Uid.mk ~current_unit:(Env.get_unit_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 get_desc ty 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 = ld.ld_uid; + } + ) + lbls in + lbls, lbls' + +let transl_constructor_arguments env univars closed = function + | Pcstr_tuple l -> + let l = List.map (transl_simple_type env ?univars ~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 univars closed l in + Types.Cstr_record lbls', + Cstr_record lbls + +let make_constructor env loc type_path type_params svars sargs sret_type = + match sret_type with + | None -> + let args, targs = + transl_constructor_arguments env None 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 *) + (* narrow and widen are now invoked through wrap_type_variable_scope *) + TyVarEnv.with_local_scope begin fun () -> + let closed = svars <> [] in + let targs, tret_type, args, ret_type, _univars = + Ctype.with_local_level_if closed begin fun () -> + TyVarEnv.reset (); + let univar_list = + TyVarEnv.make_poly_univars (List.map (fun v -> v.txt) svars) in + let univars = if closed then Some univar_list else None in + let args, targs = + transl_constructor_arguments env univars closed sargs + in + let tret_type = + transl_simple_type env ?univars ~closed sret_type in + let ret_type = tret_type.ctyp_type in + (* TODO add back type_path as a parameter ? *) + begin match get_desc ret_type with + | Tconstr (p', _, _) when Path.same type_path p' -> () + | _ -> + let trace = + (* Expansion is not helpful here -- the restriction on GADT + return types is purely syntactic. (In the worst case, + expansion produces gibberish.) *) + [Ctype.unexpanded_diff + ~got:ret_type + ~expected:(Ctype.newconstr type_path type_params)] + in + raise (Error(sret_type.ptyp_loc, + Constraint_failed( + env, Errortrace.unification_error ~trace))) + end; + (targs, tret_type, args, ret_type, univar_list) + end + ~post: begin fun (_, _, args, ret_type, univars) -> + Btype.iter_type_expr_cstr_args Ctype.generalize args; + Ctype.generalize ret_type; + let _vars = TyVarEnv.instance_poly_univars env loc univars in + let set_level t = Ctype.enforce_current_level env t in + Btype.iter_type_expr_cstr_args set_level args; + set_level ret_type; + end + in + targs, Some tret_type, args, Some ret_type + end + + +let shape_map_labels = + List.fold_left (fun map { ld_id; ld_uid; _} -> + Shape.Map.add_label map ld_id ld_uid) + Shape.Map.empty + +let shape_map_cstrs = + List.fold_left (fun map { cd_id; cd_uid; cd_args; _ } -> + let cstr_shape_map = + let label_decls = + match cd_args with + | Cstr_tuple _ -> [] + | Cstr_record ldecls -> ldecls + in + shape_map_labels label_decls + in + Shape.Map.add_constr map cd_id + @@ Shape.str ~uid:cd_uid cstr_shape_map) + (Shape.Map.empty) + + +let transl_declaration env sdecl (id, uid) = + (* Bind type parameters *) + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + 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 ~closed:false sty, + transl_simple_type env ~closed: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 Definition + | 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 scstr.pcd_loc (Path.Pident id) params + scstr.pcd_vars scstr.pcd_args scstr.pcd_res + in + let tcstr = + { cd_id = name; + cd_name = scstr.pcd_name; + cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + cd_vars = scstr.pcd_vars; + 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 = tcstr.cd_uid } + 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 None 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 ~closed: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 err -> + raise(Error(loc, Inconsistent_constraint (env, err)))) + cstrs; + (* 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; + let decl = + { + 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; + } + in + let typ_shape = + let uid = decl.typ_type.type_uid in + match decl.typ_kind with + | Ttype_variant cstrs -> Shape.str ~uid (shape_map_cstrs cstrs) + | Ttype_record labels -> Shape.str ~uid (shape_map_labels labels) + | Ttype_abstract | Ttype_open -> Shape.leaf uid + in + decl, typ_shape + end + +(* 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 = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty 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 + (* We don't expand the error trace because that produces types that + *already* violate the constraints -- we need to report a problem with + the unexpanded types, or we get errors that talk about the same type + twice. This is generally true for constraint errors. *) + try Ctype.matches ~expand_error_trace:false env ty ty' + with Ctype.Matches_failure (env, err) -> + raise (Error(loc, Constraint_failed (env, err))) + end; + List.iter (check_constraints_rec env loc visited) args + | Tpoly (ty, tl) -> + let _, ty = Ctype.instance_poly ~fixed: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 get_desc ty 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 err -> + Some (Includecore.Constraint err) + | () -> + 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, env, err))) + with Not_found -> + raise(Error(loc, Unavailable_type_constructor path)) + end + | _ -> raise(Error(loc, Definition_mismatch (ty, env, None))) + end + | _ -> () + +let check_abbrev env sdecl (id, decl) = + check_coherence env sdecl.ptype_loc (Path.Pident id) decl + + +(* Note: Well-foundedness for OCaml types + + We want to guarantee that all cycles within OCaml types are + "guarded". + + More precisely, we consider a reachability relation + "[t] is reachable [guarded|unguarded] from [u]" + defined as follows: + + - [t1, t2...] are reachable guarded from object types + [< m1 : t1; m2 : t2; ... >] + or polymorphic variants + [[`A of t1 | `B of t2 | ...]]. + + - [t1, t2...] are reachable rectypes-guarded from + [t1 -> t2], [t1 * t2 * ...], and all other built-in + contractive type constructors. + + (By rectypes-guarded we mean: guarded if -rectypes is set, + unguarded if it is not set.) + + - If [(t1, t2...) c] is a datatype (variant or record), + then [t1, t2...] are reachable rectypes-guarded from it. + + - If [(t1, t2...) c] is an abstract type, + then [t1, t2...] are reachable unguarded from it. + + - If [(t1, t2...) c] is an (expandable) abbreviation, + then its expansion is reachable unguarded from it. + Note that we do not define [t1, t2...] as reachable. + + - The relation is transitive and guardedness of a composition + is the disjunction of each guardedness: + if t1 is reachable from t2 and t2 is reachable from t3; + then t1 is reachable guarded from t3 if t1 is guarded in t2 + or t2 is guarded in t3, and reachable unguarded otherwise. + + A type [t] is not well-founded if and only if [t] is reachable + unguarded in [t]. + + Notice that, in the case of datatypes, the arguments of + a parametrized datatype are reachable (they must not contain + recursive occurrences of the type), but the definition of the + datatype is not defined as reachable. + + (* well-founded *) + type t = Foo of u + and u = t + + (* ill-founded *) + type 'a t = Foo of 'a + and u = u t + > Error: The type abbreviation u is cyclic + + Indeed, in the second example [u] is reachable unguarded in [u t] + -- its own definition. +*) + +(* Note: Forms of ill-foundedness + + Several OCaml language constructs could introduce ill-founded + types, and there are several distinct checks that forbid different + sources of ill-foundedness. + + 1. Type aliases. + + (* well-founded *) + type t = < x : 'a > as 'a + + (* ill-founded, unless -rectypes is used *) + type t = (int * 'a) as 'a + > Error: This alias is bound to type int * 'a + > but is used as an instance of type 'a + > The type variable 'a occurs inside int * 'a + + Ill-foundedness coming from type aliases is detected by the "occur check" + used by our type unification algorithm. See typetexp.ml. + + 2. Type abbreviations. + + (* well-founded *) + type t = < x : t > + + (* ill-founded, unless -rectypes is used *) + type t = (int * t) + > Error: The type abbreviation t is cyclic + + Ill-foundedness coming from type abbreviations is detected by + [check_well_founded] below. + + 3. Recursive modules. + + (* well-founded *) + module rec M : sig type t = < x : M.t > end = M + + (* ill-founded, unless -rectypes is used *) + module rec M : sig type t = int * M.t end = M + > Error: The definition of M.t contains a cycle: + > int * M.t + + This is also checked by [check_well_founded] below, + as called from [check_recmod_typedecl]. + + 4. Functor application + + A special case of (3) is that a type can be abstract + in a functor definition, and be instantiated with + an abbreviation in an application of the functor. + This can introduce ill-foundedness, so functor applications + must be checked by re-checking the type declarations of their result. + + module type T = sig type t end + module Fix(F:(T -> T)) = struct + (* this recursive definition is well-founded + as F(Fixed).t contains no reachable type expression. *) + module rec Fixed : T with type t = F(Fixed).t = F(Fixed) + end + + (* well-founded *) + Module M = Fix(functor (M:T) -> struct type t = < x : M.t > end) + + (* ill-founded *) + module M = Fix(functor (M:T) -> struct type t = int * M.t end);; + > Error: In the signature of this functor application: + > The definition of Fixed.t contains a cycle: + > F(Fixed).t +*) + +(* Check that a type expression is well-founded: + - if -rectypes is used, we must prevent non-contractive fixpoints + ('a as 'a) + - if -rectypes is not used, we only allow cycles in the type graph + if they go through an object or polymorphic variant type *) + +let check_well_founded ~abs_env env loc path to_check visited ty0 = + let rec check parents trace ty = + if TypeSet.mem ty parents then begin + (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) + let err = + let reaching_path, rec_abbrev = + (* The reaching trace is accumulated in reverse order, we + reverse it to get a reaching path. *) + match trace with + | [] -> assert false + | Expands_to (ty1, _) :: trace when (match get_desc ty1 with + Tconstr (p,_,_) -> Path.same p path | _ -> false) -> + List.rev trace, true + | trace -> List.rev trace, false + in + if rec_abbrev + then Recursive_abbrev (Path.name path, abs_env, reaching_path) + else Cycle_in_def (Path.name path, abs_env, reaching_path) + in raise (Error (loc, err)) + end; + let (fini, parents) = + try + (* Map each node to the set of its already checked parents *) + let prev = TypeMap.find ty !visited in + if TypeSet.subset parents prev then (true, parents) else + let parents = TypeSet.union parents prev in + visited := TypeMap.add ty parents !visited; + (false, parents) + with Not_found -> + visited := TypeMap.add ty parents !visited; + (false, parents) + in + if fini then () else + let rec_ok = + match get_desc ty with + | Tconstr(p,_,_) -> + !Clflags.recursive_types && Ctype.is_contractive env p + | Tobject _ | Tvariant _ -> true + | _ -> !Clflags.recursive_types + in + if rec_ok then () else + let parents = TypeSet.add ty parents in + match get_desc ty with + | Tconstr(p, tyl, _) -> + let to_check = to_check p in + if to_check then List.iter (check_subtype parents trace ty) tyl; + begin match Ctype.try_expand_once_opt env ty with + | ty' -> check parents (Expands_to (ty, ty') :: trace) ty' + | exception Ctype.Cannot_expand -> + if not to_check then List.iter (check_subtype parents trace ty) tyl + end + | _ -> + Btype.iter_type_expr (check_subtype parents trace ty) ty + and check_subtype parents trace outer_ty inner_ty = + check parents (Contains (outer_ty, inner_ty) :: trace) inner_ty + in + let snap = Btype.snapshot () in + try Ctype.wrap_trace_gadt_instances env (check TypeSet.empty []) ty0 + with Ctype.Escape _ -> + (* Will be detected by check_regularity *) + Btype.backtrack snap + +let check_well_founded_manifest ~abs_env env loc path decl = + if decl.type_manifest = None then () else + let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in + let visited = ref TypeMap.empty in + check_well_founded ~abs_env env loc path (Path.same path) visited + (Ctype.newconstr path args) + +(* Given a new type declaration [type t = ...] (potentially mutually-recursive), + we check that accepting the declaration does not introduce ill-founded types. + + Note: we check that the types at the toplevel of the declaration + are not reachable unguarded from themselves, that is, we check that + there is no cycle going through the "root" of the declaration. But + we *also* check that all the type sub-expressions reachable from + the root even those that are guarded, are themselves + well-founded. (So we check the absence of cycles, even for cycles + going through inner type subexpressions but not the root. + + We are not actually sure that this "deep check" is necessary + (we don't have an example at hand where it is necessary), but we + are doing it anyway out of caution. +*) +let check_well_founded_decl ~abs_env env loc path decl to_check = + let open Btype in + (* We iterate on all subexpressions of the declaration to check + "in depth" that no ill-founded type exists. *) + let it = + let checked = + (* [checked] remembers the types that the iterator already + checked, to avoid looping on cyclic types. *) + ref TypeSet.empty in + let visited = + (* [visited] remembers the inner visits performed by + [check_well_founded] on each type expression reachable from + this declaration. This avoids unnecessary duplication of + [check_well_founded] work when invoked on two parts of the + type declaration that have common subexpressions. *) + ref TypeMap.empty in + {type_iterators with it_type_expr = + (fun self ty -> + if TypeSet.mem ty !checked then () else begin + check_well_founded ~abs_env env loc path to_check visited ty; + checked := TypeSet.add ty !checked; + self.it_do_type_expr self ty + end)} in + it.it_type_declaration it (Ctype.generic_instance_declaration decl) + +(* Check for non-regular abbreviations; an abbreviation + [type 'a t = ...] is non-regular if the expansion of [...] + contains instances [ty t] where [ty] is not equal to ['a]. + + Note: in the case of a constrained type definition + [type 'a t = ... constraint 'a = ...], we require + that all instances in [...] be equal to the constrained type. +*) + +let check_regularity ~abs_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 TypeSet.empty in + + let rec check_regular cpath args prev_exp trace ty = + if not (TypeSet.mem ty !visited) then begin + visited := TypeSet.add ty !visited; + match get_desc ty with + | Tconstr(path', args', _) -> + if Path.same path path' then begin + if not (Ctype.is_equal abs_env false args args') then + raise (Error(loc, + Non_regular { + definition=path; + used_as=ty; + defined_as=Ctype.newconstr path args; + reaching_path=List.rev trace; + })) + 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 abs_env) args' params + with Ctype.Unify err -> + raise (Error(loc, Constraint_failed (abs_env, err))); + end; + check_regular path' args + (path' :: prev_exp) (Expands_to (ty,body) :: trace) + body + with Not_found -> () + end; + List.iter (check_subtype cpath args prev_exp trace ty) args' + | Tpoly (ty, tl) -> + let (_, ty) = + Ctype.instance_poly ~keep_names:true ~fixed:false tl ty in + check_regular cpath args prev_exp trace ty + | _ -> + Btype.iter_type_expr + (check_subtype cpath args prev_exp trace ty) ty + end + and check_subtype cpath args prev_exp trace outer_ty inner_ty = + let trace = Contains (outer_ty, inner_ty) :: trace in + check_regular cpath args prev_exp trace inner_ty + 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_regularity ~abs_env env id_loc_list to_check tdecl = + let decl = tdecl.typ_type in + let id = tdecl.typ_id in + check_regularity ~abs_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' = newty2 ~level:(get_level ty) (get_desc ty) in + if Ctype.deep_occur ty ty' then + let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in + link_type ty (newty2 ~level:(get_level ty) 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 shapes env = + List.fold_right2 + (fun (id, decl) shape env -> + add_type ~check:true ~shape id decl env) + decls shapes 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 + (* Translate declarations, using a temporary environment where abbreviations + expand to a generic type variable. After that, we check the coherence of + the translated declarations in the resulting new environment. *) + let tdecls, decls, shapes, new_env = + Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> + (* 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, shapes = + List.map (fun (tdecl, shape) -> + (tdecl.typ_id, tdecl.typ_type), shape) tdecls + |> List.split + in + current_slot := None; + (* Check for duplicates *) + check_duplicates sdecl_list; + (* Build the final env. *) + let new_env = add_types_to_env decls shapes env in + ((tdecls, decls, shapes, new_env), List.map snd decls) + end + in + (* Check for ill-formed abbrevs *) + let id_loc_list = + List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc)) + ids_list sdecl_list + in + (* [check_abbrev_regularity] and error messages cannot use the new + environment, as this might result in non-termination. Instead we use a + completely abstract version of the temporary environment, giving a reason + for why abbreviations cannot be expanded (#12334, #12368) *) + let abs_env = + List.fold_left2 + (enter_type ~abstract_abbrevs:Rec_check_regularity rec_flag) + env sdecl_list ids_list in + List.iter (fun (id, decl) -> + check_well_founded_manifest ~abs_env 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 ~abs_env new_env (List.assoc id id_loc_list) + (Path.Pident id) + decl to_check) + decls; + List.iter (fun (tdecl, _shape) -> + check_abbrev_regularity ~abs_env new_env id_loc_list to_check tdecl) + tdecls; + (* Check that all type variables are closed *) + List.iter2 + (fun sdecl (tdecl, _shape) -> + 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 shapes env in + (* Check re-exportation *) + List.iter2 (check_abbrev final_env) sdecl_list decls; + (* Keep original declaration *) + let final_decls = + List.map2 + (fun (tdecl, _shape) (_id2, decl) -> + { tdecl with typ_type = decl } + ) tdecls decls + in + (* Done *) + (final_decls, final_env, shapes) + +(* 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(svars, sargs, sret_type) -> + let targs, tret_type, args, ret_type = + make_constructor env sext.pext_loc type_path typext_params + svars sargs sret_type + in + args, ret_type, Text_decl(svars, 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 Keep_existentials_flexible 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 err -> + raise (Error(lid.loc, + Rebind_wrong_type(lid.txt, env, err))) + 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 + (fun ty -> + if get_desc ty = Tvar (Some "_") + && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + typext_params + end; + (* Ensure that constructor's type matches the type being extended *) + let cstr_type_path = Btype.cstr_type_path cdescr in + let cstr_type_params = (Env.find_type cstr_type_path env).type_params 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 List.map get_desc args with + | [ 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 + let ext_cstrs = + { 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; } + in + let shape = + let map = match ext_cstrs.ext_kind with + | Text_decl (_, Cstr_record lbls, _) -> shape_map_labels lbls + | _ -> Shape.Map.empty + in + Shape.str ~uid:ext_cstrs.ext_type.ext_uid map + in + ext_cstrs, shape + +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 = + 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, env, err))) + end; + let ttype_params, _type_params, constructors = + (* Note: it would be incorrect to call [create_scope] *after* + [TyVarEnv.reset] or after [with_local_level] (see #10010). *) + let scope = Ctype.create_scope () in + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + 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 + (ttype_params, type_params, constructors) + end + ~post: begin fun (_, type_params, constructors) -> + (* Generalize types *) + List.iter Ctype.generalize type_params; + List.iter + (fun (ext, _shape) -> + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; + Option.iter Ctype.generalize ext.ext_type.ext_ret_type) + constructors; + end + in + (* Check that all type variables are closed *) + List.iter + (fun (ext, _shape) -> + 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, _shape) -> + (* 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, shape) -> + let rebind = is_rebind ext in + Env.add_extension ~check:true ~shape ~rebind + ext.ext_id ext.ext_type env) + env constructors + in + let constructors, shapes = List.split 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, shapes) + +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 ext, shape = + let scope = Ctype.create_scope () in + Ctype.with_local_level + (fun () -> + TyVarEnv.reset(); + transl_extension_constructor ~scope env + Predef.path_exn [] [] Asttypes.Public sext) + ~post: begin fun (ext, _shape) -> + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; + Option.iter Ctype.generalize ext.ext_type.ext_ret_type; + end + in + (* 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 ~shape ~rebind ext.ext_id ext.ext_type env + in + ext, newenv, shape + +let transl_type_exception env t = + let contructor, newenv, shape = + 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, shape + + +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" attrs, + Attr_helper.get_no_payload_attribute "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, get_desc (Ctype.expand_head_opt env ty) with + | Untagged, Tconstr (_, _, _) when + Typeopt.maybe_pointer_type env ty = Lambda.Immediate -> + Some Untagged_immediate + | 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, get_desc ty, + 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_poly (_, t) | Ptyp_alias (t, _)), _, _ -> + parse_native_repr_attributes env t ty ~global_repr + | 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.expand_head_opt env ty in + try match get_desc ty 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; + Ctype.with_local_level begin fun () -> + TyVarEnv.reset(); + (* 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 ~closed:false ty in + let cty' = transl_simple_type env ~closed: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 ~closed: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 err -> + raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, err))) + ) 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 err -> + raise(Error(loc, Inconsistent_constraint (env, err))) + ) constraints; + let sig_decl_abstract = Btype.type_kind_is_abstract sig_decl in + let priv = + if sdecl.ptype_private = Private then Private else + if arity_ok && not sig_decl_abstract + then sig_decl.type_private else sdecl.ptype_private + in + if arity_ok && not sig_decl_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 Definition, 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:(Some id) 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 + { + 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; + } + end + ~post:(fun ttyp -> generalize_decl ttyp.typ_type) + +(* 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.with_local_level ~post:generalize_decl begin fun () -> + { type_params = make_params arity; + type_arity = arity; + type_kind = Type_abstract Definition; + 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; + } + end + +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 + +(* 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 ~abs_env:env env loc path decl to_check; + check_regularity ~abs_env:env env loc path decl to_check; + (* additional coherence check, 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 +module Style = Misc.Style + +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.prepare_for_printing [typ ti; ty0]; + fprintf ppf + ".@ @[In %s@ %a@;<1 -2>the variable %a is unbound@]" + kwd (Style.as_inline_code pr) ti + (Style.as_inline_code Printtyp.prepared_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.prepared_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 get_desc ty with + Tobject(fi,_) -> + let (tl, rv) = Ctype.flatten_fields fi in + if eq_type rv tv then trivial ty else + explain_unbound ppf tv tl (fun (_,_,t) -> t) + "method" (fun (lab,_,_) -> lab ^ ": ") + | Tvariant row -> + if eq_type (row_more row) tv then trivial ty else + explain_unbound ppf tv (row_fields row) + (fun (_l,f) -> match 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 + +module Reaching_path = struct + type t = reaching_type_path + + (* Simplify a reaching path before showing it in error messages. *) + let simplify path = + let rec simplify : t -> t = function + | Contains (ty1, _ty2) :: Contains (_ty2', ty3) :: rest -> + (* If t1 contains t2 and t2 contains t3, then t1 contains t3 + and we don't need to show t2. *) + simplify (Contains (ty1, ty3) :: rest) + | hd :: rest -> hd :: simplify rest + | [] -> [] + in simplify path + + (* See Printtyp.add_type_to_preparation. + + Note: it is better to call this after [simplify], otherwise some + type variable names may be used for types that are removed + by simplification and never actually shown to the user. + *) + let add_to_preparation path = + List.iter (function + | Contains (ty1, ty2) | Expands_to (ty1, ty2) -> + List.iter Printtyp.add_type_to_preparation [ty1; ty2] + ) path + + let pp ppf reaching_path = + let pp_step ppf = function + | Expands_to (ty, body) -> + Format.fprintf ppf "%a = %a" + (Style.as_inline_code Printtyp.prepared_type_expr) ty + (Style.as_inline_code Printtyp.prepared_type_expr) body + | Contains (outer, inner) -> + Format.fprintf ppf "%a contains %a" + (Style.as_inline_code Printtyp.prepared_type_expr) outer + (Style.as_inline_code Printtyp.prepared_type_expr) inner + in + let comma ppf () = Format.fprintf ppf ",@ " in + Format.(pp_print_list ~pp_sep:comma pp_step) ppf reaching_path + + let pp_colon ppf path = + Format.fprintf ppf ":@;<1 2>@[%a@]" + pp path +end + +let report_error ppf = function + | Repeated_parameter -> + fprintf ppf "A type parameter occurs several times" + | Duplicate_constructor s -> + fprintf ppf "Two constructors are named %a" Style.inline_code 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 %a" Style.inline_code s + | Recursive_abbrev (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Printtyp.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The type abbreviation %a is cyclic%a@]" + Style.inline_code s + Reaching_path.pp_colon reaching_path + | Cycle_in_def (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Printtyp.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The definition of %a contains a cycle%a@]" + Style.inline_code s + Reaching_path.pp_colon reaching_path + | Definition_mismatch (ty, _env, None) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" + "This variant or record definition" "does not match that of type" + (Style.as_inline_code Printtyp.type_expr) ty + | Definition_mismatch (ty, env, Some err) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" + "This variant or record definition" "does not match that of type" + (Style.as_inline_code Printtyp.type_expr) ty + (Includecore.report_type_mismatch + "the original" "this" "definition" env) + err + | Constraint_failed (env, err) -> + fprintf ppf "@[Constraints are not satisfied in this type.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "should be an instance of"); + fprintf ppf "@]" + | Non_regular { definition; used_as; defined_as; reaching_path } -> + let reaching_path = Reaching_path.simplify reaching_path in + let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in + Printtyp.prepare_for_printing [used_as; defined_as]; + Reaching_path.add_to_preparation reaching_path; + fprintf ppf + "@[This recursive type is not regular.@ \ + The type constructor %a is defined as@;<1 2>type %a@ \ + but it is used as@;<1 2>%a%t\ + All uses need to match the definition for the recursive type \ + to be regular.@]" + Style.inline_code (Path.name definition) + pp_type (Printtyp.tree_of_typexp Type defined_as) + pp_type (Printtyp.tree_of_typexp Type used_as) + (fun pp -> + let is_expansion = function Expands_to _ -> true | _ -> false in + if List.exists is_expansion reaching_path then + fprintf pp "@ after the following expansion(s)%a@ " + Reaching_path.pp_colon reaching_path + else fprintf pp ".@ ") + | Inconsistent_constraint (env, err) -> + fprintf ppf "@[The type constraints are not consistent.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type"); + fprintf ppf "@]" + | Type_clash (env, err) -> + Printtyp.report_unification_error ppf env err + (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 "@[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"; + 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" + (Style.as_inline_code Printtyp.path) path + "is not extensible" + | Extension_mismatch (path, env, err) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" + "This extension" "does not match the definition of type" + Style.inline_code (Path.name path) + (Includecore.report_type_mismatch + "the type" "this extension" "definition" env) + err + | Rebind_wrong_type (lid, env, err) -> + Printtyp.report_unification_error ppf env err + (function ppf -> + fprintf ppf "The constructor %a@ has type" + (Style.as_inline_code Printtyp.longident) lid) + (function ppf -> + fprintf ppf "but was expected to be of type") + | Rebind_mismatch (lid, p, p') -> + fprintf ppf + "@[%s@ %a@ %s@ %a@ %s@ %s@ %a@]" + "The constructor" + (Style.as_inline_code Printtyp.longident) lid + "extends type" Style.inline_code (Path.name p) + "whose declaration does not match" + "the declaration of type" Style.inline_code (Path.name p') + | Rebind_private lid -> + fprintf ppf "@[%s@ %a@ %s@]" + "The constructor" + (Style.as_inline_code 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 + (match n with + | Variance_variable_error { error; variable; context } -> + Printtyp.prepare_for_printing [ variable ]; + begin match context with + | Type_declaration (id, decl) -> + Printtyp.add_type_declaration_to_preparation id decl; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the definition" + (Style.as_inline_code @@ Printtyp.prepared_type_declaration id) + decl + | Gadt_constructor c -> + Printtyp.add_constructor_to_preparation c; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the GADT constructor" + (Style.as_inline_code Printtyp.prepared_constructor) + c + | Extension_constructor (id, e) -> + Printtyp.add_extension_constructor_to_preparation e; + fprintf ppf "@[%s@;<1 2>%a@;" + "In the extension constructor" + (Printtyp.prepared_extension_constructor id) + e + end; + begin match error with + | Variance_not_reflected -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" + (Style.as_inline_code Printtyp.prepared_type_expr) variable + "has a variance that" + "is not reflected by its occurrence in type parameters." + | No_variable -> + fprintf ppf "@[%s@ %a@ %s@ %s@]@]" + "the type variable" + (Style.as_inline_code Printtyp.prepared_type_expr) variable + "cannot be deduced" + "from the type parameters." + | Variance_not_deducible -> + fprintf ppf "@[%s@ %a@ %s@ %s@ It" + "the type variable" + (Style.as_inline_code Printtyp.prepared_type_expr) variable + "has a variance that" + "cannot be deduced from the type parameters." + end + | Variance_not_satisfied n -> + fprintf ppf "@[@[%s@ %s@ The %d%s type parameter" + "In this definition, expected parameter" + "variances are not satisfied." + n (Misc.ordinal_suffix n)); + (match n with + | Variance_variable_error { error = 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" + (Style.as_inline_code 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 %a/%a attributes" + Style.inline_code "[@@unboxed]" + Style.inline_code "[@@untagged]" + | Cannot_unbox_or_untag_type Unboxed -> + fprintf ppf "@[Don't know how to unbox this type.@ \ + Only %a, %a, %a, and %a can be unboxed.@]" + Style.inline_code "float" + Style.inline_code "int32" + Style.inline_code "int64" + Style.inline_code "nativeint" + | Cannot_unbox_or_untag_type Untagged -> + fprintf ppf "@[Don't know how to untag this type. Only %a@ \ + and other immediate types can be untagged.@]" + Style.inline_code "int" + | Deep_unbox_or_untag_attribute kind -> + fprintf ppf + "@[The attribute %a should be attached to@ \ + a direct argument or result of the primitive,@ \ + it should not occur deeply into its type.@]" + Style.inline_code + (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged") + | Immediacy (Typedecl_immediacy.Bad_immediacy_attribute violation) -> + (match violation with + | Type_immediacy.Violation.Not_always_immediate -> + fprintf ppf + "@[Types@ marked@ with@ the@ immediate@ attribute@ must@ be@ \ + non-pointer@ types@ like@ %a@ or@ %a.@]" + Style.inline_code "int" + Style.inline_code "bool" + | Type_immediacy.Violation.Not_always_immediate_on_64bits -> + fprintf ppf + "@[Types@ marked@ with@ the@ %a@ attribute@ must@ be@ \ + produced@ using@ the@ %a@ functor.@]" + Style.inline_code "immediate64" + Style.inline_code "Stdlib.Sys.Immediate64.Make" + ) + | 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" + (Style.as_inline_code 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 %a.@]" + pp_evar evar + Style.inline_code "[@@ocaml.boxed]" + | 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 %a block.@]" + Style.inline_code "nonrec" + | Invalid_private_row_declaration ty -> + let pp_private ppf ty = fprintf ppf "private %a" Printtyp.type_expr ty in + Format.fprintf ppf + "@[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.@]@,\ + @[@[@{Hint@}: If you intended to define a private \ + type abbreviation,@ \ + write explicitly@]@;<1 2>%a@]" + (Style.as_inline_code Printtyp.type_expr) ty + (Style.as_inline_code pp_private) 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_502/typing/typedecl.mli b/upstream/ocaml_502/typing/typedecl.mli new file mode 100644 index 0000000000..5598271b0a --- /dev/null +++ b/upstream/ocaml_502/typing/typedecl.mli @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* 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 * Shape.t list + +val transl_exception: + Env.t -> Parsetree.extension_constructor -> + Typedtree.extension_constructor * Env.t * Shape.t + +val transl_type_exception: + Env.t -> + Parsetree.type_exception -> Typedtree.type_exception * Env.t * Shape.t + +val transl_type_extension: + bool -> Env.t -> Location.t -> Parsetree.type_extension -> + Typedtree.type_extension * Env.t * Shape.t list + +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 + +type native_repr_kind = Unboxed | Untagged + +type reaching_type_path = reaching_type_step list +and reaching_type_step = + | Expands_to of type_expr * type_expr + | Contains of type_expr * type_expr + +type error = + Repeated_parameter + | Duplicate_constructor of string + | Too_many_constructors + | Duplicate_label of string + | Recursive_abbrev of string * Env.t * reaching_type_path + | Cycle_in_def of string * Env.t * reaching_type_path + | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error + | Non_regular of { + definition: Path.t; + used_as: type_expr; + defined_as: type_expr; + reaching_path: reaching_type_path; + } + | 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 * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error + | 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_502/typing/typedecl_immediacy.ml b/upstream/ocaml_502/typing/typedecl_immediacy.ml new file mode 100644 index 0000000000..71e49a10be --- /dev/null +++ b/upstream/ocaml_502/typing/typedecl_immediacy.ml @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* 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 + | None -> Type_immediacy.Unknown + | Some argrepr -> Ctype.immediacy env argrepr + end + | (Type_variant (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_502/typing/typedecl_immediacy.mli b/upstream/ocaml_502/typing/typedecl_immediacy.mli new file mode 100644 index 0000000000..17fb985c80 --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/typedecl_properties.ml b/upstream/ocaml_502/typing/typedecl_properties.ml new file mode 100644 index 0000000000..28a1bb6673 --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/typedecl_properties.mli b/upstream/ocaml_502/typing/typedecl_properties.mli new file mode 100644 index 0000000000..153c3f719c --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/typedecl_separability.ml b/upstream/ocaml_502/typing/typedecl_separability.ml new file mode 100644 index 0000000000..c8f2f3b171 --- /dev/null +++ b/upstream/ocaml_502/typing/typedecl_separability.ml @@ -0,0 +1,668 @@ +(**************************************************************************) +(* *) +(* 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 get_desc ret_type with + | Tconstr (_, tyl, _) -> 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 get_desc ty 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 get_desc ty 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 (row_fields desc) in + let add_row acc = + let row = row_more desc in + match get_desc row with + | Tvariant more -> immediate_subtypes_variant_row acc more + | _ -> row :: acc + in + add_row (add_subtypes acc) + +and immediate_subtypes_variant_row_field acc f = + match row_field_repr f with + | Rpresent(None) + | Rabsent -> acc + | Rpresent(Some(ty)) -> ty :: acc + | Reither(_,field_types,_) -> + List.rev_append field_types acc + +let free_variables ty = + Ctype.free_variables ty + |> List.map (fun ty -> + match get_desc ty with + Tvar text -> {text; id = get_id ty} + | _ -> + (* 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 = + 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 (get_desc ty, 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 = get_id ty} 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 = ) + for each type parameter 'a of the type constructor. For each + such equation, we should "strengthen" the current context in + the following way: + - if is another variable 'b, + the mode of 'a is set to the mode of 'b, + and 'b is set to Ind + - if 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 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 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 get_desc param_instance with + | Tvar text -> + let var = {text; id = get_id param_instance} 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_502/typing/typedecl_separability.mli b/upstream/ocaml_502/typing/typedecl_separability.mli new file mode 100644 index 0000000000..079e640807 --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/typedecl_unboxed.ml b/upstream/ocaml_502/typing/typedecl_unboxed.ml new file mode 100644 index 0000000000..16290f0fbb --- /dev/null +++ b/upstream/ocaml_502/typing/typedecl_unboxed.ml @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* 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 + +(* 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 None else + let ty = Ctype.expand_head_opt env ty in + match get_desc ty with + | Tconstr (p, args, _) -> + begin match Env.find_type p env with + | exception Not_found -> Some ty + | {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 get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in + get_unboxed_type_representation env + (Ctype.apply env type_params ty2 args) (fuel - 1) + | _ -> Some ty + end + | _ -> Some 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_502/typing/typedecl_unboxed.mli b/upstream/ocaml_502/typing/typedecl_unboxed.mli new file mode 100644 index 0000000000..9e860dc128 --- /dev/null +++ b/upstream/ocaml_502/typing/typedecl_unboxed.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* 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 + +(* for typeopt.ml *) +val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option diff --git a/upstream/ocaml_502/typing/typedecl_variance.ml b/upstream/ocaml_502/typing/typedecl_variance.ml new file mode 100644 index 0000000000..c384e8c467 --- /dev/null +++ b/upstream/ocaml_502/typing/typedecl_variance.ml @@ -0,0 +1,437 @@ +(**************************************************************************) +(* *) +(* 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_variable_context = + | Type_declaration of Ident.t * type_declaration + | Gadt_constructor of constructor_declaration + | Extension_constructor of Ident.t * extension_constructor + +type variance_variable_error = + | No_variable + | Variance_not_reflected + | Variance_not_deducible + +type variance_error = + | Variance_not_satisfied of int + | Variance_variable_error of { + error : variance_variable_error; + context : variance_variable_context; + variable : type_expr + } + +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 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 get_desc ty with + Tarrow (_, ty1, ty2, _) -> + compute_variance_rec (Variance.conjugate vari) 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 + List.iter2 + (fun ty v -> compute_variance_rec (compose vari v) 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 -> + List.iter + (fun (_,f) -> + match row_field_repr f with + Rpresent (Some ty) -> + compute_same ty + | Reither (_, tyl, _) -> + let v = Variance.(inter vari unknown) in (* cf PR#7269 *) + List.iter (compute_variance_rec v) tyl + | _ -> ()) + (row_fields row); + compute_same (row_more row) + | Tpoly (ty, _) -> + compute_same ty + | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () + | Tpackage (_, fl) -> + let v = Variance.(compose vari full) 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_if p May_pos (set_if n May_neg (set_if i Inj null)) + +let injective = Variance.(set Inj null) + +let compute_variance_type env ~check (required, loc) decl tyl = + (* Requirements *) + let check_injectivity = Btype.type_kind_is_abstract decl 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 = 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 = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + if mem Inj (get_variance ty tvl) then () else + match get_desc ty 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 eq_type 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; + begin match check with + | None -> () + | Some context -> + (* 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.exists (eq_type 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 = + 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 begin + match List.find_opt (eq_type ty) fvl with + | Some variable -> + let error = + if not i2 then + No_variable + else if c2 || n2 then + Variance_not_reflected + else + Variance_not_deducible + in + let variance_error = + Variance_variable_error { error; context; variable } + in + raise + (Error (loc + , Bad_variance ( variance_error + , (c1,n1,false) + , (c2,n2,false)))) + | None -> + Btype.iter_type_expr check ty + end + 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 = not (Btype.type_kind_is_abstract decl) in + let (p, n) = + if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *) + else (false, false) (* only check *) + and i = concr in + let v = union v (make p n i) in + if not concr || Btype.is_Tvar ty then v else + union v + (if p then if n then full else covariant else conjugate covariant)) + 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 get_desc ty with + | Tvar _ -> List.exists (List.exists (eq_type ty)) 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 get_desc ret_type with + | Tconstr (_, tyl, _) -> + (* let tyl = List.map (Ctype.expand_head env) 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 decl ext rloc = + let check = + Some (Extension_constructor (ext.Typedtree.ext_id, ext.Typedtree.ext_type)) + in + let ext = ext.Typedtree.ext_type in + compute_variance_gadt env ~check rloc + {decl with type_params = ext.ext_type_params} + (ext.ext_args, ext.ext_ret_type) + +let compute_variance_gadt_constructor env ~check rloc decl tl = + let check = + match check with + | Some _ -> Some (Gadt_constructor tl) + | None -> None + in + compute_variance_gadt env ~check rloc decl + (tl.Types.cd_args, tl.Types.cd_res) + +let compute_variance_decl env ~check decl (required, _ as rloc) = + let check = + Option.map (fun id -> Type_declaration (id, decl)) check + in + let abstract = Btype.type_kind_is_abstract decl in + if (abstract || decl.type_kind = Type_open) && decl.type_manifest = None then + List.map + (fun (c, n, i) -> make (not n) (not c) (not abstract || i)) + required + else begin + let mn = + match decl.type_manifest with + None -> [] + | Some ty -> [ false, ty ] + in + let vari = + 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 vari = + List.map + (fun ty -> + compute_variance_type env ~check rloc + {decl with type_private = Private} + (add_false [ ty ]) + ) + (Option.to_list decl.type_manifest) + in + let constructor_variance = + List.map + (compute_variance_gadt_constructor env ~check rloc decl) + tll + in + match List.append vari constructor_variance with + | vari :: rem -> + List.fold_left (List.map2 Variance.union) vari rem + | _ -> 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) + in + if mn = [] || not abstract then + List.map Variance.strengthen vari + else vari + end + +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 decl ext rloc) + +let compute_decl env ~check decl req = + compute_variance_decl env ~check decl (req, decl.type_loc) + +let check_decl env id decl req = + ignore (compute_variance_decl env ~check:(Some id) 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:None 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 id 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, _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) (_, _, clty, cltydef, _) -> + let variance = decl.type_variance in + (decl, {clty with cty_variance = variance}, + {cltydef with + clty_variance = variance; + clty_hash_type = {cltydef.clty_hash_type with type_variance = variance} + })) + decls cldecls diff --git a/upstream/ocaml_502/typing/typedecl_variance.mli b/upstream/ocaml_502/typing/typedecl_variance.mli new file mode 100644 index 0000000000..6392e61dd1 --- /dev/null +++ b/upstream/ocaml_502/typing/typedecl_variance.mli @@ -0,0 +1,75 @@ +(**************************************************************************) +(* *) +(* 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_variable_context = + | Type_declaration of Ident.t * type_declaration + | Gadt_constructor of constructor_declaration + | Extension_constructor of Ident.t * extension_constructor + +type variance_variable_error = + | No_variable + | Variance_not_reflected + | Variance_not_deducible + +type variance_error = + | Variance_not_satisfied of int + | Variance_variable_error of { + error : variance_variable_error; + context : variance_variable_context; + variable : type_expr + } + +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:Ident.t option -> 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.class_declaration * Types.class_type_declaration * + 'a Typedtree.class_infos) list -> + (Typedecl_properties.decl * + Types.class_declaration * Types.class_type_declaration) list +(* FIXME: improve this horrible interface *) diff --git a/upstream/ocaml_502/typing/typedtree.ml b/upstream/ocaml_502/typing/typedtree.ml new file mode 100644 index 0000000000..e2978ba03f --- /dev/null +++ b/upstream/ocaml_502/typing/typedtree.ml @@ -0,0 +1,910 @@ +(**************************************************************************) +(* *) +(* 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 + +module Uid = Shape.Uid + +(* 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 * Uid.t -> value pattern_desc + | Tpat_alias : + value general_pattern * Ident.t * string loc * Uid.t -> 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 function_param list * function_body + | 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 + | 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 * (Ident.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 * Location.t + | 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 + | Tmeth_ancestor of Ident.t * Path.t + +and 'k case = + { + c_lhs: 'k general_pattern; + c_guard: expression option; + c_rhs: expression; + } + +and function_param = + { + fp_arg_label: arg_label; + fp_param: Ident.t; + fp_partial: partial; + fp_kind: function_param_kind; + fp_newtypes: string loc list; + fp_loc : Location.t; + } + +and function_param_kind = + | Tparam_pat of pattern + | Tparam_optional_default of pattern * expression + +and function_body = + | Tfunction_body of expression + | Tfunction_cases of + { cases: value case list; + partial: partial; + param: Ident.t; + loc: Location.t; + exp_extra: exp_extra option; + attributes: attributes; + } + +and record_label_definition = + | Kept of Types.type_expr * mutable_flag + | 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 * MethSet.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_apply_unit of module_expr + | 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_uid: Uid.t; + 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_rec_kind: Value_rec_types.recursive_binding_kind; + 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_uid: Uid.t; + 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_uid: Uid.t; + 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_uid: Uid.t; + 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 loc + | Ttyp_variant of row_field list * closed_flag * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + | Ttyp_open of Path.t * Longident.t loc * core_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_uid: Uid.t; + 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_uid: Uid.t; + cd_vars: string loc list; + 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 string loc list * 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_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; + shape: Shape.t; +} + +type item_declaration = + | Value of value_description + | Value_binding of value_binding + | Type of type_declaration + | Constructor of constructor_declaration + | Extension_constructor of extension_constructor + | Label of label_declaration + | Module of module_declaration + | Module_substitution of module_substitution + | Module_binding of module_binding + | Module_type of module_type_declaration + | Class of class_declaration + | Class_type of class_type_declaration + +(* 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, uid) -> + Tpat_alias (f.f p1, id, s, uid) + | 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, uid) -> + f (id,s,pat.pat_type, uid) + | Tpat_alias(p, id, s, uid) -> + iter_bound_idents f p; + f (id,s,pat.pat_type, uid) + | 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, uid) -> (* note the ``Not_found'' case *) + {p with pat_desc = + try Tpat_var (alpha_var env id, s, uid) with + | Not_found -> Tpat_any} + | Tpat_alias (p1, id, s, uid) -> + let new_p = alpha_pat env p1 in + begin try + {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s, uid)} + 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 + +(* Expressions are considered nominal if they can be used as the subject of a + sentence or action. In practice, we consider that an expression is nominal + if they satisfy one of: + - Similar to an identifier: words separated by '.' or '#'. + - Do not contain spaces when printed. + *) +let rec exp_is_nominal exp = + match exp.exp_desc with + | _ when exp.exp_attributes <> [] -> false + | Texp_ident _ | Texp_instvar _ | Texp_constant _ + | Texp_variant (_, None) + | Texp_construct (_, _, []) -> + true + | Texp_field (parent, _, _) | Texp_send (parent, _) -> exp_is_nominal parent + | _ -> false diff --git a/upstream/ocaml_502/typing/typedtree.mli b/upstream/ocaml_502/typing/typedtree.mli new file mode 100644 index 0000000000..5f042f0e22 --- /dev/null +++ b/upstream/ocaml_502/typing/typedtree.mli @@ -0,0 +1,919 @@ +(**************************************************************************) +(* *) +(* 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 +module Uid = Shape.Uid + +(* 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, _, _) :: ... } + (module _) { pat_desc = Tpat_any + ; pat_extra = (Tpat_unpack, _, _) :: ... } + *) + +and 'k pattern_desc = + (* value patterns *) + | Tpat_any : value pattern_desc + (** _ *) + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc + (** x *) + | Tpat_alias : + value general_pattern * Ident.t * string loc * Uid.t -> 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 function_param list * function_body + (** fun P0 P1 -> function p1 -> e1 | p2 -> e2 (body = Tfunction_cases _) + fun P0 P1 -> E (body = Tfunction_body _) + + This construct has the same arity as the originating + {{!Parsetree.expression_desc.Pexp_function}[Pexp_function]}. + Arity determines when side-effects for effectful parameters are run + (e.g. optional argument defaults, matching against lazy patterns). + Parameters' effects are run left-to-right when an n-ary function is + saturated with n arguments. + *) + | 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 + | 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 * (Ident.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 * Location.t + | 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 + | Tmeth_ancestor of Ident.t * Path.t + +and 'k case = + { + c_lhs: 'k general_pattern; + c_guard: expression option; + c_rhs: expression; + } + +and function_param = + { + fp_arg_label: arg_label; + fp_param: Ident.t; + (** [fp_param] is the identifier that is to be used to name the + parameter of the function. + *) + fp_partial: partial; + (** + [fp_partial] = + [Partial] if the pattern match is partial + [Total] otherwise. + *) + fp_kind: function_param_kind; + fp_newtypes: string loc list; + (** [fp_newtypes] are the new type declarations that come *after* that + parameter. The newtypes that come before the first parameter are + placed as exp_extras on the Texp_function node. This is just used in + {!Untypeast}. *) + fp_loc: Location.t; + (** [fp_loc] is the location of the entire value parameter, not including + the [fp_newtypes]. + *) + } + +and function_param_kind = + | Tparam_pat of pattern + (** [Tparam_pat p] is a non-optional argument with pattern [p]. *) + | Tparam_optional_default of pattern * expression + (** [Tparam_optional_default (p, e)] is an optional argument [p] with default + value [e], i.e. [?x:(p = e)]. If the parameter is of type [a option], the + pattern and expression are of type [a]. *) + +and function_body = + | Tfunction_body of expression + | Tfunction_cases of + { cases: value case list; + partial: partial; + param: Ident.t; + loc: Location.t; + exp_extra: exp_extra option; + attributes: attributes; + (** [attributes] is just used in untypeast. *) + } +(** The function body binds a final argument in [Tfunction_cases], + and this argument is pattern-matched against the cases. +*) + +and record_label_definition = + | Kept of Types.type_expr * mutable_flag + | 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.MethSet.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_apply_unit of module_expr + | 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; (** [None] for [module _ = struct ... end] *) + mb_name: string option loc; + mb_uid: Uid.t; + 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_rec_kind: Value_rec_types.recursive_binding_kind; + 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 + (** External declaration coerced to a regular value. + {[ + module M : sig val ext : a -> b end = + struct external ext : a -> b = "my_c_function" end + ]} + Only occurs inside a [Tcoerce_structure] coercion. *) + | Tcoerce_alias of Env.t * Path.t * module_coercion + (** Module alias coerced to a regular module. + {[ + module M : sig module Sub : T end = + struct module Sub = Some_alias end + ]} + Only occurs inside a [Tcoerce_structure] 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_uid: Uid.t; + 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_uid: Uid.t; + 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_uid: Uid.t; + 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 loc + | Ttyp_variant of row_field list * closed_flag * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + | Ttyp_open of Path.t * Longident.t loc * core_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_uid: Uid.t; + 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_uid: Uid.t; + cd_vars: string loc list; + 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 string loc list * 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_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; + shape: Shape.t; +} +(** 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. +*) + +type item_declaration = + | Value of value_description + | Value_binding of value_binding + | Type of type_declaration + | Constructor of constructor_declaration + | Extension_constructor of extension_constructor + | Label of label_declaration + | Module of module_declaration + | Module_substitution of module_substitution + | Module_binding of module_binding + | Module_type of module_type_declaration + | Class of class_declaration + | Class_type of class_type_declaration +(** [item_declaration] groups together items that correspond to the syntactic + category of "declarations" which include types, values, modules, etc. + declarations in signatures and their definitions in implementations. *) + +(* 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 * Types.Uid.t) 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 * Types.Uid.t) list + +(** Splits an or pattern into its value (left) and exception (right) parts. *) +val split_pattern: + computation general_pattern -> pattern option * pattern option + +(** Whether an expression looks nice as the subject of a sentence in a error + message. *) +val exp_is_nominal : expression -> bool diff --git a/upstream/ocaml_502/typing/typemod.ml b/upstream/ocaml_502/typing/typemod.ml new file mode 100644 index 0000000000..b8934f1713 --- /dev/null +++ b/upstream/ocaml_502/typing/typemod.ml @@ -0,0 +1,3458 @@ +(**************************************************************************) +(* *) +(* 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 Style = Misc.Style + +let () = Includemod_errorprinter.register () + +module Sig_component_kind = Shape.Sig_component_kind +module String = Misc.Stdlib.String + +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 { vars : type_expr list; expression : type_expr } + | Non_generalizable_module of + { vars : type_expr list; item : value_description; mty : 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 + | Pextra_ty (p, extra) -> Pextra_ty (path_concat head p, extra) + +(* 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 ~initially_opened_module + ~open_implicit_modules = + let env = Env.initial 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_visible ()) + 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_if p May_pos (set_if n May_neg (set_if i Inj 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 *) + | Pextra_ty _ -> assert false + +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 get_desc ty 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 get_desc hd 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 Definition; + 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 = + Env.lookup_modtype_path ~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_path ~use:false ~load:false + ~loc:lid'.loc lid'.txt env) + | Pwith_modsubst (_, lid') -> + ignore (Env.lookup_module_path ~use:false ~load: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, env = 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); + ] + ) 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 | Label | Constructor -> 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" attr + in + match remove_aliases with + | None -> false + | Some _ -> true + +(* Check and translate a module type expression *) + +let transl_modtype_longident loc env lid = + Env.lookup_modtype_path ~loc lid env + +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 ?(toplevel = 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 -> + 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, _shapes) = + 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, _s) = 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_uid=md.md_uid; 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_uid=md.md_uid; 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, _uid) -> + 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 (fun (md, _, _) -> md) 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, decl = 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, + Sig_modtype (mtd.mtd_id, decl, Exported) :: rem, + final_env + | Psig_modtypesubst pmtd -> + let newenv, mtd, _decl = 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; + ) 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) + ] + ) 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; + ) 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); + ] + ) 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; + if toplevel || not (Warnings.is_active (Misplaced_attribute "")) + then Builtin_attributes.mark_alert_used 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_uid=decl.mtd_uid; + mtd_type=tmty; + mtd_attributes=pmtd_attributes; + mtd_loc=pmtd_loc; + } + in + newenv, mtd, decl + +and transl_recmodule_modtypes env sdecls = + let make_env curr = + List.fold_left (fun env (id_shape, _, md, _) -> + Option.fold ~none:env ~some:(fun (id, shape) -> + Env.add_module_declaration ~check:true ~shape ~arg:true + id Mp_present md env + ) id_shape + ) env curr + in + let transition env_c curr = + List.map2 + (fun pmd (id_shape, 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_shape, id_loc, md, tmty)) + sdecls curr in + let map_mtys curr = + List.filter_map + (fun (id_shape, _, md, _) -> + Option.map (fun (id, _) -> (id, md)) id_shape) + 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_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let md = + { md_type = approx_modtype approx_env pmd.pmd_type; + md_loc = pmd.pmd_loc; + md_attributes = pmd.pmd_attributes; + md_uid } + in + let id_shape = + Option.map (fun id -> id, Shape.var md_uid id) id + in + (id_shape, 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_shape, id_loc, md, mty) -> + let tmd = + {md_id=Option.map fst id_shape; md_name=id_loc; md_type=mty; + md_uid=md.Types.md_uid; md_presence=Mp_present; + md_loc=pmd.pmd_loc; + md_attributes=pmd.pmd_attributes} + in + tmd, md.Types.md_uid, Option.map snd id_shape + ) 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 + | (Tmod_structure _ | Tmod_functor _ | Tmod_apply_unit _ | Tmod_unpack _ | + Tmod_apply _) -> + 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 + do not contain non-generalized type variable *) + +let rec nongen_modtype env = function + Mty_ident _ -> None + | Mty_alias _ -> None + | Mty_signature sg -> + let env = Env.add_signature sg env in + List.find_map (nongen_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 + nongen_modtype env body + +and nongen_signature_item env = function + | Sig_value(_id, desc, _) -> + Ctype.nongen_vars_in_schema env desc.val_type + |> Option.map (fun vars -> (vars, desc)) + | Sig_module(_id, _, md, _, _) -> nongen_modtype env md.md_type + | _ -> None + +let check_nongen_modtype env loc mty = + nongen_modtype env mty + |> Option.iter (fun (vars, item) -> + let vars = Btype.TypeSet.elements vars in + let error = + Non_generalizable_module { vars; item; mty } + in + raise(Error(loc, env, error)) + ) + +let check_nongen_signature_item env sig_item = + match sig_item with + Sig_value(_id, vd, _) -> + Ctype.nongen_vars_in_schema env vd.val_type + |> Option.iter (fun vars -> + let vars = Btype.TypeSet.elements vars in + let error = + Non_generalizable { vars; expression = vd.val_type } + in + raise (Error (vd.val_loc, env, error)) + ) + | Sig_module (_id, _, md, _, _) -> + check_nongen_modtype env md.md_loc md.md_type + | _ -> () + +let check_nongen_signature env sg = + List.iter (check_nongen_signature_item 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, shape, _uid) -> + let ids = + Option.map + (fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id + in + (ids, mty_actual, shape)) + 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, shape) -> + 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 ~shape 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, _shape) -> + 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, shape, 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, shape = + try + Includemod.modtypes_with_shape ~shape + ~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_uid = uid; + mb_presence = Mp_present; + mb_expr = modl'; + mb_attributes = attrs; + mb_loc = loc; + } + in + mb, shape, 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 = + (* We call Ctype.correct_levels to ensure that the types being added to the + module type are at generic_level. *) + let mty = + package_constraints env loc (Mty_ident p) + (List.map (fun (n, t) -> Longident.flatten n, Ctype.correct_levels t) fl) + in + Subst.modtype Keep Subst.identity mty + +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_package env mark arg mty explicit = + let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let mty1 = Subst.modtype Keep Subst.identity arg.mod_type in + let mty2 = Subst.modtype Keep Subst.identity mty in + let coercion = + try + Includemod.modtypes ~loc:arg.mod_loc env ~mark mty1 mty2 + 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 } + +let wrap_constraint_with_shape env mark arg mty + shape explicit = + let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let coercion, shape = + try + Includemod.modtypes_with_shape ~shape ~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 }, shape + +(* Type a module value expression *) + + +(* These describe the X in [F(X)] (which might be missing, for [F ()]) *) +type argument_summary = { + is_syntactic_unit: bool; + arg: Typedtree.module_expr; + path: Path.t option; + shape: Shape.t +} + +type application_summary = { + loc: Location.t; + attributes: attributes; + f_loc: Location.t; (* loc for F *) + arg: argument_summary option (* None for () *) +} + +let simplify_app_summary app_view = match app_view.arg with + | None -> + Includemod.Error.Unit, Mty_signature [] + | Some arg -> + let mty = arg.arg.mod_type in + match arg.is_syntactic_unit , arg.path with + | true , _ -> Includemod.Error.Empty_struct, 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 shape = + Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path + in + let shape = if alias && aliasable then Shape.alias shape else shape in + let md = + if alias && aliasable then + (Env.add_required_global (Path.head path); md) + else begin + let mty = + if sttn then + Env.find_strengthened_module ~aliasable path env + else + (Env.find_module path env).md_type + in + match mty 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 + ~strengthen:sttn env p1 in + { md with + mod_desc = + Tmod_constraint (md, mty, Tmodtype_implicit, + Tcoerce_alias (env, path, Tcoerce_none)); + mod_type = mty } + | mty -> + { md with mod_type = mty } + end + in + md, shape + | Pmod_structure sstr -> + let (str, sg, names, shape, _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, shape else + wrap_constraint_with_shape env false md + (Mty_signature sg') shape Tmodtype_implicit + | Pmod_functor(arg_opt, sbody) -> + let t_arg, ty_arg, newenv, funct_shape_param, funct_body = + match arg_opt with + | Unit -> + Unit, Types.Unit, env, Shape.for_unnamed_functor_param, false + | Named (param, smty) -> + let mty = transl_modtype_functor_arg env smty in + let scope = Ctype.create_scope () in + let (id, newenv, var) = + match param.txt with + | None -> None, env, Shape.for_unnamed_functor_param + | Some name -> + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let arg_md = + { md_type = mty.mty_type; + md_attributes = []; + md_loc = param.loc; + md_uid; + } + in + let id = Ident.create_scoped ~scope name in + let shape = Shape.var md_uid id in + let newenv = Env.add_module_declaration + ~shape ~arg:true ~check:true id Mp_present arg_md env + in + Some id, newenv, id + in + Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, + var, true + in + let body, body_shape = 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 }, + Shape.abs funct_shape_param body_shape + | Pmod_apply _ | Pmod_apply_unit _ -> + type_application smod.pmod_loc sttn funct_body env smod + | Pmod_constraint(sarg, smty) -> + let arg, arg_shape = type_module ~alias true funct_body anchor env sarg in + let mty = transl_modtype env smty in + let md, final_shape = + wrap_constraint_with_shape env true arg mty.mty_type arg_shape + (Tmodtype_explicit mty) + in + { md with + mod_loc = smod.pmod_loc; + mod_attributes = smod.pmod_attributes; + }, + final_shape + | Pmod_unpack sexp -> + let exp = + Ctype.with_local_level_if_principal + (fun () -> Typecore.type_exp env sexp) + ~post:Typecore.generalize_structure_exp + in + let mty = + match get_desc (Ctype.expand_head env exp.exp_type) with + 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 + | 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 }, + Shape.leaf_for_unpack + | 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, shape = 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 = Some { + is_syntactic_unit = sarg.pmod_desc = Pmod_structure []; + arg; + path = path_of_module arg; + shape; + } + } in + extract_application funct_body env (summary::sargs) f + | Pmod_apply_unit f -> + let summary = { + loc = smod.pmod_loc; + attributes = smod.pmod_attributes; + f_loc = f.pmod_loc; + arg = None + } in + extract_application funct_body env (summary::sargs) f + | _ -> smod, sargs + in + let sfunct, args = extract_application funct_body env [] smod in + let funct, funct_shape = + let has_path { arg } = match arg with + | None | Some { path = None } -> false + | Some { path = Some _ } -> true + in + let strengthen = strengthen && List.for_all has_path args in + type_module strengthen funct_body None env sfunct + in + List.fold_left + (type_one_application ~ctx:(loc, sfunct, funct, args) funct_body env) + (funct, funct_shape) args + +and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) + funct_body env (funct, funct_shape) app_view = + match Env.scrape_alias env funct.mod_type with + | Mty_functor (Unit, mty_res) -> + begin match app_view.arg with + | None -> () + | Some arg -> + if arg.is_syntactic_unit then + (* this call to warning_scope allows e.g. + [ F (struct end [@warning "-73"]) ] + not to warn; useful when generating code that must + work over multiple versions of OCaml *) + Builtin_attributes.warning_scope arg.arg.mod_attributes @@ fun () -> + Location.prerr_warning arg.arg.mod_loc + Warnings.Generative_application_expects_unit + else + raise (Error (app_view.f_loc, env, Apply_generative)); + end; + 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_unit funct; + mod_type = mty_res; + mod_env = env; + mod_attributes = app_view.attributes; + mod_loc = funct.mod_loc }, + Shape.app funct_shape ~arg:Shape.dummy_mod + | Mty_functor (Named (param, mty_param), mty_res) as mty_functor -> + let apply_error () = + let args = List.map simplify_app_summary args in + let mty_f = md_f.mod_type in + let app_name = match sfunct.pmod_desc with + | Pmod_ident l -> Includemod.Named_leftmost_functor l.txt + | _ -> Includemod.Anonymous_functor + in + raise(Includemod.Apply_error {loc=apply_loc;env;app_name;mty_f;args}) + in + begin match app_view with + | { arg = None; _ } -> apply_error () + | { loc = app_loc; attributes = app_attributes; + arg = Some { shape = arg_shape; path = arg_path; arg } } -> + let coercion = + try Includemod.modtypes + ~loc:arg.mod_loc ~mark:Mark_both env arg.mod_type mty_param + with Includemod.Error _ -> apply_error () + in + let mty_appl = + match 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 arg.mod_type env + in + check_well_formed_module env app_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_loc, env, error)) + in + begin match + Includemod.modtypes + ~loc:app_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, arg, coercion); + mod_type = mty_appl; + mod_env = env; + mod_attributes = app_attributes; + mod_loc = app_loc }, + Shape.app ~arg:arg_shape funct_shape + end + | Mty_alias path -> + raise(Error(app_view.f_loc, env, Cannot_scrape_alias path)) + | Mty_ident _ | Mty_signature _ -> + let args = List.map simplify_app_summary args in + let mty_f = md_f.mod_type in + let app_name = match sfunct.pmod_desc with + | Pmod_ident l -> Includemod.Named_leftmost_functor l.txt + | _ -> Includemod.Anonymous_functor + in + raise(Includemod.Apply_error {loc=apply_loc;env;app_name;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, mod_shape = type_module true funct_body None env od.popen_expr in + let scope = Ctype.create_scope () in + let sg, newenv = + Env.enter_signature ~scope ~mod_shape + (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 shape_map {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), [], shape_map, env + | Pstr_value(rec_flag, sdefs) -> + let (defs, newenv) = + Typecore.type_binding env rec_flag sdefs in + let defs = match rec_flag with + | Recursive -> Typecore.annotate_recursive_bindings env defs + | Nonrecursive -> 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. *) + let items, shape_map = + List.fold_left + (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ, _uid)-> + Signature_names.check_value names loc id; + let vd = Env.find_value (Pident id) newenv in + Sig_value(id, vd, Exported) :: acc, + Shape.Map.add_value shape_map id vd.val_uid + ) + ([], shape_map) + (let_bound_idents_full defs) + in + Tstr_value(rec_flag, defs), + List.rev items, + shape_map, + 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)], + Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid, + newenv + | Pstr_type (rec_flag, sdecls) -> + let (decls, newenv, shapes) = + 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; + let items = map_rec_type_with_row_types ~rec_flag + (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported)) + decls [] + in + let shape_map = List.fold_left2 + (fun map { typ_id; _} shape -> + Shape.Map.add_type map typ_id shape) + shape_map + decls + shapes + in + Tstr_type (rec_flag, decls), + items, + shape_map, + enrich_type_decls anchor decls env newenv + | Pstr_typext styext -> + let (tyext, newenv, shapes) = + Typedecl.transl_type_extension true env loc styext + in + let constructors = tyext.tyext_constructors in + let shape_map = List.fold_left2 (fun shape_map ext shape -> + Signature_names.check_typext names ext.ext_loc ext.ext_id; + Shape.Map.add_extcons shape_map ext.ext_id shape + ) shape_map constructors shapes + in + (Tstr_typext tyext, + map_ext + (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported)) + constructors [], + shape_map, + newenv) + | Pstr_exception sext -> + let (ext, newenv, shape) = 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)], + Shape.Map.add_extcons shape_map + constructor.ext_id + shape, + 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, md_shape = + 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 + let md_shape = Shape.set_uid_if_none md_shape 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 ~shape:md_shape 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 + let shape_map = match id with + | Some id -> Shape.Map.add_module shape_map id md_shape + | None -> shape_map + in + Tstr_module {mb_id=id; mb_name=name; mb_uid = md.md_uid; + mb_expr=modl; mb_presence=pres; mb_attributes=attrs; + mb_loc=pmb_loc; }, + sg, + shape_map, + 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, _prev_shape) + (name, _, smodl, attrs, loc) -> + let modl, shape = + 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, shape, uid)) + decls sbind in + let newenv = (* allow aliasing recursive modules from outside *) + List.fold_left + (fun env (id_opt, _, mty, _, _, attrs, loc, shape, uid) -> + match id_opt with + | None -> env + | Some id -> + let mdecl = + { + md_type = mty.mty_type; + md_attributes = attrs; + md_loc = loc; + md_uid = uid; + } + in + Env.add_module_declaration ~check:true ~shape + id Mp_present mdecl env + ) + env bindings1 + in + let bindings2 = + check_recmodule_inclusion newenv bindings1 in + let mbs = + List.filter_map (fun (mb, shape, uid) -> + Option.map (fun id -> id, mb, uid, shape) mb.mb_id + ) bindings2 + in + let shape_map = + List.fold_left (fun map (id, _mb, _uid, shape) -> + Shape.Map.add_module map id shape + ) shape_map mbs + in + Tstr_recmodule (List.map (fun (mb, _, _) -> mb) bindings2), + map_rec (fun rs (id, mb, uid, _shape) -> + 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 [], + shape_map, + newenv + | Pstr_modtype pmtd -> + (* check that it is non-abstract *) + let newenv, mtd, decl = transl_modtype_decl env pmtd in + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + let id = mtd.mtd_id in + let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in + Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv + | Pstr_open sod -> + let (od, sg, newenv) = + type_open_decl ~toplevel funct_body names env sod + in + Tstr_open od, sg, shape_map, newenv + | Pstr_class cl -> + let (classes, new_env) = Typeclass.class_declarations env cl in + let shape_map = List.fold_left (fun acc 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; + let uid = cls.cls_decl.cty_uid in + let map f id v acc = f acc id v in + map Shape.Map.add_class cls.cls_id uid acc + |> map Shape.Map.add_class_type cls.cls_ty_id uid + |> map Shape.Map.add_type cls.cls_obj_id (Shape.leaf uid) + ) shape_map classes + in + 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) + ]) + classes []), + shape_map, + new_env + | Pstr_class_type cl -> + let (classes, new_env) = Typeclass.class_type_declarations env cl in + let shape_map = List.fold_left (fun acc 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; + let uid = decl.clsty_ty_decl.clty_uid in + let map f id v acc = f acc id v in + map Shape.Map.add_class_type decl.clsty_ty_id uid acc + |> map Shape.Map.add_type decl.clsty_obj_id (Shape.leaf uid) + ) shape_map classes + in + 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); + ]) + classes []), + shape_map, + new_env + | Pstr_include sincl -> + let smodl = sincl.pincl_mod in + let modl, modl_shape = + 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, shape, new_env = + Env.enter_signature_and_shape ~scope ~parent_shape:shape_map + modl_shape (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, shape, new_env + | Pstr_extension (ext, _attrs) -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | Pstr_attribute x -> + Builtin_attributes.warning_attribute x; + if toplevel || not (Warnings.is_active (Misplaced_attribute "")) then + Builtin_attributes.mark_alert_used x; + Tstr_attribute x, [], shape_map, env + in + let rec type_struct env shape_map sstr = + match sstr with + | [] -> ([], [], shape_map, env) + | pstr :: srem -> + let previous_saved_types = Cmt_format.get_saved_types () in + let desc, sg, shape_map, new_env = type_str_item env shape_map 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, shape_map, final_env) = + type_struct new_env shape_map srem + in + (str :: str_rem, sg @ sig_rem, shape_map, final_env) + in + let previous_saved_types = Cmt_format.get_saved_types () in + let run () = + let (items, sg, shape_map, final_env) = + type_struct env Shape.Map.empty 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, Shape.str shape_map, final_env + in + if toplevel then run () + else Builtin_attributes.warning_scope [] run + +let type_toplevel_phrase env s = + Env.reset_required_globals (); + type_structure ~toplevel:true false None env s + +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 } + | _ -> + let me, _shape = type_module env smod in + me + in + let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in + (* PR#5036: must not contain non-generalized type variables *) + check_nongen_modtype env smod.pmod_loc 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 *) + let modl, scope = + Typetexp.TyVarEnv.with_local_scope begin fun () -> + (* type the module and create a scope in a raised level *) + Ctype.with_local_level begin fun () -> + let modl, _mod_shape = type_module env m in + let scope = Ctype.create_scope () in + modl, scope + end + end + in + 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 + 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_package 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; + Typetexp.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 target annots = + let annot = Unit_info.annot target in + Cmt2annot.gen_annot (Some (Unit_info.Artifact.filename annot)) + ~sourcefile:(Unit_info.Artifact.source_file annot) + ~use_summaries:false + annots + +let type_implementation target initial_env ast = + let sourcefile = Unit_info.source_file target in + let save_cmt target annots initial_env cmi shape = + Cmt_format.save_cmt (Unit_info.cmt target) + annots initial_env cmi shape; + gen_annot target annots; + in + 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, shape, finalenv) = + type_structure initial_env ast in + let shape = + let id = Ident.create_persistent @@ Unit_info.modname target in + Shape.set_uid_if_none shape (Uid.of_compilation_unit_id id) + in + let simple_sg = Signature_names.simplify finalenv names sg in + if !Clflags.print_types then begin + Typecore.force_delayed_checks (); + let shape = Shape_reduce.local_reduce Env.empty shape in + Printtyp.wrap_printing_env ~error:false initial_env + (fun () -> fprintf std_formatter "%a@." + (Printtyp.printed_signature @@ Unit_info.source_file target) + simple_sg + ); + gen_annot target (Cmt_format.Implementation str); + { structure = str; + coercion = Tcoerce_none; + shape; + signature = simple_sg + } (* result is ignored by Compile.implementation *) + end else begin + let source_intf = Unit_info.mli_from_source target in + if !Clflags.cmi_file <> None + || Sys.file_exists source_intf then begin + let compiled_intf_file = + match !Clflags.cmi_file with + | Some cmi_file -> Unit_info.Artifact.from_filename cmi_file + | None -> + try Unit_info.find_normalized_cmi target with Not_found -> + raise(Error(Location.in_file sourcefile, Env.empty, + Interface_not_compiled source_intf)) + in + let dclsig = Env.read_signature compiled_intf_file in + let coercion, shape = + Includemod.compunit initial_env ~mark:Mark_positive + sourcefile sg source_intf + dclsig shape + 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 shape = Shape_reduce.local_reduce Env.empty shape in + let annots = Cmt_format.Implementation str in + save_cmt target annots initial_env None (Some shape); + { structure = str; + coercion; + shape; + signature = dclsig + } + end else begin + Location.prerr_warning + (Location.in_file (Unit_info.source_file target)) + Warnings.Missing_mli; + let coercion, shape = + Includemod.compunit initial_env ~mark:Mark_positive + sourcefile sg "(inferred signature)" simple_sg shape + in + check_nongen_signature finalenv simple_sg; + normalize_signature simple_sg; + Typecore.force_delayed_checks (); + (* See comment above. Here the target signature contains all + the values 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. *) + let shape = Shape_reduce.local_reduce Env.empty shape in + 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 (Unit_info.cmi target) + in + let annots = Cmt_format.Implementation str in + save_cmt target annots initial_env (Some cmi) (Some shape) + end; + { structure = str; + coercion; + shape; + signature = simple_sg + } + end + end + ) + ~exceptionally:(fun () -> + let annots = + Cmt_format.Partial_implementation + (Array.of_list (Cmt_format.get_saved_types ())) + in + save_cmt target annots initial_env None None + ) + +let save_signature target tsg initial_env cmi = + Cmt_format.save_cmt (Unit_info.cmti target) + (Cmt_format.Interface tsg) initial_env (Some cmi) None + +let type_interface env ast = + transl_signature ~toplevel:true env ast + +let transl_signature env ast = + transl_signature ~toplevel:false 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 target_cmi = + (* Read the signatures of the units *) + let units = + List.map + (fun f -> + let artifact = Unit_info.Artifact.from_filename f in + let sg = Env.read_signature (Unit_info.companion_cmi artifact) in + if Unit_info.is_cmi artifact && + not(Mtype.no_code_needed_sig Env.initial sg) + then raise(Error(Location.none, Env.empty, + Implementation_is_required f)); + Unit_info.Artifact.modname artifact, sg) + objfiles in + (* Compute signature of packaged unit *) + Ident.reinit(); + let sg = package_signatures units in + (* Compute the shape of the package *) + let prefix = Unit_info.Artifact.prefix target_cmi in + let pack_uid = Uid.of_compilation_unit_id (Ident.create_persistent prefix) in + let shape = + List.fold_left (fun map (name, _sg) -> + let id = Ident.create_persistent name in + Shape.Map.add_module map id (Shape.for_persistent_unit name) + ) Shape.Map.empty units + |> Shape.str ~uid:pack_uid + in + (* See if explicit interface is provided *) + let mli = Unit_info.mli_from_artifact target_cmi in + if Sys.file_exists mli then begin + if not (Sys.file_exists @@ Unit_info.Artifact.filename target_cmi) then + begin + raise(Error(Location.in_file mli, Env.empty, + Interface_not_compiled mli)) + end; + let dclsig = Env.read_signature target_cmi in + let cc, _shape = + Includemod.compunit initial_env ~mark:Mark_both + "(obtained by packing)" sg mli dclsig shape + in + Cmt_format.save_cmt (Unit_info.companion_cmt target_cmi) + (Cmt_format.Packed (sg, objfiles)) initial_env None (Some shape); + cc + 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 target_cmi imports + in + Cmt_format.save_cmt (Unit_info.companion_cmt target_cmi) + (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) initial_env + (Some cmi) (Some shape); + 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@]" + (Style.as_inline_code modtype) mty + | Not_included errs -> + let main = Includemod_errorprinter.err_msgs errs in + Location.errorf ~loc "@[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.@]" + (Style.as_inline_code 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" + (Style.as_inline_code modtype) mty + | With_no_component lid -> + Location.errorf ~loc + "@[The signature constrained by %a has no component named %a@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid + | With_mismatch(lid, explanation) -> + let main = Includemod_errorprinter.err_msgs explanation in + Location.errorf ~loc + "@[\ + @[In this %a constraint, the new definition of %a@ \ + does not match its original definition@ \ + in the constrained signature:@]@ \ + %t@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid main + | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> + let main = Includemod_errorprinter.err_msgs explanation in + Location.errorf ~loc + "@[\ + @[This %a constraint on %a makes the applicative functor @ \ + type %a ill-typed in the constrained signature:@]@ \ + %t@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid + Style.inline_code (Path.name path) + main + | With_changes_module_alias(lid, id, path) -> + Location.errorf ~loc + "@[\ + @[This %a constraint on %a changes %a, which is aliased @ \ + in the constrained signature (as %a)@].@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid + Style.inline_code (Path.name path) + Style.inline_code (Ident.name id) + | With_cannot_remove_constrained_type -> + Location.errorf ~loc + "@[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) -> + let[@manual.ref "ss:module-type-substitution"] manual_ref = + [ 12; 7; 3 ] + in + let pp_constraint ppf () = + Format.fprintf ppf "%s := %a" + (Path.name p) Printtyp.modtype mty + in + Location.errorf ~loc + "This %a constraint@ %a@ makes a packed module ill-formed.@ %a" + Style.inline_code "with" + (Style.as_inline_code pp_constraint) () + Misc.print_see_manual manual_ref + | Repeated_name(kind, name) -> + Location.errorf ~loc + "@[Multiple definition of the %s name %a.@ \ + Names must be unique in a given structure or signature.@]" + (Sig_component_kind.to_string kind) Style.inline_code name + | Non_generalizable { vars; expression } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + prepare_for_printing vars; + add_type_to_preparation expression; + Location.errorf ~loc + "@[The type of this expression,@ %a,@ \ + contains the non-generalizable type variable(s): %a.@ %a@]" + (Style.as_inline_code prepared_type_scheme) expression + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + (Style.as_inline_code prepared_type_scheme)) vars + Misc.print_see_manual manual_ref + | Non_generalizable_module { vars; mty; item } -> + let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in + prepare_for_printing vars; + add_type_to_preparation item.val_type; + let sub = + [ Location.msg ~loc:item.val_loc + "The type of this value,@ %a,@ \ + contains the non-generalizable type variable(s) %a." + (Style.as_inline_code prepared_type_scheme) + item.val_type + (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") + @@ Style.as_inline_code prepared_type_scheme) vars + ] + in + Location.errorf ~loc ~sub + "@[The type of this module,@ %a,@ \ + contains non-generalizable type variable(s).@ %a@]" + modtype mty + Misc.print_see_manual manual_ref + | 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" + (Style.as_inline_code type_expr) ty + | Incomplete_packed_module ty -> + Location.errorf ~loc + "The type of this packed module contains variables:@ %a" + (Style.as_inline_code 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" + (Style.as_inline_code longident) lid + (Style.as_inline_code 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 %a" + Style.inline_code "()" + | Cannot_scrape_alias p -> + Location.errorf ~loc + "This is an alias for module %a, which is missing" + (Style.as_inline_code path) p + | Cannot_scrape_package_type p -> + Location.errorf ~loc + "The type of this packed module refers to %a, which is missing" + (Style.as_inline_code 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 = + Printtyp.namespaced_ident shadowed_item_kind shadowed_item_id + in + let shadower = + Printtyp.namespaced_ident shadowed_item_kind shadower_id + in + let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in + let shadowed_msg = + Location.msg ~loc:shadowed_item_loc + "@[%s %a came from this include.@]" + (String.capitalize_ascii shadowed_item_kind) + Style.inline_code shadowed + in + let user_msg = + Location.msg ~loc:user_loc + "@[The %s %a has no valid type@ if %a is shadowed.@]" + (Sig_component_kind.to_string user_kind) + Style.inline_code (Ident.name user_id) + Style.inline_code shadowed + in + Location.errorf ~loc ~sub:[shadowed_msg; user_msg] + "Illegal shadowing of included %s %a@ by %a." + shadowed_item_kind + Style.inline_code shadowed + Style.inline_code shadower + | 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 + let opened_id = Ident.name opened_item_id in + let user_msg = + Location.msg ~loc:user_loc + "@[The %s %a has no valid type@ if %a is hidden.@]" + (Sig_component_kind.to_string user_kind) + Style.inline_code (Ident.name user_id) + Style.inline_code opened_id + in + Location.errorf ~loc ~sub:[user_msg] + "The %s %a introduced by this open appears in the signature." + opened_item_kind + Style.inline_code opened_id + | Invalid_type_subst_rhs -> + Location.errorf ~loc "Only type synonyms are allowed on the right of %a" + Style.inline_code ":=" + | Unpackable_local_modtype_subst p -> + let[@manual.ref "ss:module-type-substitution"] manual_ref = + [ 12; 7; 3 ] + in + Location.errorf ~loc + "The module type@ %a@ is not a valid type for a packed module:@ \ + it is defined as a local substitution (temporary name)@ \ + for an anonymous module type.@ %a" + Style.inline_code (Path.name p) + Misc.print_see_manual manual_ref + +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_502/typing/typemod.mli b/upstream/ocaml_502/typing/typemod.mli new file mode 100644 index 0000000000..05f750a020 --- /dev/null +++ b/upstream/ocaml_502/typing/typemod.mli @@ -0,0 +1,143 @@ +(**************************************************************************) +(* *) +(* 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 * Shape.t +val type_structure: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Signature_names.t * Shape.t * + Env.t +val type_toplevel_phrase: + Env.t -> Parsetree.structure -> + Typedtree.structure * Types.signature * Signature_names.t * Shape.t * + Env.t +val type_implementation: + Unit_info.t -> 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_signature: + 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: + Unit_info.t -> Typedtree.signature -> Env.t -> + Cmi_format.cmi_infos -> unit + +val package_units: + Env.t -> string list -> Unit_info.Artifact.t -> Typedtree.module_coercion + +(* Should be in Envaux, but it breaks the build of the debugger *) +val initial_env: + loc:Location.t -> + initially_opened_module:string option -> + open_implicit_modules:string list -> Env.t + +module Sig_component_kind : sig + type t = + | Value + | Type + | Constructor + | Label + | 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 { vars : type_expr list; expression : type_expr } + | Non_generalizable_module of + { vars : type_expr list; item : value_description; mty : 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_502/typing/typeopt.ml b/upstream/ocaml_502/typing/typeopt.ml new file mode 100644 index 0000000000..0b131ee072 --- /dev/null +++ b/upstream/ocaml_502/typing/typeopt.ml @@ -0,0 +1,227 @@ +(**************************************************************************) +(* *) +(* 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 = + match get_desc ty with + | Tconstr _ -> + let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in + begin match get_desc ty with + | Tconstr (p, _, _) -> + begin match Env.find_type p env with + | {type_kind = ( Type_variant (_, Variant_unboxed) + | Type_record (_, Record_unboxed _) ); _} -> begin + match Typedecl_unboxed.get_unboxed_type_representation env ty with + | None -> ty + | Some ty2 -> ty2 + end + | _ -> ty + | exception Not_found -> ty + end + | _ -> + ty + end + | _ -> ty + +let scrape env ty = + get_desc (scrape_ty env ty) + +let scrape_poly env ty = + let ty = scrape_ty env ty in + match get_desc ty with + | Tpoly (ty, _) -> get_desc ty + | d -> d + +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 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 maybe_pointer_type env ty = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Immediate + else Pointer + +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 get_desc ty 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_poly env ty with + | 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, [], _) 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 = + ["float16_elt", Pbigarray_float16; + "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 = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Pintval + else begin + match get_desc ty with + | 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 + end + +(** 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_502/typing/typeopt.mli b/upstream/ocaml_502/typing/typeopt.mli new file mode 100644 index 0000000000..d1fcf41e7b --- /dev/null +++ b/upstream/ocaml_502/typing/typeopt.mli @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* 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 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_502/typing/types.ml b/upstream/ocaml_502/typing/types.ml new file mode 100644 index 0000000000..997e78d492 --- /dev/null +++ b/upstream/ocaml_502/typing/types.ml @@ -0,0 +1,902 @@ +(**************************************************************************) +(* *) +(* 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 transient_expr = + { mutable desc: type_desc; + mutable level: int; + mutable scope: int; + id: int } + +and type_expr = transient_expr + +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_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 = [`some] row_field_gen +and _ row_field_gen = + RFpresent : type_expr option -> [> `some] row_field_gen + | RFeither : + { no_arg: bool; + arg_type: type_expr list; + matched: bool; + ext: [`some | `none] row_field_gen ref} -> [> `some] row_field_gen + | RFabsent : [> `some] row_field_gen + | RFnone : [> `none] row_field_gen + +and abbrev_memo = + Mnil + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo + | Mlink of abbrev_memo ref + +and any = [`some | `none | `var] +and field_kind = [`some|`var] field_kind_gen +and _ field_kind_gen = + FKvar : {mutable field_kind: any field_kind_gen} -> [> `var] field_kind_gen + | FKprivate : [> `none] field_kind_gen (* private method; only under FKvar *) + | FKpublic : [> `some] field_kind_gen (* public method *) + | FKabsent : [> `some] field_kind_gen (* hidden private method *) + +and commutable = [`some|`var] commutable_gen +and _ commutable_gen = + Cok : [> `some] commutable_gen + | Cunknown : [> `none] commutable_gen + | Cvar : {mutable commu: any commutable_gen} -> [> `var] commutable_gen + +module TransientTypeOps = 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 = Shape.Uid + +(* Maps of methods and instance variables *) + +module MethSet = Misc.Stdlib.String.Set +module VarSet = Misc.Stdlib.String.Set + +module Meths = Misc.Stdlib.String.Map +module Vars = Misc.Stdlib.String.Map + + +(* 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 + class_signature * self_meths * Ident.t Vars.t * string + (* Self *) + | Val_anc of class_signature * Ident.t Meths.t * string + (* Ancestor *) + +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + +(* Variance *) +(* Variance forms a product lattice of the following partial orders: + 0 <= may_pos <= pos + 0 <= may_weak <= may_neg <= neg + 0 <= inj + Additionally, the following implications are valid + pos => inj + neg => inj + Examples: + type 'a t : may_pos + may_neg + may_weak + type 'a t = 'a : pos + type 'a t = 'a -> unit : neg + type 'a t = ('a -> unit) -> unit : pos + may_weak + type 'a t = A of (('a -> unit) -> unit) : pos + type +'a p = .. : may_pos + inj + type +!'a t : may_pos + inj + type -!'a t : may_neg + inj + type 'a t = A : inj + *) + +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 + 4 + | May_weak -> 4 + | Inj -> 8 + | Pos -> 16 + 8 + 1 + | Neg -> 32 + 8 + 4 + 2 + | Inv -> 63 + 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 v = union v (single x) + let set_if b x v = if b then set x v else v + let mem x = subset (single x) + let null = 0 + let unknown = 7 + let full = single Inv + let covariant = single Pos + let swap f1 f2 v v' = + set_if (mem f2 v) f1 (set_if (mem f1 v) f2 v') + let conjugate v = + let v' = inter v (union (single Inj) (single May_weak)) in + swap Pos Neg v (swap May_pos May_neg v v') + let compose v1 v2 = + if mem Inv v1 && mem Inj v2 then full else + let mp = + mem May_pos v1 && mem May_pos v2 || mem May_neg v1 && mem May_neg v2 + and mn = + mem May_pos v1 && mem May_neg v2 || mem May_neg v1 && mem May_pos v2 + and mw = mem May_weak v1 && v2 <> null || v1 <> null && mem May_weak v2 + and inj = mem Inj v1 && mem Inj v2 + and pos = mem Pos v1 && mem Pos v2 || mem Neg v1 && mem Neg v2 + and neg = mem Pos v1 && mem Neg v2 || mem Neg v1 && mem Pos v2 in + List.fold_left (fun v (b,f) -> set_if b f v) null + [mp, May_pos; mn, May_neg; mw, May_weak; inj, Inj; pos, Pos; neg, Neg] + let strengthen v = + if mem May_neg v then v else v land (full - single May_weak) + let get_upper v = (mem May_pos v, mem May_neg v) + let get_lower v = (mem Pos v, mem Neg v, mem Inj v) + let unknown_signature ~injective ~arity = + let v = if injective then set Inj 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 of type_origin + | Type_record of 'lbl list * record_representation + | Type_variant of 'cstr list * variant_representation + | Type_open + +and type_origin = + Definition + | Rec_check_regularity + | Existential of string + +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 *) + +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 + +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_hash_type: type_declaration; + 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_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) + +let item_visibility = function + | Sig_value (_, _, vis) + | Sig_type (_, _, _, vis) + | Sig_typext (_, _, _, vis) + | Sig_module (_, _, _, _, vis) + | Sig_modtype (_, _, vis) + | Sig_class (_, _, _, vis) + | Sig_class_type (_, _, _, vis) -> vis + +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 + +(**** 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 [`none|`some] row_field_gen ref + | Ckind of [`var] field_kind_gen + | Ccommu of [`var] commutable_gen + | Cuniv of type_expr option ref * type_expr option + +type changes = + Change of change * changes ref + | Unchanged + | Invalid + +let trail = Local_store.s_table ref Unchanged + +let log_change ch = + let r' = ref Unchanged in + !trail := Change (ch, r'); + trail := r' + +(* constructor and accessors for [field_kind] *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +let rec field_kind_internal_repr : field_kind -> field_kind = function + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as fk} -> + field_kind_internal_repr fk + | kind -> kind + +let field_kind_repr fk = + match field_kind_internal_repr fk with + | FKvar _ -> Fprivate + | FKpublic -> Fpublic + | FKabsent -> Fabsent + +let field_public = FKpublic +let field_absent = FKabsent +let field_private () = FKvar {field_kind=FKprivate} + +(* Constructor and accessors for [commutable] *) + +let rec is_commu_ok : type a. a commutable_gen -> bool = function + | Cvar {commu} -> is_commu_ok commu + | Cunknown -> false + | Cok -> true + +let commu_ok = Cok +let commu_var () = Cvar {commu=Cunknown} + +(**** Representative of a type ****) + +let rec repr_link (t : type_expr) d : type_expr -> type_expr = + function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> + log_change (Ccompress (t, t.desc, d)); + t.desc <- d; + t' + +let repr_link1 t = function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> t' + +let repr t = + match t.desc with + Tlink t' -> + repr_link1 t t' + | Tfield (_, k, _, t') when field_kind_internal_repr k = FKabsent -> + repr_link1 t t' + | _ -> t + +(* getters for type_expr *) + +let get_desc t = (repr t).desc +let get_level t = (repr t).level +let get_scope t = (repr t).scope +let get_id t = (repr t).id + +(* transient type_expr *) + +module Transient_expr = struct + let create desc ~level ~scope ~id = {desc; level; scope; id} + let set_desc ty d = ty.desc <- d + let set_stub_desc ty d = assert (ty.desc = Tvar None); ty.desc <- d + let set_level ty lv = ty.level <- lv + let set_scope ty sc = ty.scope <- sc + let coerce ty = ty + let repr = repr + let type_expr ty = ty +end + +(* Comparison for [type_expr]; cannot be used for functors *) + +let eq_type t1 t2 = t1 == t2 || repr t1 == repr t2 +let compare_type t1 t2 = compare (get_id t1) (get_id t2) + +(* Constructor and accessors for [row_desc] *) + +let create_row ~fields ~more ~closed ~fixed ~name = + { row_fields=fields; row_more=more; + row_closed=closed; row_fixed=fixed; row_name=name } + +(* [row_fields] subsumes the original [row_repr] *) +let rec row_fields row = + match get_desc row.row_more with + | Tvariant row' -> + row.row_fields @ row_fields row' + | _ -> + row.row_fields + +let rec row_repr_no_fields row = + match get_desc row.row_more with + | Tvariant row' -> row_repr_no_fields row' + | _ -> row + +let row_more row = (row_repr_no_fields row).row_more +let row_closed row = (row_repr_no_fields row).row_closed +let row_fixed row = (row_repr_no_fields row).row_fixed +let row_name row = (row_repr_no_fields row).row_name + +let rec get_row_field tag row = + let rec find = function + | (tag',f) :: fields -> + if tag = tag' then f else find fields + | [] -> + match get_desc row.row_more with + | Tvariant row' -> get_row_field tag row' + | _ -> RFabsent + in find row.row_fields + +let set_row_name row row_name = + let row_fields = row_fields row in + let row = row_repr_no_fields row in + {row with row_fields; row_name} + +type row_desc_repr = + Row of { fields: (label * row_field) list; + more:type_expr; + closed:bool; + fixed:fixed_explanation option; + name:(Path.t * type_expr list) option } + +let row_repr row = + let fields = row_fields row in + let row = row_repr_no_fields row in + Row { fields; + more = row.row_more; + closed = row.row_closed; + fixed = row.row_fixed; + name = row.row_name } + +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +let rec row_field_repr_aux tl : row_field -> row_field = function + | RFeither ({ext = {contents = RFnone}} as r) -> + RFeither {r with arg_type = tl@r.arg_type} + | RFeither {arg_type; + ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_repr_aux (tl@arg_type) rf + | RFpresent (Some _) when tl <> [] -> + RFpresent (Some (List.hd tl)) + | RFpresent _ as rf -> rf + | RFabsent -> RFabsent + +let row_field_repr fi = + match row_field_repr_aux [] fi with + | RFeither {no_arg; arg_type; matched} -> Reither (no_arg, arg_type, matched) + | RFpresent t -> Rpresent t + | RFabsent -> Rabsent + +let rec row_field_ext (fi : row_field) = + match fi with + | RFeither {ext = {contents = RFnone} as ext} -> ext + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_ext rf + | _ -> Misc.fatal_error "Types.row_field_ext " + +let rf_present oty = RFpresent oty +let rf_absent = RFabsent +let rf_either ?use_ext_of ~no_arg arg_type ~matched = + let ext = + match use_ext_of with + Some rf -> row_field_ext rf + | None -> ref RFnone + in + RFeither {no_arg; arg_type; matched; ext} + +let rf_either_of = function + | None -> + RFeither {no_arg=true; arg_type=[]; matched=false; ext=ref RFnone} + | Some ty -> + RFeither {no_arg=false; arg_type=[ty]; matched=false; ext=ref RFnone} + +let eq_row_field_ext rf1 rf2 = + row_field_ext rf1 == row_field_ext rf2 + +let changed_row_field_exts l f = + let exts = List.map row_field_ext l in + f (); + List.exists (fun r -> !r <> RFnone) exts + +let match_row_field ~present ~absent ~either (f : row_field) = + match f with + | RFabsent -> absent () + | RFpresent t -> present t + | RFeither {no_arg; arg_type; matched; ext} -> + let e : row_field option = + match !ext with + | RFnone -> None + | RFeither _ | RFpresent _ | RFabsent as e -> Some e + in + either no_arg arg_type matched e + + +(**** Some type creators ****) + +let new_id = Local_store.s_ref (-1) + +let create_expr = Transient_expr.create + +let newty3 ~level ~scope desc = + incr new_id; + create_expr desc ~level ~scope ~id:!new_id + +let newty2 ~level desc = + newty3 ~level ~scope:Ident.lowest_scope desc + + (**********************************) + (* Utilities for backtracking *) + (**********************************) + +let undo_change = function + Ctype (ty, desc) -> Transient_expr.set_desc ty desc + | Ccompress (ty, desc, _) -> Transient_expr.set_desc ty desc + | Clevel (ty, level) -> Transient_expr.set_level ty level + | Cscope (ty, scope) -> Transient_expr.set_scope ty scope + | Cname (r, v) -> r := v + | Crow r -> r := RFnone + | Ckind (FKvar r) -> r.field_kind <- FKprivate + | Ccommu (Cvar r) -> r.commu <- Cunknown + | Cuniv (r, v) -> r := v + +type snapshot = changes ref * int +let last_snapshot = Local_store.s_ref 0 + +let log_type ty = + if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) +let link_type ty ty' = + let ty = repr ty in + let ty' = repr ty' in + if ty == ty' then () else begin + log_type ty; + let desc = ty.desc in + Transient_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'; Transient_expr.set_desc ty' (Tvar name) + | None, Some _ -> () + | Some _, Some _ -> + if ty.level < ty'.level then + (log_type ty'; Transient_expr.set_desc ty' (Tvar name)) + | None, None -> () + end + | _ -> () + 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 = + let ty = repr ty in + if td != ty.desc then begin + log_type ty; + Transient_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 = + let ty = repr ty in + if level <> ty.level then begin + if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); + Transient_expr.set_level ty level + end +(* TODO: introduce a guard and rename it to set_higher_scope? *) +let set_scope ty scope = + let ty = repr ty in + if scope <> ty.scope then begin + if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); + Transient_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 rec link_row_field_ext ~(inside : row_field) (v : row_field) = + match inside with + | RFeither {ext = {contents = RFnone} as e} -> + let RFeither _ | RFpresent _ | RFabsent as v = v in + log_change (Crow e); e := v + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + link_row_field_ext ~inside:rf v + | _ -> invalid_arg "Types.link_row_field_ext" + +let rec link_kind ~(inside : field_kind) (k : field_kind) = + match inside with + | FKvar ({field_kind = FKprivate} as rk) as inside -> + (* prevent a loop by normalizing k and comparing it with inside *) + let FKvar _ | FKpublic | FKabsent as k = field_kind_internal_repr k in + if k != inside then begin + log_change (Ckind inside); + rk.field_kind <- k + end + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as inside} -> + link_kind ~inside k + | _ -> invalid_arg "Types.link_kind" + +let rec commu_repr : commutable -> commutable = function + | Cvar {commu = Cvar _ | Cok as commu} -> commu_repr commu + | c -> c + +let rec link_commu ~(inside : commutable) (c : commutable) = + match inside with + | Cvar ({commu = Cunknown} as rc) as inside -> + (* prevent a loop by normalizing c and comparing it with inside *) + let Cvar _ | Cok as c = commu_repr c in + if c != inside then begin + log_change (Ccommu inside); + rc.commu <- c + end + | Cvar {commu = Cvar _ | Cok as inside} -> + link_commu ~inside c + | _ -> invalid_arg "Types.link_commu" + +let set_commu_ok c = link_commu ~inside:c Cok + +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 ~cleanup_abbrev (changes, old) = + match !changes with + Unchanged -> last_snapshot := old + | Invalid -> failwith "Types.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 undo_first_change_after (changes, _) = + match !changes with + | Change (ch, _) -> + undo_change ch + | _ -> () + +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 -> + Transient_expr.set_desc ty desc; r := !next + | _ -> ()) + log diff --git a/upstream/ocaml_502/typing/types.mli b/upstream/ocaml_502/typing/types.mli new file mode 100644 index 0000000000..7ed7fc971e --- /dev/null +++ b/upstream/ocaml_502/typing/types.mli @@ -0,0 +1,735 @@ +(**************************************************************************) +(* *) +(* 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 +type row_desc +type row_field +type field_kind +type commutable + +type 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", field_public, 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). *) + +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 *) + +(** [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 *) + +(** [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 [commu_ok] arrows, otherwise as + [commu_var ()]. + + 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 must rely on [is_commu_ok] arrows, + otherwise they 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. +*) + +val is_commu_ok: commutable -> bool +val commu_ok: commutable +val commu_var: unit -> commutable + +(** [field_kind] indicates the accessibility of a method. + + An [Fprivate] field may become [Fpublic] or [Fabsent] during unification, + but not the other way round. + + The same [field_kind] is kept shared when copying [Tfield] nodes + so that the copies of the self-type of a class share the same accessibility + (see also PR#10539). + *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +val field_kind_repr: field_kind -> field_kind_view +val field_public: field_kind +val field_absent: field_kind +val field_private: unit -> field_kind +val field_kind_internal_repr: field_kind -> field_kind + (* Removes indirections in [field_kind]. + Only needed for performance. *) + +(** Getters for type_expr; calls repr before answering a value *) + +val get_desc: type_expr -> type_desc +val get_level: type_expr -> int +val get_scope: type_expr -> int +val get_id: type_expr -> int + +(** Transient [type_expr]. + Should only be used immediately after [Transient_expr.repr] *) +type transient_expr = private + { mutable desc: type_desc; + mutable level: int; + mutable scope: int; + id: int } + +module Transient_expr : sig + (** Operations on [transient_expr] *) + + val create: type_desc -> level: int -> scope: int -> id: int -> transient_expr + val set_desc: transient_expr -> type_desc -> unit + val set_level: transient_expr -> int -> unit + val set_scope: transient_expr -> int -> unit + val repr: type_expr -> transient_expr + val type_expr: transient_expr -> type_expr + val coerce: type_expr -> transient_expr + (** Coerce without normalizing with [repr] *) + + val set_stub_desc: type_expr -> type_desc -> unit + (** Instantiate a not yet instantiated stub. + Fail if already instantiated. *) +end + +val create_expr: type_desc -> level: int -> scope: int -> id: int -> type_expr + +(** Functions and definitions moved from Btype *) + +val newty3: level:int -> scope:int -> type_desc -> type_expr + (** Create a type with a fresh id *) + +val newty2: level:int -> type_desc -> type_expr + (** Create a type with a fresh id and no scope *) + +module TransientTypeOps : sig + (** Comparisons for functors *) + + type t = transient_expr + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +(** Comparisons for [type_expr]; cannot be used for functors *) + +val eq_type: type_expr -> type_expr -> bool +val compare_type: type_expr -> type_expr -> int + +(** Constructor and accessors for [row_desc] *) + +(** [ `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 = _; + _ }; + _ }; + _ + } + +*) + +val create_row: + fields:(label * row_field) list -> + more:type_expr -> + closed:bool -> + fixed:fixed_explanation option -> + name:(Path.t * type_expr list) option -> row_desc + +val row_fields: row_desc -> (label * row_field) list +val row_more: row_desc -> type_expr +val row_closed: row_desc -> bool +val row_fixed: row_desc -> fixed_explanation option +val row_name: row_desc -> (Path.t * type_expr list) option + +val set_row_name: row_desc -> (Path.t * type_expr list) option -> row_desc + +val get_row_field: label -> row_desc -> row_field + +(** get all fields at once; different from the old [row_repr] *) +type row_desc_repr = + Row of { fields: (label * row_field) list; + more: type_expr; + closed: bool; + fixed: fixed_explanation option; + name: (Path.t * type_expr list) option } + +val row_repr: row_desc -> row_desc_repr + +(** Current contents of a row field *) +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +val row_field_repr: row_field -> row_field_view +val rf_present: type_expr option -> row_field +val rf_absent: row_field +val rf_either: + ?use_ext_of:row_field -> + no_arg:bool -> type_expr list -> matched:bool -> row_field +val rf_either_of: type_expr option -> row_field + +val eq_row_field_ext: row_field -> row_field -> bool +val changed_row_field_exts: row_field list -> (unit -> unit) -> bool + +val match_row_field: + present:(type_expr option -> 'a) -> + absent:(unit -> 'a) -> + either:(bool -> type_expr list -> bool -> row_field option ->'a) -> + row_field -> 'a + +(* *) + +module Uid = Shape.Uid + +(* Sets and maps of methods and instance variables *) + +module MethSet : Set.S with type elt = string +module VarSet : Set.S with type elt = string + +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 class_signature * self_meths * Ident.t Vars.t * string + (* Self *) + | Val_anc of class_signature * Ident.t Meths.t * string + (* Ancestor *) + +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + (* The [field_kind] is always [Fabsent] in a complete class type. *) + +(* 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 -> t -> t + val set_if : bool -> f -> t -> t + val mem : f -> t -> bool + val conjugate : t -> t (* exchange positive and negative *) + val compose : t -> t -> t + val strengthen : t -> t (* remove May_weak when possible *) + val get_upper : t -> bool * bool (* may_pos, may_neg *) + val get_lower : t -> bool * bool * bool (* pos, neg, 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 of type_origin + | Type_record of 'lbl list * record_representation + | Type_variant of 'cstr list * variant_representation + | Type_open + +and type_origin = + Definition + | Rec_check_regularity (* See Typedecl.transl_type_decl *) + | Existential of string + +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 *) + (* The argument is the path of the 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 *) + +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 + +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_hash_type: type_declaration; (* object type with an open row *) + 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 + +val item_visibility : signature_item -> visibility + +(* 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_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 + +(**** Utilities for backtracking ****) + +type snapshot + (* A snapshot for backtracking *) +val snapshot: unit -> snapshot + (* Make a snapshot for later backtracking. Costs nothing *) +val backtrack: cleanup_abbrev:(unit -> unit) -> 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_first_change_after: snapshot -> unit + (* Backtrack only the first change after a snapshot. + Does not update the list of changes *) +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?). + The old values are logged and reverted on backtracking. + *) + +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 link_row_field_ext: inside:row_field -> row_field -> unit + (* Extract the extension variable of [inside] and set it to the + second argument *) +val set_univar: type_expr option ref -> type_expr -> unit +val link_kind: inside:field_kind -> field_kind -> unit +val link_commu: inside:commutable -> commutable -> unit +val set_commu_ok: commutable -> unit diff --git a/upstream/ocaml_502/typing/typetexp.ml b/upstream/ocaml_502/typing/typetexp.ml new file mode 100644 index 0000000000..24cbf515d4 --- /dev/null +++ b/upstream/ocaml_502/typing/typetexp.ml @@ -0,0 +1,995 @@ +(**************************************************************************) +(* *) +(* 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 * string list + | No_type_wildcards + | Undefined_type_constructor of Path.t + | Type_arity_mismatch of Longident.t * int * int + | Bound_type_variable of string + | Recursive_type + | Type_mismatch of Errortrace.unification_error + | Alias_type_mismatch of Errortrace.unification_error + | 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 + +module TyVarEnv : sig + val reset : unit -> unit + (* see mli file *) + + val is_in_scope : string -> bool + + val add : string -> type_expr -> unit + (* add a global type variable to the environment *) + + val with_local_scope : (unit -> 'a) -> 'a + (* see mli file *) + + type poly_univars + val with_univars : poly_univars -> (unit -> 'a) -> 'a + (* evaluate with a locally extended set of univars *) + + val make_poly_univars : string list -> poly_univars + (* see mli file *) + + val check_poly_univars : Env.t -> Location.t -> poly_univars -> type_expr list + (* see mli file *) + + val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (* see mli file *) + + type policy + val fixed_policy : policy (* no wildcards allowed *) + val extensible_policy : policy (* common case *) + val univars_policy : policy (* fresh variables are univars (in methods) *) + val new_any_var : Location.t -> Env.t -> policy -> type_expr + (* create a new variable to represent a _; fails for fixed_policy *) + val new_var : ?name:string -> policy -> type_expr + (* create a new variable according to the given policy *) + + val add_pre_univar : type_expr -> policy -> unit + (* remember that a variable might become a univar if it isn't unified; + used for checking method types *) + + val collect_univars : (unit -> 'a) -> 'a * type_expr list + (* collect univars during a computation; returns the univars. + The wrapped computation should use [univars_policy]. + postcondition: the returned type_exprs are all Tunivar *) + + val reset_locals : ?univars:poly_univars -> unit -> unit + (* clear out the local type variable env't; call this when starting + a new e.g. type signature. Optionally pass some univars that + are in scope. *) + + val lookup_local : + row_context:type_expr option ref list -> string -> type_expr + (* look up a local type variable; throws Not_found if it isn't in scope *) + + val remember_used : string -> type_expr -> Location.t -> unit + (* remember that a given name is bound to a given type *) + + val globalize_used_variables : policy -> Env.t -> unit -> unit + (* after finishing with a type signature, used variables are unified to the + corresponding global type variables if they exist. Otherwise, in function + of the policy, fresh used variables are either + - added to the global type variable scope if they are not longer + variables under the {!fixed_policy} + - added to the global type variable scope under the {!extensible_policy} + - expected to be collected later by a call to `collect_univar` under the + {!universal_policy} + *) + +end = struct + (** Map indexed by type variable names. *) + module TyVarMap = Misc.Stdlib.String.Map + + let not_generic v = get_level v <> Btype.generic_level + + (* These are the "global" type variables: they were in scope before + we started processing the current type. + *) + let type_variables = ref (TyVarMap.empty : type_expr TyVarMap.t) + + (* These are variables that have been used in the currently-being-checked + type. + *) + let used_variables = + ref (TyVarMap.empty : (type_expr * Location.t) TyVarMap.t) + + (* These are variables we expect to become univars (they were introduced with + e.g. ['a .]), but we need to make sure they don't unify first. Why not + just birth them as univars? Because they might successfully unify with a + row variable in the ['a. < m : ty; .. > as 'a] idiom. They are like the + [used_variables], but will not be globalized in [globalize_used_variables]. + *) + type pending_univar = { + univar: type_expr (** the univar itself *); + mutable associated: type_expr option ref list + (** associated references to row variables that we want to generalize + if possible *) + } + + let univars = ref ([] : (string * pending_univar) list) + let assert_univars uvs = + assert (List.for_all (fun (_name, v) -> not_generic v.univar) uvs) + + (* These are variables that will become univars when we're done with the + current type. Used to force free variables in method types to become + univars. + *) + let pre_univars = ref ([] : type_expr list) + + let reset () = + reset_global_level (); + type_variables := TyVarMap.empty + + let is_in_scope name = + TyVarMap.mem name !type_variables + + let add name v = + assert (not_generic v); + type_variables := TyVarMap.add name v !type_variables + + let narrow () = + (increase_global_level (), !type_variables) + + let widen (gl, tv) = + restore_global_level gl; + type_variables := tv + + let with_local_scope f = + let context = narrow () in + Fun.protect + f + ~finally:(fun () -> widen context) + + (* throws Not_found if the variable is not in scope *) + let lookup_global_type_variable name = + TyVarMap.find name !type_variables + + let get_in_scope_names () = + let add_name name _ l = + if name = "_" then l else Pprintast.tyvar_of_name name :: l + in + TyVarMap.fold add_name !type_variables [] + + (*****) + type poly_univars = (string * pending_univar) list + + let with_univars new_ones f = + assert_univars new_ones; + let old_univars = !univars in + univars := new_ones @ !univars; + Fun.protect + f + ~finally:(fun () -> univars := old_univars) + + let make_poly_univars vars = + let make name = { univar=newvar ~name (); associated = [] } in + List.map (fun name -> name, make name ) vars + + let promote_generics_to_univars promoted vars = + List.fold_left + (fun acc v -> + match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name); + v :: acc + | _ -> acc + ) + promoted vars + + let check_poly_univars env loc vars = + vars |> List.iter (fun (_, p) -> generalize p.univar); + let univars = + vars |> List.map (fun (name, {univar=ty1; _ }) -> + let v = Btype.proxy ty1 in + begin match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name) + | _ -> + raise (Error (loc, env, Cannot_quantify(name, v))) + end; + v) + in + (* Since we are promoting variables to univars in + {!promote_generics_to_univars}, even if a row variable is associated with + multiple univars we will promote it once, when checking the nearest + univar associated to this row variable. + *) + let promote_associated acc (_,v) = + let enclosed_rows = List.filter_map (!) v.associated in + promote_generics_to_univars acc enclosed_rows + in + List.fold_left promote_associated univars vars + + let instance_poly_univars env loc vars = + let vs = check_poly_univars env loc vars in + vs |> List.iter (fun v -> + match get_desc v with + | Tunivar name -> + set_type_desc v (Tvar name) + | _ -> assert false); + vs + + (*****) + let reset_locals ?univars:(uvs=[]) () = + assert_univars uvs; + univars := uvs; + used_variables := TyVarMap.empty + + let associate row_context p = + let add l x = if List.memq x l then l else x :: l in + p.associated <- List.fold_left add row_context p.associated + + (* throws Not_found if the variable is not in scope *) + let lookup_local ~row_context name = + try + let p = List.assoc name !univars in + associate row_context p; + p.univar + with Not_found -> + instance (fst (TyVarMap.find name !used_variables)) + (* This call to instance might be redundant; all variables + inserted into [used_variables] are non-generic, but some + might get generalized. *) + + let remember_used name v loc = + assert (not_generic v); + used_variables := TyVarMap.add name (v, loc) !used_variables + + + type flavor = Unification | Universal + type extensibility = Extensible | Fixed + type policy = { flavor : flavor; extensibility : extensibility } + + let fixed_policy = { flavor = Unification; extensibility = Fixed } + let extensible_policy = { flavor = Unification; extensibility = Extensible } + let univars_policy = { flavor = Universal; extensibility = Extensible } + + let add_pre_univar tv = function + | { flavor = Universal } -> + assert (not_generic tv); + pre_univars := tv :: !pre_univars + | _ -> () + + let collect_univars f = + pre_univars := []; + let result = f () in + let univs = promote_generics_to_univars [] !pre_univars in + result, univs + + let new_var ?name policy = + let tv = Ctype.newvar ?name () in + add_pre_univar tv policy; + tv + + let new_any_var loc env = function + | { extensibility = Fixed } -> raise(Error(loc, env, No_type_wildcards)) + | policy -> new_var policy + + let globalize_used_variables { flavor; extensibility } env = + let r = ref [] in + TyVarMap.iter + (fun name (ty, loc) -> + if flavor = Unification || is_in_scope name then + 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, lookup_global_type_variable name) :: !r + with Not_found -> + if extensibility = Fixed && Btype.is_Tvar ty then + raise(Error(loc, env, + Unbound_type_variable (Pprintast.tyvar_of_name name, + get_in_scope_names ()))); + let v2 = new_global_var () in + r := (loc, v, v2) :: !r; + add name v2) + !used_variables; + used_variables := TyVarMap.empty; + fun () -> + List.iter + (function (loc, t1, t2) -> + try unify env t1 t2 with Unify err -> + raise (Error(loc, env, Type_mismatch err))) + !r +end + +(* Support for first-class modules. *) + +let transl_modtype_longident = ref (fun _ -> assert false) +let transl_modtype = ref (fun _ -> assert false) + +let sort_constraints_no_duplicates loc env 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 + +let create_package_mty loc p l = + List.fold_left + (fun mty (s, _) -> + 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 = None; + 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 generalize_ctyp typ = generalize typ.ctyp_type + +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 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 = + if not (valid_tyvar_name name) then + raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); + if TyVarEnv.is_in_scope name then + raise Already_bound; + let v = new_global_var ~name () in + TyVarEnv.add name v; + 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) + +(* Forward declaration (set in 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 rec transl_type env ~policy ?(aliased=false) ~row_context styp = + Builtin_attributes.warning_scope styp.ptyp_attributes + (fun () -> transl_type_aux env ~policy ~aliased ~row_context styp) + +and transl_type_aux env ~row_context ~aliased ~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 = TyVarEnv.new_any_var styp.ptyp_loc env policy 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 + TyVarEnv.lookup_local ~row_context:row_context name + with Not_found -> + let v = TyVarEnv.new_var ~name policy in + TyVarEnv.remember_used name v styp.ptyp_loc; + v + end + in + ctyp (Ttyp_var name) ty + | Ptyp_arrow(l, st1, st2) -> + let cty1 = transl_type env ~policy ~row_context st1 in + let cty2 = transl_type env ~policy ~row_context 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, commu_ok)) in + ctyp (Ttyp_arrow (l, cty1, cty2)) ty + | Ptyp_tuple stl -> + assert (List.length stl >= 2); + let ctys = List.map (transl_type env ~policy ~row_context) 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 ~row_context) stl in + let params = instance_list decl.type_params in + let unify_param = + match decl.type_manifest with + None -> unify_var + | Some ty -> + if get_level ty = 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 err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) + ) + (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 ~row_context o fields in + ctyp (Ttyp_object (fields, o)) (newobj ty) + | Ptyp_class(lid, stl) -> + let (path, decl) = + let path, decl = Env.lookup_cltype ~loc:lid.loc lid.txt env in + (path, decl.clty_hash_type) + 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 ~row_context) stl in + let body = Option.get decl.type_manifest in + let (params, body) = instance_parameterized_type decl.type_params body in + List.iter2 + (fun (sty, cty) ty' -> + try unify_var env ty' cty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) + ) + (List.combine stl args) params; + let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in + let ty = Ctype.apply ~use_current_level:true env params body ty_args in + let ty = match get_desc ty with + | Tobject (fi, _) -> + let _, tv = flatten_fields fi in + TyVarEnv.add_pre_univar tv policy; + ty + | _ -> + assert false + in + ctyp (Ttyp_class (path, lid, args)) ty + | Ptyp_alias(st, alias) -> + let cty = + try + let t = TyVarEnv.lookup_local ~row_context alias.txt in + let ty = transl_type env ~policy ~aliased:true ~row_context st in + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(alias.loc, env, Alias_type_mismatch err)) + end; + ty + with Not_found -> + let t, ty = + with_local_level_if_principal begin fun () -> + let t = newvar () in + (* Use the whole location, which is used by [Type_mismatch]. *) + TyVarEnv.remember_used alias.txt t styp.ptyp_loc; + let ty = transl_type env ~policy ~row_context st in + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(alias.loc, env, Alias_type_mismatch err)) + end; + (t, ty) + end + ~post: (fun (t, _) -> generalize_structure t) + in + let t = instance t in + let px = Btype.proxy t in + begin match get_desc px with + | Tvar None -> set_type_desc px (Tvar (Some alias.txt)) + | Tunivar None -> set_type_desc px (Tunivar (Some alias.txt)) + | _ -> () + 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 (create_row ~fields:[l,f] ~more:(newvar()) + ~closed:true ~fixed:None ~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 row_context 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 ~row_context) 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 + rf_either ty_tl ~no_arg:c ~matched:false + | _ -> + if List.length stl > 1 || c && stl <> [] then + raise(Error(styp.ptyp_loc, env, + Present_has_conjunction l.txt)); + match tl with [] -> rf_present None + | st :: _ -> rf_present (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 ~row_context sty in + let ty = cty.ctyp_type in + let nm = + match get_desc cty.ctyp_type with + Tconstr(p, tl, _) -> Some(p, tl) + | _ -> None + in + name := if Hashtbl.length hfields <> 0 then None else nm; + let fl = match get_desc (expand_head env cty.ctyp_type), nm with + Tvariant row, _ when Btype.static_row row -> + row_fields row + | 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 row_field_repr f with + Rpresent oty -> rf_either_of oty + | _ -> 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 more_slot = ref None in + let row_context = + if aliased then row_context else more_slot :: row_context + in + let tfields = List.map (add_field row_context) fields in + let fields = List.rev (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 name = !name in + let make_row more = + create_row ~fields ~more ~closed:(closed = Closed) ~fixed:None ~name + in + let more = + if Btype.static_row (make_row (newvar ())) then newty Tnil else + TyVarEnv.new_var policy + in + more_slot := Some more; + let ty = newty (Tvariant (make_row more)) in + ctyp (Ttyp_variant (tfields, closed, present)) ty + | Ptyp_poly(vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + let new_univars, cty = + with_local_level begin fun () -> + let new_univars = TyVarEnv.make_poly_univars vars in + let cty = TyVarEnv.with_univars new_univars begin fun () -> + transl_type env ~policy ~row_context st + end in + (new_univars, cty) + end + ~post:(fun (_,cty) -> generalize_ctyp cty) + in + let ty = cty.ctyp_type in + let ty_list = TyVarEnv.check_poly_univars env styp.ptyp_loc new_univars in + let ty_list = List.filter (fun v -> deep_occur v ty) ty_list in + let ty' = Btype.newgenty (Tpoly(ty, ty_list)) in + unify_var env (newvar()) ty'; + ctyp (Ttyp_poly (vars, cty)) ty' + | Ptyp_package (p, l) -> + let loc = styp.ptyp_loc in + let l = sort_constraints_no_duplicates loc env l in + let mty = create_package_mty loc p l in + let mty = + TyVarEnv.with_local_scope (fun () -> !transl_modtype env mty) in + let ptys = List.map (fun (s, pty) -> + s, transl_type env ~policy ~row_context pty + ) l in + let path = !transl_modtype_longident 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_open (mod_ident, t) -> + let path, new_env = + !type_open Asttypes.Fresh env loc mod_ident + in + let cty = transl_type new_env ~policy ~row_context t in + ctyp (Ttyp_open (path, mod_ident, cty)) cty.ctyp_type + | Ptyp_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and transl_fields env ~policy ~row_context 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_type env ~policy ~row_context + (Ast_helper.Typ.force_poly 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 ~row_context sty in + let nm = + match get_desc cty.ctyp_type with + Tconstr(p, _, _) -> Some p + | _ -> None in + let t = expand_head env cty.ctyp_type in + match get_desc t, nm with + Tobject (tf, _), _ + when (match get_desc tf with Tfield _ | Tnil -> true | _ -> false) -> + begin + if opened_object t then + raise (Error (sty.ptyp_loc, env, Opened_object nm)); + let rec iter_add ty = + match get_desc ty with + | Tfield (s, _k, ty1, ty2) -> + add_typed_field sty.ptyp_loc s ty1; + iter_add ty2 + | Tnil -> () + | _ -> assert false + in + iter_add tf; + OTinherit cty + end + | 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 with + | Closed -> newty Tnil + | Open -> TyVarEnv.new_var policy + in + let ty = List.fold_left (fun ty (s, ty') -> + newty (Tfield (s, field_public, 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 = + if Btype.try_mark_node ty then + begin match get_desc ty with + | Tvariant row -> + let Row {fields; more; name; closed} = row_repr row in + if Btype.is_Tunivar more then + let fields = + List.map + (fun (s,f as p) -> match row_field_repr f with + Reither (no_arg, tl, _m) -> + s, rf_either tl ~use_ext_of:f ~no_arg ~matched:true + | _ -> p) + fields + in + set_type_desc ty + (Tvariant + (create_row ~fields ~more ~name ~closed + ~fixed:(Some (Univar more)))); + Btype.iter_row make_fixed_univars row + | _ -> + Btype.iter_type_expr make_fixed_univars ty + end + +let transl_type env policy styp = + transl_type env ~policy ~row_context:[] styp + +let make_fixed_univars ty = + make_fixed_univars ty; + Btype.unmark_type ty + +let transl_simple_type env ?univars ~closed styp = + TyVarEnv.reset_locals ?univars (); + let policy = TyVarEnv.(if closed then fixed_policy else extensible_policy) in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); + make_fixed_univars typ.ctyp_type; + typ + +let transl_simple_type_univars env styp = + TyVarEnv.reset_locals (); + let typ, univs = + TyVarEnv.collect_univars begin fun () -> + with_local_level ~post:generalize_ctyp begin fun () -> + let policy = TyVarEnv.univars_policy in + let typ = transl_type env policy styp in + TyVarEnv.globalize_used_variables policy env (); + typ + end + end 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 = + TyVarEnv.reset_locals (); + let typ, force = + with_local_level begin fun () -> + let policy = TyVarEnv.extensible_policy in + let typ = transl_type env policy styp in + 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 = TyVarEnv.globalize_used_variables policy env in + (typ, force) + end + (* Generalize everything except the variables that were just globalized. *) + ~post:(fun (typ,_) -> generalize_ctyp typ) + in + (typ, instance typ.ctyp_type, force) + +let transl_type_scheme env styp = + match styp.ptyp_desc with + | Ptyp_poly (vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + let univars, typ = + with_local_level begin fun () -> + TyVarEnv.reset (); + let univars = TyVarEnv.make_poly_univars vars in + let typ = transl_simple_type env ~univars ~closed:true st in + (univars, typ) + end + ~post:(fun (_,typ) -> generalize_ctyp typ) + in + let _ = TyVarEnv.instance_poly_univars env styp.ptyp_loc univars in + { ctyp_desc = Ttyp_poly (vars, typ); + ctyp_type = typ.ctyp_type; + ctyp_env = env; + ctyp_loc = styp.ptyp_loc; + ctyp_attributes = styp.ptyp_attributes } + | _ -> + with_local_level + (fun () -> TyVarEnv.reset (); transl_simple_type env ~closed:false styp) + ~post:generalize_ctyp + + +(* Error report *) + +open Format +open Printtyp +module Style = Misc.Style +let pp_tag ppf t = Format.fprintf ppf "`%s" t + + +let report_error env ppf = function + | Unbound_type_variable (name, in_scope_names) -> + fprintf ppf "The type variable %a is unbound in this type declaration.@ %a" + Style.inline_code name + did_you_mean (fun () -> Misc.spellcheck in_scope_names name ) + | No_type_wildcards -> + fprintf ppf "A type wildcard %a is not allowed in this type declaration." + Style.inline_code "_" + | Undefined_type_constructor p -> + fprintf ppf "The type constructor@ %a@ is not yet completely defined" + (Style.as_inline_code 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)@]" + (Style.as_inline_code longident) lid expected provided + | Bound_type_variable name -> + fprintf ppf "Already bound type parameter %a" + (Style.as_inline_code Pprintast.tyvar) name + | Recursive_type -> + fprintf ppf "This type is recursive" + | 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 %a has a conjunctive type" + Style.inline_code l + | Present_has_no_type l -> + fprintf ppf + "@[@[The constructor %a is missing from the upper bound@ \ + (between %a@ and %a)@ of this polymorphic variant@ \ + but is present in@ its lower bound (after %a).@]@,\ + @[@{Hint@}: Either add %a in the upper bound,@ \ + or remove it@ from the lower bound.@]@]" + (Style.as_inline_code pp_tag) l + Style.inline_code "<" + Style.inline_code ">" + Style.inline_code ">" + (Style.as_inline_code pp_tag) l + | Constructor_mismatch (ty, ty') -> + let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in + wrap_printing_env ~error:true env (fun () -> + Printtyp.prepare_for_printing [ty; ty']; + fprintf ppf "@[%s %a@ %s@ %a@]" + "This variant type contains a constructor" + pp_type (tree_of_typexp Type ty) + "which should be" + pp_type (tree_of_typexp Type ty')) + | Not_a_variant ty -> + fprintf ppf + "@[The type %a@ does not expand to a polymorphic variant type@]" + (Style.as_inline_code Printtyp.type_expr) ty; + begin match get_desc ty 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 %a@ and %a have the same hash value.@ %s@]" + (Style.as_inline_code pp_tag) lab1 + (Style.as_inline_code pp_tag) lab2 + "Change one of them." + | Invalid_variable_name name -> + fprintf ppf "The type variable name %a is not allowed in programs" + Style.inline_code name + | Cannot_quantify (name, v) -> + fprintf ppf + "@[The universal type variable %a cannot be generalized:@ " + (Style.as_inline_code 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" + (Style.as_inline_code Printtyp.type_expr) v; + fprintf ppf ".@]"; + | Multiple_constraints_on_type s -> + fprintf ppf "Multiple constraints for type %a" + (Style.as_inline_code longident) s + | Method_mismatch (l, ty, ty') -> + wrap_printing_env ~error:true env (fun () -> + fprintf ppf "@[Method %a has type %a,@ which should be %a@]" + Style.inline_code l + (Style.as_inline_code Printtyp.type_expr) ty + (Style.as_inline_code Printtyp.type_expr) ty') + | Opened_object nm -> + fprintf ppf + "Illegal open object type%a" + (fun ppf -> function + Some p -> fprintf ppf "@ %a" (Style.as_inline_code path) p + | None -> fprintf ppf "") nm + | Not_an_object ty -> + fprintf ppf "@[The type %a@ is not an object type@]" + (Style.as_inline_code 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_502/typing/typetexp.mli b/upstream/ocaml_502/typing/typetexp.mli new file mode 100644 index 0000000000..56ed31c5fb --- /dev/null +++ b/upstream/ocaml_502/typing/typetexp.mli @@ -0,0 +1,104 @@ +(**************************************************************************) +(* *) +(* 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 + +module TyVarEnv : sig + (* this is just the subset of [TyVarEnv] that is needed outside + of [Typetexp]. See the ml file for more. *) + + val reset : unit -> unit + (** removes all type variables from scope *) + + val with_local_scope : (unit -> 'a) -> 'a + (** Evaluate in a narrowed type-variable scope *) + + type poly_univars + val make_poly_univars : string list -> poly_univars + (** remember that a list of strings connotes univars; this must + always be paired with a [check_poly_univars]. *) + + val check_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (** Verify that the given univars are universally quantified, + and return the list of variables. The type in which the + univars are used must be generalised *) + + val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (** Same as [check_poly_univars], but instantiates the resulting + type scheme (i.e. variables become Tvar rather than Tunivar) *) + +end + +(* Forward declaration, to be filled in by Typemod.type_open *) +val type_open: + (?used_slot:bool ref -> Asttypes.override_flag -> Env.t -> Location.t -> + Longident.t Asttypes.loc -> Path.t * Env.t) + ref + +val valid_tyvar_name : string -> bool + +val transl_simple_type: + Env.t -> ?univars:TyVarEnv.poly_univars -> closed: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 transl_type_param: + Env.t -> Parsetree.core_type -> Typedtree.core_type + +exception Already_bound + +type error = + | Unbound_type_variable of string * string list + | No_type_wildcards + | Undefined_type_constructor of Path.t + | Type_arity_mismatch of Longident.t * int * int + | Bound_type_variable of string + | Recursive_type + | Type_mismatch of Errortrace.unification_error + | Alias_type_mismatch of Errortrace.unification_error + | 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 diff --git a/upstream/ocaml_502/typing/untypeast.ml b/upstream/ocaml_502/typing/untypeast.ml new file mode 100644 index 0000000000..50fbbf8bd9 --- /dev/null +++ b/upstream/ocaml_502/typing/untypeast.ml @@ -0,0 +1,943 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + +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_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.Papply (p1, p2) -> + Longident.Lapply (lident_of_path p1, lident_of_path p2) + | Path.Pdot (p, s) | Path.Pextra_ty (p, Pcstr_ty s) -> + Longident.Ldot (lident_of_path p, s) + | Path.Pextra_ty (p, _) -> lident_of_path p + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +(** 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 + ~vars:cd.cd_vars + ~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 (vs, args, ret) -> + Pext_decl (vs, 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) + | Texp_function (params, body) -> + let body, constraint_ = + match body with + | Tfunction_body body -> + (* Unlike function cases, the [exp_extra] is placed on the body + itself. *) + Pfunction_body (sub.expr sub body), None + | Tfunction_cases { cases; loc; exp_extra; attributes; _ } -> + let cases = List.map (sub.case sub) cases in + let constraint_ = + match exp_extra with + | Some (Texp_coerce (ty1, ty2)) -> + Some + (Pcoerce (Option.map (sub.typ sub) ty1, sub.typ sub ty2)) + | Some (Texp_constraint ty) -> + Some (Pconstraint (sub.typ sub ty)) + | Some (Texp_poly _ | Texp_newtype _) | None -> None + in + Pfunction_cases (cases, loc, attributes), constraint_ + in + let params = + List.concat_map + (fun fp -> + let pat, default_arg = + match fp.fp_kind with + | Tparam_pat pat -> pat, None + | Tparam_optional_default (pat, expr) -> pat, Some expr + in + let pat = sub.pat sub pat in + let default_arg = Option.map (sub.expr sub) default_arg in + let newtypes = + List.map + (fun x -> + { pparam_desc = Pparam_newtype x; + pparam_loc = x.loc; + }) + fp.fp_newtypes + in + let pparam_desc = + Pparam_val (fp.fp_arg_label, default_arg, pat) + in + { pparam_desc; pparam_loc = fp.fp_loc } :: newtypes) + params + in + Pexp_function (params, constraint_, body) + | 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 + | Tmeth_ancestor(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_apply_unit mexp1 -> + Pmod_apply_unit (sub.module_expr sub mexp1) + | 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) + | Ttyp_open (_path, mod_ident, t) -> Ptyp_open (mod_ident, sub.typ sub t) + 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 + +(* [Typeclass] adds a [self] parameter to initializers and methods that isn't + present in the source program. +*) +let remove_fun_self exp = + match exp with + | { exp_desc = + Texp_function + ({fp_arg_label = Nolabel; fp_kind = Tparam_pat pat} :: params, body) + } + when is_self_pat pat -> + (match params, body with + | [], Tfunction_body body -> body + | _, _ -> { exp with exp_desc = Texp_function (params, body) }) + | e -> e + +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 exp = remove_fun_self exp in + Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp)) + | Tcf_initializer exp -> + 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_502/typing/untypeast.mli b/upstream/ocaml_502/typing/untypeast.mli new file mode 100644 index 0000000000..809df9ad08 --- /dev/null +++ b/upstream/ocaml_502/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_502/typing/value_rec_check.ml b/upstream/ocaml_502/typing/value_rec_check.ml new file mode 100644 index 0000000000..e80e43a8ff --- /dev/null +++ b/upstream/ocaml_502/typing/value_rec_check.ml @@ -0,0 +1,1426 @@ +(**************************************************************************) +(* *) +(* 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, as described in + + A practical mode system for recursive definitions + Alban Reynaud, Gabriel Scherer and Jeremy Yallop + POPL 2021 + +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 + +(** {1 Static or dynamic size} *) + +type sd = Value_rec_types.recursive_binding_kind + +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 : sd = + let is_constant expr = + match classify_expression env expr with + | Constant -> true + | _ -> false + in + 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 (_, _, exprs) -> + if List.for_all is_constant exprs then Constant else Static + + | Texp_variant (_, Some expr) -> + if is_constant expr then Constant else Static + | Texp_variant (_, None) -> + Constant + + | Texp_record { representation = Record_unboxed _; + fields = [| _, Overridden (_,e) |] } -> + classify_expression env e + | Texp_record { fields; _ } -> + (* We ignore the [extended_expression] field. + As long as all fields are Overridden rather than Kept, the value + can be constant. *) + let is_constant_field (_label, def) = + match def with + | Kept _ -> false + | Overridden (_loc, expr) -> is_constant expr + in + if Array.for_all is_constant_field fields then Constant else Static + | Texp_tuple exprs -> + if List.for_all is_constant exprs then Constant else 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 _ -> + Not_recursive + + | Texp_array _ -> + Static + | Texp_pack mexp -> + classify_module_expression env mexp + | Texp_function _ -> + Static + | Texp_lazy e -> + (* The code below was copied (in part) from translcore.ml *) + begin match Typeopt.classify_lazy_argument e with + | `Constant_or_function -> + (* A constant expr (of type <> float if [Config.flat_float_array] is + true) gets compiled as itself. *) + classify_expression env e + | `Float_that_cannot_be_shortcut + | `Identifier `Forward_value -> + (* Forward blocks *) + Static + | `Identifier `Other -> + classify_expression env e + | `Other -> + (* other cases compile to a lazy block holding a function *) + Static + end + | Texp_extension_constructor _ -> + Static + + | Texp_constant _ -> + Constant + + | Texp_for _ + | Texp_setfield _ + | Texp_while _ + | Texp_setinstvar _ -> + (* Unit-returning expressions *) + Constant + + | Texp_unreachable -> + Constant + + | Texp_new _ + | Texp_instvar _ + | Texp_object _ + | Texp_match _ + | Texp_ifthenelse _ + | Texp_send _ + | Texp_field _ + | Texp_assert _ + | Texp_try _ + | Texp_override _ + | Texp_letop _ -> + Not_recursive + 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, _uid) -> + 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 : _ -> Value_rec_types.recursive_binding_kind = 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 Not_recursive. + + This could be fixed by a more complete implementation. + *) + Not_recursive + end + | Path.Pdot _ | Path.Papply _ | Path.Pextra_ty _ -> + (* local modules could have such paths to local definitions; + classify_expression could be extend to compute module + shapes more precisely *) + Not_recursive + and classify_module_expression env mexp : sd = + match mexp.mod_desc with + | Tmod_ident _ -> + Not_recursive + | Tmod_structure _ -> + Static + | Tmod_functor _ -> + Static + | Tmod_apply _ -> + Not_recursive + | Tmod_apply_unit _ -> + Not_recursive + | Tmod_constraint (mexp, _, _, coe) -> + begin match coe with + | Tcoerce_none -> classify_module_expression env mexp + | Tcoerce_structure _ -> + Static + | Tcoerce_functor _ -> Static + | Tcoerce_primitive _ -> + Misc.fatal_error "letrec: primitive coercion on a module" + | Tcoerce_alias _ -> + Misc.fatal_error "letrec: alias coercion on a module" + end + | Tmod_unpack (e, _) -> + classify_expression env e + 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 |- : m -| G' + G' |- body : m + ------------------------------- + G |- let 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) -> + (* [args] may contain omitted arguments, corresponding to labels in + the function's type that were not passed in the actual application. + The arguments before the first omitted argument are passed to the + function immediately, so they are dereferenced. The arguments after + the first omitted one are stored in a closure, so guarded. + The function itself is called immediately (dereferenced) if there + is at least one argument before the first omitted one. + On the other hand, if the first argument is omitted then the + function is stored in the closure without being called. *) + let rec split_args ~has_omitted_arg = function + | [] -> [], [] + | (_, None) :: rest -> split_args ~has_omitted_arg:true rest + | (_, Some arg) :: rest -> + let applied, delayed = split_args ~has_omitted_arg rest in + if has_omitted_arg + then applied, arg :: delayed + else arg :: applied, delayed + in + let applied, delayed = split_args ~has_omitted_arg:false args in + let function_mode = + match applied with + | [] -> Guard + | _ :: _ -> Dereference + in + join [expression e << function_mode; + list expression applied << Dereference; + list expression delayed << Guard] + | 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, _) -> + (* + G |- e: m[Dereference] + ---------------------- (plus weird 'eo' option) + G |- e#x: m + *) + join [ + expression e1 << 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 (params, body) -> + (* + G |-{body} b : m[Delay] + (Hj |-{def} Pj : m[Delay])^j + H := sum(Hj)^j + ps := sum(pat(Pj))^j + ----------------------------------- + G + H - ps |- fun (Pj)^j -> b : m + *) + let param_pat param = + (* param P ::= + | ?(pat = expr) + | pat + + Define pat(P) as + pat if P = ?(pat = expr) + pat if P = pat + *) + match param.fp_kind with + | Tparam_pat pat -> pat + | Tparam_optional_default (pat, _) -> pat + in + (* Optional argument defaults. + + G |-{def} P : m + *) + let param_default param = + match param.fp_kind with + | Tparam_optional_default (_, default) -> + (* + G |- e : m + ------------------ + G |-{def} ?(p=e) : m + *) + expression default + | Tparam_pat _ -> + (* + ------------------ + . |-{def} p : m + *) + empty + in + let patterns = List.map param_pat params in + let defaults = List.map param_default params in + let body = function_body body in + let f = join (body :: defaults) << Delay in + (fun m -> + let env = f m in + remove_patlist patterns env) + | 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 + +(* Function bodies. + + G |-{body} b : m +*) +and function_body body = + match body with + | Tfunction_body body -> + (* + G |- e : m + ------------------ + G |-{body} e : m (**) + + (**) The "e" here stands for [Tfunction_body] as opposed to + [Tfunction_cases]. + *) + expression body + | Tfunction_cases { cases; _ } -> + (* + (Gi; _ |- pi -> ei : m)^i (**) + ------------------ + sum(Gi)^i |-{body} function (pi -> ei)^i : m + + (**) Contrarily to match, the values that are pattern-matched + are bound locally, so the pattern modes do not influence + the final environment. + *) + List.map (fun c mode -> fst (case c mode)) cases + |> join + +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_apply_unit f -> + modexp f << 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; + ] + | Path.Pextra_ty (p, _extra) -> + path p + +(* 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 |- : 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 : sd option = + match expr.exp_desc with + | Texp_function _ -> + (* Fast path: functions can never have invalid recursive references *) + Some Static + | _ -> + let rkind = classify_expression expr in + let is_valid = + match rkind with + | Static | Constant -> + (* The expression has known size or is constant *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] + | Not_recursive -> + (* The expression has unknown size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] + | Class -> + assert false (* Not generated by [classify_expression] *) + in + if is_valid then Some rkind else None + +(* 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_502/typing/value_rec_check.mli b/upstream/ocaml_502/typing/value_rec_check.mli new file mode 100644 index 0000000000..8010e7c92c --- /dev/null +++ b/upstream/ocaml_502/typing/value_rec_check.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +val is_valid_recursive_expression : + Ident.t list -> + Typedtree.expression -> + Value_rec_types.recursive_binding_kind option + +val is_valid_class_expr : Ident.t list -> Typedtree.class_expr -> bool diff --git a/upstream/ocaml_502/typing/value_rec_types.mli b/upstream/ocaml_502/typing/value_rec_types.mli new file mode 100644 index 0000000000..93be6ee9ba --- /dev/null +++ b/upstream/ocaml_502/typing/value_rec_types.mli @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Vincent Laviron, OCamlPro *) +(* *) +(* Copyright 2023 OCamlPro, SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Types related to the compilation of value let-recs (non-functional + recursive definitions) *) + +(** The kind of recursive bindings, as computed by + [Rec_check.classify_expression] *) +type recursive_binding_kind = +| Static + (** The expression evaluates to a function or block of a + statically known size. + It will be pre-allocated and back-patched later. + The expression can refer to recursive variables as long as it + does not inspect them during its evaluation. *) +| Constant + (** The expression evaluates to a value that does not contain any + occurrence of a recursive variable. + Combined with the invariant that recursive variables must never be + examined during the definitions, this special case allow using the + same rules as Static bindings (i.e. allow guarded occurrences of + recursive variables in the expression) for values that cannot be + back-patched (unit, integers, empty arrays, ...). *) +| Not_recursive + (** Non recursive bindings. Arbitrary expressions, that are not allowed to + refer to any recursive variable. *) +| Class + (** Bindings generated by the compilation of objects and classes. + These bindings are generated in Lambda form directly and never go through + [Rec_check], so to avoid re-implementing the classification pass on Lambda + we simply identify this special case with a dedicated constructor. *) diff --git a/upstream/ocaml_502/utils/arg_helper.ml b/upstream/ocaml_502/utils/arg_helper.ml new file mode 100644 index 0000000000..fa80007ad4 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/arg_helper.mli b/upstream/ocaml_502/utils/arg_helper.mli new file mode 100644 index 0000000000..18f60fea5c --- /dev/null +++ b/upstream/ocaml_502/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 + | =[,...] + + (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_502/utils/binutils.ml b/upstream/ocaml_502/utils/binutils.ml new file mode 100644 index 0000000000..916d14d026 --- /dev/null +++ b/upstream/ocaml_502/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/ocaml/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_502/utils/binutils.mli b/upstream/ocaml_502/utils/binutils.mli new file mode 100644 index 0000000000..44e17fec38 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/build_path_prefix_map.ml b/upstream/ocaml_502/utils/build_path_prefix_map.ml new file mode 100644 index 0000000000..17cfac82e2 --- /dev/null +++ b/upstream/ocaml_502/utils/build_path_prefix_map.ml @@ -0,0 +1,118 @@ +(**************************************************************************) +(* *) +(* 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.ksprintf (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 make_target path : pair option -> path option = function + | None -> None + | Some { target; source } -> + let is_prefix = + String.length source <= String.length path + && String.equal source (String.sub path 0 (String.length source)) in + if is_prefix then + Some (target ^ (String.sub path (String.length source) + (String.length path - String.length source))) + else None + +let rewrite_first prefix_map path = + List.find_map (make_target path) (List.rev prefix_map) + +let rewrite_all prefix_map path = + List.filter_map (make_target path) (List.rev prefix_map) + +let rewrite prefix_map path = + match rewrite_first prefix_map path with + | None -> path + | Some path -> path diff --git a/upstream/ocaml_502/utils/build_path_prefix_map.mli b/upstream/ocaml_502/utils/build_path_prefix_map.mli new file mode 100644 index 0000000000..d8ec9caf4d --- /dev/null +++ b/upstream/ocaml_502/utils/build_path_prefix_map.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* 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}. + + See + {{: https://reproducible-builds.org/specs/build-path-prefix-map/ } + the BUILD_PATH_PREFIX_MAP spec} +*) + + +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_first : map -> path -> path option +(** [rewrite_first 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_all : map -> path -> path list +(** [rewrite_all map path] finds all sources in [map] + that are a prefix of the input [path]. For each matching + source, in priority order, it replaces this prefix with + the corresponding target and adds the result to + the returned list. + If there are no matches, it just returns [[]]. *) + +val rewrite : map -> path -> path +(** [rewrite path] uses [rewrite_first] to try to find a + mapping for path. If found, it returns that, otherwise + it just returns [path]. *) diff --git a/upstream/ocaml_502/utils/ccomp.ml b/upstream/ocaml_502/utils/ccomp.ml new file mode 100644 index 0000000000..afde5a6567 --- /dev/null +++ b/upstream/ocaml_502/utils/ccomp.ml @@ -0,0 +1,216 @@ +(**************************************************************************) +(* *) +(* 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_response_file 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 ~response_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 response_files && + (String.length s >= 65536 + || (String.length s >= 4096 && Sys.os_type = "Win32")) + then build_response_file quoted + else s + +let quote_prefixed ~response_files pr lst = + let lst = List.filter (fun f -> f <> "") lst in + let lst = List.map (fun f -> pr ^ f) lst in + quote_files ~response_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 ~response_files:true "-I" + (List.map (Misc.expand_directory Config.standard_library) + (List.rev ( !Clflags.hidden_include_dirs + @ !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 ~response_files:true file_list)) + | _ -> + assert(String.length Config.ar > 0); + command(Printf.sprintf "%s rc %s %s" + Config.ar quoted_archive + (quote_files ~response_files:Config.ar_supports_response_files + file_list)) + +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 ~response_files:true + l_prefix (Load_path.get_path_list ())) + (quote_files ~response_files:true (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 ~response_files:true "-L" + (Load_path.get_path_list ())) + (String.concat " " (List.rev !Clflags.all_ccopts)) + (quote_files ~response_files:true 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_502/utils/ccomp.mli b/upstream/ocaml_502/utils/ccomp.mli new file mode 100644 index 0000000000..84f5041871 --- /dev/null +++ b/upstream/ocaml_502/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: response_files:bool -> 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_502/utils/clflags.ml b/upstream/ocaml_502/utils/clflags.ml new file mode 100644 index 0000000000..ed6b6ce800 --- /dev/null +++ b/upstream/ocaml_502/utils/clflags.ml @@ -0,0 +1,582 @@ +(**************************************************************************) +(* *) +(* 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 cmi_file = ref None + +let compile_only = ref false (* -c *) +and output_name = ref (None : string option) (* -o *) +and include_dirs = ref ([] : string list) (* -I *) +and hidden_include_dirs = ref ([] : string list) (* -H *) +and no_std_include = ref false (* -nostdlib *) +and no_cwd = ref false (* -nocwd *) +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 safer_matching = ref false (* -safer-matching *) +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 (* -bin-annot *) +let store_occurrences = ref false (* -bin-annot-occurrences *) +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 true (* -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_shape = ref false (* -dshape *) +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 "" + +let with_runtime = ref true (* -with-runtime *) + +let keep_docs = ref false (* -keep-docs *) +let keep_locs = ref true (* -keep-locs *) + +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 *) +let dump_dir: string option ref = ref None (* -dump-dir *) + +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 | Lambda | Scheduling | Emit + + let to_string = function + | Parsing -> "parsing" + | Typing -> "typing" + | Lambda -> "lambda" + | Scheduling -> "scheduling" + | Emit -> "emit" + + let of_string = function + | "parsing" -> Some Parsing + | "typing" -> Some Typing + | "lambda" -> Some Lambda + | "scheduling" -> Some Scheduling + | "emit" -> Some Emit + | _ -> None + + let rank = function + | Parsing -> 0 + | Typing -> 1 + | Lambda -> 2 + | Scheduling -> 50 + | Emit -> 60 + + let passes = [ + Parsing; + Typing; + Lambda; + 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 \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_502/utils/clflags.mli b/upstream/ocaml_502/utils/clflags.mli new file mode 100644 index 0000000000..0dba055eba --- /dev/null +++ b/upstream/ocaml_502/utils/clflags.mli @@ -0,0 +1,276 @@ +(**************************************************************************) +(* *) +(* 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 cmi_file : string option ref +val compile_only : bool ref +val output_name : string option ref +val include_dirs : string list ref +val hidden_include_dirs : string list ref +val no_std_include : bool ref +val no_cwd : 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 safer_matching : bool 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 store_occurrences : 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_shape : 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 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 +val dump_dir : string option 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 | Lambda | 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_502/utils/config.fixed.ml b/upstream/ocaml_502/utils/config.fixed.ml new file mode 100644 index 0000000000..9374f4464a --- /dev/null +++ b/upstream/ocaml_502/utils/config.fixed.ml @@ -0,0 +1,73 @@ +#2 "utils/config.fixed.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* David Allsopp, Tarides UK. *) +(* *) +(* Copyright 2022 David Allsopp Ltd. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Configuration for the boot compiler. The compiler should refuse to bootstrap + if configured with values which would contradict the configuration below. + The values below are picked to trigger errors if accidentally used in the + compiler (e.g. for the C compiler). *) + +let boot_cannot_call s = "/ The boot compiler should not call " ^ s + +let bindir = "/tmp" +let standard_library_default = "/tmp" +let ccomp_type = "n/a" +let c_compiler = boot_cannot_call "the C compiler" +let c_output_obj = "" +let c_has_debug_prefix_map = false +let as_has_debug_prefix_map = false +let ocamlc_cflags = "" +let ocamlc_cppflags = "" +let ocamlopt_cflags = "" +let ocamlopt_cppflags = "" +let bytecomp_c_libraries = "" +let bytecomp_c_compiler = "" +let native_c_compiler = c_compiler +let native_c_libraries = "" +let native_ldflags = "" +let native_pack_linker = boot_cannot_call "the linker" +let default_rpath = "" +let mksharedlibrpath = "" +let ar = boot_cannot_call "ar" +let supports_shared_libraries = false +let native_dynlink = false +let mkdll = native_pack_linker +let mkexe = native_pack_linker +let mkmaindll = native_pack_linker +let flambda = false +let with_flambda_invariants = false +let with_cmm_invariants = false +let windows_unicode = false +let flat_float_array = true +let function_sections = false +let afl_instrument = false +let native_compiler = false +let tsan = false +let architecture = "none" +let model = "default" +let system = "unknown" +let asm = boot_cannot_call "the assembler" +let asm_cfi_supported = false +let with_frame_pointers = false +let reserved_header_bits = 0 +let ext_exe = ".ex_The boot compiler should not be using Config.ext_exe" +let ext_obj = ".o_The boot compiler cannot process C objects" +let ext_asm = ".s_The boot compiler should not be using Config.ext_asm" +let ext_lib = ".a_The boot compiler cannot process C libraries" +let ext_dll = ".so_The boot compiler cannot load DLLs" +let host = "zinc-boot-ocaml" +let target = host +let systhread_supported = false +let flexdll_dirs = [] +let ar_supports_response_files = true diff --git a/upstream/ocaml_502/utils/config.mli b/upstream/ocaml_502/utils/config.mli new file mode 100644 index 0000000000..f1e1d04bd4 --- /dev/null +++ b/upstream/ocaml_502/utils/config.mli @@ -0,0 +1,270 @@ +(**************************************************************************) +(* *) +(* 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_ldflags : string +(* Flags to pass to the system linker *) + +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 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 native_compiler: bool +(** Whether the native compiler is available or not + + @since 5.1 *) + +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 *) + +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 reserved_header_bits : int +(** How many bits of a block's header are reserved *) + +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 naked_pointers : bool +(** Whether the runtime supports naked pointers + + @since 4.14 *) + +val supports_shared_libraries: bool +(** Whether shared libraries are supported + + @since 4.08 *) + +val native_dynlink: bool +(** Whether native shared libraries are supported + + @since 5.1 *) + +val afl_instrument : bool +(** Whether afl-fuzz instrumentation is generated by default *) + +val ar_supports_response_files: bool +(** Whether ar supports @FILE arguments. *) + +val tsan : bool +(** Whether ThreadSanitizer instrumentation is enabled *) + +(** 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_502/utils/consistbl.ml b/upstream/ocaml_502/utils/consistbl.ml new file mode 100644 index 0000000000..29289201f6 --- /dev/null +++ b/upstream/ocaml_502/utils/consistbl.ml @@ -0,0 +1,95 @@ +(**************************************************************************) +(* *) +(* 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 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_502/utils/consistbl.mli b/upstream/ocaml_502/utils/consistbl.mli new file mode 100644 index 0000000000..acc89eb31d --- /dev/null +++ b/upstream/ocaml_502/utils/consistbl.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* 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 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_502/utils/diffing.ml b/upstream/ocaml_502/utils/diffing.ml new file mode 100644 index 0000000000..94391803ae --- /dev/null +++ b/upstream/ocaml_502/utils/diffing.ml @@ -0,0 +1,447 @@ +(**************************************************************************) +(* *) +(* 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 + 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. + +*) + +(** Shared types *) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation + +let style = function + | Preservation -> Misc.Style.[ FG Green ] + | Deletion -> Misc.Style.[ FG Red; Bold] + | Insertion -> Misc.Style.[ FG Red; Bold] + | Modification -> Misc.Style.[ FG Magenta; Bold] + +let prefix ppf (pos, p) = + let sty = style p in + Format.pp_open_stag ppf (Misc.Style.Style sty); + Format.fprintf ppf "%i. " pos; + Format.pp_close_stag ppf () + + +let (let*) = Option.bind +let (let+) x f = Option.map f x +let (let*!) x f = Option.iter f x + +module type Defs = sig + type left + type right + type eq + type diff + type state +end + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +let classify = function + | Delete _ -> Deletion + | Insert _ -> Insertion + | Change _ -> Modification + | Keep _ -> Preservation + +module Define(D:Defs) = struct + open D + +type nonrec change = (left,right,eq,diff) change + +type patch = change list +module type S = sig + val diff: state -> left array -> right array -> patch +end + + +type full_state = { + line: left array; + column: right array; + state: state +} + +(* 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 t + + val make : shape -> t + val reshape : shape -> t -> t + + (** accessor functions *) + val diff : t -> int -> int -> change option + val state : t -> int -> int -> full_state option + val weight : t -> int -> int -> int + + val line : t -> int -> int -> left option + val column : t -> int -> int -> right option + + val set : + t -> int -> int -> + diff:change option -> + weight:int -> + state: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 t = + { states: full_state option array array; + weight: int array array; + 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 + + +(* 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) + +(* 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 + + module type Full_core = sig + type update_result + type update_state + val weight: change -> int + val test: state -> left -> right -> (eq, diff) result + val update: change -> update_state -> update_result + end + +module Generic + (X: Full_core + with type update_result := full_state + and type update_state := full_state) = struct + open X + + (* Boundary cell update *) + let compute_column0 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 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 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 m i j = + match i, j with + | _ when Matrix.diff m i j <> None -> () + | 0,0 -> () + | 0,j -> compute_line0 m j + | i,0 -> compute_column0 m i; + | _ -> compute_inner_cell 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 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 m i j + done + done; + loop m + else + m + in + loop m0 + end + + + module type Parameters = Full_core with type update_state := state + + module Simple(X:Parameters with type update_result := state) = struct + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = { fs with state = X.update d fs.state } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + + let may_append x = function + | [||] -> x + | y -> Array.append x y + + + module Left_variadic + (X:Parameters with type update_result := state * left array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; line = may_append fs.line a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + module Right_variadic + (X:Parameters with type update_result := state * right array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; column = may_append fs.column a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + +end diff --git a/upstream/ocaml_502/utils/diffing.mli b/upstream/ocaml_502/utils/diffing.mli new file mode 100644 index 0000000000..7f4d7ced1b --- /dev/null +++ b/upstream/ocaml_502/utils/diffing.mli @@ -0,0 +1,147 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** 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 ). + + 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 core types of a diffing implementation *) +module type Defs = sig + type left + type right + type eq + (** Detailed equality trace *) + + type diff + (** Detailed difference trace *) + + type state + (** environment of a partial patch *) +end + +(** The kind of changes which is used to share printing and styling + across implementation*) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation +val prefix: Format.formatter -> (int * change_kind) -> unit +val style: change_kind -> Misc.Style.style list + + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +val classify: _ change -> change_kind + +(** [Define(Defs)] creates the diffing types from the types + defined in [Defs] and the functors that need to be instantatied + with the diffing algorithm parameters +*) +module Define(D:Defs): sig + open D + + (** The type of potential changes on a list. *) + type nonrec change = (left,right,eq,diff) change + type patch = change list + (** A patch is an ordered list of changes. *) + + module type Parameters = sig + type update_result + + val weight: change -> int + (** [weight ch] returns the weight of the change [ch]. + Used to find the smallest patch. *) + + val test: state -> left -> right -> (eq, diff) result + (** + [test st xl xr] tests if the elements [xl] and [xr] are + co mpatible ([Ok]) or not ([Error]). + *) + + val update: change -> state -> update_result + (** [update ch st] returns the new state after applying a change. + The [update_result] type also contains expansions in the variadic + case. + *) + end + + module type S = sig + val diff: state -> left array -> right array -> patch + (** [diff state l r] computes the optimal patch between [l] and [r], + using the initial state [state]. + *) + end + + + module Simple: (Parameters with type update_result := state) -> S + + (** {1 Variadic diffing} + + Variadic diffing allows to expand the lists being diffed during diffing. + in one specific direction. + *) + module Left_variadic: + (Parameters with type update_result := state * left array) -> S + + module Right_variadic: + (Parameters with type update_result := state * right array) -> S + +end diff --git a/upstream/ocaml_502/utils/diffing_with_keys.ml b/upstream/ocaml_502/utils/diffing_with_keys.ml new file mode 100644 index 0000000000..28688a838b --- /dev/null +++ b/upstream/ocaml_502/utils/diffing_with_keys.ml @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + + +type 'a with_pos = {pos:int; data:'a} +let with_pos l = List.mapi (fun n data -> {pos=n+1; data}) l + +(** Composite change and mismatches *) +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +let prefix ppf x = + let kind = match x with + | Change _ | Swap _ | Move _ -> Diffing.Modification + | Insert _ -> Diffing.Insertion + | Delete _ -> Diffing.Deletion + in + let style k ppf inner = + let sty = Diffing.style k in + Format.pp_open_stag ppf (Misc.Style.Style sty); + Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner + in + match x with + | Change (Name {pos; _ } | Type {pos; _}) + | Insert { pos; _ } | Delete { pos; _ } -> + style kind ppf "%i. " pos + | Swap { pos = left, right; _ } -> + style kind ppf "%i<->%i. " left right + | Move { got; expected; _ } -> + style kind ppf "%i->%i. " expected got + + + +(** To detect [move] and [swaps], we are using the fact that + there are 2-cycles in the graph of name renaming. + - [Change (x,y,_) is then an edge from + [key_left x] to [key_right y]. + - [Insert x] is an edge between the special node epsilon and + [key_left x] + - [Delete x] is an edge between [key_right] and the epsilon node + Since for 2-cycle, knowing one edge is enough to identify the cycle + it might belong to, we are using maps of partial 2-cycles. +*) +module Two_cycle: sig + type t = private (string * string) + val create: string -> string -> t +end = struct + type t = string * string + let create kx ky = + if kx <= ky then kx, ky else ky, kx +end +module Swap = Map.Make(struct + type t = Two_cycle.t + let compare: t -> t -> int = Stdlib.compare + end) +module Move = Misc.Stdlib.String.Map + + +module Define(D:Diffing.Defs with type eq := unit) = struct + + module Internal_defs = struct + type left = D.left with_pos + type right = D.right with_pos + type diff = (D.left, D.right, D.diff) mismatch + type eq = unit + type state = D.state + end + module Diff = Diffing.Define(Internal_defs) + + type left = Internal_defs.left + type right = Internal_defs.right + type diff = (D.left, D.right, D.diff) mismatch + type composite_change = (D.left,D.right,D.diff) change + type nonrec change = (left, right, unit, diff) Diffing.change + type patch = composite_change list + + module type Parameters = sig + include Diff.Parameters with type update_result := D.state + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple(Impl:Parameters) = struct + open Impl + + (** Partial 2-cycles *) + type ('l,'r) partial_cycle = + | Left of int * D.state * 'l + | Right of int * D.state * 'r + | Both of D.state * 'l * 'r + + (** Compute the partial cycle and edge associated to an edge *) + let edge state (x:left) (y:right) = + let kx, ky = key_left x.data, key_right y.data in + let edge = + if kx <= ky then + Left (x.pos, state, (x,y)) + else + Right (x.pos,state, (x,y)) + in + Two_cycle.create kx ky, edge + + let merge_edge ex ey = match ex, ey with + | ex, None -> Some ex + | Left (lpos, lstate, l), Some Right (rpos, rstate,r) + | Right (rpos, rstate,r), Some Left (lpos, lstate, l) -> + let state = if lpos < rpos then rstate else lstate in + Some (Both (state,l,r)) + | Both _ as b, _ | _, Some (Both _ as b) -> Some b + | l, _ -> Some l + + let two_cycles state changes = + let add (state,(swaps,moves)) (d:change) = + update d state, + match d with + | Change (x,y,_) -> + let k, edge = edge state x y in + Swap.update k (merge_edge edge) swaps, moves + | Insert nx -> + let k = key_right nx.data in + let edge = Right (nx.pos, state,nx) in + swaps, Move.update k (merge_edge edge) moves + | Delete nx -> + let k, edge = key_left nx.data, Left (nx.pos, state, nx) in + swaps, Move.update k (merge_edge edge) moves + | _ -> swaps, moves + in + List.fold_left add (state,(Swap.empty,Move.empty)) changes + + (** Check if an edge belongs to a known 2-cycle *) + let swap swaps x y = + let kx, ky = key_left x.data, key_right y.data in + let key = Two_cycle.create kx ky in + match Swap.find_opt key swaps with + | None | Some (Left _ | Right _)-> None + | Some Both (state, (ll,lr),(rl,rr)) -> + match test state ll rr, test state rl lr with + | Ok _, Ok _ -> + Some ({pos=ll.pos; data=kx}, {pos=rl.pos; data=ky}) + | Error _, _ | _, Error _ -> None + + let move moves x = + let name = + match x with + | Either.Left x -> key_left x.data + | Either.Right x -> key_right x.data + in + match Move.find_opt name moves with + | None | Some (Left _ | Right _)-> None + | Some Both (state,got,expected) -> + match test state got expected with + | Ok _ -> + Some (Move {name; got=got.pos; expected=expected.pos}) + | Error _ -> None + + let refine state patch = + let _, (swaps, moves) = two_cycles state patch in + let filter: change -> composite_change option = function + | Keep _ -> None + | Insert x -> + begin match move moves (Either.Right x) with + | Some _ as move -> move + | None -> Some (Insert {pos=x.pos;insert=x.data}) + end + | Delete x -> + begin match move moves (Either.Left x) with + | Some _ -> None + | None -> Some (Delete {pos=x.pos; delete=x.data}) + end + | Change(x,y, reason) -> + match swap swaps x y with + | Some ({pos=pos1; data=first}, {pos=pos2; data=last}) -> + if x.pos = pos1 then + Some (Swap { pos = pos1, pos2; first; last}) + else None + | None -> Some (Change reason) + in + List.filter_map filter patch + + let diff state left right = + let left = with_pos left in + let right = with_pos right in + let module Raw = Diff.Simple(Impl) in + let raw = Raw.diff state (Array.of_list left) (Array.of_list right) in + refine state raw + + end +end diff --git a/upstream/ocaml_502/utils/diffing_with_keys.mli b/upstream/ocaml_502/utils/diffing_with_keys.mli new file mode 100644 index 0000000000..2da8268767 --- /dev/null +++ b/upstream/ocaml_502/utils/diffing_with_keys.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** + + When diffing lists where each element has a distinct key, we can refine + the diffing patch by introducing two composite edit moves: swaps and moves. + + [Swap]s exchange the position of two elements. [Swap] cost is set to + [2 * change - epsilon]. + [Move]s change the position of one element. [Move] cost is set to + [delete + addition - epsilon]. + + When the cost [delete + addition] is greater than [change] and with those + specific weights, the optimal patch with [Swap]s and [Move]s can be computed + directly and cheaply from the original optimal patch. + +*) + +type 'a with_pos = {pos: int; data:'a} +val with_pos: 'a list -> 'a with_pos list + +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +(** This specialized version of changes introduces two composite + changes: [Move] and [Swap] +*) +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +val prefix: Format.formatter -> ('l,'r,'diff) change -> unit + +module Define(D:Diffing.Defs with type eq := unit): sig + + type diff = (D.left, D.right, D.diff) mismatch + type left = D.left with_pos + type right = D.right with_pos + + (** Composite changes and patches *) + type composite_change = (D.left,D.right,D.diff) change + type patch = composite_change list + + (** Atomic changes *) + type change = (left,right,unit,diff) Diffing.change + + module type Parameters = sig + val weight: change -> int + val test: D.state -> left -> right -> (unit, diff) result + val update: change -> D.state -> D.state + + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple: Parameters -> sig + val diff: D.state -> D.left list -> D.right list -> patch + end + +end diff --git a/upstream/ocaml_502/utils/identifiable.ml b/upstream/ocaml_502/utils/identifiable.ml new file mode 100644 index 0000000000..9bbfb65733 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/identifiable.mli b/upstream/ocaml_502/utils/identifiable.mli new file mode 100644 index 0000000000..0da5a66191 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/int_replace_polymorphic_compare.ml b/upstream/ocaml_502/utils/int_replace_polymorphic_compare.ml new file mode 100644 index 0000000000..7cd6bf1099 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/int_replace_polymorphic_compare.mli b/upstream/ocaml_502/utils/int_replace_polymorphic_compare.mli new file mode 100644 index 0000000000..689e741b66 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/lazy_backtrack.ml b/upstream/ocaml_502/utils/lazy_backtrack.ml new file mode 100644 index 0000000000..13e4eb4400 --- /dev/null +++ b/upstream/ocaml_502/utils/lazy_backtrack.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* 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 get_contents x = + match !x with + | Thunk a -> Either.Left a + | Done b -> Either.Right b + | Raise e -> raise e + +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_502/utils/lazy_backtrack.mli b/upstream/ocaml_502/utils/lazy_backtrack.mli new file mode 100644 index 0000000000..4e2fbd3808 --- /dev/null +++ b/upstream/ocaml_502/utils/lazy_backtrack.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* 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 get_contents : ('a,'b) t -> ('a,'b) Either.t +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_502/utils/load_path.ml b/upstream/ocaml_502/utils/load_path.ml new file mode 100644 index 0000000000..08b94c8343 --- /dev/null +++ b/upstream/ocaml_502/utils/load_path.ml @@ -0,0 +1,233 @@ +(**************************************************************************) +(* *) +(* 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 visible_files : registry ref = s_table STbl.create 42 +let visible_files_uncap : registry ref = s_table STbl.create 42 + +let hidden_files : registry ref = s_table STbl.create 42 +let hidden_files_uncap : registry ref = s_table STbl.create 42 + +module Dir = struct + type t = { + path : string; + files : string list; + hidden : bool; + } + + let path t = t.path + let files t = t.files + let hidden t = t.hidden + + let find t fn = + if List.mem fn t.files then + Some (Filename.concat t.path fn) + else + None + + let find_normalized t fn = + let fn = Misc.normalized_unit_filename fn in + let search base = + if Misc.normalized_unit_filename base = fn then + Some (Filename.concat t.path base) + else + None + in + List.find_map search 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 ~hidden path = + { path; files = Array.to_list (readdir_compat path); hidden } +end + +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string + +let visible_dirs = s_ref [] +let hidden_dirs = s_ref [] +let no_auto_include _ _ = raise Not_found +let auto_include_callback = ref no_auto_include + +let reset () = + assert (not Config.merlin || Local_store.is_bound ()); + STbl.clear !hidden_files; + STbl.clear !hidden_files_uncap; + STbl.clear !visible_files; + STbl.clear !visible_files_uncap; + hidden_dirs := []; + visible_dirs := []; + auto_include_callback := no_auto_include + +let get_visible () = List.rev !visible_dirs + +let get_path_list () = + Misc.rev_map_end Dir.path !visible_dirs (List.rev_map Dir.path !hidden_dirs) + +type paths = + { visible : string list; + hidden : string list } + +let get_paths () = + { visible = List.rev_map Dir.path !visible_dirs; + hidden = List.rev_map Dir.path !hidden_dirs } + +let get_visible_path_list () = List.rev_map Dir.path !visible_dirs +let get_hidden_path_list () = List.rev_map Dir.path !hidden_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 + let filename = Misc.normalized_unit_filename base in + if dir.Dir.hidden then begin + STbl.replace !hidden_files base fn; + STbl.replace !hidden_files_uncap filename fn + end else begin + STbl.replace !visible_files base fn; + STbl.replace !visible_files_uncap filename fn + end + ) dir.Dir.files + +let init ~auto_include ~visible ~hidden = + reset (); + visible_dirs := List.rev_map (Dir.create ~hidden:false) visible; + hidden_dirs := List.rev_map (Dir.create ~hidden:true) hidden; + List.iter prepend_add !hidden_dirs; + List.iter prepend_add !visible_dirs; + auto_include_callback := auto_include + +let remove_dir dir = + assert (not Config.merlin || Local_store.is_bound ()); + let visible = List.filter (fun d -> Dir.path d <> dir) !visible_dirs in + let hidden = List.filter (fun d -> Dir.path d <> dir) !hidden_dirs in + if List.compare_lengths visible !visible_dirs <> 0 + || List.compare_lengths hidden !hidden_dirs <> 0 then begin + reset (); + visible_dirs := visible; + hidden_dirs := hidden; + List.iter prepend_add hidden; + List.iter prepend_add visible + 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 order to enforce + left-to-right precedence. *) +let add (dir : Dir.t) = + assert (not Config.merlin || Local_store.is_bound ()); + let update base fn visible_files hidden_files = + if dir.hidden && not (STbl.mem !hidden_files base) then + STbl.replace !hidden_files base fn + else if not (STbl.mem !visible_files base) then + STbl.replace !visible_files base fn + in + List.iter + (fun base -> + let fn = Filename.concat dir.Dir.path base in + update base fn visible_files hidden_files; + let ubase = Misc.normalized_unit_filename base in + update ubase fn visible_files_uncap hidden_files_uncap) + dir.files; + if dir.hidden then + hidden_dirs := dir :: !hidden_dirs + else + visible_dirs := dir :: !visible_dirs + +let append_dir = add + +let add_dir ~hidden dir = add (Dir.create ~hidden dir) + +(* Add the directory at the start of load path - so basenames are + unconditionally added. *) +let prepend_dir (dir : Dir.t) = + assert (not Config.merlin || Local_store.is_bound ()); + prepend_add dir; + if dir.hidden then + hidden_dirs := !hidden_dirs @ [dir] + else + visible_dirs := !visible_dirs @ [dir] + +let is_basename fn = Filename.basename fn = fn + +let auto_include_libs libs alert find_in_dir fn = + let scan (lib, lazy dir) = + let file = find_in_dir dir fn in + let alert_and_add_dir _ = + alert lib; + append_dir dir + in + Option.iter alert_and_add_dir file; + file + in + match List.find_map scan libs with + | Some base -> base + | None -> raise Not_found + +let auto_include_otherlibs = + (* Ensure directories are only ever scanned once *) + let expand = Misc.expand_directory Config.standard_library in + let otherlibs = + let read_lib lib = lazy (Dir.create ~hidden:false (expand ("+" ^ lib))) in + List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in + auto_include_libs otherlibs + +type visibility = Visible | Hidden + +let find_file_in_cache fn visible_files hidden_files = + try (STbl.find !visible_files fn, Visible) with + | Not_found -> (STbl.find !hidden_files fn, Hidden) + +let find fn = + assert (not Config.merlin || Local_store.is_bound ()); + try + if is_basename fn && not !Sys.interactive then + fst (find_file_in_cache fn visible_files hidden_files) + else + Misc.find_in_path (get_path_list ()) fn + with Not_found -> + !auto_include_callback Dir.find fn + +let find_normalized_with_visibility fn = + assert (not Config.merlin || Local_store.is_bound ()); + try + if is_basename fn && not !Sys.interactive then + find_file_in_cache (Misc.normalized_unit_filename fn) + visible_files_uncap hidden_files_uncap + else + try + (Misc.find_in_path_normalized (get_visible_path_list ()) fn, Visible) + with + | Not_found -> + (Misc.find_in_path_normalized (get_hidden_path_list ()) fn, Hidden) + with Not_found -> + let fn_uncap = Misc.normalized_unit_filename fn in + (!auto_include_callback Dir.find_normalized fn_uncap, Visible) + +let find_normalized fn = fst (find_normalized_with_visibility fn) diff --git a/upstream/ocaml_502/utils/load_path.mli b/upstream/ocaml_502/utils/load_path.mli new file mode 100644 index 0000000000..488b75f760 --- /dev/null +++ b/upstream/ocaml_502/utils/load_path.mli @@ -0,0 +1,120 @@ +(**************************************************************************) +(* *) +(* 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] and [-H] 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 : hidden:bool -> 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 *) + +module Dir : sig + type t + (** Represent one directory in the load path. *) + + val create : hidden:bool -> 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. *) + + val hidden : t -> bool + (** If the modules in this directory should not be bound in the initial + scope *) + + val find : t -> string -> string option + (** [find dir fn] returns the full path to [fn] in [dir]. *) + + val find_normalized : t -> string -> string option + (** As {!find}, but search also for uncapitalized name, i.e. if name is + Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) +end + +type auto_include_callback = + (Dir.t -> string -> string option) -> string -> string +(** The type of callback functions on for [init ~auto_include] *) + +val no_auto_include : auto_include_callback +(** No automatic directory inclusion: misses in the load path raise [Not_found] + as normal. *) + +val init : + auto_include:auto_include_callback -> visible:string list -> + hidden:string list -> unit +(** [init ~visible ~hidden] is the same as + [reset (); + List.iter add_dir (List.rev hidden); + List.iter add_dir (List.rev visible)] *) + +val auto_include_otherlibs : + (string -> unit) -> auto_include_callback +(** [auto_include_otherlibs alert] is a callback function to be passed to + {!Load_path.init} and automatically adds [-I +lib] to the load path after + calling [alert lib]. *) + +val get_path_list : unit -> string list +(** Return the list of directories passed to [add_dir] so far. *) + +type paths = + { visible : string list; + hidden : string list } + +val get_paths : unit -> paths +(** Return the 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_normalized : string -> string +(** Same as [find], but search also for normalized unit name (see + {!Misc.normalized_unit_filename}), i.e. if name is [Foo.ml], allow + [/path/Foo.ml] and [/path/foo.ml] to match. *) + +type visibility = Visible | Hidden + +val find_normalized_with_visibility : string -> string * visibility +(** Same as [find_normalized], but also reports whether the cmi was found in a + -I directory (Visible) or a -H directory (Hidden) *) + +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_visible : unit -> Dir.t list +(** Same as [get_paths ()], except that it returns a [Dir.t list], and doesn't + include the -H paths. *) diff --git a/upstream/ocaml_502/utils/local_store.ml b/upstream/ocaml_502/utils/local_store.ml new file mode 100644 index 0000000000..4babf61d82 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/local_store.mli b/upstream/ocaml_502/utils/local_store.mli new file mode 100644 index 0000000000..3ea05d5889 --- /dev/null +++ b/upstream/ocaml_502/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 {!val:Stdlib.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_store 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 store is active (i.e. when called from the callback + passed to {!with_store}), [false] otherwise. *) diff --git a/upstream/ocaml_502/utils/misc.ml b/upstream/ocaml_502/utils/misc.ml new file mode 100644 index 0000000000..8a7883b427 --- /dev/null +++ b/upstream/ocaml_502/utils/misc.ml @@ -0,0 +1,1179 @@ +(**************************************************************************) +(* *) +(* 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 rev_map_end f l1 l2 = + let rec rmap_f accu = function + | [] -> accu + | hd::tl -> rmap_f (f hd :: accu) tl + in + rmap_f l2 l1 + +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 rec iteri2 i f l1 l2 = + match (l1, l2) with + ([], []) -> () + | (a1::l1, a2::l2) -> f i a1 a2; iteri2 (i + 1) f l1 l2 + | (_, _) -> raise (Invalid_argument "iteri2") + + let iteri2 f l1 l2 = iteri2 0 f 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 chunks_of n l = + if n <= 0 then raise (Invalid_argument "chunks_of"); + (* Invariant: List.length l = remaining *) + let rec aux n acc l ~remaining = + match remaining with + | 0 -> List.rev acc + | _ when remaining <= n -> List.rev (l :: acc) + | _ -> + let chunk, rest = split_at n l in + aux n (chunk :: acc) rest ~remaining:(remaining - n) + in + aux n [] l ~remaining:(List.length 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 normalized_unit_filename = String.uncapitalize_ascii + +let find_in_path_normalized path name = + let uname = normalized_unit_filename 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.is_regular_file 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 + +let letter_of_int n = + let letter = String.make 1 (Char.chr (Char.code 'a' + n mod 26)) in + let num = n / 26 in + if num = 0 then letter + else letter ^ Int.to_string num + +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 + +(* [find_first_mono p] assumes that there exists a natural number + N such that [p] is false on [0; N[ and true on [N; max_int], and + returns this N. (See misc.mli for the detailed specification.) *) +let find_first_mono = + let rec find p ~low ~jump ~high = + (* Invariants: + [low, jump, high] are non-negative with [low < high], + [p low = false], + [p high = true]. *) + if low + 1 = high then high + (* ensure that [low + jump] is in ]low; high[ *) + else if jump < 1 then find p ~low ~jump:1 ~high + else if jump >= high - low then find p ~low ~jump:((high - low) / 2) ~high + else if p (low + jump) then + (* We jumped too high: continue with a smaller jump and lower limit *) + find p ~low:low ~jump:(jump / 2) ~high:(low + jump) + else + (* we jumped too low: + continue from [low + jump] with a larger jump *) + let next_jump = max jump (2 * jump) (* avoid overflows *) in + find p ~low:(low + jump) ~jump:next_jump ~high + in + fun p -> + if p 0 then 0 + else find p ~low:0 ~jump:1 ~high:max_int + +(* String operations *) + +let split_null_terminated s = + let[@tail_mod_cons] rec discard_last_sep = function + | [] | [""] -> [] + | x :: xs -> x :: discard_last_sep xs + in + discard_last_sep (String.split_on_char '\000' s) + +let concat_null_terminated = function + | [] -> "" + | l -> String.concat "\000" (l @ [""]) + +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 + + +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) + +let ordinal_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" + +(* Color support handling *) +module Color = struct + 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 enabled = ref true + +end + +(* Terminal styling handling *) +module Style = 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 tag_style ={ + ansi: style list; + text_open:string; + text_close:string + } + + type styles = { + error: tag_style; + warning: tag_style; + loc: tag_style; + hint: tag_style; + inline_code: tag_style; + } + + let no_markup stl = { ansi = stl; text_close = ""; text_open = "" } + + let default_styles = { + warning = no_markup [Bold; FG Magenta]; + error = no_markup [Bold; FG Red]; + loc = no_markup [Bold]; + hint = no_markup [Bold; FG Blue]; + inline_code= { ansi=[Bold]; text_open = {|"|}; text_close = {|"|} } + } + + 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 + | Format.String_tag "hint" -> (!cur_styles).hint + | Format.String_tag "inline_code" -> (!cur_styles).inline_code + | Style s -> no_markup s + | _ -> raise Not_found + + + let as_inline_code printer ppf x = + Format.pp_open_stag ppf (Format.String_tag "inline_code"); + printer ppf x; + Format.pp_close_stag ppf () + + let inline_code ppf s = as_inline_code Format.pp_print_string ppf s + + (* 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.ansi else style.text_open + with Not_found -> or_else s + + let mark_close_tag ~or_else s = + try + let style = style_of_tag s in + if !Color.enabled then ansi_of_style_l [Reset] else style.text_close + with Not_found -> or_else s + + (* add tag handling to formatter [ppf] *) + let set_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'; + () + + 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 + | Color.Auto -> Color.should_enable_color () + | Color.Always -> true + | Color.Never -> false + in + fun o -> + if !first then ( + first := false; + Format.set_mark_tags true; + List.iter set_tag_handling formatter_l; + Color.enabled := (match o with + | Some s -> enable_color s + | None -> enable_color Color.default_setting) + ); + () +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 + let comma ppf () = Format.fprintf ppf ", " in + Format.fprintf ppf "@\n@{Hint@}: Did you mean %a%s%a?@?" + (Format.pp_print_list ~pp_sep:comma Style.inline_code) rest + (if rest = [] then "" else " or ") + Style.inline_code last + +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 "@["; + 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 + +let print_see_manual ppf manual_section = + let open Format in + fprintf ppf "(see manual section %a)" + (pp_print_list ~pp_sep:(fun f () -> pp_print_char f '.') pp_print_int) + manual_section + + +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_502/utils/misc.mli b/upstream/ocaml_502/utils/misc.mli new file mode 100644 index 0000000000..6deedc4934 --- /dev/null +++ b/upstream/ocaml_502/utils/misc.mli @@ -0,0 +1,796 @@ +(**************************************************************************) +(* *) +(* 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}. + +*) + +(** {1 Reporting fatal errors} *) + +val fatal_error: string -> 'a + (** Raise the [Fatal_error] exception with the given string. *) + +val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a + (** Format the arguments according to the given format string + and raise [Fatal_error] with the resulting string. *) + +exception Fatal_error + +(** {1 Exceptions and finalization} *) + +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. *) + +(** {1 List operations} *) + +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 rev_map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list + (** [map_end f l t] is [map f (rev 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. *) + +(** {1 Hash table operations} *) + +val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t + (** Create a hashtable with the given initial size and fills it + with the given bindings. *) + +(** {1 Extensions to the standard library} *) + +module Stdlib : sig + +(** {2 Extensions to the List module} *) + 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 iteri2 : (int -> 'a -> 'b -> unit) -> 'a list -> 'b list -> unit + (** Same as {!List.iter2}, but the function is applied to the index of + the element as first argument (counting from 0) *) + + 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 chunks_of : int -> 'a t -> 'a t t + (** [chunks_of n t] returns a list of nonempty lists whose + concatenation is equal to the original list. Every list has [n] + elements, except for possibly the last list, which may have fewer. + [chunks_of] raises if [n <= 0]. *) + + 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 + +(** {2 Extensions to the Option module} *) + module Option : sig + type 'a t = 'a option + + val print + : (Format.formatter -> 'a -> unit) + -> Format.formatter + -> 'a t + -> unit + end + +(** {2 Extensions to the Array module} *) + module Array : sig + val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool + (** Same as [Array.exists2] from the standard library. *) + + val for_alli : (int -> 'a -> bool) -> 'a array -> bool + (** Same as [Array.for_all] from the standard library, 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 + +(** {2 Extensions to the String module} *) + 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 + +(** {1 Operations on files and file paths} *) + +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. *) + + (** Normalize file name [Foo.ml] to [foo.ml] *) +val normalized_unit_filename: string -> string + +val find_in_path_normalized: string list -> string -> string +(** Same as {!find_in_path_rel} , but search also for normalized unit filename, + 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 and is a regular file. + Does nothing for other kinds of files. + Never raises 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 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 protect_writing_to_file + : filename:string + -> f:(out_channel -> 'a) + -> 'a + (** 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 concat_null_terminated : string list -> string +(** [concat_null_terminated [x1;x2; ... xn]] is + [x1 ^ "\000" ^ x2 ^ "\000" ^ ... ^ xn ^ "\000"] *) + +val split_null_terminated : string -> string list +(** [split_null_terminated s] is similar + [String.split_on_char '\000'] but ignores the trailing separator, if any *) + +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. *) + +(** {1 Integer operations} *) + +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. *) + +val letter_of_int : int -> string + +module Int_literal_converter : sig + val int : string -> int + (** Convert a string to an integer. Unlike {!Stdlib.int_of_string}, + this function accepts the string representation of [max_int + 1] + and returns [min_int] in this case. *) + + val int32 : string -> int32 + (** Likewise, at type [int32] *) + + val int64 : string -> int64 + (** Likewise, at type [int64] *) + + val nativeint : string -> nativeint + (** Likewise, at type [nativeint] *) + +end + +val find_first_mono : (int -> bool) -> int + (**[find_first_mono p] takes an integer predicate [p : int -> bool] + that we assume: + 1. is monotonic on natural numbers: + if [a <= b] then [p a] implies [p b], + 2. is satisfied for some natural numbers in range [0; max_int] + (this is equivalent to: [p max_int = true]). + + [find_first_mono p] is the smallest natural number N that satisfies [p], + computed in O(log(N)) calls to [p]. + + Our implementation supports two cases where the preconditions on [p] + are not respected: + - If [p] is always [false], we silently return [max_int] + instead of looping or crashing. + - If [p] is non-monotonic but eventually true, + we return some satisfying value. + *) + +(** {1 String operations} *) + +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 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 ordinal_suffix : int -> string +(** [ordinal_suffix n] is the appropriate suffix to append to the numeral [n] as + an ordinal number: [1] -> ["st"], [2] -> ["nd"], [3] -> ["rd"], + [4] -> ["th"], and so on. Handles larger numbers (e.g., [42] -> ["nd"]) and + the numbers 11--13 (which all get ["th"]) correctly. *) + +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. *) + +(** {1 Operations on references} *) + +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. +*) + +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]. *) + +(** {1 Operations on triples and quadruples} *) + +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 + +(** {1 Spell checking and ``did you mean'' suggestions} *) + +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. +*) + +(** {1 Color support detection }*) +module Color: sig + + type setting = Auto | Always | Never + + val default_setting : setting + +end + + +(** {1 Styling handling for terminal output } *) + +module Style : 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 tag_style ={ + ansi: style list; + text_open:string; + text_close:string + } + + type styles = { + error: tag_style; + warning: tag_style; + loc: tag_style; + hint: tag_style; + inline_code: tag_style; + } + + val as_inline_code: (Format.formatter -> 'a -> unit as 'printer) -> 'printer + val inline_code: Format.formatter -> string -> unit + + val default_styles: styles + val get_styles: unit -> styles + val set_styles: styles -> unit + + val setup : Color.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_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 + +(** {1 Formatted output} *) + +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. *) + +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} +*) + +val print_see_manual : Format.formatter -> int list -> unit +(** See manual section *) + +(** {1 Displaying configuration variables} *) + +val show_config_and_exit : unit -> unit + (** Display the values of all compiler configuration variables from module + [Config], then exit the program with code 0. *) + +val show_config_variable_and_exit : string -> unit + (** Display the value of the given configuration variable, + then exit the program with code 0. *) + +(** {1 Handling of build maps} *) + +(** Build maps cause the compiler to normalize file names embedded in + object files, thus leading to more reproducible builds. *) + +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. *) + +(** {1 Handling of magic numbers} *) + +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 + *) + + 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 + +(** {1 Miscellaneous type aliases} *) + +type filepath = string +type modname = string +type crcs = (modname * Digest.t option) list + +type alerts = string Stdlib.String.Map.t diff --git a/upstream/ocaml_502/utils/numbers.ml b/upstream/ocaml_502/utils/numbers.ml new file mode 100644 index 0000000000..1680675bab --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/numbers.mli b/upstream/ocaml_502/utils/numbers.mli new file mode 100644 index 0000000000..fa565e67e1 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/profile.ml b/upstream/ocaml_502/utils/profile.ml new file mode 100644 index 0000000000..27c92a5463 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/profile.mli b/upstream/ocaml_502/utils/profile.mli new file mode 100644 index 0000000000..7eff6957b6 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/strongly_connected_components.ml b/upstream/ocaml_502/utils/strongly_connected_components.ml new file mode 100644 index 0000000000..eb1501ca7c --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/strongly_connected_components.mli b/upstream/ocaml_502/utils/strongly_connected_components.mli new file mode 100644 index 0000000000..e700952792 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/targetint.ml b/upstream/ocaml_502/utils/targetint.ml new file mode 100644 index 0000000000..9d15a2ff56 --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/targetint.mli b/upstream/ocaml_502/utils/targetint.mli new file mode 100644 index 0000000000..a222f5d68c --- /dev/null +++ b/upstream/ocaml_502/utils/targetint.mli @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* 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 +(** [abs x] is the absolute value of [x]. On [min_int] this + is [min_int] itself and thus remains negative. *) + +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_502/utils/terminfo.ml b/upstream/ocaml_502/utils/terminfo.ml new file mode 100644 index 0000000000..1b4a3578eb --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/terminfo.mli b/upstream/ocaml_502/utils/terminfo.mli new file mode 100644 index 0000000000..10f5f5453f --- /dev/null +++ b/upstream/ocaml_502/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_502/utils/warnings.ml b/upstream/ocaml_502/utils/warnings.ml new file mode 100644 index 0000000000..1812e0a341 --- /dev/null +++ b/upstream/ocaml_502/utils/warnings.ml @@ -0,0 +1,1240 @@ +(**************************************************************************) +(* *) +(* 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 *) + was turned into a hard error *) + | 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 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) + +(* 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 + | 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 + | Unused_tmc_attribute -> 71 + | Tmc_breaks_tailcall -> 72 + | Generative_application_expects_unit -> 73 +;; +(* DO NOT REMOVE the ;; above: it is used by + the testsuite/ests/warnings/mnemonics.mll test to determine where + the definition of the number function above ends *) + +let last_warning_number = 73 + +type description = + { number : int; + names : string list; + (* 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. *) + description : string; + since : Sys.ocaml_release_info option; + (* The compiler version introducing this warning; only tagged for warnings + created after 3.12, which introduced the numbered syntax. *) + } + +let since major minor = Some { Sys.major; minor; patchlevel=0; extra=None } + +let descriptions = [ + { number = 1; + names = ["comment-start"]; + description = "Suspicious-looking start-of-comment mark."; + since = None }; + { number = 2; + names = ["comment-not-end"]; + description = "Suspicious-looking end-of-comment mark."; + since = None }; + { number = 3; + names = []; + description = "Deprecated synonym for the 'deprecated' alert."; + since = None }; + { number = 4; + names = ["fragile-match"]; + description = + "Fragile pattern matching: matching that will remain complete even\n\ + \ if additional constructors are added to one of the variant types\n\ + \ matched."; + since = None }; + { number = 5; + names = ["ignored-partial-application"]; + description = + "Partially applied function: expression whose result has function\n\ + \ type and is ignored."; + since = None }; + { number = 6; + names = ["labels-omitted"]; + description = "Label omitted in function application."; + since = None }; + { number = 7; + names = ["method-override"]; + description = "Method overridden."; + since = None }; + { number = 8; + names = ["partial-match"]; + description = "Partial match: missing cases in pattern-matching."; + since = None }; + { number = 9; + names = ["missing-record-field-pattern"]; + description = "Missing fields in a record pattern."; + since = None }; + { number = 10; + names = ["non-unit-statement"]; + description = + "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)."; + since = None }; + { number = 11; + names = ["redundant-case"]; + description = + "Redundant case in a pattern matching (unused match case)."; + since = None }; + { number = 12; + names = ["redundant-subpat"]; + description = "Redundant sub-pattern in a pattern-matching." ; + since = None}; + { number = 13; + names = ["instance-variable-override"]; + description = "Instance variable overridden."; + since = None }; + { number = 14; + names = ["illegal-backslash"]; + description = "Illegal backslash escape in a string constant."; + since = None }; + { number = 15; + names = ["implicit-public-methods"]; + description = "Private method made public implicitly."; + since = None }; + { number = 16; + names = ["unerasable-optional-argument"]; + description = "Unerasable optional argument."; + since = None }; + { number = 17; + names = ["undeclared-virtual-method"]; + description = "Undeclared virtual method."; + since = None }; + { number = 18; + names = ["not-principal"]; + description = "Non-principal type."; + since = None }; + { number = 19; + names = ["non-principal-labels"]; + description = "Type without principality."; + since = None }; + { number = 20; + names = ["ignored-extra-argument"]; + description = "Unused function argument."; + since = None }; + { number = 21; + names = ["nonreturning-statement"]; + description = "Non-returning statement."; + since = None }; + { number = 22; + names = ["preprocessor"]; + description = "Preprocessor warning."; + since = None }; + { number = 23; + names = ["useless-record-with"]; + description = "Useless record \"with\" clause."; + since = None }; + { number = 24; + names = ["bad-module-name"]; + description = + "Bad module name: the source file name is not a valid OCaml module name."; + since = None }; + { number = 25; + names = []; + description = "Ignored: now part of warning 8."; + since = None }; + { number = 26; + names = ["unused-var"]; + description = + "Suspicious unused variable: unused variable that is bound\n\ + \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character."; + since = None }; + { number = 27; + names = ["unused-var-strict"]; + description = + "Innocuous unused variable: unused variable that is not bound with\n\ + \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character."; + since = None }; + { number = 28; + names = ["wildcard-arg-to-constant-constr"]; + description = + "Wildcard pattern given as argument to a constant constructor."; + since = None }; + { number = 29; + names = ["eol-in-string"]; + description = + "Unescaped end-of-line in a string constant (non-portable code)."; + since = None }; + { number = 30; + names = ["duplicate-definitions"]; + description = + "Two labels or constructors of the same name are defined in two\n\ + \ mutually recursive types."; + since = None }; + { number = 31; + names = ["module-linked-twice"]; + description = + "A module is linked twice in the same executable.\n\ + \ Ignored: now a hard error (since 5.1)."; + since = None }; + { number = 32; + names = ["unused-value-declaration"]; + description = "Unused value declaration."; + since = since 4 0 }; + { number = 33; + names = ["unused-open"]; + description = "Unused open statement."; + since = since 4 0 }; + { number = 34; + names = ["unused-type-declaration"]; + description = "Unused type declaration."; + since = since 4 0 }; + { number = 35; + names = ["unused-for-index"]; + description = "Unused for-loop index."; + since = since 4 0 }; + { number = 36; + names = ["unused-ancestor"]; + description = "Unused ancestor variable."; + since = since 4 0 }; + { number = 37; + names = ["unused-constructor"]; + description = "Unused constructor."; + since = since 4 0 }; + { number = 38; + names = ["unused-extension"]; + description = "Unused extension constructor."; + since = since 4 0 }; + { number = 39; + names = ["unused-rec-flag"]; + description = "Unused rec flag."; + since = since 4 0 }; + { number = 40; + names = ["name-out-of-scope"]; + description = "Constructor or label name used out of scope."; + since = since 4 1 }; + { number = 41; + names = ["ambiguous-name"]; + description = "Ambiguous constructor or label name."; + since = since 4 1 }; + { number = 42; + names = ["disambiguated-name"]; + description = + "Disambiguated constructor or label name (compatibility warning)."; + since = since 4 1 }; + { number = 43; + names = ["nonoptional-label"]; + description = "Nonoptional label applied as optional."; + since = since 4 1 }; + { number = 44; + names = ["open-shadow-identifier"]; + description = "Open statement shadows an already defined identifier."; + since = since 4 1 }; + { number = 45; + names = ["open-shadow-label-constructor"]; + description = + "Open statement shadows an already defined label or constructor."; + since = since 4 1 }; + { number = 46; + names = ["bad-env-variable"]; + description = "Error in environment variable."; + since = since 4 1 }; + { number = 47; + names = ["attribute-payload"]; + description = "Illegal attribute payload."; + since = since 4 2 }; + { number = 48; + names = ["eliminated-optional-arguments"]; + description = "Implicit elimination of optional arguments."; + since = since 4 2 }; + { number = 49; + names = ["no-cmi-file"]; + description = "Absent cmi file when looking up module alias."; + since = since 4 2 }; + { number = 50; + names = ["unexpected-docstring"]; + description = "Unexpected documentation comment."; + since = since 4 3 }; + { number = 51; + names = ["wrong-tailcall-expectation"]; + description = + "Function call annotated with an incorrect @tailcall attribute."; + since = since 4 3 }; + { number = 52; + names = ["fragile-literal-pattern"]; + description = "Fragile constant pattern."; + since = since 4 3 }; + { number = 53; + names = ["misplaced-attribute"]; + description = "Attribute cannot appear in this context."; + since = since 4 3 }; + { number = 54; + names = ["duplicated-attribute"]; + description = "Attribute used more than once on an expression."; + since = since 4 3 }; + { number = 55; + names = ["inlining-impossible"]; + description = "Inlining impossible."; + since = since 4 3 }; + { number = 56; + names = ["unreachable-case"]; + description = + "Unreachable case in a pattern-matching (based on type information)."; + since = since 4 3 }; + { number = 57; + names = ["ambiguous-var-in-pattern-guard"]; + description = "Ambiguous or-pattern variables under guard."; + since = since 4 3 }; + { number = 58; + names = ["no-cmx-file"]; + description = "Missing cmx file."; + since = since 4 3 }; + { number = 59; + names = ["flambda-assignment-to-non-mutable-value"]; + description = "Assignment to non-mutable value."; + since = since 4 3 }; + { number = 60; + names = ["unused-module"]; + description = "Unused module declaration."; + since = since 4 4 }; + { number = 61; + names = ["unboxable-type-in-prim-decl"]; + description = "Unboxable type in primitive declaration."; + since = since 4 4 }; + { number = 62; + names = ["constraint-on-gadt"]; + description = "Type constraint on GADT type declaration."; + since = since 4 6 }; + { number = 63; + names = ["erroneous-printed-signature"]; + description = "Erroneous printed signature."; + since = since 4 8 }; + { number = 64; + names = ["unsafe-array-syntax-without-parsing"]; + description = + "-unsafe used with a preprocessor returning a syntax tree."; + since = since 4 8 }; + { number = 65; + names = ["redefining-unit"]; + description = "Type declaration defining a new '()' constructor."; + since = since 4 8 }; + { number = 66; + names = ["unused-open-bang"]; + description = "Unused open! statement."; + since = since 4 8 }; + { number = 67; + names = ["unused-functor-parameter"]; + description = "Unused functor parameter."; + since = since 4 10 }; + { number = 68; + names = ["match-on-mutable-state-prevent-uncurry"]; + description = + "Pattern-matching depending on mutable state prevents the remaining \n\ + \ arguments from being uncurried."; + since = since 4 12 }; + { number = 69; + names = ["unused-field"]; + description = "Unused record field."; + since = since 4 13 }; + { number = 70; + names = ["missing-mli"]; + description = "Missing interface file."; + since = since 4 13 }; + { number = 71; + names = ["unused-tmc-attribute"]; + description = "Unused @tail_mod_cons attribute."; + since = since 4 14 }; + { number = 72; + names = ["tmc-breaks-tailcall"]; + description = "A tail call is turned into a non-tail call \ + by the @tail_mod_cons transformation."; + since = since 4 14 }; + { number = 73; + names = ["generative-application-expects-unit"]; + description = "A generative functor is applied to an empty structure \ + (struct end) rather than to ()."; + since = since 5 1 }; +] + +let name_to_number = + let h = Hashtbl.create last_warning_number in + List.iter (fun {number; names; _} -> + List.iter (fun name -> Hashtbl.add h name number) 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); + 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 with_state state f = + let prev = backup () in + restore state; + try + let r = f () in + restore prev; + r + with exn -> + restore prev; + raise exn + +let mk_lazy f = + let state = backup () in + lazy (with_state state f) + +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 ghost_loc_in_file name = + let pos = { Lexing.dummy_pos with pos_fname = name } in + { loc_start = pos; loc_end = pos; loc_ghost = true } + +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 nowhere = ghost_loc_in_file "_none_" 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 + "@[@[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" +let default_disabled_alerts = [ "unstable"; "unsynchronized_access" ] + +let () = ignore @@ parse_options false defaults_w +let () = ignore @@ parse_options true defaults_warn_error +let () = + List.iter (set_alert ~error:false ~enable:false) default_disabled_alerts + +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." + | Instance_variable_override (cname :: slist) -> + String.concat " " + ("the following instance variables are overridden by the class" + :: cname :: ":\n " :: slist) + | Instance_variable_override [] -> assert false + | Illegal_backslash -> + "illegal backslash escape in string.\n\ + Hint: Single backslashes \\ are reserved for escape sequences\n\ + (\\n, \\r, ...). Did you check the list of OCaml escape sequences?\n\ + To get a backslash character, escape it with a second backslash: \\\\." + | 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\n\ + (non-portable behavior before OCaml 5.2)" + | Duplicate_definitions (kind, cname, tc1, tc2) -> + Printf.sprintf "the %s %s is defined in both types %s and %s." + kind cname tc1 tc2 + | 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 -> + let[@manual.ref "ss:warn52"] ref_manual = [ 13; 5; 3 ] in + Format.asprintf + "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. %a" + Misc.print_see_manual ref_manual + | Unreachable_case -> + "this match case is unreachable.\n\ + Consider replacing it with a refutation case ' -> .'" + | 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[@manual.ref "ss:warn57"] ref_manual = [ 13; 5; 4 ] in + let vars = List.sort String.compare vars in + let vars_explanation = + let in_different_places = + "in different places in different or-pattern alternatives" + in + match vars with + | [] -> assert false + | [x] -> "variable " ^ x ^ " appears " ^ in_different_places + | _::_ -> + let vars = String.concat ", " vars in + "variables " ^ vars ^ " appear " ^ in_different_places + in + Format.asprintf + "Ambiguous or-pattern variables under guard;\n\ + %s.\n\ + Only the first match will be used to evaluate the guard expression.\n\ + %a" + vars_explanation Misc.print_see_manual ref_manual + | 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." + | Unused_tmc_attribute -> + "This function is marked @tail_mod_cons\n\ + but is never applied in TMC position." + | Tmc_breaks_tailcall -> + "This call\n\ + is in tail-modulo-cons position in a TMC function,\n\ + but the function called is not itself specialized for TMC,\n\ + so the call will not be transformed into a tail call.\n\ + Please either mark the called function with the [@tail_mod_cons]\n\ + attribute, or mark this call with the [@tailcall false] attribute\n\ + to make its non-tailness explicit." + | Generative_application_expects_unit -> + "A generative functor\n\ + should be applied to '()'; using '(struct end)' is deprecated." +;; + +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 {number; _} -> number = n) descriptions with + | Some {names = 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 pp_since out release_info = + Printf.fprintf out " (since %d.%0*d)" + release_info.Sys.major + (if release_info.Sys.major >= 5 then 0 else 2) + release_info.Sys.minor + +let help_warnings () = + List.iter + (fun {number; description; names; since} -> + let name = + match names with + | s :: _ -> " [" ^ s ^ "]" + | [] -> "" + in + Printf.printf "%3i%s %s%a\n" + number name description (fun out -> Option.iter (pp_since out)) since) + 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_502/utils/warnings.mli b/upstream/ocaml_502/utils/warnings.mli new file mode 100644 index 0000000000..f0a4b1c923 --- /dev/null +++ b/upstream/ocaml_502/utils/warnings.mli @@ -0,0 +1,170 @@ +(**************************************************************************) +(* *) +(* 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; +} + +val ghost_loc_in_file : string -> loc +(** Return an empty ghost range located in a given file *) + +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 + Note: since OCaml 5.2, the lexer normalizes \r\n sequences in + the source file to a single \n character, so the behavior of + newlines in string literals is portable. This warning is + never emitted anymore. *) + | Duplicate_definitions of string * string * string * string (* 30 *) + | 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 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) + | Generative_application_expects_unit (* 73 *) + +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 with_state : state -> (unit -> 'a) -> 'a +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. *) + +type description = + { number : int; + names : string list; + description : string; + since : Sys.ocaml_release_info option; } + +val descriptions : description list From 1c4064fbec9be35bb472858ea2681f9fa2f13e6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 5 Feb 2024 14:24:22 +0100 Subject: [PATCH 060/130] fix auto-patcher --- upstream/gen_patch.sh | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/upstream/gen_patch.sh b/upstream/gen_patch.sh index 04a78357c1..3fa724dfd9 100644 --- a/upstream/gen_patch.sh +++ b/upstream/gen_patch.sh @@ -2,8 +2,8 @@ D_MERLIN=../src/ocaml -FROM=500 -TO=501 +FROM=501 +TO=502 D_FROM=ocaml_${FROM} D_TO=ocaml_${TO} @@ -18,11 +18,12 @@ for file in "${D_TO}"/*/*.ml*; do F_PATCH=$(echo "${F_TO}" | sed "s/${D_TO}/${D_PATCH}/g") mkdir "$(dirname "${F_PATCH}")" 2>/dev/null | true # Make diff - RES=$(diff -u -N "${F_FROM}" "${F_TO}") - if [ -n "${RES}" ]; then - # Write the patch file if non-empty - echo "${RES}" > "${F_PATCH}.patch" + diff -u -N "${F_FROM}" "${F_TO}" >"${F_PATCH}.patch" + if [ -s "${F_PATCH}.patch" ]; then # Apply the patch file patch "${F_MERLIN}" "${F_PATCH}.patch" + echo "patched ${F_MERLIN}" + else + rm "${F_PATCH}.patch" fi done From 36ff3d4b573492a33dfc8b1a6957cbdde8e0a62e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 5 Feb 2024 16:38:30 +0100 Subject: [PATCH 061/130] typer: merge upstream changes into vendored typer --- src/ocaml/parsing/ast_helper.ml | 12 +- src/ocaml/parsing/ast_helper.mli | 10 +- src/ocaml/parsing/ast_iterator.ml | 59 +- src/ocaml/parsing/ast_iterator.mli | 3 + src/ocaml/parsing/ast_mapper.ml | 84 +- src/ocaml/parsing/ast_mapper.mli | 9 +- src/ocaml/parsing/attr_helper.ml | 11 +- src/ocaml/parsing/attr_helper.mli | 13 +- src/ocaml/parsing/builtin_attributes.ml | 273 +- src/ocaml/parsing/builtin_attributes.mli | 130 +- src/ocaml/parsing/lexer.ml | 3 + src/ocaml/parsing/location.ml | 97 +- src/ocaml/parsing/parsetree.mli | 102 +- src/ocaml/parsing/pprintast.ml | 300 +- src/ocaml/parsing/pprintast.mli | 11 +- src/ocaml/parsing/printast.ml | 47 +- src/ocaml/parsing/syntaxerr.ml | 9 +- src/ocaml/parsing/syntaxerr.mli | 9 +- src/ocaml/parsing/unit_info.ml | 119 + src/ocaml/parsing/unit_info.mli | 153 + src/ocaml/preprocess/lexer_raw.mll | 74 +- src/ocaml/preprocess/parser_explain.ml | 2 + src/ocaml/preprocess/parser_printer.ml | 32 +- src/ocaml/preprocess/parser_raw.ml | 14408 ++++++++-------- src/ocaml/preprocess/parser_raw.mli | 20 +- src/ocaml/preprocess/parser_raw.mly | 389 +- src/ocaml/preprocess/parser_recover.ml | 6101 +++---- src/ocaml/typing/btype.ml | 10 +- src/ocaml/typing/btype.mli | 6 +- src/ocaml/typing/cmi_format.ml | 7 +- src/ocaml/typing/cmt_format.ml | 310 +- src/ocaml/typing/cmt_format.mli | 11 +- src/ocaml/typing/ctype.ml | 867 +- src/ocaml/typing/ctype.mli | 33 +- src/ocaml/typing/datarepr.ml | 4 +- src/ocaml/typing/dune | 2 +- src/ocaml/typing/env.ml | 206 +- src/ocaml/typing/env.mli | 26 +- src/ocaml/typing/envaux.ml | 6 +- src/ocaml/typing/includeclass.ml | 12 +- src/ocaml/typing/includecore.ml | 91 +- src/ocaml/typing/includemod.ml | 14 +- src/ocaml/typing/includemod.mli | 8 +- src/ocaml/typing/includemod_errorprinter.ml | 98 +- src/ocaml/typing/lambda.ml | 9 + src/ocaml/typing/magic_numbers.ml | 6 +- src/ocaml/typing/msupport.ml | 2 +- src/ocaml/typing/mtype.ml | 6 +- src/ocaml/typing/oprint.ml | 99 +- src/ocaml/typing/outcometree.mli | 11 +- src/ocaml/typing/parmatch.ml | 81 +- src/ocaml/typing/parmatch.mli | 26 +- src/ocaml/typing/path.ml | 6 +- src/ocaml/typing/patterns.ml | 18 +- src/ocaml/typing/patterns.mli | 4 +- src/ocaml/typing/persistent_env.ml | 93 +- src/ocaml/typing/persistent_env.mli | 12 +- src/ocaml/typing/predef.ml | 6 +- src/ocaml/typing/primitive.ml | 42 +- src/ocaml/typing/primitive.mli | 2 +- src/ocaml/typing/printpat.ml | 38 +- src/ocaml/typing/printpat.mli | 8 +- src/ocaml/typing/printtyp.ml | 255 +- src/ocaml/typing/printtyped.ml | 63 +- src/ocaml/typing/shape.ml | 392 +- src/ocaml/typing/shape.mli | 97 +- src/ocaml/typing/shape_reduce.ml | 347 + src/ocaml/typing/shape_reduce.mli | 62 + src/ocaml/typing/subst.ml | 67 +- src/ocaml/typing/subst.mli | 5 - src/ocaml/typing/tast_iterator.ml | 82 +- src/ocaml/typing/tast_iterator.mli | 1 + src/ocaml/typing/tast_mapper.ml | 64 +- src/ocaml/typing/typeclass.ml | 134 +- src/ocaml/typing/typecore.ml | 2203 ++- src/ocaml/typing/typecore.mli | 18 +- src/ocaml/typing/typedecl.ml | 375 +- src/ocaml/typing/typedecl.mli | 8 +- src/ocaml/typing/typedecl_immediacy.ml | 5 +- src/ocaml/typing/typedecl_separability.ml | 2 +- src/ocaml/typing/typedecl_variance.ml | 19 +- src/ocaml/typing/typedtree.ml | 81 +- src/ocaml/typing/typedtree.mli | 123 +- src/ocaml/typing/typemod.ml | 431 +- src/ocaml/typing/typemod.mli | 12 +- src/ocaml/typing/typeopt.ml | 22 +- src/ocaml/typing/typeopt.mli | 4 +- src/ocaml/typing/types.ml | 7 +- src/ocaml/typing/types.mli | 7 +- src/ocaml/typing/typetexp.ml | 106 +- src/ocaml/typing/typetexp.mli | 7 +- src/ocaml/typing/untypeast.ml | 119 +- .../{rec_check.ml => value_rec_check.ml} | 295 +- .../{rec_check.mli => value_rec_check.mli} | 7 +- src/ocaml/typing/value_rec_types.mli | 42 + src/ocaml/utils/clflags.ml | 3 + src/ocaml/utils/clflags.mli | 3 + src/ocaml/utils/config.ml | 2 + src/ocaml/utils/config.mli | 2 + src/ocaml/utils/diffing.ml | 10 +- src/ocaml/utils/diffing.mli | 2 +- src/ocaml/utils/diffing_with_keys.ml | 2 +- src/ocaml/utils/load_path.ml | 165 +- src/ocaml/utils/load_path.mli | 50 +- src/ocaml/utils/warnings.mli | 6 +- src/utils/misc.ml | 343 +- src/utils/misc.mli | 72 +- src/utils/std.ml | 8 + 108 files changed, 17354 insertions(+), 13436 deletions(-) create mode 100644 src/ocaml/parsing/lexer.ml create mode 100644 src/ocaml/parsing/unit_info.ml create mode 100644 src/ocaml/parsing/unit_info.mli create mode 100644 src/ocaml/typing/lambda.ml create mode 100644 src/ocaml/typing/shape_reduce.ml create mode 100644 src/ocaml/typing/shape_reduce.mli rename src/ocaml/typing/{rec_check.ml => value_rec_check.ml} (84%) rename src/ocaml/typing/{rec_check.mli => value_rec_check.mli} (89%) create mode 100644 src/ocaml/typing/value_rec_types.mli diff --git a/src/ocaml/parsing/ast_helper.ml b/src/ocaml/parsing/ast_helper.ml index ce4c27234c..5e093022bc 100644 --- a/src/ocaml/parsing/ast_helper.ml +++ b/src/ocaml/parsing/ast_helper.ml @@ -77,6 +77,7 @@ module Typ = struct 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 open_ ?loc ?attrs mod_ident t = mk ?loc ?attrs (Ptyp_open (mod_ident, t)) let force_poly t = match t.ptyp_desc with @@ -107,9 +108,9 @@ module Typ = struct 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_alias(core_type, alias) -> + check_variable var_names alias.loc alias.txt; + Ptyp_alias(loop core_type, alias) | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) @@ -119,6 +120,8 @@ module Typ = struct Ptyp_poly(string_lst, loop core_type) | Ptyp_package(longident,lst) -> Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) + | Ptyp_open (mod_ident, core_type) -> + Ptyp_open (mod_ident, loop core_type) | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) in @@ -186,8 +189,7 @@ module Exp = struct 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 function_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_function (a, b, c)) 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)) diff --git a/src/ocaml/parsing/ast_helper.mli b/src/ocaml/parsing/ast_helper.mli index 8ac40ed7c2..70f59e5b97 100644 --- a/src/ocaml/parsing/ast_helper.mli +++ b/src/ocaml/parsing/ast_helper.mli @@ -81,12 +81,14 @@ module Typ : 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 alias: ?loc:loc -> ?attrs:attrs -> core_type -> string with_loc + -> 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 open_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type -> core_type val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type val force_poly: core_type -> core_type @@ -139,9 +141,9 @@ module Exp: 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 function_ : ?loc:loc -> ?attrs:attrs -> function_param list + -> type_constraint option -> function_body + -> expression val apply: ?loc:loc -> ?attrs:attrs -> expression -> (arg_label * expression) list -> expression val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list diff --git a/src/ocaml/parsing/ast_iterator.ml b/src/ocaml/parsing/ast_iterator.ml index 2398e772d1..94d5806fb3 100644 --- a/src/ocaml/parsing/ast_iterator.ml +++ b/src/ocaml/parsing/ast_iterator.ml @@ -40,6 +40,7 @@ type iterator = { class_type_declaration: iterator -> class_type_declaration -> unit; class_type_field: iterator -> class_type_field -> unit; constructor_declaration: iterator -> constructor_declaration -> unit; + directive_argument: iterator -> directive_argument -> unit; expr: iterator -> expression -> unit; extension: iterator -> extension -> unit; extension_constructor: iterator -> extension_constructor -> unit; @@ -61,6 +62,8 @@ type iterator = { signature_item: iterator -> signature_item -> unit; structure: iterator -> structure -> unit; structure_item: iterator -> structure_item -> unit; + toplevel_directive: iterator -> toplevel_directive -> unit; + toplevel_phrase: iterator -> toplevel_phrase -> unit; typ: iterator -> core_type -> unit; row_field: iterator -> row_field -> unit; object_field: iterator -> object_field -> unit; @@ -132,6 +135,9 @@ module T = struct | Ptyp_package (lid, l) -> iter_loc sub lid; List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l + | Ptyp_open (mod_ident, t) -> + iter_loc sub mod_ident; + sub.typ sub t | Ptyp_extension x -> sub.extension sub x let iter_type_declaration sub @@ -348,6 +354,32 @@ end module E = struct (* Value expressions for the core language *) + let iter_function_param sub { pparam_loc = loc; pparam_desc = desc } = + sub.location sub loc; + match desc with + | Pparam_val (_lab, def, p) -> + iter_opt (sub.expr sub) def; + sub.pat sub p + | Pparam_newtype ty -> + iter_loc sub ty + + let iter_body sub body = + match body with + | Pfunction_body e -> + sub.expr sub e + | Pfunction_cases (cases, loc, attrs) -> + sub.cases sub cases; + sub.location sub loc; + sub.attributes sub attrs + + let iter_constraint sub constraint_ = + match constraint_ with + | Pconstraint ty -> + sub.typ sub ty + | Pcoerce (ty1, ty2) -> + iter_opt (sub.typ sub) ty1; + sub.typ sub ty2 + let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = sub.location sub loc; sub.attributes sub attrs; @@ -357,11 +389,10 @@ module E = struct | 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_function (params, constraint_, body) -> + List.iter (iter_function_param sub) params; + iter_opt (iter_constraint sub) constraint_; + iter_body sub body | Pexp_apply (e, l) -> sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l | Pexp_match (e, pel) -> @@ -694,4 +725,22 @@ let default_iterator = | PTyp x -> this.typ this x | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g ); + + directive_argument = + (fun this a -> + this.location this a.pdira_loc + ); + + toplevel_directive = + (fun this d -> + iter_loc this d.pdir_name; + iter_opt (this.directive_argument this) d.pdir_arg; + this.location this d.pdir_loc + ); + + toplevel_phrase = + (fun this -> function + | Ptop_def s -> this.structure this s + | Ptop_dir d -> this.toplevel_directive this d + ); } diff --git a/src/ocaml/parsing/ast_iterator.mli b/src/ocaml/parsing/ast_iterator.mli index 638ac5e8b6..6b02889163 100644 --- a/src/ocaml/parsing/ast_iterator.mli +++ b/src/ocaml/parsing/ast_iterator.mli @@ -43,6 +43,7 @@ type iterator = { class_type_declaration: iterator -> class_type_declaration -> unit; class_type_field: iterator -> class_type_field -> unit; constructor_declaration: iterator -> constructor_declaration -> unit; + directive_argument: iterator -> directive_argument -> unit; expr: iterator -> expression -> unit; extension: iterator -> extension -> unit; extension_constructor: iterator -> extension_constructor -> unit; @@ -64,6 +65,8 @@ type iterator = { signature_item: iterator -> signature_item -> unit; structure: iterator -> structure -> unit; structure_item: iterator -> structure_item -> unit; + toplevel_directive: iterator -> toplevel_directive -> unit; + toplevel_phrase: iterator -> toplevel_phrase -> unit; typ: iterator -> core_type -> unit; row_field: iterator -> row_field -> unit; object_field: iterator -> object_field -> unit; diff --git a/src/ocaml/parsing/ast_mapper.ml b/src/ocaml/parsing/ast_mapper.ml index 12d9018880..e3997095a9 100644 --- a/src/ocaml/parsing/ast_mapper.ml +++ b/src/ocaml/parsing/ast_mapper.ml @@ -20,6 +20,9 @@ (* Ensure that record patterns don't miss any field. *) *) +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + open Parsetree open Ast_helper open Location @@ -45,6 +48,7 @@ type mapper = { constant: mapper -> constant -> constant; constructor_declaration: mapper -> constructor_declaration -> constructor_declaration; + directive_argument: mapper -> directive_argument -> directive_argument; expr: mapper -> expression -> expression; extension: mapper -> extension -> extension; extension_constructor: mapper -> extension_constructor @@ -68,6 +72,8 @@ type mapper = { signature_item: mapper -> signature_item -> signature_item; structure: mapper -> structure -> structure; structure_item: mapper -> structure_item -> structure_item; + toplevel_directive: mapper -> toplevel_directive -> toplevel_directive; + toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase; typ: mapper -> core_type -> core_type; type_declaration: mapper -> type_declaration -> type_declaration; type_extension: mapper -> type_extension -> type_extension; @@ -144,7 +150,9 @@ module T = struct 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_alias (t, s) -> + let s = map_loc sub s in + 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 @@ -152,6 +160,8 @@ module T = struct | Ptyp_package (lid, l) -> package ~loc ~attrs (map_loc sub lid) (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_open (mod_ident, t) -> + open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t) | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_type_declaration sub @@ -387,6 +397,35 @@ end module E = struct (* Value expressions for the core language *) + let map_function_param sub { pparam_loc = loc; pparam_desc = desc } = + let loc = sub.location sub loc in + let desc = + match desc with + | Pparam_val (lab, def, p) -> + Pparam_val + (lab, + map_opt (sub.expr sub) def, + sub.pat sub p) + | Pparam_newtype ty -> + Pparam_newtype (map_loc sub ty) + in + { pparam_loc = loc; pparam_desc = desc } + + let map_function_body sub body = + match body with + | Pfunction_body e -> + Pfunction_body (sub.expr sub e) + | Pfunction_cases (cases, loc, attributes) -> + let cases = sub.cases sub cases in + let loc = sub.location sub loc in + let attributes = sub.attributes sub attributes in + Pfunction_cases (cases, loc, attributes) + + let map_constraint sub c = + match c with + | Pconstraint ty -> Pconstraint (sub.typ sub ty) + | Pcoerce (ty1, ty2) -> Pcoerce (map_opt (sub.typ sub) ty1, sub.typ sub ty2) + let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = let open Exp in let loc = sub.location sub loc in @@ -397,10 +436,11 @@ module E = struct | 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_function (ps, c, b) -> + function_ ~loc ~attrs + (List.map (map_function_param sub) ps) + (map_opt (map_constraint sub) c) + (map_function_body sub b) | Pexp_apply (e, l) -> apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> @@ -767,6 +807,22 @@ let default_mapper = | PTyp x -> PTyp (this.typ this x) | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) ); + + directive_argument = + (fun this a -> + { pdira_desc= a.pdira_desc + ; pdira_loc= this.location this a.pdira_loc} ); + + toplevel_directive = + (fun this d -> + { pdir_name= map_loc this d.pdir_name + ; pdir_arg= map_opt (this.directive_argument this) d.pdir_arg + ; pdir_loc= this.location this d.pdir_loc } ); + + toplevel_phrase = + (fun this -> function + | Ptop_def s -> Ptop_def (this.structure this s) + | Ptop_dir d -> Ptop_dir (this.toplevel_directive this d) ); } let extension_of_error {kind; main; sub} = @@ -844,11 +900,16 @@ module PpxContext = struct } let make ~tool_name () = + let Load_path.{ visible; hidden } = Load_path.get_paths () in 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 "include_dirs", make_list make_string (!Clflags.include_dirs); + lid "hidden_include_dirs", + make_list make_string (!Clflags.hidden_include_dirs); + lid "load_path", + make_pair (make_list make_string) (make_list make_string) + (visible, hidden); 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; @@ -917,6 +978,8 @@ module PpxContext = struct tool_name_ref := get_string payload | "include_dirs" -> Clflags.include_dirs := get_list get_string payload + | "hidden_include_dirs" -> + Clflags.hidden_include_dirs := get_list get_string payload | "load_path" -> (* Duplicates Compmisc.auto_include, since we can't reference Compmisc from this module. *) @@ -927,8 +990,11 @@ module PpxContext = struct let alert = Location.auto_include_alert in Load_path.auto_include_otherlibs alert find_in_dir fn in *) - Load_path.(init - ~auto_include:no_auto_include (get_list get_string payload)) + let visible, hidden = + get_pair (get_list get_string) (get_list get_string) payload + in + let auto_include = Load_path.no_auto_include in + Load_path.init ~auto_include ~visible ~hidden | "open_modules" -> Clflags.open_modules := get_list get_string payload | "for_package" -> diff --git a/src/ocaml/parsing/ast_mapper.mli b/src/ocaml/parsing/ast_mapper.mli index 69f6b017ab..541c1f7dac 100644 --- a/src/ocaml/parsing/ast_mapper.mli +++ b/src/ocaml/parsing/ast_mapper.mli @@ -36,7 +36,7 @@ let test_mapper argv = expr = fun mapper expr -> match expr with | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) + Ast_helper.Exp.constant (Pconst_integer ("42", None)) | other -> default_mapper.expr mapper other; } let () = @@ -74,6 +74,7 @@ type mapper = { constant: mapper -> constant -> constant; constructor_declaration: mapper -> constructor_declaration -> constructor_declaration; + directive_argument: mapper -> directive_argument -> directive_argument; expr: mapper -> expression -> expression; extension: mapper -> extension -> extension; extension_constructor: mapper -> extension_constructor @@ -97,6 +98,8 @@ type mapper = { signature_item: mapper -> signature_item -> signature_item; structure: mapper -> structure -> structure; structure_item: mapper -> structure_item -> structure_item; + toplevel_directive: mapper -> toplevel_directive -> toplevel_directive; + toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase; typ: mapper -> core_type -> core_type; type_declaration: mapper -> type_declaration -> type_declaration; type_extension: mapper -> type_extension -> type_extension; @@ -122,8 +125,8 @@ val tool_name: unit -> string ["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}. *) + {!Clflags.hidden_include_dirs}, {!Load_path}, {!Clflags.open_modules}, + {!Clflags.for_package}, {!Clflags.debug}. *) val apply: source:string -> target:string -> mapper -> unit diff --git a/src/ocaml/parsing/attr_helper.ml b/src/ocaml/parsing/attr_helper.ml index 0a616cd746..390124199b 100644 --- a/src/ocaml/parsing/attr_helper.ml +++ b/src/ocaml/parsing/attr_helper.ml @@ -16,14 +16,17 @@ open Asttypes open Parsetree +module Style = Misc.Style + 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 +let get_no_payload_attribute nm attrs = + let actions = [(nm, Builtin_attributes.Return)] in + match Builtin_attributes.select_attributes actions attrs with | [] -> None | [ {attr_name = name; attr_payload = PStr []; attr_loc = _} ] -> Some name | [ {attr_name = name; _} ] -> @@ -40,9 +43,9 @@ open Format let report_error ppf = function | Multiple_attributes name -> - fprintf ppf "Too many `%s' attributes" name + fprintf ppf "Too many %a attributes" Style.inline_code name | No_payload_expected name -> - fprintf ppf "Attribute `%s' does not accept a payload" name + fprintf ppf "Attribute %a does not accept a payload" Style.inline_code name let () = Location.register_error_of_exn diff --git a/src/ocaml/parsing/attr_helper.mli b/src/ocaml/parsing/attr_helper.mli index a3ddc0c9cb..a94042a290 100644 --- a/src/ocaml/parsing/attr_helper.mli +++ b/src/ocaml/parsing/attr_helper.mli @@ -27,14 +27,11 @@ 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 +(** The [string] argument of the following functions is the name of the + attribute we are looking for. If the argument is ["foo"], these functions + will find attributes with the name ["foo"] or ["ocaml.foo"] *) +val get_no_payload_attribute : string -> attributes -> string loc option +val has_no_payload_attribute : string -> attributes -> bool exception Error of Location.t * error diff --git a/src/ocaml/parsing/builtin_attributes.ml b/src/ocaml/parsing/builtin_attributes.ml index 0db2133143..6add5ac375 100644 --- a/src/ocaml/parsing/builtin_attributes.ml +++ b/src/ocaml/parsing/builtin_attributes.ml @@ -15,6 +15,84 @@ open Asttypes open Parsetree +open Ast_helper + + +module Attribute_table = Hashtbl.Make (struct + type t = string with_loc + + let hash : t -> int = Hashtbl.hash + let equal : t -> t -> bool = (=) +end) +let unused_attrs = Attribute_table.create 128 +let mark_used t = Attribute_table.remove unused_attrs t + +(* [attr_order] is used to issue unused attribute warnings in the order the + attributes occur in the file rather than the random order of the hash table +*) +let attr_order a1 a2 = + match String.compare a1.loc.loc_start.pos_fname a2.loc.loc_start.pos_fname + with + | 0 -> Int.compare a1.loc.loc_start.pos_cnum a2.loc.loc_start.pos_cnum + | n -> n + +let warn_unused () = + let keys = List.of_seq (Attribute_table.to_seq_keys unused_attrs) in + let keys = List.sort attr_order keys in + List.iter (fun sloc -> + Location.prerr_warning sloc.loc (Warnings.Misplaced_attribute sloc.txt)) + keys + +(* These are the attributes that are tracked in the builtin_attrs table for + misplaced attribute warnings. *) +let builtin_attrs = + [ "alert" + ; "boxed" + ; "deprecated" + ; "deprecated_mutable" + ; "explicit_arity" + ; "immediate" + ; "immediate64" + ; "inline" + ; "inlined" + ; "noalloc" + ; "poll" + ; "ppwarning" + ; "specialise" + ; "specialised" + ; "tailcall" + ; "tail_mod_cons" + ; "unboxed" + ; "untagged" + ; "unrolled" + ; "warnerror" + ; "warning" + ; "warn_on_literal_pattern" + ] + +let builtin_attrs = + let tbl = Hashtbl.create 128 in + List.iter (fun attr -> Hashtbl.add tbl attr ()) builtin_attrs; + tbl + +let drop_ocaml_attr_prefix s = + let len = String.length s in + if String.starts_with ~prefix:"ocaml." s && len > 6 then + String.sub s 6 (len - 6) + else + s + +let is_builtin_attr s = Hashtbl.mem builtin_attrs (drop_ocaml_attr_prefix s) + +type current_phase = Parser | Invariant_check + +let register_attr current_phase name = + match current_phase with + | Parser when !Clflags.all_ppx <> [] -> () + | Parser | Invariant_check -> + if is_builtin_attr name.txt then + Attribute_table.replace unused_attrs name () + let string_of_cst = function | Pconst_string(s, _, _) -> Some s @@ -67,6 +145,41 @@ let error_of_extension ext = | ({txt; loc}, _) -> Location.errorf ~loc "Uninterpreted extension '%s'." txt +let attr_equals_builtin {attr_name = {txt; _}; _} s = + (* Check for attribute s or ocaml.s. Avoid allocating a fresh string. *) + txt = s || + ( String.length txt = 6 + String.length s + && String.starts_with ~prefix:"ocaml." txt + && String.ends_with ~suffix:s txt) + +let mark_alert_used a = + if attr_equals_builtin a "deprecated" || attr_equals_builtin a "alert" + then mark_used a.attr_name + +let mark_alerts_used l = List.iter mark_alert_used l + +let mark_warn_on_literal_pattern_used l = + List.iter (fun a -> + if attr_equals_builtin a "warn_on_literal_pattern" + then mark_used a.attr_name) + l + +let mark_deprecated_mutable_used l = + List.iter (fun a -> + if attr_equals_builtin a "deprecated_mutable" + then mark_used a.attr_name) + l + +let mark_payload_attrs_used payload = + let iter = + { Ast_iterator.default_iterator + with attribute = fun self a -> + mark_used a.attr_name; + Ast_iterator.default_iterator.attribute self a + } + in + iter.payload iter payload + let kind_and_message = function | PStr[ {pstr_desc= @@ -87,15 +200,14 @@ 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 + if attr_equals_builtin x "deprecated" then + Some (x, "deprecated", string_of_opt_payload x.attr_payload) + else if attr_equals_builtin x "alert" then + 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 + else None let alert_attrs l = List.filter_map alert_attr l @@ -128,9 +240,8 @@ let check_alerts_inclusion ~def ~use loc attrs1 attrs2 s = 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) + | attr :: _ when attr_equals_builtin attr "deprecated_mutable" -> + Some (string_of_opt_payload attr.attr_payload) | _ :: tl -> deprecated_mutable_of_attrs tl let check_deprecated_mutable loc attrs s = @@ -164,73 +275,67 @@ let rec attrs_of_str = function 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 = + let process loc name errflag payload = + mark_used name; 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 + with Arg.Bad msg -> warn_payload loc name.txt msg end | None -> - warn_payload loc txt "A single string literal is expected" + warn_payload loc name.txt "A single string literal is expected" in - let process_alert loc txt = function + let process_alert loc name = 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 + begin + mark_used name; + try Warnings.parse_alert_option s + with Arg.Bad msg -> warn_payload loc name.txt msg end | k -> + (* Don't [mark_used] in the [Some] cases - that happens in [Env] or + [type_mod] if they are in a valid place. Do [mark_used] in the + [None] case, which is just malformed and covered by the "Invalid + payload" warning. *) match kind_and_message k with | Some ("all", _) -> - warn_payload loc txt "The alert name 'all' is reserved" + warn_payload loc name.txt "The alert name 'all' is reserved" | Some _ -> () - | None -> warn_payload loc txt "Invalid payload" + | None -> begin + mark_used name; + warn_payload loc name.txt "Invalid payload" + end 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 - | _ -> - () + fun ({attr_name; attr_loc; attr_payload} as attr) -> + if attr_equals_builtin attr "warning" then + process attr_loc attr_name false attr_payload + else if attr_equals_builtin attr "warnerror" then + process attr_loc attr_name true attr_payload + else if attr_equals_builtin attr "alert" then + process_alert attr_loc attr_name attr_payload + else if ppwarning && attr_equals_builtin attr "ppwarning" then + begin match attr_payload with + | PStr [{ pstr_desc= + Pstr_eval({pexp_desc=Pexp_constant + (Pconst_string (s, _, _))},_); + pstr_loc }] -> + (mark_used attr_name; + Location.prerr_warning pstr_loc (Warnings.Preprocessor s)) + | _ -> + (mark_used attr_name; + warn_payload attr_loc attr_name.txt + "A single string literal is expected") + end let warning_scope ?ppwarning attrs f = let prev = Warnings.backup () in @@ -244,33 +349,34 @@ let warning_scope ?ppwarning attrs f = raise exn -let warn_on_literal_pattern = +let has_attribute nm attrs = List.exists - (fun a -> match a.attr_name.txt with - | "ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern" -> true - | _ -> false - ) + (fun a -> + if attr_equals_builtin a nm + then (mark_used a.attr_name; true) + else false) + attrs -let explicit_arity = - List.exists - (fun a -> match a.attr_name.txt with - | "ocaml.explicit_arity"|"explicit_arity" -> true - | _ -> false - ) +type attr_action = Mark_used_only | Return +let select_attributes actions attrs = + List.filter (fun a -> + List.exists (fun (nm, action) -> + attr_equals_builtin a nm && + begin + mark_used a.attr_name; + action = Return + end) + actions + ) attrs -let immediate = - List.exists - (fun a -> match a.attr_name.txt with - | "ocaml.immediate"|"immediate" -> true - | _ -> false - ) +let warn_on_literal_pattern attrs = + has_attribute "warn_on_literal_pattern" attrs -let immediate64 = - List.exists - (fun a -> match a.attr_name.txt with - | "ocaml.immediate64"|"immediate64" -> true - | _ -> false - ) +let explicit_arity attrs = has_attribute "explicit_arity" attrs + +let immediate attrs = has_attribute "immediate" attrs + +let immediate64 attrs = has_attribute "immediate64" attrs (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" attributes cannot be input by the user, they are added by the @@ -279,11 +385,6 @@ let immediate64 = 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_unboxed attrs = has_attribute "unboxed" attrs -let has_boxed attr = - List.exists (check ["ocaml.boxed"; "boxed"]) attr +let has_boxed attrs = has_attribute "boxed" attrs diff --git a/src/ocaml/parsing/builtin_attributes.mli b/src/ocaml/parsing/builtin_attributes.mli index 6200fd74ec..4eb5ef91f2 100644 --- a/src/ocaml/parsing/builtin_attributes.mli +++ b/src/ocaml/parsing/builtin_attributes.mli @@ -13,26 +13,103 @@ (* *) (**************************************************************************) -(** Support for some of the builtin attributes +(** Support for 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.boxed + - ocaml.deprecated - ocaml.deprecated_mutable + - ocaml.explicit_arity - ocaml.immediate - ocaml.immediate64 - - ocaml.boxed / ocaml.unboxed + - ocaml.inline + - ocaml.inlined + - ocaml.noalloc + - ocaml.poll + - ocaml.ppwarning + - ocaml.specialise + - ocaml.specialised + - ocaml.tailcall + - ocaml.tail_mod_cons + - ocaml.unboxed + - ocaml.untagged + - ocaml.unrolled + - ocaml.warnerror + - ocaml.warning + - ocaml.warn_on_literal_pattern {b Warning:} this module is unstable and part of {{!Compiler_libs}compiler-libs}. *) +(** {2 Attribute tracking for warning 53} *) + +(** [register_attr] must be called on the locations of all attributes that + should be tracked for the purpose of misplaced attribute warnings. In + particular, it should be called on all attributes that are present in the + source program except those that are contained in the payload of another + attribute (because these may be left behind by a ppx and intentionally + ignored by the compiler). + + The [current_phase] argument indicates when this function is being called + - either when an attribute is created in the parser or when we see an + attribute while running the check in the [Ast_invariants] module. This is + used to ensure that we track only attributes from the final version of the + parse tree: we skip adding attributes seen at parse time if we can see that + a ppx will be run later, because the [Ast_invariants] check is always run on + the result of a ppx. + + Note that the [Ast_invariants] check is also run on parse trees created from + marshalled ast files if no ppx is being used, ensuring we don't miss + attributes in that case. +*) +type current_phase = Parser | Invariant_check +val register_attr : current_phase -> string Location.loc -> unit + +(** Marks the attributes hiding in the payload of another attribute used, for + the purposes of misplaced attribute warnings (see comment on + [current_phase] above). In the parser, it's simplest to add these to + the table and remove them later, rather than threading through state + tracking whether we're in an attribute payload. *) +val mark_payload_attrs_used : Parsetree.payload -> unit + +(** Issue misplaced attribute warnings for all attributes created with + [mk_internal] but not yet marked used. *) +val warn_unused : unit -> unit + +(** {3 Warning 53 helpers for environment attributes} + + Some attributes, like deprecation markers, do not affect the compilation of + the definition on which they appear, but rather result in warnings on future + uses of that definition. This is implemented by moving the raw attributes + into the environment, where they will be noticed on future accesses. + + To make misplaced attribute warnings work appropriately for these + attributes, we mark them "used" when they are moved into the environment. + This is done with the helper functions in this section. +*) + +(** Marks the attribute used for the purposes of misplaced attribute warnings if + it is an alert. Call this when moving things allowed to have alert + attributes into the environment. *) +val mark_alert_used : Parsetree.attribute -> unit + +(** The same as [List.iter mark_alert_used]. *) +val mark_alerts_used : Parsetree.attributes -> unit + +(** Marks "warn_on_literal_pattern" attributes used for the purposes of + misplaced attribute warnings. Call this when moving constructors into the + environment. *) +val mark_warn_on_literal_pattern_used : Parsetree.attributes -> unit + +(** Marks "deprecated_mutable" attributes used for the purposes of misplaced + attribute warnings. Call this when moving labels of mutable fields into the + environment. *) +val mark_deprecated_mutable_used : Parsetree.attributes -> unit + +(** {2 Helpers for alert and warning attributes} *) + val check_alerts: Location.t -> Parsetree.attributes -> string -> unit val check_alerts_inclusion: def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> @@ -47,14 +124,12 @@ 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. + "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix) are + processed and marked used for warning 53. Other attributes are ignored. Also implement ocaml.ppwarning (unless ~ppwarning:false is passed). @@ -73,10 +148,37 @@ val warning_scope: is executed. *) +(** {2 Helpers for searching for particular attributes} *) + +(** [has_attribute name attrs] is true if an attribute with name [name] or + ["ocaml." ^ name] is present in [attrs]. It marks that attribute used for + the purposes of misplaced attribute warnings. *) +val has_attribute : string -> Parsetree.attributes -> bool + +(** [select_attributes actions attrs] finds the elements of [attrs] that appear + in [actions] and either returns them or just marks them used, according to + the corresponding [attr_action]. + + Each element [(nm, action)] of the [actions] list is an attribute along with + an [attr_action] specifying what to do with that attribute. The action is + used to accommodate different compiler configurations. If an attribute is + used only in some compiler configurations, it's important that we still look + for it and mark it used when compiling with other configurations. + Otherwise, we would issue spurious misplaced attribute warnings. *) +type attr_action = Mark_used_only | Return +val select_attributes : + (string * attr_action) list -> Parsetree.attributes -> Parsetree.attributes + +(** [attr_equals_builtin attr s] is true if the name of the attribute is [s] or + ["ocaml." ^ s]. This is useful for manually inspecting attribute names, but + note that doing so will not result in marking the attribute used for the + purpose of warning 53, so it is usually preferrable to use [has_attribute] + or [select_attributes]. *) +val attr_equals_builtin : Parsetree.attribute -> string -> bool + val warn_on_literal_pattern: Parsetree.attributes -> bool val explicit_arity: Parsetree.attributes -> bool - val immediate: Parsetree.attributes -> bool val immediate64: Parsetree.attributes -> bool diff --git a/src/ocaml/parsing/lexer.ml b/src/ocaml/parsing/lexer.ml new file mode 100644 index 0000000000..3ebda68eb7 --- /dev/null +++ b/src/ocaml/parsing/lexer.ml @@ -0,0 +1,3 @@ +(* This forward reference is filled in Lexer_raw.mll *) +let is_keyword_ref : (string -> bool) ref = ref (fun _ -> false) +let is_keyword txt = !is_keyword_ref txt diff --git a/src/ocaml/parsing/location.ml b/src/ocaml/parsing/location.ml index 1b8b5f1552..781a2e846b 100644 --- a/src/ocaml/parsing/location.ml +++ b/src/ocaml/parsing/location.ml @@ -150,6 +150,11 @@ let print_updating_num_loc_lines ppf f arg = pp_print_flush ppf (); pp_set_formatter_out_functions ppf out_functions +(* +let setup_tags () = + Misc.Style.setup !Clflags.color +*) + (******************************************************************************) (* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *) @@ -219,6 +224,7 @@ let print_filename ppf file = location might be invalid; in which case we do not print it. *) let print_loc ppf loc = + (* setup_tags (); *) let file_valid = function | "_none_" -> (* This is a dummy placeholder, but we print it anyway to please editors @@ -548,7 +554,7 @@ let lines_around *) (* -(* Try to get lines from a lexbuf *) +(* Attempt to get lines from the lexing buffer. *) let lines_around_from_lexbuf ~(start_pos: position) ~(end_pos: position) (lb: lexbuf): @@ -592,56 +598,17 @@ let lines_around_from_phrasebuf 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 *) + input. *) 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 + match !input_lexbuf, !input_phrase_buffer, !input_name with + | _, Some pb, "//toplevel//" -> + lines_around_from_phrasebuf pb ~start_pos ~end_pos + | Some lb, _, _ -> + lines_around_from_lexbuf lb ~start_pos ~end_pos + | None, _, _ -> [] - 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 () *) (******************************************************************************) @@ -760,6 +727,7 @@ let batch_mode_printer : report_printer = in let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in let pp self ppf report = + (* setup_tags (); *) separate_new_message ppf; (* Make sure we keep [num_loc_lines] updated. The tabulation box is here to give submessage the option @@ -814,7 +782,7 @@ let batch_mode_printer : report_printer = (* let terminfo_toplevel_printer (lb: lexbuf): report_printer = let pp self ppf err = - setup_colors (); + setup_tags (); (* 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. *) @@ -939,13 +907,21 @@ let deprecated ?def ?use loc message = alert ?def ?use ~kind:"deprecated" loc message +module Style = Misc.Style + let auto_include_alert lib = - let message = Printf.sprintf "\ - OCaml's lib directory layout changed in 5.0. The %s subdirectory has been \ - automatically added to the search path, but you should add -I +%s to the \ - command-line to silence this alert (e.g. by adding %s to the list of \ - libraries in your dune file, or adding use_%s to your _tags file for \ - ocamlbuild, or using -package %s for ocamlfind)." lib lib lib lib lib in + let message = Format.asprintf "\ + OCaml's lib directory layout changed in 5.0. The %a subdirectory has been \ + automatically added to the search path, but you should add %a to the \ + command-line to silence this alert (e.g. by adding %a to the list of \ + libraries in your dune file, or adding %a to your %a file for \ + ocamlbuild, or using %a for ocamlfind)." + Style.inline_code lib + Style.inline_code ("-I +" ^lib) + Style.inline_code lib + Style.inline_code ("use_"^lib) + Style.inline_code "_tags" + Style.inline_code ("-package " ^ lib) in let alert = {Warnings.kind="ocaml_deprecated_auto_include"; use=none; def=none; message = Format.asprintf "@[@\n%a@]" Format.pp_print_text message} @@ -953,11 +929,14 @@ let auto_include_alert lib = prerr_alert none alert let deprecated_script_alert program = - let message = Printf.sprintf "\ - Running %s where the first argument is an implicit basename with no \ - extension (e.g. %s script-file) is deprecated. Either rename the script \ - (%s script-file.ml) or qualify the basename (%s ./script-file)" - program program program program + let message = Format.asprintf "\ + Running %a where the first argument is an implicit basename with no \ + extension (e.g. %a) is deprecated. Either rename the script \ + (%a) or qualify the basename (%a)" + Style.inline_code program + Style.inline_code (program ^ " script-file") + Style.inline_code (program ^ " script-file.ml") + Style.inline_code (program ^ " ./script-file") in let alert = {Warnings.kind="ocaml_deprecated_cli"; use=none; def=none; diff --git a/src/ocaml/parsing/parsetree.mli b/src/ocaml/parsing/parsetree.mli index 7bb13135e7..2f0a40c26c 100644 --- a/src/ocaml/parsing/parsetree.mli +++ b/src/ocaml/parsing/parsetree.mli @@ -121,7 +121,7 @@ and core_type_desc = - [T #tconstr] when [l=[T]], - [(T1, ..., Tn) #tconstr] when [l=[T1 ; ... ; Tn]]. *) - | Ptyp_alias of core_type * string (** [T as 'a]. *) + | Ptyp_alias of core_type * string loc (** [T as 'a]. *) | Ptyp_variant of row_field list * closed_flag * label list option (** [Ptyp_variant([`A;`B], flag, labels)] represents: - [[ `A|`B ]] @@ -166,6 +166,7 @@ and core_type_desc = {!value_description}. *) | Ptyp_package of package_type (** [(module S)]. *) + | Ptyp_open of Longident.t loc * core_type (** [M.(T)] *) | Ptyp_extension of extension (** [[%id]]. *) and package_type = Longident.t loc * (Longident.t loc * core_type) list @@ -296,30 +297,21 @@ and expression_desc = - [let rec P1 = E1 and ... and Pn = EN in E] when [flag] is {{!Asttypes.rec_flag.Recursive}[Recursive]}. *) - | Pexp_function of case list (** [function P1 -> E1 | ... | Pn -> En] *) - | Pexp_fun of arg_label * expression option * pattern * expression - (** [Pexp_fun(lbl, exp0, P, E1)] represents: - - [fun P -> E1] - when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} - and [exp0] is [None] - - [fun ~l:P -> E1] - when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} - and [exp0] is [None] - - [fun ?l:P -> E1] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [None] - - [fun ?l:(P = E0) -> E1] - when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} - and [exp0] is [Some E0] - - Notes: - - If [E0] is provided, only - {{!Asttypes.arg_label.Optional}[Optional]} is allowed. - - [fun P1 P2 .. Pn -> E1] is represented as nested - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - - [let f P = E] is represented using - {{!expression_desc.Pexp_fun}[Pexp_fun]}. - *) + | Pexp_function of + function_param list * type_constraint option * function_body + (** [Pexp_function ([P1; ...; Pn], C, body)] represents any construct + involving [fun] or [function], including: + - [fun P1 ... Pn -> E] + when [body = Pfunction_body E] + - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em] + when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]] + + [C] represents a type constraint or coercion placed immediately before the + arrow, e.g. [fun P1 ... Pn : ty -> ...] when [C = Some (Pconstraint ty)]. + + A function must have parameters. [Pexp_function (params, _, body)] must + have non-empty [params] or a [Pfunction_cases _] body. + *) | Pexp_apply of expression * (arg_label * expression) list (** [Pexp_apply(E0, [(l1, E1) ; ... ; (ln, En)])] represents [E0 ~l1:E1 ... ~ln:En] @@ -440,6 +432,66 @@ and binding_op = pbop_loc : Location.t; } +and function_param_desc = + | Pparam_val of arg_label * expression option * pattern + (** [Pparam_val (lbl, exp0, P)] represents the parameter: + - [P] + when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]} + and [exp0] is [None] + - [~l:P] + when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]} + and [exp0] is [None] + - [?l:P] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [None] + - [?l:(P = E0)] + when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]} + and [exp0] is [Some E0] + + Note: If [E0] is provided, only + {{!Asttypes.arg_label.Optional}[Optional]} is allowed. + *) + | Pparam_newtype of string loc + (** [Pparam_newtype x] represents the parameter [(type x)]. + [x] carries the location of the identifier, whereas the [pparam_loc] + on the enclosing [function_param] node is the location of the [(type x)] + as a whole. + + Multiple parameters [(type a b c)] are represented as multiple + [Pparam_newtype] nodes, let's say: + + {[ [ { pparam_kind = Pparam_newtype a; pparam_loc = loc1 }; + { pparam_kind = Pparam_newtype b; pparam_loc = loc2 }; + { pparam_kind = Pparam_newtype c; pparam_loc = loc3 }; + ] + ]} + + Here, the first loc [loc1] is the location of [(type a b c)], and the + subsequent locs [loc2] and [loc3] are the same as [loc1], except marked as + ghost locations. The locations on [a], [b], [c], correspond to the + variables [a], [b], and [c] in the source code. + *) + +and function_param = + { pparam_loc : Location.t; + pparam_desc : function_param_desc; + } + +and function_body = + | Pfunction_body of expression + | Pfunction_cases of case list * Location.t * attributes + (** In [Pfunction_cases (_, loc, attrs)], the location extends from the + start of the [function] keyword to the end of the last case. The compiler + will only use typechecking-related attributes from [attrs], e.g. enabling + or disabling a warning. + *) +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + +and type_constraint = + | Pconstraint of core_type + | Pcoerce of core_type option * core_type +(** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *) + (** {2 Value descriptions} *) and value_description = diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml index ce6fc4f5b3..f8c866d1de 100644 --- a/src/ocaml/parsing/pprintast.ml +++ b/src/ocaml/parsing/pprintast.ml @@ -94,16 +94,19 @@ let needs_parens txt = 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 = +(* Turn an arbitrary variable name into a valid OCaml identifier by adding \# + in case it is a keyword, or parenthesis when it is an infix or prefix + operator. *) +let ident_of_name ppf txt = let format : (_, _, _) format = - if not (needs_parens txt) then "%s" + if Lexer.is_keyword txt then "\\#%s" + else if not (needs_parens txt) then "%s" else if needs_spaces txt then "(@;%s@;)" else "(%s)" in fprintf ppf format txt +let ident_of_name_loc ppf s = ident_of_name ppf s.txt + let protect_longident ppf print_longident longprefix txt = let format : (_, _, _) format = if not (needs_parens txt) then "%a.%s" @@ -133,11 +136,15 @@ type construct = | `nil | `normal | `simple of Longident.t - | `tuple ] + | `tuple + | `btrue + | `bfalse ] let view_expr x = match x.pexp_desc with | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple + | Pexp_construct ( {txt= Lident "true"; _},_) -> `btrue + | Pexp_construct ( {txt= Lident "false"; _},_) -> `bfalse | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil | Pexp_construct ( {txt= Lident"::";_},Some _) -> let rec loop exp acc = match exp with @@ -160,7 +167,7 @@ let view_expr x = | _ -> `normal let is_simple_construct :construct -> bool = function - | `nil | `tuple | `list _ | `simple _ -> true + | `nil | `tuple | `list _ | `simple _ | `btrue | `bfalse -> true | `cons _ | `normal -> false let pp = fprintf @@ -169,12 +176,14 @@ type ctxt = { pipe : bool; semi : bool; ifthenelse : bool; + functionrhs : bool; } -let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } +let reset_ctxt = { pipe=false; semi=false; ifthenelse=false; functionrhs=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 under_functionrhs ctxt = { ctxt with functionrhs = true } (* let reset_semi ctxt = { ctxt with semi=false } let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } @@ -216,7 +225,7 @@ let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> else fu f x let rec longident f = function - | Lident s -> protect_ident f s + | Lident s -> ident_of_name f s | Ldot(y,s) -> protect_longident f longident y s | Lapply (y,s) -> pp f "%a(%a)" longident y longident s @@ -267,16 +276,23 @@ let iter_loc f ctxt {txt; loc = _} = f ctxt txt let constant_string f s = pp f "%S" s -let tyvar ppf s = +let tyvar_of_name 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 + "' " ^ s + else if Lexer.is_keyword s then + "'\\#" ^ s + else if String.equal s "_" then + s else - Format.fprintf ppf "'%s" s + "'" ^ s + +let tyvar ppf s = + Format.fprintf ppf "%s" (tyvar_of_name s) let tyvar_loc f str = tyvar f str.txt -let string_quot f x = pp f "`%s" x +let string_quot f x = pp f "`%a" ident_of_name x (* c ['a,'b] *) let rec class_params_def ctxt f = function @@ -288,8 +304,8 @@ let rec class_params_def ctxt f = function 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 + | Labelled s -> pp f "%a:%a" ident_of_name s (core_type1 ctxt) c + | Optional s -> pp f "?%a:%a" ident_of_name s (core_type1 ctxt) c and core_type ctxt f x = if x.ptyp_attributes <> [] then begin @@ -301,7 +317,7 @@ and core_type ctxt f x = 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 + pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s.txt | Ptyp_poly ([], ct) -> core_type ctxt f ct | Ptyp_poly (sl, ct) -> @@ -362,7 +378,7 @@ and core_type1 ctxt f x = let core_field_type f x = match x.pof_desc with | Otag (l, ct) -> (* Cf #7200 *) - pp f "@[%s: %a@ %a@ @]" l.txt + pp f "@[%a: %a@ %a@ @]" ident_of_name l.txt (core_type ctxt) ct (attributes ctxt) x.pof_attributes | Oinherit ct -> pp f "@[%a@ @]" (core_type ctxt) ct @@ -401,7 +417,7 @@ and pattern ctxt f x = end else match x.ppat_desc with | Ppat_alias (p, s) -> - pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p ident_of_name s.txt | _ -> pattern_or ctxt f x and pattern_or ctxt f x = @@ -431,8 +447,8 @@ and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = 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("()"|"[]");_}), _) -> + pp f "@[<2>`%a@;%a@]" ident_of_name l (simple_pattern ctxt) p + | Ppat_construct (({txt=Lident("()"|"[]"|"true"|"false");_}), _) -> simple_pattern ctxt f x | Ppat_construct (({txt;_} as li), po) -> (* FIXME The third field always false *) @@ -444,7 +460,7 @@ and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = 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 + (list ~sep:"@ " ident_of_name_loc) vl (simple_pattern ctxt) x | None -> pp f "%a" longident_loc li) | _ -> simple_pattern ctxt f x @@ -452,10 +468,10 @@ and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = 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) -> + | Ppat_construct (({txt=Lident ("()"|"[]"|"true"|"false" as x);_}), None) -> pp f "%s" x | Ppat_any -> pp f "_"; - | Ppat_var ({txt = txt;_}) -> protect_ident f txt + | Ppat_var ({txt = txt;_}) -> ident_of_name f txt | Ppat_array l -> pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l | Ppat_unpack { txt = None } -> @@ -485,7 +501,7 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = 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_variant (l,None) -> pp f "`%a" ident_of_name l | Ppat_constraint (p, ct) -> pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct | Ppat_lazy p -> @@ -497,7 +513,8 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = let with_paren = match p.ppat_desc with | Ppat_array _ | Ppat_record _ - | Ppat_construct (({txt=Lident ("()"|"[]");_}), None) -> false + | Ppat_construct (({txt=Lident ("()"|"[]"|"true"|"false");_}), None) -> + false | _ -> true in pp f "@[<2>%a.%a @]" longident_loc lid (paren with_paren @@ pattern1 ctxt) p @@ -513,20 +530,21 @@ and label_exp ctxt f (l,opt,p) = | {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) + | Some o -> + pp f "?(%a=@;%a)@;" ident_of_name rest (expression ctxt) o + | None -> pp f "?%a@ " ident_of_name 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) + pp f "?%a:(%a=@;%a)@;" + ident_of_name rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%a:%a@;" ident_of_name 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 + pp f "~%a@;" ident_of_name l + | _ -> pp f "~%a:%a@;" ident_of_name l (simple_pattern ctxt) p and sugar_expr ctxt f e = if e.pexp_attributes <> [] then false @@ -604,18 +622,41 @@ and sugar_expr ctxt f e = 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 function_param ctxt f param = + match param.pparam_desc with + | Pparam_val (a, b, c) -> label_exp ctxt f (a, b, c) + | Pparam_newtype ty -> pp f "(type %s)@;" ty.txt + +and function_body ctxt f function_body = + match function_body with + | Pfunction_body body -> expression ctxt f body + | Pfunction_cases (cases, _, attrs) -> + pp f "@[function%a%a@]" + (item_attributes ctxt) attrs + (case_list ctxt) cases + +and type_constraint ctxt f constraint_ = + match constraint_ with + | Pconstraint ty -> + pp f ":@;%a" (core_type ctxt) ty + | Pcoerce (ty1, ty2) -> + pp f "%a:>@;%a" + (option ~first:":@;" (core_type ctxt)) ty1 + (core_type ctxt) ty2 + +and function_params_then_body ctxt f params constraint_ body ~delimiter = + pp f "%a%a%s@;%a" + (list (function_param ctxt) ~sep:"") params + (option (type_constraint ctxt)) constraint_ + delimiter + (function_body (under_functionrhs ctxt)) body 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_function _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ | Pexp_newtype _ when ctxt.pipe || ctxt.semi -> paren true (expression reset_ctxt) f x @@ -625,16 +666,34 @@ and expression ctxt f x = | 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 + pp f "@[<2>fun@;(type@;%a)@;->@;%a@]" ident_of_name lid.txt (expression ctxt) e - | Pexp_function l -> - pp f "@[function%a@]" (case_list ctxt) l + | Pexp_function (params, c, body) -> + begin match params, c with + (* Omit [fun] if there are no params. *) + | [], None -> + (* If function cases are a direct body of a function, + the function node should be wrapped in parens so + it doesn't become part of the enclosing function. *) + let should_paren = + match body with + | Pfunction_cases _ -> ctxt.functionrhs + | Pfunction_body _ -> false + in + let ctxt' = if should_paren then reset_ctxt else ctxt in + pp f "@[<2>%a@]" (paren should_paren (function_body ctxt')) body + | [], Some c -> + pp f "@[<2>(%a@;%a)@]" + (function_body ctxt) body + (type_constraint ctxt) c + | _ :: _, _ -> + pp f "@[<2>fun@;%a@]" + (fun f () -> + function_params_then_body ctxt f params c body ~delimiter:"->") + (); + + end | Pexp_match (e, l) -> pp f "@[@[@[<2>match %a@]@ with@]%a@]" (expression reset_ctxt) e (case_list ctxt) l @@ -722,10 +781,10 @@ and expression ctxt f x = | Pexp_new (li) -> pp f "@[new@ %a@]" longident_loc li; | Pexp_setinstvar (s, e) -> - pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e + pp f "@[%a@ <-@ %a@]" ident_of_name s.txt (expression ctxt) e | Pexp_override l -> (* FIXME *) let string_x_expression f (s, e) = - pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in + pp f "@[%a@ =@ %a@]" ident_of_name s.txt (expression ctxt) e in pp f "@[{<%a>}@]" (list string_x_expression ~sep:";" ) l; | Pexp_letmodule (s, me, e) -> @@ -752,7 +811,7 @@ and expression ctxt f x = (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 + pp f "@[<2>`%a@;%a@]" ident_of_name l (simple_expr ctxt) eo | Pexp_letop {let_; ands; body} -> pp f "@[<2>@[%a@,%a@] in@;<1 -2>%a@]" (binding_op ctxt) let_ @@ -776,7 +835,8 @@ and expression2 ctxt f x = else match x.pexp_desc with | Pexp_field (e, li) -> pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li - | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt + | Pexp_send (e, s) -> + pp f "@[%a#%a@]" (simple_expr ctxt) e ident_of_name s.txt | _ -> simple_expr ctxt f x @@ -787,6 +847,8 @@ and simple_expr ctxt f x = (match view_expr x with | `nil -> pp f "[]" | `tuple -> pp f "()" + | `btrue -> pp f "true" + | `bfalse -> pp f "false" | `list xs -> pp f "@[[%a]@]" (list (expression (under_semi ctxt)) ~sep:";@;") xs @@ -808,7 +870,7 @@ and simple_expr ctxt f x = 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_variant (l, None) -> pp f "`%a" ident_of_name l | Pexp_record (l, eo) -> let longident_x_expression f ( li, e) = match e with @@ -878,12 +940,14 @@ and class_type_field ctxt f x = 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 + pp f "@[<2>val @ %a%a%a@ :@ %a@]%a" + mutable_flag mf virtual_flag vf + ident_of_name 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 + pp f "@[<2>method %a %a%a :@;%a@]%a" + private_flag pf virtual_flag vf + ident_of_name s.txt (core_type ctxt) ct (item_attributes ctxt) x.pctf_attributes | Pctf_constraint (ct1, ct2) -> pp f "@[<2>constraint@ %a@ =@ %a@]%a" @@ -930,9 +994,10 @@ and class_type ctxt f x = 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 + pp f "@[<2>%s %a%a%a@ =@ %a@]%a" kwd virtual_flag x.pci_virt - (class_params_def ctxt) ls txt + (class_params_def ctxt) ls + ident_of_name txt (class_type ctxt) x.pci_expr (item_attributes ctxt) x.pci_attributes in @@ -951,21 +1016,24 @@ and class_field ctxt f x = (class_expr ctxt) ce (fun f so -> match so with | None -> (); - | Some (s) -> pp f "@ as %s" s.txt ) so + | Some (s) -> pp f "@ as %a" ident_of_name 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 + pp f "@[<2>val%s %a%a =@;%a@]%a" (override ovf) + mutable_flag mf + ident_of_name 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 + pp f "@[<2>method virtual %a %a :@;%a@]%a" + private_flag pf + ident_of_name 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 + pp f "@[<2>val virtual %a%a :@ %a@]%a" + mutable_flag mf + ident_of_name s.txt (core_type ctxt) ct (item_attributes ctxt) x.pcf_attributes | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> @@ -987,8 +1055,8 @@ and class_field ctxt f x = 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 + pp f "%a :@;%a=@;%a" + ident_of_name s.txt (core_type ctxt) ct (expression ctxt) e | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> bind e | _ -> bind e) e @@ -1123,7 +1191,7 @@ and signature_item ctxt f x : unit = | 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 + ident_of_name vd.pval_name.txt (value_description ctxt) vd (item_attributes ctxt) vd.pval_attributes | Psig_typext te -> @@ -1132,9 +1200,10 @@ and signature_item ctxt f x : unit = 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 + pp f "@[<2>%s %a%a%a@;:@;%a@]%a" kwd virtual_flag x.pci_virt - (class_params_def ctxt) ls txt + (class_params_def ctxt) ls + ident_of_name txt (class_type ctxt) x.pci_expr (item_attributes ctxt) x.pci_attributes in begin @@ -1263,14 +1332,10 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; pvb_constraint = ct; _} = 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_function (params, c, body) -> + function_params_then_body ctxt f params c body ~delimiter:"=" | Pexp_newtype (str,e) -> - pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e + pp f "(type@ %a)@ %a" ident_of_name str.txt pp_print_pexp_function e | _ -> pp f "=@;%a" (expression ctxt) x in match ct with @@ -1399,9 +1464,10 @@ and structure_item ctxt f x = 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 + pp f "@[<2>%s %a%a%a %a%a=@;%a@]%a" kwd virtual_flag x.pci_virt - (class_params_def ctxt) ls txt + (class_params_def ctxt) ls + ident_of_name txt (list (label_exp ctxt)) args (option class_constraint) constr (class_expr ctxt) cl @@ -1418,7 +1484,7 @@ and structure_item ctxt f x = | Pstr_class_type l -> class_type_declaration_list ctxt f l | Pstr_primitive vd -> pp f "@[external@ %a@ :@ %a@]%a" - protect_ident vd.pval_name.txt + ident_of_name vd.pval_name.txt (value_description ctxt) vd (item_attributes ctxt) vd.pval_attributes | Pstr_include incl -> @@ -1475,10 +1541,11 @@ and type_def_list ctxt f (rf, exported, l) = else if exported then " =" else " :=" in - pp f "@[<2>%s %a%a%s%s%a@]%a" kwd + pp f "@[<2>%s %a%a%a%s%a@]%a" kwd nonrec_flag rf (type_params ctxt) x.ptype_params - x.ptype_name.txt eq + ident_of_name x.ptype_name.txt + eq (type_declaration ctxt) x (item_attributes ctxt) x.ptype_attributes in @@ -1491,9 +1558,9 @@ and type_def_list ctxt f (rf, exported, l) = and record_declaration ctxt f lbls = let type_record_field f pld = - pp f "@[<2>%a%s:@;%a@;%a@]" + pp f "@[<2>%a%a:@;%a@;%a@]" mutable_flag pld.pld_mutable - pld.pld_name.txt + ident_of_name pld.pld_name.txt (core_type ctxt) pld.pld_type (attributes ctxt) pld.pld_attributes in @@ -1625,14 +1692,14 @@ and label_x_expression_param ctxt f (l,e) = | Nolabel -> expression2 ctxt f e (* level 2*) | Optional str -> if Some str = simple_name then - pp f "?%s" str + pp f "?%a" ident_of_name str else - pp f "?%s:%a" str (simple_expr ctxt) e + pp f "?%a:%a" ident_of_name str (simple_expr ctxt) e | Labelled lbl -> if Some lbl = simple_name then - pp f "~%s" lbl + pp f "~%a" ident_of_name lbl else - pp f "~%s:%a" lbl (simple_expr ctxt) e + pp f "~%a:%a" ident_of_name lbl (simple_expr ctxt) e and directive_argument f x = match x.pdira_desc with @@ -1690,47 +1757,68 @@ let binding = binding reset_ctxt let payload = payload reset_ctxt let case_list = case_list reset_ctxt +module Style = Misc.Style +(* merlin: moved from parse.ml *) 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 + "This %a might be unmatched" Style.inline_code opening ] - "Syntax error: '%s' expected" closing + "Syntax error: %a expected" Style.inline_code closing | Expecting (loc, nonterm) -> - Location.errorf ~source ~loc "Syntax error: %s expected." nonterm + Location.errorf ~loc "Syntax error: %a expected." + Style.inline_code nonterm | Not_expecting (loc, nonterm) -> - Location.errorf ~source ~loc "Syntax error: %s not expected." nonterm + Location.errorf ~loc "Syntax error: %a not expected." + Style.inline_code 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." + Location.errorf ~loc + "Syntax error: applicative paths of the form %a \ + are not supported when the option %a is set." + Style.inline_code "F(X).t" + Style.inline_code "-no-app-func" | Variable_in_scope (loc, var) -> - Location.errorf ~source ~loc + Location.errorf ~loc "In this scoped type, variable %a \ - is reserved for the local type %s." - tyvar var var + is reserved for the local type %a." + (Style.as_inline_code tyvar) var + Style.inline_code var | Other loc -> - Location.errorf ~source ~loc "Syntax error" + 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 ~source ~loc "invalid package type: %s" s + | Invalid_package_type (loc, ipt) -> + let invalid ppf ipt = match ipt with + | Syntaxerr.Parameterized_types -> + Format.fprintf ppf "parametrized types are not supported" + | Constrained_types -> + Format.fprintf ppf "constrained types are not supported" + | Private_types -> + Format.fprintf ppf "private types are not supported" + | Not_with_type -> + Format.fprintf ppf "only %a constraints are supported" + Style.inline_code "with type t =" + | Neither_identifier_nor_with_type -> + Format.fprintf ppf + "only module type identifier and %a constraints are supported" + Style.inline_code "with type" + in + Location.errorf ~loc "invalid package type: %a" invalid ipt | Removed_string_set loc -> Location.errorf ~loc "Syntax error: strings are immutable, there is no assignment \ - syntax for them.\n\ - Hint: Mutable sequences of bytes are available in the Bytes module.\n\ - Hint: Did you mean to use 'Bytes.set'?" - + syntax for them.\n\ + @{Hint@}: Mutable sequences of bytes are available in \ + the Bytes module.\n\ + @{Hint@}: Did you mean to use %a?" + Style.inline_code "Bytes.set" let () = Location.register_error_of_exn (function diff --git a/src/ocaml/parsing/pprintast.mli b/src/ocaml/parsing/pprintast.mli index c9f5393dc2..1f921f02c0 100644 --- a/src/ocaml/parsing/pprintast.mli +++ b/src/ocaml/parsing/pprintast.mli @@ -50,11 +50,18 @@ val signature_item: Format.formatter -> Parsetree.signature_item -> unit val binding: Format.formatter -> Parsetree.value_binding -> unit val payload: Format.formatter -> Parsetree.payload -> unit +val tyvar_of_name : string -> string + (** Turn a type variable name into a valid identifier, taking care of the + special treatment required for the single quote character in second + position, or for keywords by escaping them with \#. No-op on "_". *) + 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. *) + (** Print a type variable name as a valid identifier, taking care of the + special treatment required for the single quote character in second + position, or for keywords by escaping them with \#. No-op on "_". *) (* merlin *) val case_list : Format.formatter -> Parsetree.case list -> unit val protect_ident : Format.formatter -> string -> unit val needs_parens : string -> bool +val ident_of_name : Format.formatter -> string -> unit diff --git a/src/ocaml/parsing/printast.ml b/src/ocaml/parsing/printast.ml index 4b5612ede7..d7d569214e 100644 --- a/src/ocaml/parsing/printast.ml +++ b/src/ocaml/parsing/printast.ml @@ -175,7 +175,7 @@ let rec core_type i ppf x = 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; + line i ppf "Ptyp_alias \"%s\"\n" s.txt; core_type i ppf ct; | Ptyp_poly (sl, ct) -> line i ppf "Ptyp_poly%a\n" typevars sl; @@ -183,6 +183,9 @@ let rec core_type i ppf x = | Ptyp_package (s, l) -> line i ppf "Ptyp_package %a\n" fmt_longident_loc s; list i package_with ppf l; + | Ptyp_open (mod_ident, t) -> + line i ppf "Ptyp_open \"%a\"\n" fmt_longident_loc mod_ident; + core_type i ppf t | Ptyp_extension (s, arg) -> line i ppf "Ptyp_extension \"%s\"\n" s.txt; payload i ppf arg @@ -260,15 +263,11 @@ and expression i ppf x = line i ppf "Pexp_let %a\n" fmt_rec_flag rf; list i value_binding ppf l; expression i ppf e; - | Pexp_function l -> + | Pexp_function (params, c, body) -> 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; + list i function_param ppf params; + option i type_constraint ppf c; + function_body i ppf body | Pexp_apply (e, l) -> line i ppf "Pexp_apply\n"; expression i ppf e; @@ -386,6 +385,36 @@ and expression i ppf x = | Pexp_unreachable -> line i ppf "Pexp_unreachable" +and function_param i ppf { pparam_desc = desc; pparam_loc = loc } = + match desc with + | Pparam_val (l, eo, p) -> + line i ppf "Pparam_val %a\n" fmt_location loc; + arg_label (i+1) ppf l; + option (i+1) expression ppf eo; + pattern (i+1) ppf p + | Pparam_newtype ty -> + line i ppf "Pparam_newtype \"%s\" %a\n" ty.txt fmt_location loc + +and function_body i ppf body = + match body with + | Pfunction_body e -> + line i ppf "Pfunction_body\n"; + expression (i+1) ppf e + | Pfunction_cases (cases, loc, attrs) -> + line i ppf "Pfunction_cases %a\n" fmt_location loc; + attributes (i+1) ppf attrs; + list (i+1) case ppf cases + +and type_constraint i ppf constraint_ = + match constraint_ with + | Pconstraint ty -> + line i ppf "Pconstraint\n"; + core_type (i+1) ppf ty + | Pcoerce (ty1, ty2) -> + line i ppf "Pcoerce\n"; + option (i+1) core_type ppf ty1; + core_type (i+1) ppf ty2 + 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; diff --git a/src/ocaml/parsing/syntaxerr.ml b/src/ocaml/parsing/syntaxerr.ml index df7b8a0548..8a326c1104 100644 --- a/src/ocaml/parsing/syntaxerr.ml +++ b/src/ocaml/parsing/syntaxerr.ml @@ -15,6 +15,13 @@ (* Auxiliary type for reporting syntax errors *) +type invalid_package_type = + | Parameterized_types + | Constrained_types + | Private_types + | Not_with_type + | Neither_identifier_nor_with_type + type error = Unclosed of Location.t * string * Location.t * string | Expecting of Location.t * string @@ -23,7 +30,7 @@ type error = | 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 + | Invalid_package_type of Location.t * invalid_package_type | Removed_string_set of Location.t exception Error of error diff --git a/src/ocaml/parsing/syntaxerr.mli b/src/ocaml/parsing/syntaxerr.mli index 577d5360cd..a84bc6664c 100644 --- a/src/ocaml/parsing/syntaxerr.mli +++ b/src/ocaml/parsing/syntaxerr.mli @@ -20,6 +20,13 @@ *) +type invalid_package_type = + | Parameterized_types + | Constrained_types + | Private_types + | Not_with_type + | Neither_identifier_nor_with_type + type error = Unclosed of Location.t * string * Location.t * string | Expecting of Location.t * string @@ -28,7 +35,7 @@ type error = | 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 + | Invalid_package_type of Location.t * invalid_package_type | Removed_string_set of Location.t exception Error of error diff --git a/src/ocaml/parsing/unit_info.ml b/src/ocaml/parsing/unit_info.ml new file mode 100644 index 0000000000..b2e081a221 --- /dev/null +++ b/src/ocaml/parsing/unit_info.ml @@ -0,0 +1,119 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed 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 modname = string +type filename = string +type file_prefix = string + +type t = { + source_file: filename; + prefix: file_prefix; + modname: modname; +} + +let source_file (x: t) = x.source_file +let modname (x: t) = x.modname +let prefix (x: t) = x.prefix + +let basename_chop_extensions basename = + match String.index basename '.' with + | dot_pos -> String.sub basename 0 dot_pos + | exception Not_found -> basename + +let modulize s = String.capitalize_ascii s + +(* We re-export the [Misc] definition *) +let normalize = Misc.normalized_unit_filename + +let modname_from_source source_file = + source_file |> Filename.basename |> basename_chop_extensions |> modulize + +let start_char = function + | 'A' .. 'Z' -> true + | _ -> false + +let is_identchar_latin1 = function + | 'A'..'Z' | 'a'..'z' | '_' | '\192'..'\214' | '\216'..'\246' + | '\248'..'\255' | '\'' | '0'..'9' -> true + | _ -> false + +(* Check validity of module name *) +let is_unit_name name = + String.length name > 0 + && start_char name.[0] + && String.for_all is_identchar_latin1 name + +let check_unit_name file = + if not (is_unit_name (modname file)) then + Location.prerr_warning (Location.in_file (source_file file)) + (Warnings.Bad_module_name (modname file)) + +let make ?(check_modname=true) ~source_file prefix = + let modname = modname_from_source prefix in + let p = { modname; prefix; source_file } in + if check_modname then check_unit_name p; + p + +module Artifact = struct + type t = + { + source_file: filename option; + filename: filename; + modname: modname; + } + let source_file x = x.source_file + let filename x = x.filename + let modname x = x.modname + let prefix x = Filename.remove_extension (filename x) + + let from_filename filename = + let modname = modname_from_source filename in + { modname; filename; source_file = None } + +end + +let mk_artifact ext u = + { + Artifact.filename = u.prefix ^ ext; + modname = u.modname; + source_file = Some u.source_file; + } + +let companion_artifact ext x = + { x with Artifact.filename = Artifact.prefix x ^ ext } + +let cmi f = mk_artifact ".cmi" f +let cmo f = mk_artifact ".cmo" f +let cmx f = mk_artifact ".cmx" f +let obj f = mk_artifact Config.ext_obj f +let cmt f = mk_artifact ".cmt" f +let cmti f = mk_artifact ".cmti" f +let annot f = mk_artifact ".annot" f + +let companion_obj f = companion_artifact Config.ext_obj f +let companion_cmi f = companion_artifact ".cmi" f +let companion_cmt f = companion_artifact ".cmt" f + +let mli_from_artifact f = Artifact.prefix f ^ !Config.interface_suffix +let mli_from_source u = + let prefix = Filename.remove_extension (source_file u) in + prefix ^ !Config.interface_suffix + +let is_cmi f = Filename.check_suffix (Artifact.filename f) ".cmi" + +let find_normalized_cmi f = + let filename = modname f ^ ".cmi" in + let filename = Load_path.find_normalized filename in + { Artifact.filename; modname = modname f; source_file = Some f.source_file } diff --git a/src/ocaml/parsing/unit_info.mli b/src/ocaml/parsing/unit_info.mli new file mode 100644 index 0000000000..48acafc06d --- /dev/null +++ b/src/ocaml/parsing/unit_info.mli @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2023 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed 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 centralize the handling of compilation files and their metadata. + + Maybe more importantly, this module provides functions for deriving module + names from strings or filenames. +*) + +(** {1:modname_from_strings Module name convention and computation} *) + +type modname = string +type filename = string +type file_prefix = string + +(** [modulize s] capitalizes the first letter of [s]. *) +val modulize: string -> modname + +(** [normalize s] uncapitalizes the first letter of [s]. *) +val normalize: string -> string + +(** [modname_from_source filename] is [modulize stem] where [stem] is the + basename of the filename [filename] stripped from all its extensions. + For instance, [modname_from_source "/pa.th/x.ml.pp"] is ["X"]. *) +val modname_from_source: filename -> modname + +(** {2:module_name_validation Module name validation function}*) + +(** [is_unit_name ~strict name] is true only if [name] can be used as a + valid module name. *) +val is_unit_name : modname -> bool + + +(** {1:unit_info Metadata for compilation unit} *) + +type t +(** Metadata for a compilation unit: + - the module name associated to the unit + - the filename prefix (dirname + basename with all extensions stripped) + for compilation artifacts + - the input source file + For instance, when calling [ocamlopt dir/x.mli -o target/y.cmi], + - the input source file is [dir/x.mli] + - the module name is [Y] + - the prefix is [target/y] +*) + +(** [source_file u] is the source file of [u]. *) +val source_file: t -> filename + +(** [prefix u] is the filename prefix of the unit. *) +val prefix: t -> file_prefix + +(** [modname u] or [artifact_modname a] is the module name of the unit + or compilation artifact.*) +val modname: t -> modname + +(** [check_unit_name u] prints a warning if the derived module name [modname u] + should not be used as a module name as specified + by {!is_unit_name}[ ~strict:true]. *) +val check_unit_name : t -> unit + +(** [make ~check ~source_file prefix] associates both the + [source_file] and the module name {!modname_from_source}[ target_prefix] to + the prefix filesystem path [prefix]. + + If [check_modname=true], this function emits a warning if the derived module + name is not valid according to {!check_unit_name}. +*) +val make: ?check_modname:bool -> source_file:filename -> file_prefix -> t + +(** {1:artifact_function Build artifacts }*) +module Artifact: sig + type t +(** Metadata for a single compilation artifact: + - the module name associated to the artifact + - the filesystem path + - the input source file if it exists +*) + + (** [source_file a] is the source file of [a] if it exists. *) + val source_file: t -> filename option + + (** [prefix a] is the filename prefix of the compilation artifact. *) + val prefix: t -> file_prefix + + (** [filename u] is the filesystem path for a compilation artifact. *) + val filename: t -> filename + + (** [modname a] is the module name of the compilation artifact.*) + val modname: t -> modname + + (** [from_filename filename] reconstructs the module name + [modname_from_source filename] associated to the artifact [filename]. *) + val from_filename: filename -> t + +end + +(** {1:info_build_artifacts Derived build artifact metadata} *) + +(** Those functions derive a specific [artifact] metadata from an [unit] + metadata.*) +val cmi: t -> Artifact.t +val cmo: t -> Artifact.t +val cmx: t -> Artifact.t +val obj: t -> Artifact.t +val cmt: t -> Artifact.t +val cmti: t -> Artifact.t +val annot: t -> Artifact.t + +(** The functions below change the type of an artifact by updating the + extension of its filename. + Those functions purposefully do not cover all artifact kinds because we want + to track which artifacts are assumed to be bundled together. *) +val companion_cmi: Artifact.t -> Artifact.t +val companion_obj: Artifact.t -> Artifact.t +val companion_cmt: Artifact.t -> Artifact.t + + +(** {1:ml_mli_cmi_interaction Mli and cmi derived from implementation files } *) + +(** The compilation of module implementation changes in presence of mli and cmi + files, the function belows help to handle this. *) + +(** [mli_from_source u] is the interface source filename associated to the unit + [u]. The actual suffix depends on {!Config.interface_suffix}. +*) +val mli_from_source: t -> filename + +(** [mli_from_artifact t] is the name of the interface source file derived from + the artifact [t]. This variant is necessary when handling artifacts derived + from an unknown source files (e.g. packed modules). *) +val mli_from_artifact: Artifact.t -> filename + +(** Check if the artifact is a cmi *) +val is_cmi: Artifact.t -> bool + +(** [find_normalized_cmi u] finds in the load_path a file matching the module + name [modname u]. + @raise Not_found if no such cmi exists *) +val find_normalized_cmi: t -> Artifact.t diff --git a/src/ocaml/preprocess/lexer_raw.mll b/src/ocaml/preprocess/lexer_raw.mll index 3fce4ec5c4..c6c39fe58a 100644 --- a/src/ocaml/preprocess/lexer_raw.mll +++ b/src/ocaml/preprocess/lexer_raw.mll @@ -149,6 +149,35 @@ let list_keywords = fun keywords -> Hashtbl.fold add_kw keywords init +let store_string_char buf c = Buffer.add_char buf c +let store_substring buf s ~pos ~len = Buffer.add_substring buf s pos len + +let store_normalized_newline buf newline = + (* #12502: we normalize "\r\n" to "\n" at lexing time, + to avoid behavior difference due to OS-specific + newline characters in string literals. + + (For example, Git for Windows will translate \n in versioned + files into \r\n sequences when checking out files on Windows. If + your code contains multiline quoted string literals, the raw + content of the string literal would be different between Git for + Windows users and all other users. Thanks to newline + normalization, the value of the literal as a string constant will + be the same no matter which programming tools are used.) + + Many programming languages use the same approach, for example + Java, Javascript, Kotlin, Python, Swift and C++. + *) + (* Our 'newline' regexp accepts \r*\n, but we only wish + to normalize \r?\n into \n -- see the discussion in #12502. + All carriage returns except for the (optional) last one + are reproduced in the output. We implement this by skipping + the first carriage return, if any. *) + let len = String.length newline in + if len = 1 + then store_string_char buf '\n' + else store_substring buf newline ~pos:1 ~len:(len - 1) + (* To store the position of the beginning of a string and comment *) let in_comment state = state.comment_start_loc <> [] @@ -263,6 +292,7 @@ let keyword_or state s default = with Not_found -> default let is_keyword name = Hashtbl.mem keyword_table name +let () = Lexer.is_keyword_ref := is_keyword let check_label_name lexbuf name = if is_keyword name @@ -325,7 +355,7 @@ let prepare_error loc = function Location.error ~loc ~sub msg | Keyword_as_label kwd -> Location.errorf ~loc - "`%s' is a keyword, it cannot be used as label name" kwd + "%a is a keyword, it cannot be used as label name" Style.inline_code kwd | Invalid_literal s -> Location.errorf ~loc "Invalid literal %s" s (* FIXME: Invalid_directive? *) @@ -386,10 +416,12 @@ let hex_float_literal = ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )? (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? let literal_modifier = ['G'-'Z' 'g'-'z'] +let raw_ident_escape = "\#" refill {fun k lexbuf -> Refill (fun () -> k lexbuf)} + rule token state = parse | ("\\" as bs) newline { match state.preprocessor with @@ -420,6 +452,8 @@ rule token state = parse { fail lexbuf (Reserved_sequence (".~", Some "is reserved for use in MetaOCaml")) } *) + | "~" raw_ident_escape (lowercase identchar * as name) ':' + { return (LABEL name) } | "~" (lowercase identchar * as name) ':' { lABEL (check_label_name lexbuf name) } | "~" (lowercase_latin1 identchar_latin1 * as name) ':' @@ -427,10 +461,14 @@ rule token state = parse return (LABEL name) } | "?" { return QUESTION } + | "?" raw_ident_escape (lowercase identchar * as name) ':' + { return (OPTLABEL name) } | "?" (lowercase identchar * as name) ':' { oPTLABEL (check_label_name lexbuf name) } | "?" (lowercase_latin1 identchar_latin1 * as name) ':' { warn_latin1 lexbuf; return (OPTLABEL name) } + | raw_ident_escape (lowercase identchar * as name) + { return (LIDENT name) } | lowercase identchar * as name { return (try Hashtbl.find state.keywords name with Not_found -> @@ -505,7 +543,7 @@ rule token state = parse { 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) + | "\'" ("\\" [^ '#'] as esc) { fail lexbuf (Illegal_escape (esc, None)) } | "(*" { let start_loc = Location.curr lexbuf in @@ -678,22 +716,24 @@ and comment state = parse Buffer.add_char state.buffer '}'; comment state lexbuf } - | "''" + | "\'\'" { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "'" newline "'" + | "\'" (newline as nl) "\'" { update_loc lexbuf None 1 false 1; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); + store_string_char state.buffer '\''; + store_normalized_newline state.buffer nl; + store_string_char state.buffer '\''; comment state lexbuf } - | "'" [^ '\\' '\'' '\010' '\013' ] "'" + | "\'" [^ '\\' '\'' '\010' '\013' ] "'" { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "'" + | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "'" { Buffer.add_string state.buffer (Lexing.lexeme lexbuf); comment state lexbuf } - | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + | "\'\\" ['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'] "'" + | "\'\\" '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 @@ -703,9 +743,9 @@ and comment state = parse state.comment_start_loc <- []; fail_loc (Unterminated_comment start) loc } - | newline + | newline as nl { update_loc lexbuf None 1 false 0; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); + store_normalized_newline state.buffer nl; comment state lexbuf } | (lowercase | uppercase) identchar * @@ -749,11 +789,9 @@ and string state = parse 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); + | newline as nl + { update_loc lexbuf None 1 false 0; + store_normalized_newline state.buffer nl; string state lexbuf } | eof @@ -765,9 +803,9 @@ and string state = parse string state lexbuf } and quoted_string delim state = parse - | newline + | newline as nl { update_loc lexbuf None 1 false 0; - Buffer.add_string state.buffer (Lexing.lexeme lexbuf); + store_normalized_newline state.buffer nl; quoted_string delim state lexbuf } | eof diff --git a/src/ocaml/preprocess/parser_explain.ml b/src/ocaml/preprocess/parser_explain.ml index ef02f70969..2f5db44a21 100644 --- a/src/ocaml/preprocess/parser_explain.ml +++ b/src/ocaml/preprocess/parser_explain.ml @@ -21,6 +21,7 @@ let nullable (type a) : a MenhirInterpreter.nonterminal -> bool = | N_option_preceded_EQUAL_module_type__ -> true | N_option_preceded_EQUAL_expr__ -> true | N_option_preceded_COLON_core_type__ -> true + | N_option_preceded_COLON_atomic_type__ -> true | N_option_preceded_AS_mkrhs_LIDENT___ -> true | N_option_SEMI_ -> true | N_option_BAR_ -> true @@ -48,4 +49,5 @@ let nullable (type a) : a MenhirInterpreter.nonterminal -> bool = | N_ext -> true | N_class_self_type -> true | N_class_self_pattern -> true + | N_attr_payload -> true | _ -> false diff --git a/src/ocaml/preprocess/parser_printer.ml b/src/ocaml/preprocess/parser_printer.ml index e49be91525..2bfbe32000 100644 --- a/src/ocaml/preprocess/parser_printer.ml +++ b/src/ocaml/preprocess/parser_printer.ml @@ -207,6 +207,7 @@ let print_symbol = function | 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_nonempty_concat_fun_param_as_list_) -> "reversed_nonempty_concat_fun_param_as_list_" | 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_" @@ -245,6 +246,7 @@ let print_symbol = function | 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_COLON_atomic_type__) -> "option_preceded_COLON_atomic_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_" @@ -252,6 +254,7 @@ let print_symbol = function | 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_object_type) -> "object_type" | 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__" @@ -273,7 +276,7 @@ let print_symbol = function | 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___anonymous_43_) -> "mk_longident_mod_ext_longident___anonymous_43_" | 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_" @@ -324,16 +327,22 @@ let print_symbol = function | 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_fun_seq_expr) -> "fun_seq_expr" + | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_fun_params) -> "fun_params" + | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_fun_param_as_list) -> "fun_param_as_list" + | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_fun_expr) -> "fun_expr" + | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_fun_body) -> "fun_body" | 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_type) -> "extension_type" | 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_delimited_type_supporting_local_open) -> "delimited_type_supporting_local_open" + | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_delimited_type) -> "delimited_type" | 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" @@ -356,6 +365,7 @@ let print_symbol = function | 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_payload) -> "attr_payload" | 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" @@ -553,6 +563,7 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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_nonempty_concat_fun_param_as_list_ -> (fun _ -> "reversed_nonempty_concat_fun_param_as_list_") | 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_") @@ -591,6 +602,7 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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_COLON_atomic_type__ -> (fun _ -> "option_preceded_COLON_atomic_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_") @@ -598,6 +610,7 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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_object_type -> (fun _ -> "object_type") | 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__") @@ -619,7 +632,7 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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___anonymous_43_ -> (fun _ -> "mk_longident_mod_ext_longident___anonymous_43_") | 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_") @@ -670,16 +683,22 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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_fun_seq_expr -> (fun _ -> "fun_seq_expr") + | MenhirInterpreter.N MenhirInterpreter.N_fun_params -> (fun _ -> "fun_params") + | MenhirInterpreter.N MenhirInterpreter.N_fun_param_as_list -> (fun _ -> "fun_param_as_list") + | MenhirInterpreter.N MenhirInterpreter.N_fun_expr -> (fun _ -> "fun_expr") + | MenhirInterpreter.N MenhirInterpreter.N_fun_body -> (fun _ -> "fun_body") | 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_type -> (fun _ -> "extension_type") | 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_delimited_type_supporting_local_open -> (fun _ -> "delimited_type_supporting_local_open") + | MenhirInterpreter.N MenhirInterpreter.N_delimited_type -> (fun _ -> "delimited_type") | 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") @@ -702,6 +721,7 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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_payload -> (fun _ -> "attr_payload") | 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") diff --git a/src/ocaml/preprocess/parser_raw.ml b/src/ocaml/preprocess/parser_raw.ml index 83dc615ee5..f1b2c3e667 100644 --- a/src/ocaml/preprocess/parser_raw.ml +++ b/src/ocaml/preprocess/parser_raw.ml @@ -17,7 +17,7 @@ module MenhirBasics = struct | VAL | UNDERSCORE | UIDENT of ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) # 23 "src/ocaml/preprocess/parser_raw.ml" ) @@ -30,7 +30,7 @@ module MenhirBasics = struct | THEN | STRUCT | STRING of ( -# 837 "src/ocaml/preprocess/parser_raw.mly" +# 903 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) # 36 "src/ocaml/preprocess/parser_raw.ml" ) @@ -43,12 +43,12 @@ module MenhirBasics = struct | RBRACKET | RBRACE | QUOTED_STRING_ITEM of ( -# 842 "src/ocaml/preprocess/parser_raw.mly" +# 908 "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 ( -# 839 "src/ocaml/preprocess/parser_raw.mly" +# 905 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) # 54 "src/ocaml/preprocess/parser_raw.ml" ) @@ -56,7 +56,7 @@ module MenhirBasics = struct | QUESTION | PRIVATE | PREFIXOP of ( -# 823 "src/ocaml/preprocess/parser_raw.mly" +# 889 "src/ocaml/preprocess/parser_raw.mly" (string) # 62 "src/ocaml/preprocess/parser_raw.ml" ) @@ -66,7 +66,7 @@ module MenhirBasics = struct | PERCENT | OR | OPTLABEL of ( -# 816 "src/ocaml/preprocess/parser_raw.mly" +# 882 "src/ocaml/preprocess/parser_raw.mly" (string) # 72 "src/ocaml/preprocess/parser_raw.ml" ) @@ -85,13 +85,13 @@ module MenhirBasics = struct | MATCH | LPAREN | LIDENT of ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) # 91 "src/ocaml/preprocess/parser_raw.ml" ) | LET_LWT | LETOP of ( -# 781 "src/ocaml/preprocess/parser_raw.mly" +# 847 "src/ocaml/preprocess/parser_raw.mly" (string) # 97 "src/ocaml/preprocess/parser_raw.ml" ) @@ -111,39 +111,39 @@ module MenhirBasics = struct | LBRACE | LAZY | LABEL of ( -# 786 "src/ocaml/preprocess/parser_raw.mly" +# 852 "src/ocaml/preprocess/parser_raw.mly" (string) # 117 "src/ocaml/preprocess/parser_raw.ml" ) | INT of ( -# 785 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string * char option) # 122 "src/ocaml/preprocess/parser_raw.ml" ) | INITIALIZER | INHERIT | INFIXOP4 of ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 845 "src/ocaml/preprocess/parser_raw.mly" (string) # 129 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP3 of ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 844 "src/ocaml/preprocess/parser_raw.mly" (string) # 134 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP2 of ( -# 777 "src/ocaml/preprocess/parser_raw.mly" +# 843 "src/ocaml/preprocess/parser_raw.mly" (string) # 139 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP1 of ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 842 "src/ocaml/preprocess/parser_raw.mly" (string) # 144 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP0 of ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 841 "src/ocaml/preprocess/parser_raw.mly" (string) # 149 "src/ocaml/preprocess/parser_raw.ml" ) @@ -151,7 +151,7 @@ module MenhirBasics = struct | IN | IF | HASHOP of ( -# 834 "src/ocaml/preprocess/parser_raw.mly" +# 900 "src/ocaml/preprocess/parser_raw.mly" (string) # 157 "src/ocaml/preprocess/parser_raw.ml" ) @@ -166,7 +166,7 @@ module MenhirBasics = struct | FOR_LWT | FOR | FLOAT of ( -# 764 "src/ocaml/preprocess/parser_raw.mly" +# 830 "src/ocaml/preprocess/parser_raw.mly" (string * char option) # 172 "src/ocaml/preprocess/parser_raw.ml" ) @@ -182,7 +182,7 @@ module MenhirBasics = struct | DOWNTO | DOTTILDE | DOTOP of ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) # 188 "src/ocaml/preprocess/parser_raw.ml" ) @@ -191,14 +191,14 @@ module MenhirBasics = struct | DOT | DONE | DOCSTRING of ( -# 859 "src/ocaml/preprocess/parser_raw.mly" +# 925 "src/ocaml/preprocess/parser_raw.mly" (Docstrings.docstring) # 197 "src/ocaml/preprocess/parser_raw.ml" ) | DO | CONSTRAINT | COMMENT of ( -# 858 "src/ocaml/preprocess/parser_raw.mly" +# 924 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t) # 204 "src/ocaml/preprocess/parser_raw.ml" ) @@ -209,7 +209,7 @@ module MenhirBasics = struct | COLON | CLASS | CHAR of ( -# 744 "src/ocaml/preprocess/parser_raw.mly" +# 810 "src/ocaml/preprocess/parser_raw.mly" (char) # 215 "src/ocaml/preprocess/parser_raw.ml" ) @@ -222,7 +222,7 @@ module MenhirBasics = struct | ASSERT | AS | ANDOP of ( -# 782 "src/ocaml/preprocess/parser_raw.mly" +# 848 "src/ocaml/preprocess/parser_raw.mly" (string) # 228 "src/ocaml/preprocess/parser_raw.ml" ) @@ -242,6 +242,9 @@ let _eRR = [@@@ocaml.warning "-9"] +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + open Asttypes open Longident open Parsetree @@ -383,6 +386,10 @@ let mkuplus ~oploc name arg = | _ -> Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) +let mk_attr ~loc name payload = + Builtin_attributes.(register_attr Parser name); + Attr.mk ~loc name payload + (* 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 *) @@ -425,11 +432,13 @@ let rec mktailpat nilloc = let open Location in function 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 -> mkexp ~loc (Pexp_constraint(e, t)) - | _, Some t -> mkexp ~loc (Pexp_coerce(e, t1, t)) - | None, None -> assert false +let mkexp_desc_constraint e t = + match t with + | Pconstraint t -> Pexp_constraint(e, t) + | Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) + +let mkexp_constraint ~loc e t = + mkexp ~loc (mkexp_desc_constraint e t) let mkexp_opt_constraint ~loc e = function | None -> e @@ -813,6 +822,64 @@ let class_of_let_bindings ~loc lbs body = assert (lbs.lbs_extension = None); mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body)) +(* If all the parameters are [Pparam_newtype x], then return [Some xs] where + [xs] is the corresponding list of values [x]. This function is optimized for + the common case, where a list of parameters contains at least one value + parameter. +*) +let all_params_as_newtypes = + let is_newtype { pparam_desc; _ } = + match pparam_desc with + | Pparam_newtype _ -> true + | Pparam_val _ -> false + in + let as_newtype { pparam_desc; pparam_loc } = + match pparam_desc with + | Pparam_newtype x -> Some (x, pparam_loc) + | Pparam_val _ -> None + in + fun params -> + if List.for_all is_newtype params + then Some (List.filter_map as_newtype params) + else None + +(* Given a construct [fun (type a b c) : t -> e], we construct + [Pexp_newtype(a, Pexp_newtype(b, Pexp_newtype(c, Pexp_constraint(e, t))))] + rather than a [Pexp_function]. +*) +let mkghost_newtype_function_body newtypes body_constraint body = + let wrapped_body = + match body_constraint with + | None -> body + | Some body_constraint -> + let loc = { body.pexp_loc with loc_ghost = true } in + Exp.mk (mkexp_desc_constraint body body_constraint) ~loc + in + let expr = + List.fold_right + (fun (newtype, newtype_loc) e -> + (* Mints a ghost location that approximates the newtype's "extent" as + being from the start of the newtype param until the end of the + function body. + *) + let loc = (newtype_loc.Location.loc_start, body.pexp_loc.loc_end) in + ghexp (Pexp_newtype (newtype, e)) ~loc) + newtypes + wrapped_body + in + expr.pexp_desc + +let mkfunction params body_constraint body = + match body with + | Pfunction_cases _ -> Pexp_function (params, body_constraint, body) + | Pfunction_body body_exp -> + (* If all the params are newtypes, then we don't create a function node; + we create nested newtype nodes. *) + match all_params_as_newtypes params with + | None -> Pexp_function (params, body_constraint, body) + | Some newtypes -> + mkghost_newtype_function_body newtypes body_constraint body_exp + (* 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. *) @@ -824,11 +891,11 @@ let package_type_of_module_type pmty = | Pwith_type (lid, ptyp) -> let loc = ptyp.ptype_loc in if ptyp.ptype_params <> [] then - err loc "parametrized types are not supported"; + err loc Syntaxerr.Parameterized_types; if ptyp.ptype_cstrs <> [] then - err loc "constrained types are not supported"; + err loc Syntaxerr.Constrained_types; if ptyp.ptype_private <> Public then - err loc "private types are not supported"; + err loc Syntaxerr.Private_types; (* restrictions below are checked by the 'with_constraint' rule *) (* assert (ptyp.ptype_kind = Ptype_abstract); *) @@ -838,7 +905,7 @@ let package_type_of_module_type pmty = | None -> None end | _ -> - err pmty.pmty_loc "only 'with type t =' constraints are supported"; + err pmty.pmty_loc Not_with_type; None in match pmty with @@ -846,8 +913,7 @@ let package_type_of_module_type pmty = | {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" + err pmty.pmty_loc Neither_identifier_nor_with_type ; (Location.mkloc (Lident "_") pmty.pmty_loc, [], []) let mk_directive_arg ~loc k = @@ -900,7 +966,7 @@ let expr_of_lwt_bindings ~loc lbs body = (lbs.lbs_extension, [])) -# 904 "src/ocaml/preprocess/parser_raw.ml" +# 970 "src/ocaml/preprocess/parser_raw.ml" module Tables = struct @@ -1446,22 +1512,22 @@ module Tables = struct Obj.repr () and default_reduction = - (16, "\000\000\000\000\000\000\002\222\002\221\002\220\002\219\002\218\002\173\002\217\002\216\002\215\002\214\002\213\002\212\002\211\002\210\002\209\002\208\002\207\002\206\002\205\002\204\002\203\002\202\002\201\002\200\002\199\002\172\002\198\002\197\002\196\002\195\002\194\002\193\002\192\002\191\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\000\000\000\000\000,\000\189\000\000\000\000\000\000\000\000\000\000\000\000\002\142\001[\000\000\000\000\000\000\000\000\000\000\000\000\000h\000c\000\191\000\000\000\000\000\000\000\000\000\000\002\160\000\000\002g\002h\000\000\002e\002f\000\000\001\179\000f\001\158\001\176\001\175\000\000\001\180\001\184\000\000\000\000\000\000\001q\001p\000\000\002\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\174\001\178\001\177\001\159\001\182\001\173\001\172\001\171\001\170\001\169\001\167\001\183\001\181\000\000\000\000\000\000\000\226\000\000\000\000\001\162\000\000\000\000\000\000\001\164\000\000\000\000\000\000\001\166\001\188\001\185\001\168\001\160\001\186\001\187\000\000\003 \003!\000\000\000\000\000\026\001O\000\000\000\222\000\223\000\000\000\000\000\000\001\210\001\209\000\000\000\000\000\025\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001o\000\000\000\000\000\000\000\000\000\000\003\029\000\000\003\024\000\000\000\000\003\026\000\000\003\028\000\000\003\025\003\027\000\000\003\019\000\000\003\018\003\014\0023\000\000\003\017\000\000\0024\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\000\000\000\000\000\000\000\000\000\000\000\000\000\229\000\017\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001Y\000\000\000\000\001\\\001Z\001a\000C\002|\000\000\001\028\002\248\002\247\000\000\000\000\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\015\000\000\000\000\000\000\000e\000\000\000\237\000\000\002i\000\000\000\000\000\000\001\192\000\000\000\000\000'\000\000\000\000\000\000\000\000\000\000\000\000\001`\000\000\001P\001_\000\000\001N\000`\000 \000\000\000\000\001\135\000\027\000\000\000\000\000\000\000\000\003\r\000*\000\000\000\000\000!\000\028\000\000\000\000\000\000\000\204\000\000\000\000\000\000\000\206\002=\002/\000\000\000$\000\000\0020\000\000\000\000\001\189\000\000\000\000\000\000\000\018\000\000\000\000\000\000\000\019\002\249\000\000\002\250\000\000\000w\000\000\000\000\000#\000\000\000\000\000\000\000%\000\000\000&\000\000\000(\000\000\000\000\000)\002%\002$\000\000\000\000\000\000\000\000\000\000\000\000\000a\000\000\002\165\000d\000g\000b\002\154\003\"\002\155\001\243\002\157\000\000\000\000\002\162\002d\002\164\000\000\000\000\000\000\002\168\000\000\000\000\000\000\001\239\001\230\000\000\000\000\000\000\000\000\000\000\001\229\000\000\001\242\002\171\000\000\000\000\000\000\000\000\001\137\000\000\000\000\001\241\002\163\000o\000\000\000\000\000n\000\000\002\156\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\001\231\001\240\001\234\000\000\000m\000\000\002\169\000\000\002\167\000\000\002j\000\000\000\000\002G\002\166\000\000\000\000\000\000\000\000\001\194\0017\0018\002l\000\000\002k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\248\000\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\251\000\000\000\000\000\000\000\000\000\000\000\000\000\246\001\250\000\247\000\000\000\000\000\000\000\000\000\000\000\250\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\207\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002!\000\000\000\000\001x\000\000\000\000\000\000\000\000\000\000\000\000\0039\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\000\000\000\000\000\000\000\000\000\000\001w\000\000\000\000\000\000\001X\001\127\001W\001|\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 \000\000\000\000\001v\000\000\000\208\000\000\000\000\001i\000\000\000\000\001m\000\000\001\212\000\000\000\000\001\211\001l\001j\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\128\001]\002\133\002\131\000\000\000\000\000\000\002\143\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\153\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\241\000\240\000\000\000\242\000\000\000\000\000\000\002\139\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\003#\002\141\002\130\002\129\000\000\000\000\000z\001:\000\000\000\000\000\173\000\000\000\000\000\000\000\000\000\000\000\187\000\000\000\000\000\000\000\172\000\000\000\000\000\000\002N\002M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\003\000\000\000\000\001\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\247\001\245\001\246\000\000\000\000\000\000\000\252\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\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\001\024\000\000\001d\002\241\000\000\000\000\002\240\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\246\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\001\139\000\000\002\006\000\000\000\000\000\000\000\000\000i\000\000\000\000\000j\000\000\000\000\000\000\000\000\001\129\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\231\000\000\000\000\000s\000\000\000\234\000\232\000\000\000\000\000\000\000\211\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\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\002O\000k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\150\001\146\000\000\000\000\000\000\000\216\000\000\000\000\002\020\002\030\000\000\000\219\002\018\002\019\000\000\000\000\000\000\000\000\000\000\001\153\001\149\001\145\000\000\000\000\000\217\000\000\000\000\001\152\001\148\001\144\001\142\002\030\000\000\000\221\000\000\000\000\002\b\000\000\000\000\002X\002\029\002\027\002\028\000\000\000\000\000\000\002\030\000\000\000\218\002\030\000\000\000\220\000\000\000\000\000\000\000\000\002W\000\000\000\000\000\000\000\000\000\000\000\000\001\157\000\000\000\000\000\000\001\156\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\001r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\026\002]\000\000\000\000\000\000\002[\000\000\000\000\000\000\002Z\000\000\001f\000\000\000\000\000\000\000\000\002a\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003+\000\000\000\000\000\000\000\196\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000G\000\000\000\000\000\000\000\000\001\134\000\000\001\133\000\000\000\000\000\000\000\000\000J\000\000\000\000\000\000\002\r\000\000\002\012\000\000\000\000\000\000\000\000\000K\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000P\000\000\000\000\000\000\000Q\000O\000\000\000S\000\000\000\000\000\000\000\000\000\000\000I\000\000\000\000\000\000\000\000\000\000\000\000\000L\000\000\000R\000\000\000M\000N\000\000\001+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\022\000_\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\\\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\020\002b\002S\000\000\002Y\002T\002`\002_\002^\002\\\001%\000\000\002Q\000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\000\001\030\002U\000\000\000\000\000\000\000\000\000\000\000\000\002\030\000\000\000\000\001 \002V\002R\002c\001$\001\253\002P\000\000\000\000\000\000\000\000\000\000\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\000\000\000\003(\000\000\0008\000\000\000\000\003.\000\000\003-\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003%\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\001L\000\000\000\000\001J\001H\000\251\000\000\000\000\000\000\000\198\000\197\002\226\000\000\0009\000\000\000\000\0031\000\000\0030\000\000\000\000\000\000\001F\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001K\000\000\000\000\001I\001G\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000X\000\000\000\000\000\000\000\000\000\000\000\000\0005\000\000\000\000\000\000\000\000\000\000\002#\002\"\000W\000\000\0003\001\b\000\000\000B\000/\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\006\000\000\000V\000\000\000\000\000Y\000\000\000\000\001\196\000\000\0007\000\000\000\000\000\000\0006\000\000\000\000\000\000\000:\000\000\000Z\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\018\002\244\002\235\000\000\000\000\000\000\000\000\000\000\000\000\001\004\002\239\002\223\002\234\002\243\002\242\000\000\001;\001)\000\000\001\005\000\000\002\232\000\000\002\236\002\233\002\245\001\252\000\000\000\000\002\229\000\000\000\194\000\000\002\228\000\000\000\000\000\228\000\000\002\005\000\020\000\000\000\000\000\000\002s\000\000\000\000\002r\000\000\000\000\000\000\000\000\002u\000\000\000\000\002A\000\000\000\000\002y\000\000\000\000\002w\002\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\171\000\000\002t\000\000\000\000\002x\000\000\000\000\002v\001\r\000\000\000\000\001\014\000\000\000\000\000\174\000\000\001\016\001\015\000\000\000\000\002\137\000\000\002\149\000\000\002\148\000\000\002\152\000\000\002\151\000\000\000\000\002\138\000\000\000\000\000\000\002\017\000\000\001\208\000\000\000\000\000\000\002J\002\016\000\000\002\145\000\000\000\000\000\000\001^\000\000\000x\000y\000\000\000\000\000\000\000\000\000\144\000\000\000\000\000\000\000\130\000\000\000\000\000\000\000\000\000\000\000\000\000\129\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\200\000\000\000\201\000\202\000\138\000\000\000\137\000\000\000\000\001=\000\000\001>\001<\002)\000\000\000\000\002*\002(\000\000\000\000\000\000\000\000\000\000\002{\000\000\002z\000\000\000\000\002m\000\000\000\000\002\144\000\000\000\000\000\000\002D\002\135\000\000\002\134\000\000\002\150\000\135\000\000\000\000\000\000\000\000\000\134\000\000\000\000\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\133\002\225\002\227\001\011\001\206\000\000\000\244\000\245\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\255\000\254\000\000\0019\000\000\002\147\000\000\002\146\002\132\000\000\000\000\000\000\000\000\002}\000\000\000\000\002~\000\000\002o\000\000\002p\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\213\000\000\000\000\001\216\000\000\000\000\001\214\000\000\000\000\001\215\000\000\001\155\000\000\000\000\000\000\001\154\000\000\000\000\001(\001'\000\000\000\190\000\000\000\000\000\000\000\000\001E\001?\000\000\000\000\001@\000\031\000\000\000\030\000\000\000\000\000\205\000\000\000\000\000\000\000\"\000\029\000\000\000\000\000\000\000\023\000\000\000\000\000\000\000\000\001\151\001\147\000\000\001\143\003\012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000\000\002\238\002\025\002\026\002\021\002\023\002\022\002\024\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\000\000\000\000\000\002\237\000\000\001g\000\000\000\000\000\024\000\000\003)\000\000\001s\000\000\002\159\000\000\000D\000\000\000\000\000E\000\000\000\000\002\127\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\127\000\000\000~\000\000\000\000\000\000\000\143\000\000\000-\000\000\000\000\000\000\000\000\000\128\000\000\000\224\000\001\000\000\000\000\000\227\000\002\000\000\000\000\000\000\001R\001S\000\003\000\000\000\000\000\000\000\000\001U\001V\001T\000\021\001Q\000\022\000\000\001\217\000\000\000\004\000\000\001\218\000\000\000\005\000\000\001\219\000\000\000\000\001\220\000\006\000\000\000\007\000\000\001\221\000\000\000\b\000\000\001\222\000\000\000\t\000\000\001\223\000\000\000\n\000\000\001\224\000\000\000\011\000\000\001\225\000\000\000\000\001\226\000\012\000\000\000\000\001\227\000\r\000\000\000\000\000\000\000\000\000\000\003\001\002\252\002\253\003\000\002\254\000\000\003\005\000\014\000\000\003\004\000\000\001/\000\000\000\000\003\002\000\000\003\003\000\000\000\000\000\000\000\000\0013\0014\000\000\000\000\0012\0011\000\015\000\000\000\000\000\000\003\031\000\000\003\030") + (16, "\000\000\000\000\000\000\002\233\002\232\002\231\002\230\002\229\002\184\002\228\002\227\002\226\002\225\002\224\002\223\002\222\002\221\002\220\002\219\002\218\002\217\002\216\002\215\002\214\002\213\002\212\002\211\002\210\002\183\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\190\002\189\002\188\002\187\002\186\002\185\000\000\000\000\000\"\000\137\000\000\000\000\000\000\000\000\000\000\000\000\002\153\001b\000\000\000\000\000\000\000\000\000\000\000\000\000_\000Z\000\139\000\000\000\000\000\000\000\000\000\000\002\171\000\000\002r\002s\000\000\002p\002q\000\000\001\188\000]\001\167\001\185\001\184\000\000\001\189\001\193\000\000\000\000\000\000\001x\001w\000\000\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\183\001\187\001\186\001\168\001\191\001\182\001\181\001\180\001\179\001\178\001\176\001\192\001\190\000\000\000\000\000\000\000\233\000\000\000\000\001\171\000\000\000\000\000\000\001\173\000\000\000\000\000\000\001\175\001\197\001\194\001\177\001\169\001\195\001\196\000\000\003*\003+\000\000\000\000\000 \001V\000\000\000\229\000\230\000\000\000\000\000\000\001\221\001\220\000\000\000\000\000\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001v\000\000\000\000\000\000\000\000\000\000\003'\000\000\003\"\000\000\000\000\003$\000\000\003&\000\000\003#\003%\000\000\003\029\000\000\003\028\003\024\002@\000\000\003\027\000\000\002A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001T\000\000\000\000\000\000\000\000\000\000\000\000\000\236\000\017\000\016\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\001c\001a\001h\000:\002\135\000\000\001#\003\002\003\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\026\000\000\000\000\000\000\000\\\000\000\000\244\000\000\002t\000\000\000\000\000\000\001\201\000\000\000\000\000x\000\000\000\000\000\000\000\000\000\000\000\000\001g\000\000\001W\001f\000\000\001U\000W\000\027\000\000\000\000\001\142\000\024\000\000\000\000\000\000\000\000\000o\000\000\000\000\000\000\000\000\000\000\000\000\003\023\000\211\000p\000\142\000q\000\023\000\000\000\000\000\000\000\000\000\028\000\025\000\018\000\000\000r\000n\000\000\000\000\000\000\000\019\000\030\000\000\000\213\002J\002<\000\000\000u\000\000\002=\000\000\000\000\001\198\000\000\000\000\000\000\000\000\003\003\000\000\003\004\000\000\000\000\000t\000\000\000\000\000\000\000v\000\000\000w\000\000\000y\000\000\000\000\000z\0022\0021\000\000\000\000\000\000\000\000\000\000\000\000\000X\000\000\002\176\000[\000^\000Y\002\165\003,\002\166\001\254\002\168\000\000\000\000\002\173\002o\002\175\000\000\000\000\000\000\002\179\000\000\000\000\000\000\001\250\001\241\000\000\000\000\000\000\000\000\000\000\001\240\000\000\001\253\002\182\000\000\000\000\000\000\000\000\001\144\000\000\000\000\001\252\002\174\000f\000\000\000\000\000e\000\000\002\167\000\000\000\000\000\000\000\000\002\181\000\000\000\000\000\000\001\242\001\251\001\245\000\000\000d\000\000\002\180\000\000\002\178\000\000\002u\000\000\000\000\002T\002\177\000\000\000\000\000\000\000\000\001\203\001>\001?\002w\000\000\002v\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\255\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\006\000\000\000\000\000\000\000\000\000\000\000\000\000\253\002\005\000\254\000\000\000\000\000\000\000\203\000\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\214\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002.\000\000\000\000\001\127\000\000\000\000\000\000\000\000\000\000\000\000\003C\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\026\000\000\000\000\000\000\000\000\000\000\001~\000\000\000\000\000\000\001_\001\134\001^\001\131\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-\000\000\000\000\001}\000\000\000\215\000\000\000\000\001p\000\000\000\000\001t\000\000\001\223\000\000\000\000\001\222\001s\001q\000\000\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\000\000\000\000\000\000\000\000\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\002\000\000\000\204\002,\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0027\0025\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\001d\002\144\002\142\000\000\000\000\000\000\002\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\248\000\247\000\000\000\249\000\000\000\000\000\000\002\150\000\000\000\000\000\000\002|\000\000\000\000\000\000\000\000\003-\002\152\002\141\002\140\000\000\000\000\000}\001A\000\000\000\000\000\188\002X\000\000\000\000\000\000\000\000\000\173\000\000\000\000\000\000\000\187\000\000\000\172\000\000\000\171\000\000\000\177\000\000\000\181\000\000\000\175\000\000\000\174\000\000\000\179\000\000\000\170\000\000\000\169\000\000\000\168\000\000\000\167\000\000\000\166\000\000\000\180\000\000\000\178\000\000\000\000\000\000\002G\000\000\000\190\000\000\000\182\000\000\000\183\000\000\000\184\000\202\000\176\000\000\000\000\000\000\000\209\000\000\000\208\000\000\000\000\000\000\000\000\000\000\000\000\001\n\000\000\000\000\001\t\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\002\002\000\002\001\000\000\000\000\000\000\001\003\000\000\000\000\000\000\000\000\000\000\000\000\002\011\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001)\001\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\000\000\000\000\000\000\000\000\000\001\031\000\000\001k\002\251\000\000\000\000\002\250\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\000\000\000\000\000\000\000\0024\000\000\000\000\000\000\000\000\000\000\001\146\000\000\002\017\000\000\000\000\000\000\000\000\000`\000\000\000\000\000a\000\000\000\000\000\000\000\000\001\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\238\000\000\000\000\000j\000\000\000\241\000\239\000\000\000\000\000\000\000\218\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\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\002Z\000b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\157\001\153\000\000\000\000\000\000\000\223\000\000\000\000\002\031\002)\000\000\000\226\002\029\002\030\000\000\000\000\000\000\000\000\000\000\001\160\001\156\001\152\000\000\000\000\000\224\000\000\000\000\001\159\001\155\001\151\001\149\002)\000\000\000\228\000\000\000\000\002\019\000\000\000\000\002c\002(\002&\002'\000\000\000\000\000\000\002)\000\000\000\225\002)\000\000\000\227\000\000\000\000\000\000\000\000\002b\000\000\000\000\000\000\000\000\000\000\000\000\001\166\000\000\000\000\000\000\001\165\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\133\000\000\000\000\000\000\000\000\000\000\001y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001!\002h\000\000\000\000\000\000\002f\000\000\000\000\000\000\002e\000\000\001m\000\000\000\000\000\000\000\000\002l\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0035\000\000\000\000\000\000\000\145\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\000\000\001\140\000\000\000\000\000\000\000\000\000A\000\000\000\000\000\000\002\024\000\000\002\023\000\000\000\000\000\000\000\000\000B\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000G\000\000\000\000\000\000\000H\000F\000\000\000J\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000C\000\000\000I\000\000\000D\000E\000\000\0012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000V\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000S\000\000\000U\000T\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\027\002m\002^\000\000\002d\002_\002k\002j\002i\002g\001,\000\000\002\\\000\000\000\000\000\000\000\000\000\000\002)\000\000\000\000\001%\002`\000\000\000\000\000\000\000\000\000\000\000\000\002)\000\000\000\000\001'\002a\002]\002n\001+\002\b\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\0030\000\000\000\000\0032\000\000\000/\000\000\000\000\0038\000\000\0037\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003/\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\000\000\001S\000\000\000\000\001Q\001O\000\000\001\219\000\000\000\000\000\147\002\237\002+\000\000\0000\000\000\000\000\003;\000\000\003:\000\000\000\000\000\000\001M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\001P\001N\000\000\000\000\000\000\0002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\014\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000O\000\000\000\000\000\000\000\000\000\000\000\000\000,\000\000\000\000\000\000\000\000\000\000\0020\002/\000N\000\000\000*\001\015\000\000\0009\000&\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\r\000\000\000M\000\000\000\000\000P\000\000\000\000\001\205\000\000\000.\000\000\000\000\000\000\000-\000\000\000\000\000\000\0001\000\000\000Q\000\000\0003\0004\000\000\0014\000\000\000\000\000\000\000\000\000\000\000\000\0007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\025\002\254\002\245\000\000\000\000\000\000\000\000\000\000\000\000\001\011\002\249\002\234\002\244\002\253\002\252\000\000\001B\0010\000\000\001\012\000\000\002\242\000\000\002\246\002\243\002\255\002\007\000\000\000\000\002\239\000#\000\000\002\238\000\000\000\000\000\143\000\000\000\235\000\000\002\016\000\020\002F\000\000\000\000\002~\000\000\000\000\002}\000\000\000\000\000\000\000\000\002\128\000\000\000\000\002N\000\000\000\000\002\132\000\000\000\000\002\130\002\147\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\186\000\000\002\127\000\000\000\000\002\131\000\000\000\000\002\129\001\020\000\000\000\000\001\021\000\000\000\000\000\189\000\000\001\023\001\022\000\000\000\000\002\148\000\000\002\160\000\000\002\159\000\000\002\163\000\000\002\162\000\000\000\000\002\149\000\000\000\000\000\000\002\028\000\000\000\000\000\000\000\000\002W\002\027\000\000\002\156\000\000\000\000\000\000\001e\000\000\000{\000|\000\000\000\000\000\000\000\000\000\159\000\000\000\000\000\000\000\133\000\000\000\000\000\000\000\000\000\000\000\000\000\132\000\153\000\000\000\000\001D\000\000\001E\001C\0026\000\000\000\000\000\000\000\000\000\000\000\000\002\134\000\000\002\133\000\000\000\000\002x\000\000\000\000\002\155\000\000\000\000\000\000\002Q\002\146\000\000\002\145\000\000\002\161\000\152\000\000\000\000\000\000\000\000\000\151\000\000\000\000\000\000\000\000\000\000\000\000\000\149\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\150\002\236\001\018\001\217\000\000\000\251\000\252\000\000\000\000\000\000\000\000\000\000\000\000\001\b\000\000\000\000\000\000\000\000\001\007\000\000\000\000\001\006\001\005\000\000\001@\000\000\002\158\000\000\002\157\002\143\000\000\000\000\000\000\000\000\002\136\000\000\000\000\002\137\000\000\002z\000\000\002{\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\224\000\000\000\000\001\227\000\000\000\000\001\225\000\000\000\000\001\226\000\000\001\164\000\000\000\000\000\000\001\163\000\000\000\000\001/\001.\000\000\000\138\000\000\000\000\000\000\000\000\001L\001F\000\000\000\000\001G\001\162\000\000\001\161\000\000\000\000\000\212\000\000\000\000\000\000\000\029\000\026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\158\001\154\000\000\001\150\003\022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\140\000\000\002\248\002$\002%\002 \002\"\002!\002#\000\000\000\000\000\000\000\141\000\000\000\000\000\000\000\000\000\000\000\000\002\247\000\000\001n\000\000\000\000\000s\000\000\0033\000\000\001z\000\000\002\170\000\000\000;\000\000\000\000\000<\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\130\000\000\000\129\000\000\000\000\000\000\000\158\000\000\000$\000\000\000\000\000\000\000\000\000\131\000\000\000\231\000\001\000\000\000\000\000\234\000\002\000\000\000\000\000\000\001Y\001Z\000\003\000\000\000\000\000\000\000\000\001\\\001]\001[\000\021\001X\000\022\000\000\001\228\000\000\000\004\000\000\001\229\000\000\000\005\000\000\001\230\000\000\000\000\001\231\000\006\000\000\000\007\000\000\001\232\000\000\000\b\000\000\001\233\000\000\000\t\000\000\001\234\000\000\000\n\000\000\001\235\000\000\000\011\000\000\001\236\000\000\000\000\001\237\000\012\000\000\000\000\001\238\000\r\000\000\000\000\000\000\000\000\000\000\003\011\003\006\003\007\003\n\003\b\000\000\003\015\000\014\000\000\003\014\000\000\0016\000\000\000\000\003\012\000\000\003\r\000\000\000\000\000\000\000\000\001:\001;\000\000\000\000\0019\0018\000\015\000\000\000\000\000\000\003)\000\000\003(") 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\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\"\001@0$r\000\000\n\001@\001\140\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\128\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\001\128\000\000\016\000\000\000@\000\000\000\000\000\000\000\000\012\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\001\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\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000B@\n\160\002\012\021!\192\001\016\000\236\b\025\000 \018\000A\000\016@\001\n\000\b\000\006 \000\b\000\000\144\002\b\000\130\000\b@\000@\0001\000\000@\000\000\000\000\000 \0000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\004\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\128\007\224\012\t\000\000\248\132\000\129\000 Q`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\002\128\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\000\000\000\000\000\000\000\000\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\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\t\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\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\136\000\000\000\000\000\000\000\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\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\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\192\000\014\002\000\012.\016\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\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\005\128Y\208\004\025\026C\129\131\"\001\216\017\"\017@\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\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\001\128\000\028\004\b\024\\ \000\016\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\001\000 \0160 \128\000\001\000\000\000\000\000\000\b\001\001\000\000\129\129\004\000\000\b\000\000\000\000\000\000@\b\b\000\004\012\b\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\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\000\000\000\000\000\000\000\000\000\000\000g\240\144b\197V\254f\250\002\128\251\137@\003\142\003?\132\131\022*\183\2433\208\020\007\220J\000\028p\000\192\000\004\152 \140\000 \004\000\000\000\000\000\002\000\006\000\000$\129\004`\001\000 \000\000\000\000\000\016\0000\000\001$\b#\000\000\001\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\000@\000\000\000\000\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\000\018@\0020\000\000\016\000\000\000\000\000\b\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\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\001\000\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\002\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\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\016\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\002\000\000\018@\002\000\000\000\016\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\004\000\000\000\000\000\000\000\000\000\000\t\000\"\130\b \020\134\000\004@\003\176\002\004\000\1281\000\003\192\128\003\011\133\000\002\000 \002\000\001\000\002@\b\160\003\b\021!\192\001\016\000\204\b\131\b \012@\000\224 \000\194\225@\000\128\b\000\128\000@\000`\000\135\001\002\006\023\b\000\004\000\000\000\001\000\000\133\128]\192\004\025\026C\129\130\"\001\216\001f\017`\024\000\001\128\000\001\133\194\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\006\000\000`\000\000ap\128\000D\000\000@\000\000\000\016\000\128\000\000\001\000\000\000\002 \000\000\000@\000\001\128\000\028\004\000\024\\ \000\016\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\192g\240\145b\197V\254fz\002\128\251\153@\003\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\0000\016\002\002\000\002\002\b\000\000\016\000\000\000\000\128\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\000\000\000\000\000\000` \004\000\000\004\004\000\000\000 \000\000\000\000\000\007\001\000 \000\000 \000\000\001\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\128\002\000\000\000@\000 \001\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\b\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\002\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\191\214\239\2517\223\251\255\254N\143\238e\132\014y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\2241\184@\017p\163\127\018}\000@}\000\160\000\199\001\141\194\000\139\005\027\248\147\232\002\003\232\005\000\0068\012n\016\004X(\223\196\143@\016\031@(\0001\192cp\196#\241V\254\164z|\194\250A\192\025\174\176\024\132!\016\n\001\129#\144\000\000P\n\000\012`\024\220 \b\176Q\191\137\030\128 >\128P\000s\129\015=\187\215\250\190w\207\239\254\220\031\191\182\255\249\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224\001\136A\0160\001\024\018m\000\016\005\000\000\000\130\000\012B\b\129\000\b\192\147h\000\128(\000\000\004\016\000b\016D\b\000F\004\139@\004\001@\000\000 \128\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\000P\000\000\b \000\196 \b\016\000\140\t\022\128\b\002\160\000\000Q\000\006!\002@\128\004`H\180\000@\021\000\000\002\b\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\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\000D\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\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\002 \000\000\000\000 \000\000\000\016\000\000\000\000\000\000\017\000\000\000\000\000\000\000\000\000\128\000\000\000\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\001\136@\0160\001\024\018i\000\016\005\000\000\000\130\000\012B\000\129\000\b\192\147H\000\128(\000\000\004\016\000b\016\004\b\000F\004\138@\004\001@\000\000 \128\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000&)\027P\144\020`I\172\002@\020\160@\218\170\000\000\b\000\004\000 \000\000 \000\000\128\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\019\020\141\168H\n0$\222\001 \n\208\016mU\000\b\000\000\000\000\001\000\"\128\000\000\000\000\000\000\000\000\196!\b\016\000\140\t\022\128\b\002\160\000\002A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\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\000l\000\000@\000\004\000\b\000\002\128\002b\136\000\196 \b\016\000\140\t\022\128\b\002\160\000\000A\000 \000\027\000\000\016\000\001\000\002\000\000\160\000\152\162\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\000\000\000\000\000\000\000\000\000\000\002b\017\180\b\001F\004\155@$\001Z\000\t\170\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\004\196#h\016\002\140\t6\128H\002\180\000\019U@\007!\136G\224,iH\180\248\196\021\129\0002Y`\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\b\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\128\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\128 @\0020$R\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\128\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\016\000\000\000\000\000\t\130 \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 \004\000\003`\000\002\000\000 \000@\000\020\000\019\020@\006\000\000p\016\000ap\128\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\012B\000\129\000\b\192\145h\000\128*\000\000\004\016\002\000\001\176\000\001\000\000\016\000 \000\n\000\t\138 \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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\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\002\000\000\000\000\000\001 D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\016\129 @\0020$Z\000 \n\128\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\144\000\000\000\000\b\000\000\000\000\000\004\133\016\001\136@\144 \001\024\018-\000\016\005@\000\000\162\000\000\000\000\000\000\000\000\000\000\000\000\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\128\000\000\000\000\128\000\000\000\000\000H\017\000\000\000D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000 \000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\017\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\229$Z\019\004\142\153\245\128\200\002\246\000\027\197P\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\002\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\000\000\128\000\000\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\002\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\016\004\b\000F\004\139@\004\001@\000\000 \128\003\020\128(H\0020$\214\001 \n@\000M\021\128\016\000\000\000\000\001\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\006!\000@\128\004`H\180\000@\021\000\000\002\b\000\000\000@\000\000\000\000\b\000\000\000\004\000\004\193\016\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\016\000\000\000\000\002\000\000\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\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\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\000b\144\005\t\000F\004\138\192\004\001H\000\004\160\128\003\016\128 @\0020$R\000 \n\000\000\001\004\000\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\006!\004@\200$`I\180\000@\021\000\000\002\b\0000\016\002\002\000\002\002\b\000\000\016\000\000\000\000\128\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\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\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\000\192\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\128\016\016\000\b\024\016\000\000\000\128\000\000\000\000\000\004\000\144\128\000@\192\128\000\000\004\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\001\000\004\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\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\004\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\000\000\000\000\000\000\000\000\000\000\000\000\132\128\021@\004\024\nC\128\002 \001\216\000\"\000@\004\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\192\000\004\144\000\140\000\000\004\000\000\000\000\000\002\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\004\000\001\000\000\001\128\000\030\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\007\001\000\006\023\b\000\004\000\000\000\000\000\000\132\128\021@\004\024\nC\128\002 \001\216\000\"\001@\024\000\001\192@\001\133\194\000\001\000\000\000\000\000\000! \005P\001\006\002\144\224\000\136\000v\000H\128Q\t\000*\128\b0\020\135\000\004@\003\176\002D\000\1280\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\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\016\144\002\168\000\131\001Hp\000D\000;\000$@\b\000\000\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\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\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000B@\n\160\002\012\005!\192\001\016\000\236\000\017\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\002\000\000\000\001\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\004$\000\170\000 \193R\028\000\017\000\014\192\129\144\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\004\000\128\128\000@\192\128\000\000\004\000\000\000\000\000\016\144\002\168\000\131\001Hp\000D\000;\000\004@\b\001\000 \000\0160 \000\000\001\000\000\000\000\000\004$\000\170\000 \192R\028\000\017\000\014\192\001\016\002\000\000\000\000\000\000\000\000\000\000\000\000\016\004\004\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\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\016\144\002\168\000\131\005Hp\000D\000;\002\004@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004$\000\170\000 \192R\028\000\017\000\014\192\001\016\002\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\000B@\n\160\002\012\005!\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\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\000\000\000\000\000\002\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000B@\n\160\002\012\021!\192\001\144\000\236\000\019\000 \028\004\016\128\000\000\128\128\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\004\000\000\000 \000\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@\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\000\000\000\000\000\000\000\000\000\000\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\144\002\168\000\131\005Hp\000d\000;\002\004\192\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\004\000\b\000\000\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\198\225\002E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\000\000\000\001\000\000\000\000\128\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\004\000 \000\000\000\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\000b\016\004@(\006\004\142@\000\001@(\0001\128\128\000\b\128\000\000\000\000\000\000`\000@\144$\000\000\024\132\001\016\n\001\129#\144\000\000P\n\000\012`\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\006!\000DB\128`I\228\000\000\020\002\128\003\024\0001\b\002 \020\003\002O \000\000\160\020\000\024\192\001\136@\017\000\160\024\0189\000\000\005\000\160\000\198\001\141\194\000\139\133\027\248\147\232\002\003\232%\000\0068\012n\016\004X(\223\196\159@\016\031A(\0001\192cp\128\"\193F\254$z\000\128\250\t@\001\142\003\027\132\001\023\n7\241'\208\004\007\208\n\000\012p\024\220 \b\176Q\191\137>\128 >\128P\000c\128\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\017@\001\136@\016 \001\024\018m\000\016\005@\000\000\138\000\012B\000\129\000\b\192\145h\000\128*\000\000\004P\000b\016\004\b\000F\004\139@\004\001P\000\000 \128\016\000\000\000\000\b\000\000\128\000\000\000\000\000H\017\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\197 \n\026\000\140\t5\128\b\002\128\000\000A\000\006)\000P\144\004`I\172\000@\020\000\000\002\b\0001H\002\132\128#\002E`\002\000\160\000\000\016@\001\200b\017\248\011\026R->1\005`@\012\150X\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\003\020\128(H\n0$V\000 \n\000\000\005\004\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\196 \b\024\000\140\t6\128\b\002\160\000\000A\000\006!\000@\128\004`I\180\000@\021\000\000\002\b\0001\b\002\004\000#\002E\160\002\000\168\000\000\016@\000\000\000\000\000\000\000\000@\000\128\000 \000$\b\129\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\000\016\000\018\004@\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\0001\b\002 \020\003\002G \000\000\160\020\000\024\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\004<\246\239_\234\249\215?\191\251p~\254\219\255\239\128@\000\000\000\000\012\001\028\000\000\000\000\000\000\000\000\198\225\136G\226\173\253H\244\249\133\244\131\1283]`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0001\184B\017`\163\127\018=\000@}\000\160\000\199\001\141\194\016\139\005\027\248\145\232\002\003\232\005\000\0068\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\000\000\000\000\b\000 \000\000\000\000\000\001\000\000\002\000@@\000 `@\000\000\002\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\001\141\194\016\139\005\027\248\145\232\002\003\232\005\000\0068\012n\016\132X(\223\196\143@\016\031@(\0001\192\003\016\132 @\0020$Z\000 \n\000\000\001\004\000\000\000\000\000\000\000\000\004\000\000\000\002\000\002`\136\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\001\136@\017\016\160\024\018y\000\000\005\000\160\000\198\000\012B\000\136\005\000\192\147\200\000\000(\005\000\0060\000b\016\004@(\006\004\142@\000\001@(\0001\128\132\138]\193\244\031\n\195\129\255n\005\222\155~p\240\024\132\001\016\n\001\129#\144\000\000P\n\000\012`!\231\183z\255W\206\185\253\255\219\131\247\246\223\255|\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\2241\184@\017`\163\127\018=\000@}\000\160\000\199\002\030{w\175\245|\235\159\223\253\184?\127m\255\243\192\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\000\000\000\001 \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\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\016\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\000\001\144\000\000\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\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@\017\000\160\024\0189\000\000\005\000\160\000\198\002\030{w\175\245|\235\159\223\253\184?\127m\255\247\192\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\b\000\000\000\000\001\128\002\128\000\000\000\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\000BE.\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\243\219\189\127\171\231\\\254\255\237\193\251\251o\255\158\132\138]\193\244\031\n\195\129\255n\005\222\155~p\240\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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!\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\000\000\000\000\000\000\000\000\b\000\000\000\000\000\002\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\bH\165\220\031A\240\1728\031\242\224]\224\183\231\0151\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\204n\016\004X(\223\196\143@\016\031@(\0001\192\132\138]\193\244\031\n\195\129\255.\005\222\011~p\240\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000!\231\183z\255W\206\185\253\255\219\131\247\246\223\255=\t\020\187\131\232>\021\135\003\254\220\011\1896\252\225\2307\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\003\159\235w\143\213\127\251\159\239\254\187\255}-\255\251\215\183d@\130\254*@\0010p:q\193`Phcp\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\000\000\000\000\000\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\002\018)w\007\208|+\014\007\252\184\023x-\249\195\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!\"\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\0151\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\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!\"\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\0151\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\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!\"\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\0151\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\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!\"\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\0151\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\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!\"\151p}\007\194\176\224\127\203\129w\130\223\156<\006!\000@\128\004`I\180\000@\020\000\000\002\b\0001\b\002\004\000#\002E\160\002\000\160\000\000\016@\000\000\000\000\000\000\000\000@\000\000\000 \000&\b\128\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\016\000\018\004@\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\001\136@\016 \001\024\018-\000\016\005@\000\000\130\000\000\000\000\000\000\000\000\002\000\000\000\001\000\001 D\000b\016\004\b\000F\004\139@\004\001P\000\000 \128\000\000\000\000\000\000\000\000\128\000\000\000@\000H\017\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\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\b\000\t\002 \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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \020\134\000\006@\0030\000\004\000\139\219\178 A\127\021 \000\1528\0298\224\176(43\248H\181b\171\1273=\001@}\192\160\003\199\000\012B\000\129\000\b\192\145h\000\128*\000\000\004\016\002\000\000 \000\000\000\000\016\000\000\000\000\000\t\002 cp\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\224\000\128\b\000\000\000 \000\000\000\000\000\000\000\000\002\000\000\000@\000 \001\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\b\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\000\016@)\012\000\b\128\007`\000\b\000\000 \004\004\000\002\006\004\000\000\000 \000\000\000\000\000\132\128\017@\004\024\nC\128\002 \001\152\000\002\000\000$\000\138\000 \128R\024\000\017\000\012\192\000\016\000\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\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\024\b\001\000\000\001\001\000\000\000\b\000\000\000\000\000\001 \004P\001\004\n\144\224\000\200\000f\000\000\128\016\002\000@@\000 `@\000\000\002\000\000\000\000\000\b\000\000\000\000\000\128\000\b\000\000\000\004\000\000\000\000\001\128\128\016\000\000\016\016\000\000\000\128\000\000\000\000\000\018\000E\000\016@\169\014\000\012\128\006`\000\b\001\000\144\002(\000\130\001H`\000D\0003\000\000@\b\004\128\017@\004\016\nB\000\002 \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\128\000\b\000\000H\001\020\000A\000\1640\000\"\000\025\128\000 \004\002@\b\160\002\b\005!\000\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\000\000\004\000\000\000\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\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\023\183d@\130\254*@\0010p:q\193`Phg\240\145j\197V\254fz\002\128\251\129@\007\142\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\000H\001\020\000A\002\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\128\000\192\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\000\016\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\192\000\014\002\000\012.\016\000\b\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\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\144\002(\000\130!Hp0D\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\001 $P\001\004\002\144\192\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016D)\014\006\b\128\007`\004\b\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\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\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\194\001Hp\000D\000;\000\000\192\000\003\000\0000\000\0000\184P\000 \000\000\000\000\000\000\000\000\000\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\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\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\b\128\000\000\000\000\128\000\002\000\000\000\000\001\000\000\000D\000\000\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\000\000\000\000\001\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\004@\000\000\000\000@\000\001\000\000\000\000\000\128\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 \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\128\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\002\192(\160\002\012\r!\192\001\144\000\204\000\129\b \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\176\n(\000\130\003Hp\000d\0003\000 B\b\001\016\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 \004P\001\004\002\144\224\000\136\000f\004\000\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\000\000\000\000\000\000\128\000\002@\b\160\002\b\005!\192\001\016\000\204\000\001\000\000\018\000E\000\016@)\012\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\000\0000\000\0000\184P\000 \000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\128\000\000\000\192\000\012\000\000\012.\020\000\b\000\000\000\000\000\000\000\000\000\000\000\016\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\002\192\b\160\002\b\r!\192\001\144\000\204\000\129\b \022\001E\000\016`i\014\000\012\128\006`\004\bA\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\003\000\0000\000\0000\184@\000 \000\000\000\000\000\000,\000\138\000 \128\210\028\000\025\000\012\192\b\016\130\001`\020P\001\006\006\144\224\000\200\000f\000@\132\016\t\000\"\128\b \020\135\000\004@\0030\000\004\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\240\002/\001\130\006\031H\000D\0000\000\000@\000\003\000\000\018`\1300\000\128\016\000\000\000\000\000\b\000\024\000\000\146\004\017\128\004\000\128\000\000\000\000\000@\000\192\000\004\144 \140\000\000\004\000\000\000\000\000\002\000\006\000\000$\128\004`\000\000 \000\000\000\000\000\016\000\016\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\002@\b\160\130\b\000!\128\001\000\000\236\000\137\000 \012@\000\240 \000\194\225@\000\128\b\000\128\000@\000`\000'\001\000\006\023\b\000\004\000\000\000\000\002\128\000\000\000\000\000 \016\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\000Y\001\020\000A\002\1644\000\"\0009\128\016 \004\002@\b\160\003\b\005!\192\001\016\000\204\000\131\b \018\000E\000\016@)\014\000\b\128\006`\004\bA\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 \001\152\001\002\016@\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\000H\001\020\000A\000\0040\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\000\000\000\000\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\128\002 \001\216\001\002\000@\b\128\000 \000\001\000\002\128\000\000\016\001\000\000\128\000D\000\000\000\000\b\000\020\000\000\000\128\b\000\004\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\004\128\017@\006\016\nC\128\002 \001\152\001\006\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\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\001 \004P\001\004\002\144\192\000\136\000f\000@\128\016\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\136\000\002\000\000\016\000 \000\000\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\000\000\004\000\b\000\000\000@\000\000\002\000\004\128\017@\004\016\000C\000\002\000\001\152\000\002\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\138\000 \128\002\024\000\016\000\012\192\b\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\000H\001\020\000A\000\1640\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\"\000\000\128\000\004\000\b\000\000\000@\000\000\002\000\001\016\000\000\000\000 \000@\000\000\002\000\000\000\016\000$\000\138\000 \128\002\024\000\016\000\012\192\000\016\128\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\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\002\000\000\000\000\b\004\000 \000\000\000\000\000\000\002\000\000\000\000\000\000@ \001\000\000\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\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\144\000\012n\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\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\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 \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\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\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\016\000\001\000\000\004\001\014\006\000\000\000 \004\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\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\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\016\000\000@\002\000\000\000\000\000\000\000 \000\000\000\000\128\000\002\000\016\000\000\000\000\000\000\000\000\000\000\000\004\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000b\144\005\t\000F\004\138\192\004\001H\000\004\160\128\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000 \000\000\128!\128\192\000\000\004\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\128\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\004\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\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\024\164\001B@\017\129\"\176\001\000R\000\000( \000\224\000\014\002\000\012.\016\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\001\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\002\000\000\000\001\000\000\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\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\000\000\000\000\000\000\000\000\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\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\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\b\000\001\000\b\001\145\006\000\000\002\000\000\000\000@\000@\000\b\000@\012\1360\000\000\016\000\000\000\000\000\002\000\000@\002\000d@\128\000\000\128\000\000\000\000\000\016\000\002\000\016\003\"\004\000\000\004\000\000\000\000\000\001\136A\0162\001\024\018m\000\016\005\000\000\000\130\002\246\236\136\016_\197H\000&\014\007N8,\n\r\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 \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\016\000\000\000\000\000\000\b\000\000\000\000\000\000\000\128\000\128\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\002\000\000\000\001\000\000 \001\0002 @\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@\000\000\000\000\000\000\000\000\000\000\016\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\138@\020$\001\024\018k\000\016\005\000\000\000\130\000\012R\000\161 \b\192\145X\000\128(\000\000\004\016\000b\144\005\t\001F\004\138\192\004\001@\000\000 \128\001\000\000 \001\0002 @\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\002\000@\000\b\000@\012\136\016\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000yIV\160\213\019\166\127x\"\000\185\148\016x\212\001\136@\017\000\160\024\0189\000\000\005\000\160\000\198\002\030{w\175\245|\235\159\223\253\184?\127m\255\247\208\243\219\189\127\171\231\\\254\255\237\193\251\251o\255\190\007\148\149j\rQ:g\247\130 \011\153A\007\141@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\024\132\017\002\000\017\129&\208\001\000P\000\000\b \000\196 \136\016\000\140\t\022\128\b\002\128\000\000A\000\006!\000@\128\004`H\180\000@\020\000\000\002\b\000H\001\020\000A\000\1640\0002\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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@\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\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\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 \004P\001\004\002\144\128\000\136\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\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\004\128\017@\004\016\nB\000\002\000\001\152\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\000H\001\020\000A\000\164 \0002\000\025\128\000 \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016@)\b\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\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\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\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\001 \000\000\000\000\000\000\000\000\002\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\000\000M\129\240\006\000\128\128|\002\000@\000X`3\027\132-\022\n7\241#\208\004\007\208\n\000\014p\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\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\000\000\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\000C\207n\245\254\175\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\255W\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\171\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\175\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\255W\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\171\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\245|\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\250\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\253_;\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\250\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\245|\235\159\223\252\184?}-\255\243\192\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\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\0001\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\b1\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\016\004\b\000F\004\139@\004\001@\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\196!\b\128P\012\t\028\128\000\002\128P\000c\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\231\000\000\000\000\000\000\000\000\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\003\027\132\t\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\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\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\003\016\128\"\001@0$r\000\000\n\001@\001\140\004\000\000\000\000\000\000\000\000\000\003\000\000\004\128\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\136\000\000\000\000\000\000\000\000\004\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\001\000\000\000\000\000\000\001\016\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\128\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\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\0000\000\000H\000\000\000\004\000\000\000\000\000\192\017\192\000\000\000\000\000\000\000\016\000\001\016\000\000\000\000\000\000\012\000\b\018\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\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\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\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\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\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\012n\016\004X(\223\196\143@\016\031@(\0001\192\000\000\000\000\000\000\000\000\000\000\000\000\000\002\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\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\001\200b\017\248\011\026R->1\005`@\012\150X\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\003\020\128(H\n0$V\000 \n\000\000\005\004\000\024\000\001\128\000\001\133\194\000\001\000\000\000\000\000\000\000@\000\000\000\002\004\000\000\000\b\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\001\138@\020$\005\024\018+\000\016\005\000\000\002\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\000\000\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\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\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\001\141\194\000\139\005\027\248\145\232\002\003\232\005@\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\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<\006!\000@\128\004`H\180\000@\021\000\000\002\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\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012n\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!\"\151p}\007\194\176\224\127\203\129w\130\223\156<\000\000\000\000\000\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\002\018)w\007\208|+\014\007\253\184\023zm\249\195\192\000\b\000>\000\192\016\016\015\128\192\b\000\011\004\006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004<\246\239_\234\249\215?\191\251p~\254\219\255\239\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\136\031\000`\b\b\007\192\160\004\000\005\130\003\000\000\004\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\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\128\001\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\006\000\000\000@\000\000\001\000\000\000\000\000\000\000\000\0000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\001\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\001\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000D\000\000\b\000\b\0000\000\000\000\128\000\000\000\000\002 \000\000\000\000@\001\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\000\000\000\001\000\000\000@\000\128\000\000\000\002\000\000\000\000\000\000\000\000\000\002\000\004\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\003\001\000 \000 \128\000\001\000\000\000\000\000\000\024\b\001\000\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\000\000\000\b\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\000\128\016\016\000\b\024\016\000\000\000\128\000\000\000\000\002\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\000\000\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\b\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\000\002@\b\160\002\b\021!\192\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` \004\000\000\004\004\016\000\000 \000\000\000\000\000\003\001\000 \000\000 \000\000\001\000\000\000\000\000\000$\000\138\000 \129R\028\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\134\000\004\000\0030\000\004\000\000H\001\020\000A\000\164 \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\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\016\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\128\000\000\000\000\000\006\000\000`\000\000aq\128\000D\000\000@\000\000\0000\000\003\000\000\003\011\132\000\002 \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 \001\000\000\000\002\000\000\000\004@\000\000\000\000\000\003\000\0000\000\0000\184@\000\"\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\000\000\004\000\000\000\000\000\000\000\000\000\000\000@\000\000\b\000\000\000\000\000\128\000\000\001\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\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\016\000\000\000\000\002\000\000\000\000\000\001\000\000\000\000\000\128\000\000\000\000\016\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\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\016\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\144\002(\000\130\001Hp\000D\0003\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\002 \000\b\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\000\000\018\000E\000\024@)\014\000\b\128\007`\000\024@\000\"\000\000\000\000\004\000\b\000\000\000@\000\000\000\000\004\128\017@\004\016\nC\128\002 \001\152\000\002\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004P\001\004\002\144\192\000\136\000f\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\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\004\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\144\002( \130\001H`\000D\000;\000 @\b\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\b\128\000 \000\001\000\002\000\000\000\016\000\000\000\128\000D\000\000\000\000\b\000\016\000\000\000\128\000\000\004\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\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\016\144\002\168\000\131\005Hp\000D\000;\000\004@\b\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\192\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\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\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\000\000\000\000\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\024\132\001\002\000\017\129\"\208\001\000T\000\000\b\160!\"\151p}\007\194\176\224\127\203\129w\130\223\156=\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\2241\b\002\004\000#\002E\160\002\000\168\000\000\017@BE.\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\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\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\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\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\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\004\128\016@\004\016\000B\000\002\000\001\144\000\002\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\017\000\000\000\000\003\000\004\000\000\000 \000\000\000\000\000\000\"\001\248\003\002@\000>!\000 @\012\020X\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\b\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\004\000?\000`H\000\007\196 \004\b\001\130\139\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\001\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\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\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\192\000\014\002\000\012.\016\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\b\000\000\000\001\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\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\002\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\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\016\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192@\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\000\002\000\b\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\004\000\128\128\000@\192\128\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\128\000\000\000\000\b\000\000\128\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\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\001\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\016\000\000\000\002\000\t\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\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\000\000\000\000\000\000@\000\000\000 \000\000\000\000\006\000\000\000\000\000\000\000\000\000\000g\240\144b\197V\254fz\002\160\251\145@\003\142\000\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\001d$\016\001\004\014\144\128\128\136\000\228\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\004\128\016@\004\016\nB\000\002 \001\144\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\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!\000\001\000\000\192\000\001\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\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\000\000\000\000\000\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\2243\248H1b\171\1273=\001P}\200\160\001\199\000\018\000A\000\016@)\b\000\b\128\006@\000\b\000\000\144\002\b\000\130\001H@\000D\0002\000\000@\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\b\000\130\001H`\000D\0002\000\000@\000\004\128\016@\004\016\nB\000\002 \001\144\000\002\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") + (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\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\"\001@0$r\000\000\n\001@\001\140\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\128\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\001\128\000\000\016\000\000\000@\000\000\000\000\000\000\000\000\012\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\001\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\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000B@\n\160\002\012\021!\192\001\016\000\236\b\025\000 \018\000A\000\016@\001\n\000\b\000\006 \000\b\000\000\144\002\b\000\130\000\b@\000@\0001\000\000@\000\000\000\000\000 \0000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\004\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\128\007\224\012\t\000\000\248\132\000\129\000 Q`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\002\128\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\000\000\000\000\000\000\000\000\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\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\t\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\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\136\000\000\000\000\000\000\000\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\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\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\192\000\014\002\000\012.\016\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\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\005\128Y\208\004\025\026C\129\131\"\001\216\017\"\017@\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\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\001\128\000\028\004\b\024\\ \000\016\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\001\000 \0160 \128\000\001\000\000\000\000\000\000\b\001\001\000\000\129\129\004\000\000\b\000\000\000\000\000\000@\b\b\000\004\012\b\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\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\000\000\000\000\000\000\000\000\000\000\000g\240\144b\197V\254f\250\002\128\251\137@\003\142\003?\132\131\022*\183\2433\208\020\007\220J\000\028p\000\192\000\004\152 \140\000 \004\000\000\000\000\000\002\000\006\000\000$\129\004`\001\000 \000\000\000\000\000\016\0000\000\001$\b#\000\000\001\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\000@\000\000\000\000\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\000\018@\0020\000\000\016\000\000\000\000\000\b\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\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\001\000\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\002\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\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\016\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\002\000\000\018@\002\000\000\000\016\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\004\000\000\000\000\000\000\000\000\000\000\t\000\"\130\b \020\134\000\004@\003\176\002\004\000\1281\000\003\192\128\003\011\133\000\002\000 \002\000\001\000\002@\b\160\003\b\021!\192\001\016\000\204\b\131\b \012@\000\224 \000\194\225@\000\128\b\000\128\000@\000`\000\135\001\002\006\023\b\000\004\000\000\000\001\000\000\133\128]\192\004\025\026C\129\130\"\001\216\001f\017`\024\000\001\128\000\001\133\194\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\006\000\000`\000\000ap\128\000D\000\000@\000\000\000\016\000\128\000\000\001\000\000\000\002 \000\000\000@\000\001\128\000\028\004\000\024\\ \000\016\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\192g\240\145b\197V\254fz\002\128\251\153@\003\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\0000\016\002\002\000\002\002\b\000\000\016\000\000\000\000\128\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\000\000\000\000\000\000` \004\000\000\004\004\000\000\000 \000\000\000\000\000\007\001\000 \000\000 \000\000\001\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\128\002\000\000\000@\000 \001\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\b\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\002\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\191\214\239\2517\223\251\255\254N\143\238e\132\014y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\2241\184@\017p\163\127\018}\000@}\000\160\000\199\001\141\194\000\139\005\027\248\147\232\002\003\232\005\000\0068\012n\016\004X(\223\196\143@\016\031@(\0001\192cp\196#\241V\254\164z|\194\250A\192\025\174\176\024\132!\016\n\001\129#\144\000\000P\n\000\012`\024\220 \b\176Q\191\137\030\128 >\128P\000s\129\015=\187\215\250\190w\207\239\254\220\031\191\182\255\249\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224\001\136A\0160\001\024\018m\000\016\005\000\000\000\130\000\012B\b\129\000\b\192\147h\000\128(\000\000\004\016\000b\016D\b\000F\004\139@\004\001@\000\000 \128\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\000P\000\000\b \000\196 \b\016\000\140\t\022\128\b\002\160\000\000Q\000\006!\002@\128\004`H\180\000@\021\000\000\002\b\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\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\000D\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\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\004\000\000\000\000\000\000\002\000\000\000\001\000\000\000\000\0000\024@\000\000\000\000\000\000\000\000\024\000\001\192@\129\133\194\000\001\000\000\000\000\000\000\000\192\000\012\000\000\012.\016\000\b\000\000\000\000\000\000\000\000\000\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\011\000\187\128\b24\135\003\004D\003\176\002\196\"\1920\000\003\000\000\003\011\132\000\002\000\000\000\000\000\000B\192.\224\002\012\141!\192\193\017\000\236\000\177\b\176\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\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\000B@\014\224\002\012\133!\192\193\017\000\236\000\177\b\160\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\000\000\000\000\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\001\000\000\000\000\000\128\000\002\000\000\000\000\017 \000\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\004H\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\b\000\000 \000\000\000\001\000\000\000\000\128\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\002\000\003\000\0008\b\0000\184@\000 \000\000\000\000\004\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\000\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\001\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\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\000\000\000\000\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\138F\212$\005\024\018k\000\144\005(\0166\170\128\000\002\000\001\000\b\000\000\b\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\004\197#j\018\002\140\t7\128H\002\180\004\027U@\002\000\000\000\000\000@\b\160\000\000\000\000\000\000\000\0001\bB\004\000#\002E\160\002\000\168\000\000\144@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012B\000\129\128\b\192\147h\000\128*\000\000\004\016\000b\016\004\b\000F\004\155@\004\001P\000\000 \128\003\016\128 @\0020$Z\000 \n\128\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\027\000\000\016\000\001\000\002\000\000\160\000\152\162\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\012B\000\129\000\b\192\145h\000\128*\000\000\004\016\002\000\001\176\000\001\000\000\016\000 \000\n\000\t\138 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\152\132m\002\000Q\129&\208\t\000V\128\002j\168\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0011\b\218\004\000\163\002M\160\018\000\173\000\004\213P\001\200b\017\248\011\026R->1\005`@\012\150X\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\002\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\196 \b\016\000\140\t\020\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\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\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\004\000\000\000\000\000\002`\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\016\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\003\016\128 @\0020$Z\000 \n\128\000\001\004\000\128\000l\000\000@\000\004\000\b\000\002\128\002b\136\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\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\128\000\000\000\000\000H\017\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\196 H\016\000\140\t\022\128\b\002\160\000\000A\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\002\000\000\000\000\000\001!D\000b\016$\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\000\000\002 \000\000\000\000 \000\000\000\000\000\018\004@\000\000\017\000\000\000\000\000\000\000\000\000\000\000\000\000\0000\000\b\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000yI\022\132\193#\166}`2\000\189\128\006\241T\000\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\000\000\128\000\000\000\000\000\000\000\000\b\000\000\128\000\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000\000\000 \000\000\000\000\004\000\000\000\002\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\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\128\000\000\000\000\000\000\000\000\b\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\024\132\001\002\000\017\129\"\208\001\000P\000\000\b \000\197 \n\018\000\140\t5\128H\002\144\000\019E`\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\001\136@\016 \001\024\018-\000\016\005@\000\000\130\000\000\000\016\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\004\000\000\000\000\000\128\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\196 \b\016\000\140\t\020\128\b\002\128\000\000A\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\001\136A\0162\t\024\018m\000\016\005@\000\000\130\000\012\004\000\128\128\000\128\130\000\000\004\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000 \004\004\000\002\006\004\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@\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 \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\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\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\000\000\000\000\000\000\000 \000\b\000\000\004\000\128\128\000@\192\128\000\000\004\000\000\000\000\000\016\144\002\168\000\131\001Hp\000D\000;\000\004@\b\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\128\000\000\000@\000\000\000\000\004\000\000\000\000\000\000\000\000\000\001\t\000*\128\b0T\135\000\004@\003\176 d\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\001\000 \000\0160 \000\000\001\000\000\000\000\000\004$\000\170\000 \192R\028\000\017\000\014\192\001\016\002\000@\b\b\000\004\012\b\000\000\000@\000\000\000\000\001\t\000*\128\b0\020\135\000\004@\003\176\000D\000\128\000\000\000\000\000\000\000\000\000\000\000\004\001\001\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\018\000U\000\016`\169\014\000\b\128\007`@\136\001\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\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\001\t\000*\128\b0\020\135\000\004@\003\176\000D\000\128\b\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\016\144\002\168\000\131\001Hp\000D\000;\000\004@\b\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 \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\000\000\000\000\000\000\128\000\000\000\000\000\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\016\144\002\168\000\131\005Hp\000d\000;\000\004\192\b\007\001\004 \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\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\000\000\000\000\000\000\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\1290\002\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\002\000\000\000\000\000\000\0067\b\002,\020o\226G\160\b\015\160\020\000\024\2241\184@\145`\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\001\000\000\000\000\000\000\000\001\000\b\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\024\132\001\016\n\001\129#\144\000\000P\n\000\012` \000\002 \000\000\000\000\000\000\024\000\016$\t\000\000\006!\000D\002\128`H\228\000\000\020\002\128\003\024\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\001\136@\017\016\160\024\018y\000\000\005\000\160\000\198\000\012B\000\136\005\000\192\147\200\000\000(\005\000\0060\000b\016\004@(\006\004\142@\000\001@(\0001\128cp\128\"\225F\254$\250\000\128\250\t@\001\142\003\027\132\001\022\n7\241'\208\004\007\208J\000\012p\024\220 \b\176Q\191\137\030\128 >\130P\000c\128\198\225\000E\194\141\252I\244\001\001\244\002\128\003\028\0067\b\002,\020o\226O\160\b\015\160\020\000\024\2241\184@\017`\163\127\018=\000@}\000\160\000\199\000\012B\000\129\128\b\192\147h\000\128*\000\000\004P\000b\016\004\b\000F\004\155@\004\001P\000\000\"\128\003\016\128 @\0020$Z\000 \n\128\000\001\020\000\024\132\001\002\000\017\129\"\208\001\000T\000\000\b \004\000\000\000\000\002\000\000 \000\000\000\000\000\018\004@\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\0001H\002\134\128#\002M`\002\000\160\000\000\016@\001\138@\020$\001\024\018k\000\016\005\000\000\000\130\000\012R\000\161 \b\192\145X\000\128(\000\000\004\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\128(H\n0$V\000 \n@\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\016\000\000\000\000\000\000\000\000\b\000\0000\000\003\000\000\003\011\132\000\002\000\000\000\000\000\000\000\128\000\000\000\004\b\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\012n\016\004X(\223\196\143@\016\031@(\0001\192\003\016\128 `\0020$\218\000 \n\128\000\001\020\000\024\132\001\002\000\017\129&\208\001\000T\000\000\b\160\000\196 \b\016\000\140\t\022\128\b\002\160\000\000E\001\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\2241\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\000\000\000\000\000\000\000\000\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\n\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\245|\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\136P\012\t<\128\000\002\128P\000c\000\006!\000D\002\128`I\228\000\000\020\002\128\003\024\0001\b\002 \020\003\002G \000\000\160\020\000\024\192BE.\224\250\015\133a\192\255\183\002\239M\1918x\012B\000\136\005\000\192\145\200\000\000(\005\000\0060\016\243\219\189\127\171\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\000\196 \b\024\000\140\t6\128\b\002\160\000\000E\000\006!\000@\128\004`I\180\000@\021\000\000\002(\0001\b\002\004\000#\002E\160\002\000\168\000\000\017@BE.\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\243\219\189\127\171\231\\\254\255\237\193\251\251o\255\158\000\000\000\000\000\0000\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\t\000\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\200\000\000\000\000\b\000\000\000\004\000\000\000\000\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\0002\000\000\000\000\002\000\000\000\001\000\000\128\000\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\012\128\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\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\012B\000\136\005\000\192\145\200\000\000(\005\000\0060\016\243\219\189\127\171\231\\\254\255\237\193\251\251o\255\190\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\018)w\007\208|+\014\007\252\184\023x-\249\195\204n\016\004X(\223\196\143@\016\031@(\0001\192\135\158\221\235\253_:\231\247\255n\015\223\219\127\252\244$R\238\015\160\248V\028\015\251p.\244\219\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\001\012n\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\000\000\000\000\000\000\000\000\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\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\018)w\007\208|+\014\007\252\184\023x-\249\195\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\000\001\015=\187\215\250\190u\207\239\254\220\031\191\182\255\249\232H\165\220\031A\240\1728\031\246\224]\233\183\231\0151\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\012n\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\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\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\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\012n\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\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\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\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\012n\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\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\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\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\012n\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\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\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\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000b\016\004\b\000F\004\155@\004\001@\000\000 \128\003\016\128 @\0020$Z\000 \n\000\000\001\004\000\000\000\000\000\000\000\000\004\000\000\000\002\000\002`\136\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\002\000\000\000\001\000\001 D\012n\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\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\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\001\136@\016 \001\024\018-\000\016\005@\000\000\130\000\000\000\000\000\000\000\000\002\000\000\000\001\000\001 D\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\001H`\000d\0003\000\000@\b\189\187\"\004\023\241R\000\t\131\129\211\142\011\002\131C?\132\139V*\183\2433\208\020\007\220\n\000\224P\001\227\129{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\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\000\000\000\000\000\000` \004\000\000\004\004\000\000\000 \000\000\000\000\000\004\128\017@\004\016*C\128\002 \001\152\000\002\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\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\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\002\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\002\000\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\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\t\000\"\128\b\"\020\135\003\004@\003\176\002\004\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\018\002E\000\016@)\012\000\b\128\006`\000\b\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 \001\152\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004P\001\004B\144\224`\136\000v\000@\128\000\002 \000\000@\000@\001\128\000\000\004\000\000\000\000\000\017\000\000\000\000\002\000\012\000\000\000 \000\000\000\000\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\128\000\000\000\000\000\000\000\000\000\000\001\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\t\000\"\128\012 \020\135\000\004@\003\176\000\012\000\0000\000\003\000\000\003\011\133\000\002\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\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\000\000\000\004\000\000\000\000\000\000\000\000\000\004\000\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\000\000\000\016\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\016\000\004\002\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\000D\000\000\000\000\004\000\000\016\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\b\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\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 \128\017\000\000\000\000\002\000\004\000\000\000 \000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\004\000\000\018\000E\000\016@)\014\000\b\128\006`@\b@\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\138\000 \128R\028\000\017\000\012\192\000\016\000\001 \004P\001\004\002\144\192\000\136\000f\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0000\000\003\000\000\003\011\133\000\002\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\b\000\000\000\012\000\000\192\000\000\194\225@\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\0000\000\0000\184@\000 \000\000\000\000\000\000,\000\138\000 \128\210\028\000\025\000\012\192\b\016\130\001`\020P\001\006\006\144\224\000\200\000f\000@\132\016\000\000\000\000\000\016\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\002\192\b\160\002\b\r!\192\001\144\000\204\000\129\b \022\001E\000\016`i\014\000\012\128\006`\004\bA\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\000\"\240\024 a\244\128\004@\003\000\000\004\000\0000\000\001&\b#\000\b\001\000\000\000\000\000\000\128\001\128\000\t A\024\000@\b\000\000\000\000\000\004\000\012\000\000I\002\b\192\000\000@\000\000\000\000\000 \000`\000\002H\000F\000\000\002\000\000\000\000\000\001\000\001\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000$\000\138\b \128\002\024\000\016\000\014\192\b\144\002\000\196\000\015\002\000\012.\020\000\b\000\128\b\000\004\000\006\000\002p\016\000ap\128\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\144\017@\004\016*C@\002 \003\152\001\002\000@$\000\138\0000\128R\028\000\017\000\012\192\b0\130\001 \004P\001\004\002\144\224\000\136\000f\000@\132\016\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\004\128\017@\004\016\000C\000\002\000\001\152\001\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\000H\001\020\000A\000\1648\000\"\000\029\128\016 \004\000\136\000\002\000\000\016\000(\000\000\001\000\016\000\b\000\004@\000\000\000\000\128\001@\000\000\b\000\128\000@\000\000\000\000\000\004\002\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\000H\001\020\000a\000\1648\000\"\000\025\128\016a\004\002@\b\160\002\b\005!\192\001\016\000\204\000\129\b \000\000\000\000\000\000\000\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\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\018\000E\000\016@)\012\000\b\128\006`\004\b\001\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\b\128\000 \000\001\000\002\000\000\000\016\000\000\000\128\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 \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\000\000\000\000\000\000\000\000\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\001 \004PA\004\000\016\192\000\128\000v\000D\128\016\006 \000x\016\000ap\160\000@\004\000@\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\b\160\002\b\000!\128\001\000\000\204\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\004\128\017@\004\016\nC\000\002 \001\152\001\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\b\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\002@\b\160\002\b\000!\128\001\000\000\204\000\001\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\000@\000\001\000\000\000 \000\000\000\128\000\000\000\000\000\000\b\000\b\000\000\001\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\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\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\224\000\128\b\000\000\000 \000\000\000\000\000\000\000\000\002\000\000\000@\000 \001\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\b\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\000\016@\001\012\000\b\000\007`\000H\000\000 \004\004\000\002\006\004\000\000\000 \000\000\000\000\000\132\128\017@\004\024\000C\128\002\000\001\152\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000\128\000\000\000\000 \000\000\000\000\000\000\000\000\006\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\004\000\001@\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016@\129\012\000\b\000\006`@\b\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\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\t\000\"\128\b0\000\135\000\004\000\0030\000\004\000\128H\001\020\000A\000\004 \000 \000\025\128\000 \004\001\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\001\000 \000\0160 \000\000\001\000\000\000\000\000\004$\000\138\000 \192\002\028\000\016\000\012\192\000\016\002\001 \004P\001\004\000\016\128\000\128\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\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\144\002(\000\130\000\b`\000@\0003\002\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\001\001\000\000\129\129\000\000\000\b\000\000\000\000\000! \004P\001\006\000\016\224\000\128\000f\000\000\128\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\000\000\000\000\000\000\016\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\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! \004P\001\006\000\016\224\000\128\000f\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017\000\000\002\000\002\000\012\000\000\000 \000\000\000\000\000\136\000\000\000\000\016\000`\000\000\001\000\000\000\000\000\004@\000\000\000\000\128\001\000\000\000\b\000\000\000\000\000\144\002(\000\194\000\bp\000@\0003\000\000\192\000\b\128\000\000 \000\016\000\192\000\000\000\000\000\000\000\000@\000\000\001\000\000\128\006\000\000\000\000\000\000\000\000\002\000\000\000\000\000\004\0000\000\000\000\000\000\000\000\000\016\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\b\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\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\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\002\000\000@\002\000$@\128\000\000\000\000\000\000\000\000@\000\004\000\000\018\004(\b\000\000\000\128\016\000\000\002\000\000 \000\000\144!\000@\000\000\004\000\128\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\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\002\000\000\000\000\b\004\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\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\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\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\004\000\000\002\000\000\b\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\128\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\000\000\000\000\000\000\000\000\000\000\000\000 \000\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\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\001\000\000 \001\000\018 \192\000\000\000\000\000\000\000\000\b\000\001\000\b\000\145\002\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\002\000\000\000\000\000\000\001\000\000\000\000\000\000\000\016\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\004\000\000\000@\000\000\000 \000\004\000 \002D\b\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\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\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\000\004\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\170\000 \136R\028\004\017\000\014\192\b\016\002\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\t\016 \000\000\000\000\000\000\000\000\018\000U\000\016D)\014\002\b\128\007`\004\b\001\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\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\000\000\000\000\000\000\000\001\000\000\000\000\128\000\000\000\0000\000\003\128\128\003\011\132\000\002\000\000\000\000\000\000\002\000\000 \000\000\128!\192\192\000\000\004\000\128\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\b\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\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\000\000\000\000\002\000\000 \000\000\128!\000@\000\000\004\000\128\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@\b\004\128\017@\004\016\nB\000\002 \001\152\000\002\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\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\004\000\000\128\004\000H\129\000\000\000\000\000\000\000\000\000\144\002(\000\130\001Hp\000D\0003\000\000@\b\004\128\017@\004\016\nB\000\002 \001\152\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\016\000\000\000\000\000 \001\128\000\000\000\000\000\000\000\000\128\000\000\000\000\001\000\004\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\128\000\003\000\0008\t\0002\184@\000 \000\000\000\000\000\000,\002\170\000 \192\130\028\000\017\000\014\192\0000\002\000\192\000\012\000\000\012.\016\000\b\000\000\000\000\000\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\028\004\000\024\\ \000\016\000\000\000\000\n\000\000\000\004\000\000\000\000\002\000\000\000\000\000\001\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\128\000\001\133\194\000\001\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\006\000\000p\018\000ep\128\000@\000\000\000\000\000\000X\005T\000A\129\0048\000\"\000\029\128\000 \004\002\192*\160\002\012\b!\192\001\016\000\236\000\001\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002\168\000\130\000\bp\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\001 \004P\001\004\000\016\192\000\128\000f\000\000\128\016\t\000\"\128\b \000\132\000\004\000\0030\000\004\000\128\128\000\000\000\000\001\000\012\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@\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\000\000\000\000\000\000\000\000\000\004\000\000\024\000\001\192H\001\149\194\000\001\000\000\000\000\000\000\001 \004P\001\004\000\016\192\000\128\000f\000\000\128\016\t\000\"\128\b \000\132\000\004\000\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\138\000 \128\002\016\000\016\000\012\192\000\016\002\000\128\000\004\144\000\140\000 \004\000\000\000\000\000\002\000\004\000\000$\128\004`\000\000 \000\000\000\000\000\016\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\002@\b\160\002\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\004\128\017@\004\016\nB\000\002 \001\152\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\t\000\"\128\b \000\132\000\004\000\0030\000\004\000\128 \000\001$\000#\000\b\001\000\000\000\000\000\000\128\001\000\000\t \001\024\000\000\b\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\002\000\000\003\016\000<\b\0000\184P\000 \002\000 \000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004P\001\004\000\016\192\000\128\000f\000@\128\016\t\000\"\128\b \000\132\000\004\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\001\000\000\000\000\000\000\000\000\000\136\000\000\002\000\001\000\012\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@\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( \000@\000\b\000@\012\136\016\000\000\016\000\000\000\000\000\b\000\000\128\000\002@\133\003\000\000\000\016\002\000\000\000@\000\004\000\000\018\004 \024\000\000\000\128\016\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\001\000\000\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\000\000\000\000\000\000\000\000\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\t\000\000\000\000\000\000\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\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\000\000\000\000\000\000 \000\002\000\000\b\002\024\012\000\000\000@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\b\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\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\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\001\138@\020$\001\024\018+\000\016\005 \000\002\130\000\014\000\000\224 \000\194\225\000\000\128\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\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\003\027\132\001\022\n7\241'\208\004\007\208\n\000\012p\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\004\000\004\000\000\128\004\000\200\131\000\000\001\000\000\000\000\000\000 \000\004\000 \006D\b\000\000\b\000\000\000\000\000\001\000\000 \001\0002 @\000\000@\000\000\000\000\000\024\132\017\003 \017\129&\208\001\000P\000\000\b /n\200\129\005\252T\128\002`\224t\227\130\192\160\208\006!\004@\128\004`I\180\000@\020\000\000\002\b\0001\b\"\004\000#\002E\160\002\000\160\000\000\016@\001\136@\016 \001\024\018-\000\016\005\000\000\000\130\000\000\000\000\000\000\000\000\004\000\004\000\000\000\000\000\001\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\128\000\000\000\000\000\000\b\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\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000 \000\000\000\016\000\002\000\016\003\"\004\000\000\004\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\000\000\000\000\000\000\001\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\024\164\001B@\017\129&\176\001\000P\000\000\b \000\197 \n\018\000\140\t\021\128\b\002\128\000\000A\000\006)\000P\144\020`H\172\000@\020\000\000\002\b\000\016\000\002\000\016\003\"\004\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000 \004\000\000\128\004\000\200\129\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\007\148\149j\rQ:g\247\130 \011\153A\007\141@\024\132\001\016\n\001\129#\144\000\000P\n\000\012`!\231\183z\255W\206\185\253\255\219\131\247\246\223\255}\015=\187\215\250\190u\207\239\254\220\031\191\182\255\251\224yIV\160\213\019\166\127x\"\000\185\148\016x\212\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\021@\004\017\nC\129\130 \001\152\001\006\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\t\000*\128\b\"\020\135\003\004@\0030\002\012\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\018\000U\000\016D)\014\006\b\128\006`\004\024\005\000 \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\001\145\002\000\000\002\000\000\000\000\000\001 \005P\001\004B\144\224`\136\000f\000A\128P\006!\004@\128\004`H\180\000@\020\000\000\002\b\0001\b\002\004\000#\002E\160\002\000\160\000\000\016@\000\000\000\000\000\000\000\000\128\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\128\000\000\000\000\016\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\024\000\001\192H\001\149\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\000\000@\000\004\000\000\016\0048\024\000\000\000\128\016\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\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\b\000\001\000\b\001\145\002\000\000\002\000\000\000\000\000\001\000\000\016\000\000@\016\224`\000\000\002\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\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\001\000\000\004\001\b\006\000\000\000 \004\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\128\002 \001\152\000\002\000@\024\000\001\192H\001\149\194\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\002\000\000@\002\000d@\128\000\000\128\000\000\000\000\000H\001\020\000A\000\1648\000\"\000\025\128\000 \004\001\138@\020$\001\024\018+\000\016\005 \000\002\130\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\004\128\017@\004\016\nB\000\002 \001\152\000\002\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\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\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \020\132\000\004\000\0030\000\004\000\0001\b\"\006\000#\002M\160\002\000\160\000\000\016@\001\136A\016 \001\024\018m\000\016\005\000\000\000\130\000\012B\b\129\000\b\192\145h\000\128(\000\000\004\016\000b\016\004\b\000F\004\139@\004\001@\000\000 \128\004\128\017@\004\016\nC\000\003 \001\152\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\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\001 \004P\001\004\002\144\128\000\136\000f\000\000\128\016\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\134\000\004\000\0030\000\004\000\000H\001\020\000A\000\164 \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\000@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\138\000 \128R\016\000\025\000\012\192\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\0001\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\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\001\000\002\128\000\000\000\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\006\192\000\000\000\000\000\000\000\000\000\000 \001\141\194\022\139\005\027\248\145\232\002\003\232\005\000\0078\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\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\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\004\000\n\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\000\000!\231\183z\255W\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\016\243\219\189\127\171\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\152\220 \b\176Q\191\137\030\128 >\128P\000c\128\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\by\237\222\191\213\243\190\127\127\246\224\253\253\183\255\2071\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\192 \000\000\000\000\006\000\n\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\000\000!\231\183z\255W\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\016\243\219\189\127\171\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\152\220 \b\176Q\191\137\030\128 >\128P\000c\128\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\by\237\222\191\213\243\190\127\127\246\224\253\253\183\255\2071\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\192\000\000\000\000\000\000\000\000\000\000\000\000\018\000\000\000\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\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\001\015=\187\215\250\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 \000\000\000\000\000\000\000\000\000\000\000\000\000\135\158\221\235\253_;\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<\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000C\207n\245\254\175\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\030\135\158\221\235\253_;\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\250\190u\207\239\254\\\031\190\150\255\249\224\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\012n\016\004X(\223\196\143@\016\031@(\0001\192\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\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\002\000\000\000\001\000\001 D\012n\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\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\004\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\0001\b\002\004\000#\002E\160\002\000\160\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\000b\016\132@(\006\004\142@\000\001@(\0001\128\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\024\220 \b\176Q\191\137\030\128 >\128P\000s\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\141\194\004\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\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\004\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\001\136@\017\000\160\024\0189\000\000\005\000\160\000\198\002\000\000\000\000\000\000\000\000\000\001\128\000\002@\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\000D\000\000\000\000\000\000\000\000\002\000\001 \000\000\000\002 \000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\017\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\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\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\004\000\000\000\000\000\000\000\000\000\003\000\000\004\128\000\000\000@\000\000\000\000\012\001\028\000\000\000\000\000\000\000\001\000\000\017\000\000\000\000\000\000\000\192\000\129 H\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\000\000\000\000\000\000\000\000\000\000\000\000\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\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\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\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\002\000\000\000\000\000\000\000\000\000\000\000\128\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\000\000\000\000\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\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\021\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\132\138]\193\244\031\n\195\129\255.\005\222\011~p\240\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\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\000\000\000\000\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\004$R\238\015\160\248V\028\015\251p.\244\219\243\135\128\000\000\000\000\000\000\000\000\000\001\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\by\237\222\191\213\243\174\127\127\246\224\253\253\183\255\223\000\000\000@\000\000\000\000\000\000\000\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\001\000\000\000\b\000\000\000\000\b\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\000\000\000\000\000\000\000\000\000\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\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\024\b\001\000\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\000\000\000\000\000\000\000@\001\000\002\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\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\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\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\136\000\000\016\000\016\000`\000\000\001\000\000\000\000\000\004@\000\000\000\000\128\003\000\000\000\b\000\000\000\000\000\"\000\000\000\000\004\000\b\000\000\000@\000\000\000\000\000\000\000\000\002\000\000\000\128\001\000\000\000\000\004\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\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\000\000\000\000\000\000\000\000\000\000\000\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\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\004\000\000\000\000\000\000\000\000\000\004\000\000\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\004\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\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\000\000\000\000\000\t\000\"\128\b \020\134\000\006@\0030\000\004\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000BE.\224\250\015\133a\192\255\151\002\239\005\1918x\000\000\000\000\000\000\000\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\192@\b\b\000\b\b \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\002\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 \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\000\000\001\000\000\000\000\000\000\000\000\000\000\000\t\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\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\000b\016\004\b\000F\004\139@\004\001P\000\000\"\128\132\138]\193\244\031\n\195\129\255.\005\222\011~p\244\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\160\000\000E\001\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\006@\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\b\001\001\000\000\129\129\000\000\000\b\000\000\000\000\000 \000\001\000\000\002\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\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\144\002(\000\130\005Hp\000D\0003\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\b\001\000\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\000\t\000\"\128\b T\135\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\000\000\204\000\001\000\000\018\000E\000\016@)\b\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\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\016\000\000\000\000\001\000\000\004\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000 \000\000\000\000\000\001\128\000\024\000\000\024\\`\000\017\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000@\000\000\000\128\000\000\001\016\000\000\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\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\001\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\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\016\000\000\002\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\000\000\000\000\000\000\000\000\000\000\000\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\000\000\004\000\000\000\000\000\128\000\000\000\000\000@\000\000\000\000 \000\000\000\000\004\000\000\000\000\000\002\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\017@\004\016\nC\128\002 \001\152\001\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\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\004@\000\000\000\000\128\001\000\000\000\b\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\012 \020\135\000\004@\003\176\000\012 \000\017\000\000\000\000\002\000\004\000\000\000 \000\000\000\000\002@\b\160\002\b\005!\192\001\016\000\204\000\001\b\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\004\128\017A\004\016\nC\000\002 \001\216\001\002\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\000\000\000\000\000\000\000\000\000\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\128\021@\004\024*C\128\002 \001\216\000\"\000D\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\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\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\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\004\000\000\000\000\000\002`\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\000\000p\016\000ap\128\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\016\000\001\000\000\004\001\b\006\000\000\000 \004\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\004\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\160\000\000E\001\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\232H\165\220\031A\240\1728\031\242\224]\224\183\231\015\001\136@\016 \001\024\018-\000\016\005@\000\000\138\002\018)w\007\208|+\014\007\252\184\023x-\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\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\004\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\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\136\000\000\000\000\024\000 \000\000\001\000\000\000\000\000\000\001\016\015\192\024\018\000\001\241\b\001\002\000`\162\192\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\016\000\000\000\000\003\000\000\000\000\000\000\000\000\000\000\000\000 \001\248\003\002@\000>!\000 @\012\020X\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\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\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\b\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\143@\016\031@(\0001\192\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\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\016\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\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\128\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\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 \004\004\000\002\006\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\000\000\000\000@\000\004\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\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\b\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\000\000\000\000\000\000\128\000\000\000\016\000H\017\000\000\000\000\000\000\000\000\000\000\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\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\001\000\000\000\000\0000\000\000\000\000\000\000\000\000\000\003?\132\131\022*\183\2433\208\021\007\220\138\000\028p\000@\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\011! \128\b t\132\004\004@\007 \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\130\000 \128R\016\000\017\000\012\128\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\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\018\000A\000\016@)\b\000\b\000\006\000\000\b\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\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\0003\248H1b\171\1273=\001P}\200\160\001\199\001\159\194A\139\021[\249\153\232\n\131\238E\000\0148\000\144\002\b\000\130\001H@\000D\0002\000\000@\000\004\128\016@\004\016\nB\000\002 \001\144\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\t\000 \128\b \020\134\000\004@\003 \000\004\000\000H\001\004\000A\000\164 \000\"\000\025\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\nC\000\002 \001\144\000\002\000\000$\000\130\000 \128R\016\000\017\000\012\128\000\016\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\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000") and start = 15 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\022N\006\021\218P\240^0\000\000\000\025\000\000\000\000\001\030\000\000\000\000P\130\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\002\248\002\160\000\t\000\000\000\000\002\236\000\000Q\168c\208\022\022\\\148\022|\003\168\0001k\026\000\000\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\234\001\132\000\157\000\000\000\168\004B\000\000\000\242\000\226\004J\000\000\005L\002\000\n\\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\000\000\002\160]`\000\000\000\000\000h\000\000\000\000^\002\003<\002\200\000\000\000\000L$\000h\000\000P\172\022\022Q\168\004\130\004\242\003\168\004\176\000\000\022\022I\186TB\022\022_\180\000\000\001<\000\000Yj\004\250\000\000\028x\000\000\000\016\000\000\000\000\001\166\000\000\000h\000\000\000\000\000\000\001\206\000\000\028x\000\000\004\004~Z\133\166k\176\135\182O\016YX_\198\000\000t4\026\018]`N\160I\186I\186\000\000\000\000\000\000I\244I\244\003\168\004\176\004\176\022\022\000\003\025\174\000\208\005\182\000\000\004v\005\186\000\000\000\000\000\000\000\000\000\000\022\022\000\000\000\000\000\000T|\022\022\000\003T|\022\022\000\003G\174w\166I\186\000\252\000\003Tr\022\022\131\242\000\000^0{\138~\206\000\000\005\182\000\000\0056\000\000\023\164K([\140\000\000K([\140\000\000K(\138\002\007\028\006\194\004\004\002\164\000\000\005\164\000\000\000\000\b0\000\000\000\000\000\000K(\000h\000\000\000\000_\180K(^\234_\198\000\000\000\000[J\007\028\000\000\000\000_\198\005\252K(\000\000\\4_\198]\030\000\000\000\000\000\000\003(\000\000K(\000\000\021\024\140\214\000\000K(\007VK(\000\000\030.\006\148\000h\000\000\000\000\031,\000\000\bT\000\000a\166\0040\000\000\006\204K(\004|\000\000\004\146\000\000\003\138\000\000\000\003\006b\000\000\000\000\000\000$@\tX^0Tr\022\022^0\000\000\007\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000ZR\030\140\000\000\000\000\000\000\001\254\026\002~\206\000\000Tr\022\022^0\000\000\000\000Z\160^0\138\148^0\138\238\000\000`X\000\000\000\000`\252P\130\004\180\004\180\000\000\b,^0\000\000\000\000\000\000\bB\b~\000\000\027\138\000\000^0\139 K(\003~\000\000^0\139n\0001\000\000\000\000\000\000\b\186\000\000\022Z\000\000\130\028\000\000\b\198\000\000QF^0\000\000\000\000H\250\tB\005\182\t\156\000\000\000\000\000\000\000\000\b\180\000\000O\138\006\022\th\007\174K(\016\186\t\200\000\000\000\000\007l\th\t\018\000\003^0b\128\002\254\000\000^0\024\144K(\017\138\t\018\n\152\000\000\000\000\000\000Q~\004\180\n\168pb^0\000\000\000\003T|P&I\244\003\168\004\176\003~\002\004\000\t\000\000\n\132Q\168Q\168\011bQ\168\003~\002\004\002\004\000\000\011xQ\168\000\000p\230\001LYj\005\182\005\248\141&\000\000K(lVK(e&l\222K(\005lK(mh\000\000\t\134\n\150\006\140Q\168qn\000\000\006\196\011\148d\020\000\000\000\000\000\000\000\000Q\168q\246Q\168r~\000\218\004\004e\176\005\186\004\004f:\000\000s\006\001L\000\000\000\000s\142\023f\000\000\025\228\000\000\011\250\004\176\000\000d\158S\184\000\000\000$\000\000Q\168\026P\000\000\000\000\000\000cF\000\000\000$\000\003K\178\005\234\t\170\000\003\024\006L\184\018\022\000\003T|\022\022\018\022T|\022\022J\182T|\022\022\000\003Tr\022\022^0^0H\250\000\003Tr\022\022\127^Rz\004\180\012Bx4\000\003Tr\022\022^0\028N\000\003Tr\022\022^0\027\138\000\003\018\022\000\000\000\000\000\000\000\000\001\250\023rH\180\000\000UPV$I\244\003\168\004\176\006\192Q\168\026b\000\000V\248W\204{\138\029LK(\t\174\000\003T|\022\022\018\022\024\006\018\022\003\002\017\254\000\003\000\003\018\022\n\200\012\020\007\220K(#|K(\028\nK(#\154\012v\000\000\000\000\012b\000\000\018\022\004\n\012\206\000\000$\236\000\003\r\024\000\000\027\254\000\003\019\020\025\004\000\000\000\000\000\000\000\000\b\224\000\003\000\000\000\000\t\202\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^0\029\134K(\n\208\000\003\000\000\031\130\000\003\000\000^0 F^0 \128^0!D\0001\000\000\000\000\000\000!~^0\"B\000\000x\156N\160I\186^0N,\000\003\000\000I~\025\174\000\208\000h\133\242Q\168\130\136x\156x\156\000\000\000\000\004\002\005\n\000\t\006\n\004\176\127\198Q\168\005\198\004\176\128Px\156\136\020\002\160\000\t\006\nx\156\136\020\000\000\006\n\000\000\000\000\006\nx\156\000\000N\160I\186N\160I\186I\244\003\168\004\176x\156\000\000\022|\003\168\0001\012f]`\n\n\000h\000\000K(y&\012\182\r\186\134V\000\000x\156\000\000y\140K\198\022\022\005\170\000\000\t\148\014$\000\000\014F\128\180_\198\000=\000\000\014&\r\178]`\011\030K(#\250\022\022\011\152\021\220\000\000$\248\014\132\000\000\000\248\000\000\000\000\014\160_\198f\194\000\000m\242\006\178\n\146\002\004\b&\r\220\022\022x\156\000\000\142(\011\184_\198\014p_\198t\022gj\014\128_\198t\180h\018\022\022x\156\000\000\000\000n\200TB\022\022k\254Yj\011\208n\006\133\166\138\002\000=\014\224\000\000\000\000u6y\240\022\022\000\000\130\236\005\170\000\000\000\000\1326\000\000\000\000\000\000\129\024\025z\026x\000=\015\006\000\000\000\000\000\000y\240\022\022\000\000\000=\015\014\000\000\000\000\000\000\000\000\000\000\1326\000\000\015\014\027\226\000\000\022\232\138\026\000\000\000\000\000\000\000\000\012\028~Z\133\166\000\000\1326\000\000\000\000\1326\000\000\015 \027\226\022\232\138\026\000\000\141`\023\152\002\248\000\208\004\004\1326\000\000\000\208\004\004\1326\000\000JP\025\174\000\208\000h\133\242Q\168x\156\000\000\004\002\006\194\bn\004\004\1326\000\000\000\t\014xQ\168x\156Y\252\002\160\000\t\014\138Q\168x\156Y\252\000\000\000\000\007\018\000\003x\156\000\000Q\168\136Hx\156\000\000\007\018\000\000P\172\022\022Q\168x\156\000\000K\198\022\022\005\170y\240#\242\029j\021\220\017\184\000\000\012v\028x\011b\000\000\015\"\014\240\0312\021\218[ZK(\012N\000\000Rf\003\218\006\242\011\232\000\000\011\198\000\000\015R\014\214K(UP\000\000\003\168\017\180\012*\000\000\012`\000\000\015\\\014\218]`Q\236\000\000\022\022\0312\015|\004j\000\208\000\003\002X\0312K(\012\158\007\028\000\000K(\b\238\n\234\000\000\000\000u\220\000\000\000\003\005\204\0312vfUP\000\000\022\022K(\012\168K(H\180Q\236\000\000\015\000\000\000Q\236\000\000\000\000Rf\000\000x\156\136\230\021\220\017\184\012v\015\128\015*\0312x\156\136\230\000\000\000\000\021\220\017\184\012v\015\168\0158\139\198Y<_\198\015\204\139\198\138\002\028\202\015\220\139\198_\198\015\228\139\198zpz\240\000\000b0\000\000\000\000x\156\139\132\021\220\017\184\012v\015\224\015`\139\198x\156\139\132\000\000\000\000\000\000\141`\000\000\000\000\000\000\000\000\000\000\000\000\000\000x\156\000\000\136\244\022\022M\004\015\246~Z\000\000\1326\136\244\000\000\000\000\140R\022\022M\004\015\250\015~\133\166\000\000\1326\140R\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\026#\242\021\220\017\184\012v\016\n{\138J\224\021\218P\240V\248\022f\002\210\000=\016\012\n\012\000\003\000\000\015\184\000\003\000\000Q\236\000\000\007\222\012\230\000\000\r^\000\000\016 \015\158K(O\156\0162\012\b\000\003\000\000\015\238\000\003\000\000\022\138\003\168\r(\016P|\012]`\004\180\015\232K(\rp\000\003\000\000\015\254\000\003\000\000\000\000\000\000pb\016\000\000\003\000\000\000\000\000\000Q\236\000\000\021\182\rd\000\000\r\132\000\000\016^\015\220]`\000\000\016n|\142_,\004\180\016\020K(\rv\000\003\000\000\016.\000\003\000\000\000\000\022\022\000\003Q\236\000\000\022<\022\022J\224J\224}\130N\160\022\022\131\242^0\n\200\000\000\021\178\000\208\000\003\tZJ\224K(\r\228\005\182\000\000\022\022{\138{\138J\224\r\136J\224\000\000L\166\018\022\005\018\006\026M\160\000\000\000\000\000\000hv\000\000\000\000i\000\000\000\000\000i\138\000\003\r\138J\224j\020\131\242^0\n\200\000\000\007\012\000\000\139\198\016\226\000\000G\174\016\186\000\000Q\236\000\000J\224G\174Q\236\000\000\022\022K(Q\236\000\000\016Z\000\000Q\236\000\000\000\000V\248\000\000\132\192\139\198\016jJ\224\133${\138\000\000x\156\137\144\021\220\017\184\012v\016\204{\138x\156\137\144\000\000\000\000\000\000\129\254Tr\022\022\131\242^0x\156\000\000\000\000\000\000\000\000\000\000\000\000\134\186\000\000\000\000\135<\000\000x\156\000\000\136\244\000\000\000\000\000\000\000\000x\156\129\254\000\000\017\022\000\000\134\186\000\000\135<\017\026\000\000\017,\000\000\000\0003\206\000\003\0170\000\000\000\003\0172\000\000\012\230\018\252\000\003\017D\000\000j\160J\182\000\000\000\003\017B\000\000\000\003\017H\000\000\000\000\019\250\000\003\017Z\007\"\000\0034\204\000\003\017X\b \000\0035\202\000\003\017f\t\030\000\0036\200%\234\000\003\017\132\n\028\000\0037\198\000\003\017\144\011\026\000\0038\196\000\003\017\146\012\024\000\0039\194\012\246\020\248\000\003\017\154\r\022\000\003:\192\000\003\017\180\014\020\000\003;\190\000\003\017\184\015\018\000\003<\188\016\016\000\003=\186\021\016\000\000\017\238\000\000\000\003\017\238\000\000\000\003\018\004\000\000\000\000\"|\000\003\000\000\007\214\000\003\000\000^0\000\000\000\000}\000\018\024\000\000K\178\000\000\017^\000\000X\158\000\000\0188\000\000\005\234\017\194\000\000\024\006\031r\005\182\000\000\031\192\000\000\011T\014N\023|\000\000\000\000\018F\000\000\001t\027\000R\128\000\000\014(\000\000\000\000\000\003\017\156\000\003\017\180\000\000\017\178\000\003\017\198\000\000\000\003\014(\000\003\017\218\000\003\017\228\000\000\000\000Sv\004\180\018\154x4_\198\t\240\000\003\000\000x4\000\000\000\000\000\000x4\000\000\018n\000\003\000\000\000\003\000\000\000\000\000\000>\184^0\000\000\000\000\018\172\000\003?\182\000\003@\180\000\000\018\002\000\000\027\000j\160\000\000\017\014\018\156\000\000v\216\014\"\014\136\000\000\000\000\0182\000\000\018\188\000\000\000\000\003\168\004\176\023\160\000\003\000\000\002\248\002\160\000\t\006\n\018R\000\003\000\000K\198\022\022\005\170\000\230\003~\018X\000\003\000\000\000\000\000\000\000\000\000\000\018\232\000\000\000\000\141\160\004\180\018PK(\014\164\000\003\000\000\r\146K(\014\200\000\003\000\000\018f\000\003\000\000\000\000x\156\000\000A\178\000\000\018@\000\000\000\000I\244\003\168\004\176\024\232\000\000Q\168\027N\000\000\nT\000\000\019\014\000\000\019@^0B\176\019J^0C\174wR\000\000Q\168\027`\000\000Q\168\027\210\000\000Q\168\028\208\000\000x\156\000\000\003\168\004\176x\156\000\000x\156\129\254\000\000\000\000\019 \000\000\021\006\014<\022\022u`\000\000\000\000!\004\140\130\000\000\000\000\018\184\000\000\019\016K(\000\000\014\144\n,\007\028\000\000\000\000K(\005V\007\158\000\000K(\012\148\000=\019D\000\000\000\000\131P\000\000\000\000\0198\027\226\029P\005\170y\240\006\178\022\022\000\000\132Z\000\000\000\000\000\000\000\000\000\000\000\000\000\000}\246\006\178\022\022\000\000\015\140~Z\019L\027\226\029P\132Z\000\000\018\196\000\000o&\028\246\000\000x\156\000\000\018\212\000\000\029\206\000\000\028N\000\000K(\014\252\000\000V\248\018\236\000\000\019\186^0D\172E\170^0F\168\000\003\000\000\000\003\000\000\018\230\000\003\018\236\000\000\019\152\000\000\000\003\018\236\000\003\018\242\000\000\019\018\000\000\000\000\\\148\019\"\000\000\000\000\028\252k\026\019\196\000\000\000\000\000\000\012T\017\196o\152\019\202\000\000\000\000\000\000\000\000\000\000\000\000\019J\000\000\006\178\000\000\019^\000\000K(\000\000\003~\000\000\000\003\019`\000\000\000\000\004\004\000\000\bl\000\000\000\003\000\000\001\212\000\000\004\176\000\000\005\190\000\000Q\168\000\000\026P\000\000\n\150\000\000\019j\000\000^0\024\144\000\000\000\000\024\216\019p\000\000\000\000\019h\025\178J\182\000h\129\154\000\000\000\000\000\000\000\000\000\000\138~\000\000\000\000\020\"\000\000\141\150\000\000\015\176\020&\000\000\020<\000\000K\178K\178\140d\140d\000\000\000\000x\156\140d\000\000\000\000\000\000x\156\140d\019\160\000\000\019\172\000\000"), (16, "\t-\000\006\000\246\001\142\001\146\t-\001\002\001\006\t-\001\n\001\022\001\"\t-\012\214\t-\012Y\001&\t-\007Z\t-\t-\t-\005\253\t-\t-\t-\001*\001\186\002N\001\254\001.\t-\003V\003Z\n\138\t-\012Y\t-\006\181\0012\br\003z\002\230\t-\t-\003\174\003\178\t-\003\182\003\194\003\206\003\218\003\226\006\234\007:\002\234\t-\t-\003F\001J\002f\003\214\t-\t-\t-\b\154\b\158\b\170\b\186\bf\005n\t-\t-\t-\t-\t-\t-\t-\t-\t-\b\210\001N\t-\000\238\t-\t-\t-\001J\b\222\b\246\t\022\t*\005z\t-\005~\t-\t-\t-\b\150\t-\t-\t-\t-\b\178\002j\b\182\002\006\024\n\t-\001N\t-\t-\004i\t-\t-\t-\t-\t-\t-\005\130\b\198\t-\t-\t-\t>\004j\t\162\012\129\t-\t-\t-\t-\012\129\012\129\012\129\012\129\bv\002\022\012\129\012\129\012\129\012\129\001\250\012\129\012\129\003\129\012\129\012\129\012\129\003\161\012\129\012\129\012\129\012\129\012\206\012\129\004i\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012Q\012\129\012\214\012\129\000\238\012\129\012\129\012\129\012\129\012\129\007\150\005\253\012\129\012\129\012\129\003E\012\129\003\222\012\129\012\129\012\129\012Q\001\173\012\129\012\129\012\129\012\129\012\129\012\129\012\129\003E\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\b\026\012\129\012\129\007\210\012\129\012\129\012\129\001V\001\250\003\129\b\"\002\242\012\129\012\129\012\129\012\129\012\129\012\129\b&\012\129\012\129\012\129\012\129\012\129\012\129\012\129\rN\012\129\012\129\001Z\012\129\012\129\002\246\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\012\129\003\n\001\173\012\129\012\129\012\129\012\129\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\002&\001\173\002\202\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\023f\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\003A\001\173\001\173\001\173\001\173\001\173\007V\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\0283\001\173\001\173\001\173\001\173\001\173\001\173\001\173\b\"\004i\004i\003\014\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\004F\tV\001\173\005\178\001\173\001\173\r:\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\001\173\016:\001\173\001\173\001\173\001\173\001\173\n-\002\237\002\237\004>\006\246\n-\n-\n-\n-\002J\001\154\n-\n-\n-\n-\000\238\n-\n-\004i\n-\n-\n-\b\"\n-\n-\n-\n-\004i\n-\000\n\n-\n-\n-\n-\n-\n-\n-\n-\001\246\n-\000\238\n-\004\202\n-\n-\n-\n-\n-\006\250\007\022\n-\n-\n-\002\014\n-\002\030\n-\n-\n-\002\237\004J\n-\n-\n-\n-\n-\n-\n-\002V\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\002v\n-\n-\006B\n-\n-\n-\004i\002z\004i\004i\005>\n-\n-\n-\n-\n-\n-\004i\n-\n-\n-\n-\n-\t\186\n-\001\158\n\018\n-\004i\n-\n-\004i\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\n-\000\238\n-\n-\n-\n-\n-\003\201\004i\004i\004i\002^\003\201\003\201\003\201\003\201\004i\004\206\003\201\003\201\003\201\003\201\000\238\003\201\003\201\004i\003\201\003\201\003\201\005B\003\201\003\201\003\201\003\201\004i\003\201\028\003\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\004i\003\201\000\238\003\201\005\030\003\201\003\201\003\201\003\201\003\201\003\026\006\129\003\201\003\201\003\201\006\137\003\201\004i\003\201\003\201\003\201\004\206\000\238\003\201\003\201\003\201\003\201\003\201\003\201\003\201\002\158\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\005.\t\178\n\n\002\n\003\201\003\201\003\201\002\026\003r\002\170\001\006\0056\003\201\003\201\003\201\003\201\003\201\003\201\002\174\003\201\003\201\003\201\003\201\003\201\t\186\003\201\006\029\n\018\003\201\001*\003\201\003\201\000\238\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\003\201\012U\003\201\003\201\003\201\003\201\003\201\003\185\003n\001\142\001\146\006\002\003\185\003\185\003\185\003\185\003F\b\241\003\185\003\185\003\185\003\185\012U\003\185\003\185\011\234\003\185\003\185\003\185\002\162\003\185\003\185\003\185\003\185\007\245\003\185\003\142\003\185\003\185\003\185\003\185\003\185\003\185\003\185\003\185\007N\003\185\016.\003\185\004\014\003\185\003\185\003\185\003\185\003\185\004\206\001\250\003\185\003\185\003\185\003\129\003\185\b\217\003\185\003\185\003\185\004\206\006\029\003\185\003\185\003\185\003\185\003\185\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\004N\t\178\n\n\012\182\003\185\003\185\003\185\001\"\006\154\001\006\007\146\003\146\003\185\003\185\003\185\003\185\003\185\003\185\000\238\003\185\003\185\003\185\003\185\003\185\t\186\003\185\004\213\n\018\003\185\000\238\003\185\003\185\002\214\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\012\186\003\185\003\185\003\185\003\185\003\185\003\181\003\134\b\014\003\150\bf\003\181\003\181\003\181\003\181\012\198\007\198\003\181\003\181\003\181\003\181\b\217\003\181\003\181\000\238\003\181\003\181\003\181\000\238\003\181\003\181\003\181\003\181\b\162\003\181\004\166\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\005~\003\181\016r\003\181\007V\003\181\003\181\003\181\003\181\003\181\006\190\006\214\003\181\003\181\003\181\028C\003\181\012\002\003\181\003\181\003\181\005J\024n\003\181\003\181\003\181\003\181\003\181\003\181\003\181\b\"\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\007\162\t\178\n\n\001\006\003\181\003\181\003\181\001\"\004\250\011\242\001\142\014\238\003\181\003\181\003\181\003\181\003\181\003\181\007\170\003\181\003\181\003\181\003\181\003\181\t\186\003\181\014\254\n\018\003\181\011\250\003\181\003\181\015\206\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\003\181\r2\003\181\003\181\003\181\003\181\003\181\t\205\bf\004>\004>\002^\t\205\t\205\t\205\t\205\012\198\020>\t\205\t\205\t\205\t\205\000\238\t\205\t\205\015\214\t\205\t\205\t\205\007\222\t\205\t\205\t\205\t\205\006\005\t\205\004j\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\005~\t\205\b\006\t\205\007V\t\205\t\205\t\205\t\205\t\205\0036\004i\t\205\t\205\t\205\000\238\t\205\021\230\t\205\t\205\t\205\004V\007\238\t\205\t\205\t\205\t\205\t\205\t\205\t\205\tz\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\005&\t\205\t\205\026N\t\205\t\205\t\205\006\222\024\238\0156\000\238\003\169\t\205\t\205\t\205\t\205\t\205\t\205\018j\t\205\t\205\t\205\t\205\t\205\t\205\t\205\020B\t\205\t\205\015B\t\205\t\205\004i\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\t\205\000\238\t\221\t\205\t\205\t\205\t\205\t\221\t\221\t\221\t\221\018r\003\146\t\221\t\221\t\221\t\221\004N\t\221\t\221\005\253\t\221\t\221\t\221\004i\t\221\t\221\t\221\t\221\006\014\t\221\004\234\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\006\193\t\221\003\169\t\221\022\226\t\221\t\221\t\221\t\221\t\221\026R\b\245\t\221\t\221\t\221\r>\t\221\021\250\t\221\t\221\t\221\004Z\006\198\t\221\t\221\t\221\t\221\t\221\t\221\t\221\006&\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\214\t\221\t\221\t\222\t\221\t\221\t\221\001V\004>\005\189\000\238\022\234\t\221\t\221\t\221\t\221\t\221\t\221\006b\t\221\t\221\t\221\t\221\t\221\t\221\t\221\006z\t\221\t\221\001Z\t\221\t\221\b\245\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\t\221\b\197\t\213\t\221\t\221\t\221\t\221\t\213\t\213\t\213\t\213\005\189\028#\t\213\t\213\t\213\t\213\0071\t\213\t\213\004J\t\213\t\213\t\213\b\245\t\213\t\213\t\213\t\213\014\242\t\213\005\189\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\006\150\t\213\000\238\t\213\004\209\t\213\t\213\t\213\t\213\t\213\nF\007)\t\213\t\213\t\213\007)\t\213\022\014\t\213\t\213\t\213\001\006\007\214\t\213\t\213\t\213\t\213\t\213\t\213\t\213\006\178\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\001f\t\213\t\213\006\158\t\213\t\213\t\213\007\001\006\194\b\197\007\025\006\230\t\213\t\213\t\213\t\213\t\213\t\213\011:\t\213\t\213\t\213\t\213\t\213\t\213\t\213\006\210\t\213\t\213\019\174\t\213\t\213\002^\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\t\213\005^\t\193\t\213\t\213\t\213\t\213\t\193\t\193\t\193\t\193\000\238\b\"\t\193\t\193\t\193\t\193\002^\t\193\t\193\012~\t\193\t\193\t\193\023\218\t\193\t\193\t\193\t\193\007\025\t\193\0036\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\nV\t\193\b\166\t\193\t\158\t\193\t\193\t\193\t\193\t\193\012\190\025r\t\193\t\193\t\193\006\145\t\193\022&\t\193\t\193\t\193\0036\004\146\t\193\t\193\t\193\t\193\t\193\t\193\t\193\001\162\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\193\001f\t\193\t\193\007\018\t\193\t\193\t\193\002*\011:\018J\0266\007*\t\193\t\193\t\193\t\193\t\193\t\193\012\134\t\193\t\193\t\193\t\193\t\193\t\193\t\193\t\214\t\193\t\193\t\222\t\193\t\193\002j\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\b\193\t\201\t\193\t\193\t\193\t\193\t\201\t\201\t\201\t\201\t\206\t\246\t\201\t\201\t\201\t\201\t\214\t\201\t\201\t\222\t\201\t\201\t\201\011\158\t\201\t\201\t\201\t\201\000\238\t\201\012~\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\004\129\t\201\000\238\t\201\007b\t\201\t\201\t\201\t\201\t\201\006\"\007\025\t\201\t\201\t\201\007\025\t\201\022:\t\201\t\201\t\201\015\158\011N\t\201\t\201\t\201\t\201\t\201\t\201\t\201\007\242\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\007n\t\201\t\201\012\250\t\201\t\201\t\201\003\149\004\129\b\193\015\218\007\134\t\201\t\201\t\201\t\201\t\201\t\201\002^\t\201\t\201\t\201\t\201\t\201\t\201\t\201\012~\t\201\t\201\012\234\t\201\t\201\002j\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\t\201\b\166\t\197\t\201\t\201\t\201\t\201\t\197\t\197\t\197\t\197\002^\006\t\t\197\t\197\t\197\t\197\r\162\t\197\t\197\015\210\t\197\t\197\t\197\003\014\t\197\t\197\t\197\t\197\006\r\t\197\bZ\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\015\254\t\197\016\006\t\197\t\014\t\197\t\197\t\197\t\197\t\197\015\190\t\210\t\197\t\197\t\197\014f\t\197\022N\t\197\t\197\t\197\rV\b)\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\242\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\197\004>\t\197\t\197\b\221\t\197\t\197\t\197\b%\t\254\018\146\016F\000\238\t\197\t\197\t\197\t\197\t\197\t\197\003\t\t\197\t\197\t\197\t\197\t\197\t\197\t\197\t\214\t\197\t\197\t\222\t\197\t\197\015\150\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\000\238\t\209\t\197\t\197\t\197\t\197\t\209\t\209\t\209\t\209\000\238\027\186\t\209\t\209\t\209\t\209\n\014\t\209\t\209\018n\t\209\t\209\t\209\n\030\t\209\t\209\t\209\t\209\012\173\t\209\012v\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\014F\t\209\018v\t\209\016\142\t\209\t\209\t\209\t\209\t\209\b\221\012\146\t\209\t\209\t\209\016N\t\209\022j\t\209\t\209\t\209\019\026\b\025\t\209\t\209\t\209\t\209\t\209\t\209\t\209\019\018\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\021\158\t\209\t\209\003\142\t\209\t\209\t\209\006\001\022Z\012~\012\185\003\142\t\209\t\209\t\209\t\209\t\209\t\209\012\150\t\209\t\209\t\209\t\209\t\209\t\209\t\209\b\029\t\209\t\209\000\238\t\209\t\209\000\238\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\t\209\019\186\t\225\t\209\t\209\t\209\t\209\t\225\t\225\t\225\t\225\019\214\020\"\t\225\t\225\t\225\t\225\018\206\t\225\t\225\019J\t\225\t\225\t\225\023v\t\225\t\225\t\225\t\225\024f\t\225\012\194\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\b\"\t\225\025\250\t\225\025\018\t\225\t\225\t\225\t\225\t\225\003\254\023N\t\225\t\225\t\225\t\029\t\225\022~\t\225\t\225\t\225\011:\012\222\t\225\t\225\t\225\t\225\t\225\t\225\t\225\012\226\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\r\n\t\225\t\225\0262\t\225\t\225\t\225\r\030\006^\016N\r^\t\005\t\225\t\225\t\225\t\225\t\225\t\225\rn\t\225\t\225\t\225\t\225\t\225\t\225\t\225\005\t\t\225\t\225\b\162\t\225\t\225\023z\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\r\182\t\217\t\225\t\225\t\225\t\225\t\217\t\217\t\217\t\217\000\238\027\030\t\217\t\217\t\217\t\217\t\t\t\217\t\217\014\002\t\217\t\217\t\217\014\"\t\217\t\217\t\217\t\217\000\238\t\217\014B\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\014\138\t\217\015\006\t\217\025\006\t\217\t\217\t\217\t\217\t\217\026B\015\030\t\217\t\217\t\217\000\238\t\217\022\146\t\217\t\217\t\217\015\166\025\026\t\217\t\217\t\217\t\217\t\217\t\217\t\217\002^\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\015\170\t\217\t\217\015\226\t\217\t\217\t\217\015\230\016\014\016\018\016*\016\162\t\217\t\217\t\217\t\217\t\217\t\217\004\129\t\217\t\217\t\217\t\217\t\217\t\217\t\217\016\210\t\217\t\217\016\214\t\217\t\217\026\202\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\t\217\016\250\n\029\t\217\t\217\t\217\t\217\n\029\n\029\n\029\n\029\016\254\017\014\n\029\n\029\n\029\n\029\011\158\n\029\n\029\017\030\n\029\n\029\n\029\017*\n\029\n\029\n\029\n\029\017^\n\029\017b\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\017\178\n\029\017\218\n\029\017\222\n\029\n\029\n\029\n\029\n\029\018\"\018F\n\029\n\029\n\029\018V\n\029\022\158\n\029\n\029\n\029\018~\018\130\n\029\n\029\n\029\n\029\n\029\n\029\n\029\018\142\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\018\158\n\029\n\029\018\182\n\029\n\029\n\029\018\198\018\218\018\242\019\"\019&\n\029\n\029\n\029\n\029\n\029\n\029\0192\n\029\n\029\n\029\n\029\n\029\n\029\n\029\003\173\n\029\n\029\019B\n\029\n\029\019V\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\n\029\020J\t\181\n\029\n\029\n\029\n\029\t\181\t\181\t\181\t\181\020V\020\134\t\181\t\181\t\181\t\181\020\170\t\181\t\181\020\210\t\181\t\181\t\181\000\238\t\181\t\181\t\181\t\181\021Z\t\181\021n\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\021v\t\181\021\138\t\181\021\150\t\181\t\181\t\181\t\181\t\181\021\170\021\194\t\181\t\181\t\181\021\206\t\181\003\173\t\181\t\181\t\181\021\226\021\246\t\181\t\181\t\181\t\181\t\181\t\181\t\181\022\n\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\t\181\022\"\t\178\n\n\004%\t\181\t\181\t\181\015\250\0226\015\142\022J\022f\t\181\t\181\t\181\t\181\t\181\t\181\007\242\t\181\t\181\t\181\t\181\t\181\t\186\t\181\022z\n\018\t\181\022\142\t\181\t\181\016\002\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\000\238\t\181\t\181\t\181\t\181\t\181\002\t\022\178\b!\022\190\012\165\002\t\001\002\001\006\002\t\027\190\002j\001\"\002\t\t\202\002\t\022\202\001&\002\t\012\165\002\t\002\t\002\t\022\254\002\t\002\t\002\t\001*\004%\t\250\023\014\001.\002\t\002\t\002\t\002\t\002\t\n\002\002\t\t\190\0012\023\030\003z\023*\002\t\002\t\002\t\002\t\002\t\023^\023\134\003\206\002N\002\t\022\182\002\t\022\194\002\t\002\t\003F\023\142\023\150\003\214\002\t\002\t\002\t\b\154\b\158\b\170\023\158\019\226\005n\002\t\002\t\002\t\002\t\002\t\002\t\002\t\002\t\002\t\023\178\t\178\n\n\023\186\002\t\002\t\002\t\023\206\023\254\024*\024B\024Z\005z\002\t\005~\002\t\002\t\002\t\024v\002\t\002\t\002\t\002\t\b\178\021\214\b\182\024~\022\022\002\t\024\174\002\t\002\t\024\206\002\t\002\t\002\t\002\t\002\t\002\t\005\130\b\198\002\t\002\t\002\t\t>\004j\024\234\n\t\002\t\002\t\002\t\002\t\n\t\001\002\001\006\n\t\024\254\025&\001\"\n\t\n\t\n\t\025F\001&\n\t\025z\n\t\n\t\n\t\025\130\n\t\n\t\n\t\001*\025\142\n\t\025\238\001.\n\t\n\t\n\t\n\t\n\t\n\t\n\t\021\162\0012\026\030\003z\026&\n\t\n\t\n\t\n\t\n\t\026b\026z\003\206\002N\n\t\021\186\n\t\021\198\n\t\n\t\003F\026\210\026\230\003\214\n\t\n\t\n\t\b\154\b\158\b\170\027\002\n\t\005n\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\027*\n\t\n\t\0272\n\t\n\t\n\t\027Z\027b\027j\027v\027~\005z\n\t\005~\n\t\n\t\n\t\027\135\n\t\n\t\n\t\n\t\b\178\n\t\b\182\027\151\n\t\n\t\027\170\n\t\n\t\027\198\n\t\n\t\n\t\n\t\n\t\n\t\005\130\b\198\n\t\n\t\n\t\t>\004j\027\227\n\005\n\t\n\t\n\t\n\t\n\005\001\002\001\006\n\005\027\243\028\015\001\"\n\005\n\005\n\005\028c\001&\n\005\028\127\n\005\n\005\n\005\028\138\n\005\n\005\n\005\001*\028\191\n\005\028\211\001.\n\005\n\005\n\005\n\005\n\005\n\005\n\005\021\218\0012\028\219\003z\029\023\n\005\n\005\n\005\n\005\n\005\029\031\000\000\003\206\002N\n\005\021\238\n\005\022\002\n\005\n\005\003F\000\000\000\000\003\214\n\005\n\005\n\005\b\154\b\158\b\170\000\000\n\005\005n\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\000\000\n\005\n\005\000\000\n\005\n\005\n\005\000\000\000\000\000\000\000\000\000\000\005z\n\005\005~\n\005\n\005\n\005\000\000\n\005\n\005\n\005\n\005\b\178\n\005\b\182\000\000\n\005\n\005\000\000\n\005\n\005\000\000\n\005\n\005\n\005\n\005\n\005\n\005\005\130\b\198\n\005\n\005\n\005\t>\004j\000\000\002I\n\005\n\005\n\005\n\005\002I\001\002\001\006\002I\000\000\000\000\001\"\002I\t\202\002I\004i\001&\002I\000\000\002I\002I\002I\000\000\002I\002I\002I\001*\004i\t\250\000\000\001.\002I\002I\002I\002I\002I\n\002\002I\022^\0012\000\000\003z\004\218\002I\002I\002I\002I\002I\000\000\000\000\003\206\002N\002I\022r\002I\022\134\002I\002I\003F\000\238\000\000\003\214\002I\002I\002I\b\154\b\158\b\170\000\238\019\226\005n\002I\002I\002I\002I\002I\002I\002I\002I\002I\000\000\004i\002I\000\000\002I\002I\002I\019\014\004i\000\000\004i\000\000\005z\002I\005~\002I\002I\002I\000\000\002I\002I\002I\002I\b\178\000\000\b\182\004i\000\000\002I\000\000\002I\002I\019\022\002I\002I\002I\002I\002I\002I\005\130\b\198\002I\002I\002I\t>\004j\004i\004i\002I\002I\002I\002I\004i\004i\b\025\004i\004i\004i\004i\004i\004i\004i\004i\000\000\004i\000\238\004i\004i\004i\004i\004i\004i\000\000\004i\004i\004i\004i\004i\004i\004i\004i\004i\000\000\004i\004i\000\238\000\238\004i\004i\000\000\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\004i\006j\004i\004i\004i\004i\004i\004i\004i\004i\000\238\004i\004i\004i\004i\004i\004i\004i\004i\004i\019\162\004i\000\000\004i\004i\004i\004i\004i\004i\000\238\004i\000\n\004i\004i\004i\004i\004i\004i\004i\000\000\004i\004i\004i\000\000\000\238\004i\004i\002\237\002\237\004i\000\238\004i\004i\000\000\004i\004i\000\000\004i\012\182\000\000\000\000\002\237\001\"\000\000\004i\004i\004i\000\000\000\238\004i\004i\004i\004i\000\169\000\169\004i\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\000\000\169\000\000\000\169\000\169\019v\000\169\000\169\000\000\0062\000\169\000\169\005\222\000\169\000\169\000\169\000\169\012\186\000\169\006F\000\169\000\169\000\000\006N\000\169\000\169\018:\000\169\000\169\000\169\007\146\000\169\012\198\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\003\146\018\170\000\169\000\169\000\000\001\006\000\169\000\169\bJ\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\000\169\005~\002\237\000\169\000\000\t!\000\169\000\000\000\169\000\000\000\169\000\000\000\000\000\000\b\014\000\169\000\169\000\169\000\169\000\169\000\169\007\017\000\169\000\169\000\169\007\017\tZ\002N\000\169\000\n\r\210\000\169\003\134\000\169\000\238\000\222\000\000\023\002\000\000\000\169\000\000\023\018\023\"\023.\000\000\000\169\000\169\000\169\000\169\bf\002A\000\169\000\169\000\169\000\169\002A\001\002\001\006\002A\002\237\000\000\001\"\002A\000\238\002A\000\000\001&\002A\000\000\002A\002A\002A\000\000\002A\002A\002A\001*\000\000\024\146\000\000\001.\002A\002A\002A\002A\002A\000\000\002A\000\000\0012\000\000\003z\000\000\002A\002A\002A\002A\002A\007\017\000\000\003\206\b\174\002A\000\000\002A\000\000\002A\002A\003F\000\000\000\000\003\214\002A\002A\002A\b\154\b\158\b\170\004\022\014\162\005n\002A\002A\002A\002A\002A\002A\002A\002A\002A\000\000\t\178\n\n\000\000\002A\002A\002A\000\000\000\000\000\000\004!\000\000\005z\002A\005~\002A\002A\002A\000\000\002A\002A\002A\002A\b\178\t\186\b\182\000\000\n\018\002A\000\000\002A\002A\001\006\002A\002A\002A\002A\002A\002A\005\130\b\198\002A\002A\002A\t>\004j\000\000\002U\002A\002A\002A\002A\002U\000\238\025^\002U\000\000\000\000\000\000\002U\000\000\002U\000\000\000\000\002U\000\000\002U\002U\002U\000\000\002U\002U\002U\000\000\000\000\001\186\002N\000\000\002U\002U\002U\002U\002U\bf\002U\000\000\004!\000\000\028o\000\000\002U\002U\002U\002U\002U\000\000\000\000\000\238\000\000\002U\000\000\002U\0062\002U\002U\005\222\007\002\000\000\000\000\002U\002U\002U\006F\012\182\000\000\000\000\006N\001\"\002U\002U\002U\002U\002U\002U\002U\002U\002U\000\000\t\178\n\n\000\000\002U\002U\002U\000\000\r\246\000\000\000\000\000\000\002\237\002U\003\146\002U\002U\002U\000\000\002U\002U\002U\002U\025b\t\186\000\000\000\000\n\018\002U\012\186\002U\002U\007\146\002U\002U\002U\002U\002U\002U\000\n\000\000\002U\002U\002U\012\198\000\000\014\026\002Q\002U\002U\002U\002U\002Q\bR\003\146\002Q\002\237\001\186\002N\002Q\000\000\002Q\0051\000\000\002Q\000\000\002Q\002Q\002Q\002\237\002Q\002Q\002Q\005~\000\000\0051\b\014\000\000\002Q\002Q\002Q\002Q\002Q\000\000\002Q\014&\007\146\000\000\000\000\000\000\002Q\002Q\002Q\002Q\002Q\007\146\000\238\005\182\000\000\002Q\000\000\002Q\r\190\002Q\002Q\000\000\0051\b~\003\246\002Q\002Q\002Q\006n\012\182\004\002\000\000\t\130\001\"\002Q\002Q\002Q\002Q\002Q\002Q\002Q\002Q\002Q\000\000\t\178\n\n\b\014\002Q\002Q\002Q\000\000\000\000\000\000\0051\000\000\b\014\002Q\0051\002Q\002Q\002Q\000\000\002Q\002Q\002Q\002Q\000\238\t\186\000\000\000\000\n\018\002Q\012\186\002Q\002Q\000\238\002Q\002Q\002Q\002Q\002Q\002Q\000\000\000\000\002Q\002Q\002Q\012\198\003B\r\250\002E\002Q\002Q\002Q\002Q\002E\000\000\003\146\002E\000\000\000\000\028S\002E\000\000\002E\000\000\000\000\002E\000\000\002E\002E\002E\000\000\002E\002E\002E\005~\000\000\000\000\000\000\000\000\002E\002E\002E\002E\002E\000\000\002E\014\006\007\146\000\000\000\000\000\000\002E\002E\002E\002E\002E\007\146\000\000\tZ\023j\002E\000\000\002E\r\190\002E\002E\000\000\000\000\025j\023\002\002E\002E\002E\023\018\023\"\023.\000\000\025\166\000\000\002E\002E\002E\002E\002E\002E\002E\002E\002E\000\000\t\178\n\n\b\014\002E\002E\002E\000\000\000\000\000\000\006.\000\000\b\014\002E\000\000\002E\002E\002E\000\000\002E\002E\002E\002E\000\238\t\186\007\146\000\000\n\018\002E\000\000\002E\002E\000\238\002E\002E\002E\002E\002E\002E\000\000\b\025\002E\002E\002E\b\025\000\000\025\178\002M\002E\002E\002E\002E\002M\000\238\000\000\002M\000\000\000\000\000\000\002M\000\000\002M\014F\000\000\002M\000\000\002M\002M\002M\b\014\002M\002M\002M\012\029\012\029\000\000\000\000\012\029\002M\002M\002M\002M\002M\b\025\002M\000\000\t:\000\000\000\000\000\238\002M\002M\002M\002M\002M\000\000\000\000\000\000\b\025\002M\000\000\002M\0062\002M\002M\005\222\006:\000\000\027\018\002M\002M\002M\006F\000\000\012M\000\000\006N\000\238\002M\002M\002M\002M\002M\002M\002M\002M\002M\b\025\000\000\002M\000\000\002M\002M\002M\000\000\012M\000\000\000\000\002\194\025\182\002M\002\198\002M\002M\002M\000\000\002M\002M\002M\002M\012\029\000\238\007\146\000\000\002\210\002M\b\025\002M\002M\000\000\n&\002M\002M\002M\002M\002M\t&\t\230\002M\002M\002M\007\146\b\193\025\190\t)\002M\002M\002M\002M\t)\000\000\001\162\t)\002\222\023\162\001\"\t)\000\000\t)\000\000\000\000\nb\026\242\t)\n\134\t)\b\014\t)\t)\t)\0062\000\000\000\000\005\222\027\022\n\154\n\178\n\186\n\162\n\194\006F\t)\000\000\000\238\006N\b\014\000\238\t)\t)\n\202\n\210\t)\000\000\012\182\027\162\002j\t)\001\"\t)\000\000\n\218\t)\002\226\002\237\000\000\000\238\t)\t)\000\238\012\198\000\000\000\000\000\000\000\000\000\000\t)\t)\nj\n\170\n\226\n\234\n\250\t)\t)\000\000\000\000\t)\000\000\t)\t)\011\002\000\000\b\193\000\n\000\000\000\000\012\186\t)\005~\t)\t)\011\n\b\245\t)\t)\t)\t)\000\000\007\185\007\146\002\237\012\198\t)\000\000\t)\t)\000\000\011*\t)\0112\n\242\t)\t)\002\237\002\237\t)\011\018\t)\000\000\000\000\027\n\002\129\t)\t)\011\026\011\"\002\129\ni\000\000\002\129\005~\007\185\000\000\002\129\000\000\002\129\000\000\000\000\002\129\000\000\002\129\002\129\002\129\b\014\002\129\002\129\002\129\007\185\000\000\000\000\007\185\t\150\002\129\002\129\002\129\002\129\002\129\007\185\002\129\026\130\ni\007\185\000\000\000\238\002\129\002\129\002\129\002\129\002\129\000\000\b\173\000\000\000\000\002\129\000\000\002\129\ni\002\129\002\129\ni\011F\000\000\000\000\002\129\002\129\002\129\ni\000\000\000\000\000\000\ni\000\000\002\129\002\129\nj\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\001&\b\173\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\000\000\000\000\001F\000\000\002\129\000\000\002\129\002\129\b\173\002\129\002\129\002\129\002\129\002\129\002\129\001R\000\000\002\129\002\129\002\129\000\000\000\000\000\000\002i\002\129\002\129\002\129\002\129\002i\000\000\000\000\002i\000\000\000\000\000\000\002i\000\000\002i\000\000\005n\002i\000\000\002i\002i\002i\b\173\002i\002i\002i\004\246\000\000\000\000\b\173\000\000\002i\002i\002i\002i\002i\002^\002i\005z\000\000\000\000\000\000\000\000\002i\002i\002i\002i\002i\000\000\b\169\000\000\000\000\002i\000\000\002i\001*\002i\002i\000\000\000\000\000\000\0236\002i\002i\002i\005\130\000\000\000\000\015\174\000\000\000\000\002i\002i\nj\002i\002i\002i\002i\002i\002i\0036\000\000\002i\016&\002i\002i\002i\003F\000\000\000\000\b\169\000\000\000\000\002i\016>\002i\002i\002i\000\000\002i\002i\002i\002i\000\000\000\000\000\000\000\000\000\000\002i\000\000\002i\002i\b\169\002i\002i\002i\002i\002i\002i\000\000\0079\002i\002i\002i\0079\000\000\000\000\002u\002i\002i\002i\002i\002u\000\238\000\000\002u\000\000\000\000\000\000\002u\000\000\002u\t\178\n\n\nb\000\000\002u\002u\002u\b\169\002u\002u\002u\004\246\000\000\000\000\b\169\000\000\002u\002u\002u\n\162\002u\000\000\002u\t\186\011Z\000\000\n\018\000\000\002u\002u\002u\002u\002u\000\000\000\000\000\000\000\000\002u\000\000\002u\011b\002u\002u\011j\000\000\000\000\000\000\002u\002u\002u\011r\000\000\000\000\000\000\011z\0079\002u\002u\nj\n\170\002u\002u\002u\002u\002u\000\000\000\000\002u\000\000\002u\002u\002u\t\214\000\000\000\000\t\222\000\000\000\000\002u\000\000\002u\002u\002u\000\000\002u\002u\002u\002u\000\000\000\238\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\133\002u\002u\002u\002u\002\133\007\205\000\000\002\133\000\000\007\181\000\000\002\133\000\000\002\133\002^\000\000\002\133\000\000\002\133\002\133\002\133\000\000\002\133\002\133\002\133\007\181\000\000\026\014\005\222\000\000\002\133\002\133\002\133\002\133\002\133\007\181\002\133\000\000\007\205\007\181\000\000\000\000\002\133\002\133\002\133\002\133\002\133\000\000\000\000\000\000\000\000\002\133\000\000\002\133\007\205\002\133\002\133\005\222\0036\000\000\000\000\002\133\002\133\002\133\007\205\000\000\000\000\000\000\007\205\000\000\002\133\002\133\nj\002\133\002\133\002\133\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\004\146\000\000\000\000\002\133\005\r\002\133\002\133\002\133\000\000\002\133\002\133\002\133\002\133\000\000\000\238\000\000\000\000\000\000\002\133\000\000\002\133\002\133\000\000\002\133\002\133\002\133\002\133\002\133\002\133\000\000\000\000\002\133\002\133\002\133\000\000\000\000\000\000\002e\002\133\002\133\002\133\002\133\002e\007\221\000\000\002e\000\000\007\225\000\000\002e\000\000\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\0062\000\000\000\000\005\222\000\000\002e\002e\002e\002e\002e\007\225\002e\000\000\007\221\007\225\000\000\000\000\002e\002e\002e\002e\002e\000\000\000\000\000\000\000\000\002e\000\000\002e\011\142\002e\002e\007\221\000\000\000\000\000\000\002e\002e\002e\007\221\000\000\000\000\000\000\007\221\000\000\002e\002e\nj\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\002e\000\000\000\238\000\000\000\000\000\000\002e\000\000\002e\002e\000\000\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\002e\002e\000\000\000\000\000\000\002q\002e\002e\002e\002e\002q\000\238\000\000\002q\000\000\007\177\000\000\002q\000\000\002q\000\000\000\000\nb\000\000\002q\002q\002q\000\000\002q\002q\002q\007\177\000\000\000\000\005\222\000\000\002q\002q\002q\n\162\002q\007\177\002q\000\000\022\214\007\177\000\000\000\000\002q\002q\002q\002q\002q\000\000\000\000\000\000\000\000\002q\000\000\002q\011b\002q\002q\011j\000\000\000\000\000\000\002q\002q\002q\011r\000\000\000\000\000\000\011z\000\000\002q\002q\nj\n\170\002q\002q\002q\002q\002q\000\000\000\000\002q\000\000\002q\002q\002q\000\000\000\000\000\000\012%\012%\000\000\002q\012%\002q\002q\002q\000\000\002q\002q\002q\002q\000\000\000\000\012!\012!\000\000\002q\012!\002q\002q\000\000\002q\002q\002q\002q\002q\002q\000\000\000\000\002q\002q\002q\000\000\000\000\000\000\002m\002q\002q\002q\002q\002m\002\237\000\238\002m\000\000\015\130\000\000\002m\000\000\002m\000\000\000\000\nb\000\000\002m\002m\002m\000\238\002m\002m\002m\b\r\000\000\000\000\000\000\b\r\002m\002m\002m\n\162\002m\000\n\002m\000\000\000\000\012%\000\000\000\000\002m\002m\002m\002m\002m\000\000\000\000\000\000\000\000\002m\002\237\002m\012!\002m\002m\000\000\000\000\000\000\007\021\002m\002m\002m\007\021\002\237\002\237\000\000\000\000\b\r\002m\002m\nj\n\170\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\b\r\002m\000\000\002m\002m\002m\000\000\002m\002m\002m\002m\000\000\000\000\000\238\000\000\000\000\002m\000\000\002m\002m\000\000\002m\002m\002m\002m\002m\002m\000\000\000\000\002m\002m\002m\000\000\000\000\000\000\002\149\002m\002m\002m\002m\002\149\004\246\001\006\002\149\000\000\000\000\007\021\002\149\000\000\002\149\000\000\000\000\nb\000\000\002\149\002\149\002\149\000\000\002\149\002\149\002\149\b\t\000\000\000\000\000\000\b\t\n\154\n\178\n\186\n\162\n\194\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002\149\002\149\n\202\n\210\002\149\000\000\000\000\n\022\003\134\002\149\000\000\002\149\000\000\n\218\002\149\000\000\000\000\000\000\000\000\002\149\002\149\000\238\021\130\000\000\021\142\000\000\000\000\b\t\002\149\002\149\nj\n\170\n\226\n\234\n\250\002\149\002\149\000\000\000\000\002\149\000\000\002\149\002\149\011\002\000\000\000\000\000\000\000\000\000\000\b\t\002\149\000\000\002\149\002\149\011\n\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\n\242\002\149\002\149\000\000\000\000\002\149\011\018\002\149\000\000\000\000\000\000\002}\002\149\002\149\011\026\011\"\002}\004\246\001\006\002}\000\000\000\000\000\000\002}\000\000\002}\000\000\000\000\nb\000\000\002}\002}\002}\000\000\002}\002}\002}\000\000\000\000\000\000\000\000\000\000\002}\002}\002}\n\162\002}\000\000\002}\000\000\000\000\000\000\000\000\000\000\002}\002}\002}\002}\002}\000\000\000\000\022\026\003\134\002}\000\000\002}\000\000\002}\002}\000\000\000\000\000\000\000\000\002}\002}\002}\022.\000\000\022B\000\000\000\000\000\000\002}\002}\nj\n\170\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\nb\000\000\002y\002y\002y\000\000\002y\002y\002y\000\000\000\000\000\000\000\000\000\000\002y\002y\002y\n\162\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\000\000\002y\002y\nj\n\170\002y\002y\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\002y\002y\002y\000\000\000\000\002y\002y\002y\000\000\000\000\000\000\002\141\002y\002y\002y\002y\002\141\000\000\000\000\002\141\000\000\000\000\000\000\002\141\000\000\002\141\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\002\141\000\000\002\141\000\000\000\000\000\000\000\000\000\000\002\141\002\141\n\202\n\210\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\nj\n\170\n\226\n\234\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\n\242\002\141\002\141\000\000\000\000\002\141\002\141\002\141\000\000\000\000\000\000\002a\002\141\002\141\002\141\002\141\002a\000\000\000\000\002a\000\000\000\000\000\000\002a\000\000\002a\000\000\000\000\nb\000\000\002a\002a\002a\000\000\002a\002a\002a\000\000\000\000\000\000\000\000\000\000\002a\002a\002a\n\162\002a\000\000\002a\000\000\000\000\000\000\000\000\000\000\002a\002a\002a\002a\002a\000\000\000\000\000\000\000\000\002a\000\000\002a\000\000\002a\002a\000\000\000\000\000\000\000\000\002a\002a\002a\000\000\000\000\000\000\000\000\000\000\000\000\002a\002a\nj\n\170\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\000\000\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\002]\002a\002a\002a\002a\002]\000\000\000\000\002]\000\000\000\000\000\000\002]\000\000\002]\000\000\000\000\nb\000\000\002]\002]\002]\000\000\002]\002]\002]\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\002]\000\000\002]\000\000\000\000\000\000\000\000\000\000\002]\002]\n\202\n\210\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]\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002]\002]\nj\n\170\n\226\n\234\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]\n\242\002]\002]\000\000\000\000\002]\002]\002]\000\000\000\000\000\000\002\185\002]\002]\002]\002]\002\185\000\000\000\000\002\185\000\000\000\000\000\000\002\185\000\000\002\185\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\002\185\000\000\002\185\000\000\000\000\000\000\000\000\000\000\002\185\002\185\n\202\n\210\002\185\000\000\000\000\000\000\000\000\002\185\000\000\002\185\000\000\002\185\002\185\000\000\000\000\000\000\000\000\002\185\002\185\002\185\000\000\000\000\000\000\000\000\000\000\000\000\002\185\002\185\nj\n\170\n\226\002\185\002\185\002\185\002\185\000\000\000\000\002\185\000\000\002\185\002\185\002\185\000\000\000\000\000\000\000\000\000\000\000\000\002\185\000\000\002\185\002\185\002\185\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\002\185\002\185\002\185\n\242\002\185\002\185\000\000\000\000\002\185\002\185\002\185\000\000\000\000\000\000\002Y\002\185\002\185\002\185\002\185\002Y\000\000\000\000\002Y\000\000\000\000\000\000\002Y\000\000\002Y\000\000\000\000\nb\000\000\002Y\002Y\002Y\000\000\002Y\002Y\002Y\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\002Y\000\000\002Y\000\000\000\000\000\000\000\000\000\000\002Y\002Y\n\202\n\210\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\nj\n\170\n\226\n\234\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\n\242\002Y\002Y\000\000\000\000\002Y\002Y\002Y\000\000\000\000\000\000\002\145\002Y\002Y\002Y\002Y\002\145\000\000\000\000\002\145\000\000\000\000\000\000\002\145\000\000\002\145\000\000\000\000\nb\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\002\145\000\000\002\145\000\000\000\000\000\000\000\000\000\000\002\145\002\145\n\202\n\210\002\145\000\000\000\000\000\000\000\000\002\145\000\000\002\145\000\000\002\145\002\145\000\000\000\000\000\000\000\000\002\145\002\145\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\145\nj\n\170\n\226\n\234\002\145\002\145\002\145\000\000\000\000\002\145\000\000\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\000\000\002\145\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\002\145\000\000\002\145\002\145\000\000\002\145\002\145\002\145\n\242\002\145\002\145\000\000\000\000\002\145\002\145\002\145\000\000\000\000\000\000\002\137\002\145\002\145\002\145\002\145\002\137\000\000\000\000\002\137\000\000\000\000\000\000\002\137\000\000\002\137\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\002\137\000\000\002\137\000\000\000\000\000\000\000\000\000\000\002\137\002\137\n\202\n\210\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\nj\n\170\n\226\n\234\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\n\242\002\137\002\137\000\000\000\000\002\137\002\137\002\137\000\000\000\000\000\000\002\153\002\137\002\137\002\137\002\137\002\153\000\000\000\000\002\153\000\000\000\000\000\000\002\153\000\000\002\153\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\153\000\000\000\000\000\000\000\000\000\000\002\153\002\153\n\202\n\210\002\153\000\000\000\000\000\000\000\000\002\153\000\000\002\153\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\153\002\153\000\000\000\000\002\153\000\000\002\153\002\153\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\153\000\000\002\153\002\153\011\n\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\n\242\002\153\002\153\000\000\000\000\002\153\011\018\002\153\000\000\000\000\000\000\002\157\002\153\002\153\011\026\011\"\002\157\000\000\000\000\002\157\000\000\000\000\000\000\002\157\000\000\002\157\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\002\157\000\000\002\157\000\000\000\000\000\000\000\000\000\000\002\157\002\157\n\202\n\210\002\157\000\000\000\000\000\000\000\000\002\157\000\000\002\157\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\157\002\157\000\000\000\000\002\157\000\000\002\157\002\157\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\157\000\000\002\157\002\157\011\n\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\n\242\002\157\002\157\000\000\000\000\002\157\002\157\002\157\000\000\000\000\000\000\002\161\002\157\002\157\011\026\011\"\002\161\000\000\000\000\002\161\000\000\000\000\000\000\002\161\000\000\002\161\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\002\161\000\000\002\161\000\000\000\000\000\000\000\000\000\000\002\161\002\161\n\202\n\210\002\161\000\000\000\000\000\000\000\000\002\161\000\000\002\161\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\161\002\161\000\000\000\000\002\161\000\000\002\161\002\161\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\161\000\000\002\161\002\161\011\n\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\002\161\002\161\002\161\n\242\002\161\002\161\000\000\000\000\002\161\002\161\002\161\000\000\000\000\000\000\b\229\002\161\002\161\011\026\011\"\b\229\000\000\000\000\b\229\000\000\000\000\000\000\b\229\000\000\b\229\000\000\000\000\nb\000\000\b\229\b\229\b\229\000\000\b\229\b\229\b\229\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\b\229\000\000\000\000\000\000\000\000\000\000\b\229\b\229\n\202\n\210\b\229\000\000\000\000\000\000\000\000\b\229\000\000\b\229\000\000\n\218\b\229\000\000\000\000\000\000\000\000\b\229\b\229\000\238\000\000\000\000\000\000\000\000\000\000\000\000\b\229\b\229\nj\n\170\n\226\n\234\n\250\b\229\b\229\000\000\000\000\b\229\000\000\b\229\b\229\011\002\000\000\000\000\000\000\000\000\000\000\000\000\b\229\000\000\b\229\b\229\011\n\000\000\b\229\b\229\b\229\b\229\000\000\000\000\000\000\000\000\000\000\b\229\000\000\b\229\b\229\000\000\b\229\b\229\b\229\n\242\b\229\b\229\000\000\000\000\b\229\011\018\b\229\000\000\000\000\000\000\002\165\b\229\b\229\011\026\011\"\002\165\000\000\000\000\002\165\000\000\000\000\000\000\002\165\000\000\002\165\000\000\000\000\nb\000\000\002\165\002\165\002\165\000\000\002\165\002\165\002\165\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\002\165\000\000\000\000\000\000\000\000\000\000\002\165\002\165\n\202\n\210\002\165\000\000\000\000\000\000\000\000\002\165\000\000\002\165\000\000\n\218\002\165\000\000\000\000\000\000\000\000\002\165\002\165\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\165\002\165\nj\n\170\n\226\n\234\n\250\002\165\002\165\000\000\000\000\002\165\000\000\002\165\002\165\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\165\000\000\002\165\002\165\011\n\000\000\002\165\002\165\002\165\002\165\000\000\000\000\000\000\000\000\000\000\002\165\000\000\002\165\002\165\000\000\011*\002\165\0112\n\242\002\165\002\165\000\000\000\000\002\165\011\018\002\165\000\000\000\000\000\000\b\225\002\165\002\165\011\026\011\"\b\225\000\000\000\000\b\225\000\000\000\000\000\000\b\225\000\000\b\225\000\000\000\000\nb\000\000\b\225\b\225\b\225\000\000\b\225\b\225\b\225\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\b\225\000\000\000\000\000\000\000\000\000\000\b\225\b\225\n\202\n\210\b\225\000\000\000\000\000\000\000\000\b\225\000\000\b\225\000\000\n\218\b\225\000\000\000\000\000\000\000\000\b\225\b\225\000\238\000\000\000\000\000\000\000\000\000\000\000\000\b\225\b\225\nj\n\170\n\226\n\234\n\250\b\225\b\225\000\000\000\000\b\225\000\000\b\225\b\225\011\002\000\000\000\000\000\000\000\000\000\000\000\000\b\225\000\000\b\225\b\225\011\n\000\000\b\225\b\225\b\225\b\225\000\000\000\000\000\000\000\000\000\000\b\225\000\000\b\225\b\225\000\000\b\225\b\225\b\225\n\242\b\225\b\225\000\000\000\000\b\225\011\018\b\225\000\000\000\000\000\000\002\209\b\225\b\225\011\026\011\"\002\209\000\000\000\000\002\209\000\000\000\000\000\000\002\209\000\000\002\209\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\209\000\000\000\000\000\000\000\000\000\000\002\209\002\209\n\202\n\210\002\209\000\000\000\000\000\000\000\000\002\209\000\000\002\209\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\209\002\209\000\000\000\000\002\209\000\000\002\209\002\209\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\209\000\000\002\209\002\209\011\n\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\011*\002\209\0112\n\242\002\209\002\209\000\000\000\000\002\209\011\018\002\209\000\000\000\000\000\000\002\225\002\209\002\209\011\026\011\"\002\225\000\000\000\000\002\225\000\000\000\000\000\000\002\225\000\000\002\225\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\225\000\000\000\000\000\000\000\000\000\000\002\225\002\225\n\202\n\210\002\225\000\000\000\000\000\000\000\000\002\225\000\000\002\225\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\225\002\225\000\000\000\000\002\225\000\000\002\225\002\225\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\225\000\000\002\225\002\225\011\n\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\011*\002\225\0112\n\242\002\225\002\225\000\000\000\000\002\225\011\018\002\225\000\000\000\000\000\000\002\217\002\225\002\225\011\026\011\"\002\217\000\000\000\000\002\217\000\000\000\000\000\000\002\217\000\000\002\217\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\217\000\000\000\000\000\000\000\000\000\000\002\217\002\217\n\202\n\210\002\217\000\000\000\000\000\000\000\000\002\217\000\000\002\217\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\217\002\217\000\000\000\000\002\217\000\000\002\217\002\217\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\217\000\000\002\217\002\217\011\n\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\011*\002\217\0112\n\242\002\217\002\217\000\000\000\000\002\217\011\018\002\217\000\000\000\000\000\000\002\197\002\217\002\217\011\026\011\"\002\197\000\000\000\000\002\197\000\000\000\000\000\000\002\197\000\000\002\197\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\197\000\000\000\000\000\000\000\000\000\000\002\197\002\197\n\202\n\210\002\197\000\000\000\000\000\000\000\000\002\197\000\000\002\197\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\197\002\197\000\000\000\000\002\197\000\000\002\197\002\197\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\197\000\000\002\197\002\197\011\n\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\011*\002\197\0112\n\242\002\197\002\197\000\000\000\000\002\197\011\018\002\197\000\000\000\000\000\000\002\205\002\197\002\197\011\026\011\"\002\205\000\000\000\000\002\205\000\000\000\000\000\000\002\205\000\000\002\205\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\205\000\000\000\000\000\000\000\000\000\000\002\205\002\205\n\202\n\210\002\205\000\000\000\000\000\000\000\000\002\205\000\000\002\205\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\205\002\205\000\000\000\000\002\205\000\000\002\205\002\205\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\205\000\000\002\205\002\205\011\n\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\011*\002\205\0112\n\242\002\205\002\205\000\000\000\000\002\205\011\018\002\205\000\000\000\000\000\000\002\201\002\205\002\205\011\026\011\"\002\201\000\000\000\000\002\201\000\000\000\000\000\000\002\201\000\000\002\201\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\201\000\000\000\000\000\000\000\000\000\000\002\201\002\201\n\202\n\210\002\201\000\000\000\000\000\000\000\000\002\201\000\000\002\201\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\201\002\201\000\000\000\000\002\201\000\000\002\201\002\201\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\201\000\000\002\201\002\201\011\n\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\011*\002\201\0112\n\242\002\201\002\201\000\000\000\000\002\201\011\018\002\201\000\000\000\000\000\000\002\213\002\201\002\201\011\026\011\"\002\213\000\000\000\000\002\213\000\000\000\000\000\000\002\213\000\000\002\213\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\213\000\000\000\000\000\000\000\000\000\000\002\213\002\213\n\202\n\210\002\213\000\000\000\000\000\000\000\000\002\213\000\000\002\213\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\213\002\213\000\000\000\000\002\213\000\000\002\213\002\213\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\213\000\000\002\213\002\213\011\n\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\011*\002\213\0112\n\242\002\213\002\213\000\000\000\000\002\213\011\018\002\213\000\000\000\000\000\000\002\229\002\213\002\213\011\026\011\"\002\229\000\000\000\000\002\229\000\000\000\000\000\000\002\229\000\000\002\229\000\000\000\000\nb\000\000\002\229\002\229\002\229\000\000\002\229\002\229\002\229\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\002\229\000\000\000\000\000\000\000\000\000\000\002\229\002\229\n\202\n\210\002\229\000\000\000\000\000\000\000\000\002\229\000\000\002\229\000\000\n\218\002\229\000\000\000\000\000\000\000\000\002\229\002\229\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\229\002\229\nj\n\170\n\226\n\234\n\250\002\229\002\229\000\000\000\000\002\229\000\000\002\229\002\229\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\229\000\000\002\229\002\229\011\n\000\000\002\229\002\229\002\229\002\229\000\000\000\000\000\000\000\000\000\000\002\229\000\000\002\229\002\229\000\000\011*\002\229\0112\n\242\002\229\002\229\000\000\000\000\002\229\011\018\002\229\000\000\000\000\000\000\002\221\002\229\002\229\011\026\011\"\002\221\000\000\000\000\002\221\000\000\000\000\000\000\002\221\000\000\002\221\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\221\000\000\000\000\000\000\000\000\000\000\002\221\002\221\n\202\n\210\002\221\000\000\000\000\000\000\000\000\002\221\000\000\002\221\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\221\002\221\000\000\000\000\002\221\000\000\002\221\002\221\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\221\000\000\002\221\002\221\011\n\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\011*\002\221\0112\n\242\002\221\002\221\000\000\000\000\002\221\011\018\002\221\000\000\000\000\000\000\002\193\002\221\002\221\011\026\011\"\002\193\000\000\000\000\002\193\000\000\000\000\000\000\002\193\000\000\002\193\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\193\000\000\000\000\000\000\000\000\000\000\002\193\002\193\n\202\n\210\002\193\000\000\000\000\000\000\000\000\002\193\000\000\002\193\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\193\002\193\000\000\000\000\002\193\000\000\002\193\002\193\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\193\000\000\002\193\002\193\011\n\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\011*\002\193\0112\n\242\002\193\002\193\000\000\000\000\002\193\011\018\002\193\000\000\000\000\000\000\002\029\002\193\002\193\011\026\011\"\002\029\000\000\000\000\002\029\000\000\000\000\000\000\002\029\000\000\002\029\000\000\000\000\002\029\000\000\002\029\002\029\002\029\000\000\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\000\000\002\029\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\000\000\000\000\000\000\000\000\002\029\000\000\002\029\000\000\002\029\002\029\000\000\000\000\000\000\000\000\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\002\029\002\029\002\029\002\029\000\000\000\000\002\029\000\000\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\000\000\002\029\000\000\002\029\002\029\002\029\000\000\002\029\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\002\029\000\000\002\029\002\029\000\000\002\029\002\029\002\029\002\029\002\029\002\029\000\000\000\000\002\029\002\029\024\026\000\000\000\000\000\000\0025\002\029\002\029\002\029\002\029\0025\000\000\000\000\0025\000\000\000\000\000\000\0025\000\000\0025\000\000\000\000\nb\000\000\0025\0025\0025\000\000\0025\0025\0025\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\0025\000\000\000\000\000\000\000\000\000\000\0025\0025\n\202\n\210\0025\000\000\000\000\000\000\000\000\0025\000\000\0025\000\000\n\218\0025\000\000\000\000\000\000\000\000\0025\0025\000\238\000\000\000\000\000\000\000\000\000\000\000\000\0025\0025\nj\n\170\n\226\n\234\n\250\0025\0025\000\000\000\000\0025\000\000\0025\0025\011\002\000\000\000\000\000\000\000\000\000\000\000\000\0025\000\000\0025\0025\011\n\000\000\0025\0025\0242\0025\000\000\000\000\000\000\000\000\000\000\0025\000\000\0025\0025\000\000\011*\0025\0112\n\242\0025\0025\000\000\000\000\0025\011\018\0025\000\000\000\000\000\000\0021\0025\0025\011\026\011\"\0021\000\000\000\000\0021\000\000\000\000\000\000\0021\000\000\0021\000\000\000\000\nb\000\000\0021\0021\0021\000\000\0021\0021\0021\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\0021\000\000\000\000\000\000\000\000\000\000\0021\0021\n\202\n\210\0021\000\000\000\000\000\000\000\000\0021\000\000\0021\000\000\n\218\0021\000\000\000\000\000\000\000\000\0021\0021\000\238\000\000\000\000\000\000\000\000\000\000\000\000\0021\0021\nj\n\170\n\226\n\234\n\250\0021\0021\000\000\000\000\0021\000\000\0021\0021\011\002\000\000\000\000\000\000\000\000\000\000\000\000\0021\000\000\0021\0021\011\n\000\000\0021\0021\0021\0021\000\000\000\000\000\000\000\000\000\000\0021\000\000\0021\0021\000\000\011*\0021\0112\n\242\0021\0021\000\000\000\000\0021\011\018\0021\000\000\000\000\000\000\002\189\0021\0021\011\026\011\"\002\189\000\000\000\000\002\189\000\000\000\000\000\000\002\189\000\000\002\189\000\000\000\000\nb\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\n\154\n\178\n\186\n\162\n\194\000\000\002\189\000\000\000\000\000\000\000\000\000\000\002\189\002\189\n\202\n\210\002\189\000\000\000\000\000\000\000\000\002\189\000\000\002\189\000\000\n\218\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\nj\n\170\n\226\n\234\n\250\002\189\002\189\000\000\000\000\002\189\000\000\002\189\002\189\011\002\000\000\000\000\000\000\000\000\000\000\000\000\002\189\000\000\002\189\002\189\011\n\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\011*\002\189\0112\n\242\002\189\002\189\000\000\000\000\002\189\011\018\002\189\000\000\000\000\000\000\002)\002\189\002\189\011\026\011\"\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)\024\026\000\000\000\000\000\000\001\233\002)\002)\002)\002)\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\001\233\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\024\026\000\000\000\000\000\000\002-\001\233\001\233\001\233\001\233\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-\024\026\000\000\000\000\000\000\027>\002-\002-\002-\002-\001\237\000\000\000\000\001\237\000\000\000\000\000\000\001\237\000\000\001\237\000\000\000\000\001\237\000\000\001\237\001\237\001\237\000\000\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\001\237\001\237\001\237\001\237\001\237\000\000\001\237\000\000\000\000\000\000\000\000\000\000\001\237\001\237\001\237\001\237\001\237\000\000\000\000\000\000\000\000\001\237\000\000\001\237\000\000\001\237\001\237\000\000\000\000\000\000\000\000\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\000\000\001\237\001\237\001\237\001\237\001\237\001\237\001\237\001\237\001\237\000\000\000\000\001\237\000\000\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\000\000\027N\000\000\001\237\001\237\001\237\000\000\001\237\001\237\001\237\001\237\000\000\000\000\000\000\000\000\000\000\001\237\000\000\001\237\001\237\000\000\001\237\001\237\001\237\001\237\001\237\001\237\000\000\000\000\001\237\001\237\001\237\000\000\000\000\000\000\001\241\001\237\001\237\001\237\001\237\001\241\000\000\000\000\001\241\000\000\000\000\000\000\001\241\000\000\001\241\000\000\000\000\001\241\000\000\001\241\001\241\001\241\000\000\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\001\241\000\000\001\241\000\000\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\001\241\000\000\000\000\000\000\000\000\001\241\000\000\001\241\000\000\001\241\001\241\000\000\000\000\000\000\000\000\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\000\000\000\000\001\241\000\000\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\000\000\027F\000\000\001\241\001\241\001\241\000\000\001\241\001\241\001\241\001\241\000\000\000\000\000\000\000\000\000\000\001\241\000\000\001\241\001\241\000\000\001\241\001\241\001\241\001\241\001\241\001\241\000\000\000\000\001\241\001\241\024\026\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\000\006\000\246\000\000\000\000\007\t\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\007\t\001*\000\000\000\000\000\000\003\210\001n\tb\tf\001z\001~\000\000\000\000\000\000\0012\000\000\003z\000\000\025N\000\000\t\134\t\138\007\t\003\182\003\194\003\206\003\218\003\226\t\142\007:\000\000\001\206\007\t\003F\000\000\000\000\003\214\007\t\007\t\000\238\b\154\b\158\b\170\b\186\000\000\005n\007\t\007\t\001\210\001\214\001\218\001\222\001\226\000\000\000\000\b\210\001\230\000\000\000\000\000\000\000\000\001\234\000\000\b\222\b\246\t\022\t*\005z\000\000\005~\000\000\000\000\001\238\000\000\000\000\007\t\000\000\000\000\b\178\001\242\b\182\000\000\000\000\000\000\000\000\000\000\007\t\000\000\000\000\000\000\002.\006\"\000\000\000\000\005\130\b\198\000\000\0022\000\000\022\246\004j\t\162\020R\002:\000\000\002>\002B\000\006\000\246\000\000\000\000\001\189\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\t^\000\000\000\000\000\000\001\189\001*\000\000\000\000\000\000\003\210\001n\tb\tf\001z\001~\000\000\000\000\b\242\0012\000\000\003z\000\000\tj\000\000\t\134\t\138\001\189\003\182\003\194\003\206\003\218\003\226\t\142\007:\007-\001\206\001\189\003F\007-\000\000\003\214\001\189\001\189\000\238\b\154\b\158\b\170\b\186\000\000\005n\001\189\001\189\001\210\001\214\001\218\001\222\001\226\000\000\024\006\b\210\001\230\000\000\000\000\000\000\000\000\001\234\000\000\b\222\b\246\t\022\t*\005z\000\000\005~\000\000\000\000\001\238\000\000\000\238\001\189\000\000\000\000\b\178\001\242\b\182\000\000\002\237\002\237\011\186\000\000\001\189\000\000\000\000\000\000\002.\006^\000\000\000\000\005\130\b\198\000\000\0022\002\237\022\246\004j\t\162\000\000\002:\000\000\002>\002B\000\006\000\246\000\000\000\n\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\0062\000\000\003N\005\222\000\000\000\000\004\149\000\000\003R\001*\006F\011\166\000\000\001.\006N\003V\003Z\002\237\002\237\002\237\003^\000\000\0012\000\000\003z\000\000\011\182\002\237\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\006\234\007:\002\237\000\000\012B\003F\000\000\000\000\003\214\012J\000\n\000\000\b\154\b\158\b\170\b\186\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012R\002\237\b\210\002\237\002\237\014\202\000\000\000\000\000\000\002\237\b\222\b\246\t\022\t*\005z\002\237\005~\012f\012\170\002\237\000\000\004\149\004\149\000\000\000\000\b\178\000\000\b\182\000\000\000\000\000\000\000\n\000\000\000\000\000\000\000\000\000\000\000\000\002\237\r\138\018\014\005\130\b\198\025>\000\000\000\000\t>\004j\t\162\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\002\237\000\000\000\000\001&\000\000\000\000\004\181\000\000\b\253\000\000\b\253\b\253\003R\001*\003b\001\006\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\003^\000\000\0012\000\000\003z\000\000\011\182\000\000\003\174\003\178\001*\003\182\003\194\003\206\003\218\003\226\006\234\007:\000\000\000\000\012B\003F\000\000\018*\003\214\012J\002Z\002^\b\154\b\158\b\170\b\186\000\000\005n\019~\003\134\000\000\000\000\019\130\000\000\000\000\012R\003F\b\210\000\000\028\146\001*\002\134\002r\019\178\000\000\b\222\b\246\t\022\t*\005z\002~\005~\012f\012\170\000\000\000\000\028\179\024:\000\000\000\000\b\178\000\000\b\182\000\000\002\130\003.\000\000\019\194\000\000\000\000\003:\000\000\003F\004\026\004&\018\014\005\130\b\198\b\253\0042\000\000\t>\004j\t\162\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\0046\000\000\000\000\001&\002\237\000\000\028\226\000\000\002\237\000\000\003\254\000\000\003R\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\003^\000\000\0012\000\000\003z\000\000\011\182\000\n\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\006\234\007:\000\000\004j\012B\003F\000\000\002\237\003\214\012J\002Z\002^\b\154\b\158\b\170\b\186\000\000\005n\000\000\000\000\000\000\002\237\002\237\000\000\000\000\012R\000\000\b\210\000\000\028\146\001*\002\134\002r\000\000\000\000\b\222\b\246\t\022\t*\005z\002~\005~\012f\012\170\000\000\000\000\004\189\002\142\000\000\000\000\b\178\002\237\b\182\000\000\002\130\003.\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\018\014\005\130\b\198\023\006\0042\000\000\t>\004j\t\162\000\181\001\002\001\006\000\181\012\129\000\000\001\"\000\000\t\202\000\000\000\000\001&\0046\000\000\000\181\000\000\000\181\000\000\000\181\000\000\000\181\001*\000\000\t\250\005a\001.\000\000\000\000\005a\000\000\000\000\n\002\000\181\000\000\0012\000\000\003z\000\000\000\181\000\000\000\000\000\000\000\181\000\000\000\000\003\206\002N\000\181\012M\000\181\000\000\000\000\000\181\003F\000\000\000\000\003\214\000\181\000\181\000\181\b\154\b\158\b\170\000\000\019\226\005n\000\181\000\181\000\000\012M\000\000\000\000\002\194\000\181\000\000\002\198\000\000\000\181\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\129\012\129\005z\002\210\005~\000\181\000\181\002\218\0129\000\181\000\181\000\000\000\000\b\178\000\000\b\182\005a\000\000\000\000\000\000\000\000\000\181\000\000\012\129\000\000\000\000\012\129\000\181\000\181\005\130\b\198\000\000\002\222\005a\t>\004j\005a\000\181\000\000\000\181\000\205\001\002\001\006\000\205\000\000\000\000\001\"\000\000\t\202\000\000\000\000\001&\000\000\000\000\000\205\000\000\000\205\000\000\000\205\000\000\000\205\001*\000\000\t\250\000\000\001.\000\000\000\000\000\000\000\000\000\000\n\002\000\205\000\000\0012\000\000\003z\000\000\000\205\000\000\000\000\002\226\000\205\000\000\000\000\003\206\002N\000\205\000\000\000\205\000\000\002\237\000\205\003F\000\000\000\000\003\214\000\205\000\205\000\205\b\154\b\158\b\170\000\000\019\226\005n\000\205\000\205\011\174\000\000\000\000\002\237\000\000\000\205\000\000\000\000\000\000\000\205\000\000\000\000\000\n\000\000\000\000\000\000\000\000\000\000\000\000\005z\007\249\005~\000\205\000\205\000\000\002\237\000\205\000\205\002\237\000\000\b\178\000\000\b\182\000\000\000\000\002\237\000\000\000\000\000\205\000\000\002\237\000\000\002\237\000\000\000\205\000\205\005\130\b\198\000\000\002\237\002\237\t>\004j\000\000\000\205\000\014\000\205\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\237\000\000\000\000\000\000\000\000\000\000\000F\000\000\000\000\000\000\000\000\002\237\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\0062\000\000\000\000\005\222\000\000\000\000\000\000\002Z\002^\000\000\006F\000\000\000\000\000z\006N\000\000\000~\000\130\000\000\000\000\000\000\000\000\001f\000\134\000\138\000\142\000\000\001*\002\134\002r\000\000\000\000\000\146\000\150\000\154\000\000\000\158\002~\000\000\000\162\000\166\000\170\000\000\000\000\002\142\000\174\000\178\000\182\000\000\000\000\000\000\002\130\003.\000\186\000\000\000\190\000\194\003:\000\000\003F\004\026\004&\000\000\000\198\000\000\000\202\0042\003\241\001B\001\006\003\241\000\206\000\210\001\"\000\214\006\186\012\141\000\000\001&\000\000\000\000\003\241\000\000\0046\000\000\003\241\000\000\003\241\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\012\141\000\000\006\242\003\241\000\000\000\000\000\000\000\000\000\000\003\241\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\003\241\000\000\003\241\012\190\012\141\003\241\003F\000\000\000\000\003\246\003\241\003\241\ne\003\250\012\141\004\002\000\000\007.\005n\012\141\012\141\000\238\000\000\000\000\000\000\000\000\003\241\003\241\012\141\012\141\005r\000\000\002\237\002\237\000\000\000\000\000\000\000\000\000\000\000\000\005z\002\237\005~\003\241\003\241\0076\000\000\003\241\003\241\000\000\000\000\000\000\002\237\000\000\000\000\000\000\000\000\012\141\000\000\000\000\000\n\ne\t\214\000\000\ne\024\242\003\241\005\130\012\141\000\000\000\000\ne\000\000\004j\000\000\ne\002\237\003\241\001B\001\006\005\254\000\000\000\000\001\"\002\237\000\000\000\000\000\000\001&\001b\002\237\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\000\000\002\237\000\000\001j\001n\001r\001v\001z\001~\000\000\000\000\000\000\002\237\000\000\002\237\000\000\001\130\000\000\001\194\006\030\002\237\000\000\000\000\001^\002N\000\000\001\202\000\000\000\n\001\206\000\000\003F\000\000\001\021\003\246\000\000\000\000\002\237\003\250\000\000\004\002\005b\000\000\005n\002\237\002\237\001\210\001\214\001\218\001\222\001\226\007B\002\237\001\021\001\230\005r\000\000\000\000\002\237\001\234\000\000\000\000\000\000\000\000\000\000\005z\000\000\005~\000\000\005\190\001\238\000\000\000\000\000\000\000\000\001\021\000\000\001\242\001>\000\000\000\000\002\237\000\000\000\000\000\000\001\021\000\000\000\000\002.\006\"\001\021\006\130\005\130\000\000\t\017\0022\000\000\0026\004j\001\021\001\021\002:\000\000\002>\002B\001B\001\006\007\"\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\000\000\001\162\001\021\001j\001n\001r\001v\001z\001~\000\238\000\000\000\000\001\166\001\021\000\000\007j\001\130\000\000\001\194\006\030\001*\000\000\000\000\001^\002N\000\000\001\202\000\000\000\000\001\206\000\000\003F\000\000\004\129\003\246\000\000\000\000\002\154\003\250\000\000\004\002\005b\000\000\005n\007f\002j\001\210\001\214\001\218\001\222\001\226\000\000\003F\004\129\001\230\005r\000\000\000\000\0062\001\234\000\000\005\222\000\000\000\000\000\000\005z\t\017\005~\006F\005\190\001\238\000\000\006N\000\000\000\000\004\129\000\000\001\242\000\000\000\000\000\000\007r\000\000\000\000\000\000\004\129\000\000\000\000\002.\006\"\004\129\011\158\005\130\000\000\015\198\0022\000\000\0026\004j\004\129\004\129\002:\012\129\002>\002B\001B\001\006\t\006\000\000\000\000\001\"\000\000\000\000\000\000\003R\001&\001b\000\000\000\000\000\000\001f\000\000\005e\000\000\000\000\001*\005e\000\000\004\129\001j\001n\001r\001v\001z\001~\000\000\015\242\000\000\000\000\004\129\000\000\000\000\001\130\000\000\001\194\006\030\012B\000\000\000\000\001^\002N\012J\001\202\000\000\000\000\001\206\000\000\003F\000\000\000\000\003\246\016\030\000\000\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\005r\000\000\012\129\012\129\001\234\000\000\000\000\000\000\004\165\000\000\005z\000\000\005~\000\000\005\190\001\238\000\000\000\000\005e\016\130\000\000\000\000\001\242\000\000\000\000\012\129\000\000\000\000\012\129\000\000\000\000\000\000\000\000\002.\006\"\005e\000\000\005\130\005e\000\000\0022\000\000\0026\004j\000\000\000\000\002:\000\000\002>\002B\001B\001\006\023\198\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\000\000\000\000\000\000\001j\001n\001r\001v\001z\001~\000\000\000\000\003r\002\170\001\006\000\000\000\000\001\130\000\000\001\194\006\030\000\000\002\174\000\000\001^\002N\000\000\001\202\bj\000\000\001\206\000\000\003F\001*\000\000\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\005r\003n\000\000\000\000\001\234\000\000\000\000\000\000\000\000\003F\005z\000\000\005~\000\000\005\190\001\238\000\000\000\000\000\000\000\000\000\000\000\000\001\242\000\000\000\000\000\000\002\237\002\237\000\000\000\000\000\000\000\000\000\000\002.\006\"\000\000\000\000\005\130\007N\000\000\0022\000\000\0026\004j\000\000\000\000\002:\002\237\002>\002B\002\237\002\237\000\000\002\237\000\n\002\237\002\237\002\237\002\237\002\237\002\237\000\000\000\000\000\000\000\000\002\237\002\237\000\000\000\000\000\000\002\237\002\237\002\237\000\000\000\000\002\237\000\000\002\237\000\n\002\237\002\237\002\237\002\237\000\n\002\237\000\000\007>\000\000\002\237\000\000\002\237\000\000\024\154\000\000\002\237\002\237\000\000\002\237\002\237\002\237\002\237\002\237\002\237\002\237\000\000\002\237\000\000\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\000\000\002\237\000\000\000\000\000\000\000\000\000\000\000\000\002\237\000\000\000\000\002\237\000\000\002\237\000\000\000\000\000\000\000\000\002\237\002\237\002\237\002\237\002\237\002\237\000\000\002\237\002\237\024\182\000\000\000\000\000\000\002\237\000\000\000\000\002\237\000\000\002\237\000\000\000A\000A\000\000\000\000\004\129\000A\000A\002\237\000A\000A\000A\002\237\002\237\002\237\000\000\000A\000\000\002\237\002\237\002\237\006\185\000\000\000\000\000\000\004\129\000A\000\000\000\000\000\000\000A\000\000\000A\000A\000\000\000\000\000\000\000\000\000\000\000A\000\000\000A\000\000\000\000\000\000\000A\000A\004\129\000A\000A\000A\000A\000A\000A\000A\000\000\000\000\004\129\000A\000\000\000\000\000A\004\129\011\158\000\238\000A\000A\000A\000A\000\000\000A\000\000\004\129\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000A\000A\000A\000A\000\000\000A\000\000\000\000\000\000\000\000\000\000\004\129\000\000\000\000\000A\000\000\000A\000\000\000=\000=\000\000\000\000\004\129\000=\000=\000\000\000=\000=\000=\000\000\000A\000A\000\000\000=\000\000\000A\000A\000A\006\181\000\000\000\000\000\000\000\000\000=\000\000\000\000\000\000\000=\000\000\000=\000=\000\000\000\000\000\000\000\000\000\000\000=\000\000\000=\000\000\000\000\000\000\000=\000=\000\000\000=\000=\000=\000=\000=\000=\000=\000\000\000\000\000\000\000=\000\000\000\000\000=\000\000\000\000\000\000\000=\000=\000=\000=\000\000\000=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000=\000=\000=\000=\000=\000\000\000=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000=\000\000\000=\000\000\011\221\011\221\000\000\000\000\0186\011\221\011\221\000\000\011\221\011\221\011\221\000\000\000=\000=\000\000\011\221\000\000\000=\000=\000=\006\197\000\000\000\000\000\000\003R\011\221\000\000\000\000\000\000\011\221\000\000\011\221\011\221\000\000\000\000\000\000\000\000\000\000\011\221\000\000\011\221\000\000\000\000\000\000\011\221\011\221\018\166\011\221\011\221\011\221\011\221\011\221\011\221\011\221\000\000\000\000\012B\011\221\000\000\000\000\011\221\012J\000\000\000\000\011\221\011\221\011\221\011\221\000\000\011\221\019b\019r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\221\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\221\011\221\011\221\011\221\011\221\000\000\011\221\000\000\000\000\000\000\000\000\000\000\004\173\000\000\000\000\011\221\000\000\011\221\000\000\011\217\011\217\000\000\000\000\020r\011\217\011\217\000\000\011\217\011\217\011\217\000\000\011\221\011\221\000\000\011\217\000\000\011\221\011\221\011\221\006\193\000\000\000\000\000\000\000\000\011\217\000\000\000\000\000\000\011\217\000\000\011\217\011\217\000\000\000\000\000\000\000\000\000\000\011\217\000\000\011\217\000\000\000\000\000\000\011\217\011\217\000\000\011\217\011\217\011\217\011\217\011\217\011\217\011\217\000\000\000\000\000\000\011\217\000\000\000\000\011\217\000\000\000\000\000\000\011\217\011\217\011\217\011\217\000\000\011\217\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\217\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\217\011\217\011\217\011\217\011\217\000\000\011\217\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\217\000\000\011\217\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\217\011\217\001&\000\000\000\000\011\217\011\217\011\217\000\000\023\022\000\000\000\000\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\006\234\007:\000\000\000\000\000\000\003F\000\000\000\000\003\214\000\000\000\000\000\000\b\154\b\158\b\170\b\186\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\210\000\000\000\000\000\000\0051\000\000\0051\0051\b\222\b\246\t\022\t*\005z\0051\005~\000\000\0051\000\000\0051\000\000\0051\0051\0051\b\178\0051\b\182\000\000\000\000\012M\0129\0051\000\000\0051\0051\0051\000\000\0051\0051\0051\005\130\b\198\000\000\0051\0051\t>\004j\t\162\000\000\000\000\012M\0051\000\000\002\194\000\000\000\000\002\198\0051\0051\000\000\000\000\0051\0051\0051\0051\0051\0051\000\000\0051\002\210\000\000\0051\000\000\002\218\0129\000\000\0051\0051\0051\000\000\000\000\000\000\0051\000\000\000\000\0051\0051\000\000\000\000\000\000\000\000\000\000\0051\000\000\000\000\0051\0051\0051\002\222\0051\0051\004a\000\000\000\000\004a\000\000\000\000\000\000\000\000\0051\0051\0051\000\000\0051\0051\004a\000\000\017\006\0051\004a\000\000\004a\000\000\000\000\000\000\0051\000\000\0051\0051\0051\000\000\0032\0051\004a\000\000\000\000\000\000\0051\000\000\004a\000\000\0051\n\129\0051\0051\n\129\n\129\002\226\000\000\000\000\n\129\000\000\n\129\004a\000\000\n\129\000\000\000\000\004a\n\129\n\129\000\000\n\129\n\129\000\000\n\129\000\000\n\129\000\000\000\000\000\000\000\000\n\129\000\000\004a\n\129\000\000\000\000\000\000\000\000\000\000\007\157\000\000\n\129\000\000\n\129\000\000\000\000\000\000\n\129\n\129\004a\004a\000\000\000\000\004a\004a\n\129\007\157\007\157\n\129\007\157\007\157\n\129\n\129\000\000\n\129\000\000\n\129\n\129\000\000\000\000\000\000\000\000\004a\000\000\000\000\000\000\n\129\000\000\000\000\n\129\007\157\000\000\000\000\015\018\000\000\000\000\000\000\000\000\000\000\n\129\000\000\n\129\000\000\000\000\n\129\000\000\n\129\000\000\000\000\000\000\007\157\000\000\000\000\005\158\000\000\000\000\000\000\000\000\000\000\000\000\n\129\n\129\000\000\n\129\n\129\007\157\n\129\000\000\n\129\000\000\n\129\b\233\n\129\000\000\n\129\000\000\b\233\000\000\002^\b\233\000\000\000\000\000\000\007\157\001\029\007\157\000\000\000\000\b\233\000\000\b\233\b\233\b\233\000\000\b\233\b\233\b\233\000\000\000\000\005\214\000\000\000\000\007\157\007\157\001\029\000\000\000\000\007\157\b\233\007\157\006\249\006\249\000\000\007\157\b\233\b\233\000\000\000\000\b\233\000\000\000\000\000\000\0036\b\233\000\000\b\233\001\029\004*\b\233\015\182\006\249\006\249\006\249\b\233\b\233\b\233\001\029\000\000\000\000\000\000\006\249\001\029\b\233\b\233\000\000\000\000\000\000\000\000\000\000\b\233\000\000\001\029\000\000\004\146\006\249\006\249\000\000\b\233\000\000\000\000\006\249\000\000\006\249\006\249\006\249\000\000\b\233\b\233\b\233\006\249\b\233\b\233\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\b\233\000\000\b\233\b\233\006\249\000\000\012\021\b\233\001\029\000\000\000\000\012\021\b\233\002^\012\021\000\000\b\233\000\000\b\233\b\233\000\000\000\000\000\000\004\178\000\000\012\021\012\021\012\021\000\000\012\021\012\021\012\021\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\021\000\000\004\030\000\000\006\249\000\000\012\021\012\021\000\000\000\000\012\021\000\000\000\000\000\000\0036\012\021\001\174\012\021\000\000\r\142\012\021\000\000\000\000\000\000\000\000\012\021\012\021\012\021\000\000\000\000\014\154\000\000\000\000\000\000\012\021\012\021\003R\000\000\000\000\000\000\000\000\012\021\000\000\000\000\000\000\004\146\000\000\000\000\014\158\012\021\000\000\000\000\000\000\000\000\014\198\000\000\000\000\000\000\012\021\012\021\012\021\000\000\012\021\012\021\000\000\000\000\000\000\000\000\012B\000\000\000\000\000\000\000\000\012J\012\021\000\000\012\021\012\021\000\000\000\000\b\237\012\021\000\000\000\000\000\000\b\237\012\021\002^\b\237\015Z\012\021\000\000\012\021\012\021\000\000\000\000\000\000\b\237\000\000\b\237\b\237\b\237\000\000\b\237\b\237\b\237\012f\015n\000\000\000\000\004\137\004\137\000\000\000\000\000\000\000\000\000\000\b\237\000\000\002Z\002^\018\190\000\000\b\237\b\237\000\000\000\000\b\237\000\000\015~\000\000\0036\b\237\000\000\b\237\000\000\000\000\b\237\000\000\001*\002b\002r\b\237\b\237\b\237\000\000\000\000\000\000\000\000\002~\000\000\b\237\b\237\000\000\000\000\000\000\000\000\000\000\b\237\000\000\000\000\000\000\004\146\002\130\003.\000\000\b\237\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\b\237\b\237\b\237\0042\b\237\b\237\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\237\000\000\b\237\b\237\0046\000\000\000\000\b\237\000a\000\000\000a\000a\b\237\000\000\000\000\000\000\b\237\000\000\b\237\b\237\000a\000\000\000a\000a\000\000\000\000\000a\000a\000a\000\000\b\149\000\000\001B\001\006\000\000\000\000\000\000\001\"\000\000\000\000\000a\000\000\001&\000\000\000\000\000\000\000a\000a\000\000\t\021\000a\000\000\001*\000\000\000a\000a\000\000\000a\000\000\001F\000a\000\000\000\000\000\000\000\000\000a\000a\000a\000\000\000\000\000\000\000\000\001R\000\000\000a\000a\001^\002N\000\000\000\000\000\000\000a\000a\000\000\003F\000a\000\000\003\246\000\000\000a\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000a\000a\000a\000\000\000a\000a\000\000\000\000\000\000\000\000\005r\000\000\b\149\000\000\000\000\000\000\000a\000\000\000\000\000a\005z\012\025\005~\000a\005\190\000\000\012\025\000\000\000a\012\025\000\000\000\000\000a\000\000\000a\000\000\000\000\000\000\004\130\000\000\012\025\012\025\012\025\000\000\012\025\012\025\012\025\005\130\000\000\t\021\000\000\b\234\000\000\004j\000\000\000\000\000\000\000\000\012\025\000\000\002Z\002^\019:\000\000\012\025\012\025\000\000\000\000\012\025\000\000\000\000\000\000\000\000\012\025\000\000\012\025\000\000\000\000\012\025\000\000\001*\002b\002r\012\025\012\025\012\025\000\000\000\000\000\000\000\000\002~\000\000\012\025\012\025\000\000\000\000\000\000\000\000\000\000\012\025\000\000\000\000\000\000\012\025\002\130\003.\000\000\012\025\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\012\025\012\025\012\025\0042\012\025\012\025\003)\000\000\000\000\000\000\000\000\003)\012M\0129\003)\000\000\012\025\000\000\012\025\012\025\0046\002Z\002^\012\025\000\000\003)\003)\003)\012\025\003)\003)\003)\012\025\012M\012\025\012\025\002\194\000\000\000\000\002\198\000\000\001*\002\134\003)\000\000\000\000\002\206\000\000\000\000\003)\004z\000\000\002\210\003)\000\000\000\000\002\218\0129\003)\000\000\003)\000\000\000\000\003)\000\000\002\130\0036\000\000\003)\003)\003)\003:\000\000\003F\004\026\004&\000\000\003)\003)\000\000\0042\002\222\012\210\000\000\003)\000\000\000\000\000\000\003)\000\000\000\000\n\141\003)\000\000\001B\001\006\000\000\0046\000\000\001\"\000\000\003)\003)\003)\001&\003)\003)\000\000\n\141\n\141\000\000\n\141\n\141\000\000\001*\000\000\000\000\003)\000\000\003)\003)\001F\000\000\000\000\003)\000\000\000\000\000\000\000\000\003)\002\226\000\000\n\141\003)\001R\003)\003)\000\000\001^\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\n\141\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\141\000\000\000\000\005r\000\000\000\000\n\137\000\000\000\000\001B\001\006\000\000\000\000\005z\001\"\005~\000\000\005\190\n\141\001&\n\141\000\000\000\000\n\137\n\137\000\000\n\137\n\137\000\000\001*\000\000\000\000\000\000\000\000\n\141\000\000\001F\n\141\n\141\000\000\005\130\000\000\n\141\000\000\n\141\000\000\004j\n\137\n\141\001R\000\000\000\000\000\000\005\250\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\n\137\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\137\000\000\000\000\005r\000\000\000\000\001\213\000\000\000\000\000\000\000\000\001\213\000\000\005z\001\213\005~\000\000\005\190\n\137\000\000\n\137\000\000\000\000\000\000\000\000\001\213\001\213\001\213\000\000\001\213\001\213\001\213\000\000\000\000\n\137\000\000\000\000\n\137\n\137\000\000\005\130\000\000\n\137\001\213\n\137\000\000\004j\000\000\n\137\001\213\001\213\000\000\000\000\001\213\000\000\000\000\000\000\000\000\001\213\000\000\001\213\000\000\000\000\001\213\000\000\000\000\000\000\000\000\001\213\001\213\001\213\000\000\000\000\000\000\000\000\000\000\000\000\001\213\001\213\000\000\001i\000\000\000\000\001i\001\213\000\000\000\000\000\000\001\213\000\000\000\000\000\000\001\213\000\000\001i\000\000\001i\000\000\001i\000\000\001i\001\213\001\213\001\213\000\000\001\213\001\213\000\000\000\000\000\000\000\000\000\000\001i\000\000\000\000\000\000\000\000\001\213\001i\001\213\001\213\001B\001\006\000\000\001\213\000\000\001\"\000\000\006\186\001\213\000\000\001&\001i\004\246\000\000\001\213\000\000\001i\001i\000\238\000\000\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\000\000\000\000\006\242\000\000\001i\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\000\000\000\000\000\000\001i\001i\001i\003F\001i\001i\003\246\000\000\000\000\ne\003\250\000\000\004\002\000\000\007.\005n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001i\004-\000\000\000\000\005r\000\000\000\000\000\000\000\000\000\000\000\000\001i\000\000\000\000\005z\000\000\005~\000\000\000\000\0076\000\000\005\169\000\000\000\000\000\000\000\000\005\169\000\000\000\000\005\169\000\000\000\000\000\000\000\000\000\000\ne\000\000\000\000\ne\ne\005\169\005\130\005\169\000\000\005\169\ne\005\169\004j\000\000\ne\004-\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\169\000\000\000\000\000\000\000\000\000\000\005\169\005\169\000\000\000\000\000\000\000\000\000\000\005\169\000\000\005\169\000\000\005\169\000\000\000\000\005\169\000\000\000\000\000\000\000\000\005\169\005\169\005\169\000\000\000\000\000\000\000\000\003u\000\000\000\000\000\000\000\000\003u\000\000\000\000\003u\005\169\005\169\000\000\000\000\005\169\000\000\000\000\000\000\000\000\000\000\003u\000\000\003u\000\000\003u\000\000\003u\005\169\005\169\005\169\000\000\005\169\005\169\000\000\000\000\003u\000\000\000\000\003u\b\"\003u\000\000\000\000\003u\003u\003u\005\169\000\000\000\000\005\169\005\169\0059\000\000\003u\003u\003u\003u\000\000\003u\000\000\003u\005\169\000\000\003u\003u\003u\000\000\000\000\000\000\000\000\000\000\000\000\003u\000\000\000\000\000\000\000\000\000\000\003u\003u\000\000\000\000\000\000\003u\000\000\005=\000\000\003u\000\000\003u\000\000\000\000\003u\000\000\000\000\000\000\003u\003u\003u\003u\003u\003u\000\000\000\000\005\157\000\000\000\000\000\000\0059\005\157\000\000\000\000\005\157\003u\000\000\003u\003u\003u\000\000\003u\000\000\000\000\000\000\005\157\000\000\005\157\000\000\005\157\000\000\005\157\003u\003u\003u\000\000\003u\003u\000\000\000\000\000\000\000\000\000\000\005\157\005=\000\000\000\000\000\000\000\000\005\157\005\157\003u\003u\000\000\000\000\003u\bf\000\000\005\157\000\000\005\157\000\000\000\000\005\157\000\000\000\000\003u\000\000\005\157\005\157\000\238\000\000\000\000\000\000\bu\000\000\000\000\000\000\000\000\bu\000\000\000\000\bu\000\000\005\157\005\157\000\000\000\000\005\157\000\000\000\000\000\000\000\000\bu\000\000\bu\000\000\bu\000\000\bu\000\000\005\157\005\157\005\157\000\000\005\157\005\157\000\000\000\000\000\000\000\000\bu\000\000\000\000\000\000\000\000\000\000\bu\bu\000\000\005\157\000\000\000\000\005\157\005\157\000\000\bu\000\000\bu\000\000\000\000\bu\000\000\000\000\000\000\005\157\bu\bu\bu\000\000\000\000\000\000\000\000\012\205\000\000\000\000\000\000\000\000\012\205\000\000\000\000\012\205\bu\000\000\000\000\000\000\bu\000\000\000\000\000\000\000\000\000\000\012\205\000\000\012\205\000\000\012\205\000\000\012\205\bu\bu\bu\000\000\bu\bu\000\000\000\000\000\000\000\000\000\000\012\205\000\000\000\000\000\000\000\000\bu\012\205\012\205\bu\000\000\000\000\000\000\bu\004>\000\000\012\205\000\000\012\205\000\000\000\000\012\205\004\246\000\000\bu\000\000\012\205\012\205\012\205\000\000\000\000\000\000\000\000\012\209\000\000\000\000\000\000\000\000\012\209\000\000\000\000\012\209\012\205\000\000\000\000\000\000\012\205\000\000\000\000\000\000\000\000\000\000\012\209\000\000\012\209\000\000\012\209\000\000\012\209\012\205\012\205\012\205\000\000\012\205\012\205\000\000\000\000\000\000\000\000\000\000\012\209\004J\000\000\000\000\000\000\000\000\012\209\012\209\012\205\000\000\000\000\000\000\012\205\004>\000\000\012\209\000\000\012\209\000\000\000\000\012\209\000\000\000\000\012\205\000\000\012\209\012\209\012\209\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\197\000\000\002^\001\197\000\000\012\209\000\000\000\000\000\000\012\209\000\000\000\000\b\213\000\000\001\197\000\000\000\000\000\000\001\197\000\000\001\197\000\000\012\209\012\209\012\209\000\000\012\209\012\209\000\000\000\000\000\000\000\000\001\197\000\000\004J\000\000\000\000\000\000\001\197\001\197\000\000\012\209\000\000\000\000\000\000\012\209\0036\001\197\000\000\001\197\000\000\000\000\001\197\000\000\000\000\000\000\012\209\001\197\001\197\001\197\000\000\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\001\197\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\000\000\000\003Y\000\000\002^\003Y\000\000\000\000\001\197\001\197\000\000\000\000\001\197\001\197\b\209\000\000\003Y\000\000\000\000\000\000\003Y\000\000\003Y\000\000\001\197\000\000\000\000\000\000\000\000\000\000\000\000\001\197\000\000\000\000\003Y\000\000\001\197\000\000\000\000\000\000\003Y\001\193\001\197\000\000\000\000\000\000\000\000\000\000\0036\003Y\000\000\003Y\000\000\000\000\003Y\000\000\000\000\000\000\000\000\003Y\003Y\003Y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Y\003Y\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\000\000\000\003U\000\000\002^\003U\000\000\000\000\003Y\003Y\000\000\000\000\003Y\003Y\b\209\000\000\003U\000\000\000\000\000\000\003U\000\000\003U\000\000\003Y\000\000\000\000\000\000\000\000\000\000\000\000\003Y\000\000\000\000\003U\000\000\003Y\000\000\000\000\000\000\003U\001\193\003Y\000\000\000\000\000\000\000\000\000\000\0036\003U\000\000\003U\000\189\000\000\003U\000\189\000\000\000\000\000\000\003U\003U\003U\000\000\000\000\000\000\000\000\000\189\000\000\000\189\000\000\000\189\000\000\000\189\000\000\000\000\003U\003U\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\189\000\000\000\000\000\000\000\000\000\000\000\189\000\000\003U\003U\000\189\000\000\003U\003U\000\000\000\189\000\000\000\189\000\000\000\000\000\189\000\000\000\000\000\000\003U\000\189\000\189\000\238\000\000\000\000\000\000\003U\000\000\000\000\000\189\000\189\003U\001\001\000\000\000\000\001\001\000\189\003U\000\000\000\000\000\189\000\000\000\000\000\000\000\000\000\000\001\001\000\000\001\001\000\000\001\001\000\000\001\001\000\189\000\189\000\000\000\000\000\189\000\189\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\189\001\001\000\000\000\000\000\000\001\001\000\189\000\189\000\000\000\000\001\001\000\000\001\001\000\000\000\000\001\001\000\189\000\000\000\189\000\000\001\001\001\001\000\238\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\000\000\000\197\000\000\000\000\000\197\001\001\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\000\000\197\000\000\000\197\000\000\000\197\000\000\000\197\001\001\001\001\000\000\000\000\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\197\000\000\000\000\000\000\000\000\001\001\000\197\000\000\000\000\000\000\000\197\001\001\001\001\000\000\000\000\000\197\000\000\000\197\000\000\000\000\000\197\001\001\000\000\001\001\000\000\000\197\000\197\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\197\000\197\000\000\000\193\000\000\000\000\000\193\000\197\000\000\000\000\000\000\000\197\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\193\000\000\000\193\000\000\000\193\000\197\000\197\000\000\000\000\000\197\000\197\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\000\000\197\000\193\000\000\000\000\000\000\000\193\000\197\000\197\000\000\000\000\000\193\000\000\000\193\000\000\000\000\000\193\000\197\000\000\000\197\000\000\000\193\000\193\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\193\000\193\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\193\000\000\000\000\000\000\000\000\nb\000\000\000\000\021\178\b\249\000\000\b\249\b\249\000\193\000\193\000\000\000\000\000\193\000\193\n\154\n\178\n\186\n\162\n\194\000\000\000\000\000\000\000\000\000\000\000\193\000\000\000\000\000\000\n\202\n\210\000\193\000\193\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\218\000\193\000\000\000\193\000\000\000\000\000\000\000\000\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\nj\n\170\n\226\n\234\n\250\001b\000\000\000\000\000\000\001f\000\000\000\000\024N\011\002\000\000\000\000\000\000\000\000\001j\001n\001r\001\190\001z\001~\011\n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\194\001\198\000\000\000\000\000\000\000\000\000\000\011*\001\202\0112\n\242\001\206\000\000\000\000\000\000\b\249\011\018\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\026\011\"\000\000\000\000\001\210\001\214\001\218\001\222\001\226\000\000\000\000\001\161\001\230\000\000\001\161\000\000\000\000\001\234\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\161\000\000\000\000\001\238\001\161\000\000\001\161\000\000\000\000\000\000\001\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\161\001\161\000\000\002.\027\166\000\000\001\161\000\000\012M\0129\0022\000\000\0026\0059\000\000\001\161\002:\001\161\002>\002B\001\161\000\000\000\000\000\000\000\000\001\161\001\161\001\161\000\000\012M\000\000\000\000\002\194\000\000\000\000\002\198\000\000\000\000\000\000\000\000\000\000\001\161\r\154\000\000\000\000\001\161\012\201\000\000\002\210\000\000\000\000\012\201\002\218\0129\012\201\000\000\000\000\000\000\001\161\001\161\000\000\000\000\001\161\001\161\000\000\012\201\000\000\012\201\000\000\012\201\0059\012\201\000\000\000\000\001\161\000\000\000\000\002\222\000\000\000\000\001\161\001\161\000\000\012\201\000\000\000\000\001\161\000\000\000\000\012\201\012\201\000\000\001\161\000\000\000\000\000\000\000\000\000\000\012\201\000\000\012\201\000\000\000\000\012\201\000\000\000\000\000\000\000\000\012\201\012\201\012\201\000\000\000\000\000\000\012\197\000\000\000\000\000\000\000\000\012\197\000\000\000\000\012\197\000\000\012\201\000\000\002\226\000\000\012\201\000\000\000\000\000\000\000\000\012\197\000\000\012\197\000\000\012\197\000\000\012\197\000\000\012\201\012\201\012\201\000\000\012\201\012\201\000\000\000\000\000\000\000\000\012\197\000\000\000\000\000\000\000\000\000\000\012\197\012\197\000\000\012\201\000\000\000\000\000\000\012\201\000\000\012\197\000\000\012\197\000\000\000\000\012\197\000\000\004\246\000\000\012\201\012\197\012\197\012\197\000\000\000\000\000\000\000\000\by\000\000\000\000\000\000\000\000\by\000\000\000\000\by\012\197\000\000\000\000\000\000\012\197\000\000\000\000\000\000\000\000\000\000\by\000\000\by\000\000\by\000\000\by\012\197\012\197\012\197\000\000\012\197\012\197\000\000\000\000\000\000\000\000\000\000\by\000\000\000\000\000\000\000\000\007\190\by\by\012\197\000\000\000\000\000\000\012\197\000\000\000\000\by\000\000\by\000\000\000\000\by\000\000\000\000\012\197\000\000\by\by\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\193\000\000\002^\001\193\by\000\000\000\000\000\000\by\000\000\012)\000\000\b\209\012)\001\193\000\000\000\000\000\000\001\193\000\000\001\193\by\by\by\012)\by\by\000\000\012)\000\000\012)\000\000\001\193\000\000\000\000\000\000\0051\by\001\193\000\000\by\000\000\012)\000\000\by\000\000\0036\001\193\012)\001\193\000\000\000\000\001\193\000\000\000\000\by\000\000\001\193\001\193\001\193\000\000\000\000\012)\000\000\000\000\000\000\000\000\012)\012)\000\000\000\000\000\000\000\000\001\193\001\193\000\000\000\000\004\146\000\000\000\000\000\000\000\000\000\000\012)\000\000\000\000\000\000\000\000\000\000\000\000\001\193\001\193\000\000\000\000\001\193\001\193\000\000\000\000\000\000\000\000\012)\012)\003\030\000\000\012)\012)\001\193\001\174\002Z\002^\r\142\000\000\000\000\001\193\000\000\000\000\012)\000\000\001\193\000\000\r\166\014\154\000\000\012)\001\193\004\137\000\000\003R\001*\002\134\002r\000\000\000\000\000\000\012)\000\000\000\000\000\000\002~\014\158\000\000\000\000\000\000\000\000\000\000\014\198\000\000\000\000\000\000\005\209\000\000\000\000\002\130\003.\005\209\000\000\000\000\005\209\003:\012B\003F\004\026\004&\000\000\012J\000\000\000\000\0042\005\209\000\000\005\209\000\000\005\209\000\000\005\209\000\000\000\000\000\000\000\000\000\000\015Z\000\000\000\000\000\000\0046\000\000\005\209\000\000\000\000\000\000\000\000\000\000\005\209\005\209\000\000\000\000\000\000\012f\015n\bf\000\000\005\209\000\000\005\209\000\000\000\000\005\209\000\000\000\000\000\000\000\000\005\209\005\209\000\238\000\000\000\000\000\000\000\000\000\000\000\000\015~\000\000\000\000\001b\000\000\000\000\000\000\005\209\000\000\000\000\000\000\005\209\000\000\000\000\000\000\000\000\001j\001n\001r\001\190\001z\001~\000\000\000\000\005\209\005\209\005\209\000\000\005\209\005\209\000\000\001\194\001\198\000\000\000\000\000\000\000\000\000\000\000\000\001\202\000\000\000\000\001\206\005\209\000\000\000\000\000\000\005\209\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\209\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\000\000\000\000\000\000\000\000\001\234\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\238\000\000\000\000\000\000\000\000\000\000\000\000\001\242\000\000\000\000\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\002.\027\194\001&\000\000\000\000\000\000\000\000\0022\000\000\0026\000\000\000\000\001*\002:\006\218\002>\002B\000\000\000\000\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\000\000\003\250\007\146\004\002\000\000\007.\005n\005\205\000\000\000\000\005\205\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005r\000\000\000\000\005\205\000\000\005\205\000\000\005\205\000\000\005\205\005z\000\000\005~\000\000\000\000\0076\000\000\000\000\000\000\000\000\000\000\005\205\000\000\000\000\000\000\000\000\000\000\005\205\b\014\000\000\000\000\000\000\t\214\000\000\000\000\t\222\005\205\005\130\005\205\000\000\000\000\005\205\000\000\004j\000\000\000\000\005\205\005\205\000\238\000\000\000\000\000\000\012\213\000\000\000\000\000\000\000\000\012\213\000\000\000\000\012\213\000\000\005\205\000\000\000\000\000\000\005\205\000\000\000\000\000\000\000\000\012\213\000\000\012\213\000\000\012\213\000\000\012\213\000\000\005\205\005\205\005\205\000\000\005\205\005\205\000\000\000\000\000\000\000\000\012\213\000\000\000\000\000\000\000\000\000\000\012\213\012\213\000\000\005\205\000\000\000\000\000\000\005\205\000\000\012\213\000\000\012\213\000\000\000\000\012\213\000\000\000\000\000\000\005\205\012\213\012\213\000\238\000\000\000\000\000\000\012\217\000\000\000\000\000\000\000\000\012\217\000\000\000\000\012\217\000\000\012\213\000\000\000\000\000\000\012\213\000\000\000\000\000\000\000\000\012\217\000\000\012\217\000\000\012\217\000\000\012\217\000\000\012\213\012\213\012\213\000\000\012\213\012\213\000\000\000\000\000\000\000\000\012\217\000\000\000\000\000\000\000\000\000\000\012\217\b\014\000\000\012\213\000\000\000\000\000\000\012\213\000\000\012\217\000\000\012\217\000\000\000\000\012\217\000\000\000\000\000\000\012\213\012\217\012\217\000\238\000\000\000\000\000\000\007\146\000\000\000\000\000\000\000\000\005\229\000\000\000\000\005\229\000\000\012\217\000\000\000\000\000\000\012\217\000\000\000\000\000\000\000\000\005\229\000\000\005\229\000\000\005\229\000\000\005\229\000\000\012\217\012\217\012\217\000\000\012\217\012\217\000\000\000\000\000\000\000\000\005\229\000\000\000\000\000\000\000\000\000\000\005\229\b\014\000\000\012\217\000\000\000\000\000\000\012\217\000\000\005\229\000\000\005\229\000\000\000\000\005\229\000\000\000\000\000\000\012\217\005\229\005\229\000\238\000\000\000\000\000\000\005\233\000\000\000\000\000\000\000\000\005\233\000\000\000\000\005\233\000\000\005\229\000\000\000\000\000\000\005\229\000\000\000\000\000\000\000\000\005\233\000\000\005\233\000\000\005\233\000\000\005\233\000\000\005\229\005\229\005\229\000\000\005\229\005\229\000\000\000\000\000\000\000\000\005\233\000\000\000\000\000\000\000\000\000\000\005\233\005\233\000\000\005\229\000\000\000\000\000\000\005\229\000\000\005\233\000\000\005\233\000\000\000\000\005\233\000\000\000\000\000\000\005\229\005\233\005\233\005\233\000\000\000\000\000\000\005\225\000\000\000\000\000\000\000\000\005\225\000\000\000\000\005\225\000\000\005\233\000\000\000\000\000\000\005\233\000\000\000\000\000\000\000\000\005\225\000\000\005\225\000\000\005\225\000\000\005\225\000\000\005\233\005\233\005\233\000\000\005\233\005\233\000\000\000\000\000\000\000\000\005\225\000\000\000\000\000\000\000\000\000\000\005\225\b\014\000\000\005\233\000\000\000\000\000\000\005\233\000\000\005\225\000\000\005\225\000\000\000\000\005\225\000\000\000\000\000\000\b6\005\225\005\225\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Q\000\000\002^\003Q\000\000\005\225\000\000\000\000\000\000\005\225\000\000\000\000\000\000\000\000\003Q\000\000\002Z\002^\003Q\000\000\003Q\000\000\005\225\005\225\005\225\000\000\005\225\005\225\000\000\000\000\000\000\000\000\003Q\000\000\000\000\000\000\001*\002\134\003Q\000\000\000\000\005\225\000\000\000\000\000\000\005\225\0036\003Q\000\000\003Q\000\000\000\000\003Q\000\000\000\000\000\000\005\225\003Q\003Q\003Q\002\130\003>\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\003Q\003Q\0042\000\000\004\146\000\000\003M\000\000\002^\003M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Q\003Q\0046\003M\003Q\003Q\026\022\003M\000\000\003M\000\000\000\000\000\000\000\000\000\000\000\000\003Q\000\000\000\000\000\000\000\000\003M\000\000\003Q\000\000\000\000\026\002\003M\003Q\000\000\000\000\000\000\000\000\000\000\003Q\0036\003M\000\000\003M\000\000\000\000\003M\000\000\000\000\000\000\000\000\003M\003M\003M\000\000\000\000\000\000\000\000\000\000\001\205\000\000\012\182\001\205\000\000\000\000\001\"\000\000\003M\003M\000\000\000\000\004\146\000\000\001\205\000\000\000\000\000\000\001\205\000\000\001\205\000\000\002Z\002^\000\000\003M\003M\000\000\000\000\003M\003M\000\000\001\205\000\000\000\000\000\000\000\000\000\000\001\205\000\000\000\000\003M\001*\002\134\000\000\012\186\000\000\001\205\003M\001\205\000\000\000\000\001\205\003M\000\000\000\000\000\000\001\205\001\205\003M\012\198\000\000\000\000\000\000\000\000\000\000\002\130\003>\000\000\000\000\000\000\000\000\003:\001\205\003F\004\026\004&\001\205\000\000\000\000\000\000\0042\000\000\001Q\000\000\000\000\001Q\000\000\000\000\005~\001\205\001\205\000\000\000\000\001\205\001\205\000\000\001Q\0046\001Q\000\000\001Q\005\001\001Q\000\000\000\000\001\205\000\000\000\000\000\000\000\000\000\000\000\000\001\205\000\000\001Q\000\000\000\000\000\000\000\000\000\000\001Q\026\002\000\000\001\205\001Q\000\000\000\000\000\000\000\000\001Q\000\000\001Q\000\000\000\000\001Q\000\000\000\000\000\000\000\000\001Q\001Q\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001Q\000\000\001M\000\000\000\000\001M\001Q\000\000\000\000\000\000\001Q\000\000\000\000\000\000\000\000\000\000\001M\000\000\001M\000\000\001M\000\000\001M\001Q\001Q\001Q\000\000\001Q\001Q\000\000\000\000\000\000\000\000\000\000\001M\000\000\000\000\000\000\000\000\001Q\001M\000\000\000\000\000\000\001M\000\000\001Q\000\000\000\000\001M\000\000\001M\000\000\000\000\001M\000\000\000\000\001Q\000\000\001M\001M\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\000\000\nb\000\000\000\000\007\029\001M\000\000\000\000\007\029\001M\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\000\000\000\000\001M\001M\001M\000\000\001M\001M\000\000\n\202\n\210\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\000\000\n\218\000\000\000\000\000\000\000\000\001M\000\000\000\000\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001M\nj\n\170\n\226\n\234\n\250\nb\000\000\000\000\000\000\025\154\000\000\007\029\000\000\011\002\000\000\000\000\000\000\000\000\000\000\n\154\n\178\n\186\n\162\n\194\011\n\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\202\n\210\000\000\001\002\001\006\000\000\000\000\011*\001\"\0112\n\242\n\218\000\000\001&\000\000\000\000\011\018\000\000\006u\000\238\000\000\000\000\000\000\001*\011\026\011\"\000\000\001.\nj\n\170\n\226\n\234\n\250\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\011\002\000\000\000\000\000\000\000\000\000\000\003\206\002N\000\000\000\000\000\000\011\n\000\000\000\000\003F\000\000\000\000\003\214\000\000\000\000\000\000\b\154\b\158\b\170\000\000\000\000\005n\011*\025\158\0112\n\242\025\170\000\000\001B\001\006\000\000\011\018\000\000\001\"\000\000\006\186\000\000\000\000\001&\011\026\011\"\000\000\000\000\005z\000\000\005~\000\000\000\000\001*\000\000\006\218\000\000\000\000\000\000\b\178\001F\b\182\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\018\000\000\001R\000\000\005\130\b\198\023\194\002N\007\146\t>\004j\000\000\000\000\004\129\003F\000\000\004\129\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007.\005n\004\129\000\000\000\000\000\000\004\129\000\000\004\129\000\000\000\000\000\000\000\000\005r\000\000\000\000\000\000\000\000\000\000\000\000\004\129\000\000\000\000\005z\000\000\005~\004\129\b\014\000\000\000\000\004\129\000\000\000\000\bf\000\000\004\129\000\000\004\129\000\000\000\000\004\129\000\000\000\000\000\000\000\000\004\129\011\158\000\238\023\210\000\000\005\130\000\000\000\000\000\000\004\129\004\129\004j\b\005\000\000\000\000\b\005\004\129\004\129\000\000\000\000\004\129\000\000\000\000\000\000\000\000\000\000\b\005\000\000\000\000\000\000\b\005\000\000\b\005\004\129\004\129\000\000\000\000\004\129\004\129\000\000\000\000\000\000\000\000\000\000\b\005\b\"\000\000\000\000\000\000\004\129\b\005\000\000\000\000\000\000\b\005\000\000\004\129\000\000\000\000\b\005\000\000\b\005\000\000\b\001\b\005\000\000\b\001\004\129\000\000\b\005\b\005\000\238\000\000\000\000\000\000\000\000\000\000\b\001\b\005\b\005\000\000\b\001\000\000\b\001\000\000\b\005\000\000\000\000\000\000\b\005\000\000\000\000\000\000\000\000\000\000\b\001\000\000\000\000\000\000\000\000\000\000\b\001\b\005\b\005\b\005\b\001\b\005\b\005\000\000\000\000\b\001\000\000\b\001\003E\000\000\b\001\003E\000\000\b\005\000\000\b\001\b\001\000\238\000\000\000\000\b\005\000\000\003E\000\000\b\001\b\001\003E\000\000\003E\000\000\000\000\b\001\000\000\000\000\000\000\b\001\000\000\000\000\000\000\000\000\003E\012\206\000\000\000\000\000\000\000\000\003E\000\000\b\001\b\001\b\001\000\000\b\001\b\001\000\000\003E\000\000\003E\000\000\000\000\003E\000\000\000\000\000\000\b\001\003E\003E\003E\000\000\000\000\000\000\b\001\001}\000\000\0121\001}\000\000\000\000\000\000\000\000\000\000\003E\000\000\000\000\0121\003E\001}\000\000\001}\000\000\001}\000\000\001}\000\000\000\000\000\000\000\000\000\000\003E\003E\026\138\000\000\003E\003E\001}\000\000\000\000\000\000\000\000\000\000\001}\0121\000\000\000\000\003E\000\000\000\000\000\000\0121\000\000\rN\003E\000\000\000\000\001}\000\000\003E\000\000\000\000\001}\001}\001}\003E\000\000\000\000\000\000\001A\000\000\000\165\001A\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\165\0121\001A\000\000\001A\000\000\001A\000\000\001A\000\000\000\000\000\000\000\000\000\000\001}\001}\001}\000\000\001}\001}\001A\000\000\000\000\000\000\000\000\000\000\001A\000\165\000\000\000\000\000\000\000\000\000\000\000\000\000\165\000\000\000\000\001}\000\000\000\000\001A\000\000\000\000\000\000\000\000\001A\001A\001A\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\001A\000\000\000\000\000\000\000\165\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\000\000\000\000\001&\000\000\001A\001A\001A\006y\001A\001A\000\000\000\000\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\001A\000\000\000\000\019\206\000\000\001R\000\000\000\000\000\000\001^\002N\001A\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005b\007.\005n\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\000\000\000\000\001&\005r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\005z\006\218\005~\000\000\005\190\018&\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\020\162\000\000\005\130\000\000\006\170\000\000\003F\000\000\004j\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007.\005n\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\186\000\000\000\000\001&\005r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\005z\006\218\005~\000\000\000\000\0076\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007\030\002N\018\186\000\000\005\130\000\000\000\000\000\000\003F\000\000\004j\003\246\000\000\001\002\001\006\003\250\000\000\004\002\001\"\007.\005n\000\000\000\000\001&\000\000\000\000\000\000\000\000\006\157\000\000\000\000\000\000\005r\001*\000\000\000\000\000\000\001.\000\000\000\000\000\000\000\000\005z\000\000\005~\000\000\0012\0076\003z\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\206\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\0196\003\214\005\130\000\000\000\000\b\154\b\158\b\170\004j\000\000\005n\004i\004i\000\000\000\000\000\000\004i\000\000\000\000\000\000\000\000\004i\000\000\000\000\000\000\000\000\000\000\004i\000\000\000\000\000\000\004i\005z\000\000\005~\000\000\000\000\000\000\004i\019\134\000\000\000\000\019\158\b\178\000\000\b\182\000\000\000\000\000\000\000\000\000\000\004i\000\000\000\000\000\000\004i\004i\000\000\000\000\005\130\b\198\000\000\000\000\004i\t>\004j\004i\000\000\003E\000\238\004i\003E\004i\004i\000\000\004i\000\000\000\000\000\000\000\000\000\000\000\000\003E\000\000\000\000\000\000\003E\004i\003E\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004i\000\000\004i\003E\012\206\000\000\000\000\000\000\000\000\003E\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003E\000\000\003E\012)\000\000\003E\012)\000\000\000\000\004i\003E\003E\003E\000\000\000\000\004i\000\000\012)\000\000\000\000\000\000\012)\000\000\012)\000\000\000\000\003E\000\000\000\000\0051\003E\000\000\000\000\000\000\000\000\012)\000\000\000\000\000\000\000\000\000\000\012)\000\000\003E\003E\026\186\000\000\003E\003E\000\000\012)\000\000\012)\000\000\000\000\012)\000\000\000\000\000\000\000\000\012)\012)\001B\001\006\000\000\rN\003E\001\"\000\000\000\000\000\000\003E\001&\000\000\000\000\000\000\012)\005\186\000\000\003\254\012)\000\000\001*\000\000\000\000\000\000\000\000\000\000\000\000\001F\000\000\000\000\000\000\012)\012)\003\030\000\000\012)\012)\000\000\000\000\000\000\001R\000\000\000\000\000\000\001^\002N\000\000\012)\000\000\000\000\000\000\014j\003F\000\000\012)\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005b\000\000\005n\012)\000\000\000\000\000\000\000\000\000\000\000\000\001B\001\006\000\000\000\000\005r\001\"\000\000\006\186\000\000\000\000\001&\000\000\000\000\000\000\005z\000\000\005~\000\000\005\190\000\000\001*\000\000\006\218\000\000\000\000\000\000\000\000\001F\000\000\000\000\006\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006^\000\000\001R\005\130\000\000\000\000\t\002\002N\000\000\004j\000\000\000\000\000\000\005\133\003F\000\000\005\133\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007.\005n\005\133\000\000\000\000\000\000\005\133\000\000\005\133\000\000\000\000\000\000\000\000\005r\000\000\000\000\000\000\000\000\000\000\000\000\005\133\000\000\000\000\005z\000\000\005~\005\133\000\000\000\000\000\000\000\000\000\000\000\000\bf\000\000\005\133\000\000\005\133\000\000\000\000\005\133\000\000\000\000\000\000\000\000\005\133\005\133\000\238\000\000\000\000\005\130\000\000\000\000\000\000\000\000\000\000\004j\005\137\000\000\000\000\005\137\005\133\005\133\000\000\000\000\005\133\000\000\000\000\000\000\000\000\000\000\005\137\000\000\000\000\000\000\005\137\000\000\005\137\005\133\005\133\000\000\000\000\005\133\005\133\000\000\000\000\000\000\000\000\000\000\005\137\000\000\000\000\000\000\000\000\000\000\005\137\000\000\000\000\000\000\000\000\000\000\005\133\bf\000\000\005\137\000\000\005\137\003E\000\000\005\137\003E\000\000\005\133\000\000\005\137\005\137\000\238\000\000\000\000\000\000\000\000\003E\000\000\000\000\000\000\003E\000\000\003E\000\000\000\000\005\137\005\137\000\000\000\000\005\137\000\000\000\000\000\000\000\000\003E\012\206\000\000\000\000\000\000\000\000\003E\000\000\005\137\005\137\000\000\000\000\005\137\005\137\000\000\003E\000\000\003E\006-\000\000\003E\006-\000\000\000\000\000\000\003E\003E\003E\000\000\000\000\000\000\005\137\006-\000\000\000\000\000\000\006-\000\000\006-\000\000\000\000\003E\005\137\000\000\000\000\003E\000\000\000\000\000\000\000\000\006-\000\000\000\000\000\000\000\000\000\000\006-\000\000\003E\003E\r.\000\000\003E\003E\000\000\006-\000\000\006-\000\000\000\000\006-\000\000\000\000\000\000\000\000\006-\006-\000\238\000\000\000\000\rN\003E\000\000\011\233\000\000\001\006\011\233\000\000\000\000\028\154\000\000\006-\000\000\000\000\028\158\006-\000\000\011\233\000\000\000\000\000\000\000\000\000\000\011\233\000\000\000\000\000\000\000\000\006-\006-\r\242\000\000\006-\006-\000\000\011\233\000\000\000\000\000\000\000\000\000\000\011\233\000\000\000\000\006-\000\000\000\000\000\000\001\186\002N\011\233\006-\011\233\001\174\000\000\011\233\002\182\000\000\000\000\000\000\011\233\000\000\006-\000\000\000\000\000\000\000\000\003N\028\162\001B\001\006\004\149\000\000\003R\001\"\000\000\011\233\000\000\000\000\001&\011\233\000\000\000\000\000\000\000\000\003^\006r\000\000\000\000\001*\000\000\011\182\028\166\011\233\011\233\000\000\001F\011\233\000\000\000\000\003\226\000\000\020\238\000\000\000\000\012B\000\000\000\000\000\000\001R\012J\000\000\000\000\001^\002N\000\000\011\233\007\146\000\000\000\000\000\000\003F\007%\000\000\003\246\007%\012R\000\000\003\250\000\000\004\002\005b\000\000\005n\000\000\000\000\007%\000\000\000\000\000\000\007%\000\000\007%\012f\012\170\005r\000\000\004\149\004\149\000\000\000\000\000\000\000\000\000\000\007%\005z\000\000\005~\000\000\005\190\007%\b\014\000\000\000\000\000\000\000\000\018\014\000\000\000\000\007%\000\000\007%\001\209\000\000\007%\001\209\000\000\000\000\000\000\007%\007%\000\238\005\130\000\000\000\000\000\000\001\209\000\000\004j\000\000\001\209\000\000\001\209\000\000\000\000\007%\000\000\000\000\000\000\007%\000\000\000\000\000\000\000\000\001\209\000\000\000\000\000\000\000\000\000\000\001\209\000\000\007%\007%\000\000\000\000\007%\007%\000\000\001\209\000\000\001\209\0061\000\000\001\209\0061\000\000\000\000\000\000\001\209\001\209\000\000\000\000\000\000\000\000\007%\0061\000\000\000\000\000\000\0061\000\000\0061\000\000\000\000\001\209\000\000\000\000\000\000\001\209\000\000\000\000\000\000\000\000\0061\000\000\000\000\000\000\000\000\000\000\0061\000\000\001\209\001\209\000\000\000\000\001\209\001\209\000\000\0061\000\000\0061\000\000\000\000\0061\000\000\000\000\000\000\001\209\0061\0061\000\238\000\000\000\000\000\000\001\209\000\000\000\000\000\000\000\000\r\210\000\000\000\000\000\000\000\000\0061\001\209\000\000\000\000\0061\000\000\000\000\000\000\000\000\b5\b5\000\000\000\000\000\000\b5\000\000\000\000\0061\0061\b5\000\000\0061\0061\000\000\000\000\003\238\000\000\000\000\000\000\b5\000\000\000\000\000\000\0061\000\000\000\000\b5\000\000\000\000\000\000\0061\000\000\004\129\000\000\000\000\004\129\000\000\000\000\000\000\b5\000\000\0061\000\000\b5\b5\000\000\004\129\000\000\000\000\000\000\004\129\b5\004\129\004\129\b5\000\000\000\000\000\000\b5\000\000\b5\b5\000\000\b5\004\129\000\000\000\000\000\000\004\129\000\000\004\129\000\000\000\000\000\000\000\000\b5\000\000\004>\000\000\004\129\000\000\004\129\004\129\000\000\004\129\b5\000\000\b5\004\129\004\129\011\158\000\000\000\000\000\000\000\000\000\000\000\000\004\129\000\000\004\129\000\000\000\245\004\129\000\000\000\245\004\129\000\000\004\129\011\158\004\129\000\000\000\000\b5\000\000\000\000\000\245\000\000\000\000\b5\000\245\000\000\000\245\004\129\004\129\000\000\000\000\004\129\004\129\000\000\000\000\000\000\000\000\000\000\000\245\004J\000\000\000\000\000\000\007\190\000\245\004\129\004\129\000\000\000\000\004\129\004\129\000\000\000\000\000\245\000\000\000\245\000\249\000\000\000\245\000\249\000\000\004\129\000\000\000\245\000\245\000\238\000\000\000\000\004\129\000\000\000\249\000\000\000\000\026\130\000\249\000\000\000\249\000\000\000\000\000\245\000\000\000\000\000\000\000\245\000\000\000\000\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\000\000\249\000\000\000\245\000\245\000\000\000\000\000\245\000\245\000\000\000\249\000\000\000\249\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\249\000\249\000\238\000\000\000\000\000\000\000\245\000\000\000\000\002Z\003\"\000\000\000\000\000\000\001\"\000\000\000\249\000\245\000\000\000\000\000\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\002\134\002r\003&\000\249\000\249\000\000\000\000\000\249\000\249\002~\000\000\000\000\000\000\000\000\000\000\000\000\007!\000\000\000\000\007!\000\000\000\000\000\000\003*\003.\000\000\000\249\000\000\000\000\003:\007!\003F\004\026\004&\007!\000\000\007!\000\249\r\170\000\000\r\174\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007!\000\000\000\000\000\000\000\000\000\000\007!\0046\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007!\000\000\007!\006%\005~\007!\006%\000\000\000\000\000\000\007!\007!\000\000\000\000\012\150\000\000\r\186\006%\000\000\000\000\000\000\006%\000\000\006%\000\000\000\000\007!\000\000\000\000\000\000\007!\000\000\000\000\r\190\000\000\006%\000\000\000\000\000\000\000\000\000\000\006%\000\000\007!\007!\011\202\000\000\007!\007!\000\000\006%\000\000\006%\011\149\000\000\006%\011\149\000\000\000\000\000\000\006%\006%\000\000\014\218\000\000\000\000\007!\011\149\000\000\000\000\000\000\011\149\000\000\011\149\000\000\000\000\006%\000\000\000\000\000\000\006%\000\000\000\000\000\000\000\000\011\149\000\000\000\000\000\000\000\000\000\000\011\149\000\000\006%\006%\000\000\000\000\006%\006%\000\000\011\149\000\000\011\149\000\000\000\000\011\149\000\000\000\000\000\000\000\000\011\149\000\000\000\000\000\000\000\000\000\000\006%\000\000\011\153\000\000\000\000\011\153\000\000\000\000\000\000\000\000\011\149\nF\000\000\000\000\011\149\000\000\011\153\000\000\000\000\000\000\011\153\000\000\011\153\000\000\000\000\000\000\000\000\011\149\011\149\000\000\000\000\011\149\011\149\000\000\011\153\000\000\000\000\000\000\000\000\000\000\011\153\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\153\011\149\011\153\000\000\000\000\011\153\000\000\000\000\000\000\000\000\011\153\000\000\011:\000\000\000\000\002Z\003\"\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\011\153\nV\000\000\000\000\011\153\000\000\000\000\000\000\000\000\001*\002\134\002r\000\000\000\000\000\000\000\000\000\000\011\153\011\153\002~\000\000\011\153\011\153\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003*\003.\004Y\000\000\000\000\004Y\003:\011\153\003F\004\026\004&\000\000\000\000\000\000\000\000\r\170\004Y\026Z\011:\000\000\004Y\000\000\004Y\007\146\000\000\000\000\000\000\000\000\005\145\000\000\000\000\005\145\0046\000\000\004Y\000\000\000\000\000\000\000\000\000\000\004Y\000\000\005\145\000\000\005~\000\000\005\145\000\000\005\145\004Y\000\000\004Y\000\000\000\000\004Y\000\000\026f\000\000\000\000\004Y\005\145\000\000\000\000\000\000\000\000\000\000\005\145\b\014\000\000\000\000\000\000\000\000\000\000\r\190\000\000\004Y\000\000\000\000\000\000\004Y\005\145\000\000\000\000\000\000\000\000\005\145\005\145\000\238\000\000\000\000\000\000\000\000\004Y\004Y\000\000\000\000\004Y\004Y\000\000\000\000\000\000\005\145\000\000\000\000\000\000\000\000\000\000\004Q\000\000\000\000\004Q\000\000\000\000\000\000\004q\004Y\000\000\004q\005\145\005\145\000\000\004Q\005\145\005\145\000\000\004Q\012\018\004Q\004q\000\000\000\000\000\000\004q\000\000\004q\000\000\000\000\000\000\000\000\004Q\000\000\005\145\000\000\000\000\000\000\004Q\004q\000\000\000\000\000\000\000\000\000\000\004q\000\000\004Q\000\000\004Q\000\000\000\000\004Q\000\000\004q\000\000\004q\004Q\000\000\004q\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\000\000\000\000\000\000\004Q\000\000\000\000\004q\000\000\000\000\000\000\004q\004A\000\000\000\000\004A\000\000\004Q\004Q\000\000\000\000\004Q\004Q\000\000\004q\004q\004A\000\000\004q\004q\004A\000\000\004A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004Q\000\000\000\000\000\000\004A\000\000\000\000\004q\000\000\000\000\004A\016\194\000\000\000\000\000\000\000\000\000\000\000\000\017\166\004A\000\000\004A\000\000\000\000\004A\000\000\000\000\000\000\000\000\004A\002Z\002^\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\129\000\000\000\000\004\129\004A\000\000\003\254\000\000\004A\001*\002\134\002r\000\000\000\000\004\129\000\000\000\000\000\000\004\129\002~\004\129\004A\004A\000\000\000\000\004A\004A\000\000\000\000\000\000\000\000\000\000\004\129\002\130\003.\000\000\000\000\000\000\004\129\003:\000\000\003F\004\026\004&\004A\000\000\000\000\000\000\0042\000\000\011\249\000\000\004\129\011\249\000\000\020\194\000\000\004\129\011\158\007\169\000\000\000\000\000\000\000\000\011\249\0046\000\000\000\000\000\000\000\000\011\249\000\000\000\000\004\129\000\000\000\000\007\169\007\169\000\000\007\169\007\169\000\000\011\249\000\000\000\000\000\000\000\000\000\000\011\249\000\000\004\129\004\129\000\000\000\000\004\129\004\129\000\000\011\249\000\000\011\249\007\169\000\000\011\249\000\000\007\141\000\000\004f\011\249\004j\000\000\000\000\000\000\000\000\004\129\000\000\000\000\000\000\000\000\r\210\000\000\000\238\007\141\007\141\011\249\007\141\007\141\000\000\011\249\000\000\007\173\000\000\000\000\000\000\000\000\000\000\007\169\000\000\000\000\000\000\000\000\011\249\011\249\000\000\000\000\011\249\007\141\007\173\007\173\000\000\007\173\007\173\000\000\028\138\007\169\000\000\007\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\249\000\000\007\141\000\000\000\000\007\161\007\169\007\173\000\000\005\222\007\169\000\000\000\000\000\000\007\169\000\000\007\169\007\141\004I\000\000\007\169\004I\007\161\007\161\000\000\007\161\007\161\000\238\000\000\000\000\000\000\000\000\004I\000\000\000\000\007\141\004I\007\141\004I\000\000\000\000\000\000\007\173\000\000\000\000\000\000\007\161\000\000\000\000\000\000\004I\007\141\002Z\002^\005\222\007\141\004I\000\000\000\000\007\141\007\173\007\141\007\173\000\000\000\000\007\141\000\238\000\000\000\000\000\000\004I\000\000\001*\002\134\002r\004I\007\173\000\000\000\000\005\222\007\173\007\161\002~\000\000\007\173\015\174\007\173\000\000\000\000\000\000\007\173\004I\000\000\000\000\000\000\000\000\002\130\017\002\000\000\007\161\016&\007\161\003:\000\000\003F\004\026\004&\000\000\004I\004I\000\000\017\018\004I\004I\000\000\0062\000\000\000\000\005\222\007\161\000\000\004y\000\000\007\161\004y\007\161\000\000\000\000\0046\007\161\001\174\004I\000\000\002\182\000\000\004y\000\000\000\000\000\000\004y\000\000\004y\017N\000\000\028\226\000\000\002Z\002^\000\000\000\000\003R\000\000\000\000\004y\000\000\000\000\000\000\000\000\000\000\004y\000\000\000\000\003^\000\000\000\000\000\000\001*\002\134\011\182\000\000\000\000\000\000\000\000\004y\000\000\000\000\000\000\003\226\004y\020\238\000\000\000\000\012B\000\000\000\000\000\000\000\000\012J\006\245\006\245\002\130\003>\000\000\000\000\004y\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\012R\000\000\0042\000\000\028\146\006\245\006\245\006\245\004y\004y\000\000\000\000\004y\004y\000\000\006\245\000\000\012f\012\170\0046\000\000\004\189\000\000\005\005\000\000\012\221\012\221\000\000\000\000\006\245\006\245\004y\000\000\000\000\000\000\006\245\000\000\006\245\006\245\006\245\018\014\000\000\017\206\026\002\006\245\012\221\012\221\012\221\007\166\000\000\000\000\000\000\000\000\001\174\000\000\012\221\r\142\000\000\000\000\000\000\000\000\006\245\000\000\000\000\000\000\000\000\000\000\014\154\000\000\012\221\012\221\004\137\000\000\003R\000\000\012\221\000\000\012\221\012\221\012\221\001\174\000\000\000\000\002\182\012\221\014\158\002Z\002^\024\246\000\000\000\000\014\198\000\000\000\000\004\181\000\000\000\000\000\000\000\000\000\000\003R\012\221\000\000\000\000\000\000\012B\001*\002b\002r\004\222\012J\000\000\003^\000\000\000\000\000\000\002~\000\000\011\182\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015Z\003\226\000\000\020\238\002\130\003.\012B\000\000\000\000\000\000\003:\012J\003F\004\026\004&\000\000\000\000\012f\015n\0042\000\000\004\137\004\137\000\000\000\000\000\000\000\000\012R\002Z\002^\000\000\000\000\000\000\000\000\000\000\000\000\0046\000\000\000\000\000\000\015~\000\000\000\000\000\000\012f\012\170\000\000\000\000\001*\002b\000\000\000\000\000\000\000\000\000\000\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\014\000\000\000\000\000\000\000\000\002\130\0036\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\000\000\000\000\0042\000\000\012\210\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0046")) + ((16, "6\224@~;\198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\018;\198\000\000\000\000\022\022;\1986\224@~\022\022\000\003\000\000\000\000@~\022\022\000\003@~\022\022\000\003\000\000\000\000\000\000\018\022;,\021\218<\194K\216\000\000\000\025\000\000\000\000\001\030\000\000\000\000=\168\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\002\248\002\160\000\t\000\000\000\000\002\236\000\000>\206Qx\022\022?\170\022|\003\168\0001X2\000\000\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\234\001\132\000\157\000\000\000\168\004B\000\000\000\242\000\226\004J\000\000\005L\002\000\n\\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\000\000\002\160K\b\000\000\000\000\000h\000\000\000\000K\170\003<\003\168\000\000\000\0009J\000h\000\000=\210\022\022>\206\005.\005\000\003\168\004\176\000\000\022\0226\224@D\022\022M\\\000\000\001<\000\000G\018\004\250\000\000\028x\000\000\000\016\000\000\000\000\001\166\000\000\000h\000\000\000\000\000\000\001\206\000\000\028x\000\000\004\004jjq\130X\200s\164<6G\000I\238\000\000[\140\026\018K\b;\1986\2246\224\000\000\000\000\000\000=L=L\003\168\004\176\004\176\022\022?\170\025\174\000\208\005\182\000\000\004\144\005\186\000\000\000\000\000\000\000\000\000\000\022\022\000\000\000\000\000\000@~\022\022\000\003@~\022\022\000\0034\212c\220AP\000\252?\170@~\022\022o~\000\000K\216g\154j\222\000\000\005\182\000\000\005\130\000\000\023\1648NI4\000\0008NI4\000\0008Nu\240\007\028\006\194\004\004\002\164\000\000\006F\000\000\000\000\b0\000\000\000\000\000\0008N\000h\000\000\000\000M\\8NL\146I\238\000\000\006\196\028\2529JI\238\006r8N\000\000\000\000\000\000\000\000\000\000\000\000H\242I\238I\220\007\028\000\000\000\000\000\000\003~\000\000\000\000ON\007\140\000h\000\000\000\000J\198\000\000\000\000\000\000\003(\000\0008N\000\000\021\024xt\000\0008N\007V8N\030.\000\000\031,\000\000\bT\0040\000\000\007`8N\004|\000\000\004\146\000\000\003\138\000\000\000\003\006b\000\000\000\000\000\000$\152\tXK\216@~\022\022K\216\000\000\007\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000G\250\030\140\000\000\000\000\000\000\001\254\026\002j\222\000\000d^\022\022K\216\000\000\000\000HHK\216u\218K\216vh\000\000N\000\000\000\000\000N\164=\168\004\180\004\180\000\000\b~K\216\000\000\000\000\000\000\bB\b\186\000\000\027\138\000\000K\216v\2068N\b\n\000\000K\216v\232\0001\000\000\000\000\000\000\b\202\000\000\022Z\000\000m\168\000\000\tx\000\0006\136K\216\000\000\000\0006\140\tB\005\182\t\156\000\000\000\000\000\000\000\000\b\220\000\000<\176\006\022\011\b\007\1748N\016\186\011\144\000\000\000\000\007l\011\b\t\018\000\003K\216P(\002\254\000\000K\216\024\1448N\017\138\t\018\011\166\000\000\000\000\000\000>\164\004\180\012B\000\000K\216\000\000\000\003@~=\210=L\003\168\004\176\003~\002\004\000\t\000\000\011\144>\206>\206\012H>\206\003~\002\004\002\004\000\000\012p>\206\000\000]\184\001LG\018\005\182\005\248x\142\000\0008NYn8NR\206Y\2468N\005l8NZ\128\000\000\t\134\n\150\006\140>\206^@\000\000\tZ\011\148Q\188\000\000\000\000\000\000\000\000>\206^\200>\206_P\000\218\004\004SX\005\186\004\004S\226\000\000_\216\001L\000\000\000\000``\023f\000\000\025\228\000\000\012\220\004\176\000\000RFP\200\000\000\000$\000\000>\206\026P\000\000\000\000\000\000P\238\000\000\000$\000\003AP\005\234\t\170?\170\024\0069\222\018\022?\170@~\022\022\018\022@~\022\0227\220@~\022\022\000\003d^\022\022K\216K\2168&\000\003d^\022\022<\176\000\000Z\208\000\000\000\000\003ZI\238\t\240\012\248FFd^\022\022K\216\027\254K\216\000\000\000\000d^\022\022K\216\028N\000\003d^\022\022K\216\027\138\000\003\018\022\000\000\000\000\000\000\000\000\001\250\023r5\218\000\000B$B\248=L\003\168\004\176\006\192>\206\026b\000\000C\204D\160g\154\029L8N\t\174\000\003@~\022\022\018\022\024\006\018\022\003\002\017\254?\170d^\022\022K\216\028\252?\170\018\022\n\200\r8\007\2208N#\1548N\028\n8N#\250\r\162\000\000\000\000\r\204\000\000\018\022\004\n\r\232\000\000$\236\000\003\014b\000\000\029\250?\170\019\020\025\004\000\000\000\000\000\000\000\000\b\224\000\003\000\000\000\000\t\202\000\003\000\000\000\000\030\248?\170\031\246?\170\000\000\020\018\026\002?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170 \244?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000\000\000\000\000\000\003;\198\000\003\000\000\r\186\000\000\022\022K\216\029\1348N\n\208\000\003\000\000\031\130\000\003\000\000K\216 FK\216 \128K\216!D\0001\000\000\000\000\000\000!~K\216\"B\000\000d\210;\1986\224K\216;R\000\003\000\000:\250\025\174\000\208\000hq\224>\206n\020d\210d\210\000\000\000\000\004\002\005\n\000\t\006\n\004\176kR>\206\005\198\004\176k\220d\210t\002\002\160\000\t\006\nd\210t\002\000\000\006\n\000\000\000\000\006\nd\210\000\000;\1986\224;\1986\224=L\003\168\004\176d\210\000\000\022|\003\168\0001\r\202K\b\n\n\000h\000\0008Ne6\r\248\014\166rD\000\000d\210\000\000e\1568\236\022\022\005\170\000\000\n\146\014\160\000\000\015\bl@I\238\000=\000\000\014\230\014tK\b\011\0308N$\248\022\022\011\152\021\220\000\000%x\015D\000\000\000\248\000\000\000\000\015\144I\238Tj\000\000[n\006\178\n\168\002\004\011\224\014\216\022\022d\210\000\000Mn\011\246I\238\015jI\238`\232U\018\015lI\238a\134U\186\022\022d\210\000\000\000\000\\D@D\022\022X\\G\018\011\208jjq\130u\240\000=\015\150\000\000\000\000b\bf\000\022\022\000\000nx\005\170\000\000\000\000o\194\000\000\000\000\000\000l\164\025z\026x\000=\015\152\000\000\000\000\000\000f\000\022\022\000\000\000=\015\182\000\000\000\000\000\000\000\000\000\000o\194\000\000\015\174\027\226\000\000\022\232o\194\000\000\000\000\000\000\000\000\012\028p^q\130\000\000o\194\000\000\000\000o\194\000\000\015\208\027\226\022\232o\194\000\000x\240\023\152\002\248\000\208\004\004o\194\000\000\000\208\004\004o\194\000\000;f\025\174\000\208\000hq\224>\206o\194\000\000\004\002\006\194\bn\004\004o\194\000\000\000\t\0158>\206o\194G\164\002\160\000\t\015:>\206o\194G\164\000\000\000\000\007\018\000\003o\230\000\000>\206t6d\210\000\000\007\018\000\000=\210\022\022>\206o\194\000\0008\236\022\022\005\170f\000#\242\030\200\021\220\017\184\000\000\012v\028x\012`\000\000\015\206\015z\0312\021\218I\0028N\012N\000\000Er\003\218\006\242\011\232\000\000\012`\000\000\015\224\015`8NAP\000\000\003\168\017\180\012*\000\000\r^\000\000\015\246\015vK\b>\022\000\000\022\022\0312\016\026\004j\000\208\000\003\002X\03128N\r^\007\028\000\0008N\b\238\n\234\000\000\000\000b\174\000\000\000\003\005\204\0312c8AP\000\000\022\0228N\012\1688N5\218>\022\000\000\015\168\000\000>\022\000\000\000\000Er\000\000d\210t\212\021\220\017\184\012v\016\012\015\184\0312d\210t\212\000\000\000\000\021\220\017\184\012v\016 \015\158v\254F\228I\238\016@v\254u\240\030\198\016Xv\254I\238\016^v\254f\128g\000\000\000O\216\000\000\000\000d\210wr\021\220\017\184\012v\016X\015\214v\254d\210wr\000\000\000\000\000\000x\240\000\000\000\000\000\000\000\000\000\000\000\000\000\000d\210\000\000t\226\022\022:*\016\\jj\000\000o\194t\226\000\000\000\000w\140\022\022:*\016^\015\224q\130\000\000o\194w\140\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\026#\242\021\220\017\184\012v\016ng\1548\006\021\218<\194B\248\022f\002\210\000=\016\132\n\012\000\003\000\000\016.\000\003\000\000>\022\000\000\007\222\012\230\000\000\r\194\000\000\016\166\01668N7D\016\188\012\b\000\003\000\000\016j\000\003\000\000\022\138\003\168\r(\016\204h\028K\b\004\180\016n8N\rv\000\003\000\000\016\134\000\003\000\000\000\000\r\006\000\000\016\152FF\000\000\000\000\000\000>\022\000\000\021\182\014\016\000\000\014\\\000\000\016\248\016xK\b\000\000\017\bh\158L\212\004\180\016\1548N\r\166\000\003\000\000\016\182\000\003\000\000\000\000\022\022\000\003>\022\000\000\022<\022\0228\0068\006i\146;\198\022\022o~K\216\n\200\000\000\021\178\000\208\000\003\r<8\0068N\014\\\005\182\000\000\022\022g\154g\1548\006\r\1948\006\000\0009\204\018\022\005\018\006\026:\198\000\000\000\000\000\000V\030\000\000\000\000V\168\000\000\000\000W2\000\003\014:8\006W\188o~K\216\n\200\000\000\007\012\000\000v\254\017Z\000\0004\212\017 \000\000>\022\000\0008\0064\212>\022\000\000\022\0228N>\022\000\000\016\206\000\000>\022\000\000\000\000B\248\000\000plv\254\016\2368\006q\bg\154\000\000d\210u~\021\220\017\184\012v\017Xg\154d\210u~\000\000\000\000\000\000m\138@~\022\022o~K\216d\210\000\000\000\000\000\000\000\000\000\000\000\000r\168\000\000\000\000s*\000\000d\210\000\000t\226\000\000\000\000\000\000\000\000d\210m\138\000\000\000\000r\168\000\000s*\017\148\000\000\017\150\000\000\017\180\000\000\000\000\000\000\000\003\017\186\000\000\000\003\017\232\000\000\t\"\018\252?\170\017\242\000\000\029\130?\170\000\000?\170\018\006\000\000?\170\018\018\000\000\000\000\019\250?\170\018&\007\"?\170!\242?\170\0188\b ?\170\"\240?\170\018:\t\030?\170#\238&\232\000\003\018L\n\028?\170$\236\000\003\018J\011\026?\170%\234\000\003\018\\\012\024?\170&\232\012\230\020\248?\170\018d\r\022?\170'\230?\170\018p\014\020?\170(\228?\170\018\134\015\018?\170)\226\016\016?\170*\224\021\016\000\000\018\146\000\000?\170\018\150\000\000?\170\018\150\000\000\000\000\"|\000\003\000\000\007\214\000\003\000\000K\216\000\000\000\000i\016\018\158\000\000Er\000\000\017\216\000\000Er\000\000\018\158\000\000\005\234\0182\000\000\024\006\028\250\005\182\000\000\031\192\011T\rP\023|\000\000\000\000\018\186\000\000\001t\027\000>\170\000\000\014\176\000\000\000\000\000\003\018\020\000\003\018\030\000\000\0186\000\003\018N\000\000\000\003\014\176\000\003\018L\000\003\018Z\000\000\000\000\018\224\000\003\000\000\000\003\000\000\000\000\000\000+\222\019$?\170,\220?\170-\218\000\000\018\130\000\000\027\000\014D\000\000\017\014\019\030\000\000#\150\014L\014\190\000\000\000\000\018\188\000\000\019:\000\000\000\000\003\168\004\176\023\160\000\003\000\000\002\248\002\160\000\t\006\n\018\214\000\003\000\0008\236\022\022\005\170\000\230\003~\018\216\000\003\000\000\000\000\000\000\000\000\019`\000\000\000\000y\030\004\180\018\1828N\014\176\000\003\000\000\014\1788N\014\200\000\003\000\000\018\218\000\003\000\000\000\000d\210\000\000.\216\000\000\018\194\000\000\000\000=L\003\168\004\176\024\232\000\000>\206\027N\000\000\nT\000\000\019\144\000\000\019\194K\216/\214\019\196K\2160\212\022\022\000\000>\206\027`\000\000>\206\027\210\000\000>\206\028\246\000\000d\210\000\000\003\168\004\176d\210\000\000d\210m\138\000\000\000\000\019\152\000\000\021\006\011\166\022\022a\006\000\000\000\000!\004b2\000\000\000\000\019\028\000\000\019r8N\000\000\r\156\n,\007\028\000\000\000\0008N\005V\007\1588N\012\148\000=\019\168\000\000\000\000n\220\000\000\000\000\019\170\027\226\029P\005\170f\000\006\178\022\022\000\000d\210\000\000\000\000\000\000\000\000\000\000\000\000\000\000j\006\006\178\022\022\000\000\015\140jj\019\176\027\226\029Pd\210\000\000\019,\000\000\\\162\029\206\000\000d\210\000\000\019H\000\000\030r\000\000\028N\000\0008N\0158\000\000B\248\019\\\000\000\020&K\2161\2102\208K\2163\206\000\003\000\000\000\003\000\000\019T\000\003\019^\000\000\020\016\000\000\000\003\019l\000\003\019t\000\000\019\156\000\000\000\000?\170\019\160\000\000\000\000#\238X2\020H\000\000\000\000\000\000\012T\017\196]\020\020J\000\000\000\000\000\000\000\000\000\000\000\000\019\194\000\000\006\178\000\000\019\196\000\0008N\000\000\t\252\000\000\000\003\019\212\000\000\000\000\004\004\000\000\bl\000\000\000\003\000\000\001\212\000\000\004\176\000\000\005\190\000\000>\206\000\000\026P\000\000\n\150\000\000\019\236\000\000K\216\024\144\000\000\000\000\024\216\019\242\000\000\000\000\019\234\025\1787\220\000hm&\000\000\000\000\000\000\000\000\000\000v\b\000\000\000\000\020\156\000\000yT\000\000\015\176\020\158\000\000\020\160\000\0008\2168\216w\250w\250\000\000\000\000d\210w\250\000\000\000\000\000\000d\210w\250\020\002\000\000\020\016\000\000"), (16, "\0039\000\006\000\246\001\142\001\146\0039\001\002\001\006\0039\001\n\001\022\001\"\0039\rF\0039\012\129\001&\0039\007\130\0039\0039\0039\006\025\0039\0039\0039\001*\001\186\002N\001\254\001.\0039\003V\003Z\011\150\0039\012\129\0039\006\217\0012\b\154\003z\002\230\0039\0039\003\174\003\178\0039\003\182\003\194\003\206\003\218\003\226\007\018\007b\002\234\0039\0039\003F\001J\002f\003\214\0039\0039\0039\b\194\b\198\b\210\b\226\b\142\005\150\0039\0039\0039\0039\0039\0039\0039\0039\0039\b\250\001N\0039\000\238\0039\0039\0039\001J\t\006\t\030\tj\t~\005\162\0039\005\166\0039\0039\0039\b\190\0039\0039\0039\0039\b\218\002j\b\222\002\006\024B\0039\001N\0039\0039\004\133\0039\0039\0039\0039\0039\0039\005\170\b\238\0039\0039\0039\t\146\004j\t\246\012\169\0039\0039\0039\0039\012\169\012\169\012\169\012\169\b\158\002\022\012\169\012\169\012\169\012\169\001\250\012\169\012\169\003\157\012\169\012\169\012\169\003\189\012\169\012\169\012\169\012\169\r>\012\169\004\133\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012y\012\169\rF\012\169\000\238\012\169\012\169\012\169\012\169\012\169\007\190\006\025\012\169\012\169\012\169\003a\012\169\003\222\012\169\012\169\012\169\012y\001\137\012\169\012\169\012\169\012\169\012\169\012\169\012\169\003a\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\bB\012\169\012\169\007\250\012\169\012\169\012\169\001V\001\250\003\157\bJ\002\242\012\169\012\169\012\169\012\169\012\169\012\169\bN\012\169\012\169\012\169\012\169\012\169\012\169\012\169\r\190\012\169\012\169\001Z\012\169\012\169\002\246\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\003\n\001\137\012\169\012\169\012\169\012\169\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\002&\001\137\002\202\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\023\214\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\003]\001\137\001\137\001\137\001\137\001\137\007~\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\028W\001\137\001\137\001\137\001\137\001\137\001\137\001\137\bJ\004\133\004\133\003\014\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\004F\t\170\001\137\005\218\001\137\001\137\r\170\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\016\170\001\137\001\137\001\137\001\137\001\137\nY\002\029\002\029\004>\007\030\nY\nY\nY\nY\002J\001\154\nY\nY\nY\nY\000\238\nY\nY\004\133\nY\nY\nY\bJ\nY\nY\nY\nY\004\133\nY\000\n\nY\nY\nY\nY\nY\nY\nY\nY\001\246\nY\000\238\nY\005\n\nY\nY\nY\nY\nY\007\"\007>\nY\nY\nY\002\014\nY\002\030\nY\nY\nY\002\029\004J\nY\nY\nY\nY\nY\nY\nY\002V\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\002v\nY\nY\004\218\nY\nY\nY\004\133\0075\004\133\004\133\005f\nY\nY\nY\nY\nY\nY\004\133\nY\nY\nY\nY\nY\n\014\nY\001\158\nv\nY\004\133\nY\nY\004\133\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\000\238\nY\nY\nY\nY\nY\003\229\004\133\004\133\004\133\002^\003\229\003\229\003\229\003\229\004\133\005\014\003\229\003\229\003\229\003\229\000\238\003\229\003\229\004\133\003\229\003\229\003\229\005j\003\229\003\229\003\229\003\229\004\133\003\229\t>\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\004\133\003\229\000\238\003\229\005F\003\229\003\229\003\229\003\229\003\229\003\026\006\165\003\229\003\229\003\229\006\173\003\229\004\133\003\229\003\229\003\229\005\014\000\238\003\229\003\229\003\229\003\229\003\229\003\229\003\229\002z\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\005V\n\006\nn\002\n\003\229\003\229\003\229\002\026\003r\002\170\001\006\005^\003\229\003\229\003\229\003\229\003\229\003\229\002\174\003\229\003\229\003\229\003\229\003\229\n\014\003\229\0069\nv\003\229\001*\003\229\003\229\000\238\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\012}\003\229\003\229\003\229\003\229\003\229\003\213\003n\001\142\001\146\006*\003\213\003\213\003\213\003\213\003F\t%\003\213\003\213\003\213\003\213\012}\003\213\003\213\012Z\003\213\003\213\003\213\002\158\003\213\003\213\003\213\003\213\b!\003\213\002\162\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\007v\003\213\016\158\003\213\003\142\003\213\003\213\003\213\003\213\003\213\005\014\001\250\003\213\003\213\003\213\003\157\003\213\t\r\003\213\003\213\003\213\005\014\0069\003\213\003\213\003\213\003\213\003\213\003\213\003\213\000\238\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\004\014\n\006\nn\r&\003\213\003\213\003\213\001\"\006\194\001\006\007\186\003\146\003\213\003\213\003\213\003\213\003\213\003\213\000\238\003\213\003\213\003\213\003\213\003\213\n\014\003\213\004\241\nv\003\213\000\238\003\213\003\213\002\214\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\r*\003\213\003\213\003\213\003\213\003\213\003\209\003\134\b6\003\150\b\142\003\209\003\209\003\209\003\209\r6\007\238\003\209\003\209\003\209\003\209\t\r\003\209\003\209\000\238\003\209\003\209\003\209\000\238\003\209\003\209\003\209\003\209\b\202\003\209\004N\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\005\166\003\209\016\226\003\209\007~\003\209\003\209\003\209\003\209\003\209\006\230\006\254\003\209\003\209\003\209\028g\003\209\012r\003\209\003\209\003\209\005r\024\154\003\209\003\209\003\209\003\209\003\209\003\209\003\209\bJ\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\007\202\n\006\nn\001\006\003\209\003\209\003\209\001\"\004\158\012b\001\142\015^\003\209\003\209\003\209\003\209\003\209\003\209\007\210\003\209\003\209\003\209\003\209\003\209\n\014\003\209\015n\nv\003\209\012j\003\209\003\209\016>\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\r\162\003\209\003\209\003\209\003\209\003\209\t\249\b\142\004>\004>\002^\t\249\t\249\t\249\t\249\r6\020\174\t\249\t\249\t\249\t\249\000\238\t\249\t\249\016F\t\249\t\249\t\249\b\006\t\249\t\249\t\249\t\249\006!\t\249\004j\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\005\166\t\249\b.\t\249\007~\t\249\t\249\t\249\t\249\t\249\0036\004\133\t\249\t\249\t\249\000\238\t\249\022Z\t\249\t\249\t\249\004V\004\142\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\206\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\004\234\t\249\t\249\004\218\t\249\t\249\t\249\007\006\025\022\015\166\000\238\003\197\t\249\t\249\t\249\t\249\t\249\t\249\018\218\t\249\t\249\t\249\t\249\t\249\t\249\t\249\020\178\t\249\t\249\015\178\t\249\t\249\004\133\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\000\238\n\t\t\249\t\249\t\249\t\249\n\t\n\t\n\t\n\t\018\226\006j\n\t\n\t\n\t\n\t\004N\n\t\n\t\006\025\n\t\n\t\n\t\004\133\n\t\n\t\n\t\n\t\005N\n\t\005*\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\006\229\n\t\003\197\n\t\023V\n\t\n\t\n\t\n\t\n\t\026v\t)\n\t\n\t\n\t\000\238\n\t\022n\n\t\n\t\n\t\004Z\006\238\n\t\n\t\n\t\n\t\n\t\n\t\n\t\0066\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n:\n\t\n\t\nB\n\t\n\t\n\t\001V\004>\005\217\000\238\023^\n\t\n\t\n\t\n\t\n\t\n\t\006N\n\t\n\t\n\t\n\t\n\t\n\t\n\t\006\138\n\t\n\t\001Z\n\t\n\t\t)\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\b\249\n\001\n\t\n\t\n\t\n\t\n\001\n\001\n\001\n\001\005\217\028G\n\001\n\001\n\001\n\001\007]\n\001\n\001\004J\n\001\n\001\n\001\t)\n\001\n\001\n\001\n\001\015b\n\001\005\217\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\006\190\n\001\000\238\n\001\004\237\n\001\n\001\n\001\n\001\n\001\n\170\007U\n\001\n\001\n\001\007U\n\001\022\130\n\001\n\001\n\001\001\006\007\254\n\001\n\001\n\001\n\001\n\001\n\001\n\001\006\162\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\004>\n\001\n\001\006\198\n\001\n\001\n\001\007%\006\218\b\249\007E\007\014\n\001\n\001\n\001\n\001\n\001\n\001\011\170\n\001\n\001\n\001\n\001\n\001\n\001\n\001\022\018\n\001\n\001\003\142\n\001\n\001\002^\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\005\134\t\237\n\001\n\001\n\001\n\001\t\237\t\237\t\237\t\237\000\238\b\022\t\237\t\237\t\237\t\237\002^\t\237\t\237\012\238\t\237\t\237\t\237\0079\t\237\t\237\t\237\t\237\007E\t\237\0036\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\n\186\t\237\b\206\t\237\t\242\t\237\t\237\t\237\t\237\t\237\000\238\025\154\t\237\t\237\t\237\006\181\t\237\022\154\t\237\t\237\t\237\0036\004\198\t\237\t\237\t\237\t\237\t\237\t\237\t\237\001\162\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\001f\t\237\t\237\028'\t\237\t\237\t\237\002*\011\170\018\186\026^\001f\t\237\t\237\t\237\t\237\t\237\t\237\012\246\t\237\t\237\t\237\t\237\t\237\t\237\t\237\n:\t\237\t\237\nB\t\237\t\237\002j\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\b\245\t\245\t\237\t\237\t\237\t\237\t\245\t\245\t\245\t\245\n2\nZ\t\245\t\245\t\245\t\245\n:\t\245\t\245\nB\t\245\t\245\t\245\012\014\t\245\t\245\t\245\t\245\000\238\t\245\012\238\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\004\157\t\245\000\238\t\245\006\234\t\245\t\245\t\245\t\245\t\245\r.\007E\t\245\t\245\t\245\007E\t\245\022\174\t\245\t\245\t\245\006J\011\190\t\245\t\245\t\245\t\245\t\245\t\245\t\245\b\026\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\006\250\t\245\t\245\rj\t\245\t\245\t\245\003\177\004\157\b\245\026\"\007:\t\245\t\245\t\245\t\245\t\245\t\245\002^\t\245\t\245\t\245\t\245\t\245\t\245\t\245\003\146\t\245\t\245\rZ\t\245\t\245\002j\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\b\206\t\241\t\245\t\245\t\245\t\245\t\241\t\241\t\241\t\241\002^\012\238\t\241\t\241\t\241\t\241\014\018\t\241\t\241\016B\t\241\t\241\t\241\r\174\t\241\t\241\t\241\t\241\006)\t\241\005%\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\016n\t\241\016J\t\241\007R\t\241\t\241\t\241\t\241\t\241\016.\007\138\t\241\t\241\t\241\014\214\t\241\022\194\t\241\t\241\t\241\016\014\bU\t\241\t\241\t\241\t\241\t\241\t\241\t\241\007\150\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\004>\t\241\t\241\t\017\t\241\t\241\t\241\006%\007\174\019\002\r\198\000\238\t\241\t\241\t\241\t\241\t\241\t\241\002=\t\241\t\241\t\241\t\241\t\241\t\241\t\241\n:\t\241\t\241\nB\t\241\t\241\016\006\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\000\238\t\253\t\241\t\241\t\241\t\241\t\253\t\253\t\253\t\253\000\238\027\222\t\253\t\253\t\253\t\253\b\130\t\253\t\253\018\222\t\253\t\253\t\253\003\014\t\253\t\253\t\253\t\253\012\213\t\253\tJ\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\014\182\t\253\016v\t\253\016\254\t\253\t\253\t\253\t\253\t\253\t\017\023\190\t\253\t\253\t\253\tQ\t\253\022\222\t\253\t\253\t\253\016\182\bE\t\253\t\253\t\253\t\253\t\253\t\253\t\253\n6\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\022\206\t\253\t\253\003\142\t\253\t\253\t\253\bQ\026Z\007e\018\230\nV\t\253\t\253\t\253\t\253\t\253\t\253\020\030\t\253\t\253\t\253\t\253\t\253\t\253\t\253\n:\t\253\t\253\nB\t\253\t\253\000\238\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\bJ\n\r\t\253\t\253\t\253\t\253\n\r\n\r\n\r\n\r\000\238\006\029\n\r\n\r\n\r\n\r\nb\n\r\n\r\019>\n\r\n\r\n\r\016\190\n\r\n\r\n\r\n\r\019\130\n\r\nr\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\020F\n\r\019\138\n\r\019\186\n\r\n\r\n\r\n\r\n\r\024\146\012\225\n\r\n\r\n\r\026j\n\r\022\242\n\r\n\r\n\r\020*\n\130\n\r\n\r\n\r\n\r\n\r\n\r\n\r\011b\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\012\230\n\r\n\r\r\002\n\r\n\r\n\r\bI\011\170\r\006\023\230\r2\n\r\n\r\n\r\n\r\n\r\n\r\020\146\n\r\n\r\n\r\n\r\n\r\n\r\n\r\012\238\n\r\n\r\024z\n\r\n\r\t9\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\bJ\n\005\n\r\n\r\n\r\n\r\n\005\n\005\n\005\n\005\b\202\011b\n\005\n\005\n\005\n\005\000\238\n\005\n\005\003\254\n\005\n\005\n\005\016\190\n\005\n\005\n\005\n\005\000\238\n\005\rN\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\rR\n\005\027B\n\005\t=\n\005\n\005\n\005\n\005\n\005\025.\rz\n\005\n\005\n\005\023\234\n\005\023\006\n\005\n\005\n\005\025:\025B\n\005\n\005\n\005\n\005\n\005\n\005\n\005\002^\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\r\142\n\005\n\005\000\238\n\005\n\005\n\005\006\134\r\206\r\222\014&\014r\n\005\n\005\n\005\n\005\n\005\n\005\004\157\n\005\n\005\n\005\n\005\n\005\n\005\n\005\014\146\n\005\n\005\014\178\n\005\n\005\026\238\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\014\250\nI\n\005\n\005\n\005\n\005\nI\nI\nI\nI\015v\015\142\nI\nI\nI\nI\012\014\nI\nI\016\022\nI\nI\nI\016\026\nI\nI\nI\nI\016R\nI\016V\nI\nI\nI\nI\nI\nI\nI\nI\016~\nI\016\130\nI\016\154\nI\nI\nI\nI\nI\017\018\017B\nI\nI\nI\017F\nI\023\018\nI\nI\nI\017j\017n\nI\nI\nI\nI\nI\nI\nI\017~\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\017\142\nI\nI\017\154\nI\nI\nI\017\206\017\210\018\"\018J\018N\nI\nI\nI\nI\nI\nI\018\146\nI\nI\nI\nI\nI\nI\nI\003\201\nI\nI\018\182\nI\nI\018\198\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\018\238\t\225\nI\nI\nI\nI\t\225\t\225\t\225\t\225\018\242\018\254\t\225\t\225\t\225\t\225\019\014\t\225\t\225\019&\t\225\t\225\t\225\000\238\t\225\t\225\t\225\t\225\0196\t\225\019J\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\019b\t\225\019\146\t\225\019\150\t\225\t\225\t\225\t\225\t\225\019\162\019\178\t\225\t\225\t\225\019\198\t\225\003\201\t\225\t\225\t\225\020\186\020\198\t\225\t\225\t\225\t\225\t\225\t\225\t\225\020\246\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\021\026\n\006\nn\004A\t\225\t\225\t\225\016j\021B\015\254\021\218\021\226\t\225\t\225\t\225\t\225\t\225\t\225\b\026\t\225\t\225\t\225\t\225\t\225\n\014\t\225\021\234\nv\t\225\021\254\t\225\t\225\016r\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\000\238\t\225\t\225\t\225\t\225\t\225\002M\022\n\bM\022\030\012\205\002M\001\002\001\006\002M\027\226\002j\001\"\002M\n.\002M\0226\001&\002M\012\205\002M\002M\002M\022B\002M\002M\002M\001*\004A\n^\022V\001.\002M\002M\002M\002M\002M\nf\002M\n\018\0012\022j\003z\022~\002M\002M\002M\002M\002M\022\150\022\170\003\206\002N\002M\023*\002M\0236\002M\002M\003F\022\190\022\218\003\214\002M\002M\002M\b\194\b\198\b\210\022\238\020R\005\150\002M\002M\002M\002M\002M\002M\002M\002M\002M\023\002\n\006\nn\023&\002M\002M\002M\0232\023>\023r\023\130\023\146\005\162\002M\005\166\002M\002M\002M\023\158\002M\002M\002M\002M\b\218\022J\b\222\023\206\022\138\002M\023\246\002M\002M\023\254\002M\002M\002M\002M\002M\002M\005\170\b\238\002M\002M\002M\t\146\004j\024\006\n5\002M\002M\002M\002M\n5\001\002\001\006\n5\024\014\024\"\001\"\n5\n5\n5\024*\001&\n5\0246\n5\n5\n5\024V\n5\n5\n5\001*\024n\n5\024\134\001.\n5\n5\n5\n5\n5\n5\n5\022\022\0012\024\162\003z\024\170\n5\n5\n5\n5\n5\024\218\024\250\003\206\002N\n5\022.\n5\022:\n5\n5\003F\025\018\025&\003\214\n5\n5\n5\b\194\b\198\b\210\025N\n5\005\150\n5\n5\n5\n5\n5\n5\n5\n5\n5\025n\n5\n5\025\162\n5\n5\n5\025\170\025\182\026\022\026F\026N\005\162\n5\005\166\n5\n5\n5\026\134\n5\n5\n5\n5\b\218\n5\b\222\026\158\n5\n5\026\246\n5\n5\027\n\n5\n5\n5\n5\n5\n5\005\170\b\238\n5\n5\n5\t\146\004j\027&\n1\n5\n5\n5\n5\n1\001\002\001\006\n1\027N\027V\001\"\n1\n1\n1\027~\001&\n1\027\134\n1\n1\n1\027\142\n1\n1\n1\001*\027\154\n1\027\162\001.\n1\n1\n1\n1\n1\n1\n1\022N\0012\027\171\003z\027\187\n1\n1\n1\n1\n1\027\206\027\234\003\206\002N\n1\022b\n1\022v\n1\n1\003F\028\007\028\023\003\214\n1\n1\n1\b\194\b\198\b\210\0283\n1\005\150\n1\n1\n1\n1\n1\n1\n1\n1\n1\028\135\n1\n1\028\163\n1\n1\n1\028\174\028\227\028\247\028\255\029;\005\162\n1\005\166\n1\n1\n1\029C\n1\n1\n1\n1\b\218\n1\b\222\000\000\n1\n1\000\000\n1\n1\000\000\n1\n1\n1\n1\n1\n1\005\170\b\238\n1\n1\n1\t\146\004j\000\000\002\133\n1\n1\n1\n1\002\133\001\002\001\006\002\133\000\000\000\000\001\"\002\133\n.\002\133\004\133\001&\002\133\000\000\002\133\002\133\002\133\000\000\002\133\002\133\002\133\001*\004\133\n^\000\000\001.\002\133\002\133\002\133\002\133\002\133\nf\002\133\022\210\0012\000\000\003z\005\026\002\133\002\133\002\133\002\133\002\133\000\000\000\000\003\206\002N\002\133\022\230\002\133\022\250\002\133\002\133\003F\000\238\000\000\003\214\002\133\002\133\002\133\b\194\b\198\b\210\000\238\020R\005\150\002\133\002\133\002\133\002\133\002\133\002\133\002\133\002\133\002\133\000\000\004\133\002\133\000\000\002\133\002\133\002\133\019~\004\133\000\000\004\133\000\000\005\162\002\133\005\166\002\133\002\133\002\133\000\000\002\133\002\133\002\133\002\133\b\218\000\000\b\222\004\133\000\000\002\133\000\000\002\133\002\133\019\134\002\133\002\133\002\133\002\133\002\133\002\133\005\170\b\238\002\133\002\133\002\133\t\146\004j\004\133\004\133\002\133\002\133\002\133\002\133\004\133\004\133\bE\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\000\000\004\133\000\238\004\133\004\133\004\133\004\133\004\133\004\133\025\194\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\000\000\004\133\004\133\000\238\000\238\004\133\004\133\000\000\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\006\146\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\000\238\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\020\018\004\133\000\000\004\133\004\133\004\133\004\133\004\133\004\133\000\238\004\133\000\n\004\133\004\133\004\133\004\133\004\133\004\133\004\133\000\000\004\133\004\133\004\133\000\000\000\238\004\133\004\133\002\029\002\029\004\133\000\238\004\133\004\133\000\000\004\133\004\133\000\000\004\133\r&\011b\025\198\002\029\001\"\025\210\004\133\004\133\004\133\000\000\000\238\004\133\004\133\004\133\004\133\000\129\000\129\004\133\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\000\000\129\000\000\000\129\000\129\019\230\000\129\000\129\000\000\006Z\000\129\000\129\006\006\000\129\000\129\000\129\000\129\r*\000\129\006n\000\129\000\129\000\000\006v\000\129\000\129\018\170\000\129\000\129\000\129\007\186\000\129\r6\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\003\146\019\026\000\129\000\129\000\000\001\006\000\129\000\129\br\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\005\166\002\029\000\129\000\000\tU\000\129\000\000\000\129\000\000\000\129\000\000\000\000\000\000\b6\000\129\000\129\000\129\000\129\000\129\000\129\007=\000\129\000\129\000\129\007=\t\174\002N\000\129\000\n\014B\000\129\003\134\000\129\000\238\000\222\000\000\023v\000\000\000\129\000\000\023\134\023\150\023\162\000\000\000\129\000\129\000\129\000\129\b\142\002}\000\129\000\129\000\129\000\129\002}\001\002\001\006\002}\002\029\000\000\001\"\002}\000\238\002}\000\000\001&\002}\000\000\002}\002}\002}\000\000\002}\002}\002}\001*\000\000\024\190\000\000\001.\002}\002}\002}\002}\002}\000\000\002}\000\000\0012\000\000\003z\000\000\002}\002}\002}\002}\002}\007=\000\000\003\206\b\214\002}\000\000\002}\000\000\002}\002}\003F\000\000\000\000\003\214\002}\002}\002}\b\194\b\198\b\210\004\022\015\018\005\150\002}\002}\002}\002}\002}\002}\002}\002}\002}\000\000\n\006\nn\000\000\002}\002}\002}\000\000\000\000\000\000\004=\000\000\005\162\002}\005\166\002}\002}\002}\000\000\002}\002}\002}\002}\b\218\n\014\b\222\000\000\nv\002}\000\000\002}\002}\001\006\002}\002}\002}\002}\002}\002}\005\170\b\238\002}\002}\002}\t\146\004j\000\000\002\145\002}\002}\002}\002}\002\145\000\238\025\134\002\145\000\000\000\000\000\000\002\145\000\000\002\145\000\000\000\000\002\145\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\000\000\000\000\001\186\002N\000\000\002\145\002\145\002\145\002\145\002\145\b\142\002\145\000\000\004=\000\000\028\147\000\000\002\145\002\145\002\145\002\145\002\145\000\000\000\000\000\238\000\000\002\145\000\000\002\145\006Z\002\145\002\145\006\006\007*\000\000\000\000\002\145\002\145\002\145\006n\r&\000\000\000\000\006v\001\"\002\145\002\145\002\145\002\145\002\145\002\145\002\145\002\145\002\145\000\000\n\006\nn\000\000\002\145\002\145\002\145\000\000\014f\000\000\000\000\000\000\002\029\002\145\003\146\002\145\002\145\002\145\000\000\002\145\002\145\002\145\002\145\025\138\n\014\000\000\000\000\nv\002\145\r*\002\145\002\145\007\186\002\145\002\145\002\145\002\145\002\145\002\145\000\n\000\000\002\145\002\145\002\145\r6\000\000\014\138\002\141\002\145\002\145\002\145\002\145\002\141\bz\003\146\002\141\002\029\001\186\002N\002\141\000\000\002\141\005M\000\000\002\141\000\000\002\141\002\141\002\141\002\029\002\141\002\141\002\141\005\166\000\000\005M\b6\000\000\002\141\002\141\002\141\002\141\002\141\000\000\002\141\014\150\007\186\000\000\000\000\000\000\002\141\002\141\002\141\002\141\002\141\007\186\000\238\005\222\000\000\002\141\000\000\002\141\014.\002\141\002\141\000\000\005M\b\166\003\246\002\141\002\141\002\141\006\150\r&\004\002\000\000\t\214\001\"\002\141\002\141\002\141\002\141\002\141\002\141\002\141\002\141\002\141\000\000\n\006\nn\b6\002\141\002\141\002\141\000\000\000\000\000\000\005M\000\000\b6\002\141\005M\002\141\002\141\002\141\000\000\002\141\002\141\002\141\002\141\000\238\n\014\000\000\000\000\nv\002\141\r*\002\141\002\141\000\238\002\141\002\141\002\141\002\141\002\141\002\141\000\000\000\000\002\141\002\141\002\141\r6\003B\014j\002\129\002\141\002\141\002\141\002\141\002\129\000\000\003\146\002\129\000\000\000\000\028w\002\129\000\000\002\129\000\000\000\000\002\129\000\000\002\129\002\129\002\129\000\000\002\129\002\129\002\129\005\166\000\000\000\000\000\000\000\000\002\129\002\129\002\129\002\129\002\129\000\000\002\129\014v\007\186\000\000\000\000\000\000\002\129\002\129\002\129\002\129\002\129\007\186\000\000\t\174\023\218\002\129\000\000\002\129\014.\002\129\002\129\000\000\000\000\025\146\023v\002\129\002\129\002\129\023\134\023\150\023\162\000\000\025\206\000\000\002\129\002\129\002\129\002\129\002\129\002\129\002\129\002\129\002\129\000\000\n\006\nn\b6\002\129\002\129\002\129\000\000\000\000\000\000\006V\000\000\b6\002\129\000\000\002\129\002\129\002\129\000\000\002\129\002\129\002\129\002\129\000\238\n\014\007\186\000\000\nv\002\129\000\000\002\129\002\129\000\238\002\129\002\129\002\129\002\129\002\129\002\129\000\000\bE\002\129\002\129\002\129\bE\000\000\025\218\002E\002\129\002\129\002\129\002\129\002E\000\238\000\000\002E\000\000\000\000\000\000\002E\000\000\002E\014\182\000\000\002E\000\000\002E\002E\002E\b6\002E\002E\002E\012E\012E\000\000\000\000\012E\002E\002E\002E\002E\002E\bE\002E\000\000\t\142\000\000\000\000\000\238\002E\002E\002E\002E\002E\000\000\000\000\000\000\bE\002E\000\000\002E\006Z\002E\002E\006\006\006b\000\000\0276\002E\002E\002E\006n\000\000\012u\000\000\006v\000\238\002E\002E\002E\002E\002E\002E\002E\002E\002E\bE\000\000\002E\000\000\002E\002E\002E\000\000\012u\000\000\000\000\002\194\025\222\002E\002\198\002E\002E\002E\000\000\002E\002E\002E\002E\012E\000\238\000\000\000\000\002\210\002E\bE\002E\002E\000\000\002\025\002E\002E\002E\002E\002E\tz\nJ\002E\002E\t^\007\186\000\000\023\170\002\025\002E\002E\002E\002E\002\025\000\000\004N\002\025\002\222\024\018\000\000\002\025\000\000\002\025\000\000\000\000\002\025\025\230\002\025\002\025\002\025\000\000\002\025\002\025\002\025\006Z\000\000\000\000\006\006\027:\002\025\002\025\002\025\002\025\002\025\006n\002\025\000\000\000\000\006v\b6\000\000\002\025\002\025\002\025\002\025\002\025\000\000\r&\004\146\004Z\002\025\001\"\002\025\000\000\002\025\002\025\002\226\004\026\004&\000\238\002\025\002\025\002\025\0042\000\000\000\000\000\000\000\000\000\000\002\025\002\025\002\025\002\025\002\025\002\025\002\025\002\025\002\025\n\006\nn\002\025\000\000\002\025\002\025\002\025\022&\t-\000\000\t-\t-\r*\002\025\000\000\002\025\002\025\002\025\000\000\002\025\002\025\002\025\002\025\n\014\007\229\007\186\nv\r6\002\025\000\000\002\025\002\025\000\000\002\025\002\025\002\025\002\025\002\025\002\025\000\000\000\000\002\025\002\025\t^\000\000\000\000\027\022\002\137\002\025\002\025\002\025\002\025\002\137\n\149\000\000\002\137\005\166\007\229\000\000\002\137\000\000\002\137\000\000\000\000\002\137\000\000\002\137\002\137\002\137\b6\002\137\002\137\002\137\007\229\000\000\000\000\007\229\t\234\002\137\002\137\002\137\002\137\002\137\007\229\002\137\026\166\n\149\007\229\000\000\000\238\002\137\002\137\002\137\002\137\002\137\000\000\b\225\000\000\000\000\002\137\011b\002\137\n\149\002\137\002\137\n\149\011\182\007\186\t-\002\137\002\137\002\137\n\149\000\000\000\000\000\000\n\149\000\000\002\137\002\137\002\137\002\137\002\137\002\137\002\137\002\137\002\137\000\000\027.\002\137\000\000\002\137\002\137\002\137\000\000\000\000\001&\b\225\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\b6\000\000\001F\002\029\002\137\000\000\002\137\002\137\b\225\n\138\002\137\002\137\002\137\002\137\002\137\001R\000\000\002\137\002\137\002\137\000\238\b\245\000\000\0035\002\137\002\137\002\137\002\137\0035\000\000\000\000\0035\000\000\000\n\000\000\0035\000\000\0035\000\000\005\150\n\202\000\000\0035\011\146\0035\b\225\0035\0035\0035\004\230\002\029\000\000\b\225\000\000\n\210\n\234\n\242\n\250\011\002\002^\0035\005\162\000\238\002\029\002\029\000\000\0035\0035\011\n\011\018\0035\000\000\b\221\000\000\000\000\0035\000\000\0035\001*\011\026\0035\000\000\000\000\000\000\000\000\0035\0035\000\238\005\170\000\000\000\000\016\030\000\000\000\000\0035\0035\011\"\011*\0112\011:\011B\0035\0035\0036\000\000\0035\016\150\0035\0035\011J\003F\b\245\000\000\b\221\000\000\000\000\0035\016\174\0035\0035\011R\t)\0035\0035\0035\0035\000\000\000\000\000\000\000\000\000\000\0035\000\000\0035\0035\b\221\0035\0035\011Z\011j\0035\0035\000\000\007e\0035\011r\0035\007e\000\000\000\000\002\021\0035\0035\011z\011\130\002\021\000\238\000\000\002\021\000\000\000\000\000\000\002\021\000\000\002\021\000\000\000\000\n\202\000\000\002\021\002\021\002\021\b\221\002\021\002\021\002\021\004\230\000\000\000\000\b\221\000\000\n\210\n\234\n\242\n\250\011\002\000\000\002\021\000\000\011\202\000\000\000\000\000\000\002\021\002\021\011\n\011\018\002\021\000\000\000\000\000\000\000\000\002\021\000\000\002\021\011\210\011\026\002\021\011\218\000\000\000\000\000\000\002\021\002\021\000\238\011\226\000\000\000\000\000\000\011\234\007e\002\021\002\021\011\"\011*\0112\011:\011B\002\021\002\021\000\000\000\000\002\021\000\000\002\021\002\021\011J\n:\000\000\000\000\nB\000\000\000\000\002\021\000\000\002\021\002\021\011R\000\000\002\021\002\021\002\021\002\021\000\000\000\238\000\000\000\000\000\000\002\021\000\000\002\021\002\021\000\000\002\021\002\021\011Z\011j\002\021\002\021\000\000\000\000\002\021\011r\002\021\000\000\000\000\000\000\002\225\002\021\002\021\011z\011\130\002\225\007\249\000\000\002\225\000\000\007\225\000\000\002\225\000\000\002\225\002^\000\000\002\225\000\000\002\225\002\225\002\225\000\000\002\225\002\225\002\225\007\225\000\000\0266\006\006\000\000\002\225\002\225\002\225\002\225\002\225\007\225\002\225\000\000\007\249\007\225\000\000\000\000\002\225\002\225\002\225\002\225\002\225\000\000\000\000\000\000\000\000\002\225\000\000\002\225\007\249\002\225\002\225\006\006\0036\000\000\000\000\002\225\002\225\002\225\007\249\000\000\000\000\000\000\007\249\000\000\002\225\002\225\002\225\002\225\002\225\002\225\002\225\002\225\002\225\000\000\000\000\002\225\000\000\002\225\002\225\002\225\000\000\000\000\000\000\004\198\000\000\000\000\002\225\005)\002\225\002\225\002\225\000\000\002\225\002\225\002\225\002\225\000\000\000\238\000\000\000\000\000\000\002\225\000\000\002\225\002\225\000\000\011b\002\225\002\225\002\225\002\225\002\225\000\000\000\000\002\225\002\225\002\225\000\000\000\000\000\000\003\r\002\225\002\225\002\225\002\225\003\r\b\t\000\000\003\r\000\000\b\r\000\000\003\r\000\000\003\r\000\000\000\000\003\r\000\000\003\r\003\r\003\r\000\000\003\r\003\r\003\r\006Z\000\000\000\000\006\006\000\000\003\r\003\r\003\r\003\r\003\r\b\r\003\r\000\000\b\t\b\r\000\000\000\000\003\r\003\r\003\r\003\r\003\r\000\000\000\000\000\000\000\000\003\r\000\000\003\r\011\254\003\r\003\r\b\t\000\000\000\000\000\000\003\r\003\r\003\r\b\t\000\000\000\000\000\000\b\t\000\000\003\r\003\r\003\r\003\r\003\r\003\r\003\r\003\r\003\r\000\000\000\000\003\r\000\000\003\r\003\r\003\r\000\000\000\000\000\000\000\000\000\000\000\000\003\r\000\000\003\r\003\r\003\r\000\000\003\r\003\r\003\r\003\r\000\000\000\238\000\000\000\000\000\000\003\r\000\000\003\r\003\r\000\000\011b\003\r\003\r\003\r\003\r\003\r\000\000\000\000\003\r\003\r\003\r\000\000\000\000\000\000\003\029\003\r\003\r\003\r\003\r\003\029\000\238\000\000\003\029\000\000\007\221\000\000\003\029\000\000\003\029\000\000\000\000\003\029\000\000\003\029\003\029\003\029\000\000\003\029\003\029\003\029\007\221\000\000\000\000\006\006\000\000\003\029\003\029\003\029\003\029\003\029\007\221\003\029\000\000\023J\007\221\000\000\000\000\003\029\003\029\003\029\003\029\003\029\000\000\000\000\000\000\000\000\003\029\000\000\003\029\011\210\003\029\003\029\011\218\000\000\000\000\000\000\003\029\003\029\003\029\011\226\000\000\000\000\000\000\011\234\000\000\003\029\003\029\003\029\003\029\003\029\003\029\003\029\003\029\003\029\000\000\000\000\003\029\000\000\003\029\003\029\003\029\000\000\000\000\000\000\000\000\000\000\000\000\003\029\000\000\003\029\003\029\003\029\000\000\003\029\003\029\003\029\003\029\007I\000\000\012M\012M\007I\003\029\012M\003\029\003\029\000\000\011b\003\029\003\029\003\029\003\029\003\029\000\000\000\000\003\029\003\029\003\029\000\000\000\000\000\000\003\021\003\029\003\029\003\029\003\029\003\021\002\029\001\162\003\021\000\000\015\242\001\"\003\021\000\000\003\021\000\000\000\000\003\021\000\000\003\021\003\021\003\021\000\238\003\021\003\021\003\021\012I\012I\000\000\000\000\012I\003\021\003\021\003\021\003\021\003\021\000\n\003\021\000\000\000\000\007I\000\000\000\000\003\021\003\021\003\021\003\021\003\021\000\000\000\000\027\198\002j\003\021\002\029\003\021\012M\003\021\003\021\000\000\000\000\000\000\000\000\003\021\003\021\003\021\r6\002\029\002\029\000\000\011b\000\238\003\021\003\021\003\021\003\021\003\021\003\021\003\021\003\021\003\021\000\000\000\000\003\021\000\000\003\021\003\021\003\021\000\000\000\000\000\000\000\000\000\000\000\000\003\021\005\166\003\021\003\021\003\021\000\000\003\021\003\021\003\021\003\021\012I\000\000\007A\000\000\000\000\003\021\007A\003\021\003\021\000\000\011b\003\021\003\021\003\021\003\021\003\021\000\000\000\000\003\021\003\021\003\021\000\000\000\000\000\000\003\001\003\021\003\021\003\021\003\021\003\001\000\000\001\006\003\001\000\000\000\000\000\000\003\001\000\000\003\001\000\000\000\000\003\001\000\000\003\001\003\001\003\001\000\238\003\001\003\001\003\001\b9\000\000\000\000\000\000\b9\003\001\003\001\003\001\003\001\003\001\000\000\003\001\000\000\000\000\000\000\000\000\000\000\003\001\003\001\003\001\003\001\003\001\000\000\000\000\nz\003\134\003\001\000\000\003\001\007A\003\001\003\001\000\000\000\000\000\000\000\000\003\001\003\001\003\001\021\246\000\000\022\002\000\000\000\000\b9\003\001\003\001\003\001\003\001\003\001\003\001\003\001\003\001\003\001\000\000\000\000\003\001\000\000\003\001\003\001\003\001\000\000\000\000\000\000\b5\000\000\b9\003\001\b5\003\001\003\001\003\001\000\000\003\001\003\001\003\001\003\001\000\000\000\000\000\000\000\000\000\000\003\001\000\000\003\001\003\001\000\000\011b\003\001\003\001\003\001\003\001\003\001\000\000\000\000\003\001\003\001\003\001\000\000\000\000\000\000\003\t\003\001\003\001\003\001\003\001\003\t\004\230\b5\003\t\000\000\000\000\000\000\003\t\000\000\003\t\000\000\000\000\003\t\000\000\003\t\003\t\003\t\000\000\003\t\003\t\003\t\000\000\000\000\000\000\b5\000\000\003\t\003\t\003\t\003\t\003\t\000\000\003\t\000\000\000\000\000\000\000\000\000\000\003\t\003\t\003\t\003\t\003\t\000\000\000\000\000\000\000\000\003\t\000\000\003\t\000\000\003\t\003\t\000\000\000\000\000\000\000\000\003\t\003\t\003\t\000\000\000\000\000\000\000\000\000\000\004\230\003\t\003\t\003\t\003\t\003\t\003\t\003\t\003\t\003\t\000\000\000\000\003\t\000\000\003\t\003\t\003\t\000\000\000\000\000\000\000\000\000\000\000\000\003\t\000\000\003\t\003\t\003\t\000\000\003\t\003\t\003\t\003\t\000\000\000\000\000\000\000\000\000\000\003\t\000\000\003\t\003\t\000\000\011b\003\t\003\t\003\t\003\t\003\t\000\000\000\000\003\t\003\t\003\t\000\000\000\000\000\000\003\005\003\t\003\t\003\t\003\t\003\005\000\000\001\006\003\005\000\000\000\000\000\000\003\005\000\000\003\005\000\000\000\000\003\005\000\000\003\005\003\005\003\005\000\000\003\005\003\005\003\005\000\000\000\000\000\000\000\000\000\000\003\005\003\005\003\005\003\005\003\005\000\000\003\005\000\000\000\000\000\000\000\000\000\000\003\005\003\005\003\005\003\005\003\005\000\000\000\000\022\142\003\134\003\005\000\000\003\005\000\000\003\005\003\005\000\000\000\000\000\000\000\000\003\005\003\005\003\005\022\162\000\000\022\182\000\000\000\000\000\000\003\005\003\005\003\005\003\005\003\005\003\005\003\005\003\005\003\005\000\000\000\000\003\005\000\000\003\005\003\005\003\005\000\000\000\000\000\000\000\000\000\000\000\000\003\005\000\000\003\005\003\005\003\005\000\000\003\005\003\005\003\005\003\005\000\000\000\000\000\000\000\000\000\000\003\005\000\000\003\005\003\005\000\000\011b\003\005\003\005\003\005\003\005\003\005\000\000\000\000\003\005\003\005\003\005\000\000\000\000\000\000\003\017\003\005\003\005\003\005\003\005\003\017\000\000\000\000\003\017\000\000\000\000\000\000\003\017\000\000\003\017\000\000\000\000\003\017\000\000\003\017\003\017\003\017\000\000\003\017\003\017\003\017\000\000\000\000\000\000\000\000\000\000\003\017\003\017\003\017\003\017\003\017\000\000\003\017\000\000\000\000\000\000\000\000\000\000\003\017\003\017\003\017\003\017\003\017\000\000\000\000\000\000\000\000\003\017\000\000\003\017\000\000\003\017\003\017\000\000\000\000\000\000\000\000\003\017\003\017\003\017\000\000\000\000\000\000\000\000\000\000\000\000\003\017\003\017\003\017\003\017\003\017\003\017\003\017\003\017\003\017\000\000\000\000\003\017\000\000\003\017\003\017\003\017\000\000\000\000\000\000\000\000\000\000\000\000\003\017\000\000\003\017\003\017\003\017\000\000\003\017\003\017\003\017\003\017\000\000\000\000\000\000\000\000\000\000\003\017\000\000\003\017\003\017\000\000\011b\003\017\003\017\003\017\003\017\003\017\000\000\000\000\003\017\003\017\003\017\000\000\000\000\000\000\003!\003\017\003\017\003\017\003\017\003!\000\000\000\000\003!\000\000\000\000\000\000\003!\000\000\003!\000\000\000\000\003!\000\000\003!\003!\003!\000\000\003!\003!\003!\000\000\000\000\000\000\000\000\000\000\003!\003!\003!\003!\003!\000\000\003!\000\000\000\000\000\000\000\000\000\000\003!\003!\003!\003!\003!\000\000\000\000\000\000\000\000\003!\000\000\003!\000\000\003!\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!\003!\003!\003!\003!\003!\003!\003!\000\000\000\000\003!\000\000\003!\003!\003!\000\000\000\000\000\000\000\000\000\000\000\000\003!\000\000\003!\003!\003!\000\000\003!\003!\003!\003!\000\000\000\000\000\000\000\000\000\000\003!\000\000\003!\003!\000\000\011b\003!\003!\003!\003!\003!\000\000\000\000\003!\003!\003!\000\000\000\000\000\000\003\025\003!\003!\003!\003!\003\025\000\000\000\000\003\025\000\000\000\000\000\000\003\025\000\000\003\025\000\000\000\000\003\025\000\000\003\025\003\025\003\025\000\000\003\025\003\025\003\025\000\000\000\000\000\000\000\000\000\000\003\025\003\025\003\025\003\025\003\025\000\000\003\025\000\000\000\000\000\000\000\000\000\000\003\025\003\025\003\025\003\025\003\025\000\000\000\000\000\000\000\000\003\025\000\000\003\025\000\000\003\025\003\025\000\000\000\000\000\000\000\000\003\025\003\025\003\025\000\000\000\000\000\000\000\000\000\000\000\000\003\025\003\025\003\025\003\025\003\025\003\025\003\025\003\025\003\025\000\000\000\000\003\025\000\000\003\025\003\025\003\025\000\000\000\000\000\000\000\000\000\000\000\000\003\025\000\000\003\025\003\025\003\025\000\000\003\025\003\025\003\025\003\025\000\000\000\000\000\000\000\000\000\000\003\025\000\000\003\025\003\025\000\000\011b\003\025\003\025\003\025\003\025\003\025\000\000\000\000\003\025\003\025\003\025\000\000\000\000\000\000\002\253\003\025\003\025\003\025\003\025\002\253\000\000\000\000\002\253\000\000\000\000\000\000\002\253\000\000\002\253\000\000\000\000\002\253\000\000\002\253\002\253\002\253\000\000\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\002\253\002\253\002\253\002\253\002\253\000\000\002\253\000\000\000\000\000\000\000\000\000\000\002\253\002\253\002\253\002\253\002\253\000\000\000\000\000\000\000\000\002\253\000\000\002\253\000\000\002\253\002\253\000\000\000\000\000\000\000\000\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\000\000\002\253\002\253\002\253\002\253\002\253\002\253\002\253\002\253\002\253\000\000\000\000\002\253\000\000\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\000\000\002\253\000\000\002\253\002\253\002\253\000\000\002\253\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\002\253\000\000\002\253\002\253\000\000\011b\002\253\002\253\002\253\002\253\002\253\000\000\000\000\002\253\002\253\002\253\000\000\000\000\000\000\ta\002\253\002\253\002\253\002\253\ta\000\000\000\000\ta\000\000\000\000\000\000\ta\000\000\ta\000\000\000\000\ta\000\000\ta\ta\ta\000\000\ta\ta\ta\000\000\000\000\000\000\000\000\000\000\ta\ta\ta\ta\ta\000\000\ta\000\000\000\000\000\000\000\000\000\000\ta\ta\ta\ta\ta\000\000\000\000\000\000\000\000\ta\000\000\ta\000\000\ta\ta\000\000\000\000\000\000\000\000\ta\ta\ta\000\000\000\000\000\000\000\000\000\000\000\000\ta\ta\ta\ta\ta\ta\ta\ta\ta\000\000\000\000\ta\000\000\ta\ta\ta\000\000\000\000\000\000\000\000\000\000\000\000\ta\000\000\ta\ta\ta\000\000\ta\ta\ta\ta\000\000\000\000\000\000\000\000\000\000\ta\000\000\ta\ta\000\000\ta\ta\ta\ta\ta\ta\000\000\000\000\ta\ta\t^\000\000\000\000\000\000\002q\ta\ta\ta\ta\002q\000\000\000\000\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\000\000\000\000\000\000\002q\002q\002q\002q\002q\000\000\002q\000\000\000\000\000\000\000\000\000\000\002q\002q\002q\002q\002q\000\000\000\000\000\000\000\000\002q\000\000\002q\000\000\002q\002q\000\000\000\000\000\000\000\000\002q\002q\002q\000\000\000\000\000\000\000\000\000\000\000\000\002q\002q\002q\002q\002q\002q\002q\002q\002q\000\000\000\000\002q\000\000\002q\002q\002q\000\000\000\000\000\000\000\000\000\000\000\000\002q\000\000\002q\002q\002q\000\000\002q\002q\024^\002q\000\000\000\000\000\000\000\000\000\000\002q\000\000\002q\002q\000\000\011b\002q\002q\002q\002q\002q\000\000\000\000\002q\002q\002q\000\000\000\000\000\000\002m\002q\002q\002q\002q\002m\000\000\000\000\002m\000\000\000\000\000\000\002m\000\000\002m\000\000\000\000\002m\000\000\002m\002m\002m\000\000\002m\002m\002m\000\000\000\000\000\000\000\000\000\000\002m\002m\002m\002m\002m\000\000\002m\000\000\000\000\000\000\000\000\000\000\002m\002m\002m\002m\002m\000\000\000\000\000\000\000\000\002m\000\000\002m\000\000\002m\002m\000\000\000\000\000\000\000\000\002m\002m\002m\000\000\000\000\000\000\000\000\000\000\000\000\002m\002m\002m\002m\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\000\000\000\000\000\000\000\002m\000\000\002m\002m\000\000\011b\002m\002m\002m\002m\002m\000\000\000\000\002m\002m\002m\000\000\000\000\000\000\002\249\002m\002m\002m\002m\002\249\000\000\000\000\002\249\000\000\000\000\000\000\002\249\000\000\002\249\000\000\000\000\002\249\000\000\002\249\002\249\002\249\000\000\002\249\002\249\002\249\000\000\000\000\000\000\000\000\000\000\002\249\002\249\002\249\002\249\002\249\000\000\002\249\000\000\000\000\000\000\000\000\000\000\002\249\002\249\002\249\002\249\002\249\000\000\000\000\000\000\000\000\002\249\000\000\002\249\000\000\002\249\002\249\000\000\000\000\000\000\000\000\002\249\002\249\002\249\000\000\000\000\000\000\000\000\000\000\000\000\002\249\002\249\002\249\002\249\002\249\002\249\002\249\002\249\002\249\000\000\000\000\002\249\000\000\002\249\002\249\002\249\000\000\000\000\000\000\000\000\000\000\000\000\002\249\000\000\002\249\002\249\002\249\000\000\002\249\002\249\002\249\002\249\000\000\000\000\000\000\000\000\000\000\002\249\000\000\002\249\002\249\000\000\011b\002\249\002\249\002\249\002\249\002\249\000\000\000\000\002\249\002\249\002\249\000\000\000\000\000\000\002e\002\249\002\249\002\249\002\249\002e\000\000\000\000\002e\000\000\000\000\000\000\002e\000\000\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\002e\002e\002e\002e\002e\000\000\002e\000\000\000\000\000\000\000\000\000\000\002e\002e\002e\002e\002e\000\000\000\000\000\000\000\000\002e\000\000\002e\000\000\002e\002e\000\000\000\000\000\000\000\000\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\000\000\002e\002e\002e\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\002e\000\000\002e\002e\000\000\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\002e\t^\000\000\000\000\000\000\001\245\002e\002e\002e\002e\001\245\000\000\000\000\001\245\000\000\000\000\000\000\001\245\000\000\001\245\000\000\000\000\001\245\000\000\001\245\001\245\001\245\000\000\001\245\001\245\001\245\000\000\000\000\000\000\000\000\000\000\001\245\001\245\001\245\001\245\001\245\000\000\001\245\000\000\000\000\000\000\000\000\000\000\001\245\001\245\001\245\001\245\001\245\000\000\000\000\000\000\000\000\001\245\000\000\001\245\000\000\001\245\001\245\000\000\000\000\000\000\000\000\001\245\001\245\001\245\000\000\000\000\000\000\000\000\000\000\000\000\001\245\001\245\001\245\001\245\001\245\001\245\001\245\001\245\001\245\000\000\000\000\001\245\000\000\001\245\001\245\001\245\000\000\000\000\000\000\000\000\000\000\000\000\001\245\000\000\001\245\001\245\001\245\000\000\001\245\001\245\001\245\001\245\000\000\000\000\000\000\000\000\000\000\001\245\000\000\001\245\001\245\000\000\001\245\001\245\001\245\001\245\001\245\001\245\000\000\000\000\001\245\001\245\t^\000\000\000\000\000\000\002i\001\245\001\245\001\245\001\245\002i\000\000\000\000\002i\000\000\000\000\000\000\002i\000\000\002i\000\000\000\000\002i\000\000\002i\002i\002i\000\000\002i\002i\002i\000\000\000\000\000\000\000\000\000\000\002i\002i\002i\002i\002i\000\000\002i\000\000\000\000\000\000\000\000\000\000\002i\002i\002i\002i\002i\000\000\000\000\000\000\000\000\002i\000\000\002i\000\000\002i\002i\000\000\000\000\000\000\000\000\002i\002i\002i\000\000\000\000\000\000\000\000\000\000\000\000\002i\002i\002i\002i\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\t^\000\000\000\000\000\000\027b\002i\002i\002i\002i\001\249\000\000\000\000\001\249\000\000\000\000\000\000\001\249\000\000\001\249\000\000\000\000\001\249\000\000\001\249\001\249\001\249\000\000\001\249\001\249\001\249\000\000\000\000\000\000\000\000\000\000\001\249\001\249\001\249\001\249\001\249\000\000\001\249\000\000\000\000\000\000\000\000\000\000\001\249\001\249\001\249\001\249\001\249\000\000\000\000\000\000\000\000\001\249\000\000\001\249\000\000\001\249\001\249\000\000\000\000\000\000\000\000\001\249\001\249\001\249\000\000\000\000\000\000\000\000\000\000\000\000\001\249\001\249\001\249\001\249\001\249\001\249\001\249\001\249\001\249\000\000\000\000\001\249\000\000\001\249\001\249\001\249\000\000\000\000\000\000\000\000\000\000\000\000\027r\000\000\001\249\001\249\001\249\000\000\001\249\001\249\001\249\001\249\000\000\000\000\000\000\000\000\000\000\001\249\000\000\001\249\001\249\000\000\001\249\001\249\001\249\001\249\001\249\001\249\000\000\000\000\001\249\001\249\001\249\000\000\000\000\000\000\001\253\001\249\001\249\001\249\001\249\001\253\000\000\000\000\001\253\000\000\000\000\000\000\001\253\000\000\001\253\000\000\000\000\001\253\000\000\001\253\001\253\001\253\000\000\001\253\001\253\001\253\000\000\000\000\000\000\000\000\000\000\001\253\001\253\001\253\001\253\001\253\000\000\001\253\000\000\000\000\000\000\000\000\000\000\001\253\001\253\001\253\001\253\001\253\000\000\000\000\000\000\000\000\001\253\000\000\001\253\000\000\001\253\001\253\000\000\000\000\000\000\000\000\001\253\001\253\001\253\000\000\000\000\000\000\000\000\000\000\000\000\001\253\001\253\001\253\001\253\001\253\001\253\001\253\001\253\001\253\000\000\000\000\001\253\000\000\001\253\001\253\001\253\000\000\000\000\000\000\000\000\000\000\000\000\027j\000\000\001\253\001\253\001\253\000\000\001\253\001\253\001\253\001\253\000\000\000\000\000\000\000\000\000\000\001\253\000\000\001\253\001\253\000\000\001\253\001\253\001\253\001\253\001\253\001\253\000\000\000\000\001\253\001\253\t^\000\000\000\000\000\000\000\000\001\253\001\253\001\253\001\253\000\006\000\246\000\000\000\000\007-\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\007-\001*\000\000\000\000\000\000\003\210\001n\t\182\t\186\001z\001~\000\000\000\000\000\000\0012\000\000\003z\000\000\025v\000\000\t\218\t\222\007-\003\182\003\194\003\206\003\218\003\226\t\226\007b\000\000\001\206\007-\003F\000\000\000\000\003\214\007-\007-\000\238\b\194\b\198\b\210\b\226\000\000\005\150\007-\007-\001\210\001\214\001\218\001\222\001\226\000\000\000\000\b\250\001\230\000\000\000\000\000\000\000\000\001\234\000\000\t\006\t\030\tj\t~\005\162\000\000\005\166\000\000\000\000\001\238\000\000\000\000\007-\000\000\000\000\b\218\001\242\b\222\000\000\000\000\000\000\000\000\000\000\007-\000\000\000\000\000\000\002.\006J\000\000\000\000\005\170\b\238\000\000\0022\000\000\023j\004j\t\246\020\194\002:\000\000\002>\002B\000\006\000\246\000\000\000\000\001\153\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\t\178\000\000\000\000\000\000\001\153\001*\000\000\000\000\000\000\003\210\001n\t\182\t\186\001z\001~\000\000\000\000\000\000\0012\000\000\003z\000\000\t\190\000\000\t\218\t\222\001\153\003\182\003\194\003\206\003\218\003\226\t\226\007b\000\000\001\206\001\153\003F\000\000\000\000\003\214\001\153\001\153\000\238\b\194\b\198\b\210\b\226\000\000\005\150\001\153\001\153\001\210\001\214\001\218\001\222\001\226\000\000\000\000\b\250\001\230\000\000\000\000\000\000\000\000\001\234\000\000\t\006\t\030\tj\t~\005\162\000\000\005\166\000\000\000\000\001\238\000\000\000\000\001\153\000\000\000\000\b\218\001\242\b\222\000\000\006\170\000\000\007Y\tE\001\153\000\000\007Y\000\000\002.\006\134\000\000\000\000\005\170\b\238\000\000\0022\000\000\023j\004j\t\246\000\000\002:\000\000\002>\002B\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\000\000\000\000\003N\000\238\000\000\000\238\004\177\000\000\003R\001*\000\000\012\022\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\003^\000\000\0012\000\000\003z\000\000\012&\000\000\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\007\018\007b\012\181\000\000\012\178\003F\000\000\000\000\003\214\012\186\000\000\000\000\b\194\b\198\b\210\b\226\006Z\005\150\006Z\006\006\000\000\006\006\012\181\000\000\tE\012\194\006n\b\250\006n\000\000\006v\000\000\006v\000\000\000\000\t\006\t\030\tj\t~\005\162\000\000\005\166\012\214\r\026\012\181\000\000\004\177\004\177\000\000\000\000\b\218\000\000\b\222\000\000\012\181\000\000\000\000\000\000\000\000\012\181\012\181\000\238\000\000\000\000\r\250\018~\005\170\b\238\012\181\012\181\000\000\t\146\004j\t\246\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\000\000\000\000\004\209\000\000\000\000\000\000\000\000\012\181\003R\001*\000\000\001\006\000\000\001.\000\000\003V\003Z\000\000\012\181\000\000\003^\000\000\0012\t\026\003z\000\000\012&\000\000\003\174\003\178\001*\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\000\000\012\178\003F\000\000\018\154\003\214\012\186\002Z\002^\b\194\b\198\b\210\b\226\000\000\005\150\019\238\003\134\000\000\000\000\019\242\000\000\000\000\012\194\003F\b\250\024>\028\182\001*\002\134\002r\020\"\000\000\t\006\t\030\tj\t~\005\162\002~\005\166\012\214\r\026\000\000\000\000\028\215\024f\000\238\000\000\b\218\000\000\b\222\000\000\002\130\003.\000\000\0202\000\000\000\000\003:\000\000\003F\004\026\004&\018~\005\170\b\238\000\000\0042\000\000\t\146\004j\t\246\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\0046\000\000\000\000\001&\002\029\000\000\029\006\000\000\002\029\000\000\000\000\006Z\003R\001*\006\006\000\000\000\000\001.\000\000\003V\003Z\006n\000\000\000\000\003^\006v\0012\000\000\003z\000\000\012&\000\n\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\004j\012\178\003F\000\000\002\029\003\214\012\186\002Z\002^\b\194\b\198\b\210\b\226\000\000\005\150\000\000\000\000\000\000\002\029\002\029\000\000\000\000\012\194\000\000\b\250\000\000\028\182\001*\002\134\002r\000\000\000\000\t\006\t\030\tj\t~\005\162\002~\005\166\012\214\r\026\000\000\000\000\004\217\002\142\000\000\000\000\b\218\002\029\b\222\000\000\002\130\003.\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\018~\005\170\b\238\000\000\0042\000\000\t\146\004j\t\246\000\145\001\002\001\006\000\145\012\169\000\000\001\"\000\000\n.\000\000\000\000\001&\0046\000\000\000\145\000\000\000\145\000\000\000\145\000\000\000\145\001*\000\000\n^\005}\001.\000\000\000\000\005}\000\000\000\000\nf\000\145\000\000\0012\000\000\003z\000\000\000\145\000\000\000\000\000\000\000\145\000\000\000\000\003\206\002N\000\145\012u\000\145\000\000\000\000\000\145\003F\000\000\000\000\003\214\000\145\000\145\000\145\b\194\b\198\b\210\000\000\020R\005\150\000\145\000\145\000\000\012u\000\000\000\000\002\194\000\145\000\000\002\198\000\000\000\145\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\169\012\169\005\162\002\210\005\166\000\145\000\145\002\218\012a\000\145\000\145\000\000\000\000\b\218\000\000\b\222\005}\000\000\000\000\000\000\000\000\000\145\000\000\012\169\000\000\000\000\012\169\000\145\000\145\005\170\b\238\000\000\002\222\005}\t\146\004j\005}\000\145\000\000\000\145\000\169\001\002\001\006\000\169\000\000\000\000\001\"\000\000\n.\000\000\000\000\001&\000\000\000\000\000\169\000\000\000\169\000\000\000\169\000\000\000\169\001*\000\000\n^\000\000\001.\000\000\002\029\002\029\012*\000\000\nf\000\169\000\000\0012\000\000\003z\000\000\000\169\000\000\000\000\002\226\000\169\002\029\000\000\003\206\002N\000\169\000\000\000\169\000\000\002\029\000\169\003F\000\000\000\n\003\214\000\169\000\169\000\169\b\194\b\198\b\210\000\000\020R\005\150\000\169\000\169\012\030\000\000\000\000\002\029\000\000\000\169\000\000\000\000\000\000\000\169\000\000\000\000\000\n\002\029\002\029\015:\000\000\002\029\000\000\005\162\b%\005\166\000\169\000\169\000\000\002\029\000\169\000\169\002\029\002\029\b\218\000\000\b\222\000\000\000\000\002\029\000\000\000\000\000\169\000\000\002\029\000\n\002\029\000\000\000\169\000\169\005\170\b\238\000\000\002\029\002\029\t\146\004j\000\000\000\169\000\014\000\169\000\018\000\022\000\026\000\030\000\238\000\"\000&\000\000\000*\000.\0002\000\000\0006\000:\002\029\000\000\000>\000\000\000\000\000\000\000B\002\029\000\000\000\000\000\000\000\000\000\000\000F\000\000\000\000\000\000\000\000\002\029\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\006Z\000\000\000\000\006\006\000\000\000\000\000\000\002Z\002^\000\000\006n\000\000\000\000\000z\006v\000\000\000~\000\130\000\000\000\000\000\000\000\000\001f\000\134\000\138\000\142\000\000\001*\002\134\002r\000\000\000\000\000\146\000\150\000\154\000\000\000\158\002~\000\000\000\162\000\166\000\170\000\000\000\000\002\142\000\174\000\178\000\182\000\000\000\000\000\000\002\130\003.\000\186\000\000\000\190\000\194\003:\000\000\003F\004\026\004&\000\000\000\198\000\000\000\202\0042\004\r\001B\001\006\004\r\000\206\000\210\001\"\000\214\006\226\000\241\000\000\001&\000\000\000\000\004\r\000\000\0046\000\000\004\r\000\000\004\r\001*\000\000\007\002\000\000\000\000\000\000\000\000\001F\000\241\000\000\007\026\004\r\000\000\000\000\000\000\000\000\000\000\004\r\000\000\000\000\001R\000\000\000\000\000\000\007F\002N\004\r\000\000\004\r\r.\000\241\004\r\003F\001>\000\000\003\246\004\r\004\r\n\145\003\250\000\241\004\002\000\000\007V\005\150\000\241\000\000\000\000\000\000\000\000\000\000\000\000\004\r\004\r\000\241\000\241\005\154\000\000\002\029\002\029\000\000\000\000\000\000\000\000\000\000\000\000\005\162\002\029\005\166\004\r\004\r\007^\000\000\004\r\004\r\000\000\000\000\000\000\002\029\000\000\000\000\000\000\000\000\000\241\000\000\000\000\000\n\n\145\n:\000\000\n\145\025\026\004\r\005\170\000\241\000\000\000\000\n\145\000\000\004j\000\000\n\145\002\029\004\r\001B\001\006\006&\000\000\000\000\001\"\002\029\000\000\000\000\000\000\001&\001b\002\029\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\002\029\002\029\000\000\001j\001n\001r\001v\001z\001~\002\029\000\000\000\000\002\029\000\000\002\029\000\000\001\130\000\000\001\194\006F\002\029\000\000\000\000\001^\002N\000\000\001\202\000\000\000\n\001\206\000\000\003F\000\000\004\157\003\246\000\000\000\000\002\029\003\250\000\000\004\002\005\138\000\000\005\150\002\029\002\029\001\210\001\214\001\218\001\222\001\226\003b\002\029\004\157\001\230\005\154\000\000\000\000\002\029\001\234\000\000\000\000\000\000\000\000\000\000\005\162\000\000\005\166\000\000\005\230\001\238\000\000\000\000\000\000\000\000\004\157\000\000\001\242\000\000\000\000\000\000\002\029\000\000\000\000\000\000\004\157\000\000\000\000\002.\006J\004\157\012\014\005\170\000\000\000\000\0022\000\000\0026\004j\004\157\004\157\002:\012\169\002>\002B\001B\001\006\007J\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\007j\000\000\001f\000\000\005\129\000\000\000\000\001*\005\129\001\162\004\157\001j\001n\001r\001v\001z\001~\000\000\000\000\000\000\001\166\004\157\000\000\007\146\001\130\000\000\001\194\006F\001*\000\000\000\000\001^\002N\000\000\001\202\000\000\000\000\001\206\000\000\003F\000\000\000\000\003\246\000\000\000\000\002\154\003\250\000\000\004\002\005\138\000\000\005\150\007\142\002j\001\210\001\214\001\218\001\222\001\226\000\000\003F\000\000\001\230\005\154\000\000\012\169\012\169\001\234\000\000\000\000\000\000\000\000\000\000\005\162\000\000\005\166\000\000\005\230\001\238\000\000\000\000\005\129\000\000\000\000\000\000\001\242\000\000\000\000\012\169\007\154\000\000\012\169\000\000\000\000\000\000\000\000\002.\006J\005\129\000\000\005\170\005\129\000\000\0022\000\000\0026\004j\000\000\000\000\002:\000\000\002>\002B\000\006\000\246\000\000\000\000\001\174\001\002\001\006\r\254\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\000\000\000\000\015\n\000\000\t1\000\000\t1\t1\003R\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\015\014\000\000\0012\000\000\003z\000\000\0156\000\000\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\000\000\012\178\003F\000\000\000\000\003\214\012\186\000\000\000\000\b\194\b\198\b\210\b\226\000\000\005\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\202\000\000\b\250\000\000\000\000\002\029\002\029\000\000\000\000\000\000\n\022\t\030\tj\t~\005\162\000\000\005\166\012\214\015\222\000\000\000\000\004\165\004\165\000\000\000\000\b\218\002\029\b\222\000\000\002\029\002\029\000\000\002\029\000\n\002\029\002\029\000\000\002\029\002\029\002\029\015\238\005\170\b\238\t1\002\029\002\029\t\146\004j\t\246\002\029\002\029\000\000\000\000\000\000\002\029\000\000\000\000\000\000\002\029\000\000\002\029\002\029\000\n\002\029\000\000\007f\000\000\002\029\000\000\002\029\000\000\024\198\000\000\002\029\002\029\000\000\002\029\002\029\002\029\002\029\002\029\002\029\002\029\000\000\000\000\000\000\002\029\000\000\000\000\002\029\000\000\000\000\002\029\002\029\002\029\002\029\002\029\000\000\002\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\029\000\000\002\029\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\000\000\002\029\002\029\024\226\000\000\000\000\000\000\002\029\000\000\000\000\002\029\000\000\002\029\000\006\000\246\000\000\000\000\004\157\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\002\029\002\029\001&\000\000\000\000\002\029\002\029\002\029\000\000\003\254\000\000\004\157\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\003\174\003\178\004\157\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\000\000\004\157\003F\000\000\000\000\003\214\004\157\012\014\000\238\b\194\b\198\b\210\b\226\000\000\005\150\000\000\004\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\250\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\022\t\030\tj\t~\005\162\000\000\005\166\000\000\000\000\000\000\000\000\000\000\004\157\000\000\000\000\b\218\000\000\b\222\000\000\000A\000A\000\000\000\000\004\157\000A\000A\000\000\000A\000A\000A\000\000\005\170\b\238\025f\000A\000\000\t\146\004j\t\246\006\221\000\000\000\000\000\000\000\000\000A\000\000\000\000\000\000\000A\000\000\000A\000A\000\000\000\000\000\000\000\000\000\000\000A\000\000\000A\000\000\000\000\000\000\000A\000A\000\000\000A\000A\000A\000A\000A\000A\000A\000\000\000\000\000\000\000A\000\000\000\000\000A\000\000\000\000\000\000\000A\000A\000A\000A\000\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000A\000A\000A\000A\000\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000\000\000A\000\000\000=\000=\000\000\000\000\018\166\000=\000=\000\000\000=\000=\000=\000\000\000A\000A\000\000\000=\000\000\000A\000A\000A\006\217\000\000\000\000\000\000\003R\000=\000\000\000\000\000\000\000=\000\000\000=\000=\000\000\000\000\000\000\000\000\000\000\000=\000\000\000=\000\000\000\000\000\000\000=\000=\019\022\000=\000=\000=\000=\000=\000=\000=\000\000\000\000\012\178\000=\000\000\000\000\000=\012\186\000\000\000\000\000=\000=\000=\000=\000\000\000=\019\210\019\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\004\201\000\000\000\000\000=\000\000\000=\000\000\012\005\012\005\000\000\000\000\020\226\012\005\012\005\000\000\012\005\012\005\012\005\000\000\000=\000=\000\000\012\005\000\000\000=\000=\000=\006\233\000\000\000\000\000\000\000\000\012\005\000\000\000\000\000\000\012\005\000\000\012\005\012\005\000\000\000\000\000\000\000\000\000\000\012\005\000\000\012\005\000\000\000\000\000\000\012\005\012\005\000\000\012\005\012\005\012\005\012\005\012\005\012\005\012\005\000\000\000\000\000\000\012\005\000\000\000\000\012\005\000\000\000\000\000\000\012\005\012\005\012\005\012\005\000\000\012\005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\005\012\005\012\005\012\005\012\005\000\000\012\005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\005\000\000\012\005\000\000\012\001\012\001\000\000\000\000\000\000\012\001\012\001\000\000\012\001\012\001\012\001\000\000\012\005\012\005\000\000\012\001\000\000\012\005\012\005\012\005\006\229\000\000\000\000\000\000\000\000\012\001\000\000\000\000\000\000\012\001\000\000\012\001\012\001\000\000\000\000\000\000\000\000\000\000\012\001\000\000\012\001\000\000\000\000\000\000\012\001\012\001\000\000\012\001\012\001\012\001\012\001\012\001\012\001\012\001\000\000\000\000\000\000\012\001\000\000\000\000\012\001\000\000\000\000\000\000\012\001\012\001\012\001\012\001\000\000\012\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\001\012\001\012\001\012\001\012\001\000\000\012\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\001\000\000\012\001\000\006\000\246\000\000\000\000\0166\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\012\001\012\001\001&\000\000\000\000\012\001\012\001\012\001\000\000\023\138\000\000\003R\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\003\174\003\178\016b\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\000\000\012\178\003F\000\000\000\000\003\214\012\186\000\000\000\000\b\194\b\198\b\210\b\226\000\000\005\150\000\000\016\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\250\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\022\t\030\tj\t~\005\162\000\000\005\166\000\000\000\000\000\000\000\000\000\000\004\193\000\000\000\000\b\218\000\000\b\222\000\000\000\006\000\246\000\000\000\000\016\242\001\002\001\006\000\000\001\n\001\022\001\"\000\000\005\170\b\238\023z\001&\000\000\t\146\004j\t\246\000\000\000\000\000\000\000\000\000\000\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\000\000\000\000\003F\000\000\000\000\003\214\000\000\000\000\000\000\b\194\b\198\b\210\b\226\000\000\005\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\250\000\000\000\000\000\000\005M\000\000\005M\005M\tN\t\030\tj\t~\005\162\005M\005\166\000\000\005M\000\000\005M\000\000\005M\005M\005M\b\218\005M\b\222\000\000\000\000\012u\012a\005M\000\000\005M\005M\005M\000\000\005M\005M\005M\005\170\b\238\000\000\005M\005M\t\146\004j\t\246\000\000\000\000\012u\005M\000\000\002\194\000\000\000\000\002\198\005M\005M\000\000\000\000\005M\005M\005M\005M\005M\005M\000\000\005M\002\210\000\000\005M\000\000\002\218\012a\000\000\005M\005M\005M\000\000\000\000\000\000\005M\000\000\000\000\005M\005M\000\000\000\000\000\000\000\000\000\000\005M\000\000\000\000\005M\005M\005M\002\222\005M\005M\004}\000\000\000\000\004}\000\000\000\000\000\000\000\000\005M\005M\005M\000\000\005M\005M\004}\000\000\017v\005M\004}\000\000\004}\000\000\000\000\000\000\005M\000\000\005M\005M\005M\000\000\0032\005M\004}\000\000\000\000\000\000\005M\000\000\004}\000\000\005M\n\173\005M\005M\n\173\n\173\002\226\000\000\000\000\n\173\000\000\n\173\004}\000\000\n\173\000\000\000\000\004}\n\173\n\173\000\000\n\173\n\173\000\000\n\173\000\000\n\173\000\000\000\000\000\000\000\000\n\173\000\000\004}\n\173\000\000\000\000\000\000\000\000\000\000\007\201\000\000\n\173\000\000\n\173\000\000\000\000\000\000\n\173\n\173\004}\004}\000\000\000\000\004}\004}\n\173\007\201\007\201\n\173\007\201\007\201\n\173\n\173\000\000\n\173\000\000\n\173\n\173\000\000\000\000\000\000\000\000\004}\000\000\000\000\000\000\n\173\000\000\000\000\n\173\007\201\000\000\000\000\015\130\000\000\000\000\000\000\000\000\000\000\n\173\000\000\n\173\000\000\000\000\n\173\000\000\n\173\000\000\000\000\000\000\007\201\000\000\000\000\005\198\000\000\000\000\000\000\000\000\000\000\000\000\n\173\n\173\000\000\n\173\n\173\007\201\n\173\000\000\n\173\000\000\n\173\012=\n\173\000\000\n\173\000\000\012=\000\000\002^\012=\000\000\000\000\000\000\007\201\000\249\007\201\000\000\000\000\004\190\000\000\012=\012=\012=\000\000\012=\012=\012=\000\000\000\000\005\254\000\000\000\000\007\201\007\201\000\249\000\000\000\000\007\201\012=\007\201\007\029\007\029\000\000\007\201\012=\012=\000\000\000\000\012=\000\000\000\000\000\000\0036\012=\000\000\012=\000\249\004*\012=\016&\007\029\007\029\007\029\012=\012=\012=\000\249\000\000\000\000\000\000\007\029\000\249\012=\012=\000\000\000\000\000\000\000\000\000\000\012=\000\000\000\249\000\000\004\198\007\029\007\029\000\000\012=\000\000\000\000\007\029\000\000\007\029\007\029\007\029\000\000\012=\012=\012=\007\029\012=\012=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\249\000\000\000\000\012=\000\000\012=\012=\007\029\000\000\t!\012=\000\249\000\000\000\000\t!\012=\002^\t!\000\000\012=\000\000\012=\012=\000\000\002Z\002^\t!\000\000\t!\t!\t!\000\000\t!\t!\t!\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\002\134\t!\000\000\004\030\000\000\007\029\000\000\t!\t!\000\000\000\000\t!\000\000\000\000\000\000\0036\t!\000\000\t!\000\000\000\000\t!\000\000\002\130\0036\000\000\t!\t!\t!\003:\000\000\003F\004\026\004&\000\000\t!\t!\000\000\0042\000\000\rB\000\000\t!\000\000\000\000\000\000\004\198\000\000\000\000\000\000\t!\000\000\000\000\000\000\000\000\0046\000\000\000\000\000\000\t!\t!\t!\000\000\t!\t!\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t!\000\000\t!\t!\000\000\000\000\t\029\t!\000\000\000\000\000\000\t\029\t!\002^\t\029\000\000\t!\000\000\t!\t!\000\000\000\000\000\000\t\029\000\000\t\029\t\029\t\029\000\000\t\029\t\029\t\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\029\000\000\002Z\002^\019.\000\000\t\029\t\029\000\000\000\000\t\029\000\000\000\000\000\000\0036\t\029\000\000\t\029\000\000\000\000\t\029\000\000\001*\002b\002r\t\029\t\029\t\029\000\000\000\000\000\000\000\000\002~\000\000\t\029\t\029\000\000\000\000\000\000\000\000\000\000\t\029\000\000\000\000\000\000\004\198\002\130\003.\000\000\t\029\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\t\029\t\029\t\029\0042\t\029\t\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\029\000\000\t\029\t\029\0046\000\000\000\000\t\029\000y\000\000\000y\000y\t\029\000\000\000\000\000\000\t\029\000\000\t\029\t\029\000y\000\000\000y\000y\000\000\000\000\000y\000y\000y\000\000\b\201\000\000\001B\001\006\000\000\000\000\000\000\001\"\000\000\000\000\000y\000\000\001&\000\000\000\000\000\000\000y\000y\000\000\tI\000y\000\000\001*\000\000\000y\000y\000\000\000y\000\000\001F\000y\000\000\000\000\000\000\000\000\000y\000y\000y\000\000\000\000\000\000\000\000\001R\000\000\000y\000y\001^\002N\000\000\000\000\000\000\000y\000y\000\000\003F\000y\000\000\003\246\000\000\000y\000\000\003\250\000\000\004\002\005\138\000\000\005\150\000\000\000y\000y\000y\000\000\000y\000y\000\000\000\000\000\000\000\000\005\154\000\000\b\201\000\000\000\000\000\000\000y\000\000\000\000\000y\005\162\012A\005\166\000y\005\230\000\000\012A\000\000\000y\012A\000\000\000\000\000y\000\000\000y\000\000\000\000\000\000\004\130\000\000\012A\012A\012A\000\000\012A\012A\012A\005\170\000\000\tI\000\000\t\018\000\000\004j\000\000\000\000\000\000\000\000\012A\000\000\002Z\002^\019\170\000\000\012A\012A\000\000\000\000\012A\000\000\000\000\000\000\000\000\012A\000\000\012A\000\000\000\000\012A\000\000\001*\002b\002r\012A\012A\012A\000\000\000\000\000\000\000\000\002~\000\000\012A\012A\000\000\000\000\000\000\000\000\000\000\012A\000\000\000\000\000\000\012A\002\130\003.\000\000\012A\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\012A\012A\012A\0042\012A\012A\003E\000\000\000\000\000\000\000\000\003E\012u\012a\003E\000\000\012A\000\000\012A\012A\0046\002Z\002^\012A\000\000\003E\003E\003E\012A\003E\003E\003E\012A\012u\012A\012A\002\194\000\000\000\000\002\198\000\000\001*\002b\003E\000\000\000\000\002\206\000\000\000\000\003E\004z\000\000\002\210\003E\000\000\000\000\002\218\012a\003E\000\000\003E\000\000\000\000\003E\000\000\002\130\0036\000\000\003E\003E\003E\003:\000\000\003F\004\026\004&\000\000\003E\003E\000\000\0042\002\222\rB\000\000\003E\000\000\000\000\000\000\003E\000\000\000\000\n\185\003E\000\000\001B\001\006\000\000\0046\000\000\001\"\000\000\003E\003E\003E\001&\003E\003E\000\000\n\185\n\185\000\000\n\185\n\185\000\000\001*\000\000\000\000\003E\000\000\003E\003E\001F\000\000\000\000\003E\000\000\000\000\000\000\000\000\003E\002\226\000\000\n\185\003E\001R\003E\003E\000\000\001^\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\n\185\003\250\000\000\004\002\005\138\000\000\005\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\185\000\000\000\000\005\154\000\000\000\000\n\181\000\000\000\000\001B\001\006\000\000\000\000\005\162\001\"\005\166\000\000\005\230\n\185\001&\n\185\000\000\000\000\n\181\n\181\000\000\n\181\n\181\000\000\001*\000\000\000\000\000\000\000\000\n\185\000\000\001F\n\185\n\185\000\000\005\170\000\000\n\185\000\000\n\185\000\000\004j\n\181\n\185\001R\000\000\000\000\000\000\006\"\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\n\181\003\250\000\000\004\002\005\138\000\000\005\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\181\000\000\000\000\005\154\000\000\000\000\001\177\000\000\000\000\000\000\000\000\001\177\000\000\005\162\001\177\005\166\000\000\005\230\n\181\000\000\n\181\000\000\000\000\000\000\000\000\001\177\001\177\001\177\000\000\001\177\001\177\001\177\000\000\000\000\n\181\000\000\000\000\n\181\n\181\000\000\005\170\000\000\n\181\001\177\n\181\000\000\004j\000\000\n\181\001\177\001\177\000\000\000\000\001\177\000\000\000\000\000\000\000\000\001\177\000\000\001\177\000\000\000\000\001\177\000\000\000\000\000\000\000\000\001\177\001\177\001\177\000\000\000\000\000\000\000\000\000\000\000\000\001\177\001\177\000\000\001E\000\000\000\000\001E\001\177\000\000\000\000\000\000\001\177\000\000\000\000\000\000\001\177\000\000\001E\000\000\001E\000\000\001E\000\000\001E\001\177\001\177\001\177\000\000\001\177\001\177\000\000\000\000\000\000\000\000\000\000\001E\000\000\000\000\000\000\000\000\001\177\001E\001\177\001\177\001B\001\006\000\000\001\177\000\000\001\"\000\000\006\226\001\177\000\000\001&\001E\004\230\000\000\001\177\000\000\001E\001E\000\238\000\000\001*\000\000\007\002\000\000\000\000\000\000\000\000\001F\000\000\000\000\007\026\000\000\001E\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007F\002N\000\000\000\000\000\000\001E\001E\001E\003F\001E\001E\003\246\000\000\000\000\n\145\003\250\000\000\004\002\000\000\007V\005\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001E\004I\000\000\000\000\005\154\000\000\000\000\003r\002\170\001\006\000\000\001E\000\000\000\000\005\162\000\000\005\166\002\174\000\000\007^\000\000\005\197\000\000\b\146\000\000\000\000\005\197\000\000\001*\005\197\000\000\000\000\000\000\000\000\000\000\n\145\000\000\000\000\n\145\n\145\005\197\005\170\005\197\000\000\005\197\n\145\005\197\004j\000\000\n\145\004I\000\000\003n\000\000\000\000\000\000\000\000\000\000\005\197\000\000\003F\000\000\000\000\000\000\005\197\005\197\000\000\000\000\000\000\000\000\000\000\005\197\000\000\005\197\000\000\005\197\000\000\000\000\005\197\000\000\000\000\000\000\000\000\005\197\005\197\005\197\000\000\000\000\000\000\007v\003\145\000\000\000\000\000\000\000\000\003\145\000\000\000\000\003\145\005\197\005\197\000\000\000\000\005\197\000\000\000\000\000\000\000\000\000\000\003\145\000\000\003\145\000\000\003\145\000\000\003\145\005\197\005\197\005\197\000\000\005\197\005\197\000\000\000\000\003\145\000\000\000\000\003\145\bJ\003\145\000\000\000\000\003\145\003\145\003\145\005\197\000\000\000\000\005\197\005\197\005U\000\000\003\145\003\145\003\145\003\145\000\000\003\145\000\000\003\145\005\197\000\000\003\145\003\145\003\145\000\000\000\000\000\000\000\000\000\000\000\000\003\145\000\000\000\000\000\000\000\000\000\000\003\145\003\145\000\000\000\000\000\000\003\145\000\000\005Y\000\000\003\145\000\000\003\145\000\000\000\000\003\145\000\000\000\000\000\000\003\145\003\145\003\145\003\145\003\145\003\145\000\000\000\000\005\185\000\000\000\000\000\000\005U\005\185\000\000\000\000\005\185\003\145\000\000\003\145\003\145\003\145\000\000\003\145\000\000\000\000\000\000\005\185\000\000\005\185\000\000\005\185\000\000\005\185\003\145\003\145\003\145\000\000\003\145\003\145\000\000\000\000\000\000\000\000\000\000\005\185\005Y\000\000\000\000\000\000\000\000\005\185\005\185\003\145\003\145\000\000\000\000\003\145\b\142\000\000\005\185\000\000\005\185\000\000\000\000\005\185\000\000\000\000\003\145\000\000\005\185\005\185\000\238\000\000\000\000\000\000\b\161\000\000\000\000\000\000\000\000\b\161\000\000\000\000\b\161\000\000\005\185\005\185\000\000\000\000\005\185\000\000\000\000\000\000\000\000\b\161\000\000\b\161\000\000\b\161\000\000\b\161\000\000\005\185\005\185\005\185\000\000\005\185\005\185\000\000\000\000\000\000\000\000\b\161\000\000\000\000\000\000\000\000\000\000\b\161\b\161\000\000\005\185\000\000\000\000\005\185\005\185\000\000\b\161\000\000\b\161\000\000\000\000\b\161\000\000\000\000\000\000\005\185\b\161\b\161\b\161\000\000\000\000\000\000\000\000\012\245\000\000\000\000\000\000\000\000\012\245\000\000\000\000\012\245\b\161\000\000\000\000\000\000\b\161\000\000\000\000\000\000\000\000\000\000\012\245\000\000\012\245\000\000\012\245\000\000\012\245\b\161\b\161\b\161\000\000\b\161\b\161\000\000\000\000\000\000\000\000\000\000\012\245\000\000\000\000\000\000\000\000\b\161\012\245\012\245\b\161\000\000\000\000\000\000\b\161\004>\000\000\012\245\000\000\012\245\000\000\000\000\012\245\004\230\000\000\b\161\000\000\012\245\012\245\012\245\000\000\000\000\000\000\000\000\012\249\000\000\000\000\000\000\000\000\012\249\000\000\000\000\012\249\012\245\000\000\000\000\000\000\012\245\000\000\000\000\000\000\000\000\000\000\012\249\000\000\012\249\000\000\012\249\000\000\012\249\012\245\012\245\012\245\000\000\012\245\012\245\000\000\000\000\000\000\000\000\000\000\012\249\004J\000\000\000\000\000\000\000\000\012\249\012\249\012\245\000\000\000\000\000\000\012\245\004>\000\000\012\249\000\000\012\249\000\000\000\000\012\249\000\000\000\000\012\245\000\000\012\249\012\249\012\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\161\000\000\002^\001\161\000\000\012\249\000\000\000\000\000\000\012\249\000\000\000\000\t\t\000\000\001\161\000\000\000\000\000\000\001\161\000\000\001\161\000\000\012\249\012\249\012\249\000\000\012\249\012\249\000\000\000\000\000\000\000\000\001\161\000\000\004J\000\000\000\000\000\000\001\161\001\161\000\000\012\249\000\000\000\000\000\000\012\249\0036\001\161\000\000\001\161\000\000\000\000\001\161\000\000\000\000\000\000\012\249\001\161\001\161\001\161\000\000\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\161\001\161\000\000\000\000\004\198\000\000\000\000\000\000\000\000\000\000\000\000\003u\000\000\002^\003u\000\000\000\000\001\161\001\161\000\000\000\000\001\161\001\161\t\005\000\000\003u\000\000\000\000\000\000\003u\000\000\003u\000\000\001\161\000\000\000\000\000\000\000\000\000\000\000\000\001\161\000\000\000\000\003u\000\000\001\161\000\000\000\000\000\000\003u\001\157\001\161\000\000\000\000\000\000\000\000\000\000\0036\003u\000\000\003u\000\000\000\000\003u\000\000\000\000\000\000\000\000\003u\003u\003u\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003u\003u\000\000\000\000\004\198\000\000\000\000\000\000\000\000\000\000\000\000\003q\000\000\002^\003q\000\000\000\000\003u\003u\000\000\000\000\003u\003u\t\005\000\000\003q\000\000\000\000\000\000\003q\000\000\003q\000\000\003u\000\000\000\000\000\000\000\000\000\000\000\000\003u\000\000\000\000\003q\000\000\003u\000\000\000\000\000\000\003q\001\157\003u\000\000\000\000\000\000\000\000\000\000\0036\003q\000\000\003q\000\153\000\000\003q\000\153\000\000\000\000\000\000\003q\003q\003q\000\000\000\000\000\000\000\000\000\153\000\000\000\153\000\000\000\153\000\000\000\153\000\000\000\000\003q\003q\000\000\000\000\004\198\000\000\000\000\000\000\000\000\000\153\000\000\000\000\000\000\000\000\000\000\000\153\000\000\003q\003q\000\153\000\000\003q\003q\000\000\000\153\000\000\000\153\000\000\000\000\000\153\000\000\000\000\000\000\003q\000\153\000\153\000\238\000\000\000\000\000\000\003q\000\000\000\000\000\153\000\153\003q\000\221\000\000\000\000\000\221\000\153\003q\000\000\000\000\000\153\000\000\000\000\000\000\000\000\000\000\000\221\000\000\000\221\000\000\000\221\000\000\000\221\000\153\000\153\000\000\000\000\000\153\000\153\000\000\000\000\000\000\000\000\000\000\000\221\000\000\000\000\000\000\000\000\000\153\000\221\000\000\000\000\000\000\000\221\000\153\000\153\000\000\000\000\000\221\000\000\000\221\000\000\000\000\000\221\000\153\000\000\000\153\000\000\000\221\000\221\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\221\000\221\000\000\000\161\000\000\000\000\000\161\000\221\000\000\000\000\000\000\000\221\000\000\000\000\000\000\000\000\000\000\000\161\000\000\000\161\000\000\000\161\000\000\000\161\000\221\000\221\000\000\000\000\000\221\000\221\000\000\000\000\000\000\000\000\000\000\000\161\000\000\000\000\000\000\000\000\000\221\000\161\000\000\000\000\000\000\000\161\000\221\000\221\000\000\000\000\000\161\000\000\000\161\000\000\000\000\000\161\000\221\000\000\000\221\000\000\000\161\000\161\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\161\000\161\000\000\000\157\000\000\000\000\000\157\000\161\000\000\000\000\000\000\000\161\000\000\000\000\000\000\000\000\000\000\000\157\000\000\000\157\000\000\000\157\000\000\000\157\000\161\000\161\000\000\000\000\000\161\000\161\000\000\000\000\000\000\000\000\000\000\000\157\000\000\000\000\000\000\000\000\000\161\000\157\000\000\000\000\000\000\000\157\000\161\000\161\000\000\000\000\000\157\000\000\000\157\000\000\000\000\000\157\000\161\000\000\000\161\000\000\000\157\000\157\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\157\000\157\000\000\000\000\000\000\001b\000\000\000\157\000\000\001f\000\000\000\157\000\000\000\000\000\000\012u\012a\000\000\001j\001n\001r\001\190\001z\001~\000\157\000\157\000\000\000\000\000\157\000\157\000\000\000\000\000\000\001\194\001\198\000\000\012u\000\000\000\000\002\194\000\157\001\202\002\198\000\000\001\206\000\000\000\157\000\157\000\000\014\n\000\000\000\000\000\000\000\000\000\000\002\210\000\157\000\000\000\157\002\218\012a\001\210\001\214\001\218\001\222\001\226\000\000\000\000\001}\001\230\000\000\001}\000\000\000\000\001\234\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\000\000\002\222\001\238\001}\000\000\001}\000\000\000\000\000\000\001\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\001}\000\000\002.\027\202\000\000\001}\000\000\000\000\000\000\0022\000\000\0026\005U\000\000\001}\002:\001}\002>\002B\001}\000\000\000\000\000\000\000\000\001}\001}\001}\000\000\000\000\000\000\000\000\000\000\002\226\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\001}\012\241\000\000\000\000\000\000\000\000\012\241\000\000\000\000\012\241\000\000\000\000\000\000\001}\001}\000\000\000\000\001}\001}\000\000\012\241\000\000\012\241\000\000\012\241\005U\012\241\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\001}\001}\000\000\012\241\000\000\000\000\001}\000\000\000\000\012\241\012\241\000\000\001}\000\000\000\000\000\000\000\000\000\000\012\241\000\000\012\241\000\000\000\000\012\241\000\000\000\000\000\000\000\000\012\241\012\241\012\241\000\000\000\000\000\000\012\237\000\000\000\000\000\000\000\000\012\237\000\000\000\000\012\237\000\000\012\241\000\000\000\000\000\000\012\241\000\000\000\000\000\000\000\000\012\237\000\000\012\237\000\000\012\237\000\000\012\237\000\000\012\241\012\241\012\241\000\000\012\241\012\241\000\000\000\000\000\000\000\000\012\237\000\000\000\000\000\000\000\000\000\000\012\237\012\237\000\000\012\241\000\000\000\000\000\000\012\241\000\000\012\237\000\000\012\237\000\000\000\000\012\237\000\000\004\230\000\000\012\241\012\237\012\237\012\237\000\000\000\000\000\000\000\000\b\165\000\000\000\000\000\000\000\000\b\165\000\000\000\000\b\165\012\237\000\000\000\000\000\000\012\237\000\000\000\000\000\000\000\000\000\000\b\165\000\000\b\165\000\000\b\165\000\000\b\165\012\237\012\237\012\237\000\000\012\237\012\237\000\000\000\000\000\000\000\000\000\000\b\165\000\000\000\000\000\000\000\000\007\230\b\165\b\165\012\237\001B\001\006\000\000\012\237\000\000\001\"\b\165\006\226\b\165\000\000\001&\b\165\000\000\000\000\012\237\000\000\b\165\b\165\000\238\000\000\001*\000\000\007\002\000\000\000\000\000\000\000\000\001F\000\000\000\000\007\026\000\000\b\165\000\000\000\000\000\000\b\165\000\000\0031\000\000\001R\000\000\000\000\000\000\007F\002N\000\000\000\000\000\000\b\165\b\165\b\165\003F\b\165\b\165\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007V\005\150\b\165\000\000\000\000\b\165\000\000\000\000\000\000\b\165\000\000\000\000\000\000\005\154\000\000\001\157\000\000\002^\001\157\000\000\b\165\000\000\000\000\005\162\000\000\005\166\000\000\t\005\0031\001\157\000\000\002Z\002^\001\157\000\000\001\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0031\000\000\001\157\0031\000\000\005\170\001*\002\134\001\157\000\000\000\000\004j\000\000\000\000\000\000\000\000\0036\001\157\000\000\001\157\000\000\000\000\001\157\000\000\000\000\000\000\000\000\001\157\001\157\001\157\002\130\003>\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\001\157\001\157\0042\000\000\004\198\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\157\001\157\0046\000\000\001\157\001\157\026>\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\157\001\174\002Z\002^\r\254\000\000\000\000\001\157\000\000\000\000\026*\000\000\001\157\000\000\000\000\015\n\000\000\000\000\001\157\004\165\000\000\003R\001*\002\134\002r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002~\015\014\000\000\000\000\000\000\000\000\000\000\0156\000\000\000\000\000\000\005\237\000\000\000\000\002\130\003.\005\237\000\000\000\000\005\237\003:\012\178\003F\004\026\004&\000\000\012\186\000\000\000\000\0042\005\237\000\000\005\237\000\000\005\237\000\000\005\237\000\000\000\000\000\000\000\000\000\000\015\202\000\000\000\000\000\000\0046\000\000\005\237\000\000\000\000\000\000\000\000\000\000\005\237\005\237\000\000\000\000\000\000\012\214\015\222\b\142\000\000\005\237\000\000\005\237\000\000\000\000\005\237\000\000\000\000\000\000\000\000\005\237\005\237\000\238\000\000\000\000\000\000\000\000\000\000\000\000\015\238\000\000\000\000\001b\000\000\000\000\000\000\005\237\000\000\000\000\000\000\005\237\000\000\000\000\000\000\000\000\001j\001n\001r\001\190\001z\001~\000\000\000\000\005\237\005\237\005\237\000\000\005\237\005\237\000\000\001\194\001\198\000\000\000\000\000\000\000\000\000\000\000\000\001\202\000\000\000\000\001\206\005\237\000\000\000\000\000\000\005\237\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\237\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\007\186\000\000\000\000\000\000\001\234\005\233\000\000\000\000\005\233\000\000\000\000\000\000\000\000\000\000\000\000\001\238\000\000\000\000\000\000\005\233\000\000\005\233\001\242\005\233\000\000\005\233\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002.\027\230\000\000\000\000\005\233\000\000\000\000\0022\000\000\0026\005\233\b6\000\000\002:\000\000\002>\002B\000\000\000\000\005\233\000\000\005\233\000\000\000\000\005\233\000\000\000\000\000\000\000\000\005\233\005\233\000\238\000\000\000\000\000\000\012\253\000\000\000\000\000\000\000\000\012\253\000\000\000\000\012\253\000\000\005\233\000\000\000\000\000\000\005\233\000\000\000\000\000\000\000\000\012\253\000\000\012\253\000\000\012\253\000\000\012\253\000\000\005\233\005\233\005\233\000\000\005\233\005\233\000\000\000\000\000\000\000\000\012\253\000\000\000\000\000\000\000\000\000\000\012\253\012\253\000\000\005\233\000\000\000\000\000\000\005\233\000\000\012\253\000\000\012\253\000\000\000\000\012\253\000\000\000\000\000\000\005\233\012\253\012\253\000\238\000\000\000\000\000\000\r\001\000\000\000\000\000\000\000\000\r\001\000\000\000\000\r\001\000\000\012\253\000\000\000\000\000\000\012\253\000\000\000\000\000\000\000\000\r\001\000\000\r\001\000\000\r\001\000\000\r\001\000\000\012\253\012\253\012\253\000\000\012\253\012\253\000\000\000\000\000\000\000\000\r\001\000\000\000\000\000\000\000\000\000\000\r\001\b6\000\000\012\253\000\000\000\000\000\000\012\253\000\000\r\001\000\000\r\001\000\000\000\000\r\001\000\000\000\000\000\000\012\253\r\001\r\001\000\238\000\000\000\000\000\000\007\186\000\000\000\000\000\000\000\000\006\001\000\000\000\000\006\001\000\000\r\001\000\000\000\000\000\000\r\001\000\000\000\000\000\000\000\000\006\001\000\000\006\001\000\000\006\001\000\000\006\001\000\000\r\001\r\001\r\001\000\000\r\001\r\001\000\000\000\000\000\000\000\000\006\001\000\000\000\000\000\000\000\000\000\000\006\001\b6\000\000\r\001\000\000\000\000\000\000\r\001\000\000\006\001\000\000\006\001\000\000\000\000\006\001\000\000\000\000\000\000\r\001\006\001\006\001\000\238\000\000\000\000\000\000\006\005\000\000\000\000\000\000\000\000\006\005\000\000\000\000\006\005\000\000\006\001\000\000\000\000\000\000\006\001\000\000\000\000\000\000\000\000\006\005\000\000\006\005\000\000\006\005\000\000\006\005\000\000\006\001\006\001\006\001\000\000\006\001\006\001\000\000\000\000\000\000\000\000\006\005\000\000\000\000\000\000\000\000\000\000\006\005\006\005\000\000\006\001\000\000\000\000\000\000\006\001\000\000\006\005\000\000\006\005\000\000\000\000\006\005\000\000\000\000\000\000\006\001\006\005\006\005\006\005\000\000\000\000\000\000\005\253\000\000\000\000\000\000\000\000\005\253\000\000\000\000\005\253\000\000\006\005\000\000\000\000\000\000\006\005\000\000\000\000\000\000\000\000\005\253\000\000\005\253\000\000\005\253\000\000\005\253\000\000\006\005\006\005\006\005\000\000\006\005\006\005\000\000\000\000\000\000\000\000\005\253\000\000\000\000\000\000\000\000\000\000\005\253\b6\000\000\006\005\000\000\000\000\000\000\006\005\000\000\005\253\000\000\005\253\000\000\000\000\005\253\000\000\000\000\000\000\b^\005\253\005\253\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003m\000\000\002^\003m\000\000\005\253\000\000\000\000\000\000\005\253\000\000\000\000\000\000\000\000\003m\000\000\002Z\002^\003m\000\000\003m\000\000\005\253\005\253\005\253\000\000\005\253\005\253\000\000\000\000\000\000\000\000\003m\000\000\000\000\000\000\001*\002\134\003m\000\000\000\000\005\253\000\000\000\000\000\000\005\253\0036\003m\000\000\003m\000\000\000\000\003m\000\000\000\000\000\000\005\253\003m\003m\003m\002\130\003>\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\003m\003m\0042\000\000\004\198\000\000\003i\000\000\002^\003i\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003m\003m\0046\003i\003m\003m\005\029\003i\000\000\003i\000\000\000\000\000\000\000\000\000\000\000\000\003m\000\000\000\000\000\000\000\000\003i\000\000\003m\000\000\000\000\026*\003i\003m\000\000\000\000\000\000\000\000\000\000\003m\0036\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\001\169\000\000\r&\001\169\000\000\000\000\001\"\000\000\003i\003i\000\000\000\000\004\198\000\000\001\169\000\000\000\000\000\000\001\169\000\000\001\169\000\000\002Z\002^\000\000\003i\003i\000\000\000\000\003i\003i\000\000\001\169\000\000\000\000\000\000\000\000\000\000\001\169\000\000\000\000\003i\001*\002\134\000\000\r*\000\000\001\169\003i\001\169\000\000\000\000\001\169\003i\000\000\000\000\000\000\001\169\001\169\003i\r6\000\000\000\000\000\000\000\000\000\000\002\130\003>\000\000\000\000\000\000\000\000\003:\001\169\003F\004\026\004&\001\169\000\000\000\000\000\000\0042\000\000\001-\000\000\000\000\001-\000\000\000\000\005\166\001\169\001\169\000\000\000\000\001\169\001\169\000\000\001-\0046\001-\000\000\001-\005!\001-\000\000\000\000\001\169\000\000\000\000\000\000\000\000\000\000\000\000\001\169\000\000\001-\000\000\000\000\000\000\000\000\000\000\001-\026*\000\000\001\169\001-\000\000\000\000\000\000\000\000\001-\000\000\001-\000\000\000\000\001-\000\000\000\000\000\000\000\000\001-\001-\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001-\000\000\001)\000\000\000\000\001)\001-\000\000\000\000\000\000\001-\000\000\000\000\000\000\000\000\000\000\001)\000\000\001)\000\000\001)\000\000\001)\001-\001-\001-\000\000\001-\001-\000\000\000\000\000\000\000\000\000\000\001)\000\000\000\000\000\000\000\000\001-\001)\000\000\000\000\000\000\001)\000\000\001-\000\000\000\000\001)\000\000\001)\000\000\000\000\001)\000\000\000\000\001-\000\000\001)\001)\000\238\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\001)\000\000\000\000\000\000\001)\000\000\000\000\000\000\000\000\000\000\001\002\001\006\000\000\000\000\000\000\001\"\000\000\001)\001)\001)\001&\001)\001)\000\000\000\000\006\153\000\000\000\000\000\000\000\000\001*\000\000\000\000\001)\001.\000\000\000\000\000\000\000\000\000\000\001)\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\000\000\000\000\001)\000\000\000\000\003\206\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\214\000\000\000\000\000\000\b\194\b\198\b\210\000\000\000\000\005\150\002\029\002\029\000\000\000\000\000\000\002\029\000\000\002\029\000\000\000\000\002\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\029\005\162\002\029\005\166\000\000\000\000\000\000\002\029\000\n\000\000\002\029\000\000\b\218\000\000\b\222\000\000\000\000\000\000\000\000\000\000\002\029\000\000\000\000\000\000\002\029\002\029\000\000\000\000\005\170\b\238\000\000\000\000\002\029\t\146\004j\002\029\000\000\004\157\002\029\002\029\004\157\002\029\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\000\000\004\157\000\000\000\000\000\000\004\157\002\029\004\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\029\000\000\002\029\004\157\002\029\000\000\000\000\000\000\000\000\004\157\000\000\000\000\000\000\004\157\000\000\000\000\b\142\000\000\004\157\000\000\004\157\b1\000\000\004\157\b1\000\000\000\000\002\029\004\157\012\014\000\238\002\029\000\000\002\029\000\000\b1\000\000\004\157\004\157\b1\000\000\b1\000\000\000\000\004\157\004\157\000\000\000\000\004\157\000\000\000\000\000\000\000\000\b1\000\000\000\000\000\000\000\000\000\000\b1\000\000\004\157\004\157\b1\000\000\004\157\004\157\000\000\b1\000\000\b1\000\000\b-\b1\000\000\b-\000\000\004\157\b1\b1\000\238\000\000\000\000\000\000\004\157\000\000\b-\b1\b1\026\166\b-\000\000\b-\000\000\b1\004\157\000\000\000\000\b1\000\000\000\000\000\000\000\000\000\000\b-\000\000\000\000\000\000\000\000\000\000\b-\b1\b1\b1\b-\b1\b1\000\000\000\000\b-\000\000\b-\003a\000\000\b-\003a\000\000\b1\000\000\b-\b-\000\238\000\000\000\000\b1\000\000\003a\000\000\b-\b-\003a\000\000\003a\000\000\000\000\b-\000\000\000\000\000\000\b-\000\000\000\000\000\000\000\000\003a\r>\000\000\000\000\000\000\000\000\003a\000\000\b-\b-\b-\000\000\b-\b-\000\000\003a\000\000\003a\000\000\000\000\003a\000\000\000\000\000\000\b-\003a\003a\003a\000\000\000\000\000\000\b-\001Y\000\000\012Y\001Y\000\000\000\000\000\000\000\000\000\000\003a\000\000\000\000\012Y\003a\001Y\000\000\001Y\000\000\001Y\000\000\001Y\000\000\000\000\000\000\000\000\000\000\003a\003a\026\174\000\000\003a\003a\001Y\000\000\000\000\000\000\000\000\000\000\001Y\012Y\000\000\000\000\003a\000\000\000\000\000\000\012Y\000\000\r\190\003a\000\000\000\000\001Y\000\000\003a\000\000\000\000\001Y\001Y\001Y\003a\000\000\000\000\000\000\001\029\000\000\0025\001\029\000\000\000\000\000\000\000\000\000\000\001Y\000\000\000\000\0025\012Y\001\029\000\000\001\029\000\000\001\029\000\000\001\029\000\000\000\000\000\000\000\000\000\000\001Y\001Y\001Y\000\000\001Y\001Y\001\029\000\000\000\000\000\000\000\000\000\000\001\029\0025\000\000\000\000\000\000\000\000\000\000\000\000\0025\000\000\000\000\001Y\000\000\000\000\001\029\000\000\000\000\000\000\000\000\001\029\001\029\001\029\001Y\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\029\000\000\000\000\000\000\0025\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\226\000\000\000\000\001&\000\000\001\029\001\029\001\029\006\157\001\029\001\029\000\000\000\000\001*\000\000\007\002\000\000\000\000\000\000\000\000\001F\000\000\000\000\007\026\000\000\000\000\000\000\000\000\001\029\000\000\000\000\020>\000\000\001R\000\000\000\000\000\000\001^\002N\001\029\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005\138\007V\005\150\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\226\000\000\000\000\001&\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\005\162\007\002\005\166\000\000\005\230\018\150\001F\000\000\000\000\007\026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007F\002N\021\018\000\000\005\170\000\000\006\210\000\000\003F\000\000\004j\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007V\005\150\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\226\000\000\000\000\001&\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\005\162\007\002\005\166\000\000\000\000\007^\001F\000\000\000\000\007\026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007F\002N\019*\000\000\005\170\000\000\000\000\000\000\003F\000\000\004j\003\246\000\000\001\002\001\006\003\250\000\000\004\002\001\"\007V\005\150\000\000\000\000\001&\000\000\000\000\000\000\000\000\006\193\000\000\000\000\000\000\005\154\001*\000\000\000\000\000\000\001.\000\000\000\000\000\000\000\000\005\162\000\000\005\166\000\000\0012\007^\003z\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\206\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\019\166\003\214\005\170\000\000\000\000\b\194\b\198\b\210\004j\000\000\005\150\004\133\004\133\000\000\000\000\000\000\004\133\000\000\000\000\000\000\000\000\004\133\000\000\000\000\000\000\000\000\000\000\004\133\000\000\000\000\000\000\004\133\005\162\000\000\005\166\000\000\000\000\000\000\004\133\019\246\000\000\000\000\020\014\b\218\000\000\b\222\000\000\000\000\000\000\000\000\000\000\004\133\000\000\000\000\000\000\004\133\004\133\000\000\000\000\005\170\b\238\000\000\000\000\004\133\t\146\004j\004\133\000\000\003a\000\238\004\133\003a\004\133\004\133\000\000\004\133\000\000\000\000\000\000\000\000\000\000\000\000\003a\000\000\000\000\000\000\003a\004\133\003a\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\133\000\000\004\133\003a\r>\000\000\000\000\000\000\000\000\003a\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003a\000\000\003a\012Q\000\000\003a\012Q\000\000\000\000\004\133\003a\003a\003a\000\000\000\000\004\133\000\000\012Q\000\000\000\000\000\000\012Q\000\000\012Q\000\000\000\000\003a\000\000\000\000\005M\003a\000\000\000\000\000\000\000\000\012Q\000\000\000\000\000\000\000\000\000\000\012Q\000\000\003a\003a\026\222\000\000\003a\003a\000\000\012Q\000\000\012Q\000\000\000\000\012Q\000\000\000\000\000\000\000\000\012Q\012Q\001B\001\006\000\000\r\190\003a\001\"\000\000\000\000\000\000\003a\001&\000\000\000\000\000\000\012Q\005\226\000\000\003\254\012Q\000\000\001*\000\000\000\000\000\000\000\000\000\000\000\000\001F\000\000\000\000\000\000\012Q\012Q\003\030\000\000\012Q\012Q\000\000\000\000\000\000\001R\000\000\000\000\000\000\001^\002N\000\000\012Q\000\000\000\000\000\000\014\022\003F\000\000\012Q\003\246\000\000\005\161\000\000\003\250\005\161\004\002\005\138\000\000\005\150\012Q\000\000\000\000\000\000\000\000\000\000\005\161\000\000\000\000\000\000\005\161\005\154\005\161\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\162\000\000\005\166\005\161\005\230\000\000\000\000\000\000\000\000\005\161\000\000\000\000\000\000\000\000\000\000\000\000\b\142\000\000\005\161\000\000\005\161\000\000\000\000\005\161\006\134\000\000\000\000\005\170\005\161\005\161\000\238\000\000\000\000\004j\000\000\000\000\000\000\000\000\000\000\000\000\005\165\000\000\000\000\005\165\005\161\005\161\000\000\000\000\005\161\000\000\000\000\000\000\000\000\000\000\005\165\000\000\000\000\000\000\005\165\000\000\005\165\005\161\005\161\000\000\000\000\005\161\005\161\000\000\000\000\000\000\000\000\000\000\005\165\000\000\000\000\000\000\000\000\000\000\005\165\000\000\000\000\000\000\000\000\000\000\005\161\b\142\000\000\005\165\000\000\005\165\003a\000\000\005\165\003a\000\000\005\161\000\000\005\165\005\165\000\238\000\000\000\000\000\000\000\000\003a\000\000\000\000\000\000\003a\000\000\003a\000\000\000\000\005\165\005\165\000\000\000\000\005\165\000\000\000\000\000\000\000\000\003a\r>\000\000\000\000\000\000\000\000\003a\000\000\005\165\005\165\000\000\000\000\005\165\005\165\000\000\003a\000\000\003a\006I\000\000\003a\006I\000\000\000\000\000\000\003a\003a\003a\000\000\000\000\000\000\005\165\006I\000\000\000\000\000\000\006I\000\000\006I\000\000\000\000\003a\005\165\000\000\000\000\003a\000\000\000\000\000\000\000\000\006I\000\000\000\000\000\000\000\000\000\000\006I\000\000\003a\003a\r\158\000\000\003a\003a\000\000\006I\000\000\006I\000\000\000\000\006I\000\000\000\000\000\000\000\000\006I\006I\000\238\000\000\000\000\r\190\003a\000\000\012\017\000\000\001\006\012\017\000\000\000\000\028\190\000\000\006I\000\000\000\000\028\194\006I\000\000\012\017\000\000\000\000\000\000\000\000\000\000\012\017\000\000\000\000\000\000\000\000\006I\006I\014b\000\000\006I\006I\000\000\012\017\000\000\000\000\000\000\000\000\000\000\012\017\000\000\000\000\006I\000\000\000\000\000\000\001\186\002N\012\017\006I\012\017\001\174\000\000\012\017\002\182\000\000\000\000\000\000\012\017\000\000\006I\000\000\000\000\000\000\000\000\003N\028\198\001B\001\006\004\177\000\000\003R\001\"\000\000\012\017\000\000\000\000\001&\012\017\000\000\000\000\000\000\000\000\003^\006\154\000\000\000\000\001*\000\000\012&\028\202\012\017\012\017\000\000\001F\012\017\000\000\000\000\003\226\000\000\021^\000\000\000\000\012\178\000\000\000\000\000\000\001R\012\186\000\000\000\000\001^\002N\000\000\012\017\007\186\000\000\000\000\000\000\003F\007Q\000\000\003\246\007Q\012\194\000\000\003\250\000\000\004\002\005\138\000\000\005\150\000\000\000\000\007Q\000\000\000\000\000\000\007Q\000\000\007Q\012\214\r\026\005\154\000\000\004\177\004\177\000\000\000\000\000\000\000\000\000\000\007Q\005\162\000\000\005\166\000\000\005\230\007Q\b6\000\000\000\000\000\000\000\000\018~\000\000\000\000\007Q\000\000\007Q\001\173\000\000\007Q\001\173\000\000\000\000\000\000\007Q\007Q\000\238\005\170\000\000\000\000\000\000\001\173\000\000\004j\000\000\001\173\000\000\001\173\000\000\000\000\007Q\000\000\000\000\000\000\007Q\000\000\000\000\000\000\000\000\001\173\000\000\000\000\000\000\000\000\000\000\001\173\000\000\007Q\007Q\000\000\000\000\007Q\007Q\000\000\001\173\000\000\001\173\006M\000\000\001\173\006M\000\000\000\000\000\000\001\173\001\173\000\000\000\000\000\000\000\000\007Q\006M\000\000\000\000\000\000\006M\000\000\006M\000\000\000\000\001\173\000\000\000\000\000\000\001\173\000\000\000\000\000\000\000\000\006M\000\000\000\000\000\000\000\000\000\000\006M\000\000\001\173\001\173\000\000\000\000\001\173\001\173\000\000\006M\000\000\006M\000\000\000\000\006M\000\000\000\000\000\000\001\173\006M\006M\000\238\000\000\000\000\000\000\001\173\000\000\000\000\000\000\000\000\014B\000\000\000\000\000\000\000\000\006M\001\173\000\000\000\000\006M\000\000\000\000\000\000\000\000\ba\ba\000\000\000\000\000\000\ba\000\000\000\000\006M\006M\ba\000\000\006M\006M\000\000\000\000\003\238\000\000\000\000\000\000\ba\000\000\000\000\000\000\006M\000\000\000\000\ba\007\186\000\000\000\000\006M\000\000\004\157\000\000\000\000\004\157\000\000\000\000\000\000\ba\000\000\006M\000\000\ba\ba\000\000\004\157\000\000\000\000\000\000\004\157\ba\004\157\004\157\ba\000\000\000\000\000\000\ba\000\000\ba\ba\000\000\ba\004\157\000\000\000\000\000\000\004\157\000\000\004\157\b6\000\000\000\000\000\000\ba\000\000\004>\000\000\004\157\000\000\004\157\004\157\000\000\004\157\ba\000\000\ba\004\157\004\157\012\014\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\157\000\000\000\000\004\157\000\000\004\157\012\014\004\157\012Q\000\000\ba\012Q\000\000\000\000\000\000\000\209\ba\000\000\000\209\000\000\004\157\004\157\012Q\000\000\004\157\004\157\012Q\000\000\012Q\000\209\000\000\000\000\004J\000\209\005M\000\209\007\230\000\000\004\157\004\157\012Q\000\000\004\157\004\157\000\000\000\000\012Q\000\209\014B\000\000\bJ\000\000\000\000\000\209\004\157\000\000\000\000\000\000\000\000\000\000\012Q\004\157\000\209\000\000\000\209\012Q\012Q\000\209\000\000\000\000\000\000\000\000\000\209\000\209\000\238\000\000\000\000\000\000\000\000\000\000\000\000\012Q\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\000\000\000\000\000\000\209\000\213\000\000\000\000\000\213\000\000\012Q\012Q\003\030\000\000\012Q\012Q\000\000\000\209\000\209\000\213\000\000\000\209\000\209\000\213\000\000\000\213\012Q\000\000\000\000\000\000\014\218\000\000\000\000\012Q\000\000\000\000\000\000\000\213\000\000\000\000\000\209\000\000\000\000\000\213\012Q\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\213\000\000\000\213\000\000\000\000\000\213\000\000\000\000\000\000\000\000\000\213\000\213\000\238\000\000\000\000\002Z\003\"\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\000\213\000\000\000\000\000\000\000\213\000\000\000\000\000\000\000\000\001*\002\134\002r\003&\000\000\000\000\000\000\000\000\000\213\000\213\002~\000\000\000\213\000\213\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003*\003.\007M\000\000\000\000\007M\003:\000\213\003F\004\026\004&\000\000\000\000\000\000\000\000\014\026\007M\014\030\000\213\000\000\007M\000\000\007M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0046\000\000\007M\000\000\000\000\000\000\000\000\000\000\007M\000\000\000\000\000\000\005\166\000\000\000\000\000\000\000\000\007M\000\000\007M\006A\000\000\007M\006A\014*\000\000\000\000\007M\007M\000\000\000\000\r\006\000\000\000\000\006A\000\000\000\000\000\000\006A\000\000\006A\014.\000\000\007M\000\000\000\000\000\000\007M\000\000\000\000\000\000\000\000\006A\000\000\000\000\000\000\000\000\000\000\006A\000\000\007M\007M\012:\000\000\007M\007M\000\000\006A\000\000\006A\011\189\000\000\006A\011\189\000\000\000\000\000\000\006A\006A\000\000\015J\000\000\000\000\007M\011\189\000\000\000\000\000\000\011\189\000\000\011\189\000\000\000\000\006A\000\000\000\000\000\000\006A\000\000\000\000\000\000\000\000\011\189\000\000\000\000\000\000\000\000\000\000\011\189\000\000\006A\006A\000\000\000\000\006A\006A\000\000\011\189\000\000\011\189\000\000\000\000\011\189\000\000\000\000\000\000\000\000\011\189\000\000\000\000\000\000\000\000\000\000\006A\000\000\011\193\000\000\000\000\011\193\000\000\000\000\000\000\000\000\011\189\n\170\000\000\000\000\011\189\000\000\011\193\000\000\000\000\000\000\011\193\000\000\011\193\000\000\000\000\000\000\000\000\011\189\011\189\000\000\000\000\011\189\011\189\000\000\011\193\000\000\000\000\000\000\000\000\000\000\011\193\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\193\011\189\011\193\000\000\000\000\011\193\000\000\000\000\000\000\000\000\011\193\000\000\011\170\000\000\000\000\002Z\003\"\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\011\193\n\186\000\000\000\000\011\193\000\000\000\000\000\000\000\000\001*\002\134\002r\000\000\000\000\000\000\000\000\000\000\011\193\011\193\002~\000\000\011\193\011\193\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003*\003.\004u\000\000\000\000\004u\003:\011\193\003F\004\026\004&\000\000\000\000\000\000\000\000\014\026\004u\026~\011\170\000\000\004u\000\000\004u\007\186\000\000\000\000\000\000\000\000\005\173\000\000\000\000\005\173\0046\000\000\004u\000\000\000\000\000\000\000\000\000\000\004u\000\000\005\173\000\000\005\166\000\000\005\173\000\000\005\173\004u\000\000\004u\000\000\000\000\004u\000\000\026\138\000\000\000\000\004u\005\173\000\000\000\000\000\000\000\000\000\000\005\173\b6\000\000\000\000\000\000\000\000\000\000\014.\000\000\004u\000\000\000\000\000\000\004u\005\173\000\000\000\000\000\000\000\000\005\173\005\173\000\238\000\000\000\000\000\000\000\000\004u\004u\000\000\000\000\004u\004u\000\000\000\000\000\000\005\173\000\000\000\000\000\000\000\000\000\000\004m\000\000\000\000\004m\000\000\000\000\000\000\004\141\004u\000\000\004\141\005\173\005\173\000\000\004m\005\173\005\173\000\000\004m\012\130\004m\004\141\000\000\000\000\000\000\004\141\000\000\004\141\000\000\000\000\000\000\000\000\004m\000\000\005\173\000\000\000\000\000\000\004m\004\141\000\000\000\000\000\000\000\000\000\000\004\141\000\000\004m\000\000\004m\000\000\000\000\004m\000\000\004\141\000\000\004\141\004m\000\000\004\141\000\000\000\000\000\000\000\000\004\141\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004m\000\000\000\000\000\000\004m\000\000\000\000\004\141\000\000\000\000\000\000\004\141\004]\000\000\000\000\004]\000\000\004m\004m\000\000\000\000\004m\004m\000\000\004\141\004\141\004]\000\000\004\141\004\141\004]\000\000\004]\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004m\000\000\000\000\000\000\004]\000\000\000\000\004\141\000\000\000\000\004]\0172\000\000\000\000\000\000\000\000\007\213\000\000\018\022\004]\000\000\004]\000\000\000\000\004]\000\000\000\000\000\000\000\000\004]\002Z\002^\000\000\007\213\007\213\000\000\007\213\007\213\000\000\000\000\000\000\012!\000\000\000\000\012!\004]\000\000\003\254\000\000\004]\001*\002\134\002r\000\000\000\000\012!\000\000\007\213\000\000\000\000\002~\012!\004]\004]\000\000\000\000\004]\004]\000\000\000\000\000\000\000\000\000\000\012!\002\130\003.\000\000\000\238\000\000\012!\003:\000\000\003F\004\026\004&\004]\000\000\007\185\012!\0042\012!\000\000\007\213\012!\000\000\000\000\0212\000\000\012!\000\000\000\000\000\000\000\000\000\000\007\185\007\185\0046\007\185\007\185\000\000\007\213\000\000\007\213\000\000\012!\000\000\000\000\000\000\012!\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007\213\000\000\007\185\006\006\007\213\012!\012!\000\000\007\213\012!\007\213\000\000\007\217\000\000\007\213\000\000\000\000\028\174\000\000\000\000\000\000\004f\007\185\004j\000\000\007\205\000\000\000\000\012!\007\217\007\217\000\000\007\217\007\217\000\000\000\000\000\000\007\185\000\000\002Z\002^\000\000\007\205\007\205\000\000\007\205\007\205\000\000\000\000\000\000\000\000\000\000\000\000\007\217\000\000\007\185\000\000\007\185\000\000\001*\002\134\002r\000\000\000\000\000\000\000\000\007\205\000\000\000\000\002~\000\000\007\185\016\030\000\238\006\006\007\185\000\000\000\000\000\000\007\185\000\000\007\185\000\000\002\130\017r\007\185\000\238\016\150\007\217\003:\000\000\003F\004\026\004&\000\000\000\000\004e\000\000\017\130\004e\000\000\007\205\000\000\000\000\000\000\000\000\007\217\000\000\007\217\004\149\004e\000\000\004\149\000\000\004e\0046\004e\000\000\000\000\007\205\000\000\007\205\007\217\004\149\000\000\006\006\007\217\004\149\004e\004\149\007\217\000\000\007\217\000\000\004e\006Z\007\217\000\000\006\006\007\205\000\000\004\149\000\000\007\205\000\000\007\205\000\000\004\149\004e\007\205\000\000\000\000\000\000\004e\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\149\000\000\000\000\001\174\000\000\004\149\002\182\000\000\004e\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\029\006\000\000\000\000\000\000\004\149\000\000\003R\000\000\004e\004e\000\000\000\000\004e\004e\000\000\000\000\000\000\000\000\003^\000\000\000\000\004\149\004\149\000\000\012&\004\149\004\149\000\000\000\000\000\000\000\000\004e\000\000\003\226\000\000\021^\000\000\000\000\012\178\000\000\000\000\000\000\017\190\012\186\004\149\000\000\000\000\000\000\007\025\007\025\000\000\000\000\000\000\000\000\000\000\018>\000\000\000\000\000\000\012\194\000\000\r\005\r\005\028\182\000\000\000\000\000\000\000\000\007\025\007\025\007\025\000\000\000\000\000\000\000\000\000\000\012\214\r\026\007\025\000\000\004\217\r\005\r\005\r\005\007\206\000\000\000\000\000\000\000\000\000\000\000\000\r\005\007\025\007\025\000\000\000\000\000\000\000\000\007\025\018~\007\025\007\025\007\025\000\000\000\000\r\005\r\005\007\025\000\000\001\174\000\000\r\005\r\254\r\005\r\005\r\005\000\000\000\000\000\000\000\000\r\005\000\000\000\000\015\n\007\025\000\000\000\000\004\165\000\000\003R\000\000\000\000\000\000\002Z\002^\025\030\000\000\r\005\000\000\000\000\000\000\015\014\000\000\000\000\000\000\000\000\000\000\0156\000\000\000\000\000\000\000\000\000\000\001*\002b\002r\000\000\000\000\000\000\001\174\000\000\012\178\002\182\002~\000\000\000\000\012\186\000\000\000\000\000\000\000\000\000\000\005\030\004\209\000\000\000\000\000\000\002\130\003.\003R\000\000\000\000\015\202\003:\000\000\003F\004\026\004&\000\000\000\000\000\000\003^\0042\000\000\000\000\000\000\000\000\012&\000\000\012\214\015\222\000\000\000\000\004\165\004\165\000\000\003\226\000\000\021^\0046\000\000\012\178\000\000\000\000\000\000\000\000\012\186\000\000\000\000\000\000\000\000\000\000\015\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\194\000\000\000\000\000\000\000\000\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\214\r\026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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~")) and lhs = - (8, "\014\r\012\011\n\t\b\007\006\005\004\003\002\001\000\225\225\224\224\223\222\222\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\221\220\220\219\218\218\218\218\218\218\218\218\217\217\217\217\217\217\217\217\216\216\216\215\215\214\213\213\213\212\212\211\211\211\211\211\211\210\210\210\210\210\210\210\209\209\209\209\209\208\208\208\208\207\206\205\205\205\205\204\204\204\204\203\203\203\202\202\202\202\201\200\200\200\199\199\198\198\197\197\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\196\195\195\194\194\193\192\191\190\190\189\189\188\188\188\188\187\187\187\187\186\186\185\184\184\184\184\184\184\183\182\181\181\180\180\179\179\178\177\177\176\175\175\174\173\172\172\172\171\171\170\169\169\169\169\169\169\168\168\168\168\168\168\168\168\167\167\166\166\166\166\166\166\165\165\164\164\164\163\163\162\162\162\162\161\161\160\160\159\159\158\158\157\157\156\156\155\155\154\154\153\153\152\152\151\151\151\150\150\150\150\149\149\148\148\147\147\146\146\146\146\146\145\145\145\145\144\143\143\142\142\142\141\141\141\141\141\141\141\140\140\140\140\140\140\140\139\139\138\138\137\137\137\137\137\137\136\136\135\135\134\134\133\133\132\132\131\130\130\130\129\129\128\128\128\128\128\128\128\128\128\127\127~}}}}}}}}}}|{zyyxxxxxwvvuuttttttttttttttssrrqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqppoonnmmllkkjjiihhggffeeeeeedcba`_^]\\[ZYYYYYYYXXWWVVVVVUUUUUUTTSSSSSRRQQPONNMMMMMLLKKJJJIIIIIIHHHGGFFEEDDCCBBBAA@@??>>==<<;;::99887776665554443333210000000000000000000/////....---------------------------------------------,,++++++++++++++++***************************************************))(((''&&&&&&&&&&&&&&&&&%%$$#######\"\"\"\"!! \031\031\030\029\028\028\028\027\027\026\026\026\026\026\026\026\026\026\026\025\025\024\023\023\022\021\021\021\021\021\020\019\019\018\018\018\017\017\017\016\016\016\016\016\016\015\015") + (8, "\014\r\012\011\n\t\b\007\006\005\004\003\002\001\000\235\235\234\234\233\232\232\231\231\231\231\231\231\231\231\231\231\230\230\229\228\227\227\227\227\227\227\227\227\226\226\226\226\226\226\226\226\225\225\225\224\224\223\222\222\222\221\221\220\220\220\220\220\220\219\219\219\219\219\219\219\218\218\218\218\218\217\217\217\217\216\215\214\214\214\214\213\213\213\213\212\212\212\211\211\211\211\210\209\209\209\208\208\207\207\206\206\206\205\205\205\205\205\205\205\205\205\204\204\203\203\203\203\203\203\203\203\203\203\203\202\202\201\201\200\199\198\197\196\196\195\195\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\193\193\192\191\191\191\191\190\190\190\190\189\189\188\187\187\187\187\187\187\186\185\184\184\183\183\182\182\181\180\180\179\178\178\177\176\175\175\175\174\174\173\172\172\172\172\172\172\171\171\171\171\171\171\171\171\170\170\169\169\169\169\169\169\168\168\167\167\167\166\166\165\165\165\165\164\164\163\163\162\162\161\161\160\160\159\159\158\158\157\157\156\156\155\155\154\154\154\153\153\153\153\152\152\151\151\150\150\149\149\149\149\149\148\148\148\148\147\146\146\145\145\145\144\144\144\144\144\144\144\143\143\143\143\143\143\143\142\142\141\141\140\140\140\140\140\140\139\139\138\138\137\137\136\136\135\135\134\133\133\133\132\132\131\131\131\131\131\131\131\131\131\130\130\129\128\128\128\128\128\128\128\128\128\128\127~}||{{{{{zyyxxwwwwwwwwwwwwwwvvuuttsssssssssssssssssssssssssssssssrrqqppoonnmmllkkjjiihhggffffffedcba`_^]\\[ZZZZZZZYYXXWWWWWVVVVVVUUTTTTTSSRRQPOONNNNNMMLLKKKJJJJJJIIIHHGGFFEEDDCCBBBAA@@??>>==<<;;::998877766655544433210000000000000000000/////....---------------------------------------------,,++++++++++++++++***************************************************))((''&&&&&&&&&&&&&&&&&%%$$#######\"\"\"\"!! \031\031\030\029\028\028\028\027\027\026\026\026\026\026\026\026\026\026\026\025\025\024\023\023\022\021\021\021\021\021\020\019\019\018\018\018\017\017\017\016\016\016\016\016\016\015\015") and goto = - ((16, "\000)\001Q\000S\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\000\000\000\000\000_\000<\000\026\000\251\0001\t\152\000\000\000\000\000\233\000-\t\248\000\181\001\204\nj\000\000\000\000\000\000E\006\000=\003\012\000\025:>\000\000\000\000\000\000\000\000\000\000\000\000\000\00072\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\003<\000\210\000\000\000\000\000\000\000\000\000\221\000\000\004\1581\226\000d\004\178\000@\001H\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\244\000\000\000\000\000\000\000\000\000\000\001@\000\000\000\000\000\000\001\146\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\018\000\000\000\000\002>\000\000\000\000\000\000\000\000\000\000\000\000\000\000/\022\002B\000\000\002V\004\180\001H\000\000\000\000\005t\000k\000\000\005\168\0060\002\166\005\174\000 \000\000\000\000\000\000\000\228\000\000\000\000\002p\000\000\000\000\000\000\000\000\004\016\000\000\003<\000\000\000\000\000\000\000\000\000\000\000>\000\000\003\236\004|\000\128\000\000\003\242/\022\000\000\006\204\000\000\001\188\000\0000\\\000\194\001|\007\174\000\000\000\000\000\000\003B\003\132\005\252\001(\003\138\006\140$\146\003\222\006\144\000\243\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007n\000\000\000\000\000\000\004H\007x\n\166\004\154\007z\n\200\b\154E\006\011v\000\000$\232\004\250\b6\005\246\000\0004\2207\1588$\000\000\000u\000\000\000\000\000\000\005\208>,\006\b\000\000:\138\006t\000\000:\222A\218\000\143\000\000\000\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000;\016\005\244\000\000\000\000\000\000\b\194\000\000\001\216\000\000\000\000\004\020\001j\000\000\000\000\011\b\000\000\t\244\000\000\004\020\002\206\004\020\000\000\000\000\000\000\000\000\000\000B \000\000\bf\007\152\000\000:r\t\b\002\246\000\000\000\000\000\000\007B\000\000\000\000\000\000\000\000\007<\000\000\000\000\000\000\000\000\000\000;\146\000\000\000\000\000\000\000\000\000\000\000\000\001\024\b\012\000\000\000\000\000\000\007<\bH;\216\007\248\t.\012\026\000\000\005*\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\236\000\000\000\000\000\000\000\000\t0f\007\232\000T\000\000\007\232\007\232\000\000\000\000\007\232\000\0008$\000\000\000\000\000\000\007\2328>\000\000\000\000\007\232\000\000\006\004\t\014\000\000\000\000\000\000\000\000\000\000\000\000>\\\000\000\b\162\000\000J2\007<\000\000\000\000\000\000\000\000\b\188\tF\011\1744\238B\254\t\132\000\000\004n\007\232Jt\007<\tl\000\000\000\000\000\000\000\00072\t\222\000\0008bH\206\000\000\012b\tV\t\138\t\158\t<\007\214\t\170\001\132\nR\000\000\000\000\001J\002\184\000\000\002\228\t\182\002\160\t\234\000\000\000\000\004\210\000\000\0024\000$\002\212\000\019\011T\000\000\000\0009\000\000\000P\138\n\248\000\000J\154\007\154\000\000KD%\156\n\190\t\184KR\n\204\t\232\rf\n\208\t\242\r\196\n\224\t\244\00268\170\007\232\014\026\n\248\n\002F\25472\011\156\000\000C\024\014r\011\028\n\018?f\007\232\014\200\011$\n\022?\172\007\232\015&K\140\000\000\000\000\000\000\000\000\000\000\001N\b\240\000\000\000\000\000\000\011D\n \t\194\001\172\015\132\0024\000\000\000\000\000\0004\238\000\000K\150\007<\015|\011R\nXK\154\000\000K\180\000\000\000\000\015\212%\244\000\"\000\000\000\000\012\172K\186\007<3\028\007\003\160\014\136\011\198\014\202\000\000\017\168\007L\014\148\000\000\000\000\000(\0046\n\198\000\000\017\216\0024\n\246\000\000\005`\000\000\014J\011\238\018\\\007\190\000\000\014T\011\242\tB\r&\014h\014r\012\028\016\000\000\000\014\174\004\178\000\000\000\000\000\000\000\000\002\n\012B\014\142M\022\007<\000\000\004X\012T\015J\000\000\000\000\000\000\000\000\000\000\000\000M&\b\218\000\000\012Z\015\164\000\000\000\000\000\000\000\000\000\000\000\000G4\011\030\000\000\012j\005\168\000\000\012\128\012\132\004\180\000\000\006\026Hl\000\000\006\140\000\000M6\007<\007<\000\000\000\000\tP\000\000\005\146\000\000\007\254\tP\tP\000\000\012\152I\n\007\022\000\000\012\216\000\000M\244A \007<\000\000N4\014:\000\000ND\000\000\000\000\000\000\tP\000\000\000\000\012\180\015t\012\214\016\170\015Z\000\000\000\000NV\012\248\015\154\000\000\000\000\000\0003V\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\002\000\000\015\168\r\b\006\162\000\000\016\178\016j\r&\015\202\000\000\000\000\015\208\r\014\006\186\000\000\000\000/&\016\132\r0\015\232\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007<\015\150\rL\016\250\015\166\000\000-@\000\223\rT\015z\007D\000\178\rZ\0168\000\000\016\236\018\238\000\000\000\000\019L\000\000\r\134\000\000\003l\000\000\000\000\000\000\000\000\000\000\000\000Nl\007<\000\000\016\238\019\162\000\000\000\000\019\250\000\000\000c\rd\016\150\000\000C4GX\016P\000\000N\184\007<\020P\000\000\000\000\020\174\000\000\000\000\000\0009$\000\000\021\004\000\000\000\000\000\000\r\184\000\000\004\136\000\000\000\000\000\000\000\000\000\000\000\000Gt\000\000\000\000CrH.\016Z\000\000N\254\007<\021\\\000\000\000\000\021\178\000\000\000\000\r~\022\016\r\194\000\000\r\138\r\144\002~\005\180\r\164\bJ\r\206\016\1845x\r\232\000\000\r\222\014\014\n.\000\000\007\nI0\000\000\000]\000\000\014\020C\128C\184\011\152\015\150\012\128\000\000H\002N\158\000\000\000\000I\212\000\000\000\000\000\000\006p\000\000\000\000\006p\000\000\000\000\006p\nH\000\000\012\250\006p\016\1985\170\014>\000\000\006p\000\000OL\000\000\000\000\006p\000\000\000\000\014f\000\000\014\\\n\164\014l\000\000\014XIB\014\234\000\000\000\000\000\000\014\248\000\000\000\000\b\150\000\000\006pO\154\000\000\015\190\006pD\134\000\000\015\016\0160\014j\017R\015\254\000\000D\204\015\026\016>\000\000\000\000\000\000C\240\tV\014\130\016\2345\228\015\"\000\000\000\000\000\000\000\000\000\000\000\000\0116\000\000\000\000\011B\000\000\0158\000\000\016R\000\000\000\000\000\000\000\000\015>D\000\000\000\000\000\000\000\0116\000\000\011B\000\000\000\000\000\000\000\000\000\000\011N\022f\000\000\000\000\022\190\000\000\000\000\000\000\000\000\023\020\000\000\000\000\011N\023r\000\000\023\200\000\000\000\000\024 \000\000\000\000\000\000\000\000\024v\000\000\000\000/\190\011N\024\212\000\000\000\0000,\011N\025*\000\000\000\0000x\011N\007\138\025\130\000\000\000\0000\202\011N\025\216\000\000\000\0001r\011N\0266\000\000\000\0001\174\011N\000\000\000\000\026\140\000\000\000\0002\016\011N\026\228\000\000\000\0002h\011N\027:\000\000\000\0003\"\011N\000\0003n\011NI\212\011N\000\000\000\000\027\152\000\000\000\000\027\238\000\000\000\000\000\000\011`\028F\000\000\000\000\028\156\000\0009r\000\000\000\000K\140\000\000\000\000\028\250\000\000\000\000\000\000\029P\000\000\000\000\000\000\017\028\000\000\000\000A|\000\000\004\136\000\000\003:\000\000\016\182\000\000\b2\000\000\000\000\000\000\000\000\000\000\001N\000\000\000\000\016\016\000\000\000\000\029\168\000\000\029\254\000\000\000\000\000\000\030\\\000\000\000\000\030\178\016\020\031\n\000\000\031`\000\000\000\000\000\00072\016\182\000\000EL\007&\004\020\031\190\000\000EV\000\000\000\000\000\000E\136\000\000\000\000 \020\000\000 l\000\000\000\000\000\000\000\0009\220\000\000\000\000\000\0003\144\011N3\220\011N\000\000\000\000\000\000\000\000\011N\000\000\000\000\000\000\000\000\011N\000\000\017D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014\174\012X\001\172 \194\000\000\016.\014\182\016\184\011\236\000\000! \000\000\016:\014\188\t\236\016V\014\198\000\000!v\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0003\028\016\220\000\000O\204\007\000\188\001}\004v\001\244\001\251\002\246\002\137\004\245\001\255\001~\001\021\001\135\001j\001\029\000\227\003\020\006\137\000\231\001\002\002\247\005E\001b\001c\002\246\002\139\002\"\001\015\005D\001\170\005F\000\234\004\023\001\021\001\024\000\219\001#\002U\004\247\002\141\000\231\001 \001d\001s\004\024\001f\001g\005\023\004\031\005X\002\148\001\012\002\000\004\248\001\005\001\028\005Y\000\234\004\255\001\029\000\234\003t\005\015\003]\005E\006e\003N\002\001\002\139\000\231\001\015\005Z\006\243\005F\0037\003\144\001\021\001\"\003\004\006\133\002U\005L\002\141\000\231\001\015\001t\005N\001u\002<\004\023\001\021\001\024\005X\002\148\002\246\007A\003\t\005P\003\172\000\234\002\142\004\024\002\152\002\246\001\021\004\025\003\176\000\222\002\158\000\225\001\135\002\144\001\021\005Q\005Z\002\246\001\015\005:\001{\002Q\002R\001c\001\021\001\"\005L\003m\003D\003F\002\246\005N\001l\002\160\001#\000\231\002q\005;\002!\006\164\005B\001\135\005P\006\t\002r\002\142\0037\002\152\000\227\005C\006w\000\231\000\232\002\158\004^\001\135\002\144\002\137\005Q\005\001\004\019\006\131\005g\001\015\001\029\000\231\001\002\001\030\003\016\001\021\001\"\003z\003{\000\234\002\246\000\234\002\160\003)\005D\001\015\001#\004\245\004_\004\129\004`\001\021\001\"\002\246\003\131\006v\003\190\001 \003\132\003b\005!\001}\001\021\003\128\003D\003F\0019\005u\003\202\001~\002\246\001\135\001j\001,\007+\002R\001c\004\247\005\150\004a\005E\000\231\001\002\005\213\002\139\0007\002\024\005#\000\235\005F\001@\001#\004\248\000\240\000\243\006\244\002U\004\255\002\141\000\231\006\183\005\006\001(\005%\001\015\002Q\002R\001c\005X\002\148\001\021\001\024\003S\002%\004b\006z\002#\005\167\005\246\000\231\002q\002\246\002\"\004c\004d\003\219\004e\001E\002r\005&\005Z\001T\001\015\001\029\006\\\001\250\001\030\001\015\001\021\001\"\005L\002\137\003a\001\021\001\024\005N\002\246\001\165\002Q\002R\001c\004\130\000\234\002Q\002R\001c\005P\000\234\000\234\002\142\001 \002\152\000\227\002q\002\246\000\231\001\002\002\158\002q\001\135\002\144\002r\005Q\002\024\002\246\004g\002r\005\191\006\143\002$\004i\004s\007\003\007,\002\137\002\141\000\231\001<\000\251\002\137\002\160\004~\001\250\003y\001#\002\246\000\146\001Z\004\131\004\023\002\025\005\208\002\139\002#\001\163\001(\000\231\004\127\001q\006\170\006\171\004\024\001C\001z\002U\004\030\002\141\000\231\003\143\006\172\006\173\001,\002\246\001\131\001F\001\130\002\145\002\148\007\005\005'\006\174\003b\002Q\002R\001c\001\015\003\158\001\015\003\162\000\146\006\144\001\021\001\"\001\021\001\024\002\139\003\161\002q\002\149\0037\002\139\001\169\000\234\0037\002\246\002r\005#\002U\001\180\002\141\000\231\006\214\002U\004\227\002\141\000\231\002$\003\252\002\137\002\145\002\148\001\185\005%\006:\002\145\002\148\000\234\002\142\002\246\002\152\002Q\002R\001c\002\246\001\199\002\158\001\029\001\135\002\144\001\030\001/\002\149\001\196\001A\003\173\002q\002\149\001#\005&\004\023\003\136\003D\003F\002r\006\152\003D\003F\001\227\002\160\006\207\002\003\004\024\001[\001 \001r\0047\002\137\001\251\006\202\001\211\002\142\001\255\002\152\001\021\001,\002\142\004 \002\152\002\158\002\139\001\135\002\144\002\024\002\158\001E\001\135\002\144\002Q\002R\001c\001\015\002U\001\015\002\141\000\231\005#\001\021\001\"\001\021\001\"\0040\002\160\002q\002\145\002\148\0048\002\160\000\234\001(\002^\002r\005%\002#\001\202\002\000\000\231\006\204\002Q\002R\001c\003\223\003b\005=\002\137\001\213\002\149\000\234\002\139\000\234\002\001\001\222\0021\002q\000\234\002Q\002R\001c\005&\001\015\002U\002r\002\141\000\231\004\026\001\021\001\"\006c\003N\006\"\002q\000\231\002\145\002\148\002\137\002\142\0024\002\152\002r\001\210\002\024\0027\002:\002\158\006`\001\135\002\144\004\235\004\026\002@\000\231\002\137\006\180\004\026\002\149\001\029\002$\002H\001)\002M\005\b\001\216\002\246\000\231\002]\002\139\002\160\002\254\001\224\000\234\002#\002\246\002\246\000\231\001+\000\234\000\234\002U\001\237\002\141\000\231\001#\001 \002\142\005\027\002\152\0061\003b\001\239\002\145\002\148\002\158\002k\001\135\002\144\002\139\002\246\001\254\002\208\006\176\000\234\001\135\002Q\002R\001c\000\234\000\234\002U\001,\002\141\000\231\002\149\002\139\000\234\002\160\002\241\002\246\002q\002\250\002\145\002\148\000\234\002\024\000\234\002U\002r\002\141\000\231\000\234\003\006\002Q\002R\001c\002$\003\177\006Q\002\145\002\148\002\137\003\023\002\142\002\149\002\152\003\191\003\208\002q\006\162\003b\002\158\003\002\001\135\002\144\002#\002r\001\015\000\231\000\234\001\015\002\149\0069\001\021\001\"\000\234\001\021\001\"\002\015\002\137\006\029\003\212\003\028\002\142\002\160\002\152\003-\003>\006\025\003@\002\024\002\158\000\234\001\135\002\144\000\234\0020\003R\001b\001c\002\142\004\007\002\152\0023\003`\0026\000\234\005\001\002\158\002\246\001\135\002\144\002\139\0029\002\160\003f\000\234\003\024\001d\001e\002#\001f\001g\000\231\002U\002?\002\141\000\231\002$\003s\002C\002\160\001#\002Q\002R\001c\002\145\002\148\003\134\001\029\002\139\000\227\001\030\002G\000\231\000\232\000\234\002L\002q\003\171\000\234\000\234\002U\000\234\002\141\000\231\002r\001\227\002\149\001,\002\005\000\234\0066\002\\\002\145\002\148\001 \001\251\000\234\002\137\002j\001\255\003\175\001\021\004\245\003\181\002Q\002R\001c\000\234\002|\004'\006+\002$\005H\003\187\002\149\002\142\003\198\005l\005K\002q\002\157\000\234\001k\002\158\002\246\001\135\002\144\002r\001\029\002\225\000\234\004C\004\247\006!\001l\002\024\003\217\000\231\003\222\001(\002\137\000\234\002\000\002\142\002\249\002\152\002\160\004\248\002Q\002R\001c\002\158\004\255\001\135\002\144\001 \005\003\002\001\002\139\003\227\002\246\002\240\006$\002q\000\234\002#\003\011\000\234\000\231\001\015\002U\002r\002\141\000\231\002\160\001\021\001\"\000\234\003\237\002\242\000\234\006\031\002\145\002\148\002\137\000\227\002\245\003\243\000\231\000\232\003\254\002Q\002R\001c\002\246\003\014\004+\001}\004\t\002\246\000\234\002\139\000\234\002\252\002\149\001\134\002q\001\135\001j\004\027\003\r\004\r\003\007\002U\002r\002\141\000\231\002\246\004\245\003\n\006\016\004\"\002\246\000\234\006\139\002\145\002\148\002\137\002$\0042\001\015\001#\004S\002\142\004<\002\152\001\021\001\"\002Q\002R\001c\002\158\000\234\001\135\002\144\002\139\000\227\002\149\004\247\000\231\000\232\000\234\004U\002q\000\234\003\022\003\027\002U\001,\002\141\000\231\002r\000\234\004\248\002\160\002\246\004[\006\n\004\255\002\145\002\148\004h\005\000\000\234\002\137\000\234\002\142\004k\002\152\004\245\004u\002Q\002R\001c\002\158\000\234\001\135\002\144\002\139\004p\002\246\002\149\001#\000\234\004{\002\246\002q\003!\000\234\003(\002U\003'\002\141\000\231\002r\001\029\003,\002\160\004J\004\247\005\255\004\134\002\145\002\148\002\246\004\140\000\234\002\137\004\144\001,\002\142\003_\005l\004\172\004\248\002Q\002R\001c\002\158\004\255\001\135\002\144\001 \005\n\002\149\002\139\004\218\004\153\003e\003r\002q\000\234\005\025\003v\000\234\004\223\003x\002U\002r\002\141\000\231\002\160\003\133\003\142\005\240\005\011\003\147\002\246\003\159\002\145\002\148\002\137\004\194\002\142\003\157\002\152\003\160\004\220\002Q\002R\001c\002\158\003\164\001\135\002\144\000\234\004\228\002\246\002\139\000\234\002\246\002\149\000\234\002q\005\007\001\227\004\231\000\234\002\031\003\174\002U\002r\002\141\000\231\002\160\001\251\003\170\005\229\002\024\001\255\000\234\001\021\002\145\002\148\002\137\003\186\000\234\001\015\004\234\000\234\002\142\004\242\002\152\001\021\001\"\002Q\002R\001c\002\158\000\234\001\135\002\144\002\139\000\227\002\149\006W\000\231\000\232\002#\005\014\002q\000\231\003\180\003\182\002U\003\205\002\141\000\231\002r\003\193\000\234\002\160\002\000\002\246\005\221\005\030\002\145\002\148\000\234\005\024\002\246\002\137\005\028\002\142\0052\002\152\004\245\002\001\002Q\002R\001c\002\158\002\246\001\135\002\144\002\139\005>\002\246\002\149\001#\003\204\002\246\000\234\002q\003\199\000\234\003\203\002U\003\216\002\141\000\231\002r\002\246\003\221\002\160\002\246\004\247\005\180\006#\002\145\002\148\002$\006)\004;\002\137\0060\001,\002\142\003\226\002\152\0063\004\248\002Q\002R\001c\002\158\004\255\001\135\002\144\000\234\005\026\002\149\002\139\002\246\002\246\005 \002\246\002q\000\234\006V\006t\003\229\005$\003\233\002U\002r\002\141\000\231\002\160\003\241\000\234\003\248\006~\004\003\0050\005\172\002\145\002\148\002\137\0057\002\142\004:\002\152\005A\002\246\002Q\002R\001c\002\158\0043\001\135\002\144\000\234\006\128\005M\002\139\000\234\005T\002\149\000\234\002q\006\165\001\227\006\177\000\234\002`\0044\002U\002r\002\141\000\231\002\160\001\251\0049\002\135\002\024\001\255\002\246\001\021\002\145\002\148\002\137\004=\000\234\000\234\006N\006x\002\142\006\191\002\152\004>\004]\002Q\002R\001c\002\158\000\234\001\135\002\144\002\139\000\227\002\149\006u\000\231\000\232\002#\004V\002q\000\231\004W\004\\\002U\004r\002\141\000\231\002r\0074\000\234\002\160\002\000\002\246\002\147\004n\002\145\002\148\000\234\004o\000\234\002\137\004q\002\142\004}\002\152\004\245\002\001\002Q\002R\001c\002\158\004z\001\135\002\144\002\139\004|\004\133\002\149\004\135\004\136\004\141\007?\002q\004\145\004\149\004\167\002U\004\173\002\141\000\231\002r\001\227\004\177\002\160\002\244\004\247\002\151\004\208\002\145\002\148\002$\001\251\004\229\002\137\005\002\001\255\002\142\001\021\005l\005\012\004\248\002Q\002R\001c\002\158\004\255\001\135\002\144\0059\005,\002\149\002\139\0053\0054\007D\0058\002q\005?\001\227\005O\005\202\003\000\005\211\002U\002r\002\141\000\231\002\160\001\251\005\224\002\166\005\235\001\255\005\243\001\021\002\145\002\148\002\137\002\000\002\142\006\027\002\152\006(\006*\002Q\002R\001c\002\158\006/\001\135\002\144\0062\006?\002\001\002\139\006U\006^\002\149\006\160\002q\006\182\007&\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\001\227\000\000\002\165\003\184\002\000\000\000\000\000\002\145\002\148\002\137\001\251\000\000\000\000\000\000\001\255\002\142\001\021\002\152\000\000\002\001\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\001\227\002q\000\000\003\195\000\000\002U\000\000\002\141\000\231\002r\001\251\000\000\002\160\000\000\001\255\002\213\001\021\002\145\002\148\000\000\000\000\000\000\002\137\002\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\001\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\001\227\000\000\002\160\003\201\002\000\002\216\000\000\002\145\002\148\000\000\001\251\000\000\002\137\000\000\001\255\002\142\001\021\002\152\000\000\002\001\002Q\002R\001c\002\158\001\227\001\135\002\144\003\210\000\000\002\149\002\139\000\000\000\000\000\000\001\251\002q\000\000\000\000\001\255\000\000\001\021\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\002\237\000\000\000\000\000\000\000\000\002\145\002\148\002\137\002\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\001\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\002\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\001\227\000\000\004\148\003\218\000\000\000\000\002\001\002\145\002\148\002\137\001\251\000\000\000\000\000\000\001\255\002\142\001\021\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\001\227\002q\000\000\006Z\000\000\002U\000\000\002\141\000\231\002r\001\251\000\000\002\160\000\000\001\255\004\151\001\021\002\145\002\148\000\000\000\000\000\000\002\137\002\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\001\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\001\227\000\000\002\160\006i\002\000\004\166\000\000\002\145\002\148\000\000\001\251\000\000\002\137\000\000\001\255\002\142\001\021\002\152\000\000\002\001\002Q\002R\001c\002\158\001\227\001\135\002\144\006l\000\000\002\149\002\139\000\000\000\000\000\000\001\251\002q\000\000\000\000\001\255\000\000\001\021\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\004\169\000\000\000\000\000\000\000\000\002\145\002\148\002\137\002\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\001\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\002\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\001\227\000\000\004\181\006o\000\000\000\000\002\001\002\145\002\148\002\137\001\251\000\000\000\000\000\000\001\255\002\142\001\021\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\004\184\000\000\002\145\002\148\000\000\000\000\000\000\002\137\002\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\001\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\004\190\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\004\212\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\004\215\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\004\219\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\005b\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005e\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\005j\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005n\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005p\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\005s\002\145\002\148\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\005x\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005}\000\000\000\000\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\130\000\000\000\000\002\137\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\136\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\141\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\005\146\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\153\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\005\158\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\005\163\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\175\000\000\000\000\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\178\000\000\000\000\002\137\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\183\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\186\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\195\000\000\000\000\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\005\199\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\225\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\227\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\005\231\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\005l\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\005\234\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\236\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\005\238\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\005\248\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006\001\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006\004\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006&\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006-\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\0065\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006C\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006H\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006K\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006\211\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006\213\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\006\216\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006\221\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\006\223\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\152\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\006f\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\006O\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\006\024\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\006\019\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\005\171\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\005`\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\154\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\156\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\161\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\168\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\170\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\172\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\174\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\176\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\178\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\180\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\182\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\184\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\186\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\188\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\190\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\192\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\001b\001c\000\000\002\139\000\000\000\000\002\149\000\000\002q\000\000\000\000\000\000\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\001d\004\186\000\000\001f\001g\000\000\000\000\002\145\002\148\002\137\000\000\000\000\000\000\000\000\000\000\002\142\000\000\002\194\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\000\000\002\160\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\000\000\002\137\000\000\002\142\000\000\002\196\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\002\139\000\000\000\000\002\149\000\000\000\000\001k\000\000\002q\000\000\000\000\000\000\002U\000\000\002\141\000\231\002r\000\000\001l\002\160\000\000\000\231\000\000\004^\002\145\002\148\000\000\000\000\000\000\002\137\000\000\000\000\002\142\000\000\002\198\000\000\000\000\002Q\002R\001c\002\158\000\000\001\135\002\144\000\000\000\000\002\149\002\139\000\000\000\000\000\000\004_\002q\004`\000\000\005-\000\000\000\000\000\000\002U\002r\002\141\000\231\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\137\000\000\002\142\000\000\002\200\000\000\000\000\000\000\001}\004a\002\158\001\029\001\135\002\144\001\030\000\000\001\134\002\139\001\135\001j\002\149\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002U\005/\002\141\000\231\002\160\000\000\000\000\000\000\000\000\001 \000\000\001\029\002\145\002\148\001\030\004b\000\000\000\000\000\000\000\000\002\142\000\000\002\202\000\000\004c\004d\003t\004e\002\158\000\000\001\135\002\144\002\139\000\000\002\149\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\000\000\001\029\002\160\004\128\001\030\001(\003t\002\145\002\148\001\029\000\000\000\000\001\030\000\000\002\142\000\000\002\204\000\000\000\000\003w\000\000\000\000\002\158\000\000\001\135\002\144\000\000\004g\001 \002\149\006\140\000\000\004i\004s\001(\001\015\001 \000\000\000\000\000\000\000\000\001\021\001\"\004~\000\000\002\160\000\000\000\000\003\156\000\000\000\000\000\000\000\000\003t\000\000\000\000\000\000\000\000\002\142\004\127\002\206\000\000\000\000\000\000\001\015\000\000\002\158\000\000\001\135\002\144\001\021\001\"\000\000\001(\000\000\000\000\000\000\002Q\002R\001c\000\000\001(\000\000\000\000\000\000\003z\003{\000\000\000\000\002\160\001<\000\000\002q\000\000\000\000\004y\000\000\001#\000\000\000\000\002r\003|\003\140\001\015\000\000\000\000\003\132\003b\000\000\001\021\001\"\001\015\000\000\002\137\003z\003{\000\000\001\021\001\"\001<\000\000\000\000\000\000\000\000\001,\000\000\001#\001F\000\000\000\000\003|\003\140\002Q\002R\001c\003\132\003b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\000\000\000\000\000\000\001,\000\000\002r\001F\000\000\001<\000\000\000\000\003z\003{\000\000\001\029\001#\001<\001\030\002\137\006\147\002Q\002R\001c\001#\002\139\000\000\000\000\003|\003\140\000\000\000\000\000\000\003\132\003b\000\000\002q\002U\000\000\002\141\000\231\000\000\001 \001,\002r\000\000\001F\000\000\000\000\002\145\002\148\001,\003:\000\000\001F\000\000\000\000\002\137\000\000\000\000\000\000\000\000\002Q\002R\001c\000\000\006}\000\000\000\000\000\000\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002q\000\000\000\000\002\139\000\000\000\000\000\000\000\000\002r\000\000\001(\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\000\000\002\137\000\000\002\142\000\000\005{\000\000\002\145\002\148\000\000\000\000\002\158\000\000\001\135\002\144\000\000\000\000\000\000\000\000\000\000\001\015\002\139\000\000\000\000\000\000\000\000\001\021\001\"\000\000\002\149\000\000\000\000\000\000\002U\002\160\002\141\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\000\000\000\000\002Q\002R\001c\000\000\000\000\000\000\000\000\000\000\000\000\002\142\000\000\005\128\000\000\002\139\000\000\002q\000\000\002\158\002\149\001\135\002\144\000\000\000\000\002r\000\000\002U\001<\002\141\000\231\000\000\002Q\002R\001c\001#\000\000\000\000\002\137\002\145\002\148\000\000\002\160\000\000\000\000\000\000\000\000\002q\000\000\002\142\000\000\005\133\000\000\000\000\000\000\002r\004^\002\158\000\000\001\135\002\144\002\149\001,\000\000\000\000\003A\000\000\000\000\002\137\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\160\002Q\002R\001c\004_\006\192\004`\000\000\000\000\000\000\002\142\000\000\005\139\000\000\000\000\000\000\002q\000\000\002\158\002\139\001\135\002\144\000\000\000\000\002r\000\000\000\000\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\004a\000\000\002\137\000\000\000\000\000\000\002\160\000\000\002\145\002\148\002Q\002R\001c\000\000\002\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002q\002U\000\000\002\141\000\231\002\149\000\000\000\000\002r\000\000\004b\000\000\000\000\002\145\002\148\000\000\000\000\000\000\000\000\004c\004d\002\137\004e\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\002\149\005\144\000\000\002\139\000\000\000\000\000\000\002\158\000\000\001\135\002\144\000\000\004\130\000\000\000\000\002U\000\000\002\141\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\148\002\142\002\160\005\149\000\000\000\000\000\000\000\000\004g\002\158\000\000\001\135\002\144\004i\004s\002Q\002R\001c\000\000\002\139\001\029\002\149\000\000\001\030\004~\000\000\000\000\000\000\000\000\000\000\002q\002U\002\160\002\141\000\231\000\000\000\000\000\000\002r\004^\004\127\000\000\000\000\002\145\002\148\000\000\000\000\001 \000\000\000\000\002\142\002\137\005\156\002Q\002R\001c\000\000\006D\002\158\000\000\001\135\002\144\000\000\000\000\000\000\002\149\000\000\004_\002q\004`\002Q\002R\001c\000\000\000\000\000\000\002r\000\000\000\000\000\000\000\000\002\160\000\000\000\000\000\000\002q\000\000\000\000\000\000\002\137\000\000\000\000\001(\002r\002\142\000\000\005\161\000\000\004a\000\000\000\000\000\000\002\158\000\000\001\135\002\144\002\137\000\000\002Q\002R\001c\000\000\002\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\015\002q\002U\002\160\002\141\000\231\001\021\001\"\000\000\002r\000\000\004b\000\000\000\000\002\145\002\148\000\000\000\000\000\000\000\000\004c\004d\002\137\004e\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\149\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\002\139\000\000\000\000\004f\000\000\000\000\000\000\002\145\002\148\000\000\001<\000\000\002U\000\000\002\141\000\231\000\000\001#\000\000\000\000\002\142\002y\005\166\000\000\002\145\002\148\000\000\004g\002\158\002\149\001\135\002\144\004i\004s\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\000\000\004~\001,\000\000\002\149\001F\000\000\000\000\002U\002\160\002\141\000\231\000\000\000\000\000\000\000\000\002\142\004\127\005\169\000\000\002\145\002\148\000\000\000\000\002\158\000\000\001\135\002\144\001\174\001c\000\000\000\000\000\000\002\142\000\000\006\012\000\000\001\188\001c\000\000\000\000\002\158\002\149\001\135\002\144\000\000\000\000\002\160\002\209\001s\000\000\001f\001g\000\000\001\174\001c\000\000\001d\002e\000\000\001f\001g\000\000\000\000\002\160\000\000\000\000\000\000\000\000\000\000\000\000\002\142\000\000\006\014\002\209\001s\000\000\001f\001g\002\158\000\000\001\135\002\144\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\214\002\226\002\227\000\000\000\000\000\000\000\000\000\000\000\000\005\181\002\226\002\227\002\160\000\000\000\000\000\000\001\174\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\214\002\226\002\227\000\000\000\000\000\000\000\000\000\000\001{\000\000\002\209\001s\000\000\001f\001g\001\174\001c\001{\000\000\000\000\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001{\002\209\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001\174\001c\001l\000\000\000\000\000\231\000\000\000\000\002\214\002\226\002\227\002\230\006M\000\000\000\000\005\184\005\189\000\000\000\000\000\000\002\209\001s\000\000\001f\001g\005:\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\214\002\226\002\227\000\000\002\230\002\231\001}\007:\000\000\001{\007;\000\000\000\000\005B\001~\001}\001\135\001j\000\000\000\000\000\000\001l\005C\001~\000\231\001\135\001j\000\000\000\000\002\214\002\226\002\227\001}\000\000\001{\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\135\001j\000\000\000\000\001l\000\000\000\000\000\231\000\000\005D\000\000\000\000\000\000\000\000\002\230\004\230\000\000\000\000\000\000\000\000\000\000\001{\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\001b\001c\002\230\005\r\000\000\001}\001d\001s\005E\001f\001g\000\000\000\000\001~\000\000\001\135\001j\005F\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\006\206\001}\002\230\005@\000\000\000\000\000\000\005G\002\148\001~\007=\001\135\001j\000\000\006\209\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\002<\000\000\000\000\001b\001c\000\000\005J\001}\000\000\000\000\000\000\001t\000\000\001u\002<\001~\005L\001\135\001j\000\000\000\000\005N\000\000\001d\001s\000\000\001f\001g\000\000\000\000\001{\000\000\005P\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\001{\000\231\000\000\000\000\005Q\000\000\000\000\000\000\000\000\006\t\000\000\000\000\001l\001b\001c\000\231\000\000\000\000\000\000\000\000\000\000\000\000\001t\006\t\001u\001\139\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\001\172\000\000\000\000\000\000\000\000\000\000\000\146\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\001l\000\000\001~\000\231\001\135\001j\000\000\000\000\001}\001t\000\000\001u\001\160\001b\001c\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001{\001\158\001b\001c\001d\001s\000\000\001f\001g\000\000\000\000\004\188\001l\000\000\001\162\000\231\000\000\000\000\000\000\004\191\000\000\001}\001d\004\186\000\000\001f\001g\000\000\000\000\001~\000\000\001\135\001j\000\000\001t\000\000\001u\001\160\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\001\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\001l\001{\000\000\000\231\001~\000\000\001\135\001j\000\000\001\029\000\000\000\000\001\030\001l\000\000\000\000\000\231\000\000\000\000\001k\001b\001c\001t\000\000\001u\002<\000\000\000\000\000\000\004\188\000\000\001l\000\000\000\000\000\231\000\000\001 \004\191\000\000\000\000\001d\004\186\000\000\001f\001g\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\001\188\001c\000\000\000\000\001}\000\000\000\000\000\000\001l\004\187\000\000\000\231\001~\000\000\001\135\001j\000\000\001}\000\000\006\005\001d\002e\001(\001f\001g\001~\000\000\001\135\001j\000\000\0067\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\001\015\001b\001c\000\000\000\000\001k\001\021\001\"\000\000\000\000\005\181\002\226\002\227\000\000\000\000\000\000\000\000\001l\000\000\001}\000\231\001d\001s\000\000\001f\001g\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\001b\001c\000\000\000\000\004\187\001<\001l\001d\001s\000\231\001f\001g\001#\000\000\001t\000\000\001u\002<\000\000\000\000\001d\001s\000\000\001f\001g\004\192\000\000\000\000\000\000\000\000\001}\000\000\000\000\001\029\000\000\000\000\001\030\005\188\001\134\001,\001\135\001j\001\236\000\000\000\000\001\029\000\000\001{\001\030\000\000\001t\0010\001u\007\027\000\000\007\029\000\000\000\000\000\000\001l\001 \000\000\000\231\001t\000\000\001u\006\196\000\000\001:\001}\006\b\0011\001 \000\000\000\000\000\000\000\000\001~\001O\001\135\001j\000\000\000\000\001{\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\0010\000\000\001l\001{\000\000\000\231\000\000\000\000\000\000\000\000\000\000\000\000\001(\000\000\000\000\001l\000\000\000\000\000\231\001\029\0011\001 \001\030\000\000\001(\0010\000\000\001M\000\000\001}\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\135\001j\0016\001\015\000\000\000\000\0011\001 \000\000\001\021\001\"\000\000\000\000\0012\000\000\001\015\000\000\000\000\000\000\000\000\000\000\001\021\001\"\000\000\000\000\000\000\001}\001(\000\000\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\135\001j\000\000\001}\000\000\000\000\000\000\000\000\0016\001\029\000\000\001~\001\030\001\135\001j\0010\001(\000\000\000\000\000\000\000\000\001\015\001<\000\000\000\000\000\000\000\000\001\021\001\"\001#\000\000\000\000\000\000\0016\001<\0011\001 \001b\001c\000\000\000\000\001#\001K\000\000\000\000\001D\001\015\000\000\000\000\000\000\004^\000\000\001\021\001\"\000\000\000\000\001,\001d\001s\001B\001f\001g\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\001F\000\000\000\000\000\000\000\000\001<\000\000\004_\006\229\004`\001(\000\000\001#\000\000\000\000\000\000\001D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0016\000\000\001t\001<\001u\001\164\000\000\000\000\001b\001c\001#\004a\001,\001\015\001D\001F\000\000\000\000\000\000\001\021\001\"\001b\001c\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\001{\000\000\001,\000\000\000\000\001F\001d\001s\000\000\001f\001g\004b\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\004c\004d\000\000\004e\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001<\000\000\000\000\001t\000\000\001u\001\154\001#\000\000\001b\001c\001D\000\000\000\000\000\000\004\130\001t\000\000\001u\001\151\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\001,\000\000\001{\001F\000\000\004g\006\231\000\000\001}\000\000\004i\004s\000\000\000\000\001l\001{\001~\000\231\001\135\001j\000\000\004~\000\000\000\000\000\000\000\000\000\000\001l\001b\001c\000\231\000\000\000\000\000\000\000\000\000\000\000\000\004\127\001t\000\000\001u\001w\001b\001c\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\001b\001c\000\000\000\000\000\000\000\000\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\001d\001s\001}\001f\001g\000\000\000\000\000\000\001l\000\000\001~\000\231\001\135\001j\000\000\001}\001t\000\000\001u\001y\000\000\000\000\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\001t\000\000\001u\001|\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\001\150\000\000\000\000\001{\000\000\000\000\000\000\000\000\001d\001s\001\029\001f\001g\004G\000\000\001l\000\000\001{\000\231\000\000\000\000\001\029\000\000\000\000\001\030\001}\000\000\000\000\000\000\001l\001{\000\000\000\231\001~\000\000\001\135\001j\001 \001b\001c\000\000\000\000\001l\001b\001c\000\231\000\000\006I\001 \000\000\000\000\001t\000\000\001u\001\142\006L\000\000\000\000\001d\004\186\000\000\001f\001g\001d\001s\000\000\001f\001g\002Q\002R\001c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\004I\000\000\001{\000\000\001~\000\000\001\135\001j\000\000\005\205\001}\001(\000\000\000\000\001l\000\000\005\214\000\231\001~\000\000\001\135\001j\000\000\001}\001t\000\000\001u\001\147\000\000\000\000\001\015\001~\000\000\001\135\001j\000\000\001\021\004L\000\000\006\022\000\000\001\015\000\000\000\000\000\000\000\000\000\000\001\021\001\"\000\000\000\000\000\000\001k\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\002T\000\000\001~\000\000\001\135\001j\001b\001c\000\000\004M\000\000\000\000\005\217\001<\002\141\000\231\001\002\000\000\004\187\000\000\001#\004\024\000\000\004R\001V\004O\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\000\000\000\000\001b\001c\000\000\001}\000\000\000\000\001,\000\000\001}\001F\005\208\001\134\000\000\001\135\001j\000\000\001~\000\000\001\135\001j\001d\001s\000\000\001f\001g\000\000\001b\001c\001t\000\000\001u\002I\001b\001c\002\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\143\000\000\001\135\002\144\001d\001s\000\000\001f\001g\000\000\001d\001s\000\000\001f\001g\000\000\001b\001c\000\000\001{\000\000\001t\000\000\001u\002N\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\000\000\001t\000\000\001u\002\218\001b\001c\001t\001{\001u\002\220\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001d\001s\000\000\001f\001g\000\000\000\000\000\000\001t\001{\001u\002\222\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\001l\000\000\001}\000\231\000\000\000\000\001l\000\000\000\000\000\231\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\001b\001c\001{\000\000\001t\000\000\001u\002\229\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001}\001d\001s\000\000\001f\001g\000\000\000\000\001~\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\001\029\000\000\000\000\001\030\001}\000\000\001G\000\000\001l\000\000\001}\000\231\001~\000\000\001\135\001j\000\000\000\000\001~\000\000\001\135\001j\001t\000\000\001u\002\235\001I\001 \000\000\000\000\000\000\000\000\004\017\000\000\000\000\000\000\001}\000\000\002Q\002R\001c\000\000\000\000\000\000\001~\000\000\001\135\001j\005:\000\000\000\000\000\000\000\000\000\000\000\000\001{\000\000\000\000\000\000\000\000\000\000\005\205\000\000\007:\000\000\000\000\007;\001l\005\214\005B\000\231\001}\001(\000\000\000\000\000\000\000\000\000\000\005C\001~\000\000\001\135\001j\005:\000\000\000\000\000\000\000\000\000\000\0016\000\000\005\215\000\000\001\029\000\000\000\000\001\030\000\000\007:\001G\000\000\007;\001\015\000\000\005B\000\000\000\000\005D\001\021\001\"\000\000\000\000\000\000\005C\000\000\000\000\000\000\000\000\005:\001I\001 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\001}\001\030\000\000\007:\0010\002T\007;\000\000\001~\005B\001\135\001j\005D\005E\000\000\000\000\000\000\005\217\005C\002\141\000\231\001\002\005F\000\000\0015\001 \000\000\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\001(\000\000\000\000\004F\000\000\000\000\005G\002\148\000\000\007<\000\000\000\000\005D\005E\000\000\000\000\000\000\0016\000\000\000\000\000\000\005\208\005F\000\000\000\000\000\000\001,\000\000\005J\001F\001\015\000\000\000\000\000\000\000\000\001(\001\021\001\"\005L\000\000\000\000\005G\002\148\005N\007@\002\142\000\000\000\000\005E\000\000\000\000\000\000\0016\002\143\005P\001\135\002\144\005F\000\000\000\000\000\000\000\000\000\000\005J\000\000\001\015\000\000\001b\001c\000\000\005Q\001\021\001\"\005L\000\000\000\000\005G\002\148\005N\007E\001b\001c\000\000\000\000\0068\001<\000\000\001d\004\186\005P\001f\001g\001#\000\000\001b\001c\001D\000\000\005J\000\000\001d\004\186\000\000\001f\001g\005Q\000\000\000\000\005L\000\000\000\000\004\185\000\000\005N\001d\004\186\000\000\001f\001g\001,\001<\000\000\001F\000\000\005P\001b\001c\001#\000\000\000\000\000\000\001D\001b\001c\000\000\000\000\000\000\000\000\000\000\000\000\005Q\000\000\004\216\000\000\000\000\001d\004\186\000\000\001f\001g\000\000\000\000\001d\004\186\001,\001f\001g\001F\000\000\000\000\001b\001c\000\000\001k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001k\000\000\000\231\000\000\001d\004\186\000\000\001f\001g\005:\000\000\000\000\001l\000\000\001k\000\231\000\000\005:\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\005;\000\000\000\231\005B\000\000\000\000\000\000\000\000\005;\004\187\000\000\005B\005C\000\000\000\000\000\000\000\000\000\000\001k\000\000\005C\000\000\005\249\000\000\000\000\001k\000\000\000\000\000\000\000\000\001l\000\000\000\000\000\231\000\000\001}\004\187\001l\000\000\000\000\000\231\005D\005\252\001\134\000\000\001\135\001j\000\000\001}\005D\000\000\000\000\000\000\001k\000\000\000\000\001\134\000\000\001\135\001j\001b\001c\001}\000\000\000\000\001l\000\000\004\187\000\231\000\000\001\134\000\000\001\135\001j\004\243\000\000\000\000\005E\000\000\000\000\001d\004\186\000\000\001f\001g\005E\005F\000\000\000\000\000\000\000\000\000\000\000\000\001}\005F\001b\001c\000\000\000\000\000\000\001}\001\134\004\243\001\135\001j\005G\002\148\000\000\001\134\000\000\001\135\001j\005I\005G\002\148\001d\004\186\000\000\001f\001g\005U\005\005\000\000\002Q\002R\001c\000\000\005J\001}\000\000\000\000\000\000\000\000\000\000\000\000\005J\001\134\005L\001\135\001j\000\000\000\000\005N\000\000\000\000\005L\006S\000\000\000\000\005\004\005N\000\000\000\000\005P\000\000\000\000\001k\000\000\000\000\001b\001c\005P\000\000\000\000\001b\001c\000\000\000\000\001l\005Q\000\000\000\231\000\000\000\000\000\000\000\000\000\000\005Q\000\000\001d\004\186\000\000\001f\001g\001d\004\186\000\000\001f\001g\001b\001c\001k\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\000\000\005-\000\231\000\000\000\000\001d\004\186\000\000\001f\001g\000\000\000\000\000\000\000\000\000\000\000\000\002T\000\000\000\000\000\000\000\000\000\000\000\000\005:\000\000\000\000\000\000\001}\002U\000\000\002\141\000\231\000\000\000\000\000\000\001\134\005-\001\135\001j\000\000\000\000\005;\000\000\000\000\005B\000\000\000\000\000\000\000\000\005.\000\000\001k\000\000\005C\000\000\000\000\001k\005:\000\000\000\000\000\000\001\029\001}\001l\001\030\000\000\000\231\000\000\001l\000\000\001\134\000\231\001\135\001j\000\000\0071\000\000\000\000\005B\000\000\000\000\001k\005D\000\000\0056\000\000\000\000\005C\001 \000\000\000\000\002\142\000\000\001l\000\000\000\000\000\231\000\000\003\031\002\143\005\249\001\135\002\144\000\000\000\000\005\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\190\000\000\000\000\005D\000\000\005E\000\000\005\251\000\000\000\000\000\000\000\000\005\250\001}\005F\000\000\000\000\005\249\001}\000\000\001(\001\134\000\000\001\135\001j\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\005G\002\148\001\029\000\000\005\254\001\030\005E\006y\000\000\000\000\001}\000\000\000\000\000\000\000\000\005F\000\000\001\015\001\134\000\000\001\135\001j\005J\001\021\001\"\000\000\001b\001c\000\000\001 \000\000\000\000\005L\000\000\005G\002\148\000\000\005N\0072\003\031\000\000\000\000\000\000\000\000\000\000\000\000\001d\004\186\005P\001f\001g\000\000\000\000\000\000\003$\000\000\005J\000\000\000\000\000\000\001\029\000\000\000\000\001\030\005Q\000\000\005L\000\000\000\000\000\000\000\000\005N\001<\000\000\001(\000\000\000\000\000\000\001\029\001#\000\000\001\030\005P\003*\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\003\031\005Q\000\000\000\000\000\000\000\000\000\000\001\015\001 \001,\000\000\000\000\001F\001\021\001\"\004\006\000\000\000\000\003\031\000\000\000\000\000\000\001 \000\000\000\000\001k\000\000\000\000\001b\001c\000\000\000\000\003\031\004\182\000\000\001(\000\000\001l\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\000\000\004\203\001d\001\133\000\000\001f\001g\001(\000\000\000\000\000\000\000\000\002Q\002R\001c\000\000\001<\000\000\000\000\001\015\000\000\001(\000\000\001#\000\000\001\021\001\"\003*\005\253\000\000\000\000\000\000\000\000\000\000\000\000\004\251\000\000\001\015\000\000\000\000\000\000\000\000\001\029\001\021\001\"\001\030\000\000\000\000\000\000\000\000\001,\001\015\000\000\001F\001}\000\000\000\000\001\021\001\"\004\252\000\000\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\001 \000\000\000\000\000\000\001\029\001<\000\000\001\030\000\000\001k\003\031\000\000\001#\000\000\000\000\000\000\003*\000\000\000\000\000\000\000\000\001l\000\000\001<\000\231\004\213\000\000\000\000\000\000\000\000\001#\001 \000\000\000\000\003*\000\000\004\017\001<\000\000\001,\002T\000\000\001F\000\000\001#\001(\001b\001c\003*\000\000\001\029\000\000\002U\001\030\002\141\000\231\000\000\001,\000\000\000\000\001F\000\000\000\000\000\000\000\000\000\000\001d\001\205\000\000\001f\001g\001,\000\000\000\000\001F\001\015\001(\001 \000\000\000\000\000\000\001\021\001\"\001\029\001}\000\000\001\030\003:\000\000\000\000\004\254\000\000\001\134\000\000\001\135\001j\000\000\000\000\000\000\000\000\000\000\003=\001\029\000\000\000\000\001\030\001\015\000\000\000\000\000\000\001 \001\029\001\021\001\"\001\030\002\142\000\000\000\000\000\000\000\000\000\000\000\000\001(\002\143\000\000\001\135\002\144\000\000\000\000\001 \001<\000\000\000\000\000\000\004\238\000\000\000\000\001#\001 \000\000\000\000\003*\001k\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\000\000\001\015\000\000\001l\001(\000\000\000\231\001\021\001\"\000\000\001<\000\000\001\029\001,\000\000\001\030\001F\001#\000\000\000\000\001 \004\022\000\000\001(\000\000\002Q\002R\001c\000\000\000\000\000\000\000\000\001(\000\000\001\015\000\000\000\000\000\000\000\000\001 \001\021\001\"\000\000\000\000\001,\000\000\000\000\001F\004\251\000\000\000\000\000\000\000\000\001\015\000\000\000\000\001<\000\000\000\000\001\021\001\"\006\255\001\015\001#\000\000\001(\001}\000\000\001\021\001\"\000\000\000\000\000\000\000\000\001\134\000\000\001\135\001j\000\000\000\000\001\029\000\000\000\000\001\030\001(\000\000\000\000\000\000\000\000\001<\001,\000\000\000\000\003A\000\000\001\015\001#\000\000\000\000\000\000\004#\001\021\001\"\004&\000\000\000\000\000\000\001 \001<\000\000\000\000\000\000\000\000\001\029\001\015\001#\001\030\001<\000\000\004\022\001\021\001\"\002T\001,\001#\000\000\001F\000\000\004#\000\000\000\000\005\031\001\029\000\000\002U\001\030\002\141\000\231\000\000\000\000\001 \001\029\001,\000\000\001\030\001F\000\000\000\000\000\000\000\000\001<\001,\001(\000\000\001F\000\000\000\000\001#\000\000\001 \000\000\007\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \001<\000\000\000\000\004\253\000\000\000\000\000\000\001#\000\000\000\000\000\000\001\144\000\000\001\015\000\000\001,\001(\000\000\001F\001\021\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\142\000\000\000\000\000\000\000\000\000\000\001,\001(\002\143\001F\001\135\002\144\002Q\002R\001c\000\000\001(\000\000\001\015\002Q\002R\001c\000\000\000\000\001\021\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\021\000\000\001\015\000\000\000\000\001<\000\000\006\018\001\021\001\"\000\000\001\015\001#\002Q\002R\001c\001\179\001\021\001\"\000\000\002Q\002R\001c\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\002Q\002R\001c\002S\000\000\001<\001,\000\000\000\000\001F\002l\001\029\001#\000\000\001\030\000\000\001\194\000\000\000\000\000\000\001 \000\000\000\000\002n\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\001<\000\000\001\241\000\000\000\000\001 \001,\001#\002T\001F\000\000\001\243\000\000\001\029\000\000\002T\001\030\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\001,\000\000\002U\001F\002\141\000\231\000\000\001(\000\000\001,\000\000\000\000\001F\000\000\000\000\001 \000\000\000\000\000\000\002T\000\000\000\000\002Q\002R\001c\001(\002T\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\000\000\001\015\002U\002T\002\141\000\231\000\000\001\021\001\"\002\130\000\000\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\001\015\001\029\000\000\002\142\001\030\001(\001\021\001\"\000\000\001\029\002\142\002\143\001\030\001\135\002\144\000\000\000\000\000\000\002\143\000\000\001\135\002\144\002Q\002R\001c\000\000\000\000\000\000\001 \002Q\002R\001c\000\000\000\000\000\000\001\015\001 \001<\000\000\002\142\000\000\001\021\001\"\000\000\001#\002\140\002\142\002\143\002g\001\135\002\144\000\000\002\159\000\000\002\143\001<\001\135\002\144\000\000\002\142\000\000\000\000\001#\000\000\002T\000\000\002w\002\143\000\000\001\135\002\144\001,\001\029\001(\001F\001\030\002U\000\000\002\141\000\231\001\029\001(\000\000\001\030\000\000\000\000\000\000\000\000\001\029\001,\001<\001\030\001F\000\000\000\000\000\000\000\000\001#\000\000\001 \000\000\002{\000\000\001\015\000\000\000\000\000\000\001 \000\000\001\021\001\"\001\015\000\000\000\000\000\000\001 \000\000\001\021\001\"\002T\000\000\000\000\000\000\000\000\001,\000\000\002T\001F\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\000\000\000\000\002U\002\142\002\141\000\231\000\000\000\000\001(\001\029\000\000\002\143\001\030\001\135\002\144\000\000\001(\000\000\000\000\000\000\000\000\000\000\001<\000\000\001(\000\000\000\000\000\000\000\000\001#\001<\000\000\000\000\002\211\000\000\000\000\001 \001#\001\015\000\000\000\000\003#\000\000\000\000\001\021\001\"\001\015\001\029\000\000\000\000\004G\000\000\001\021\001\"\001\015\000\000\001,\000\000\002\142\001F\001\021\001\"\000\000\000\000\001,\002\142\002\143\001F\001\135\002\144\000\000\000\000\000\000\002\143\001 \001\135\002\144\000\000\000\000\001\029\000\000\001(\004G\000\000\000\000\000\000\000\000\001\029\000\000\000\000\004G\000\000\000\000\001<\000\000\000\000\001\029\000\000\000\000\004G\001#\001<\000\000\000\000\003\239\000\000\001 \001\029\001#\001<\001\030\001\015\003\251\000\000\001 \000\000\001#\001\021\001\"\004I\004\021\000\000\000\000\001 \002Q\002R\001c\001,\000\000\000\000\001F\000\000\000\000\000\000\001 \001,\000\000\000\000\001F\000\000\000\000\000\000\000\000\001,\000\000\001\029\001F\004\250\001\030\001\015\000\000\004I\000\000\000\000\000\000\001\021\004L\000\000\000\000\004I\000\000\000\000\000\000\000\000\000\000\000\000\001<\000\000\004I\000\000\000\000\000\000\001 \001#\000\000\000\000\000\000\004%\000\000\001(\001\029\001\015\000\000\001\030\000\000\000\000\000\000\001\021\004L\001\015\000\000\000\000\000\000\000\000\000\000\001\021\004L\000\000\001\015\000\000\001,\000\000\000\000\001F\001\021\004L\000\000\001 \000\000\001\015\000\000\004M\000\000\000\000\000\000\001\021\001\"\001(\000\000\001\029\000\000\002T\004G\004\024\000\000\004Q\000\000\004O\000\000\000\000\000\000\000\000\000\000\002U\000\000\002\141\000\231\000\000\001,\000\000\000\000\000\000\000\000\004M\000\000\000\000\001 \001\015\000\000\000\000\000\000\004M\001(\001\021\001\"\004\024\000\000\004P\001\029\004O\004M\004G\000\000\004\024\001<\004N\000\000\004O\000\000\000\000\001,\001#\004\024\000\000\004Z\004\162\004O\000\000\001,\000\000\000\000\000\000\001\015\001\029\000\000\001 \001\030\001,\001\021\001\"\000\000\004I\000\000\000\000\000\000\000\000\002\142\000\000\001,\000\000\000\000\001F\001<\000\000\002\143\001\029\001\135\002\144\001\030\001#\001 \000\000\000\000\004\179\000\000\001\029\000\000\000\000\001\030\000\000\000\000\001\015\000\000\000\000\000\000\000\000\000\000\001\021\004L\000\000\004I\000\000\001 \000\000\000\000\000\000\001,\001<\000\000\001F\000\000\000\000\001 \000\000\001#\000\000\001\029\000\000\004\210\001\030\000\000\000\000\000\000\000\000\000\000\001(\000\000\000\000\000\000\001\029\001\015\000\000\001\030\000\000\000\000\000\000\001\021\004L\000\000\000\000\000\000\001,\000\000\001 \001F\000\000\000\000\001(\001\029\000\000\000\000\001\030\000\000\004M\000\000\001\015\001 \001(\000\000\000\000\000\000\001\021\001\"\000\000\000\000\004\024\000\000\005\018\000\000\004O\000\000\000\000\000\000\001\029\000\000\001 \001\030\001\015\000\000\000\000\001,\000\000\000\000\001\021\001\"\000\000\000\000\001\015\001(\000\000\000\000\000\000\004M\001\021\001\"\000\000\000\000\000\000\000\000\000\000\001 \001(\000\000\000\000\004\024\000\000\005*\000\000\004O\000\000\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\001\015\001,\001(\006A\000\000\000\000\001\021\001\"\000\000\000\000\000\000\000\000\000\000\001\015\001<\000\000\000\000\000\000\000\000\001\021\001\"\001#\000\000\000\000\001<\006F\001,\001(\000\000\001F\000\000\001#\001\015\000\000\000\000\006\146\000\000\000\000\001\021\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\001F\000\000\000\000\000\000\001<\000\000\001\015\001,\000\000\000\000\001F\001#\001\021\001\"\000\000\006\150\000\000\001<\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\006\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001<\000\000\001,\000\000\000\000\001F\000\000\001#\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\001F\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\001#\000\000\001,\000\000\000\000\001\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\003<")) + ((16, "\001\228\001\139\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\000\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\153\001\000\000)\000s\0007\012\006\000\000\000\000\000S\001F\r\002\0004\001\192\r\142\000\000\000\000\000\000)n\000\\\002Z\000RH@\000\000\000\000\000\000\000\000\000\000\000\000\000\000C\014\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\198\002\196\001\190\000\000\000\000\000\000\000\000\000a\000\000\002\222\007\154\001\216\003>\000\130\002\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\002T\000\000\000\000\000\000\000\000\000\000\002\182\000\000\000\000\000\000\002\190\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000<\214\000\000\000\000\002\208\000\000\000\000\000\000\000\000\000\000\000\000\000\000B\220\002\242\000\000\002\212\003\142\002\146\000\000\000\000\003\188\000j\000\000\003\198\006\208\002\222\003\228\000\005\000\000\000\000\000\000\001f\000\000\000\000\000\031\000\000\000\000\000\000\000\000\004N\000\000\003T\000\000\000\000\000\000\000\000\000\000\000\006\000\000\000-\004\234\tR\000\000\r\170B\220\000\000#$\000\000\001N\000\000B\240\001\004\003P\b\140\000\000\000\000\000\000\003\186\0042\004\166\000\196\002&\004\240+\234\004X\005\020\000\216\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\024\000\000\000\000\000\000\004\142\005P\r\242\004\168\005\176\014\\\n.)n%\022\000\000,N\004\214\005\180\005\228\000\000%\212C\224D\158\000\000\000\203\000\000\000\000\000\000\005\216H(\005\246\000\000\0018\006&\000\000\002\244;\236\001\148\000\000\001\r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006t\005\170\000\000\000\000\000\000!\216\000\000\004\224\000\000\000\000\005\158Hr1`\000\000W\234\000\000\000\000\000\000\000\000\000\000\000\000\004\020\006\022\004\020\002\202\000\000\000\000\000\000\005x\000\000\000\000\000\000\000\000\006\b\000\000\000\000\004\020\000\000\000\000\000\000\000\000\000\000\006\250\004\230\n\252\000\000\000\000\0050\000\000\003\160\001\132\003 \001\022\012f\000\000\000\000VH\000\000V\134\012\014\000\000K\230\005xLp\005x\000\000\001t\000\007\000\000\006\190\003\160\000\000\000\000\0116\000\000\000\000\000\000\000\000\000\000\007R\003\160\b\254\003\160\000\000\000W\000\000\000\000\002\020\000\000\000\000\000\000\012\144\000\000\000\000\003\160\003\160\000\000\003\160\000\000\000\000\004\212\000\000\000^\002&\000\000\000^\000\000\t\188\003\160\000\000\000\000\000\000\000\000\000\000\000^\015\234%j\012N\011\248-X\004\176\000\0003v-\142\011>\007\026D\022\011@\007\192\0168\011N\007\202\016\158\011P\007\230<\134D\230\007\240\016\242\011\\\b\006,Z\000\000\022L\000\000\000\000\012$\n\194\004\020\000\000\017\166\011p\b8=T\000\000Er\000\000\000\000\011t\b\128L\228\007\240\017\198\011\128\b\132MF\007\240\018tG\236\000\000\000\000\000\000\000\000\000\000\002n\nN\000\000\000\000\000\000\011\196\b\134\005\196\000^\011p\003\160\000\000\000\000\000\000*\176\000\000Mj\005x\018\148\011\242\b\144L\024\000\000X\236\000\000\000\000&\030\012 \b\184=\162\000\000-\230.\138\000\000\000\000\r\132M\142\005xF\190\005xM\242\005x\000\000\000\000\000\000\000\000\000\000Y\166\000\000\000\000\000\000\001\170\019H\000\000\000\000\000\000.HY\184\000\000\000\000\000\000\000\000\000\000\012*\019\156\000\000\000\000\012.\020\002\000\000\000\000\012@.\252\012@/T\000\000Y\238\000\000/x\000\000/\208\000\0000$\000\0000\158\000\0001\020\000\0001\144\000\0001\228\000\0002<\000\0002\158\000\0003\020\000\0003l\000\0003\206\000\0004&\000\0004\136\000\0004\224\000\0005B\000\0005\154\000\0005\252\000\0006T\000\0006\182\000\0007\014\000\000\000\000\000\000\020P\004b\020\182\000\000\000\000\000\000\b\202=\222\000\000NP\005x\021\n\000\000\012n\021\190\000\000M\186\007\240O$\007\240OD\007\240\002\190\000\000\000\000\000\000\000\000OZ\007\240\000\000\000Q\004\216\000(O\208\007\240\021\222\000\000\012\170\012\182\t\020\012\238\r\188\014\188\003\160\000b\003\016\000\000\000\000\t:\r\186\r\208\000a\005\200\000^\014\246\003\160\006\000\000^\003\184\r\156\tR\r\222\000\020\0052\r\164\000\000\004\016\000\000\000\000\006\198\005d\000\000\005\144\003\160\005\240\001\148\rX\tn\t\030\000^\000\000\rd\t\130\007\\\000\000>\n\000\000\r\142\000\000O\164\005x\000\000\014\016\014\022\000\000\0078\000\000\005x\rt\t\132\005\246\000\000\000\000\000\000\000\000\000\000\r\152'z\000\203\000\000\000\000\000\000E\172\000\000V\236\000\000\t\144\000\000\t\158\000\000\000\000\000\000\000\000\002|\000\000\000\000\000\000\015\216\004\020\000\000\004\020\000?\000\000\000\000\000\000\000\000\t\164\b`\000\000\000\218\000\0004v\000\000\019\240\004\020\004\020\000\000\024\b\004\020\004\020\t\166\t>\000\000\000\000\b\184\r|\t\184\004\176\006L\b^\004\234\nv;\236\0038\000\000\000\000\000\000\006\222\r\164\t\186\000\000\r\174\006\222\000\000\014\152\tT\000\000\000\000\000\000\005x\000}\000\240\003Z\000\000\000\000\000\000\000\000\r\180\t\204\000\000\007\218\000\000\000\000\000\000\000\000\000\000\014\156\t\194\000\000\000\000\014\144\000\000\002L\001\022\000\000\000\000\000\000\000\000\b\140\014\244\011L\014\176\t\252\000\000\014\188\n\002\000\000\000\000\014\186\005\186\002\226\000\000X\000\r\206\r\210\t\220\005\136\n&\000\000\t\224\bv\n2\000\000\r\214\r\222\t\226\014\016\r\188\017>\003\160\000\000\t\242\014\136\000\000\b\212\nD\000\000\014\138\000\000\017\248\004\228\014R\nz\014\142\000\000\018\002\006R\014V\000\000\000\000\004T\nD\nl\000\000\018 \003\160\np\000\000\0064\000\000\014\006\n\138\019\014\006\182\000\000\014\014\n\142\b\132\r\152\014\022\014\026\n\180\015\146\000\000\0142\002\230\000\000\000\000\000\000\000\000\000\215\n\196\014\004O\184\005x\000\000\001\\\n\202\014\202\000\000\000\000\000\000\000\000\000\000\000\000P,\007j\000\000\n\210\015&\000\000\000\000\000\000\000\000\000\000\000\000>^\n\250\000\000\n\220\000\252\000\000\n\230\n\234\n\188\000\000\002\184E\208\000\000\002\238\000\000PP\005x\005x\000\000\000\000\007v\000\000\011b\000\000\0068\007v\007v\000\000\011\002@\018\005xP\182\005x\011\022\000\000\000\000\000\000\011L\000\000\000\000\001\248\000\000\bF\014\130\011D\015\160\014D\000\000\000\000\b\026\b\188\014\142\000\000\000\000\011`\015\174\014P\000\000\000\000\004f\000\000WP\000\000QN7|\005x\000\000Q\146Z,\000\000Q\186\000\000\000\000\000\000\007v\000\000\000\000\011j\014\152\011l\015\190\014^\000\000\000\000R\"\012\004\014\164\000\000\000\000\000\000X\168\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\b\000\000\014\178\011p\b\216\000\000\015\182\015j\012\026\014\194\000\000\000\000\014\198\011x\t6\000\000\000\000\011\170\015p\012*\014\210\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005x\014z\011z\015\236\014\148\000\000R\150\001\001\011\146\014b\004\132\000x\011\154\015(\000\000\015\226\022\140\000\000\000\000\022\172\000\000\0128\000\000\002N\000\000\000\000\000\000\000\000\000\000\000\000RJ\005x\000\000\015\234\023`\000\000\000\000\023\180\000\000\000\228\011\164\015\142\000\000>*>\252\015<\000\000Rf\005x\024\026\000\000\000\000\024h\000\000\000\000\002T\000\000\000\000\024\206\000\000\000\000\000\000\012V\000\000\007\214\000\000\000\000\000\000\000\000\000\000\000\000?(\000\000\000\000?\150@8\015>\000\000R\144\005x\025\"\000\000\000\000\025\214\000\000\000\000\011\178\025\246\012\\\000\000\011\192\012D\000\245\000\167\012R\t\030\012f\015\156@\172\012d\000\000\012j\012r\011\130\000\000\004XF4\000\000\003X\000\000\012z\026d\030|\007\156\014f\bT\000\0001\210Y\248\000\000\000\000\rD\000\000\000\000\000\000\007^\000\000\000\000\007^\000\000\000\000\007^\012\180\000\000\012R\007^\015\160@\182\012\200\000\000\007^\000\000SR\000\000\000\000\007^\000\000\000\000\012\244\000\000\012\182\007\196\r*\000\000\012|F\152\r.\000\000\000\000\000\000\r8\000\000\000\000\005z\000\000\007^S\140\000\000\014\148\007^W\024\000\000\r<\014\248\012\150\016 \014\194\000\000W\144\r@\015\006\000\000\000\000\000\000\n\216\n\012\012\154\015\190A \rH\000\000\000\000\000\000\000\000\000\000\000\000\012*\000\000\000\000\012.\000\000\rN\000\000\015\"\000\000\000\000\000\000\000\000\rXF\014\000\000\000\000\012*\000\000\012.\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\026\164\000\000\000\000\026\196\000\000\000\000\000\000\000\000&\130\000\000\000\000\000\000&\218\000\000'(\000\000\000\000'\142\000\000\000\000\000\000\000\000'\220\000\000\000\0007\178\000\000(4\000\000\000\0008(\000\000(\150\000\000\000\0008\128\000\000\006\020\027x\000\000\000\0008\186\000\000\027\204\000\000\000\00094\000\000\0282\000\000\000\0009n\000\000\000\000\000\000)\"\000\000\000\0009\194\000\000)\160\000\000\000\000:<\000\000)\214\000\000\000\000:v\000\000\000\000:\240\000\000\rD\000\000\000\000\000\000*.\000\000\000\000*\144\000\000\000\000\000\000\012n\028\128\000\000\000\000\028\230\000\000\0184\000\000\000\000G\236\000\000\000\000+^\000\000\000\000\000\000+\154\000\000\000\000\000\000\015\244\000\000\000\0000F\000\000\007\128\000\000\004<\015\146\000\000\b\002\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\014\212\000\000\000\000\029:\000\000\029\238\000\000\000\000\000\000\030\014\000\000\000\000\030\188\014\214\030\220\000\000\031\144\000\000\000\000\000\000\000\000\031\228\000\000 J\000\000\000\000\000\000\000\000\000\000;D\000\000;~\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\164\t\154\000^ \152\000\000\014\222\012\178\015p\007\202\000\000 \254\000\000\014\226\012\218\t\\\015\004\012\232\000\000!R\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\190\015\138\000\000S\244\005x\"\006\000\000\000\000T\b\005x\"&\000\000\000\000\"\212\000\000\000\000\r\138\000\000\000\000\000\000\000\000\000\000\000\000\014\234\012\244\n\004\000^\000\000\021V\003\160\000\000\016D\000\000\000\000\000\000\000\000A\200\000\000\000\000B:\000\000\000\000\000\000\022\022\003\160\000\000\0228\003\160\000\000\023&\003\160\000\000\007&\000\000\r\018\nd\007<\000\000\r\146W\166\000\000\000\000\000\000\000\000\r \000\000\r,\006\138\000\000\000\000\004\0203\188\000\000\000\000\000\000\000\000\000\000X\178\000\000\000\000\b\188\004b\000\000\000\000T\\\005x\005xT\160\005x\007\244\000\000\000\000\000\000\005x\000\000\000\000\000\000\015\232\000\208\t\158\r\164\004,\r4\000\000\000<\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\180\004\140\r\146\000\000\n~\014\244\000\000\015\236\006\012\002:\000\000\000\000\000\000\000^\003\160\000\000\014\b\000\000\000\000\000\000\003\160\000\000\007\240\000\000T\246\005x\000\000\007\000\000\000\000\000\000\000B\134\000\000\000\000B\162\000\000\"\244\000\000#\168\000\000\000\000#\252\000\000\000\000\000\000\000\000$b\000\000$\176\000\000\000\000\000\000\000\000\000\000.`\000\000\000\000\000\000\0000\002\192\000\000\000\000\000\000\000\000\000\000\007\248\002\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000g\000\000\000\000\000\000G\134\000\000\005x\000\000\011\254\000\000\000\000\000\000\002\138\000\000\000\000\000\000\003\"\000\000\000\000\000\000\004\150\000\000\000^\000\000\000\145\000\000\003\160\000\000\000\147\000\000\000\000\000\000G\208\007\240\000\000\000\000\004\228\000\000\000\000\000\000\000\000\002n\005\020\015 \001\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\166\000\000\014\024\000\000\000\000\000\000\000\000\005d\007 JPU\128\000\000\000\000\014>U\142\000\000\000\000\000\000\014PU\252\000\000\000\000\000\000\000\000"), (16, "\005V\001\017\002f\002g\001m\000;\000\227\001\021\006\167\000\231\000\232\000\188\000\227\003\144\000\193\000\231\000\232\002\138\005W\005n\007 \005^\007\028\003S\000\188\002\139\006\187\001\254\001\015\000\188\005_\005o\000\197\000\227\001\021\001\024\000\231\001\002\002\162\005\017\005V\003\018\002f\002g\001m\005\017\000\194\001\003\006\245\007\004\0007\000\227\007!\001\237\000\231\000\232\007\029\002\138\005W\005n\005`\005^\002\005\002\005\005r\002\139\002\t\002\t\001\021\001\021\005_\005o\001\005\005\019\003^\003`\003b\001\237\002\162\005\019\006\203\004\180\006\229\003j\005\017\003\031\000\231\002\005\000\149\001m\005\020\002\t\002\018\001\021\0043\005\027\005\020\005a\001\021\005D\005`\005\027\002\164\003j\005r\0050\000\231\005b\0044\002\n\002\n\003\018\004K\001\015\002j\005|\002\166\000\231\005\019\001\021\001)\001\\\002\001\003\150\003\151\006\246\005s\002\173\003\018\002\011\003\018\000@\002\005\005t\002\n\005\020\002\t\005a\001\021\001\029\005\027\003'\002\164\003$\005+\000?\003\167\005b\005u\002+\003\160\003~\000\234\002\011\002j\002\"\002\166\000\231\005h\006\247\007\005\000D\001\145\005j\006\254\001\021\005s\002\173\0007\003c\0007\002\177\0007\005t\002\178\001_\003q\005l\006\175\002\n\003m\002\167\001\145\002\233\006\196\006\176\001\029\002-\005u\001\030\000\231\002\183\001@\001\145\002\169\003\144\005m\001\029\005h\003'\002\"\000\234\0035\005j\003\020\000\188\006\255\000\198\001\254\006\227\002\022\002\177\001A\001 \002\178\002\185\006\177\005l\004\182\001Y\003\018\002\167\005V\002\233\002f\002g\001m\001\"\000G\006{\006\178\002\183\002-\001\145\002\169\000\231\005m\007\000\000:\002\138\005W\005n\000\227\005^\001#\000\231\000\232\002\139\000N\005z\001\021\001)\005_\005o\002.\002\185\007\001\004\221\002\023\001&\002\162\001\015\005V\006\210\002f\002g\001m\001\021\001\024\0074\002g\001m\004\223\000\227\001\"\002,\000\231\001\002\001F\002\138\005W\006\234\005`\005^\001s\001\"\005r\002\139\000\234\006\179\006\180\001#\005_\005o\003\177\001\159\001m\001\021\001)\002.\002\162\000b\001#\006\181\006\182\003\150\003\151\001+\001\021\001)\001,\006\145\001\242\004\187\001-\001.\006\183\003~\003w\005a\002\016\000E\005`\000\231\002\164\003\178\004D\0043\003\159\005b\004\215\000\233\003\160\003~\005\248\001m\002j\001\015\002\166\000\231\003z\0044\000\234\001\021\001\024\004;\0015\005\132\005s\002\173\000\231\001\002\004F\000f\001+\005t\0009\001,\000=\005a\000\211\001-\001.\001P\002\164\001+\003\018\003\176\001,\005b\005u\004H\001-\001.\002\252\001m\002j\002\"\002\166\000\231\005h\0075\000H\002\166\000\231\005j\005\146\001/\005s\002\173\0019\000\234\002\"\002\177\004I\005t\002\178\000\188\006\141\005l\000\193\002\021\004\216\002\167\004J\002\233\002&\001\021\001\029\002-\005u\001\030\000\231\002\183\001@\001\145\002\169\001\025\005m\004\191\005h\002/\007\016\006\236\002-\005j\000\188\000\231\001\241\001\254\004F\005v\004\003\002\177\001A\001 \002\178\002\185\000m\005l\006\193\001W\003S\002\167\005V\002\233\002f\002g\001m\004H\003\018\001t\000\234\002\183\001\237\001\145\002\169\006\197\005m\000O\007\017\002\138\005W\005n\002\005\005^\001\021\000\146\002\t\002\139\001\021\006\177\004I\003\018\005_\005o\002.\002\185\000\129\003\179\003\180\001&\002\162\001\015\005V\006\178\002f\002g\001m\001\021\001\024\002.\001\015\003a\003`\003b\001\"\007\020\001\021\001\024\001F\002\138\005W\005n\005`\005^\003\160\003~\006\133\002\139\001\015\002\n\000c\001#\005_\005o\001\021\001\024\001\237\001\021\001)\002\030\002\162\001\237\003\194\000k\002\028\000\133\002\005\000\234\002\011\000\137\002\t\002\005\001\021\007\021\003S\002\t\000\231\001\021\001\237\005a\000\156\002\027\005`\003\018\002\164\003\019\005x\0043\002\005\005b\0014\003S\002\t\003\178\001\021\003\018\002j\000\163\002\166\000\231\000\227\0044\000\165\000\231\000\232\0045\0015\000\175\005s\002\173\0013\000n\004\215\002\n\001+\005t\000\192\001,\002\n\005a\000\234\001-\001.\001P\002\164\003\137\003`\003b\004/\005b\005u\001\029\002\011\000\234\004c\002\n\002j\002\011\002\166\000\231\005h\0007\003\156\003`\003b\005j\000\191\001/\005s\002\173\0019\000\166\001\233\002\177\002\011\005t\002\178\003\213\001 \005l\002f\002g\001m\002\167\000\188\002\233\003\181\001\254\000\227\003 \005u\000\231\001\002\002\183\000\170\001\145\002\169\001h\005m\000\173\005h\000\234\001\180\005\234\005\238\005j\007(\002g\001m\005\012\005\242\003(\001\029\002\177\000\176\001\015\002\178\002\185\003\169\005l\0007\001\021\001)\002\167\004e\002\233\003j\001\005\005V\000\231\002f\002g\001m\002\183\006!\001\145\002\169\006}\005m\001\"\007\024\000\234\0077\0078\003\239\002\138\007:\002\"\000\227\005^\002\004\000\231\000\232\002\139\001\015\001\233\001#\002\185\005_\007<\001\021\001\024\001\021\004h\000\234\003\018\002\162\003'\005V\000\234\002f\002g\001m\007K\003j\007*\007\025\000\231\002\"\002-\002i\005\017\000\231\007C\000\234\002\138\007D\005=\005`\005^\002 \002\026\005\245\002\139\002\166\000\231\001\002\000\218\005_\007L\001\"\003\241\001\015\006\173\003\018\001\145\002\162\002#\001\021\001)\002-\000\219\0007\000\231\005?\005\019\000\224\001#\007+\001+\002\166\000\231\004i\001\021\001)\005a\001-\001.\005`\003\018\002\164\005\237\005\020\005A\006\153\005b\0044\005\027\004n\003\224\004k\005\"\002j\000\239\002\166\000\231\002.\001\237\000\222\002\231\001\238\006\185\001/\001\145\005s\002\173\000\242\002\005\007?\002\167\0007\002\t\005B\001\021\003\193\005a\000\225\001\029\000\235\002\168\002\164\001\145\002\169\001\235\002\026\005b\005u\002.\003%\000\250\001+\000\234\002j\001,\002\166\000\231\005h\001-\001.\000\253\000\188\005j\003\132\001\254\005s\002\173\000\240\007P\002\"\002\177\002\"\003\200\002\178\003,\002\n\005l\006\192\001\021\003\005\002\167\005C\002\233\002\004\001>\001\029\001a\005u\001\030\000\234\002\183\001@\001\145\002\169\002\011\005m\001\029\005h\002s\002\"\003\026\002-\005j\002-\000\231\001\t\000\231\000\234\005?\000\234\002\177\001A\001 \002\178\002\185\000\243\005l\000\251\001B\003\018\002\167\005V\002\233\002f\002g\001m\001\"\005A\003\030\001\012\002\183\002-\001\145\002\169\000\231\005m\001\028\000\234\002\138\005W\006\194\005\179\005^\001#\000\231\001\002\002\139\003\179\003\180\001\021\001)\005_\005o\001=\002\185\003\242\005B\0018\001&\002\162\001\015\005V\001O\002f\002g\001m\001\021\001\024\002.\003\018\002.\003.\001M\001\"\003\160\003~\007C\001F\002\138\007D\005\196\005`\005^\001<\001\"\000\234\002\139\000\234\006\179\006\180\001#\005_\007G\003\230\0039\001m\001\021\001)\002.\002\162\001e\001#\006\181\006\182\003O\003~\001+\001\021\001)\001,\006\140\001|\003\241\001-\001.\006\183\003~\001\237\005a\0030\002\003\005`\004z\002\164\001I\003\018\0043\002\005\005b\003+\001\221\002\t\000\234\001\021\003\018\002j\003\018\002\166\000\231\0011\0044\005\236\000\234\003\247\004:\0015\002+\005s\002\173\004\228\004{\006\201\004|\001+\005t\001\223\001,\002+\005a\003\018\001-\001.\001P\002\164\001+\003\018\002\004\001,\005b\005u\000\234\001-\001.\006\252\002\n\002j\006\211\002\166\000\231\005h\001\232\000\234\004}\0053\005j\003'\001/\005s\002\173\0019\007J\001\237\002\177\002\011\002\r\002\178\002;\006\141\005l\006|\000\234\002\005\002\167\005?\002\233\002\t\005\241\001\021\003E\005u\006\128\004\232\002\183\001^\001\145\002\169\002\004\005m\004~\005h\003\141\003~\005A\000\227\005j\000\234\000\231\001\002\004\127\004\128\003\172\004\129\002\177\004\024\0057\002\178\002\185\000\227\005l\004<\000\231\000\232\002\167\005V\002\233\002f\002g\001m\002\n\001\175\000\234\005B\002\183\003\190\001\145\002\169\004\158\005m\003S\0066\002\138\005W\005\237\001d\005^\004z\000\234\002\011\002\139\003\018\005\017\003S\002,\005_\006\129\001\029\002\185\006\154\001\030\002>\004\131\002\162\003\018\002,\002A\004\133\004\143\000\188\000\227\004\136\001\254\000\231\001\002\004{\004\157\004|\001l\001m\002D\004\154\005\029\001\015\001 \005`\005\019\006S\0018\001\021\001\024\003\164\003`\003b\0046\006V\002J\003'\001n\002K\004\155\001p\001q\005\020\006\161\003`\003b\004}\005\027\005\237\003\018\000\227\005\031\006\253\000\231\000\232\000\188\001\015\004\146\001\254\0007\002V\005a\001\021\001)\004L\002L\002\164\001\173\003\204\001&\000\234\005b\005\029\001\029\001\021\000\234\001\030\003o\002j\001\015\002\166\000\231\004~\005\017\001\"\001\021\001)\001{\0043\000\234\005s\002\173\004\127\004\128\001\132\004\129\002]\006\132\002b\002r\001 \001#\0044\001\015\002\128\000\234\004S\001\021\001)\001\021\001)\001\141\005u\001\140\003\018\003\218\001u\005\019\003\144\002\"\004\158\001\021\005h\004T\002\136\003\018\001\237\005j\001v\002\015\000\234\000\231\001\179\002\236\005\020\002\177\002\005\0046\002\178\005\027\002\t\005l\001\021\005\028\004\131\002\167\001&\002\233\0034\004\133\004\143\002-\003\251\003~\000\231\002\183\0015\001\145\002\169\001\190\005m\001\"\006\166\004\154\001+\002M\000\234\001,\000\234\000\234\003\r\001-\001.\004\159\000\234\002f\002g\001m\001#\002\185\003\018\002\"\004\155\002\n\001\021\001)\004\214\004\220\003}\003\022\002\138\002f\002g\001m\000\234\001\135\0046\001/\002\139\003\149\0019\003\"\002\011\000\234\006f\001\144\002\138\001\145\001t\003\018\006/\002\162\003\018\002-\002\139\0033\000\231\001\195\002.\001\029\005\220\001\237\001\030\006\189\002)\0038\003I\002\162\003\150\003\151\003\018\002\005\003Z\0015\002\"\002\t\003\018\001\021\006D\003\\\000\234\001+\003n\003|\001,\003\018\001 \004\255\001-\001.\003\152\003\168\003\130\003\143\003\171\003\160\003~\001\029\005V\000\234\006<\003~\003\162\006a\003\144\003\018\002-\003\018\000\146\000\231\003\199\000\234\003\203\003\209\001/\002\164\005W\0019\002\n\005^\002.\003\215\002\"\003\186\000\146\000\234\003\189\002j\005_\002\166\000\231\002\164\001&\006\171\003~\000\234\000\234\002\011\003\235\002\170\002\173\000\231\000\234\002j\003\201\002\166\000\231\001\"\003\147\000\234\003\205\006\127\000\234\000\234\002-\002\170\002\173\000\231\005`\003\219\001\209\002\174\000\234\000\234\001#\001\206\001\029\001\212\001\015\001\030\001\021\001)\000\234\002.\001\021\001)\003\018\002\174\005Y\003\236\000\234\003\240\000\234\000\234\002\177\001\"\006-\002\178\001\220\003\226\003\018\000\234\001\226\001 \002\167\005a\002\233\003\245\004*\003\250\002\177\000\231\001#\002\178\002\183\005b\001\145\002\169\001\021\001)\002\167\003\144\002\233\001\029\003\150\003\151\001\030\003\018\003\255\0015\002\183\002.\001\145\002\169\005c\002\173\004\t\001+\002\185\004\015\001,\005e\003\018\004\026\001-\001.\003\152\003\168\004%\001&\001 \003\160\003~\0047\002\185\004)\005f\002f\002g\001m\004#\002f\002g\001m\001\"\003\184\005h\004>\003\144\000\234\001/\005j\002\138\0019\004C\001+\002\138\000\234\001,\000\234\002\139\001#\001-\001.\002\139\005l\007\012\001\021\001)\001\237\006\223\0048\002u\002\162\000\231\001\234\001&\002\162\000\234\002\005\004N\004G\001\247\002\t\005m\001\021\000\234\005\007\002Q\000\234\000\231\001\"\004\149\000\234\004X\001\249\004o\002\b\000\234\003\018\004q\003\018\004\135\000\234\002\025\000\234\004\145\004\162\001#\006(\003\018\003\150\003\151\007\014\001\021\001)\0015\000\234\003\018\004\168\006$\002:\002=\004\172\001+\003\018\002\n\001,\004\200\002@\002C\001-\001.\003\152\003\168\004\246\002I\002\164\003\160\003~\003\018\002\164\0055\003\018\002R\002\011\002U\003\018\002\\\002j\000\234\002\166\000\231\002j\002a\002\166\000\231\001/\003\150\003\151\0019\002\170\002\173\0015\000\234\002\170\002\173\002f\002g\001m\000\234\001+\000\234\004w\001,\004\132\000\234\000\234\001-\001.\003\152\003\168\002\138\002\174\004\140\003\160\003~\002\174\002q\000\234\002\139\000\227\004\151\000\234\000\231\000\232\006\216\003\018\000\234\004\181\002f\002g\001m\002\162\001/\000\234\002\177\0019\004\251\002\178\002\177\002\127\000\234\002\178\004\222\005'\002\167\004\248\002\233\003\018\002\167\005\003\002\233\005\023\005\017\005\000\002\183\005#\001\145\002\169\002\183\005\006\001\145\002\169\002\135\005\014\005:\002f\002g\001m\005$\000\227\002\149\000\231\000\231\000\232\003\018\005V\003\018\005N\002\185\005Z\002\138\003\018\002\185\003\018\006.\003\018\005\019\001\029\002\139\003\018\001\030\0064\003\018\007:\006\213\002\164\005^\003\018\005d\005*\005g\002\162\005\017\005\020\002\227\005_\000\234\002j\005\027\002\166\000\231\006;\005&\000\234\001 \002f\002g\001m\006>\002\170\002\173\0054\003\018\000\234\006`\000\234\003\018\002\253\002i\000\234\002\138\003\021\003\144\000\234\000\234\005`\005\019\003\012\002\139\006~\002j\002\174\002\166\000\231\006m\003\014\006\136\000\234\0058\000\234\005<\002\162\006\138\005\020\000\234\005@\006\174\005L\005\027\005S\001&\000\234\0056\005]\002\177\002\164\005i\002\178\002f\002g\001m\005p\005a\003\017\002\167\001\"\002\233\002j\005\025\002\166\000\231\000\234\005b\002\138\002\183\003\018\001\145\002\169\000\234\002\170\002\173\002\139\001#\003\018\000\234\003*\006X\006j\001\021\001)\006\130\005c\002\173\006\186\002\162\007;\003\024\002\167\002\185\000\234\003)\002\174\003\018\003#\003&\002\164\000\234\002\168\0032\001\145\002\169\003\018\000\234\005f\0037\003=\000\234\002j\003D\002\166\000\231\003C\003H\005h\002\177\003{\003\129\002\178\005j\002\170\002\173\003\142\003\150\003\151\002\167\003\146\002\233\0015\003\148\003\161\003\170\003\175\005l\003\187\002\183\001+\001\145\002\169\001,\006\200\003\185\002\174\001-\001.\006\164\006\165\003\188\007=\002\164\003\160\003~\005m\003\192\000\234\002f\002g\001m\003\202\002\185\003\198\002j\003\214\002\166\000\231\002\177\003\208\007H\002\178\001/\002\138\003\210\0019\002\170\002\173\002\167\007M\002\233\002\139\003\233\003\221\003\232\003\227\003\231\006C\002\183\003\244\001\145\002\169\000\227\003\249\002\162\000\231\000\232\004W\002\174\003\254\002f\002g\001m\001\237\004\001\004\005\003\016\004\r\004\020\004\031\004V\004O\002\185\002\005\004P\002\138\004U\002\t\004Y\001\021\004Z\002\177\004y\002\139\002\178\005\017\004r\004s\004x\006A\004\142\002\167\001\237\002\233\004\138\003\028\002\162\004\139\004\141\004\153\004\150\002\183\002\005\001\145\002\169\004\152\002\t\004\161\001\021\004\163\001\029\002f\002g\001m\004\164\004\169\004\173\004\177\002\164\005\019\002\n\004\195\004\201\004\205\004\236\002\185\002\138\005\001\005\030\005(\002j\005U\002\166\000\231\002\139\005O\005\020\005P\005T\002\011\006,\005\027\002\170\002\173\005[\005H\005k\002\162\005\231\002\n\002f\002g\001m\005\239\005\252\006\007\006&\0063\0065\006:\002\164\006=\006I\006_\002\174\002\138\006h\006\169\002\011\006\191\007/\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\006\027\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001\"\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\001#\002\138\000\000\000\000\000\000\000\000\001\021\001)\002j\002\139\002\166\000\231\000\000\000\000\002\177\006\021\002\185\002\178\000\000\000\000\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\006\r\002\185\002\170\002\173\000\000\000\000\001+\002\162\002\177\001,\000\000\002\178\000\000\001-\001.\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003e\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\177\000\000\000\000\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\002\174\002\138\002f\002g\001m\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\000\000\002\185\002\138\000\000\000\000\002\170\002\173\002\162\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\006\001\000\000\002\167\000\000\002\233\000\000\001\237\002\162\000\000\003\212\000\000\002\174\002\183\000\000\001\145\002\169\002\005\000\000\000\000\000\000\002\t\000\000\001\021\000\000\000\000\000\000\000\000\001\198\001m\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\185\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\001n\002z\000\000\001p\001q\000\000\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\002\n\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\164\000\000\002\138\002f\002g\001m\000\000\002\185\002\170\002\173\002\139\002\011\002j\000\000\002\166\000\231\005\249\000\000\002\138\005\210\002\254\002\255\000\000\002\162\002\170\002\173\002\139\000\000\001\237\000\000\002\174\003\223\005\209\001\237\000\000\000\000\003\229\000\000\002\005\002\162\000\000\000\000\002\t\002\005\001\021\000\000\002\174\002\t\001\237\001\021\000\000\003\238\000\000\004\218\000\000\001\133\002\178\006\012\002\005\000\000\000\000\000\000\002\t\002\167\001\021\002\233\000\000\001v\000\000\002\177\000\231\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\n\000\000\002\164\000\000\002\183\002\n\001\145\002\169\002f\002g\001m\000\000\002\185\005\217\002j\000\000\002\166\000\231\002\164\002\011\002\n\000\000\000\000\002\138\002\011\000\000\002\170\002\173\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\002\160\000\000\002\011\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\002\174\001\135\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\002\172\000\000\002\167\001\237\002\233\000\000\003\246\002\162\002\177\000\000\000\000\002\178\002\183\002\005\001\145\002\169\000\000\002\t\002\167\001\021\002\233\001\029\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\185\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\002\176\002\185\002\170\002\173\000\000\000\000\000\000\002\162\000\000\002\n\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\002\174\002\138\000\000\000\000\002\011\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\002\234\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001\"\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\001#\002\138\000\000\000\000\000\000\000\000\001\021\001)\002j\002\139\002\166\000\231\000\000\000\000\002\177\002\232\002\185\002\178\000\000\000\000\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\002\241\002\185\002\170\002\173\000\000\000\000\001+\002\162\002\177\001,\000\000\002\178\000\000\001-\001.\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003u\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\177\000\000\000\000\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\002\174\002\138\002f\002g\001m\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\002\244\002\185\002\138\000\000\000\000\002\170\002\173\002\162\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\003\t\000\000\002\167\000\000\002\233\000\000\001\237\002\162\000\000\006d\000\000\002\174\002\183\000\000\001\145\002\169\002\005\000\000\000\000\000\000\002\t\000\000\001\021\000\000\000\000\000\000\000\000\001l\001m\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\185\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\001n\002K\000\000\001p\001q\000\000\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\002\n\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\164\000\000\002\138\002f\002g\001m\000\000\002\185\002\170\002\173\002\139\002\011\002j\000\000\002\166\000\231\004\176\000\000\002\138\000\000\000\000\000\000\000\000\002\162\002\170\002\173\002\139\000\000\000\000\000\000\002\174\001\237\004\179\000\000\006s\000\000\000\000\000\000\000\000\002\162\000\000\002\005\000\000\000\000\000\000\002\t\002\174\001\021\001\237\000\000\000\000\006v\000\000\002\177\000\000\001u\002\178\000\000\002\005\000\000\000\000\000\000\002\t\002\167\001\021\002\233\000\000\001v\000\000\002\177\000\231\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\000\000\000\000\002\164\002\n\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\002\185\000\000\002j\000\000\002\166\000\231\002\164\002M\002\n\000\000\002\011\002\138\000\000\000\000\002\170\002\173\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\004\194\000\000\002\011\000\000\002N\002\170\002\173\002\162\000\000\000\000\000\000\002\174\001\135\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\001\144\000\000\001\145\001t\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\004\197\000\000\002\167\001\237\002\233\000\000\006y\002\162\002\177\000\000\000\000\002\178\002\183\002\005\001\145\002\169\000\000\002\t\002\167\001\021\002\233\001\029\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\185\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\004\209\002\185\002\170\002\173\000\000\000\000\000\000\002\162\000\000\002\n\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\002\174\002\138\000\000\000\000\002\011\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\004\212\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001\"\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\001#\002\138\000\000\000\000\000\000\000\000\001\021\001)\002j\002\139\002\166\000\231\000\000\000\000\002\177\000\000\002\185\002\178\000\000\000\000\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\004\240\002\185\002\170\002\173\000\000\000\000\001+\002\162\002\177\001,\000\000\002\178\000\000\001-\001.\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003y\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\177\000\000\000\000\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\002\174\002\138\002f\002g\001m\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\004\243\002\185\002\138\000\000\000\000\002\170\002\173\002\162\004\218\000\000\002\139\002\178\004\219\000\000\000\000\000\000\004\247\000\000\002\167\000\000\002\233\000\000\000\000\002\162\000\000\000\000\000\000\002\174\002\183\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001m\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\185\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\001n\002K\000\000\001p\001q\000\000\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\164\000\000\002\138\002f\002g\001m\000\000\002\185\002\170\002\173\002\139\000\000\002j\000\000\002\166\000\231\005\127\000\000\002\138\000\000\000\000\000\000\000\000\002\162\002\170\002\173\002\139\000\000\000\000\000\000\002\174\000\000\005\130\000\000\000\000\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\000\000\000\000\000\000\002\174\000\000\000\000\000\000\000\000\000\000\000\000\002\177\000\000\001u\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\001v\000\000\002\177\000\231\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\000\000\000\000\002\164\000\000\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\002\185\000\000\002j\000\000\002\166\000\231\002\164\005\015\000\000\000\000\000\000\002\138\000\000\000\000\002\170\002\173\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\005\165\000\000\000\000\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\002\174\001\135\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\001\144\000\000\001\145\001t\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\002\177\005!\002\139\002\178\000\000\000\000\000\000\000\000\005\170\000\000\002\167\000\000\002\233\000\000\000\000\002\162\002\177\000\000\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\185\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\005\175\002\185\002\170\002\173\000\000\000\000\000\000\002\162\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\005\212\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\002\177\005\215\002\185\002\178\000\000\000\000\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\005\253\002\185\002\170\002\173\000\000\000\000\000\000\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\177\000\000\000\000\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\002\174\002\138\002f\002g\001m\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\005\255\002\185\002\138\000\000\000\000\002\170\002\173\002\162\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\006\003\000\000\002\167\000\000\002\233\000\000\000\000\002\162\000\000\000\000\000\000\002\174\002\183\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001m\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\185\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\001n\002K\000\000\001p\001q\000\000\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\164\000\000\002\138\002f\002g\001m\000\000\002\185\002\170\002\173\002\139\000\000\002j\000\000\002\166\000\231\006\006\000\000\002\138\000\000\000\000\000\000\000\000\002\162\002\170\002\173\002\139\000\000\000\000\000\000\002\174\000\000\006\b\000\000\000\000\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\000\000\000\000\000\000\002\174\000\000\000\000\000\000\000\000\000\000\000\000\002\177\000\000\001u\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\001v\000\000\002\177\000\231\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\000\000\000\000\002\164\000\000\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\002\185\000\000\002j\000\000\002\166\000\231\002\164\005\015\000\000\000\000\000\000\002\138\000\000\000\000\002\170\002\173\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\006\n\000\000\000\000\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\002\174\001\135\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\001\144\000\000\001\145\001t\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\002\177\005 \002\139\002\178\000\000\000\000\000\000\000\000\006\015\000\000\002\167\000\000\002\233\000\000\000\000\002\162\002\177\000\000\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\185\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\006\018\002\185\002\170\002\173\000\000\000\000\000\000\002\162\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\0061\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\002\177\0068\002\185\002\178\000\000\000\000\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\006@\002\185\002\170\002\173\000\000\000\000\000\000\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\001\029\002\177\000\000\001\030\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\001 \000\000\002\174\002\138\002f\002g\001m\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\006M\002\185\002\138\000\000\000\000\002\170\002\173\002\162\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\006R\000\000\002\167\000\000\002\233\000\000\000\000\002\162\000\000\000\000\000\000\002\174\002\183\001&\001\145\002\169\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\002\177\000\000\002\185\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001#\002\233\000\000\000\000\000\000\000\000\001\021\001)\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\164\000\000\002\138\002f\002g\001m\000\000\002\185\002\170\002\173\002\139\000\000\002j\000\000\002\166\000\231\006U\000\000\002\138\000\000\000\000\000\000\000\000\002\162\002\170\002\173\002\139\000\000\000\000\001?\002\174\000\000\006\220\000\000\000\000\001\029\000\000\001+\006\147\002\162\001,\000\000\000\000\000\000\001-\001.\002\174\000\000\000\000\000\000\000\000\000\000\000\000\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\001 \002\167\000\000\002\233\000\000\000\000\000\000\002\177\001/\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\000\000\000\000\002\164\000\000\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\002\185\000\000\002j\000\000\002\166\000\231\002\164\000\000\000\000\000\000\000\000\002\138\000\000\000\000\002\170\002\173\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\006\222\001\"\000\000\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\002\174\000\000\002f\002g\001m\000\000\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\006\225\000\000\002\167\000\000\002\233\000\000\000\000\002\162\002\177\000\000\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\185\002\138\000\000\001+\000\000\002j\001,\002\166\000\231\002\139\001-\001.\000\000\000\000\000\000\006\230\002\185\002\170\002\173\000\000\000\000\000\000\002\162\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\001/\000\000\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\006\232\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\002\177\000\000\002\185\002\178\000\000\006[\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\000\000\002\185\002\170\002\173\006*\000\000\000\000\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\001\184\001m\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\237\001}\002\177\001p\001q\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\002\242\002\254\002\255\002\185\000\000\000\000\005\201\002\170\002\173\002\162\000\000\000\000\000\000\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\005\137\002f\002g\001m\000\000\000\000\000\000\002\174\002\183\000\000\001\145\002\169\000\000\000\000\001\133\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\001v\000\000\000\000\000\231\000\000\000\000\002\185\002\180\005\135\000\000\000\000\002\162\000\000\000\000\002\167\000\000\005\137\000\000\000\000\002f\002g\001m\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\002\138\003\002\006W\002j\000\000\002\166\000\231\000\000\002\139\000\000\000\000\000\000\000\000\000\000\002\185\002\170\002\173\000\000\005\139\000\000\000\000\002\162\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\000\000\002\174\000\000\002\138\000\000\002\164\000\000\001\136\000\000\001\145\001t\002\139\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\005\141\000\000\000\000\002\162\000\000\000\000\002\180\000\000\002\170\002\173\000\000\000\000\000\000\002\167\000\000\005\137\001\029\000\000\002f\002g\001m\000\000\000\000\002\183\000\000\001\145\002\169\000\000\002\164\000\000\002\174\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\003c\002\185\000\000\000\000\000\000\005\144\002\170\002\173\002\162\000\000\002\180\002f\002g\001m\000\000\000\000\000\000\002\167\000\000\005\137\000\000\002\164\000\000\000\000\000\000\000\000\002\138\002\183\002\174\001\145\002\169\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\149\002\170\002\173\002\162\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002f\002g\001m\001\"\000\000\000\000\002\167\000\000\005\137\000\000\000\000\000\000\002\174\000\000\000\000\002\138\002\183\002\164\001\145\002\169\001#\000\000\000\000\002\139\000\000\000\000\001\021\001)\000\000\002j\000\000\002\166\000\231\005\154\000\000\000\000\002\162\000\000\002\180\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\005\137\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\000\000\002\185\002\170\002\173\005\159\001+\000\000\002\162\001,\000\000\000\000\002\180\001-\001.\000\000\000\000\003f\000\000\002\167\000\000\005\137\000\000\002\164\000\000\002\174\000\000\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\002j\000\000\002\166\000\231\003g\000\000\000\000\002f\002g\001m\000\000\000\000\002\170\002\173\000\000\000\000\002\180\000\000\002\185\000\000\000\000\000\000\002\138\002\167\000\000\005\137\000\000\000\000\000\000\000\000\002\139\000\000\000\000\002\183\002\174\001\145\002\169\002\164\000\000\000\000\005\182\000\000\000\000\002\162\000\000\002f\002g\001m\000\000\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002\170\002\173\000\000\000\000\000\000\000\000\002\167\006]\005\137\002f\002g\001m\000\000\000\000\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\002\174\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\002f\002g\001m\000\000\002\185\000\000\005\187\000\000\000\000\002\162\002\164\000\000\002\180\000\000\000\000\002\138\000\000\000\000\000\000\002\167\000\000\005\137\002j\002\139\002\166\000\231\000\000\000\000\000\000\002\183\000\000\001\145\002\169\005\192\002\170\002\173\002\162\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002f\002g\001m\000\000\002i\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\174\000\000\000\000\002\138\002j\000\000\002\166\000\231\000\000\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\005\204\000\000\000\000\002\162\000\000\002\180\000\000\000\000\002j\000\000\002\166\000\231\002\167\000\000\005\137\000\000\002f\002g\001m\000\000\002\170\002\173\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\002\138\000\000\001\198\001m\002j\000\000\002\166\000\231\002\139\000\000\000\000\002\174\000\000\000\000\000\000\002\185\002\170\002\173\005\207\002\167\000\000\002\162\001n\002z\000\000\001p\001q\000\000\000\000\002\168\000\000\001\145\002\169\000\000\000\000\000\000\002\164\002\180\002\174\000\000\000\000\000\000\000\000\000\000\002\167\000\000\005\137\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\002\170\002\173\000\000\000\000\002\180\005\210\002\254\002\255\000\000\000\000\000\000\002\167\000\000\005\137\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\183\002\174\001\145\002\169\002\164\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\001\133\000\000\002\138\000\000\002\185\000\000\000\000\002\180\002\170\002\173\002\139\000\000\001v\000\000\002\167\000\231\005\137\002f\002g\001m\005\224\000\000\000\000\002\162\002\183\000\000\001\145\002\169\000\000\000\000\002\174\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\005\213\005\218\000\000\000\000\000\000\000\000\002\185\000\000\005\228\000\000\000\000\002\162\000\000\000\000\002\180\002f\002g\001m\000\000\000\000\000\000\002\167\000\000\005\137\000\000\000\000\000\000\000\000\000\000\000\000\002\138\002\183\000\000\001\145\002\169\000\000\000\000\001\135\002\139\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\001\136\000\000\001\145\001t\002\162\000\000\000\000\000\000\002\185\000\000\002j\000\000\002\166\000\231\001l\001m\000\000\000\000\002f\002g\001m\000\000\002\170\002\173\000\000\001l\001m\000\000\002\164\000\000\000\000\006B\000\000\002\138\001n\002K\000\000\001p\001q\000\000\002j\002\139\002\166\000\231\002\174\001n\002K\000\000\001p\001q\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\001\029\000\000\000\000\001\030\002L\000\000\001@\000\000\000\000\000\000\002\164\000\000\002\180\000\000\000\000\002L\002\174\000\000\000\000\002\167\000\000\005\137\002j\000\000\002\166\000\231\001A\001 \000\000\002\183\000\000\001\145\002\169\001U\002\170\002\173\000\000\000\000\000\000\000\000\000\000\000\000\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\005\137\000\000\002\185\000\000\001u\002\174\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\001u\001v\000\000\000\000\000\231\000\000\002j\001&\002\166\000\231\000\000\000\000\001v\000\000\000\000\000\231\002\180\002\185\002\170\002\173\000\000\000\000\001\"\002\167\000\000\006p\001F\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\000\000\002M\001#\002\174\000\000\002\138\000\000\000\000\001\021\001)\000\000\000\000\002M\002\139\000\000\000\000\000\000\002f\002g\001m\002\185\000\000\004\214\004\220\000\000\000\000\002\162\000\000\000\000\002\180\000\000\001\135\002\138\002O\004\220\000\000\002\167\000\000\006Y\000\000\002\139\001\144\001\135\001\145\001t\000\000\002\183\000\000\001\145\002\169\000\000\000\000\001\144\002\162\001\145\001t\000\000\0015\000\000\000\000\000\000\002f\002g\001m\000\000\001+\000\000\000\000\001,\000\000\002\185\000\000\001-\001.\001P\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\000\000\000\000\000\000\002\162\001/\000\000\000\000\0019\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\002f\002g\001m\000\000\002\170\002\173\000\000\002\164\000\000\000\000\004z\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\002\174\000\000\000\000\000\000\000\000\002\170\002\173\002f\002g\001m\002\162\000\000\004{\006\238\004|\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\002\180\002\174\000\000\000\000\005\023\000\000\000\000\002\167\000\000\006#\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\183\004}\001\145\002\169\000\000\000\000\002\170\002\173\000\000\000\000\002\180\005\199\000\000\000\000\000\000\000\000\000\000\002\167\000\000\006\030\000\000\002f\002g\001m\002\185\000\000\000\000\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\000\000\002\138\004~\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\004\127\004\128\000\000\004\129\002\185\000\000\000\000\002\180\002\170\002\173\002\162\000\000\000\000\000\000\002\167\000\000\005\200\002i\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\004\158\002j\002\174\002\166\000\231\002\138\000\000\000\000\002f\002g\001m\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\138\004\131\006\240\002\162\000\000\002\180\004\133\004\143\002\139\000\000\000\000\000\000\002\167\000\000\005}\000\000\005\026\000\000\000\000\000\000\004\154\002\162\002\183\002\164\001\145\002\169\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\002j\000\000\002\166\000\231\004\155\000\000\000\000\000\000\000\000\002\138\002\167\002\185\002\170\002\173\000\000\000\000\000\000\002\139\000\000\000\000\002\168\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\002\162\000\000\002\164\000\000\002\174\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\164\002\138\000\000\002f\002g\001m\002\170\002\173\000\000\002\139\002\180\000\000\002j\000\000\002\166\000\231\000\000\002\167\000\000\002\228\000\000\000\000\002\162\000\000\002\170\002\173\005\234\002\183\002\174\001\145\002\169\000\000\000\000\005\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\002\174\002f\002g\001m\000\000\002\185\000\000\000\000\002\180\000\000\002j\005\243\002\166\000\231\000\000\002\167\002\138\002\182\000\000\000\000\000\000\000\000\002\170\002\173\002\139\002\183\002\180\001\145\002\169\000\000\000\000\000\000\000\000\002\167\000\000\002\186\000\000\002\162\000\000\000\000\002\164\000\000\000\000\002\183\002\174\001\145\002\169\000\000\000\000\002\185\000\000\000\000\002j\000\000\002\166\000\231\000\000\002i\000\000\000\000\002f\002g\001m\000\000\002\170\002\173\000\000\002\185\000\000\005\245\002\180\002\166\000\231\001\002\000\000\002\138\000\000\002\167\000\000\002\188\000\000\000\000\000\000\002\139\000\000\000\000\002\174\002\183\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\000\000\001\029\000\000\005\237\001'\000\000\002\185\002\180\002j\000\000\002\166\000\231\000\000\000\000\002\167\000\000\002\190\002f\002g\001m\002\170\002\173\000\000\000\000\002\183\000\000\001\145\002\169\001 \000\000\000\000\002\167\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\002\168\002\174\001\145\002\169\000\000\000\000\000\000\002\185\000\000\002f\002g\001m\002\162\000\000\002\164\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\002j\002\180\002\166\000\231\000\000\000\000\005\023\002\138\002\167\000\000\002\192\000\000\002\170\002\173\000\000\002\139\000\000\000\000\002\183\000\000\001\145\002\169\001\"\000\000\000\000\000\000\000\000\000\000\002\162\000\000\005\024\000\000\000\000\000\000\002\174\000\000\002f\002g\001m\001#\000\000\000\000\002\185\000\000\000\000\001\021\001)\000\000\000\000\000\000\002\164\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\002\180\000\000\002j\000\000\002\166\000\231\000\000\002\167\000\000\002\194\000\000\000\000\002\162\000\000\002\170\002\173\000\000\002\183\000\000\001\145\002\169\000\000\000\000\002i\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\002\164\000\000\000\000\002j\002\174\002\166\000\231\000\000\002\138\002\185\001+\000\000\002j\001,\002\166\000\231\002\139\001-\001.\000\000\000\000\000\000\000\000\000\000\002\170\002\173\000\000\000\000\000\000\002\162\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\196\000\000\005\026\000\000\001/\002\164\000\000\002\174\002\183\000\000\001\145\002\169\000\000\002f\002g\001m\000\000\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\138\002\170\002\173\002\167\002\185\002\180\000\000\000\000\002\139\000\000\000\000\000\000\002\167\002\168\002\198\001\145\002\169\000\000\000\000\000\000\000\000\002\162\002\183\002\174\001\145\002\169\002\164\000\000\000\000\002f\002g\001m\000\000\000\000\002f\002g\001m\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\138\000\000\002\185\000\000\000\000\002\180\002\170\002\173\002\139\000\000\000\000\000\000\002\167\006 \002\200\000\000\000\000\000\000\000\000\000\000\000\000\002\162\002\183\000\000\001\145\002\169\000\000\000\000\002\174\000\000\000\000\000\000\000\000\001\029\002f\002g\001m\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\138\000\000\000\000\000\000\002j\002\180\002\166\000\231\002\139\000\000\000\000\000\000\002\167\000\000\002\202\000\000\002\170\002\173\000\000\000\000\000\000\002\162\002\183\000\000\001\145\002\169\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\002\164\000\000\002\174\000\000\000\000\002i\000\000\000\000\002\138\000\000\002\185\000\000\002j\000\000\002\166\000\231\002\139\002j\000\000\002\166\000\231\000\000\000\000\000\000\002\170\002\173\000\000\000\000\002\180\002\162\000\000\000\000\000\000\000\000\000\000\002\167\001\"\002\204\000\000\000\000\000\000\001\029\002f\002g\001m\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\001#\000\000\000\000\000\000\002\138\000\000\001\021\001)\002j\006\143\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\003c\002\180\002\170\002\173\000\000\000\000\000\000\002\162\002\167\000\000\002\206\000\000\000\000\002\167\000\000\002f\002g\001m\002\183\000\000\001\145\002\169\002\164\002\168\002\174\001\145\002\169\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\001+\002\170\002\173\001,\000\000\002\180\002\162\001-\001.\000\000\000\000\000\000\002\167\001\"\002\208\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\001#\000\000\000\000\006\141\002\138\000\000\001\021\001)\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002\170\002\173\000\000\000\000\000\000\002\162\002\167\000\000\002\210\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\000\000\001\145\002\169\002\164\000\000\002\174\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\001+\002\170\002\173\001,\000\000\002\180\002\162\001-\001.\000\000\000\000\003s\002\167\000\000\002\212\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\000\000\000\000\000\000\003v\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002\170\002\173\000\000\000\000\000\000\002\162\002\167\000\000\002\214\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\000\000\001\145\002\169\002\164\000\000\002\174\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\000\000\002\170\002\173\000\000\000\000\002\180\002\162\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\216\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002\170\002\173\000\000\000\000\000\000\002\162\002\167\000\000\002\218\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\000\000\001\145\002\169\002\164\000\000\002\174\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\000\000\002\170\002\173\000\000\000\000\002\180\002\162\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\220\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\002j\001Q\002\166\000\231\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002\170\002\173\002f\002g\001m\000\000\002\167\000\000\002\222\001S\001 \000\000\000\000\000\000\000\000\004-\002\183\002\138\001\145\002\169\002\164\000\000\002\174\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\162\000\000\002\185\000\000\000\000\000\000\002\170\002\173\000\000\000\000\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001&\002\224\000\000\000\000\000\000\002f\002g\001m\000\000\002\183\002\174\001\145\002\169\000\000\000\000\001\"\000\000\000\000\000\000\001F\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\001#\002\185\000\000\000\000\002\180\000\000\001\021\001)\000\000\002\162\000\000\002\167\000\000\002\226\002\164\000\000\000\000\002f\002g\001m\000\000\002\183\000\000\001\145\002\169\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\002\170\002\173\002\139\000\000\000\000\000\000\000\000\002\185\002f\002g\001m\000\000\000\000\000\000\000\000\002\162\000\000\0015\000\000\000\000\000\000\000\000\002\174\002\138\000\000\001+\000\000\000\000\001,\000\000\000\000\002\139\001-\001.\004b\002\164\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\162\000\000\000\000\002j\002\180\002\166\000\231\000\000\000\000\000\000\000\000\002\167\000\000\005\152\001/\002\170\002\173\0019\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\002\174\000\000\000\000\002\138\000\000\000\000\000\000\000\000\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\002\170\002\173\002\162\000\000\002\180\002\164\000\000\000\000\000\000\000\000\002\138\002\167\000\000\005\157\000\000\000\000\000\000\002j\002\139\002\166\000\231\002\183\002\174\001\145\002\169\000\000\000\000\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\180\000\000\000\000\002\174\002\138\000\000\000\000\002\167\000\000\005\162\000\000\000\000\002\139\000\000\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\002\180\002j\000\000\002\166\000\231\000\000\000\000\002\167\000\000\005\168\000\000\000\000\002\185\002\170\002\173\000\000\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\002\174\002\138\000\000\000\000\000\000\000\000\002\185\002\170\002\173\002\139\000\000\000\000\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\002\162\000\000\000\000\002\164\002\180\000\000\000\000\002\174\002\138\000\000\000\000\002\167\000\000\005\173\000\000\002j\002\139\002\166\000\231\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\005\178\000\000\000\000\002\185\000\000\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\002\185\002\180\002j\002\139\002\166\000\231\000\000\000\000\002\167\000\000\005\185\000\000\000\000\000\000\002\170\002\173\002\162\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\002\174\002\138\000\000\000\000\000\000\000\000\002\185\002\170\002\173\002\139\000\000\000\000\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\002\180\000\000\000\000\002\174\002\138\000\000\000\000\002\167\000\000\005\190\000\000\000\000\002\139\000\000\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\002\180\002j\000\000\002\166\000\231\000\000\000\000\002\167\000\000\005\195\000\000\000\000\002\185\002\170\002\173\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\001Q\000\000\002\164\000\000\000\000\000\000\002\174\000\000\000\000\000\000\000\000\000\000\002\185\000\000\002j\000\000\002\166\000\231\000\000\000\000\001S\001 \000\000\000\000\000\000\000\000\002\170\002\173\000\000\000\000\000\000\002\164\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\005\198\000\000\002j\001\029\002\166\000\231\001\030\002\174\002\183\001@\001\145\002\169\000\000\000\000\002\170\002\173\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001m\000\000\001&\000\000\000\000\001E\001 \000\000\002\185\002\180\000\000\000\000\002\174\000\000\000\000\000\000\002\167\001\"\006\023\001n\001}\001F\001p\001q\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\002\180\000\000\001\021\001)\006\020\000\000\000\000\002\167\001\029\006\025\000\000\001\030\002\185\000\000\001&\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\000\000\000\000\001~\000\000\001\127\002F\001\"\000\000\000\000\000\000\001F\000\000\001 \000\000\000\000\000\000\000\000\000\000\002\185\000\000\000\000\000\000\003;\001#\000\000\000\000\000\000\000\000\0015\001\021\001)\000\000\000\000\000\000\000\000\000\000\001+\001\133\006\199\001,\000\000\001l\001m\001-\001.\001P\000\000\000\000\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001&\000\000\002Z\001n\001}\000\000\001p\001q\000\000\000\000\000\000\001/\000\000\000\000\0019\001\"\000\000\000\000\000\000\000\000\0015\000\000\001l\001m\000\000\000\000\002W\000\000\001+\000\000\000\000\001,\001#\000\000\000\000\001-\001.\001P\001\021\001)\000\000\000\000\001n\001}\000\000\001p\001q\001~\000\000\001\127\002F\000\000\001\184\001m\000\000\000\000\000\000\000\000\001\135\000\000\000\000\001/\000\000\000\000\0019\002\137\000\000\000\000\001\136\000\000\001\145\001t\002\237\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\001\029\001\133\000\000\001\030\000\000\001~\0015\001\127\002F\001l\001m\000\000\000\000\001v\001+\000\000\000\231\001,\000\000\000\000\000\000\001-\001.\003F\002Z\000\000\004\213\001 \000\000\001n\002K\000\000\001p\001q\002\242\002\254\002\255\003;\000\000\000\000\001\133\000\000\001\029\000\000\000\000\001\030\000\000\001/\000\000\000\000\0019\000\000\001v\003@\000\000\000\231\000\000\002L\000\000\000\000\000\000\000\000\000\000\002Z\000\000\000\000\000\000\000\000\000\000\001 \001\133\000\000\000\000\001&\000\000\000\000\000\000\000\000\000\000\003;\001\135\000\000\001v\000\000\000\000\000\231\000\000\000\000\001\"\000\000\001\136\000\000\001\145\001t\000\000\004\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\000\000\001u\000\000\000\000\001\021\001)\000\000\000\000\001&\000\000\003\002\003\003\001\135\001v\001\029\000\000\000\231\001\030\000\000\000\000\000\000\000\000\001\136\001\"\001\145\001t\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\001#\001 \001\135\000\000\000\000\000\000\001\021\001)\000\000\000\000\002M\003;\001\136\0015\001\145\001t\000\000\000\000\000\000\000\000\000\000\001+\000\000\001 \001,\000\000\000\000\004\210\001-\001.\003F\004\214\004\220\003;\000\000\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\000\000\001l\001m\000\000\001&\000\000\004\231\001\144\000\000\001\145\001t\001/\0015\000\000\0019\000\000\000\000\000\000\004\244\001\"\001+\001n\002K\001,\001p\001q\001&\001-\001.\003F\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\000\000\001\"\001\021\001)\000\000\000\000\000\000\000\000\000\000\002L\000\000\000\000\000\000\001/\000\000\000\000\0019\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\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\029\000\000\0015\001\030\000\000\000\000\000\000\000\000\001 \000\000\001+\001u\000\000\001,\000\000\000\000\000\000\001-\001.\003F\000\000\000\000\000\000\001v\0015\000\000\000\231\001 \000\000\000\000\000\000\000\000\001+\000\000\000\000\001,\000\000\003;\000\000\001-\001.\003F\000\000\001/\000\000\000\000\0019\000\000\000\000\000\000\000\000\001\184\001m\004\241\001&\000\000\001\184\001m\000\000\000\000\002M\000\000\000\000\000\000\000\000\001/\000\000\000\000\0019\001\"\000\000\002\237\001}\001&\001p\001q\002\237\001}\000\000\001p\001q\004\214\004\220\000\000\000\000\000\000\001#\000\000\001\"\000\000\001\135\000\000\001\021\001)\000\000\000\000\000\000\000\000\000\000\000\000\001\144\000\000\001\145\001t\000\000\001#\000\000\000\000\000\000\001\184\001m\001\021\001)\000\000\002\242\002\254\002\255\000\000\000\000\002\242\002\254\002\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\237\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0015\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001+\001\133\000\000\001,\000\000\000\000\001\133\001-\001.\004?\000\000\0015\004B\001v\000\000\000\000\000\231\000\000\001v\001+\000\000\000\231\001,\002\242\002\254\002\255\001-\001.\003F\000\000\000\000\000\000\000\000\001/\000\000\000\000\0019\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001m\000\000\000\000\003\002\005\002\000\000\000\000\001/\003\002\005)\0019\000\000\000\000\000\000\001\133\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\000\000\000\000\001\135\000\000\006l\000\000\000\000\001\136\000\000\001\145\001t\000\000\001\136\000\000\001\145\001t\000\000\000\000\001l\001m\000\000\000\000\000\000\003\002\005\\\001~\000\000\001\127\002F\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\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\135\001l\001m\000\000\000\000\001\133\006o\000\000\000\000\000\000\001\136\000\000\001\145\001t\000\000\001l\001m\001v\000\000\000\000\000\231\001n\001}\000\000\001p\001q\000\000\001~\002Z\001\127\002F\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\006\215\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\006\218\000\000\000\000\001\029\001\133\000\000\001\030\001~\000\000\001\127\002F\001l\001m\000\000\000\000\000\000\001v\000\000\000\000\000\231\001 \001~\006\150\001\127\002F\000\000\001\135\002Z\000\000\000\000\001 \001n\001}\000\000\001p\001q\001\136\000\000\001\145\001t\003V\000\000\001\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001v\006\135\001\133\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002Z\001&\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\001~\001&\001\127\001\149\002Z\000\000\001\"\000\000\001\135\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\000\000\001\136\000\000\001\145\001t\000\000\001#\000\000\000\000\000\000\000\000\000\146\001\021\001)\000\000\000\000\001#\000\000\001\133\000\000\000\000\000\000\001\021\001)\001l\001m\000\000\000\000\000\000\001\135\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\001\135\001n\001}\000\000\001p\001q\000\000\002f\002g\001m\001\136\001\182\001\145\001t\000\000\000\000\000\000\000\000\0015\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001+\000\000\0015\001,\006\029\000\000\000\000\001-\001.\006\157\001+\000\000\000\000\001,\000\000\000\000\000\000\001-\001.\001~\000\000\001\127\001\170\000\000\001l\001m\000\000\000\000\001\135\000\000\000\000\000\000\000\000\001/\000\000\000\000\0019\000\000\001\136\000\000\001\145\001t\000\000\001/\001n\001}\003]\001p\001q\000\000\001l\001m\000\000\000\000\001\133\001l\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001v\000\000\000\000\000\231\001n\001}\000\000\001p\001q\001n\001}\000\000\001p\001q\001\168\002i\000\000\000\000\000\000\001\172\001l\001m\001~\000\000\001\127\001\202\000\000\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\000\000\001~\000\000\001\127\001\170\000\000\001~\000\000\001\127\001\170\001\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\135\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\000\000\000\000\001\133\001~\000\000\001\127\002F\001\133\000\000\001l\001m\000\000\000\000\002\167\001v\000\000\000\000\000\231\000\000\001v\001\205\000\000\000\231\002\168\000\000\001\145\002\169\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\001\133\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\001v\000\000\000\000\000\231\000\000\001\135\000\000\000\000\000\000\000\000\000\000\006\019\000\000\001\029\000\000\001\136\001\030\001\145\001t\000\000\000\000\000\000\001 \001~\000\000\001\127\002F\000\000\000\000\000\000\000\000\001\135\003V\000\000\005V\000\000\001\135\000\000\000\000\000\000\001 \001\136\000\000\001\145\001t\004-\001\136\003Y\001\145\001t\000\000\000\000\005W\000\000\000\000\005^\000\000\000\000\001\133\000\000\000\000\000\000\000\000\001\029\005_\000\000\001\030\001\135\001&\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\001\136\000\000\001\145\001t\002Y\000\000\001\"\000\000\000\000\001&\000\000\000\000\000\000\001 \000\000\000\000\000\000\005`\005\n\000\000\000\000\000\000\000\000\001#\001\"\000\000\000\000\000\000\000\000\001\021\001)\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\000\000\000\000\000\000\000\000\005a\001\029\000\000\000\000\001\030\001&\001\135\000\000\000\000\001 \005b\000\000\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\001\"\000\000\000\000\000\000\0015\000\000\000\000\000\000\001 \005c\002\173\000\000\001+\000\000\000\000\001,\005q\001#\006N\001-\001.\000\000\0015\001\021\001)\000\000\000\000\000\000\000\000\000\000\001+\005f\000\000\001,\000\000\001&\000\000\001-\001.\0042\000\000\005h\000\000\000\000\000\000\001/\005j\000\000\003]\000\000\001\"\000\000\000\000\000\000\001&\000\000\000\000\000\000\000\000\000\000\005l\000\000\000\000\001/\000\000\000\000\0019\001#\000\000\001\"\000\000\000\000\0015\001\021\001)\000\000\000\000\000\000\000\000\005m\001+\001\029\000\000\001,\001\030\000\000\001#\001-\001.\0042\000\000\000\000\001\021\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\001 \000\000\000\000\001l\001m\001/\000\000\000\000\0019\000\000\000\000\000\000\000\000\000\000\0015\000\000\002f\002g\001m\000\000\000\000\000\000\001+\001n\001}\001,\001p\001q\000\000\001-\001.\004?\000\000\0015\005;\000\000\000\000\000\000\000\000\002h\000\000\001+\007\b\000\000\001,\000\000\001&\000\000\001-\001.\002\146\000\000\000\000\000\000\001\029\001/\000\000\001\030\0019\001l\001m\001\"\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\127\007$\000\000\007&\000\000\001/\000\000\000\000\0019\001#\001n\001}\001 \001p\001q\001\021\001)\000\000\001l\001m\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\133\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\001\029\000\000\001v\001\030\002i\000\231\001 \000\000\000\000\000\000\000\000\001~\000\000\001\127\006\205\001&\002j\000\000\002\166\000\231\000\000\0015\000\000\000\000\000\000\000\000\000\000\001 \000\000\001+\001\"\000\000\001,\000\000\000\000\001J\001-\001.\007\t\001~\000\000\001\127\001\174\000\000\000\000\000\000\001\133\001#\000\000\000\000\000\000\000\000\001&\001\021\001)\000\000\000\000\000\000\001v\000\000\000\000\000\231\001/\000\000\000\000\0019\000\000\001\"\000\000\001\135\000\000\000\000\000\000\001&\001\133\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\002\167\001#\000\000\001v\000\000\001\"\000\231\001\021\001)\000\000\002\168\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\0015\001l\001m\001#\000\000\000\000\000\000\000\000\001+\001\021\001)\001,\000\000\000\000\000\000\001-\001.\001`\000\000\001l\001m\001n\001}\001\135\001p\001q\001l\001m\000\000\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\0015\000\000\001n\001}\001/\001p\001q\0019\001+\001n\001}\001,\001p\001q\001\135\001-\001.\0016\000\000\001l\001m\0015\000\000\000\000\001\136\000\000\001\145\001t\001~\001+\001\127\001\164\001,\000\000\000\000\000\000\001-\001.\000\000\001n\001}\001/\001p\001q\0019\000\000\001~\000\000\001\127\001\161\001l\001m\000\000\001~\000\000\001\127\001\129\000\000\000\000\000\000\000\000\000\000\001/\001\133\000\000\001N\000\000\000\000\000\000\005V\001n\001}\000\000\001p\001q\001v\000\000\000\000\000\231\000\000\000\000\001\133\000\000\001~\007C\001\127\001\131\007D\001\133\000\000\005^\000\000\000\000\001v\000\000\000\000\000\231\000\000\000\000\005_\001v\001\029\000\000\000\231\001\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\127\001\134\001\133\000\000\001l\001m\000\000\000\000\000\000\000\000\000\000\000\000\001 \005`\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\000\000\001n\001}\001\135\001p\001q\000\000\000\000\000\000\000\000\001\133\000\000\000\000\001\136\000\000\001\145\001t\000\000\000\000\000\000\000\000\001\135\001v\000\000\000\000\000\231\000\000\005a\001\135\000\000\000\000\001\136\000\000\001\145\001t\001&\000\000\005b\001\136\000\000\001\145\001t\001l\001m\000\000\001~\000\000\001\127\001\160\000\000\001\"\000\000\000\000\000\000\000\000\000\000\005c\002\173\001\135\007F\000\000\000\000\001n\001}\000\000\001p\001q\001#\001\136\001\029\001\145\001t\001\030\001\021\001)\000\000\000\000\000\000\005f\000\000\001\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005h\001\135\000\000\001\029\001v\005j\001\030\000\231\001 \000\000\000\000\001\136\000\000\001\145\001t\000\000\000\000\000\000\001~\005l\001\127\001\152\000\000\001l\001m\000\000\000\000\000\000\000\000\000\000\001 \000\000\000\000\000\000\0015\000\000\000\000\000\000\005m\000\000\000\000\000\000\001+\001n\001}\001,\001p\001q\000\000\001-\001.\001\154\000\000\001\133\001&\001\029\000\000\000\000\001\030\000\000\000\000\000\000\000\000\000\000\000\000\001v\000\000\000\000\000\231\001\"\000\000\001\135\002f\002g\001m\001/\001&\000\000\0019\000\000\000\000\001\136\001 \001\145\001t\000\000\001#\001~\000\000\001\127\001\157\001\"\001\021\001)\000\000\002\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\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\000\000\000\000\000\000\000\000\000\000\001\133\000\000\001\029\000\000\000\000\001\030\001&\000\000\000\000\000\000\001\135\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\0015\001\136\001\"\001\145\001t\000\000\000\000\000\000\001+\000\000\001 \001,\000\000\000\000\000\000\001-\001.\001\189\000\000\001#\000\000\000\000\0015\000\000\000\000\001\021\001)\000\000\000\000\000\000\001+\002i\000\000\001,\001l\001m\000\000\001-\001.\001\204\000\000\001/\000\000\002j\0019\002\166\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001n\001}\001&\001p\001q\000\000\001\135\000\000\000\000\001/\000\000\000\000\0019\000\000\000\000\000\000\001\136\001\"\001\145\001t\0015\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001+\001l\001m\001,\000\000\000\000\001#\001-\001.\001\251\000\000\000\000\001\021\001)\000\000\000\000\001~\000\000\001\127\002^\000\000\001n\001}\000\000\001p\001q\001\029\000\000\002\167\001\030\000\000\000\000\000\000\001/\000\000\000\000\0019\000\000\002\168\000\000\001\145\002\169\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\001\133\000\000\001 \000\000\000\000\000\000\000\000\000\000\001l\001m\0015\000\000\001v\000\000\001~\000\231\001\127\002c\001+\000\000\001 \001,\000\000\000\000\000\000\001-\001.\001\253\001n\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\001&\001\133\000\000\001/\000\000\000\000\0019\000\000\000\000\000\000\000\000\000\000\000\000\001v\000\000\001\"\000\231\000\000\001&\000\000\000\000\000\000\001 \000\000\001~\000\000\001\127\002\246\000\000\000\000\000\000\001\135\001#\001\"\000\000\000\000\000\000\000\000\001\021\001)\000\000\001\136\001\029\001\145\001t\001\030\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\001\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001&\001 \000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\001\"\000\000\000\000\000\000\0015\000\000\000\000\001\136\000\000\001\145\001t\000\000\001+\000\000\000\000\001,\000\000\001#\000\000\001-\001.\002|\0015\001\021\001)\000\000\000\000\000\000\000\000\000\000\001+\000\000\001&\001,\000\000\000\000\000\000\001-\001.\002\144\000\000\000\000\000\000\000\000\000\000\001/\000\000\001\"\0019\000\000\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\001l\001m\000\000\000\000\000\000\001/\001#\001\136\0019\001\145\001t\000\000\001\021\001)\0015\000\000\001l\001m\000\000\000\000\001n\001}\001+\001p\001q\001,\000\000\001l\001m\001-\001.\002\148\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\000\000\001/\000\000\000\000\0019\000\000\000\000\0015\000\000\000\000\001~\000\000\001\127\002\248\000\000\001+\000\000\001\029\001,\000\000\001\030\000\000\001-\001.\002\239\000\000\001~\001\029\001\127\002\250\001\030\000\000\001l\001m\000\000\000\000\000\000\001~\000\000\001\127\003\001\000\000\000\000\000\000\001 \001\133\000\000\000\000\001/\000\000\000\000\0019\001n\001}\001 \001p\001q\001v\000\000\000\000\000\231\001\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\133\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001v\001\029\000\000\000\231\001\030\000\000\001&\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\127\003\007\001&\000\000\000\000\001\029\000\000\001\"\001\030\000\000\000\000\000\000\000\000\000\000\001 \000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\001\135\000\000\000\000\000\000\001\021\001)\001 \001\133\001#\000\000\001\136\000\000\001\145\001t\001\021\001)\001\135\000\000\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\001\136\001\135\001\145\001t\001\029\000\000\000\000\001\030\001&\000\000\000\000\001\136\000\000\001\145\001t\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\000\000\000\000\001&\0015\000\000\000\000\000\000\001 \000\000\000\000\000\000\001+\000\000\0015\001,\000\000\001#\001\"\001-\001.\003?\001+\001\021\001)\001,\000\000\000\000\000\000\001-\001.\004\011\000\000\000\000\000\000\001#\000\000\001\135\000\000\000\000\000\000\001\021\001)\000\000\000\000\001/\000\000\001\136\0019\001\145\001t\000\000\000\000\000\000\001&\001/\000\000\001\029\0019\000\000\004c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\000\000\000\000\0015\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001+\000\000\000\000\001,\001 \000\000\001#\001-\001.\004\023\0015\001\029\001\021\001)\004c\000\000\000\000\000\000\001+\000\000\000\000\001,\000\000\000\000\000\000\001-\001.\0041\000\000\000\000\000\000\001\029\000\000\001/\004c\000\000\0019\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\004e\001/\000\000\000\000\0019\000\000\000\000\000\000\001 \000\000\000\000\0015\000\000\000\000\000\000\001\"\000\000\000\000\000\000\001+\000\000\000\000\001,\000\000\000\000\000\000\001-\001.\004A\000\000\000\000\000\000\001#\001\029\004e\000\000\004c\000\000\001\021\004h\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\000\000\000\000\001/\001\029\004e\0019\001\030\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\000\000\001#\001\029\000\000\001\"\001\030\000\000\001\021\004h\000\000\000\000\000\000\000\000\000\000\000\000\001 \000\000\000\000\000\000\001l\001m\001#\000\000\001\029\000\000\000\000\001\030\001\021\004h\001 \001+\000\000\000\000\004i\000\000\000\000\000\000\001-\001.\001n\002K\004e\001p\001q\000\000\000\000\000\000\0044\000\000\004m\001 \004k\000\000\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\000\000\001/\001+\000\000\000\000\004i\000\000\000\000\000\000\001-\001.\001#\000\000\001&\001\"\000\000\000\000\001\021\004h\0044\000\000\004l\001+\004k\000\000\004i\000\000\000\000\001\"\001-\001.\001#\000\000\000\000\001&\001/\000\000\001\021\001)\0044\000\000\004j\000\000\004k\000\000\001#\000\000\000\000\000\000\001\"\000\000\001\021\001)\000\000\000\000\001/\001u\000\000\001\029\000\000\000\000\004c\000\000\000\000\000\000\000\000\001#\000\000\001v\000\000\000\000\000\231\001\021\001)\001+\000\000\000\000\004i\000\000\000\000\000\000\001-\001.\000\000\000\000\001 \0015\001\029\000\000\000\000\004c\0044\000\000\004v\001+\004k\000\000\001,\000\000\000\000\0015\001-\001.\004\190\000\000\005I\000\000\001/\001+\000\000\000\000\001,\000\000\000\000\001 \001-\001.\004\207\000\000\000\000\000\000\0015\000\000\000\000\000\000\000\000\000\000\001/\000\000\001+\0019\004e\001,\000\000\000\000\001\135\001-\001.\004\238\001\029\000\000\001/\001\030\000\000\0019\001\144\001\"\001\145\001t\001\029\000\000\000\000\001\030\000\000\000\000\000\000\000\000\000\000\000\000\005K\004e\000\000\001/\001#\000\000\0019\001 \000\000\000\000\001\021\004h\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\001\029\001#\000\000\001\030\000\000\000\000\000\000\001\021\004h\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\001 \000\000\000\000\000\000\001&\000\000\000\000\001\029\001+\001\"\001\030\004i\000\000\000\000\000\000\001-\001.\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\0044\001#\005.\000\000\004k\000\000\000\000\001\021\001)\001 \000\000\001#\001+\000\000\000\000\004i\001/\001\021\001)\001-\001.\001&\000\000\000\000\000\000\001\029\000\000\000\000\001\030\0044\000\000\005F\000\000\004k\000\000\000\000\001\"\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\001 \001#\000\000\001&\0015\000\000\000\000\001\021\001)\000\000\000\000\000\000\001+\000\000\0015\001,\000\000\000\000\001\"\001-\001.\006K\001+\000\000\000\000\001,\000\000\000\000\000\000\001-\001.\006P\005V\000\000\000\000\001#\000\000\000\000\000\000\005V\000\000\001\021\001)\000\000\000\000\001/\001&\007C\0019\000\000\007D\000\000\000\000\005^\007C\001/\0015\007D\0019\000\000\005^\001\"\005_\000\000\001+\000\000\000\000\001,\000\000\005_\000\000\001-\001.\006\156\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\000\000\000\000\000\000\0015\000\000\005`\000\000\005V\000\000\000\000\001/\001+\005`\0019\001,\000\000\000\000\000\000\001-\001.\006\159\000\000\007C\000\000\000\000\007D\000\000\000\000\005^\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\005_\000\000\000\000\000\000\000\000\005a\000\000\001/\000\000\0015\0019\000\000\005a\000\000\000\000\005b\000\000\001+\001\029\000\000\001,\001\030\005b\001 \001-\001.\006\208\000\000\000\000\000\000\005`\000\000\000\000\000\000\005c\002\173\000\000\007E\000\000\000\000\000\000\005c\002\173\000\000\007I\001 \000\000\000\000\000\000\001\029\001/\000\000\001\030\0019\000\000\000\000\005f\000\000\000\000\000\000\000\000\000\000\000\000\005f\000\000\000\000\005h\005a\000\000\001&\000\000\005j\000\000\005h\000\000\000\000\001 \005b\005j\000\000\000\000\000\000\000\000\000\000\001\"\005l\000\000\000\000\000\000\000\000\000\000\001&\005l\000\000\000\000\000\000\005c\002\173\000\000\007N\001\029\001#\000\000\001\030\005m\000\000\001\"\001\021\001)\000\000\000\000\005m\000\000\000\000\000\000\001l\001m\000\000\005f\000\000\000\000\000\000\001&\001#\000\000\000\000\000\000\001 \005h\001\021\001)\000\000\000\000\005j\000\000\001n\002K\001\"\001p\001q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005l\000\000\000\000\001\029\000\000\000\000\004_\001#\000\000\0015\000\000\000\000\000\000\001\021\001)\000\000\000\000\001+\000\000\005m\001,\000\000\000\000\000\000\001-\001.\001&\000\000\001l\001m\001 \0015\000\000\000\000\000\000\000\000\005V\000\000\000\000\001+\000\000\001\"\001,\000\000\000\000\000\000\001-\001.\001n\002K\001/\001p\001q\001L\005W\000\000\000\000\005^\001#\000\000\000\000\000\000\0015\000\000\001\021\001)\005_\001u\000\000\000\000\001+\000\000\001/\001,\000\000\001\246\000\000\001-\001.\001v\001\029\004z\000\231\001\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\005`\000\000\000\000\000\000\000\000\000\000\000\000\001/\000\000\000\000\001\248\001 \001#\004{\000\000\004|\000\000\0015\001\021\001)\005I\000\000\000\000\000\000\000\000\001+\000\000\000\000\001,\000\000\000\000\001u\001-\001.\000\000\000\000\000\000\005a\000\000\000\000\000\000\000\000\000\000\001v\000\000\004}\000\231\005b\000\000\000\000\001\135\000\000\000\000\000\000\000\000\000\000\000\000\001&\001/\000\000\001\144\003X\001\145\001t\000\000\000\000\005c\002\173\000\000\004z\000\000\000\000\001\"\006\131\005J\001+\000\000\000\000\001,\000\000\005I\004~\001-\001.\001\029\000\000\000\000\001\030\005f\001#\000\000\004\127\004\128\000\000\004\129\001\021\001)\004{\005h\004|\000\000\000\000\000\000\005j\000\000\002f\002g\001m\001/\000\000\001\135\001 \000\000\000\000\000\000\000\000\000\000\005l\000\000\004\156\001\144\000\000\001\145\001t\000\000\000\000\000\000\000\000\002\131\004}\000\000\000\000\000\000\000\000\005R\000\000\005m\000\000\000\000\000\000\000\000\000\000\000\000\004\131\001*\000\000\000\000\000\000\004\133\004\143\001l\001m\001+\000\000\000\000\001,\000\000\001&\000\000\001-\001.\000\000\004\154\000\000\000\000\004~\000\000\001l\001m\000\000\001n\001o\001\"\001p\001q\004\127\004\128\000\000\004\129\000\000\000\000\004\155\000\000\000\000\000\000\001/\000\000\001n\001\143\001#\001p\001q\001l\001m\000\000\001\021\001)\000\000\002f\002g\001m\000\000\000\000\004\130\000\000\002i\000\000\002f\002g\001m\000\000\000\000\001n\001\215\000\000\001p\001q\002j\000\000\002\166\000\231\002\155\000\000\000\000\000\000\000\000\000\000\004\131\000\000\000\000\002\165\000\000\004\133\004\143\002f\002g\001m\000\000\000\000\002f\002g\001m\000\000\000\000\006\149\000\000\004\154\000\000\000\000\001u\000\000\000\000\001+\000\000\000\000\001,\000\000\002\184\000\000\001-\001.\001v\005\022\000\000\000\231\004\155\001u\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\004f\000\000\001v\000\000\000\000\000\231\000\000\000\000\002\167\001/\000\000\000\000\000\000\000\000\000\000\001u\000\000\000\000\002\168\000\000\001\145\002\169\002i\000\000\001 \000\000\000\000\001v\000\000\000\000\000\231\002i\000\000\000\000\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\000\000\000\000\000\000\002i\000\000\000\000\000\000\001\144\002i\001\145\001t\000\000\000\000\000\000\001\135\002j\000\000\002\166\000\231\000\000\002j\000\000\002\166\000\231\001\144\000\000\001\145\001t\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001#\000\000\001\144\000\000\001\145\001t\001\021\001)\002\167\002\168\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\002\168\000\000\001\145\002\169\000\000\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\167\000\000\000\000\000\000\000\000\002\167\000\000\000\000\000\000\000\000\002\168\000\000\001\145\002\169\000\000\002\168\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001+\000\000\000\000\001,\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\000\000\000\000\000\000\000\000\000\001/")) and semantic_action = [| @@ -1479,9 +1545,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 4172 "src/ocaml/preprocess/parser_raw.mly" ( "+" ) -# 1485 "src/ocaml/preprocess/parser_raw.ml" +# 1551 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1504,9 +1570,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3966 "src/ocaml/preprocess/parser_raw.mly" +# 4173 "src/ocaml/preprocess/parser_raw.mly" ( "+." ) -# 1510 "src/ocaml/preprocess/parser_raw.ml" +# 1576 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1529,9 +1595,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3514 "src/ocaml/preprocess/parser_raw.mly" +# 3665 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1535 "src/ocaml/preprocess/parser_raw.ml" +# 1601 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1544,14 +1610,14 @@ module Tables = struct 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.semv = _2_inlined1; + MenhirLib.EngineTypes.startp = _startpos__2_inlined1_; + MenhirLib.EngineTypes.endp = _endpos__2_inlined1_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _3; - MenhirLib.EngineTypes.startp = _startpos__3_; - MenhirLib.EngineTypes.endp = _endpos__3_; + MenhirLib.EngineTypes.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _2; @@ -1567,33 +1633,46 @@ module Tables = struct }; }; } = _menhir_stack in - let tyvar : (string) = Obj.magic tyvar in - let _3 : unit = Obj.magic _3 in + let _2_inlined1 : (string) = Obj.magic _2_inlined1 in + let _1 : unit = 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_tyvar_ in + let _endpos = _endpos__2_inlined1_ in let _v : (Parsetree.core_type) = let _1 = - let _1 = -# 3517 "src/ocaml/preprocess/parser_raw.mly" + let _1 = + let tyvar = + let (_endpos__2_, _2) = (_endpos__2_inlined1_, _2_inlined1) in + let _endpos = _endpos__2_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 3613 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _2 _sloc ) +# 1654 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3668 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_alias(ty, tyvar) ) -# 1582 "src/ocaml/preprocess/parser_raw.ml" - in - let (_endpos__1_, _startpos__1_) = (_endpos_tyvar_, _startpos_ty_) in +# 1660 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__2_inlined1_, _startpos_ty_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1591 "src/ocaml/preprocess/parser_raw.ml" +# 1670 "src/ocaml/preprocess/parser_raw.ml" in -# 3519 "src/ocaml/preprocess/parser_raw.mly" +# 3670 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1597 "src/ocaml/preprocess/parser_raw.ml" +# 1676 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1640,30 +1719,30 @@ module Tables = struct let _v : (Ast_helper.let_binding) = let attrs2 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1646 "src/ocaml/preprocess/parser_raw.ml" +# 1725 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1655 "src/ocaml/preprocess/parser_raw.ml" +# 1734 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2758 "src/ocaml/preprocess/parser_raw.mly" +# 2877 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklb ~loc:_sloc false body attrs ) -# 1667 "src/ocaml/preprocess/parser_raw.ml" +# 1746 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1686,9 +1765,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3849 "src/ocaml/preprocess/parser_raw.mly" +# 4056 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1692 "src/ocaml/preprocess/parser_raw.ml" +# 1771 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1711,188 +1790,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3850 "src/ocaml/preprocess/parser_raw.mly" +# 4057 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 1717 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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) = -# 3575 "src/ocaml/preprocess/parser_raw.mly" - ( _2 ) -# 1756 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 3635 "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 ) -# 1823 "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 - -# 4055 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 1833 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4068 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 1839 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos = _endpos__5_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 3577 "src/ocaml/preprocess/parser_raw.mly" - ( wrap_typ_attrs ~loc:_sloc (reloc_typ ~loc:_sloc _4) _3 ) -# 1848 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 = -# 3580 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_var _2 ) -# 1881 "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" - ( mktyp ~loc:_sloc _1 ) -# 1890 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3612 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 1896 "src/ocaml/preprocess/parser_raw.ml" +# 1796 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1905,34 +1805,19 @@ module Tables = struct 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.semv = type_; + MenhirLib.EngineTypes.startp = _startpos_type__; + MenhirLib.EngineTypes.endp = _endpos_type__; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let _1 : unit = Obj.magic _1 in + let type_ : (Parsetree.core_type) = Obj.magic type_ 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 = -# 3582 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_any ) -# 1922 "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" - ( mktyp ~loc:_sloc _1 ) -# 1930 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3612 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 1936 "src/ocaml/preprocess/parser_raw.ml" + let _startpos = _startpos_type__ in + let _endpos = _endpos_type__ in + let _v : (Parsetree.core_type) = +# 3801 "src/ocaml/preprocess/parser_raw.mly" + ( type_ ) +# 1821 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1961,35 +1846,35 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 1967 "src/ocaml/preprocess/parser_raw.ml" +# 1852 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3627 "src/ocaml/preprocess/parser_raw.mly" +# 3834 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 1973 "src/ocaml/preprocess/parser_raw.ml" +# 1858 "src/ocaml/preprocess/parser_raw.ml" in -# 3585 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_constr(tid, tys) ) -# 1978 "src/ocaml/preprocess/parser_raw.ml" +# 3805 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_constr (tid, tys) ) +# 1863 "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" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1987 "src/ocaml/preprocess/parser_raw.ml" +# 1872 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1993 "src/ocaml/preprocess/parser_raw.ml" +# 1878 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2025,20 +1910,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2031 "src/ocaml/preprocess/parser_raw.ml" +# 1916 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3629 "src/ocaml/preprocess/parser_raw.mly" - ( [ty] ) -# 2037 "src/ocaml/preprocess/parser_raw.ml" +# 3836 "src/ocaml/preprocess/parser_raw.mly" + ( [ ty ] ) +# 1922 "src/ocaml/preprocess/parser_raw.ml" in -# 3585 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_constr(tid, tys) ) -# 2042 "src/ocaml/preprocess/parser_raw.ml" +# 3805 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_constr (tid, tys) ) +# 1927 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_ty_ in @@ -2046,15 +1931,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2052 "src/ocaml/preprocess/parser_raw.ml" +# 1937 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2058 "src/ocaml/preprocess/parser_raw.ml" +# 1943 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2105,9 +1990,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2111 "src/ocaml/preprocess/parser_raw.ml" +# 1996 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -2115,24 +2000,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2119 "src/ocaml/preprocess/parser_raw.ml" +# 2004 "src/ocaml/preprocess/parser_raw.ml" in -# 1158 "src/ocaml/preprocess/parser_raw.mly" +# 1245 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2124 "src/ocaml/preprocess/parser_raw.ml" +# 2009 "src/ocaml/preprocess/parser_raw.ml" in -# 3631 "src/ocaml/preprocess/parser_raw.mly" +# 3838 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 2130 "src/ocaml/preprocess/parser_raw.ml" +# 2015 "src/ocaml/preprocess/parser_raw.ml" in -# 3585 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_constr(tid, tys) ) -# 2136 "src/ocaml/preprocess/parser_raw.ml" +# 3805 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_constr (tid, tys) ) +# 2021 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -2140,15 +2025,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2146 "src/ocaml/preprocess/parser_raw.ml" +# 2031 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2152 "src/ocaml/preprocess/parser_raw.ml" +# 2037 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2161,162 +2046,59 @@ module Tables = struct 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.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _; + MenhirLib.EngineTypes.state = _menhir_s; MenhirLib.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; - }; + 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 _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__1_ in - let _endpos = _endpos__3_ in + let _startpos = _startpos__2_ in + let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = - let _1 = -# 3587 "src/ocaml/preprocess/parser_raw.mly" - ( let (f, c) = _2 in Ptyp_object (f, c) ) -# 2192 "src/ocaml/preprocess/parser_raw.ml" - in - let _endpos__1_ = _endpos__3_ in + let _1 = + let cid = + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1062 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 2075 "src/ocaml/preprocess/parser_raw.ml" + + in + let tys = +# 3834 "src/ocaml/preprocess/parser_raw.mly" + ( [] ) +# 2081 "src/ocaml/preprocess/parser_raw.ml" + in + +# 3809 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_class (cid, tys) ) +# 2086 "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 -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2201 "src/ocaml/preprocess/parser_raw.ml" +# 2096 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2207 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 = -# 3589 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_object ([], Closed) ) -# 2240 "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" - ( mktyp ~loc:_sloc _1 ) -# 2249 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3612 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 2255 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 996 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 2293 "src/ocaml/preprocess/parser_raw.ml" - - in - let tys = -# 3627 "src/ocaml/preprocess/parser_raw.mly" - ( [] ) -# 2299 "src/ocaml/preprocess/parser_raw.ml" - in - -# 3593 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_class(cid, tys) ) -# 2304 "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 - -# 1033 "src/ocaml/preprocess/parser_raw.mly" - ( mktyp ~loc:_sloc _1 ) -# 2314 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3612 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 2320 "src/ocaml/preprocess/parser_raw.ml" +# 2102 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2359,20 +2141,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2365 "src/ocaml/preprocess/parser_raw.ml" +# 2147 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3629 "src/ocaml/preprocess/parser_raw.mly" - ( [ty] ) -# 2371 "src/ocaml/preprocess/parser_raw.ml" +# 3836 "src/ocaml/preprocess/parser_raw.mly" + ( [ ty ] ) +# 2153 "src/ocaml/preprocess/parser_raw.ml" in -# 3593 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_class(cid, tys) ) -# 2376 "src/ocaml/preprocess/parser_raw.ml" +# 3809 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_class (cid, tys) ) +# 2158 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_ty_ in @@ -2380,15 +2162,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2386 "src/ocaml/preprocess/parser_raw.ml" +# 2168 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2392 "src/ocaml/preprocess/parser_raw.ml" +# 2174 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2446,9 +2228,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2452 "src/ocaml/preprocess/parser_raw.ml" +# 2234 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -2456,24 +2238,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2460 "src/ocaml/preprocess/parser_raw.ml" +# 2242 "src/ocaml/preprocess/parser_raw.ml" in -# 1158 "src/ocaml/preprocess/parser_raw.mly" +# 1245 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2465 "src/ocaml/preprocess/parser_raw.ml" +# 2247 "src/ocaml/preprocess/parser_raw.ml" in -# 3631 "src/ocaml/preprocess/parser_raw.mly" +# 3838 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 2471 "src/ocaml/preprocess/parser_raw.ml" +# 2253 "src/ocaml/preprocess/parser_raw.ml" in -# 3593 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_class(cid, tys) ) -# 2477 "src/ocaml/preprocess/parser_raw.ml" +# 3809 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_class (cid, tys) ) +# 2259 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -2481,15 +2263,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2487 "src/ocaml/preprocess/parser_raw.ml" +# 2269 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2493 "src/ocaml/preprocess/parser_raw.ml" +# 2275 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2502,9 +2284,9 @@ module Tables = struct 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.semv = type_; + MenhirLib.EngineTypes.startp = _startpos_type__; + MenhirLib.EngineTypes.endp = _endpos_type__; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _2; @@ -2519,32 +2301,44 @@ module Tables = struct }; }; } = _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 type_ : (Parsetree.core_type) = Obj.magic type_ 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 _endpos = _endpos_type__ in let _v : (Parsetree.core_type) = let _1 = - let _1 = -# 3596 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_variant([_2], Closed, None) ) -# 2533 "src/ocaml/preprocess/parser_raw.ml" - in - let _endpos__1_ = _endpos__3_ in + let _1 = + let mod_ident = + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1062 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 2320 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3813 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_open (mod_ident, type_) ) +# 2326 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__1_ = _endpos_type__ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2542 "src/ocaml/preprocess/parser_raw.ml" +# 2336 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2548 "src/ocaml/preprocess/parser_raw.ml" +# 2342 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2557,77 +2351,42 @@ module Tables = struct 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.semv = ident; + MenhirLib.EngineTypes.startp = _startpos_ident_; + MenhirLib.EngineTypes.endp = _endpos_ident_; 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; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 ident : (string) = Obj.magic ident in 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 _endpos = _endpos_ident_ in let _v : (Parsetree.core_type) = let _1 = - let _1 = - let _3 = - let _1 = - let xs = -# 253 "" - ( List.rev xs ) -# 2598 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1130 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 2603 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3641 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 2609 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3598 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_variant(_3, Closed, None) ) -# 2615 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos__1_ = _endpos__4_ in + let _1 = +# 3815 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_var ident ) +# 2375 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos__1_ = _endpos_ident_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2625 "src/ocaml/preprocess/parser_raw.ml" +# 2384 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2631 "src/ocaml/preprocess/parser_raw.ml" +# 2390 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2639,85 +2398,35 @@ module Tables = struct (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; - }; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = - let _1 = - let _4 = - let _1 = - let xs = -# 253 "" - ( List.rev xs ) -# 2688 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1130 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 2693 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3641 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 2699 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3600 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_variant(_2 :: _4, Closed, None) ) -# 2705 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos__1_ = _endpos__5_ in + let _1 = +# 3817 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_any ) +# 2416 "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" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2715 "src/ocaml/preprocess/parser_raw.ml" +# 2424 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2721 "src/ocaml/preprocess/parser_raw.ml" +# 2430 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2729,78 +2438,35 @@ module Tables = struct (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; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 _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.core_type) = let _1 = - let _1 = - let _3 = - let _1 = - let xs = -# 253 "" - ( List.rev xs ) -# 2771 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1130 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 2776 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3641 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 2782 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3602 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_variant(_3, Open, None) ) -# 2788 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos__1_ = _endpos__4_ in + let _endpos = _endpos__1_ in + let _v : (string Location.loc) = let _1 = + let _1 = +# 4239 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 2456 "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" - ( mktyp ~loc:_sloc _1 ) -# 2798 "src/ocaml/preprocess/parser_raw.ml" +# 1092 "src/ocaml/preprocess/parser_raw.mly" + ( mkloc _1 (make_loc _sloc) ) +# 2464 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 2804 "src/ocaml/preprocess/parser_raw.ml" +# 4241 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 2470 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2813,42 +2479,76 @@ module Tables = struct 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.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; + MenhirLib.EngineTypes.state = _; + MenhirLib.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 : unit = Obj.magic _1 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.core_type) = let _1 = + let _endpos = _endpos__3_ in + let _v : (string Location.loc) = let _1 = let _1 = -# 3604 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_variant([], Open, None) ) -# 2837 "src/ocaml/preprocess/parser_raw.ml" +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ^ "." ^ _3.txt ) +# 2510 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos__1_ = _endpos__2_ in + let _endpos__1_ = _endpos__3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" - ( mktyp ~loc:_sloc _1 ) -# 2846 "src/ocaml/preprocess/parser_raw.ml" +# 1092 "src/ocaml/preprocess/parser_raw.mly" + ( mkloc _1 (make_loc _sloc) ) +# 2519 "src/ocaml/preprocess/parser_raw.ml" in -# 3612 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 2852 "src/ocaml/preprocess/parser_raw.ml" +# 4241 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 2525 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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.payload) = 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) = +# 4296 "src/ocaml/preprocess/parser_raw.mly" + ( Builtin_attributes.mark_payload_attrs_used _1; + _1 + ) +# 2552 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2866,9 +2566,9 @@ module Tables = struct 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.semv = _3; + MenhirLib.EngineTypes.startp = _startpos__3_; + MenhirLib.EngineTypes.endp = _endpos__3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _2; @@ -2885,53 +2585,19 @@ module Tables = struct }; } = _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 _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.core_type) = let _1 = - let _1 = - let _3 = - let _1 = - let xs = -# 253 "" - ( List.rev xs ) -# 2902 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1130 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 2907 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3641 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 2913 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3606 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_variant(_3, Closed, Some []) ) -# 2919 "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" - ( mktyp ~loc:_sloc _1 ) -# 2929 "src/ocaml/preprocess/parser_raw.ml" - - in + let _v : (Parsetree.attribute) = let _endpos = _endpos__4_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in -# 3612 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 2935 "src/ocaml/preprocess/parser_raw.ml" +# 4245 "src/ocaml/preprocess/parser_raw.mly" + ( mk_attr ~loc:(make_loc _sloc) _2 _3 ) +# 2601 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2943,321 +2609,20 @@ module Tables = struct (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; - }; - }; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 _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__6_ in - let _v : (Parsetree.core_type) = let _1 = - let _1 = - let _5 = - let xs = xs_inlined1 in - let _1 = - let xs = -# 253 "" - ( List.rev xs ) -# 3000 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1098 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 3005 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3669 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 3011 "src/ocaml/preprocess/parser_raw.ml" - - in - let _3 = - let _1 = - let xs = -# 253 "" - ( List.rev xs ) -# 3019 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1130 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 3024 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3641 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 3030 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3608 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_variant(_3, Closed, Some _5) ) -# 3036 "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 - -# 1033 "src/ocaml/preprocess/parser_raw.mly" - ( mktyp ~loc:_sloc _1 ) -# 3046 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3612 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 3052 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - MenhirLib.EngineTypes.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 = -# 3610 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_extension _1 ) -# 3078 "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" - ( mktyp ~loc:_sloc _1 ) -# 3086 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3612 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 3092 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - MenhirLib.EngineTypes.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 = -# 4032 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 3118 "src/ocaml/preprocess/parser_raw.ml" - in - let _endpos = _endpos__1_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 1026 "src/ocaml/preprocess/parser_raw.mly" - ( mkloc _1 (make_loc _sloc) ) -# 3126 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4034 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 3132 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 = -# 4033 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ^ "." ^ _3.txt ) -# 3172 "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 - -# 1026 "src/ocaml/preprocess/parser_raw.mly" - ( mkloc _1 (make_loc _sloc) ) -# 3181 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4034 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 3187 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 4038 "src/ocaml/preprocess/parser_raw.mly" - ( Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 3236 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - MenhirLib.EngineTypes.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) = -# 2017 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 3261 "src/ocaml/preprocess/parser_raw.ml" + let _endpos = _endpos__1_ in + let _v : (Parsetree.class_expr) = +# 2104 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 2626 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3296,18 +2661,18 @@ module Tables = struct let _v : (Parsetree.class_expr) = let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3302 "src/ocaml/preprocess/parser_raw.ml" +# 2667 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2019 "src/ocaml/preprocess/parser_raw.mly" +# 2106 "src/ocaml/preprocess/parser_raw.mly" ( wrap_class_attrs ~loc:_sloc _3 _2 ) -# 3311 "src/ocaml/preprocess/parser_raw.ml" +# 2676 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3347,9 +2712,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2021 "src/ocaml/preprocess/parser_raw.mly" +# 2108 "src/ocaml/preprocess/parser_raw.mly" ( class_of_let_bindings ~loc:_sloc _1 _3 ) -# 3353 "src/ocaml/preprocess/parser_raw.ml" +# 2718 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3412,34 +2777,34 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 3418 "src/ocaml/preprocess/parser_raw.ml" +# 2783 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in let _4 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3427 "src/ocaml/preprocess/parser_raw.ml" +# 2792 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 3433 "src/ocaml/preprocess/parser_raw.ml" +# 2798 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2023 "src/ocaml/preprocess/parser_raw.mly" +# 2110 "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)) ) -# 3443 "src/ocaml/preprocess/parser_raw.ml" +# 2808 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3509,37 +2874,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 3515 "src/ocaml/preprocess/parser_raw.ml" +# 2880 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3524 "src/ocaml/preprocess/parser_raw.ml" +# 2889 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 3532 "src/ocaml/preprocess/parser_raw.ml" +# 2897 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2023 "src/ocaml/preprocess/parser_raw.mly" +# 2110 "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)) ) -# 3543 "src/ocaml/preprocess/parser_raw.ml" +# 2908 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3569,9 +2934,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = -# 2027 "src/ocaml/preprocess/parser_raw.mly" +# 2114 "src/ocaml/preprocess/parser_raw.mly" ( Cl.attr _1 _2 ) -# 3575 "src/ocaml/preprocess/parser_raw.ml" +# 2940 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3606,18 +2971,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 3610 "src/ocaml/preprocess/parser_raw.ml" +# 2975 "src/ocaml/preprocess/parser_raw.ml" in -# 1098 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 3615 "src/ocaml/preprocess/parser_raw.ml" +# 2980 "src/ocaml/preprocess/parser_raw.ml" in -# 2030 "src/ocaml/preprocess/parser_raw.mly" +# 2117 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_apply(_1, _2) ) -# 3621 "src/ocaml/preprocess/parser_raw.ml" +# 2986 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -3625,15 +2990,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1049 "src/ocaml/preprocess/parser_raw.mly" +# 1115 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3631 "src/ocaml/preprocess/parser_raw.ml" +# 2996 "src/ocaml/preprocess/parser_raw.ml" in -# 2033 "src/ocaml/preprocess/parser_raw.mly" +# 2120 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3637 "src/ocaml/preprocess/parser_raw.ml" +# 3002 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3657,23 +3022,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2032 "src/ocaml/preprocess/parser_raw.mly" +# 2119 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_extension _1 ) -# 3663 "src/ocaml/preprocess/parser_raw.ml" +# 3028 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1049 "src/ocaml/preprocess/parser_raw.mly" +# 1115 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3671 "src/ocaml/preprocess/parser_raw.ml" +# 3036 "src/ocaml/preprocess/parser_raw.ml" in -# 2033 "src/ocaml/preprocess/parser_raw.mly" +# 2120 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3677 "src/ocaml/preprocess/parser_raw.ml" +# 3042 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3726,33 +3091,33 @@ module Tables = struct let _v : (Parsetree.class_field) = let _6 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3732 "src/ocaml/preprocess/parser_raw.ml" +# 3097 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3741 "src/ocaml/preprocess/parser_raw.ml" +# 3106 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 3747 "src/ocaml/preprocess/parser_raw.ml" +# 3112 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2088 "src/ocaml/preprocess/parser_raw.mly" +# 2175 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3756 "src/ocaml/preprocess/parser_raw.ml" +# 3121 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3812,36 +3177,36 @@ module Tables = struct let _v : (Parsetree.class_field) = let _6 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3818 "src/ocaml/preprocess/parser_raw.ml" +# 3183 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _3 = let _1 = _1_inlined2 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3827 "src/ocaml/preprocess/parser_raw.ml" +# 3192 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 3835 "src/ocaml/preprocess/parser_raw.ml" +# 3200 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2088 "src/ocaml/preprocess/parser_raw.mly" +# 2175 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3845 "src/ocaml/preprocess/parser_raw.ml" +# 3210 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3881,9 +3246,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _3 = let _1 = _1_inlined1 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3887 "src/ocaml/preprocess/parser_raw.ml" +# 3252 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3891,11 +3256,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2091 "src/ocaml/preprocess/parser_raw.mly" +# 2178 "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 ) -# 3899 "src/ocaml/preprocess/parser_raw.ml" +# 3264 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3935,9 +3300,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _3 = let _1 = _1_inlined1 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3941 "src/ocaml/preprocess/parser_raw.ml" +# 3306 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3945,11 +3310,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2095 "src/ocaml/preprocess/parser_raw.mly" +# 2182 "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 ) -# 3953 "src/ocaml/preprocess/parser_raw.ml" +# 3318 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3995,28 +3360,28 @@ module Tables = struct let _v : (Parsetree.class_field) = let _4 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4001 "src/ocaml/preprocess/parser_raw.ml" +# 3366 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4010 "src/ocaml/preprocess/parser_raw.ml" +# 3375 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2099 "src/ocaml/preprocess/parser_raw.mly" +# 2186 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 4020 "src/ocaml/preprocess/parser_raw.ml" +# 3385 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4062,28 +3427,28 @@ module Tables = struct let _v : (Parsetree.class_field) = let _4 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4068 "src/ocaml/preprocess/parser_raw.ml" +# 3433 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4077 "src/ocaml/preprocess/parser_raw.ml" +# 3442 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2102 "src/ocaml/preprocess/parser_raw.mly" +# 2189 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_initializer _3) ~attrs:(_2@_4) ~docs ) -# 4087 "src/ocaml/preprocess/parser_raw.ml" +# 3452 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4115,9 +3480,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _2 = let _1 = _1_inlined1 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4121 "src/ocaml/preprocess/parser_raw.ml" +# 3486 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -4125,10 +3490,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2105 "src/ocaml/preprocess/parser_raw.mly" +# 2192 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_extension _1) ~attrs:_2 ~docs ) -# 4132 "src/ocaml/preprocess/parser_raw.ml" +# 3497 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4152,23 +3517,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_field) = let _1 = let _1 = -# 2108 "src/ocaml/preprocess/parser_raw.mly" +# 2195 "src/ocaml/preprocess/parser_raw.mly" ( Pcf_attribute _1 ) -# 4158 "src/ocaml/preprocess/parser_raw.ml" +# 3523 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1047 "src/ocaml/preprocess/parser_raw.mly" +# 1113 "src/ocaml/preprocess/parser_raw.mly" ( mkcf ~loc:_sloc _1 ) -# 4166 "src/ocaml/preprocess/parser_raw.ml" +# 3531 "src/ocaml/preprocess/parser_raw.ml" in -# 2109 "src/ocaml/preprocess/parser_raw.mly" +# 2196 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4172 "src/ocaml/preprocess/parser_raw.ml" +# 3537 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4198,9 +3563,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = -# 1997 "src/ocaml/preprocess/parser_raw.mly" +# 2084 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 4204 "src/ocaml/preprocess/parser_raw.ml" +# 3569 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4245,24 +3610,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2000 "src/ocaml/preprocess/parser_raw.mly" +# 2087 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constraint(_4, _2) ) -# 4251 "src/ocaml/preprocess/parser_raw.ml" +# 3616 "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 -# 1049 "src/ocaml/preprocess/parser_raw.mly" +# 1115 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4260 "src/ocaml/preprocess/parser_raw.ml" +# 3625 "src/ocaml/preprocess/parser_raw.ml" in -# 2003 "src/ocaml/preprocess/parser_raw.mly" +# 2090 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4266 "src/ocaml/preprocess/parser_raw.ml" +# 3631 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4293,24 +3658,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2002 "src/ocaml/preprocess/parser_raw.mly" +# 2089 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, _2) ) -# 4299 "src/ocaml/preprocess/parser_raw.ml" +# 3664 "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 -# 1049 "src/ocaml/preprocess/parser_raw.mly" +# 1115 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4308 "src/ocaml/preprocess/parser_raw.ml" +# 3673 "src/ocaml/preprocess/parser_raw.ml" in -# 2003 "src/ocaml/preprocess/parser_raw.mly" +# 2090 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4314 "src/ocaml/preprocess/parser_raw.ml" +# 3679 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4348,24 +3713,24 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2064 "src/ocaml/preprocess/parser_raw.mly" +# 2151 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 4354 "src/ocaml/preprocess/parser_raw.ml" +# 3719 "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 -# 1049 "src/ocaml/preprocess/parser_raw.mly" +# 1115 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4363 "src/ocaml/preprocess/parser_raw.ml" +# 3728 "src/ocaml/preprocess/parser_raw.ml" in -# 2065 "src/ocaml/preprocess/parser_raw.mly" +# 2152 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4369 "src/ocaml/preprocess/parser_raw.ml" +# 3734 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4396,24 +3761,24 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2064 "src/ocaml/preprocess/parser_raw.mly" +# 2151 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 4402 "src/ocaml/preprocess/parser_raw.ml" +# 3767 "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 -# 1049 "src/ocaml/preprocess/parser_raw.mly" +# 1115 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 4411 "src/ocaml/preprocess/parser_raw.ml" +# 3776 "src/ocaml/preprocess/parser_raw.ml" in -# 2065 "src/ocaml/preprocess/parser_raw.mly" +# 2152 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4417 "src/ocaml/preprocess/parser_raw.ml" +# 3782 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4436,9 +3801,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3839 "src/ocaml/preprocess/parser_raw.mly" +# 4046 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4442 "src/ocaml/preprocess/parser_raw.ml" +# 3807 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4478,9 +3843,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2073 "src/ocaml/preprocess/parser_raw.mly" +# 2160 "src/ocaml/preprocess/parser_raw.mly" ( reloc_pat ~loc:_sloc _2 ) -# 4484 "src/ocaml/preprocess/parser_raw.ml" +# 3849 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4532,24 +3897,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2075 "src/ocaml/preprocess/parser_raw.mly" +# 2162 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_2, _4) ) -# 4538 "src/ocaml/preprocess/parser_raw.ml" +# 3903 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 4547 "src/ocaml/preprocess/parser_raw.ml" +# 3912 "src/ocaml/preprocess/parser_raw.ml" in -# 2076 "src/ocaml/preprocess/parser_raw.mly" +# 2163 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4553 "src/ocaml/preprocess/parser_raw.ml" +# 3918 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4568,9 +3933,9 @@ module Tables = struct let _symbolstartpos = _endpos in let _sloc = (_symbolstartpos, _endpos) in -# 2078 "src/ocaml/preprocess/parser_raw.mly" +# 2165 "src/ocaml/preprocess/parser_raw.mly" ( ghpat ~loc:_sloc Ppat_any ) -# 4574 "src/ocaml/preprocess/parser_raw.ml" +# 3939 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4607,9 +3972,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = -# 2205 "src/ocaml/preprocess/parser_raw.mly" +# 2292 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 4613 "src/ocaml/preprocess/parser_raw.ml" +# 3978 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4626,24 +3991,24 @@ module Tables = struct let _endpos = _startpos in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 2206 "src/ocaml/preprocess/parser_raw.mly" +# 2293 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 4632 "src/ocaml/preprocess/parser_raw.ml" +# 3997 "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 -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 4641 "src/ocaml/preprocess/parser_raw.ml" +# 4006 "src/ocaml/preprocess/parser_raw.ml" in -# 2207 "src/ocaml/preprocess/parser_raw.mly" +# 2294 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4647 "src/ocaml/preprocess/parser_raw.ml" +# 4012 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4689,28 +4054,28 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4695 "src/ocaml/preprocess/parser_raw.ml" +# 4060 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4704 "src/ocaml/preprocess/parser_raw.ml" +# 4069 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2215 "src/ocaml/preprocess/parser_raw.mly" +# 2302 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_inherit _3) ~attrs:(_2@_4) ~docs ) -# 4714 "src/ocaml/preprocess/parser_raw.ml" +# 4079 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4768,9 +4133,9 @@ module Tables = struct let ty : (Parsetree.core_type) = Obj.magic ty in let _3 : unit = Obj.magic _3 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 4774 "src/ocaml/preprocess/parser_raw.ml" +# 4139 "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 @@ -4781,9 +4146,9 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4787 "src/ocaml/preprocess/parser_raw.ml" +# 4152 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined3_ in @@ -4791,44 +4156,44 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let label = let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4797 "src/ocaml/preprocess/parser_raw.ml" +# 4162 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4805 "src/ocaml/preprocess/parser_raw.ml" +# 4170 "src/ocaml/preprocess/parser_raw.ml" in -# 2240 "src/ocaml/preprocess/parser_raw.mly" +# 2327 "src/ocaml/preprocess/parser_raw.mly" ( let mut, virt = flags in label, mut, virt, ty ) -# 4814 "src/ocaml/preprocess/parser_raw.ml" +# 4179 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4822 "src/ocaml/preprocess/parser_raw.ml" +# 4187 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2218 "src/ocaml/preprocess/parser_raw.mly" +# 2305 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_val _3) ~attrs:(_2@_4) ~docs ) -# 4832 "src/ocaml/preprocess/parser_raw.ml" +# 4197 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4886,9 +4251,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 4892 "src/ocaml/preprocess/parser_raw.ml" +# 4257 "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 @@ -4899,53 +4264,53 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _7 = let _1 = _1_inlined4 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4905 "src/ocaml/preprocess/parser_raw.ml" +# 4270 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__7_ = _endpos__1_inlined4_ in let _6 = let _1 = _1_inlined3 in -# 3480 "src/ocaml/preprocess/parser_raw.mly" +# 3631 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4914 "src/ocaml/preprocess/parser_raw.ml" +# 4279 "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 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4922 "src/ocaml/preprocess/parser_raw.ml" +# 4287 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4930 "src/ocaml/preprocess/parser_raw.ml" +# 4295 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4938 "src/ocaml/preprocess/parser_raw.ml" +# 4303 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2222 "src/ocaml/preprocess/parser_raw.mly" +# 2309 "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 ) -# 4949 "src/ocaml/preprocess/parser_raw.ml" +# 4314 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4991,28 +4356,28 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4997 "src/ocaml/preprocess/parser_raw.ml" +# 4362 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5006 "src/ocaml/preprocess/parser_raw.ml" +# 4371 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2226 "src/ocaml/preprocess/parser_raw.mly" +# 2313 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 5016 "src/ocaml/preprocess/parser_raw.ml" +# 4381 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5044,9 +4409,9 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _2 = let _1 = _1_inlined1 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5050 "src/ocaml/preprocess/parser_raw.ml" +# 4415 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -5054,10 +4419,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2229 "src/ocaml/preprocess/parser_raw.mly" +# 2316 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_extension _1) ~attrs:_2 ~docs ) -# 5061 "src/ocaml/preprocess/parser_raw.ml" +# 4426 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5081,23 +4446,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_type_field) = let _1 = let _1 = -# 2232 "src/ocaml/preprocess/parser_raw.mly" +# 2319 "src/ocaml/preprocess/parser_raw.mly" ( Pctf_attribute _1 ) -# 5087 "src/ocaml/preprocess/parser_raw.ml" +# 4452 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1045 "src/ocaml/preprocess/parser_raw.mly" +# 1111 "src/ocaml/preprocess/parser_raw.mly" ( mkctf ~loc:_sloc _1 ) -# 5095 "src/ocaml/preprocess/parser_raw.ml" +# 4460 "src/ocaml/preprocess/parser_raw.ml" in -# 2233 "src/ocaml/preprocess/parser_raw.mly" +# 2320 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5101 "src/ocaml/preprocess/parser_raw.ml" +# 4466 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5126,42 +4491,42 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5132 "src/ocaml/preprocess/parser_raw.ml" +# 4497 "src/ocaml/preprocess/parser_raw.ml" in let tys = let tys = -# 2191 "src/ocaml/preprocess/parser_raw.mly" +# 2278 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 5139 "src/ocaml/preprocess/parser_raw.ml" +# 4504 "src/ocaml/preprocess/parser_raw.ml" in -# 2197 "src/ocaml/preprocess/parser_raw.mly" +# 2284 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5144 "src/ocaml/preprocess/parser_raw.ml" +# 4509 "src/ocaml/preprocess/parser_raw.ml" in -# 2172 "src/ocaml/preprocess/parser_raw.mly" +# 2259 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_constr (cid, tys) ) -# 5150 "src/ocaml/preprocess/parser_raw.ml" +# 4515 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1109 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5159 "src/ocaml/preprocess/parser_raw.ml" +# 4524 "src/ocaml/preprocess/parser_raw.ml" in -# 2175 "src/ocaml/preprocess/parser_raw.mly" +# 2262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5165 "src/ocaml/preprocess/parser_raw.ml" +# 4530 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5212,9 +4577,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5218 "src/ocaml/preprocess/parser_raw.ml" +# 4583 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -5223,30 +4588,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5227 "src/ocaml/preprocess/parser_raw.ml" +# 4592 "src/ocaml/preprocess/parser_raw.ml" in -# 1130 "src/ocaml/preprocess/parser_raw.mly" +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 5232 "src/ocaml/preprocess/parser_raw.ml" +# 4597 "src/ocaml/preprocess/parser_raw.ml" in -# 2193 "src/ocaml/preprocess/parser_raw.mly" +# 2280 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 5238 "src/ocaml/preprocess/parser_raw.ml" +# 4603 "src/ocaml/preprocess/parser_raw.ml" in -# 2197 "src/ocaml/preprocess/parser_raw.mly" +# 2284 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5244 "src/ocaml/preprocess/parser_raw.ml" +# 4609 "src/ocaml/preprocess/parser_raw.ml" in -# 2172 "src/ocaml/preprocess/parser_raw.mly" +# 2259 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_constr (cid, tys) ) -# 5250 "src/ocaml/preprocess/parser_raw.ml" +# 4615 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5254,15 +4619,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1109 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5260 "src/ocaml/preprocess/parser_raw.ml" +# 4625 "src/ocaml/preprocess/parser_raw.ml" in -# 2175 "src/ocaml/preprocess/parser_raw.mly" +# 2262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5266 "src/ocaml/preprocess/parser_raw.ml" +# 4631 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5286,23 +4651,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_type) = let _1 = let _1 = -# 2174 "src/ocaml/preprocess/parser_raw.mly" +# 2261 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_extension _1 ) -# 5292 "src/ocaml/preprocess/parser_raw.ml" +# 4657 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1109 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5300 "src/ocaml/preprocess/parser_raw.ml" +# 4665 "src/ocaml/preprocess/parser_raw.ml" in -# 2175 "src/ocaml/preprocess/parser_raw.mly" +# 2262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5306 "src/ocaml/preprocess/parser_raw.ml" +# 4671 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5359,44 +4724,44 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5363 "src/ocaml/preprocess/parser_raw.ml" +# 4728 "src/ocaml/preprocess/parser_raw.ml" in -# 2211 "src/ocaml/preprocess/parser_raw.mly" +# 2298 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5368 "src/ocaml/preprocess/parser_raw.ml" +# 4733 "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 -# 991 "src/ocaml/preprocess/parser_raw.mly" +# 1057 "src/ocaml/preprocess/parser_raw.mly" ( extra_csig _startpos _endpos _1 ) -# 5377 "src/ocaml/preprocess/parser_raw.ml" +# 4742 "src/ocaml/preprocess/parser_raw.ml" in -# 2201 "src/ocaml/preprocess/parser_raw.mly" +# 2288 "src/ocaml/preprocess/parser_raw.mly" ( Csig.mk _1 _2 ) -# 5383 "src/ocaml/preprocess/parser_raw.ml" +# 4748 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5391 "src/ocaml/preprocess/parser_raw.ml" +# 4756 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2177 "src/ocaml/preprocess/parser_raw.mly" +# 2264 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc ~attrs:_2 (Pcty_signature _3) ) -# 5400 "src/ocaml/preprocess/parser_raw.ml" +# 4765 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5426,9 +4791,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_type) = -# 2183 "src/ocaml/preprocess/parser_raw.mly" +# 2270 "src/ocaml/preprocess/parser_raw.mly" ( Cty.attr _1 _2 ) -# 5432 "src/ocaml/preprocess/parser_raw.ml" +# 4797 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5491,34 +4856,34 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5497 "src/ocaml/preprocess/parser_raw.ml" +# 4862 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in let _4 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5506 "src/ocaml/preprocess/parser_raw.ml" +# 4871 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 5512 "src/ocaml/preprocess/parser_raw.ml" +# 4877 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2185 "src/ocaml/preprocess/parser_raw.mly" +# 2272 "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)) ) -# 5522 "src/ocaml/preprocess/parser_raw.ml" +# 4887 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5588,37 +4953,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5594 "src/ocaml/preprocess/parser_raw.ml" +# 4959 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5603 "src/ocaml/preprocess/parser_raw.ml" +# 4968 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 5611 "src/ocaml/preprocess/parser_raw.ml" +# 4976 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2185 "src/ocaml/preprocess/parser_raw.mly" +# 2272 "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)) ) -# 5622 "src/ocaml/preprocess/parser_raw.ml" +# 4987 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5655,9 +5020,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.class_expr) = -# 2037 "src/ocaml/preprocess/parser_raw.mly" +# 2124 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 5661 "src/ocaml/preprocess/parser_raw.ml" +# 5026 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5686,42 +5051,42 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5692 "src/ocaml/preprocess/parser_raw.ml" +# 5057 "src/ocaml/preprocess/parser_raw.ml" in let tys = let tys = -# 2191 "src/ocaml/preprocess/parser_raw.mly" +# 2278 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 5699 "src/ocaml/preprocess/parser_raw.ml" +# 5064 "src/ocaml/preprocess/parser_raw.ml" in -# 2197 "src/ocaml/preprocess/parser_raw.mly" +# 2284 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5704 "src/ocaml/preprocess/parser_raw.ml" +# 5069 "src/ocaml/preprocess/parser_raw.ml" in -# 2044 "src/ocaml/preprocess/parser_raw.mly" +# 2131 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constr(cid, tys) ) -# 5710 "src/ocaml/preprocess/parser_raw.ml" +# 5075 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1049 "src/ocaml/preprocess/parser_raw.mly" +# 1115 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5719 "src/ocaml/preprocess/parser_raw.ml" +# 5084 "src/ocaml/preprocess/parser_raw.ml" in -# 2055 "src/ocaml/preprocess/parser_raw.mly" +# 2142 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5725 "src/ocaml/preprocess/parser_raw.ml" +# 5090 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5772,9 +5137,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5778 "src/ocaml/preprocess/parser_raw.ml" +# 5143 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -5783,30 +5148,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5787 "src/ocaml/preprocess/parser_raw.ml" +# 5152 "src/ocaml/preprocess/parser_raw.ml" in -# 1130 "src/ocaml/preprocess/parser_raw.mly" +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 5792 "src/ocaml/preprocess/parser_raw.ml" +# 5157 "src/ocaml/preprocess/parser_raw.ml" in -# 2193 "src/ocaml/preprocess/parser_raw.mly" +# 2280 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 5798 "src/ocaml/preprocess/parser_raw.ml" +# 5163 "src/ocaml/preprocess/parser_raw.ml" in -# 2197 "src/ocaml/preprocess/parser_raw.mly" +# 2284 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5804 "src/ocaml/preprocess/parser_raw.ml" +# 5169 "src/ocaml/preprocess/parser_raw.ml" in -# 2044 "src/ocaml/preprocess/parser_raw.mly" +# 2131 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constr(cid, tys) ) -# 5810 "src/ocaml/preprocess/parser_raw.ml" +# 5175 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5814,15 +5179,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1049 "src/ocaml/preprocess/parser_raw.mly" +# 1115 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5820 "src/ocaml/preprocess/parser_raw.ml" +# 5185 "src/ocaml/preprocess/parser_raw.ml" in -# 2055 "src/ocaml/preprocess/parser_raw.mly" +# 2142 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5826 "src/ocaml/preprocess/parser_raw.ml" +# 5191 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5874,24 +5239,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2050 "src/ocaml/preprocess/parser_raw.mly" +# 2137 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constraint(_2, _4) ) -# 5880 "src/ocaml/preprocess/parser_raw.ml" +# 5245 "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 -# 1049 "src/ocaml/preprocess/parser_raw.mly" +# 1115 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5889 "src/ocaml/preprocess/parser_raw.ml" +# 5254 "src/ocaml/preprocess/parser_raw.ml" in -# 2055 "src/ocaml/preprocess/parser_raw.mly" +# 2142 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5895 "src/ocaml/preprocess/parser_raw.ml" +# 5260 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5948,44 +5313,44 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5952 "src/ocaml/preprocess/parser_raw.ml" +# 5317 "src/ocaml/preprocess/parser_raw.ml" in -# 2082 "src/ocaml/preprocess/parser_raw.mly" +# 2169 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5957 "src/ocaml/preprocess/parser_raw.ml" +# 5322 "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 -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 1056 "src/ocaml/preprocess/parser_raw.mly" ( extra_cstr _startpos _endpos _1 ) -# 5966 "src/ocaml/preprocess/parser_raw.ml" +# 5331 "src/ocaml/preprocess/parser_raw.ml" in -# 2069 "src/ocaml/preprocess/parser_raw.mly" +# 2156 "src/ocaml/preprocess/parser_raw.mly" ( Cstr.mk _1 _2 ) -# 5972 "src/ocaml/preprocess/parser_raw.ml" +# 5337 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5980 "src/ocaml/preprocess/parser_raw.ml" +# 5345 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2057 "src/ocaml/preprocess/parser_raw.mly" +# 2144 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc ~attrs:_2 (Pcl_structure _3) ) -# 5989 "src/ocaml/preprocess/parser_raw.ml" +# 5354 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6008,9 +5373,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.class_type) = -# 2160 "src/ocaml/preprocess/parser_raw.mly" +# 2247 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6014 "src/ocaml/preprocess/parser_raw.ml" +# 5379 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6056,14 +5421,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3543 "src/ocaml/preprocess/parser_raw.mly" +# 3694 "src/ocaml/preprocess/parser_raw.mly" ( Optional label ) -# 6062 "src/ocaml/preprocess/parser_raw.ml" +# 5427 "src/ocaml/preprocess/parser_raw.ml" in -# 2166 "src/ocaml/preprocess/parser_raw.mly" +# 2253 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6067 "src/ocaml/preprocess/parser_raw.ml" +# 5432 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -6071,15 +5436,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1109 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6077 "src/ocaml/preprocess/parser_raw.ml" +# 5442 "src/ocaml/preprocess/parser_raw.ml" in -# 2167 "src/ocaml/preprocess/parser_raw.mly" +# 2254 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6083 "src/ocaml/preprocess/parser_raw.ml" +# 5448 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6126,9 +5491,9 @@ module Tables = struct let domain : (Parsetree.core_type) = Obj.magic domain in let _2 : unit = Obj.magic _2 in let label : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 6132 "src/ocaml/preprocess/parser_raw.ml" +# 5497 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -6136,14 +5501,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3545 "src/ocaml/preprocess/parser_raw.mly" +# 3696 "src/ocaml/preprocess/parser_raw.mly" ( Labelled label ) -# 6142 "src/ocaml/preprocess/parser_raw.ml" +# 5507 "src/ocaml/preprocess/parser_raw.ml" in -# 2166 "src/ocaml/preprocess/parser_raw.mly" +# 2253 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6147 "src/ocaml/preprocess/parser_raw.ml" +# 5512 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -6151,15 +5516,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1109 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6157 "src/ocaml/preprocess/parser_raw.ml" +# 5522 "src/ocaml/preprocess/parser_raw.ml" in -# 2167 "src/ocaml/preprocess/parser_raw.mly" +# 2254 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6163 "src/ocaml/preprocess/parser_raw.ml" +# 5528 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6198,14 +5563,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3547 "src/ocaml/preprocess/parser_raw.mly" +# 3698 "src/ocaml/preprocess/parser_raw.mly" ( Nolabel ) -# 6204 "src/ocaml/preprocess/parser_raw.ml" +# 5569 "src/ocaml/preprocess/parser_raw.ml" in -# 2166 "src/ocaml/preprocess/parser_raw.mly" +# 2253 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 6209 "src/ocaml/preprocess/parser_raw.ml" +# 5574 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_domain_) in @@ -6213,15 +5578,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1043 "src/ocaml/preprocess/parser_raw.mly" +# 1109 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 6219 "src/ocaml/preprocess/parser_raw.ml" +# 5584 "src/ocaml/preprocess/parser_raw.ml" in -# 2167 "src/ocaml/preprocess/parser_raw.mly" +# 2254 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6225 "src/ocaml/preprocess/parser_raw.ml" +# 5590 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6304,9 +5669,9 @@ module Tables = struct let csig : (Parsetree.class_type) = Obj.magic csig in let _8 : unit = Obj.magic _8 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 6310 "src/ocaml/preprocess/parser_raw.ml" +# 5675 "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 @@ -6322,9 +5687,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6328 "src/ocaml/preprocess/parser_raw.ml" +# 5693 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -6334,24 +5699,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 6340 "src/ocaml/preprocess/parser_raw.ml" +# 5705 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6348 "src/ocaml/preprocess/parser_raw.ml" +# 5713 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2307 "src/ocaml/preprocess/parser_raw.mly" +# 2394 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -6359,19 +5724,19 @@ module Tables = struct ext, Ci.mk id csig ~virt ~params ~attrs ~loc ~docs ) -# 6363 "src/ocaml/preprocess/parser_raw.ml" +# 5728 "src/ocaml/preprocess/parser_raw.ml" in -# 1227 "src/ocaml/preprocess/parser_raw.mly" +# 1314 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 6369 "src/ocaml/preprocess/parser_raw.ml" +# 5734 "src/ocaml/preprocess/parser_raw.ml" in -# 2295 "src/ocaml/preprocess/parser_raw.mly" +# 2382 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6375 "src/ocaml/preprocess/parser_raw.ml" +# 5740 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6394,9 +5759,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3836 "src/ocaml/preprocess/parser_raw.mly" +# 4043 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6400 "src/ocaml/preprocess/parser_raw.ml" +# 5765 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6415,17 +5780,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 785 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 6421 "src/ocaml/preprocess/parser_raw.ml" +# 5786 "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) = -# 3715 "src/ocaml/preprocess/parser_raw.mly" +# 3922 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _1 in Pconst_integer (n, m) ) -# 6429 "src/ocaml/preprocess/parser_raw.ml" +# 5794 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6444,17 +5809,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 744 "src/ocaml/preprocess/parser_raw.mly" +# 810 "src/ocaml/preprocess/parser_raw.mly" (char) -# 6450 "src/ocaml/preprocess/parser_raw.ml" +# 5815 "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) = -# 3716 "src/ocaml/preprocess/parser_raw.mly" +# 3923 "src/ocaml/preprocess/parser_raw.mly" ( Pconst_char _1 ) -# 6458 "src/ocaml/preprocess/parser_raw.ml" +# 5823 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6473,17 +5838,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 837 "src/ocaml/preprocess/parser_raw.mly" +# 903 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 6479 "src/ocaml/preprocess/parser_raw.ml" +# 5844 "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) = -# 3717 "src/ocaml/preprocess/parser_raw.mly" +# 3924 "src/ocaml/preprocess/parser_raw.mly" ( let (s, strloc, d) = _1 in Pconst_string (s, strloc, d) ) -# 6487 "src/ocaml/preprocess/parser_raw.ml" +# 5852 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6502,17 +5867,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 764 "src/ocaml/preprocess/parser_raw.mly" +# 830 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 6508 "src/ocaml/preprocess/parser_raw.ml" +# 5873 "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) = -# 3718 "src/ocaml/preprocess/parser_raw.mly" +# 3925 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _1 in Pconst_float (f, m) ) -# 6516 "src/ocaml/preprocess/parser_raw.ml" +# 5881 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6542,9 +5907,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3791 "src/ocaml/preprocess/parser_raw.mly" +# 3998 "src/ocaml/preprocess/parser_raw.mly" ( "[]" ) -# 6548 "src/ocaml/preprocess/parser_raw.ml" +# 5913 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6574,9 +5939,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3792 "src/ocaml/preprocess/parser_raw.mly" +# 3999 "src/ocaml/preprocess/parser_raw.mly" ( "()" ) -# 6580 "src/ocaml/preprocess/parser_raw.ml" +# 5945 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6599,9 +5964,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3793 "src/ocaml/preprocess/parser_raw.mly" +# 4000 "src/ocaml/preprocess/parser_raw.mly" ( "false" ) -# 6605 "src/ocaml/preprocess/parser_raw.ml" +# 5970 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6624,9 +5989,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3794 "src/ocaml/preprocess/parser_raw.mly" +# 4001 "src/ocaml/preprocess/parser_raw.mly" ( "true" ) -# 6630 "src/ocaml/preprocess/parser_raw.ml" +# 5995 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6645,17 +6010,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) -# 6651 "src/ocaml/preprocess/parser_raw.ml" +# 6016 "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) = -# 3797 "src/ocaml/preprocess/parser_raw.mly" +# 4004 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6659 "src/ocaml/preprocess/parser_raw.ml" +# 6024 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6692,14 +6057,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = let _1 = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3995 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6698 "src/ocaml/preprocess/parser_raw.ml" +# 6063 "src/ocaml/preprocess/parser_raw.ml" in -# 3798 "src/ocaml/preprocess/parser_raw.mly" +# 4005 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6703 "src/ocaml/preprocess/parser_raw.ml" +# 6068 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6722,9 +6087,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3799 "src/ocaml/preprocess/parser_raw.mly" +# 4006 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6728 "src/ocaml/preprocess/parser_raw.ml" +# 6093 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6747,9 +6112,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3802 "src/ocaml/preprocess/parser_raw.mly" +# 4009 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6753 "src/ocaml/preprocess/parser_raw.ml" +# 6118 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6802,15 +6167,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let (_2, _1) = (_2_inlined1, _1_inlined1) in -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3995 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6808 "src/ocaml/preprocess/parser_raw.ml" +# 6173 "src/ocaml/preprocess/parser_raw.ml" in -# 3803 "src/ocaml/preprocess/parser_raw.mly" +# 4010 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 6814 "src/ocaml/preprocess/parser_raw.ml" +# 6179 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6847,14 +6212,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = let _1 = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3995 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6853 "src/ocaml/preprocess/parser_raw.ml" +# 6218 "src/ocaml/preprocess/parser_raw.ml" in -# 3804 "src/ocaml/preprocess/parser_raw.mly" +# 4011 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 6858 "src/ocaml/preprocess/parser_raw.ml" +# 6223 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6877,9 +6242,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3805 "src/ocaml/preprocess/parser_raw.mly" +# 4012 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 6883 "src/ocaml/preprocess/parser_raw.ml" +# 6248 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6916,9 +6281,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type * Parsetree.core_type) = -# 2251 "src/ocaml/preprocess/parser_raw.mly" +# 2338 "src/ocaml/preprocess/parser_raw.mly" ( _1, _3 ) -# 6922 "src/ocaml/preprocess/parser_raw.ml" +# 6287 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6943,26 +6308,26 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = let tys = let xs = let xs = -# 1114 "src/ocaml/preprocess/parser_raw.mly" +# 1201 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 6949 "src/ocaml/preprocess/parser_raw.ml" +# 6314 "src/ocaml/preprocess/parser_raw.ml" in # 253 "" ( List.rev xs ) -# 6954 "src/ocaml/preprocess/parser_raw.ml" +# 6319 "src/ocaml/preprocess/parser_raw.ml" in -# 1134 "src/ocaml/preprocess/parser_raw.mly" +# 1221 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 6960 "src/ocaml/preprocess/parser_raw.ml" +# 6325 "src/ocaml/preprocess/parser_raw.ml" in -# 3346 "src/ocaml/preprocess/parser_raw.mly" +# 3497 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_tuple tys ) -# 6966 "src/ocaml/preprocess/parser_raw.ml" +# 6331 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7001,26 +6366,26 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = let tys = let xs = let xs = -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1205 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 7007 "src/ocaml/preprocess/parser_raw.ml" +# 6372 "src/ocaml/preprocess/parser_raw.ml" in # 253 "" ( List.rev xs ) -# 7012 "src/ocaml/preprocess/parser_raw.ml" +# 6377 "src/ocaml/preprocess/parser_raw.ml" in -# 1134 "src/ocaml/preprocess/parser_raw.mly" +# 1221 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7018 "src/ocaml/preprocess/parser_raw.ml" +# 6383 "src/ocaml/preprocess/parser_raw.ml" in -# 3346 "src/ocaml/preprocess/parser_raw.mly" +# 3497 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_tuple tys ) -# 7024 "src/ocaml/preprocess/parser_raw.ml" +# 6389 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7057,9 +6422,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.constructor_arguments) = -# 3348 "src/ocaml/preprocess/parser_raw.mly" +# 3499 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_record _2 ) -# 7063 "src/ocaml/preprocess/parser_raw.ml" +# 6428 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7082,9 +6447,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constructor_declaration list) = -# 3262 "src/ocaml/preprocess/parser_raw.mly" +# 3413 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 7088 "src/ocaml/preprocess/parser_raw.ml" +# 6453 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7107,14 +6472,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.constructor_declaration list) = let cs = -# 1219 "src/ocaml/preprocess/parser_raw.mly" +# 1306 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 7113 "src/ocaml/preprocess/parser_raw.ml" +# 6478 "src/ocaml/preprocess/parser_raw.ml" in -# 3264 "src/ocaml/preprocess/parser_raw.mly" +# 3415 "src/ocaml/preprocess/parser_raw.mly" ( cs ) -# 7118 "src/ocaml/preprocess/parser_raw.ml" +# 6483 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7137,14 +6502,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = -# 3505 "src/ocaml/preprocess/parser_raw.mly" +# 3656 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7143 "src/ocaml/preprocess/parser_raw.ml" +# 6508 "src/ocaml/preprocess/parser_raw.ml" in -# 3495 "src/ocaml/preprocess/parser_raw.mly" +# 3646 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7148 "src/ocaml/preprocess/parser_raw.ml" +# 6513 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7174,9 +6539,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = -# 3497 "src/ocaml/preprocess/parser_raw.mly" +# 3648 "src/ocaml/preprocess/parser_raw.mly" ( Typ.attr _1 _2 ) -# 7180 "src/ocaml/preprocess/parser_raw.ml" +# 6545 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7194,14 +6559,14 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let _1 : unit = Obj.magic _1 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 : (Asttypes.direction_flag) = -# 3902 "src/ocaml/preprocess/parser_raw.mly" - ( Upto ) -# 7205 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.core_type) = +# 3796 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 6570 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7219,14 +6584,39 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let _1 : unit = Obj.magic _1 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 : (Asttypes.direction_flag) = -# 3903 "src/ocaml/preprocess/parser_raw.mly" - ( Downto ) -# 7230 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.core_type) = +# 3796 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 6595 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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) = +# 3796 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 6620 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7244,9 +6634,9 @@ module Tables = struct 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.semv = type_; + MenhirLib.EngineTypes.startp = _startpos_type__; + MenhirLib.EngineTypes.endp = _endpos_type__; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _menhir_s; MenhirLib.EngineTypes.semv = _1; @@ -7256,19 +6646,16 @@ module Tables = struct }; }; } = _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 _3 : unit = Obj.magic _3 in + let type_ : (Parsetree.core_type) = Obj.magic type_ in + 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 - let _loc = (_startpos, _endpos) in - -# 4112 "src/ocaml/preprocess/parser_raw.mly" - ( expr_of_lwt_bindings ~loc:_loc _1 (merloc _endpos__2_ _3) ) -# 7272 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.core_type) = +# 3749 "src/ocaml/preprocess/parser_raw.mly" + ( type_ ) +# 6659 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7281,29 +6668,29 @@ module Tables = struct 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.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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _3; - MenhirLib.EngineTypes.startp = _startpos__3_; - MenhirLib.EngineTypes.endp = _endpos__3_; + 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_inlined2; - MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; + 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_inlined1; - MenhirLib.EngineTypes.startp = _startpos__1_inlined1_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined1_; + MenhirLib.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; @@ -7316,60 +6703,51 @@ module Tables = struct }; }; } = _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 _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_xs_ in - let _v : (Parsetree.expression) = let _5 = - let xs = - let xs = -# 253 "" - ( List.rev xs ) -# 7334 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1191 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 7339 "src/ocaml/preprocess/parser_raw.ml" - - in + let _endpos = _endpos__5_ in + let _v : (Parsetree.core_type) = let package_type = + 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 -# 2802 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 7345 "src/ocaml/preprocess/parser_raw.ml" +# 3842 "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 ) +# 6726 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos__5_ = _endpos_xs_ in - let _2 = + let attrs = let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7356 "src/ocaml/preprocess/parser_raw.ml" +# 6736 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7362 "src/ocaml/preprocess/parser_raw.ml" +# 6742 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in -# 4114 "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 ) -# 7373 "src/ocaml/preprocess/parser_raw.ml" +# 3751 "src/ocaml/preprocess/parser_raw.mly" + ( wrap_typ_attrs ~loc:_sloc (reloc_typ ~loc:_sloc package_type) attrs ) +# 6751 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7387,14 +6765,69 @@ module Tables = struct 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.semv = field; + MenhirLib.EngineTypes.startp = _startpos_field_; + MenhirLib.EngineTypes.endp = _endpos_field_; + MenhirLib.EngineTypes.next = { + MenhirLib.EngineTypes.state = _menhir_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 field : (Parsetree.row_field) = Obj.magic field in + 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 = +# 3754 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_variant([ field ], Closed, None) ) +# 6791 "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 + +# 1099 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 6800 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3771 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 6806 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _1_inlined1; - MenhirLib.EngineTypes.startp = _startpos__1_inlined1_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined1_; + MenhirLib.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; @@ -7405,36 +6838,54 @@ module Tables = struct }; }; } = _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 _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__3_ in - let _v : (Parsetree.expression) = let _2 = - let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in - let _2 = - let _1 = _1_inlined1 in - -# 4055 "src/ocaml/preprocess/parser_raw.mly" + let _endpos = _endpos__4_ in + let _v : (Parsetree.core_type) = let _1 = + let _1 = + let fields = + let _1 = + let xs = +# 253 "" + ( List.rev xs ) +# 6856 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1217 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 6861 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3848 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7423 "src/ocaml/preprocess/parser_raw.ml" +# 6867 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3756 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_variant(fields, Closed, None) ) +# 6873 "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 -# 4068 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7429 "src/ocaml/preprocess/parser_raw.ml" +# 1099 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 6883 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__3_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) in -# 4118 "src/ocaml/preprocess/parser_raw.mly" - ( reloc_exp ~loc:_loc (Fake.app Fake.Lwt.in_lwt _3) ) -# 7438 "src/ocaml/preprocess/parser_raw.ml" +# 3771 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 6889 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7447,14 +6898,14 @@ module Tables = struct 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.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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _3; @@ -7462,79 +6913,1603 @@ module Tables = struct 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.semv = field; + MenhirLib.EngineTypes.startp = _startpos_field_; + MenhirLib.EngineTypes.endp = _endpos_field_; 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; - }; + MenhirLib.EngineTypes.state = _menhir_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 _5 : unit = Obj.magic _5 in + let xs : (Parsetree.row_field list) = Obj.magic xs in + let _3 : unit = Obj.magic _3 in + let field : (Parsetree.row_field) = Obj.magic field in 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 = + let _endpos = _endpos__5_ in + let _v : (Parsetree.core_type) = let _1 = + let _1 = + let fields = + let _1 = + let xs = # 253 "" ( List.rev xs ) -# 7500 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1191 "src/ocaml/preprocess/parser_raw.mly" +# 6946 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7505 "src/ocaml/preprocess/parser_raw.ml" +# 6951 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3848 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 6957 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3758 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_variant(field :: fields, Closed, None) ) +# 6963 "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 -# 2802 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 7511 "src/ocaml/preprocess/parser_raw.ml" +# 1099 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 6973 "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 - -# 4055 "src/ocaml/preprocess/parser_raw.mly" + +# 3771 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 6979 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 fields = + let _1 = + let xs = +# 253 "" + ( List.rev xs ) +# 7029 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1217 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7034 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3848 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7522 "src/ocaml/preprocess/parser_raw.ml" +# 7040 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3760 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_variant(fields, Open, None) ) +# 7046 "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 -# 4068 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7528 "src/ocaml/preprocess/parser_raw.ml" +# 1099 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 7056 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__5_ in + +# 3771 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7062 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 _loc = (_startpos, _endpos) in + let _endpos = _endpos__2_ in + let _v : (Parsetree.core_type) = let _1 = + let _1 = +# 3762 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_variant([], Open, None) ) +# 7095 "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 + +# 1099 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 7104 "src/ocaml/preprocess/parser_raw.ml" + + in -# 4120 "src/ocaml/preprocess/parser_raw.mly" - ( mkexp_attrs ~loc:_loc - (Pexp_try(Fake.app Fake.Lwt.in_lwt _3, List.rev _5)) _2 ) -# 7538 "src/ocaml/preprocess/parser_raw.ml" +# 3771 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7110 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 fields = + let _1 = + let xs = +# 253 "" + ( List.rev xs ) +# 7160 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1217 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7165 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3848 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7171 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3764 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_variant(fields, Closed, Some []) ) +# 7177 "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 + +# 1099 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 7187 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3771 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7193 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 tags = + let xs = xs_inlined1 in + let _1 = + let xs = +# 253 "" + ( List.rev xs ) +# 7258 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1164 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7263 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3876 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7269 "src/ocaml/preprocess/parser_raw.ml" + + in + let fields = + let _1 = + let xs = +# 253 "" + ( List.rev xs ) +# 7277 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1217 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7282 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3848 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7288 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3769 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_variant(fields, Closed, Some tags) ) +# 7294 "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 + +# 1099 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 7304 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3771 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7310 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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) = +# 4109 "src/ocaml/preprocess/parser_raw.mly" + ( Upto ) +# 7335 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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) = +# 4110 "src/ocaml/preprocess/parser_raw.mly" + ( Downto ) +# 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 = _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 + +# 4325 "src/ocaml/preprocess/parser_raw.mly" + ( expr_of_lwt_bindings ~loc:_loc _1 (merloc _endpos__2_ _3) ) +# 7402 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 "" + ( List.rev xs ) +# 7464 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1278 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7469 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2928 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7475 "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 + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7486 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4275 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 7492 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__5_ in + let _startpos = _startpos__1_ in + let _loc = (_startpos, _endpos) in + +# 4327 "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 ) +# 7503 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7553 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4275 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 7559 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _startpos = _startpos__1_ in + let _loc = (_startpos, _endpos) in + +# 4331 "src/ocaml/preprocess/parser_raw.mly" + ( reloc_exp ~loc:_loc (Fake.app Fake.Lwt.in_lwt _3) ) +# 7568 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 "" + ( List.rev xs ) +# 7630 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1278 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7635 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2928 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7641 "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 + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7652 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4275 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 7658 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__5_ in + let _startpos = _startpos__1_ in + let _loc = (_startpos, _endpos) in + +# 4333 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp_attrs ~loc:_loc + (Pexp_try(Fake.app Fake.Lwt.in_lwt _3, List.rev _5)) _2 ) +# 7668 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7732 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4275 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 7738 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4336 "src/ocaml/preprocess/parser_raw.mly" + ( Fake.app (Fake.app Fake.Lwt.finally_ _3) _5 ) +# 7744 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 "" + ( List.rev xs ) +# 7820 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1278 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7825 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2928 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7831 "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 + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7841 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4275 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 7847 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__7_ in + let _startpos = _startpos__1_ in + let _loc = (_startpos, _endpos) in + +# 4338 "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 ) +# 7858 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7929 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4275 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 7935 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__6_ in + let _startpos = _startpos__1_ in + let _loc = (_startpos, _endpos) in + +# 4342 "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)) ) +# 7945 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8044 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4275 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8050 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__10_ in + let _startpos = _startpos__1_ in + let _loc = (_startpos, _endpos) in + +# 4345 "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)) ) +# 8060 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8145 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4275 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8151 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__8_ in + let _startpos = _startpos__1_ in + let _loc = (_startpos, _endpos) in + +# 4348 "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 + ) +# 8164 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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) = let _1 = +# 2424 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8189 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2570 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8194 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 "" + ( List.rev xs ) +# 8243 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1278 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8248 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2928 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8254 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8265 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4275 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8271 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2426 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 8291 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2570 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8297 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.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) = +# 4265 "src/ocaml/preprocess/parser_raw.mly" + ( None ) +# 8315 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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) = +# 4266 "src/ocaml/preprocess/parser_raw.mly" + ( Some _2 ) +# 8347 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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) = +# 4278 "src/ocaml/preprocess/parser_raw.mly" + ( (_2, _3) ) +# 8393 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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 : ( +# 905 "src/ocaml/preprocess/parser_raw.mly" + (string * Location.t * string * Location.t * string option) +# 8414 "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 + +# 4280 "src/ocaml/preprocess/parser_raw.mly" + ( mk_quotedext ~loc:_sloc _1 ) +# 8425 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8480 "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 + +# 1062 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 8492 "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 + +# 1062 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 8503 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos_attrs_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 3566 "src/ocaml/preprocess/parser_raw.mly" + ( let info = symbol_info _endpos in + Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) +# 8513 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7547,70 +8522,80 @@ module Tables = struct 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.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.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 = _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; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 _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__5_ in - let _v : (Parsetree.expression) = let _2 = - let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in - let _2 = - let _1 = _1_inlined1 in - -# 4055 "src/ocaml/preprocess/parser_raw.mly" + let _endpos = _endpos__1_inlined2_ in + let _v : (Parsetree.extension_constructor) = let attrs = + let _1 = _1_inlined2 in + +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7602 "src/ocaml/preprocess/parser_raw.ml" - - in +# 8561 "src/ocaml/preprocess/parser_raw.ml" -# 4068 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7608 "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 + +# 1062 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 8573 "src/ocaml/preprocess/parser_raw.ml" + + in + let cid = + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1062 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 8583 "src/ocaml/preprocess/parser_raw.ml" in + let _startpos_cid_ = _startpos__1_ in + let _1 = +# 4083 "src/ocaml/preprocess/parser_raw.mly" + ( () ) +# 8590 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos_attrs_ in + let _symbolstartpos = _startpos_cid_ in + let _sloc = (_symbolstartpos, _endpos) in -# 4123 "src/ocaml/preprocess/parser_raw.mly" - ( Fake.app (Fake.app Fake.Lwt.finally_ _3) _5 ) -# 7614 "src/ocaml/preprocess/parser_raw.ml" +# 3566 "src/ocaml/preprocess/parser_raw.mly" + ( let info = symbol_info _endpos in + Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) +# 8599 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7622,109 +8607,36 @@ module Tables = struct (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; - }; - }; - }; - }; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = ext; + MenhirLib.EngineTypes.startp = _startpos_ext_; + MenhirLib.EngineTypes.endp = _endpos_ext_; + 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 ext : (Parsetree.extension) = Obj.magic ext 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 "" - ( List.rev xs ) -# 7690 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1191 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 7695 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2802 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 7701 "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 - -# 4055 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 7711 "src/ocaml/preprocess/parser_raw.ml" - - in + let _startpos = _startpos_ext_ in + let _endpos = _endpos_ext_ in + let _v : (Parsetree.core_type) = let _1 = + let _1 = +# 3787 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_extension ext ) +# 8625 "src/ocaml/preprocess/parser_raw.ml" + in + let (_endpos__1_, _startpos__1_) = (_endpos_ext_, _startpos_ext_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in -# 4068 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7717 "src/ocaml/preprocess/parser_raw.ml" +# 1099 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 8634 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__7_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) in -# 4125 "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 ) -# 7728 "src/ocaml/preprocess/parser_raw.ml" +# 3789 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8640 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7737,81 +8649,67 @@ module Tables = struct 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.semv = _4; + MenhirLib.EngineTypes.startp = _startpos__4_; + MenhirLib.EngineTypes.endp = _endpos__4_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _5; - MenhirLib.EngineTypes.startp = _startpos__5_; - MenhirLib.EngineTypes.endp = _endpos__5_; + MenhirLib.EngineTypes.semv = _3; + MenhirLib.EngineTypes.startp = _startpos__3_; + MenhirLib.EngineTypes.endp = _endpos__3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _4; - MenhirLib.EngineTypes.startp = _startpos__4_; - MenhirLib.EngineTypes.endp = _endpos__4_; + 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 = _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; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 _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__6_ in - let _v : (Parsetree.expression) = let _2 = - let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in - let _2 = - let _1 = _1_inlined1 in - -# 4055 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 7799 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4068 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7805 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos = _endpos__6_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) 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 -# 4129 "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)) ) -# 7815 "src/ocaml/preprocess/parser_raw.ml" +# 4253 "src/ocaml/preprocess/parser_raw.mly" + ( mark_symbol_docs _sloc; + mk_attr ~loc:(make_loc _sloc) _2 _3 ) +# 8690 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.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 = +# 2278 "src/ocaml/preprocess/parser_raw.mly" + ( [] ) +# 8708 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2095 "src/ocaml/preprocess/parser_raw.mly" + ( params ) +# 8713 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7824,109 +8722,52 @@ module Tables = struct 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.semv = _3; + MenhirLib.EngineTypes.startp = _startpos__3_; + MenhirLib.EngineTypes.endp = _endpos__3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _9; - MenhirLib.EngineTypes.startp = _startpos__9_; - MenhirLib.EngineTypes.endp = _endpos__9_; + MenhirLib.EngineTypes.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; 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; - }; - }; - }; - }; - }; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 _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__10_ in - let _v : (Parsetree.expression) = let _2 = - let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in - let _2 = - let _1 = _1_inlined1 in + let _endpos = _endpos__3_ in + let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let params = + let params = + let xs = +# 253 "" + ( List.rev xs ) +# 8754 "src/ocaml/preprocess/parser_raw.ml" + in -# 4055 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 7914 "src/ocaml/preprocess/parser_raw.ml" +# 1217 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8759 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7920 "src/ocaml/preprocess/parser_raw.ml" +# 2280 "src/ocaml/preprocess/parser_raw.mly" + ( params ) +# 8765 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__10_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) in -# 4132 "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)) ) -# 7930 "src/ocaml/preprocess/parser_raw.ml" +# 2095 "src/ocaml/preprocess/parser_raw.mly" + ( params ) +# 8771 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7939,98 +8780,112 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _7; - MenhirLib.EngineTypes.startp = _startpos__7_; - MenhirLib.EngineTypes.endp = _endpos__7_; + 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 = _6; - MenhirLib.EngineTypes.startp = _startpos__6_; - MenhirLib.EngineTypes.endp = _endpos__6_; + 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 = _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; - }; - }; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 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__8_ in - let _v : (Parsetree.expression) = let _2 = + let _endpos = _endpos_xs_ in + let _v : (Parsetree.function_body) = let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 8819 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1278 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8824 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2928 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8830 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8015 "src/ocaml/preprocess/parser_raw.ml" +# 8841 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8021 "src/ocaml/preprocess/parser_raw.ml" +# 8847 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__8_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in -# 4135 "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 - ) -# 8034 "src/ocaml/preprocess/parser_raw.ml" +# 2914 "src/ocaml/preprocess/parser_raw.mly" + ( let ext, attrs = _2 in + match ext with + | None -> Pfunction_cases (_3, make_loc _sloc, attrs) + | Some _ -> + (* function%foo extension nodes interrupt the arity *) + let cases = Pfunction_cases (_3, make_loc _sloc, []) in + Pfunction_body + (mkexp_attrs ~loc:_sloc (mkfunction [] None cases) _2) + ) +# 8864 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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.function_body) = +# 2924 "src/ocaml/preprocess/parser_raw.mly" + ( Pfunction_body _1 ) +# 8889 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8053,9 +8908,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2418 "src/ocaml/preprocess/parser_raw.mly" +# 2536 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8059 "src/ocaml/preprocess/parser_raw.ml" +# 8914 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8133,9 +8988,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 8139 "src/ocaml/preprocess/parser_raw.ml" +# 8994 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -8143,21 +8998,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8149 "src/ocaml/preprocess/parser_raw.ml" +# 9004 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8155 "src/ocaml/preprocess/parser_raw.ml" +# 9010 "src/ocaml/preprocess/parser_raw.ml" in -# 2453 "src/ocaml/preprocess/parser_raw.mly" +# 2574 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_letmodule(_4, _5, (merloc _endpos__6_ _7)), _3 ) -# 8161 "src/ocaml/preprocess/parser_raw.ml" +# 9016 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8165,10 +9020,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8172 "src/ocaml/preprocess/parser_raw.ml" +# 9027 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8253,9 +9108,9 @@ module Tables = struct let _3 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8259 "src/ocaml/preprocess/parser_raw.ml" +# 9114 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -8264,19 +9119,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 8270 "src/ocaml/preprocess/parser_raw.ml" +# 9125 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3326 "src/ocaml/preprocess/parser_raw.mly" +# 3477 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = _2 in Te.decl _1 ~vars ~args ?res ~attrs:_3 ~loc:(make_loc _sloc) ) -# 8280 "src/ocaml/preprocess/parser_raw.ml" +# 9135 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -8284,21 +9139,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8290 "src/ocaml/preprocess/parser_raw.ml" +# 9145 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8296 "src/ocaml/preprocess/parser_raw.ml" +# 9151 "src/ocaml/preprocess/parser_raw.ml" in -# 2455 "src/ocaml/preprocess/parser_raw.mly" +# 2576 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_letexception(_4, _6), _3 ) -# 8302 "src/ocaml/preprocess/parser_raw.ml" +# 9157 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -8306,10 +9161,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8313 "src/ocaml/preprocess/parser_raw.ml" +# 9168 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8379,28 +9234,28 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8385 "src/ocaml/preprocess/parser_raw.ml" +# 9240 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8391 "src/ocaml/preprocess/parser_raw.ml" +# 9246 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 8397 "src/ocaml/preprocess/parser_raw.ml" +# 9252 "src/ocaml/preprocess/parser_raw.ml" in -# 2457 "src/ocaml/preprocess/parser_raw.mly" +# 2578 "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 ) -# 8404 "src/ocaml/preprocess/parser_raw.ml" +# 9259 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8408,10 +9263,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8415 "src/ocaml/preprocess/parser_raw.ml" +# 9270 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8488,31 +9343,31 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8494 "src/ocaml/preprocess/parser_raw.ml" +# 9349 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8500 "src/ocaml/preprocess/parser_raw.ml" +# 9355 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 8508 "src/ocaml/preprocess/parser_raw.ml" +# 9363 "src/ocaml/preprocess/parser_raw.ml" in -# 2457 "src/ocaml/preprocess/parser_raw.mly" +# 2578 "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 ) -# 8516 "src/ocaml/preprocess/parser_raw.ml" +# 9371 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -8520,10 +9375,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8527 "src/ocaml/preprocess/parser_raw.ml" +# 9382 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8536,221 +9391,40 @@ module Tables = struct 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 "" - ( List.rev xs ) -# 8576 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1191 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 8581 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2802 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 8587 "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 - -# 4055 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 8597 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4068 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 8603 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2461 "src/ocaml/preprocess/parser_raw.mly" - ( Pexp_function _3, _2 ) -# 8609 "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 - -# 2420 "src/ocaml/preprocess/parser_raw.mly" - ( let desc, attrs = _1 in - mkexp_attrs ~loc:_sloc desc attrs ) -# 8620 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 4055 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 8678 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4068 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 8684 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2463 "src/ocaml/preprocess/parser_raw.mly" - ( let (l,o,p) = _3 in - Pexp_fun(l, o, p, _4), _2 ) -# 8691 "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 - -# 2420 "src/ocaml/preprocess/parser_raw.mly" - ( let desc, attrs = _1 in - mkexp_attrs ~loc:_sloc desc attrs ) -# 8702 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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.semv = _6; + MenhirLib.EngineTypes.startp = _startpos__6_; + MenhirLib.EngineTypes.endp = _endpos__6_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _6; - MenhirLib.EngineTypes.startp = _startpos__6_; - MenhirLib.EngineTypes.endp = _endpos__6_; + 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.semv = _4; + MenhirLib.EngineTypes.startp = _startpos__4_; + MenhirLib.EngineTypes.endp = _endpos__4_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _4; - MenhirLib.EngineTypes.startp = _startpos__4_; - MenhirLib.EngineTypes.endp = _endpos__4_; + MenhirLib.EngineTypes.semv = _3; + MenhirLib.EngineTypes.startp = _startpos__3_; + MenhirLib.EngineTypes.endp = _endpos__3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _3; - MenhirLib.EngineTypes.startp = _startpos__3_; - MenhirLib.EngineTypes.endp = _endpos__3_; + 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_inlined2; - MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; + 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_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; - }; + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; + MenhirLib.EngineTypes.next = _menhir_stack; }; }; }; @@ -8758,57 +9432,50 @@ module Tables = struct }; }; } = _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 _6 : (Parsetree.function_body) = Obj.magic _6 in + let _5 : unit = Obj.magic _5 in + let _4 : (Parsetree.core_type option) = Obj.magic _4 in + let _3 : (Parsetree.function_param list) = 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 _endpos = _endpos__6_ in let _v : (Parsetree.expression) = let _1 = - let _5 = -# 2689 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 8777 "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 -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8786 "src/ocaml/preprocess/parser_raw.ml" +# 9454 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8792 "src/ocaml/preprocess/parser_raw.ml" +# 9460 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__7_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in -# 2466 "src/ocaml/preprocess/parser_raw.mly" - ( (mk_newtypes ~loc:_sloc _5 _7).pexp_desc, _2 ) -# 8801 "src/ocaml/preprocess/parser_raw.ml" +# 2584 "src/ocaml/preprocess/parser_raw.mly" + ( let body_constraint = Option.map (fun x -> Pconstraint x) _4 in + mkfunction _3 body_constraint _6, _2 + ) +# 9468 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos__1_ = _endpos__7_ in + let _endpos__1_ = _endpos__6_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8812 "src/ocaml/preprocess/parser_raw.ml" +# 9479 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8871,18 +9538,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8875 "src/ocaml/preprocess/parser_raw.ml" +# 9542 "src/ocaml/preprocess/parser_raw.ml" in -# 1191 "src/ocaml/preprocess/parser_raw.mly" +# 1278 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8880 "src/ocaml/preprocess/parser_raw.ml" +# 9547 "src/ocaml/preprocess/parser_raw.ml" in -# 2802 "src/ocaml/preprocess/parser_raw.mly" +# 2928 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8886 "src/ocaml/preprocess/parser_raw.ml" +# 9553 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -8890,21 +9557,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8896 "src/ocaml/preprocess/parser_raw.ml" +# 9563 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8902 "src/ocaml/preprocess/parser_raw.ml" +# 9569 "src/ocaml/preprocess/parser_raw.ml" in -# 2468 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_match(_3, _5), _2 ) -# 8908 "src/ocaml/preprocess/parser_raw.ml" +# 9575 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -8912,10 +9579,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 8919 "src/ocaml/preprocess/parser_raw.ml" +# 9586 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8978,18 +9645,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 8982 "src/ocaml/preprocess/parser_raw.ml" +# 9649 "src/ocaml/preprocess/parser_raw.ml" in -# 1191 "src/ocaml/preprocess/parser_raw.mly" +# 1278 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8987 "src/ocaml/preprocess/parser_raw.ml" +# 9654 "src/ocaml/preprocess/parser_raw.ml" in -# 2802 "src/ocaml/preprocess/parser_raw.mly" +# 2928 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 8993 "src/ocaml/preprocess/parser_raw.ml" +# 9660 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -8997,21 +9664,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9003 "src/ocaml/preprocess/parser_raw.ml" +# 9670 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9009 "src/ocaml/preprocess/parser_raw.ml" +# 9676 "src/ocaml/preprocess/parser_raw.ml" in -# 2470 "src/ocaml/preprocess/parser_raw.mly" +# 2590 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_try(_3, _5), _2 ) -# 9015 "src/ocaml/preprocess/parser_raw.ml" +# 9682 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -9019,10 +9686,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9026 "src/ocaml/preprocess/parser_raw.ml" +# 9693 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9099,21 +9766,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9105 "src/ocaml/preprocess/parser_raw.ml" +# 9772 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9111 "src/ocaml/preprocess/parser_raw.ml" +# 9778 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2596 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), Some (merloc _endpos__6_ _7)), _2 ) -# 9117 "src/ocaml/preprocess/parser_raw.ml" +# 9784 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -9121,10 +9788,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9128 "src/ocaml/preprocess/parser_raw.ml" +# 9795 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9187,21 +9854,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9193 "src/ocaml/preprocess/parser_raw.ml" +# 9860 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9199 "src/ocaml/preprocess/parser_raw.ml" +# 9866 "src/ocaml/preprocess/parser_raw.ml" in -# 2478 "src/ocaml/preprocess/parser_raw.mly" +# 2598 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), None), _2 ) -# 9205 "src/ocaml/preprocess/parser_raw.ml" +# 9872 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -9209,10 +9876,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9216 "src/ocaml/preprocess/parser_raw.ml" +# 9883 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9282,21 +9949,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9288 "src/ocaml/preprocess/parser_raw.ml" +# 9955 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9294 "src/ocaml/preprocess/parser_raw.ml" +# 9961 "src/ocaml/preprocess/parser_raw.ml" in -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2600 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_while(_3, (merloc _endpos__4_ _5)), _2 ) -# 9300 "src/ocaml/preprocess/parser_raw.ml" +# 9967 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -9304,10 +9971,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9311 "src/ocaml/preprocess/parser_raw.ml" +# 9978 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9405,21 +10072,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9411 "src/ocaml/preprocess/parser_raw.ml" +# 10078 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9417 "src/ocaml/preprocess/parser_raw.ml" +# 10084 "src/ocaml/preprocess/parser_raw.ml" in -# 2487 "src/ocaml/preprocess/parser_raw.mly" +# 2607 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_for(_3, (merloc _endpos__4_ _5), (merloc _endpos__6_ _7), _6, (merloc _endpos__8_ _9)), _2 ) -# 9423 "src/ocaml/preprocess/parser_raw.ml" +# 10090 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__10_ in @@ -9427,10 +10094,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9434 "src/ocaml/preprocess/parser_raw.ml" +# 10101 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9479,21 +10146,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9485 "src/ocaml/preprocess/parser_raw.ml" +# 10152 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9491 "src/ocaml/preprocess/parser_raw.ml" +# 10158 "src/ocaml/preprocess/parser_raw.ml" in -# 2489 "src/ocaml/preprocess/parser_raw.mly" +# 2609 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_assert _3, _2 ) -# 9497 "src/ocaml/preprocess/parser_raw.ml" +# 10164 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -9501,10 +10168,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9508 "src/ocaml/preprocess/parser_raw.ml" +# 10175 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9553,21 +10220,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9559 "src/ocaml/preprocess/parser_raw.ml" +# 10226 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9565 "src/ocaml/preprocess/parser_raw.ml" +# 10232 "src/ocaml/preprocess/parser_raw.ml" in -# 2491 "src/ocaml/preprocess/parser_raw.mly" +# 2611 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_lazy _3, _2 ) -# 9571 "src/ocaml/preprocess/parser_raw.ml" +# 10238 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -9575,10 +10242,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2420 "src/ocaml/preprocess/parser_raw.mly" +# 2538 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9582 "src/ocaml/preprocess/parser_raw.ml" +# 10249 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9613,18 +10280,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9617 "src/ocaml/preprocess/parser_raw.ml" +# 10284 "src/ocaml/preprocess/parser_raw.ml" in -# 1098 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 9622 "src/ocaml/preprocess/parser_raw.ml" +# 10289 "src/ocaml/preprocess/parser_raw.ml" in -# 2495 "src/ocaml/preprocess/parser_raw.mly" +# 2615 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, _2) ) -# 9628 "src/ocaml/preprocess/parser_raw.ml" +# 10295 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -9632,15 +10299,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9638 "src/ocaml/preprocess/parser_raw.ml" +# 10305 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9644 "src/ocaml/preprocess/parser_raw.ml" +# 10311 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9669,24 +10336,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 9673 "src/ocaml/preprocess/parser_raw.ml" +# 10340 "src/ocaml/preprocess/parser_raw.ml" in -# 1158 "src/ocaml/preprocess/parser_raw.mly" +# 1245 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 9678 "src/ocaml/preprocess/parser_raw.ml" +# 10345 "src/ocaml/preprocess/parser_raw.ml" in -# 2830 "src/ocaml/preprocess/parser_raw.mly" +# 2981 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 9684 "src/ocaml/preprocess/parser_raw.ml" +# 10351 "src/ocaml/preprocess/parser_raw.ml" in -# 2497 "src/ocaml/preprocess/parser_raw.mly" +# 2617 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_tuple(_1) ) -# 9690 "src/ocaml/preprocess/parser_raw.ml" +# 10357 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -9694,15 +10361,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9700 "src/ocaml/preprocess/parser_raw.ml" +# 10367 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9706 "src/ocaml/preprocess/parser_raw.ml" +# 10373 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9738,15 +10405,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 9744 "src/ocaml/preprocess/parser_raw.ml" +# 10411 "src/ocaml/preprocess/parser_raw.ml" in -# 2499 "src/ocaml/preprocess/parser_raw.mly" +# 2619 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct(_1, Some _2) ) -# 9750 "src/ocaml/preprocess/parser_raw.ml" +# 10417 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -9754,15 +10421,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9760 "src/ocaml/preprocess/parser_raw.ml" +# 10427 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9766 "src/ocaml/preprocess/parser_raw.ml" +# 10433 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9793,24 +10460,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2501 "src/ocaml/preprocess/parser_raw.mly" +# 2621 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_variant(_1, Some _2) ) -# 9799 "src/ocaml/preprocess/parser_raw.ml" +# 10466 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9808 "src/ocaml/preprocess/parser_raw.ml" +# 10475 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9814 "src/ocaml/preprocess/parser_raw.ml" +# 10481 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9842,9 +10509,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 841 "src/ocaml/preprocess/parser_raw.mly" (string) -# 9848 "src/ocaml/preprocess/parser_raw.ml" +# 10515 "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 @@ -9854,24 +10521,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3761 "src/ocaml/preprocess/parser_raw.mly" +# 3968 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 9860 "src/ocaml/preprocess/parser_raw.ml" +# 10527 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 9869 "src/ocaml/preprocess/parser_raw.ml" +# 10536 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 9875 "src/ocaml/preprocess/parser_raw.ml" +# 10542 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9879,15 +10546,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9885 "src/ocaml/preprocess/parser_raw.ml" +# 10552 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9891 "src/ocaml/preprocess/parser_raw.ml" +# 10558 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9919,9 +10586,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 842 "src/ocaml/preprocess/parser_raw.mly" (string) -# 9925 "src/ocaml/preprocess/parser_raw.ml" +# 10592 "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 @@ -9931,24 +10598,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3762 "src/ocaml/preprocess/parser_raw.mly" +# 3969 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 9937 "src/ocaml/preprocess/parser_raw.ml" +# 10604 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 9946 "src/ocaml/preprocess/parser_raw.ml" +# 10613 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 9952 "src/ocaml/preprocess/parser_raw.ml" +# 10619 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -9956,15 +10623,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 9962 "src/ocaml/preprocess/parser_raw.ml" +# 10629 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9968 "src/ocaml/preprocess/parser_raw.ml" +# 10635 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9996,9 +10663,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 777 "src/ocaml/preprocess/parser_raw.mly" +# 843 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10002 "src/ocaml/preprocess/parser_raw.ml" +# 10669 "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 @@ -10008,24 +10675,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3763 "src/ocaml/preprocess/parser_raw.mly" +# 3970 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10014 "src/ocaml/preprocess/parser_raw.ml" +# 10681 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10023 "src/ocaml/preprocess/parser_raw.ml" +# 10690 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10029 "src/ocaml/preprocess/parser_raw.ml" +# 10696 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10033,15 +10700,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10039 "src/ocaml/preprocess/parser_raw.ml" +# 10706 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10045 "src/ocaml/preprocess/parser_raw.ml" +# 10712 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10073,9 +10740,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 844 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10079 "src/ocaml/preprocess/parser_raw.ml" +# 10746 "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 @@ -10085,24 +10752,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3764 "src/ocaml/preprocess/parser_raw.mly" +# 3971 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10091 "src/ocaml/preprocess/parser_raw.ml" +# 10758 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10100 "src/ocaml/preprocess/parser_raw.ml" +# 10767 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10106 "src/ocaml/preprocess/parser_raw.ml" +# 10773 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10110,15 +10777,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10116 "src/ocaml/preprocess/parser_raw.ml" +# 10783 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10122 "src/ocaml/preprocess/parser_raw.ml" +# 10789 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10150,9 +10817,9 @@ module Tables = struct } = _menhir_stack in let e2 : (Parsetree.expression) = Obj.magic e2 in let op : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 845 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10156 "src/ocaml/preprocess/parser_raw.ml" +# 10823 "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 @@ -10162,24 +10829,24 @@ module Tables = struct let _1 = let op = let _1 = -# 3765 "src/ocaml/preprocess/parser_raw.mly" +# 3972 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10168 "src/ocaml/preprocess/parser_raw.ml" +# 10835 "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 -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10177 "src/ocaml/preprocess/parser_raw.ml" +# 10844 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10183 "src/ocaml/preprocess/parser_raw.ml" +# 10850 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10187,15 +10854,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10193 "src/ocaml/preprocess/parser_raw.ml" +# 10860 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10199 "src/ocaml/preprocess/parser_raw.ml" +# 10866 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10235,23 +10902,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3766 "src/ocaml/preprocess/parser_raw.mly" +# 3973 "src/ocaml/preprocess/parser_raw.mly" ("+") -# 10241 "src/ocaml/preprocess/parser_raw.ml" +# 10908 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10249 "src/ocaml/preprocess/parser_raw.ml" +# 10916 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10255 "src/ocaml/preprocess/parser_raw.ml" +# 10922 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10259,15 +10926,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10265 "src/ocaml/preprocess/parser_raw.ml" +# 10932 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10271 "src/ocaml/preprocess/parser_raw.ml" +# 10938 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10307,23 +10974,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3767 "src/ocaml/preprocess/parser_raw.mly" +# 3974 "src/ocaml/preprocess/parser_raw.mly" ("+.") -# 10313 "src/ocaml/preprocess/parser_raw.ml" +# 10980 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10321 "src/ocaml/preprocess/parser_raw.ml" +# 10988 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10327 "src/ocaml/preprocess/parser_raw.ml" +# 10994 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10331,15 +10998,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10337 "src/ocaml/preprocess/parser_raw.ml" +# 11004 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10343 "src/ocaml/preprocess/parser_raw.ml" +# 11010 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10379,23 +11046,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3768 "src/ocaml/preprocess/parser_raw.mly" +# 3975 "src/ocaml/preprocess/parser_raw.mly" ("+=") -# 10385 "src/ocaml/preprocess/parser_raw.ml" +# 11052 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10393 "src/ocaml/preprocess/parser_raw.ml" +# 11060 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10399 "src/ocaml/preprocess/parser_raw.ml" +# 11066 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10403,15 +11070,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10409 "src/ocaml/preprocess/parser_raw.ml" +# 11076 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10415 "src/ocaml/preprocess/parser_raw.ml" +# 11082 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10451,23 +11118,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3769 "src/ocaml/preprocess/parser_raw.mly" +# 3976 "src/ocaml/preprocess/parser_raw.mly" ("-") -# 10457 "src/ocaml/preprocess/parser_raw.ml" +# 11124 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10465 "src/ocaml/preprocess/parser_raw.ml" +# 11132 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10471 "src/ocaml/preprocess/parser_raw.ml" +# 11138 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10475,15 +11142,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10481 "src/ocaml/preprocess/parser_raw.ml" +# 11148 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10487 "src/ocaml/preprocess/parser_raw.ml" +# 11154 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10523,23 +11190,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3770 "src/ocaml/preprocess/parser_raw.mly" +# 3977 "src/ocaml/preprocess/parser_raw.mly" ("-.") -# 10529 "src/ocaml/preprocess/parser_raw.ml" +# 11196 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10537 "src/ocaml/preprocess/parser_raw.ml" +# 11204 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10543 "src/ocaml/preprocess/parser_raw.ml" +# 11210 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10547,15 +11214,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10553 "src/ocaml/preprocess/parser_raw.ml" +# 11220 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10559 "src/ocaml/preprocess/parser_raw.ml" +# 11226 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10595,23 +11262,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3771 "src/ocaml/preprocess/parser_raw.mly" +# 3978 "src/ocaml/preprocess/parser_raw.mly" ("*") -# 10601 "src/ocaml/preprocess/parser_raw.ml" +# 11268 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10609 "src/ocaml/preprocess/parser_raw.ml" +# 11276 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10615 "src/ocaml/preprocess/parser_raw.ml" +# 11282 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10619,15 +11286,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10625 "src/ocaml/preprocess/parser_raw.ml" +# 11292 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10631 "src/ocaml/preprocess/parser_raw.ml" +# 11298 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10667,23 +11334,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3772 "src/ocaml/preprocess/parser_raw.mly" +# 3979 "src/ocaml/preprocess/parser_raw.mly" ("%") -# 10673 "src/ocaml/preprocess/parser_raw.ml" +# 11340 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10681 "src/ocaml/preprocess/parser_raw.ml" +# 11348 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10687 "src/ocaml/preprocess/parser_raw.ml" +# 11354 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10691,15 +11358,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10697 "src/ocaml/preprocess/parser_raw.ml" +# 11364 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10703 "src/ocaml/preprocess/parser_raw.ml" +# 11370 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10739,23 +11406,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3773 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ("=") -# 10745 "src/ocaml/preprocess/parser_raw.ml" +# 11412 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10753 "src/ocaml/preprocess/parser_raw.ml" +# 11420 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10759 "src/ocaml/preprocess/parser_raw.ml" +# 11426 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10763,15 +11430,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10769 "src/ocaml/preprocess/parser_raw.ml" +# 11436 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10775 "src/ocaml/preprocess/parser_raw.ml" +# 11442 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10811,23 +11478,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3774 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ("<") -# 10817 "src/ocaml/preprocess/parser_raw.ml" +# 11484 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10825 "src/ocaml/preprocess/parser_raw.ml" +# 11492 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10831 "src/ocaml/preprocess/parser_raw.ml" +# 11498 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10835,15 +11502,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10841 "src/ocaml/preprocess/parser_raw.ml" +# 11508 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10847 "src/ocaml/preprocess/parser_raw.ml" +# 11514 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10883,23 +11550,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3775 "src/ocaml/preprocess/parser_raw.mly" +# 3982 "src/ocaml/preprocess/parser_raw.mly" (">") -# 10889 "src/ocaml/preprocess/parser_raw.ml" +# 11556 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10897 "src/ocaml/preprocess/parser_raw.ml" +# 11564 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10903 "src/ocaml/preprocess/parser_raw.ml" +# 11570 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10907,15 +11574,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10913 "src/ocaml/preprocess/parser_raw.ml" +# 11580 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10919 "src/ocaml/preprocess/parser_raw.ml" +# 11586 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10955,23 +11622,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3776 "src/ocaml/preprocess/parser_raw.mly" +# 3983 "src/ocaml/preprocess/parser_raw.mly" ("or") -# 10961 "src/ocaml/preprocess/parser_raw.ml" +# 11628 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10969 "src/ocaml/preprocess/parser_raw.ml" +# 11636 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10975 "src/ocaml/preprocess/parser_raw.ml" +# 11642 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -10979,15 +11646,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10985 "src/ocaml/preprocess/parser_raw.ml" +# 11652 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10991 "src/ocaml/preprocess/parser_raw.ml" +# 11658 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11027,23 +11694,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3777 "src/ocaml/preprocess/parser_raw.mly" +# 3984 "src/ocaml/preprocess/parser_raw.mly" ("||") -# 11033 "src/ocaml/preprocess/parser_raw.ml" +# 11700 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11041 "src/ocaml/preprocess/parser_raw.ml" +# 11708 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11047 "src/ocaml/preprocess/parser_raw.ml" +# 11714 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11051,15 +11718,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11057 "src/ocaml/preprocess/parser_raw.ml" +# 11724 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11063 "src/ocaml/preprocess/parser_raw.ml" +# 11730 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11099,23 +11766,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3778 "src/ocaml/preprocess/parser_raw.mly" +# 3985 "src/ocaml/preprocess/parser_raw.mly" ("&") -# 11105 "src/ocaml/preprocess/parser_raw.ml" +# 11772 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11113 "src/ocaml/preprocess/parser_raw.ml" +# 11780 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11119 "src/ocaml/preprocess/parser_raw.ml" +# 11786 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11123,15 +11790,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11129 "src/ocaml/preprocess/parser_raw.ml" +# 11796 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11135 "src/ocaml/preprocess/parser_raw.ml" +# 11802 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11171,23 +11838,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3779 "src/ocaml/preprocess/parser_raw.mly" +# 3986 "src/ocaml/preprocess/parser_raw.mly" ("&&") -# 11177 "src/ocaml/preprocess/parser_raw.ml" +# 11844 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11185 "src/ocaml/preprocess/parser_raw.ml" +# 11852 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11191 "src/ocaml/preprocess/parser_raw.ml" +# 11858 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11195,15 +11862,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11201 "src/ocaml/preprocess/parser_raw.ml" +# 11868 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11207 "src/ocaml/preprocess/parser_raw.ml" +# 11874 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11243,23 +11910,23 @@ module Tables = struct let _1 = let op = let _1 = -# 3780 "src/ocaml/preprocess/parser_raw.mly" +# 3987 "src/ocaml/preprocess/parser_raw.mly" (":=") -# 11249 "src/ocaml/preprocess/parser_raw.ml" +# 11916 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11257 "src/ocaml/preprocess/parser_raw.ml" +# 11924 "src/ocaml/preprocess/parser_raw.ml" in -# 2503 "src/ocaml/preprocess/parser_raw.mly" +# 2623 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11263 "src/ocaml/preprocess/parser_raw.ml" +# 11930 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in @@ -11267,15 +11934,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11273 "src/ocaml/preprocess/parser_raw.ml" +# 11940 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11279 "src/ocaml/preprocess/parser_raw.ml" +# 11946 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11308,9 +11975,9 @@ module Tables = struct let _1 = let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 2505 "src/ocaml/preprocess/parser_raw.mly" +# 2625 "src/ocaml/preprocess/parser_raw.mly" ( mkuminus ~oploc:_loc__1_ _1 _2 ) -# 11314 "src/ocaml/preprocess/parser_raw.ml" +# 11981 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -11318,15 +11985,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11324 "src/ocaml/preprocess/parser_raw.ml" +# 11991 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11330 "src/ocaml/preprocess/parser_raw.ml" +# 11997 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11359,9 +12026,9 @@ module Tables = struct let _1 = let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 2507 "src/ocaml/preprocess/parser_raw.mly" +# 2627 "src/ocaml/preprocess/parser_raw.mly" ( mkuplus ~oploc:_loc__1_ _1 _2 ) -# 11365 "src/ocaml/preprocess/parser_raw.ml" +# 12032 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -11369,15 +12036,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11375 "src/ocaml/preprocess/parser_raw.ml" +# 12042 "src/ocaml/preprocess/parser_raw.ml" in -# 2423 "src/ocaml/preprocess/parser_raw.mly" +# 2541 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11381 "src/ocaml/preprocess/parser_raw.ml" +# 12048 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11417,9 +12084,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2425 "src/ocaml/preprocess/parser_raw.mly" +# 2543 "src/ocaml/preprocess/parser_raw.mly" ( expr_of_let_bindings ~loc:_sloc _1 (merloc _endpos__2_ _3) ) -# 11423 "src/ocaml/preprocess/parser_raw.ml" +# 12090 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11459,9 +12126,9 @@ module Tables = struct let _3 : unit = Obj.magic _3 in let bindings : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = Obj.magic bindings in let _1 : ( -# 781 "src/ocaml/preprocess/parser_raw.mly" +# 847 "src/ocaml/preprocess/parser_raw.mly" (string) -# 11465 "src/ocaml/preprocess/parser_raw.ml" +# 12132 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -11471,9 +12138,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11477 "src/ocaml/preprocess/parser_raw.ml" +# 12144 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_pbop_op_ = _startpos__1_ in @@ -11481,13 +12148,13 @@ module Tables = struct let _symbolstartpos = _startpos_pbop_op_ in let _sloc = (_symbolstartpos, _endpos) in -# 2427 "src/ocaml/preprocess/parser_raw.mly" +# 2545 "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}) ) -# 11491 "src/ocaml/preprocess/parser_raw.ml" +# 12158 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11528,9 +12195,9 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2433 "src/ocaml/preprocess/parser_raw.mly" +# 2551 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_cons ~loc:_sloc _loc__2_ (ghexp ~loc:_sloc (Pexp_tuple[_1;(merloc _endpos__2_ _3)])) ) -# 11534 "src/ocaml/preprocess/parser_raw.ml" +# 12201 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11563,35 +12230,35 @@ module Tables = struct let _3 : (Parsetree.expression) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 11569 "src/ocaml/preprocess/parser_raw.ml" +# 12236 "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 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11578 "src/ocaml/preprocess/parser_raw.ml" +# 12245 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11586 "src/ocaml/preprocess/parser_raw.ml" +# 12253 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2435 "src/ocaml/preprocess/parser_raw.mly" +# 2553 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc (Pexp_setinstvar(_1, _3)) ) -# 11595 "src/ocaml/preprocess/parser_raw.ml" +# 12262 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11647,18 +12314,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 11653 "src/ocaml/preprocess/parser_raw.ml" +# 12320 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2437 "src/ocaml/preprocess/parser_raw.mly" +# 2555 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc (Pexp_setfield(_1, _3, _5)) ) -# 11662 "src/ocaml/preprocess/parser_raw.ml" +# 12329 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11724,14 +12391,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2438 "src/ocaml/preprocess/parser_raw.mly" +# 2556 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11730 "src/ocaml/preprocess/parser_raw.ml" +# 12397 "src/ocaml/preprocess/parser_raw.ml" in -# 2398 "src/ocaml/preprocess/parser_raw.mly" +# 2516 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 11735 "src/ocaml/preprocess/parser_raw.ml" +# 12402 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11739,9 +12406,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2439 "src/ocaml/preprocess/parser_raw.mly" +# 2557 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11745 "src/ocaml/preprocess/parser_raw.ml" +# 12412 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11807,14 +12474,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2438 "src/ocaml/preprocess/parser_raw.mly" +# 2556 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11813 "src/ocaml/preprocess/parser_raw.ml" +# 12480 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2518 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 11818 "src/ocaml/preprocess/parser_raw.ml" +# 12485 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11822,9 +12489,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2439 "src/ocaml/preprocess/parser_raw.mly" +# 2557 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11828 "src/ocaml/preprocess/parser_raw.ml" +# 12495 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11890,14 +12557,14 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2438 "src/ocaml/preprocess/parser_raw.mly" +# 2556 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11896 "src/ocaml/preprocess/parser_raw.ml" +# 12563 "src/ocaml/preprocess/parser_raw.ml" in -# 2402 "src/ocaml/preprocess/parser_raw.mly" +# 2520 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 11901 "src/ocaml/preprocess/parser_raw.ml" +# 12568 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -11905,9 +12572,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2439 "src/ocaml/preprocess/parser_raw.mly" +# 2557 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 11911 "src/ocaml/preprocess/parser_raw.ml" +# 12578 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11967,9 +12634,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 11973 "src/ocaml/preprocess/parser_raw.ml" +# 12640 "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 @@ -11977,31 +12644,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2440 "src/ocaml/preprocess/parser_raw.mly" +# 2558 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 11983 "src/ocaml/preprocess/parser_raw.ml" +# 12650 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 11988 "src/ocaml/preprocess/parser_raw.ml" +# 12655 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 11994 "src/ocaml/preprocess/parser_raw.ml" +# 12661 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 11999 "src/ocaml/preprocess/parser_raw.ml" +# 12666 "src/ocaml/preprocess/parser_raw.ml" in -# 2398 "src/ocaml/preprocess/parser_raw.mly" +# 2516 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 12005 "src/ocaml/preprocess/parser_raw.ml" +# 12672 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12009,9 +12676,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2441 "src/ocaml/preprocess/parser_raw.mly" +# 2559 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12015 "src/ocaml/preprocess/parser_raw.ml" +# 12682 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12083,9 +12750,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12089 "src/ocaml/preprocess/parser_raw.ml" +# 12756 "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 @@ -12097,40 +12764,40 @@ module Tables = struct let r = let _1 = _1_inlined1 in -# 2440 "src/ocaml/preprocess/parser_raw.mly" +# 2558 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12103 "src/ocaml/preprocess/parser_raw.ml" +# 12770 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12109 "src/ocaml/preprocess/parser_raw.ml" +# 12776 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 12117 "src/ocaml/preprocess/parser_raw.ml" +# 12784 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12122 "src/ocaml/preprocess/parser_raw.ml" +# 12789 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12128 "src/ocaml/preprocess/parser_raw.ml" +# 12795 "src/ocaml/preprocess/parser_raw.ml" in -# 2398 "src/ocaml/preprocess/parser_raw.mly" +# 2516 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 12134 "src/ocaml/preprocess/parser_raw.ml" +# 12801 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12138,9 +12805,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2441 "src/ocaml/preprocess/parser_raw.mly" +# 2559 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12144 "src/ocaml/preprocess/parser_raw.ml" +# 12811 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12200,9 +12867,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12206 "src/ocaml/preprocess/parser_raw.ml" +# 12873 "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 @@ -12210,31 +12877,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2440 "src/ocaml/preprocess/parser_raw.mly" +# 2558 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12216 "src/ocaml/preprocess/parser_raw.ml" +# 12883 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12221 "src/ocaml/preprocess/parser_raw.ml" +# 12888 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12227 "src/ocaml/preprocess/parser_raw.ml" +# 12894 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12232 "src/ocaml/preprocess/parser_raw.ml" +# 12899 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2518 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 12238 "src/ocaml/preprocess/parser_raw.ml" +# 12905 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12242,9 +12909,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2441 "src/ocaml/preprocess/parser_raw.mly" +# 2559 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12248 "src/ocaml/preprocess/parser_raw.ml" +# 12915 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12316,9 +12983,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12322 "src/ocaml/preprocess/parser_raw.ml" +# 12989 "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 @@ -12330,40 +12997,40 @@ module Tables = struct let r = let _1 = _1_inlined1 in -# 2440 "src/ocaml/preprocess/parser_raw.mly" +# 2558 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12336 "src/ocaml/preprocess/parser_raw.ml" +# 13003 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12342 "src/ocaml/preprocess/parser_raw.ml" +# 13009 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 12350 "src/ocaml/preprocess/parser_raw.ml" +# 13017 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12355 "src/ocaml/preprocess/parser_raw.ml" +# 13022 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12361 "src/ocaml/preprocess/parser_raw.ml" +# 13028 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2518 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 12367 "src/ocaml/preprocess/parser_raw.ml" +# 13034 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12371,9 +13038,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2441 "src/ocaml/preprocess/parser_raw.mly" +# 2559 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12377 "src/ocaml/preprocess/parser_raw.ml" +# 13044 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12433,9 +13100,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12439 "src/ocaml/preprocess/parser_raw.ml" +# 13106 "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 @@ -12443,31 +13110,31 @@ module Tables = struct let _endpos = _endpos_v_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2440 "src/ocaml/preprocess/parser_raw.mly" +# 2558 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12449 "src/ocaml/preprocess/parser_raw.ml" +# 13116 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12454 "src/ocaml/preprocess/parser_raw.ml" +# 13121 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12460 "src/ocaml/preprocess/parser_raw.ml" +# 13127 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12465 "src/ocaml/preprocess/parser_raw.ml" +# 13132 "src/ocaml/preprocess/parser_raw.ml" in -# 2402 "src/ocaml/preprocess/parser_raw.mly" +# 2520 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 12471 "src/ocaml/preprocess/parser_raw.ml" +# 13138 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12475,9 +13142,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2441 "src/ocaml/preprocess/parser_raw.mly" +# 2559 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12481 "src/ocaml/preprocess/parser_raw.ml" +# 13148 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12549,9 +13216,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12555 "src/ocaml/preprocess/parser_raw.ml" +# 13222 "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 @@ -12563,40 +13230,40 @@ module Tables = struct let r = let _1 = _1_inlined1 in -# 2440 "src/ocaml/preprocess/parser_raw.mly" +# 2558 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12569 "src/ocaml/preprocess/parser_raw.ml" +# 13236 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12575 "src/ocaml/preprocess/parser_raw.ml" +# 13242 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 12583 "src/ocaml/preprocess/parser_raw.ml" +# 13250 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12588 "src/ocaml/preprocess/parser_raw.ml" +# 13255 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12594 "src/ocaml/preprocess/parser_raw.ml" +# 13261 "src/ocaml/preprocess/parser_raw.ml" in -# 2402 "src/ocaml/preprocess/parser_raw.mly" +# 2520 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 12600 "src/ocaml/preprocess/parser_raw.ml" +# 13267 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in @@ -12604,9 +13271,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2441 "src/ocaml/preprocess/parser_raw.mly" +# 2559 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12610 "src/ocaml/preprocess/parser_raw.ml" +# 13277 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12636,59 +13303,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2443 "src/ocaml/preprocess/parser_raw.mly" +# 2561 "src/ocaml/preprocess/parser_raw.mly" ( Exp.attr _1 _2 ) -# 12642 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.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) = -# 4058 "src/ocaml/preprocess/parser_raw.mly" - ( None ) -# 12660 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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) = -# 4059 "src/ocaml/preprocess/parser_raw.mly" - ( Some _2 ) -# 12692 "src/ocaml/preprocess/parser_raw.ml" +# 13309 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12706,9 +13323,9 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _2; @@ -12725,16 +13342,36 @@ module Tables = struct }; } = _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 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__4_ in - let _v : (Parsetree.extension) = -# 4071 "src/ocaml/preprocess/parser_raw.mly" - ( (_2, _3) ) -# 12738 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.function_param list) = let ty_params = +# 2809 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13355 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__4_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2958 "src/ocaml/preprocess/parser_raw.mly" + ( (* We desugar (type a b c) to (type a) (type b) (type c). + If we do this desugaring, the loc for each parameter is a ghost. + *) + let loc = + match ty_params with + | [] -> assert false (* lident_list is non-empty *) + | [_] -> make_loc _sloc + | _ :: _ :: _ -> ghost_loc _sloc + in + List.map + (fun x -> { pparam_loc = loc; pparam_desc = Pparam_newtype x }) + ty_params + ) +# 13375 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12752,195 +13389,19 @@ module Tables = struct MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in - let _1 : ( -# 839 "src/ocaml/preprocess/parser_raw.mly" - (string * Location.t * string * Location.t * string option) -# 12759 "src/ocaml/preprocess/parser_raw.ml" - ) = Obj.magic _1 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__1_ in - let _v : (Parsetree.extension) = let _endpos = _endpos__1_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 4073 "src/ocaml/preprocess/parser_raw.mly" - ( mk_quotedext ~loc:_sloc _1 ) -# 12770 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 4055 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 12825 "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 - -# 996 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 12837 "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 - -# 996 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 12848 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos = _endpos_attrs_ in + let _v : (Parsetree.function_param list) = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3415 "src/ocaml/preprocess/parser_raw.mly" - ( let info = symbol_info _endpos in - Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 12858 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 4055 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 12906 "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 - -# 996 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 12918 "src/ocaml/preprocess/parser_raw.ml" - - in - let cid = - let _endpos = _endpos__1_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 996 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 12928 "src/ocaml/preprocess/parser_raw.ml" - - in - let _startpos_cid_ = _startpos__1_ in - let _1 = -# 3876 "src/ocaml/preprocess/parser_raw.mly" - ( () ) -# 12935 "src/ocaml/preprocess/parser_raw.ml" - in - let _endpos = _endpos_attrs_ in - let _symbolstartpos = _startpos_cid_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 3415 "src/ocaml/preprocess/parser_raw.mly" - ( let info = symbol_info _endpos in - Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 12944 "src/ocaml/preprocess/parser_raw.ml" +# 2972 "src/ocaml/preprocess/parser_raw.mly" + ( let a, b, c = _1 in + [ { pparam_loc = make_loc _sloc; pparam_desc = Pparam_val (a, b, c) } ] + ) +# 13405 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12952,126 +13413,32 @@ module Tables = struct (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 - -# 4046 "src/ocaml/preprocess/parser_raw.mly" - ( mark_symbol_docs _sloc; - Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 12994 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.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 = -# 2191 "src/ocaml/preprocess/parser_raw.mly" - ( [] ) -# 13012 "src/ocaml/preprocess/parser_raw.ml" - in - -# 2008 "src/ocaml/preprocess/parser_raw.mly" - ( params ) -# 13017 "src/ocaml/preprocess/parser_raw.ml" - in - { MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; 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 xs : (Parsetree.function_param list) = Obj.magic xs 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 = + let _startpos = _startpos_xs_ in + let _endpos = _endpos_xs_ in + let _v : (Parsetree.function_param list) = let _1 = + let xs = # 253 "" ( List.rev xs ) -# 13058 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1130 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 13063 "src/ocaml/preprocess/parser_raw.ml" - - in +# 13431 "src/ocaml/preprocess/parser_raw.ml" + in -# 2193 "src/ocaml/preprocess/parser_raw.mly" - ( params ) -# 13069 "src/ocaml/preprocess/parser_raw.ml" +# 1185 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13436 "src/ocaml/preprocess/parser_raw.ml" in -# 2008 "src/ocaml/preprocess/parser_raw.mly" - ( params ) -# 13075 "src/ocaml/preprocess/parser_raw.ml" +# 2977 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13442 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13094,145 +13461,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2788 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 13100 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 2790 "src/ocaml/preprocess/parser_raw.mly" - ( mkexp_constraint ~loc:_sloc _3 _1 ) -# 13142 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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) = -# 2815 "src/ocaml/preprocess/parser_raw.mly" - ( (merloc _endpos__1_ _2) ) -# 13174 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 = -# 2817 "src/ocaml/preprocess/parser_raw.mly" - ( Pexp_constraint ((merloc _endpos__3_ _4), _2) ) -# 13221 "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 - -# 1029 "src/ocaml/preprocess/parser_raw.mly" - ( mkexp ~loc:_sloc _1 ) -# 13230 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2818 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 13236 "src/ocaml/preprocess/parser_raw.ml" +# 2451 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13467 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13256,21 +13487,70 @@ module Tables = struct 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 _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) = let _endpos = _endpos__2_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in + let _v : (Parsetree.expression) = +# 2452 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13499 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = +# 2454 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_sequence(_1, _3) ) +# 13539 "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 + +# 1095 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 13548 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2821 "src/ocaml/preprocess/parser_raw.mly" - ( - let (l,o,p) = _1 in - ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) - ) -# 13274 "src/ocaml/preprocess/parser_raw.ml" +# 2455 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13554 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13293,9 +13573,9 @@ module Tables = struct 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.semv = _3; + MenhirLib.EngineTypes.startp = _startpos__3_; + MenhirLib.EngineTypes.endp = _endpos__3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _2; @@ -13313,25 +13593,22 @@ module Tables = struct }; } = _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 _4 : (string Location.loc) = Obj.magic _4 in + let _3 : unit = Obj.magic _3 in let _2 : unit = Obj.magic _2 in - let _1 : unit = Obj.magic _1 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 = -# 2689 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 13327 "src/ocaml/preprocess/parser_raw.ml" - 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 -# 2826 "src/ocaml/preprocess/parser_raw.mly" - ( mk_newtypes ~loc:_sloc _3 _5 ) -# 13335 "src/ocaml/preprocess/parser_raw.ml" +# 2457 "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)) ) +# 13612 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13354,9 +13631,9 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.core_type) = -# 3531 "src/ocaml/preprocess/parser_raw.mly" +# 3682 "src/ocaml/preprocess/parser_raw.mly" ( ty ) -# 13360 "src/ocaml/preprocess/parser_raw.ml" +# 13637 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13402,19 +13679,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13408 "src/ocaml/preprocess/parser_raw.ml" +# 13685 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3543 "src/ocaml/preprocess/parser_raw.mly" +# 3694 "src/ocaml/preprocess/parser_raw.mly" ( Optional label ) -# 13413 "src/ocaml/preprocess/parser_raw.ml" +# 13690 "src/ocaml/preprocess/parser_raw.ml" in -# 3537 "src/ocaml/preprocess/parser_raw.mly" +# 3688 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13418 "src/ocaml/preprocess/parser_raw.ml" +# 13695 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13422,15 +13699,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13428 "src/ocaml/preprocess/parser_raw.ml" +# 13705 "src/ocaml/preprocess/parser_raw.ml" in -# 3539 "src/ocaml/preprocess/parser_raw.mly" +# 3690 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13434 "src/ocaml/preprocess/parser_raw.ml" +# 13711 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13477,9 +13754,9 @@ module Tables = struct let _1 : (Parsetree.core_type) = Obj.magic _1 in let _2 : unit = Obj.magic _2 in let label : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 13483 "src/ocaml/preprocess/parser_raw.ml" +# 13760 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -13487,19 +13764,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13493 "src/ocaml/preprocess/parser_raw.ml" +# 13770 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3545 "src/ocaml/preprocess/parser_raw.mly" +# 3696 "src/ocaml/preprocess/parser_raw.mly" ( Labelled label ) -# 13498 "src/ocaml/preprocess/parser_raw.ml" +# 13775 "src/ocaml/preprocess/parser_raw.ml" in -# 3537 "src/ocaml/preprocess/parser_raw.mly" +# 3688 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13503 "src/ocaml/preprocess/parser_raw.ml" +# 13780 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13507,15 +13784,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13513 "src/ocaml/preprocess/parser_raw.ml" +# 13790 "src/ocaml/preprocess/parser_raw.ml" in -# 3539 "src/ocaml/preprocess/parser_raw.mly" +# 3690 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13519 "src/ocaml/preprocess/parser_raw.ml" +# 13796 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13554,19 +13831,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 994 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13560 "src/ocaml/preprocess/parser_raw.ml" +# 13837 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3547 "src/ocaml/preprocess/parser_raw.mly" +# 3698 "src/ocaml/preprocess/parser_raw.mly" ( Nolabel ) -# 13565 "src/ocaml/preprocess/parser_raw.ml" +# 13842 "src/ocaml/preprocess/parser_raw.ml" in -# 3537 "src/ocaml/preprocess/parser_raw.mly" +# 3688 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13570 "src/ocaml/preprocess/parser_raw.ml" +# 13847 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_codomain_ in @@ -13574,15 +13851,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13580 "src/ocaml/preprocess/parser_raw.ml" +# 13857 "src/ocaml/preprocess/parser_raw.ml" in -# 3539 "src/ocaml/preprocess/parser_raw.mly" +# 3690 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13586 "src/ocaml/preprocess/parser_raw.ml" +# 13863 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13613,9 +13890,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Lexing.position * Parsetree.functor_parameter) = let _startpos = _startpos__1_ in -# 1385 "src/ocaml/preprocess/parser_raw.mly" +# 1472 "src/ocaml/preprocess/parser_raw.mly" ( _startpos, Unit ) -# 13619 "src/ocaml/preprocess/parser_raw.ml" +# 13896 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13671,16 +13948,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 13677 "src/ocaml/preprocess/parser_raw.ml" +# 13954 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1388 "src/ocaml/preprocess/parser_raw.mly" +# 1475 "src/ocaml/preprocess/parser_raw.mly" ( _startpos, Named (x, mty) ) -# 13684 "src/ocaml/preprocess/parser_raw.ml" +# 13961 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13703,9 +13980,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1377 "src/ocaml/preprocess/parser_raw.mly" +# 1464 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13709 "src/ocaml/preprocess/parser_raw.ml" +# 13986 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13722,9 +13999,9 @@ module Tables = struct let _endpos = _startpos in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3330 "src/ocaml/preprocess/parser_raw.mly" +# 3481 "src/ocaml/preprocess/parser_raw.mly" ( ([],Pcstr_tuple [],None) ) -# 13728 "src/ocaml/preprocess/parser_raw.ml" +# 14005 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13755,9 +14032,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3331 "src/ocaml/preprocess/parser_raw.mly" +# 3482 "src/ocaml/preprocess/parser_raw.mly" ( ([],_2,None) ) -# 13761 "src/ocaml/preprocess/parser_raw.ml" +# 14038 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13802,9 +14079,9 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3333 "src/ocaml/preprocess/parser_raw.mly" +# 3484 "src/ocaml/preprocess/parser_raw.mly" ( ([],_2,Some _4) ) -# 13808 "src/ocaml/preprocess/parser_raw.ml" +# 14085 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13867,24 +14144,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 13871 "src/ocaml/preprocess/parser_raw.ml" +# 14148 "src/ocaml/preprocess/parser_raw.ml" in -# 1098 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13876 "src/ocaml/preprocess/parser_raw.ml" +# 14153 "src/ocaml/preprocess/parser_raw.ml" in -# 3466 "src/ocaml/preprocess/parser_raw.mly" +# 3617 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13882 "src/ocaml/preprocess/parser_raw.ml" +# 14159 "src/ocaml/preprocess/parser_raw.ml" in -# 3336 "src/ocaml/preprocess/parser_raw.mly" +# 3487 "src/ocaml/preprocess/parser_raw.mly" ( (_2,_4,Some _6) ) -# 13888 "src/ocaml/preprocess/parser_raw.ml" +# 14165 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13915,9 +14192,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3338 "src/ocaml/preprocess/parser_raw.mly" +# 3489 "src/ocaml/preprocess/parser_raw.mly" ( ([],Pcstr_tuple [],Some _2) ) -# 13921 "src/ocaml/preprocess/parser_raw.ml" +# 14198 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13966,24 +14243,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 13970 "src/ocaml/preprocess/parser_raw.ml" +# 14247 "src/ocaml/preprocess/parser_raw.ml" in -# 1098 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13975 "src/ocaml/preprocess/parser_raw.ml" +# 14252 "src/ocaml/preprocess/parser_raw.ml" in -# 3466 "src/ocaml/preprocess/parser_raw.mly" +# 3617 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13981 "src/ocaml/preprocess/parser_raw.ml" +# 14258 "src/ocaml/preprocess/parser_raw.ml" in -# 3340 "src/ocaml/preprocess/parser_raw.mly" +# 3491 "src/ocaml/preprocess/parser_raw.mly" ( (_2,Pcstr_tuple [],Some _4) ) -# 13987 "src/ocaml/preprocess/parser_raw.ml" +# 14264 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14032,9 +14309,9 @@ module Tables = struct Parsetree.attributes * Location.t * Ocaml_parsing.Docstrings.info) = let attrs = let _1 = _1_inlined2 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14038 "src/ocaml/preprocess/parser_raw.ml" +# 14315 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined2_ in @@ -14044,23 +14321,23 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14050 "src/ocaml/preprocess/parser_raw.ml" +# 14327 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3278 "src/ocaml/preprocess/parser_raw.mly" +# 3429 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let info = symbol_info _endpos in let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 14064 "src/ocaml/preprocess/parser_raw.ml" +# 14341 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14102,9 +14379,9 @@ module Tables = struct Parsetree.attributes * Location.t * Ocaml_parsing.Docstrings.info) = let attrs = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14108 "src/ocaml/preprocess/parser_raw.ml" +# 14385 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined1_ in @@ -14113,29 +14390,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14119 "src/ocaml/preprocess/parser_raw.ml" +# 14396 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_cid_ = _startpos__1_ in let _1 = -# 3876 "src/ocaml/preprocess/parser_raw.mly" +# 4083 "src/ocaml/preprocess/parser_raw.mly" ( () ) -# 14126 "src/ocaml/preprocess/parser_raw.ml" +# 14403 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos_cid_ in let _sloc = (_symbolstartpos, _endpos) in -# 3278 "src/ocaml/preprocess/parser_raw.mly" +# 3429 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let info = symbol_info _endpos in let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 14139 "src/ocaml/preprocess/parser_raw.ml" +# 14416 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14206,9 +14483,9 @@ module Tables = struct 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 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14212 "src/ocaml/preprocess/parser_raw.ml" +# 14489 "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 @@ -14221,9 +14498,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined4 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14227 "src/ocaml/preprocess/parser_raw.ml" +# 14504 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14232,26 +14509,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14236 "src/ocaml/preprocess/parser_raw.ml" +# 14513 "src/ocaml/preprocess/parser_raw.ml" in -# 1080 "src/ocaml/preprocess/parser_raw.mly" +# 1146 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14241 "src/ocaml/preprocess/parser_raw.ml" +# 14518 "src/ocaml/preprocess/parser_raw.ml" in -# 3181 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14247 "src/ocaml/preprocess/parser_raw.ml" +# 14524 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined3 in -# 3216 "src/ocaml/preprocess/parser_raw.mly" +# 3367 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 14255 "src/ocaml/preprocess/parser_raw.ml" +# 14532 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14260,29 +14537,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14266 "src/ocaml/preprocess/parser_raw.ml" +# 14543 "src/ocaml/preprocess/parser_raw.ml" in let flag = -# 3896 "src/ocaml/preprocess/parser_raw.mly" +# 4103 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 14272 "src/ocaml/preprocess/parser_raw.ml" +# 14549 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14279 "src/ocaml/preprocess/parser_raw.ml" +# 14556 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3153 "src/ocaml/preprocess/parser_raw.mly" +# 3304 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14291,7 +14568,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14295 "src/ocaml/preprocess/parser_raw.ml" +# 14572 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14368,9 +14645,9 @@ module Tables = struct 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 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14374 "src/ocaml/preprocess/parser_raw.ml" +# 14651 "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 @@ -14384,9 +14661,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined5 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14390 "src/ocaml/preprocess/parser_raw.ml" +# 14667 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined5_ in @@ -14395,26 +14672,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14399 "src/ocaml/preprocess/parser_raw.ml" +# 14676 "src/ocaml/preprocess/parser_raw.ml" in -# 1080 "src/ocaml/preprocess/parser_raw.mly" +# 1146 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14404 "src/ocaml/preprocess/parser_raw.ml" +# 14681 "src/ocaml/preprocess/parser_raw.ml" in -# 3181 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14410 "src/ocaml/preprocess/parser_raw.ml" +# 14687 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined4 in -# 3216 "src/ocaml/preprocess/parser_raw.mly" +# 3367 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 14418 "src/ocaml/preprocess/parser_raw.ml" +# 14695 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14423,9 +14700,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14429 "src/ocaml/preprocess/parser_raw.ml" +# 14706 "src/ocaml/preprocess/parser_raw.ml" in let flag = @@ -14434,24 +14711,24 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3898 "src/ocaml/preprocess/parser_raw.mly" +# 4105 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 14440 "src/ocaml/preprocess/parser_raw.ml" +# 14717 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14448 "src/ocaml/preprocess/parser_raw.ml" +# 14725 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3153 "src/ocaml/preprocess/parser_raw.mly" +# 3304 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14460,7 +14737,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14464 "src/ocaml/preprocess/parser_raw.ml" +# 14741 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14524,9 +14801,9 @@ module Tables = struct 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 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14530 "src/ocaml/preprocess/parser_raw.ml" +# 14807 "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 @@ -14539,9 +14816,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14545 "src/ocaml/preprocess/parser_raw.ml" +# 14822 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -14550,18 +14827,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14554 "src/ocaml/preprocess/parser_raw.ml" +# 14831 "src/ocaml/preprocess/parser_raw.ml" in -# 1080 "src/ocaml/preprocess/parser_raw.mly" +# 1146 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14559 "src/ocaml/preprocess/parser_raw.ml" +# 14836 "src/ocaml/preprocess/parser_raw.ml" in -# 3181 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14565 "src/ocaml/preprocess/parser_raw.ml" +# 14842 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14570,29 +14847,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14576 "src/ocaml/preprocess/parser_raw.ml" +# 14853 "src/ocaml/preprocess/parser_raw.ml" in let flag = -# 3892 "src/ocaml/preprocess/parser_raw.mly" +# 4099 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 14582 "src/ocaml/preprocess/parser_raw.ml" +# 14859 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14589 "src/ocaml/preprocess/parser_raw.ml" +# 14866 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3153 "src/ocaml/preprocess/parser_raw.mly" +# 3304 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14601,7 +14878,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14605 "src/ocaml/preprocess/parser_raw.ml" +# 14882 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14671,9 +14948,9 @@ module Tables = struct 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 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14677 "src/ocaml/preprocess/parser_raw.ml" +# 14954 "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 @@ -14687,9 +14964,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined4 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14693 "src/ocaml/preprocess/parser_raw.ml" +# 14970 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14698,18 +14975,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14702 "src/ocaml/preprocess/parser_raw.ml" +# 14979 "src/ocaml/preprocess/parser_raw.ml" in -# 1080 "src/ocaml/preprocess/parser_raw.mly" +# 1146 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14707 "src/ocaml/preprocess/parser_raw.ml" +# 14984 "src/ocaml/preprocess/parser_raw.ml" in -# 3181 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14713 "src/ocaml/preprocess/parser_raw.ml" +# 14990 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14718,32 +14995,32 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14724 "src/ocaml/preprocess/parser_raw.ml" +# 15001 "src/ocaml/preprocess/parser_raw.ml" in let flag = let _1 = _1_inlined2 in -# 3893 "src/ocaml/preprocess/parser_raw.mly" +# 4100 "src/ocaml/preprocess/parser_raw.mly" ( Nonrecursive ) -# 14732 "src/ocaml/preprocess/parser_raw.ml" +# 15009 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14740 "src/ocaml/preprocess/parser_raw.ml" +# 15017 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3153 "src/ocaml/preprocess/parser_raw.mly" +# 3304 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14752,7 +15029,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14756 "src/ocaml/preprocess/parser_raw.ml" +# 15033 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14771,17 +15048,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14777 "src/ocaml/preprocess/parser_raw.ml" +# 15054 "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) = -# 3731 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14785 "src/ocaml/preprocess/parser_raw.ml" +# 15062 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14800,17 +15077,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14806 "src/ocaml/preprocess/parser_raw.ml" +# 15083 "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) = -# 3732 "src/ocaml/preprocess/parser_raw.mly" +# 3939 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14814 "src/ocaml/preprocess/parser_raw.ml" +# 15091 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14840,9 +15117,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.structure) = -# 1251 "src/ocaml/preprocess/parser_raw.mly" +# 1338 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14846 "src/ocaml/preprocess/parser_raw.ml" +# 15123 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14858,9 +15135,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (string) = -# 3783 "src/ocaml/preprocess/parser_raw.mly" +# 3990 "src/ocaml/preprocess/parser_raw.mly" ( "" ) -# 14864 "src/ocaml/preprocess/parser_raw.ml" +# 15141 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14890,9 +15167,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3784 "src/ocaml/preprocess/parser_raw.mly" +# 3991 "src/ocaml/preprocess/parser_raw.mly" ( ";.." ) -# 14896 "src/ocaml/preprocess/parser_raw.ml" +# 15173 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14922,9 +15199,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.signature) = -# 1258 "src/ocaml/preprocess/parser_raw.mly" +# 1345 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14928 "src/ocaml/preprocess/parser_raw.ml" +# 15205 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14968,9 +15245,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.extension) = -# 4076 "src/ocaml/preprocess/parser_raw.mly" +# 4283 "src/ocaml/preprocess/parser_raw.mly" ( (_2, _3) ) -# 14974 "src/ocaml/preprocess/parser_raw.ml" +# 15251 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14989,9 +15266,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 842 "src/ocaml/preprocess/parser_raw.mly" +# 908 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 14995 "src/ocaml/preprocess/parser_raw.ml" +# 15272 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15000,9 +15277,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4078 "src/ocaml/preprocess/parser_raw.mly" +# 4285 "src/ocaml/preprocess/parser_raw.mly" ( mk_quotedext ~loc:_sloc _1 ) -# 15006 "src/ocaml/preprocess/parser_raw.ml" +# 15283 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15048,9 +15325,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _3 : unit = Obj.magic _3 in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15054 "src/ocaml/preprocess/parser_raw.ml" +# 15331 "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 @@ -15059,34 +15336,34 @@ module Tables = struct let _v : (Parsetree.label_declaration) = let _5 = let _1 = _1_inlined3 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15065 "src/ocaml/preprocess/parser_raw.ml" +# 15342 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 3484 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15074 "src/ocaml/preprocess/parser_raw.ml" +# 15351 "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 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15082 "src/ocaml/preprocess/parser_raw.ml" +# 15359 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15090 "src/ocaml/preprocess/parser_raw.ml" +# 15367 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15097,10 +15374,10 @@ module Tables = struct _startpos__2_ in let _sloc = (_symbolstartpos, _endpos) in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3508 "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 ) -# 15104 "src/ocaml/preprocess/parser_raw.ml" +# 15381 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15160,9 +15437,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _3 : unit = Obj.magic _3 in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15166 "src/ocaml/preprocess/parser_raw.ml" +# 15443 "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 @@ -15171,43 +15448,43 @@ module Tables = struct let _v : (Parsetree.label_declaration) = let _7 = let _1 = _1_inlined4 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15177 "src/ocaml/preprocess/parser_raw.ml" +# 15454 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__7_ = _endpos__1_inlined4_ in let _5 = let _1 = _1_inlined3 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15186 "src/ocaml/preprocess/parser_raw.ml" +# 15463 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 3484 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15195 "src/ocaml/preprocess/parser_raw.ml" +# 15472 "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 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15203 "src/ocaml/preprocess/parser_raw.ml" +# 15480 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15211 "src/ocaml/preprocess/parser_raw.ml" +# 15488 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15218,14 +15495,14 @@ module Tables = struct _startpos__2_ in let _sloc = (_symbolstartpos, _endpos) in -# 3362 "src/ocaml/preprocess/parser_raw.mly" +# 3513 "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 ) -# 15229 "src/ocaml/preprocess/parser_raw.ml" +# 15506 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15248,9 +15525,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.label_declaration list) = -# 3351 "src/ocaml/preprocess/parser_raw.mly" +# 3502 "src/ocaml/preprocess/parser_raw.mly" ( [_1] ) -# 15254 "src/ocaml/preprocess/parser_raw.ml" +# 15531 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15273,9 +15550,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.label_declaration list) = -# 3352 "src/ocaml/preprocess/parser_raw.mly" +# 3503 "src/ocaml/preprocess/parser_raw.mly" ( [_1] ) -# 15279 "src/ocaml/preprocess/parser_raw.ml" +# 15556 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15305,9 +15582,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.label_declaration list) = -# 3353 "src/ocaml/preprocess/parser_raw.mly" +# 3504 "src/ocaml/preprocess/parser_raw.mly" ( _1 :: _2 ) -# 15311 "src/ocaml/preprocess/parser_raw.ml" +# 15588 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15326,9 +15603,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15332 "src/ocaml/preprocess/parser_raw.ml" +# 15609 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15339,24 +15616,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15345 "src/ocaml/preprocess/parser_raw.ml" +# 15622 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2386 "src/ocaml/preprocess/parser_raw.mly" +# 2504 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15354 "src/ocaml/preprocess/parser_raw.ml" +# 15631 "src/ocaml/preprocess/parser_raw.ml" in -# 2378 "src/ocaml/preprocess/parser_raw.mly" +# 2496 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 15360 "src/ocaml/preprocess/parser_raw.ml" +# 15637 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15389,9 +15666,9 @@ module Tables = struct let cty : (Parsetree.core_type) = Obj.magic cty in let _2 : unit = Obj.magic _2 in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15395 "src/ocaml/preprocess/parser_raw.ml" +# 15672 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15402,18 +15679,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15408 "src/ocaml/preprocess/parser_raw.ml" +# 15685 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2386 "src/ocaml/preprocess/parser_raw.mly" +# 2504 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15417 "src/ocaml/preprocess/parser_raw.ml" +# 15694 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_x_ = _startpos__1_ in @@ -15421,11 +15698,11 @@ module Tables = struct let _symbolstartpos = _startpos_x_ in let _sloc = (_symbolstartpos, _endpos) in -# 2380 "src/ocaml/preprocess/parser_raw.mly" +# 2498 "src/ocaml/preprocess/parser_raw.mly" ( let lab, pat = x in lab, mkpat ~loc:_sloc (Ppat_constraint (pat, cty)) ) -# 15429 "src/ocaml/preprocess/parser_raw.ml" +# 15706 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15448,9 +15725,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3815 "src/ocaml/preprocess/parser_raw.mly" +# 4022 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15454 "src/ocaml/preprocess/parser_raw.ml" +# 15731 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15473,9 +15750,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.arg_label * Parsetree.expression) = -# 2672 "src/ocaml/preprocess/parser_raw.mly" +# 2792 "src/ocaml/preprocess/parser_raw.mly" ( (Nolabel, _1) ) -# 15479 "src/ocaml/preprocess/parser_raw.ml" +# 15756 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15501,17 +15778,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 786 "src/ocaml/preprocess/parser_raw.mly" +# 852 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15507 "src/ocaml/preprocess/parser_raw.ml" +# 15784 "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) = -# 2674 "src/ocaml/preprocess/parser_raw.mly" +# 2794 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled _1, _2) ) -# 15515 "src/ocaml/preprocess/parser_raw.ml" +# 15792 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15536,9 +15813,9 @@ module Tables = struct }; } = _menhir_stack in let label : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15542 "src/ocaml/preprocess/parser_raw.ml" +# 15819 "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 @@ -15546,10 +15823,10 @@ module Tables = struct let _endpos = _endpos_label_ in let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2676 "src/ocaml/preprocess/parser_raw.mly" +# 2796 "src/ocaml/preprocess/parser_raw.mly" ( let loc = _loc_label_ in (Labelled label, mkexpvar ~loc label) ) -# 15553 "src/ocaml/preprocess/parser_raw.ml" +# 15830 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15592,11 +15869,11 @@ module Tables = struct }; } = _menhir_stack in let _5 : unit = Obj.magic _5 in - let ty : (Parsetree.core_type option * Parsetree.core_type option) = Obj.magic ty in + let ty : (Parsetree.type_constraint) = Obj.magic ty in let label : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15600 "src/ocaml/preprocess/parser_raw.ml" +# 15877 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _2 : unit = Obj.magic _2 in let _1 : unit = Obj.magic _1 in @@ -15606,10 +15883,10 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression) = let _endpos = _endpos__5_ in let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2679 "src/ocaml/preprocess/parser_raw.mly" +# 2799 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled label, mkexp_constraint ~loc:(_startpos__2_, _endpos) (mkexpvar ~loc:_loc_label_ label) ty) ) -# 15613 "src/ocaml/preprocess/parser_raw.ml" +# 15890 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15634,9 +15911,9 @@ module Tables = struct }; } = _menhir_stack in let label : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15640 "src/ocaml/preprocess/parser_raw.ml" +# 15917 "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 @@ -15644,10 +15921,10 @@ module Tables = struct let _endpos = _endpos_label_ in let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2682 "src/ocaml/preprocess/parser_raw.mly" +# 2802 "src/ocaml/preprocess/parser_raw.mly" ( let loc = _loc_label_ in (Optional label, mkexpvar ~loc label) ) -# 15651 "src/ocaml/preprocess/parser_raw.ml" +# 15928 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15673,17 +15950,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 816 "src/ocaml/preprocess/parser_raw.mly" +# 882 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15679 "src/ocaml/preprocess/parser_raw.ml" +# 15956 "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) = -# 2685 "src/ocaml/preprocess/parser_raw.mly" +# 2805 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, _2) ) -# 15687 "src/ocaml/preprocess/parser_raw.ml" +# 15964 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15736,15 +16013,15 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 = let _1 = _1_inlined1 in -# 2374 "src/ocaml/preprocess/parser_raw.mly" +# 2492 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15742 "src/ocaml/preprocess/parser_raw.ml" +# 16019 "src/ocaml/preprocess/parser_raw.ml" in -# 2348 "src/ocaml/preprocess/parser_raw.mly" +# 2466 "src/ocaml/preprocess/parser_raw.mly" ( (Optional (fst _3), _4, snd _3) ) -# 15748 "src/ocaml/preprocess/parser_raw.ml" +# 16025 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15769,9 +16046,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15775 "src/ocaml/preprocess/parser_raw.ml" +# 16052 "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 @@ -15784,24 +16061,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15790 "src/ocaml/preprocess/parser_raw.ml" +# 16067 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2386 "src/ocaml/preprocess/parser_raw.mly" +# 2504 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15799 "src/ocaml/preprocess/parser_raw.ml" +# 16076 "src/ocaml/preprocess/parser_raw.ml" in -# 2350 "src/ocaml/preprocess/parser_raw.mly" +# 2468 "src/ocaml/preprocess/parser_raw.mly" ( (Optional (fst _2), None, snd _2) ) -# 15805 "src/ocaml/preprocess/parser_raw.ml" +# 16082 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15848,9 +16125,9 @@ module Tables = struct let _3 : (Parsetree.pattern) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 816 "src/ocaml/preprocess/parser_raw.mly" +# 882 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15854 "src/ocaml/preprocess/parser_raw.ml" +# 16131 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15858,15 +16135,15 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 = let _1 = _1_inlined1 in -# 2374 "src/ocaml/preprocess/parser_raw.mly" +# 2492 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15864 "src/ocaml/preprocess/parser_raw.ml" +# 16141 "src/ocaml/preprocess/parser_raw.ml" in -# 2352 "src/ocaml/preprocess/parser_raw.mly" +# 2470 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, _4, _3) ) -# 15870 "src/ocaml/preprocess/parser_raw.ml" +# 16147 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15892,17 +16169,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.pattern) = Obj.magic _2 in let _1 : ( -# 816 "src/ocaml/preprocess/parser_raw.mly" +# 882 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15898 "src/ocaml/preprocess/parser_raw.ml" +# 16175 "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) = -# 2354 "src/ocaml/preprocess/parser_raw.mly" +# 2472 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, None, _2) ) -# 15906 "src/ocaml/preprocess/parser_raw.ml" +# 16183 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15946,9 +16223,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2356 "src/ocaml/preprocess/parser_raw.mly" +# 2474 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled (fst _3), None, snd _3) ) -# 15952 "src/ocaml/preprocess/parser_raw.ml" +# 16229 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15973,9 +16250,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15979 "src/ocaml/preprocess/parser_raw.ml" +# 16256 "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 @@ -15988,24 +16265,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15994 "src/ocaml/preprocess/parser_raw.ml" +# 16271 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2386 "src/ocaml/preprocess/parser_raw.mly" +# 2504 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 16003 "src/ocaml/preprocess/parser_raw.ml" +# 16280 "src/ocaml/preprocess/parser_raw.ml" in -# 2358 "src/ocaml/preprocess/parser_raw.mly" +# 2476 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled (fst _2), None, snd _2) ) -# 16009 "src/ocaml/preprocess/parser_raw.ml" +# 16286 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16031,17 +16308,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.pattern) = Obj.magic _2 in let _1 : ( -# 786 "src/ocaml/preprocess/parser_raw.mly" +# 852 "src/ocaml/preprocess/parser_raw.mly" (string) -# 16037 "src/ocaml/preprocess/parser_raw.ml" +# 16314 "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) = -# 2360 "src/ocaml/preprocess/parser_raw.mly" +# 2478 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled _1, None, _2) ) -# 16045 "src/ocaml/preprocess/parser_raw.ml" +# 16322 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16064,9 +16341,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2362 "src/ocaml/preprocess/parser_raw.mly" +# 2480 "src/ocaml/preprocess/parser_raw.mly" ( (Nolabel, None, _1) ) -# 16070 "src/ocaml/preprocess/parser_raw.ml" +# 16347 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16091,9 +16368,9 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option * bool) = -# 2725 "src/ocaml/preprocess/parser_raw.mly" +# 2844 "src/ocaml/preprocess/parser_raw.mly" ( let p,e,c = _1 in (p,e,c,false) ) -# 16097 "src/ocaml/preprocess/parser_raw.ml" +# 16374 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16120,9 +16397,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2728 "src/ocaml/preprocess/parser_raw.mly" +# 2847 "src/ocaml/preprocess/parser_raw.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1, None, true) ) -# 16126 "src/ocaml/preprocess/parser_raw.ml" +# 16403 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16157,15 +16434,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2692 "src/ocaml/preprocess/parser_raw.mly" +# 2812 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16163 "src/ocaml/preprocess/parser_raw.ml" +# 16440 "src/ocaml/preprocess/parser_raw.ml" in -# 2696 "src/ocaml/preprocess/parser_raw.mly" +# 2816 "src/ocaml/preprocess/parser_raw.mly" ( (_1, _2, None) ) -# 16169 "src/ocaml/preprocess/parser_raw.ml" +# 16446 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16203,7 +16480,7 @@ module Tables = struct } = _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 _2 : (Parsetree.type_constraint) = 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 @@ -16214,24 +16491,23 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2692 "src/ocaml/preprocess/parser_raw.mly" +# 2812 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16220 "src/ocaml/preprocess/parser_raw.ml" +# 16497 "src/ocaml/preprocess/parser_raw.ml" in -# 2698 "src/ocaml/preprocess/parser_raw.mly" +# 2818 "src/ocaml/preprocess/parser_raw.mly" ( let v = _1 in (* PR#7344 *) let t = match _2 with - Some t, None -> + Pconstraint t -> Pvc_constraint { locally_abstract_univars = []; typ=t } - | ground, Some coercion -> Pvc_coercion { ground; coercion} - | _ -> assert false + | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion} in (v, _4, Some t) ) -# 16235 "src/ocaml/preprocess/parser_raw.ml" +# 16511 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16303,24 +16579,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 16307 "src/ocaml/preprocess/parser_raw.ml" +# 16583 "src/ocaml/preprocess/parser_raw.ml" in -# 1098 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 16312 "src/ocaml/preprocess/parser_raw.ml" +# 16588 "src/ocaml/preprocess/parser_raw.ml" in -# 3466 "src/ocaml/preprocess/parser_raw.mly" +# 3617 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16318 "src/ocaml/preprocess/parser_raw.ml" +# 16594 "src/ocaml/preprocess/parser_raw.ml" in -# 3470 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 16324 "src/ocaml/preprocess/parser_raw.ml" +# 16600 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__3_ = _startpos_xs_ in @@ -16329,19 +16605,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2692 "src/ocaml/preprocess/parser_raw.mly" +# 2812 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16335 "src/ocaml/preprocess/parser_raw.ml" +# 16611 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2709 "src/ocaml/preprocess/parser_raw.mly" +# 2828 "src/ocaml/preprocess/parser_raw.mly" ( let t = ghtyp ~loc:(_loc__3_) _3 in (_1, _5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) ) -# 16345 "src/ocaml/preprocess/parser_raw.ml" +# 16621 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16414,27 +16690,27 @@ module Tables = struct let _endpos = _endpos__8_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = let _4 = -# 2689 "src/ocaml/preprocess/parser_raw.mly" +# 2809 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 16420 "src/ocaml/preprocess/parser_raw.ml" +# 16696 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2692 "src/ocaml/preprocess/parser_raw.mly" +# 2812 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16429 "src/ocaml/preprocess/parser_raw.ml" +# 16705 "src/ocaml/preprocess/parser_raw.ml" in -# 2714 "src/ocaml/preprocess/parser_raw.mly" +# 2833 "src/ocaml/preprocess/parser_raw.mly" ( let constraint' = Pvc_constraint { locally_abstract_univars=_4; typ = _6} in (_1, _8, Some constraint') ) -# 16438 "src/ocaml/preprocess/parser_raw.ml" +# 16714 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16472,9 +16748,9 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = -# 2719 "src/ocaml/preprocess/parser_raw.mly" +# 2838 "src/ocaml/preprocess/parser_raw.mly" ( (_1, _3, None) ) -# 16478 "src/ocaml/preprocess/parser_raw.ml" +# 16754 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16526,9 +16802,9 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = -# 2721 "src/ocaml/preprocess/parser_raw.mly" +# 2840 "src/ocaml/preprocess/parser_raw.mly" ( (_1, _5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=_3 })) ) -# 16532 "src/ocaml/preprocess/parser_raw.ml" +# 16808 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16590,36 +16866,36 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16596 "src/ocaml/preprocess/parser_raw.ml" +# 16872 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16605 "src/ocaml/preprocess/parser_raw.ml" +# 16881 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2748 "src/ocaml/preprocess/parser_raw.mly" +# 2867 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 16617 "src/ocaml/preprocess/parser_raw.ml" +# 16893 "src/ocaml/preprocess/parser_raw.ml" in -# 2738 "src/ocaml/preprocess/parser_raw.mly" +# 2857 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16623 "src/ocaml/preprocess/parser_raw.ml" +# 16899 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16649,9 +16925,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 2739 "src/ocaml/preprocess/parser_raw.mly" +# 2858 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 16655 "src/ocaml/preprocess/parser_raw.ml" +# 16931 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16706,41 +16982,41 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16712 "src/ocaml/preprocess/parser_raw.ml" +# 16988 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16721 "src/ocaml/preprocess/parser_raw.ml" +# 16997 "src/ocaml/preprocess/parser_raw.ml" in let ext = -# 4062 "src/ocaml/preprocess/parser_raw.mly" +# 4269 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 16727 "src/ocaml/preprocess/parser_raw.ml" +# 17003 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2748 "src/ocaml/preprocess/parser_raw.mly" +# 2867 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 16738 "src/ocaml/preprocess/parser_raw.ml" +# 17014 "src/ocaml/preprocess/parser_raw.ml" in -# 2738 "src/ocaml/preprocess/parser_raw.mly" +# 2857 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16744 "src/ocaml/preprocess/parser_raw.ml" +# 17020 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16809,18 +17085,18 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16815 "src/ocaml/preprocess/parser_raw.ml" +# 17091 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let attrs1 = let _1 = _1_inlined2 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16824 "src/ocaml/preprocess/parser_raw.ml" +# 17100 "src/ocaml/preprocess/parser_raw.ml" in let ext = @@ -16829,27 +17105,27 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4064 "src/ocaml/preprocess/parser_raw.mly" +# 4271 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "extension"; None ) -# 16835 "src/ocaml/preprocess/parser_raw.ml" +# 17111 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2748 "src/ocaml/preprocess/parser_raw.mly" +# 2867 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 16847 "src/ocaml/preprocess/parser_raw.ml" +# 17123 "src/ocaml/preprocess/parser_raw.ml" in -# 2738 "src/ocaml/preprocess/parser_raw.mly" +# 2857 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16853 "src/ocaml/preprocess/parser_raw.ml" +# 17129 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16879,9 +17155,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 2739 "src/ocaml/preprocess/parser_raw.mly" +# 2858 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 16885 "src/ocaml/preprocess/parser_raw.ml" +# 17161 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16904,9 +17180,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2390 "src/ocaml/preprocess/parser_raw.mly" +# 2508 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16910 "src/ocaml/preprocess/parser_raw.ml" +# 17186 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16944,24 +17220,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2392 "src/ocaml/preprocess/parser_raw.mly" +# 2510 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_1, _3) ) -# 16950 "src/ocaml/preprocess/parser_raw.ml" +# 17226 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 16959 "src/ocaml/preprocess/parser_raw.ml" +# 17235 "src/ocaml/preprocess/parser_raw.ml" in -# 2393 "src/ocaml/preprocess/parser_raw.mly" +# 2511 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16965 "src/ocaml/preprocess/parser_raw.ml" +# 17241 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16995,15 +17271,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2692 "src/ocaml/preprocess/parser_raw.mly" +# 2812 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 17001 "src/ocaml/preprocess/parser_raw.ml" +# 17277 "src/ocaml/preprocess/parser_raw.ml" in -# 2765 "src/ocaml/preprocess/parser_raw.mly" +# 2884 "src/ocaml/preprocess/parser_raw.mly" ( (pat, exp) ) -# 17007 "src/ocaml/preprocess/parser_raw.ml" +# 17283 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17029,9 +17305,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2768 "src/ocaml/preprocess/parser_raw.mly" +# 2887 "src/ocaml/preprocess/parser_raw.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1) ) -# 17035 "src/ocaml/preprocess/parser_raw.ml" +# 17311 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17082,10 +17358,10 @@ module Tables = struct let _startpos = _startpos_pat_ in let _endpos = _endpos_exp_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2770 "src/ocaml/preprocess/parser_raw.mly" +# 2889 "src/ocaml/preprocess/parser_raw.mly" ( let loc = (_startpos_pat_, _endpos_typ_) in (ghpat ~loc (Ppat_constraint(pat, typ)), exp) ) -# 17089 "src/ocaml/preprocess/parser_raw.ml" +# 17365 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17122,9 +17398,9 @@ module Tables = struct let _startpos = _startpos_pat_ in let _endpos = _endpos_exp_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2773 "src/ocaml/preprocess/parser_raw.mly" +# 2892 "src/ocaml/preprocess/parser_raw.mly" ( (pat, exp) ) -# 17128 "src/ocaml/preprocess/parser_raw.ml" +# 17404 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17147,10 +17423,10 @@ module Tables = struct let _startpos = _startpos_body_ in let _endpos = _endpos_body_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = -# 2777 "src/ocaml/preprocess/parser_raw.mly" +# 2896 "src/ocaml/preprocess/parser_raw.mly" ( let let_pat, let_exp = body in let_pat, let_exp, [] ) -# 17154 "src/ocaml/preprocess/parser_raw.ml" +# 17430 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17182,9 +17458,9 @@ module Tables = struct } = _menhir_stack in let body : (Parsetree.pattern * Parsetree.expression) = Obj.magic body in let _1 : ( -# 782 "src/ocaml/preprocess/parser_raw.mly" +# 848 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17188 "src/ocaml/preprocess/parser_raw.ml" +# 17464 "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 @@ -17195,22 +17471,22 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17201 "src/ocaml/preprocess/parser_raw.ml" +# 17477 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_body_ in let _symbolstartpos = _startpos_bindings_ in let _sloc = (_symbolstartpos, _endpos) in -# 2780 "src/ocaml/preprocess/parser_raw.mly" +# 2899 "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 ) -# 17214 "src/ocaml/preprocess/parser_raw.ml" +# 17490 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17228,7 +17504,7 @@ module Tables = struct let _v : (Parsetree.class_expr Parsetree.class_infos list) = # 211 "" ( [] ) -# 17232 "src/ocaml/preprocess/parser_raw.ml" +# 17508 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17292,9 +17568,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17298 "src/ocaml/preprocess/parser_raw.ml" +# 17574 "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 @@ -17307,9 +17583,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17313 "src/ocaml/preprocess/parser_raw.ml" +# 17589 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17319,24 +17595,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17325 "src/ocaml/preprocess/parser_raw.ml" +# 17601 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17333 "src/ocaml/preprocess/parser_raw.ml" +# 17609 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1986 "src/ocaml/preprocess/parser_raw.mly" +# 2073 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17344,13 +17620,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs ) -# 17348 "src/ocaml/preprocess/parser_raw.ml" +# 17624 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17354 "src/ocaml/preprocess/parser_raw.ml" +# 17630 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17368,7 +17644,7 @@ module Tables = struct let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 17372 "src/ocaml/preprocess/parser_raw.ml" +# 17648 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17439,9 +17715,9 @@ module Tables = struct let cty : (Parsetree.class_type) = Obj.magic cty in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17445 "src/ocaml/preprocess/parser_raw.ml" +# 17721 "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 @@ -17454,9 +17730,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17460 "src/ocaml/preprocess/parser_raw.ml" +# 17736 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17466,24 +17742,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17472 "src/ocaml/preprocess/parser_raw.ml" +# 17748 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17480 "src/ocaml/preprocess/parser_raw.ml" +# 17756 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2285 "src/ocaml/preprocess/parser_raw.mly" +# 2372 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17491,13 +17767,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs ) -# 17495 "src/ocaml/preprocess/parser_raw.ml" +# 17771 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17501 "src/ocaml/preprocess/parser_raw.ml" +# 17777 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17515,7 +17791,7 @@ module Tables = struct let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 17519 "src/ocaml/preprocess/parser_raw.ml" +# 17795 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17586,9 +17862,9 @@ module Tables = struct let csig : (Parsetree.class_type) = Obj.magic csig in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17592 "src/ocaml/preprocess/parser_raw.ml" +# 17868 "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 @@ -17601,9 +17877,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17607 "src/ocaml/preprocess/parser_raw.ml" +# 17883 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17613,24 +17889,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17619 "src/ocaml/preprocess/parser_raw.ml" +# 17895 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17627 "src/ocaml/preprocess/parser_raw.ml" +# 17903 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2324 "src/ocaml/preprocess/parser_raw.mly" +# 2411 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17638,13 +17914,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs ) -# 17642 "src/ocaml/preprocess/parser_raw.ml" +# 17918 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17648 "src/ocaml/preprocess/parser_raw.ml" +# 17924 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17662,7 +17938,7 @@ module Tables = struct let _v : (Parsetree.module_binding list) = # 211 "" ( [] ) -# 17666 "src/ocaml/preprocess/parser_raw.ml" +# 17942 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17723,9 +17999,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17729 "src/ocaml/preprocess/parser_raw.ml" +# 18005 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17735,24 +18011,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17741 "src/ocaml/preprocess/parser_raw.ml" +# 18017 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17749 "src/ocaml/preprocess/parser_raw.ml" +# 18025 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1632 "src/ocaml/preprocess/parser_raw.mly" +# 1719 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in @@ -17760,13 +18036,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Mb.mk name body ~attrs ~loc ~text ~docs ) -# 17764 "src/ocaml/preprocess/parser_raw.ml" +# 18040 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17770 "src/ocaml/preprocess/parser_raw.ml" +# 18046 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17784,7 +18060,7 @@ module Tables = struct let _v : (Parsetree.module_declaration list) = # 211 "" ( [] ) -# 17788 "src/ocaml/preprocess/parser_raw.ml" +# 18064 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17852,9 +18128,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17858 "src/ocaml/preprocess/parser_raw.ml" +# 18134 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17864,24 +18140,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17870 "src/ocaml/preprocess/parser_raw.ml" +# 18146 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17878 "src/ocaml/preprocess/parser_raw.ml" +# 18154 "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" +# 2014 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let docs = symbol_docs _sloc in @@ -17889,13 +18165,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Md.mk name mty ~attrs ~loc ~text ~docs ) -# 17893 "src/ocaml/preprocess/parser_raw.ml" +# 18169 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17899 "src/ocaml/preprocess/parser_raw.ml" +# 18175 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17913,7 +18189,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 17917 "src/ocaml/preprocess/parser_raw.ml" +# 18193 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17945,7 +18221,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 17949 "src/ocaml/preprocess/parser_raw.ml" +# 18225 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17963,7 +18239,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 17967 "src/ocaml/preprocess/parser_raw.ml" +# 18243 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18028,9 +18304,9 @@ module Tables = struct 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 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 18034 "src/ocaml/preprocess/parser_raw.ml" +# 18310 "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 @@ -18043,9 +18319,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18049 "src/ocaml/preprocess/parser_raw.ml" +# 18325 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18054,18 +18330,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18058 "src/ocaml/preprocess/parser_raw.ml" +# 18334 "src/ocaml/preprocess/parser_raw.ml" in -# 1080 "src/ocaml/preprocess/parser_raw.mly" +# 1146 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 18063 "src/ocaml/preprocess/parser_raw.ml" +# 18339 "src/ocaml/preprocess/parser_raw.ml" in -# 3181 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18069 "src/ocaml/preprocess/parser_raw.ml" +# 18345 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -18074,24 +18350,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18080 "src/ocaml/preprocess/parser_raw.ml" +# 18356 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18088 "src/ocaml/preprocess/parser_raw.ml" +# 18364 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3170 "src/ocaml/preprocess/parser_raw.mly" +# 3321 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -18100,13 +18376,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18104 "src/ocaml/preprocess/parser_raw.ml" +# 18380 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18110 "src/ocaml/preprocess/parser_raw.ml" +# 18386 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18124,7 +18400,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 18128 "src/ocaml/preprocess/parser_raw.ml" +# 18404 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18196,9 +18472,9 @@ module Tables = struct 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 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 18202 "src/ocaml/preprocess/parser_raw.ml" +# 18478 "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 @@ -18211,9 +18487,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18217 "src/ocaml/preprocess/parser_raw.ml" +# 18493 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -18222,26 +18498,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18226 "src/ocaml/preprocess/parser_raw.ml" +# 18502 "src/ocaml/preprocess/parser_raw.ml" in -# 1080 "src/ocaml/preprocess/parser_raw.mly" +# 1146 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 18231 "src/ocaml/preprocess/parser_raw.ml" +# 18507 "src/ocaml/preprocess/parser_raw.ml" in -# 3181 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18237 "src/ocaml/preprocess/parser_raw.ml" +# 18513 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined3 in -# 3216 "src/ocaml/preprocess/parser_raw.mly" +# 3367 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 18245 "src/ocaml/preprocess/parser_raw.ml" +# 18521 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -18250,24 +18526,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18256 "src/ocaml/preprocess/parser_raw.ml" +# 18532 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18264 "src/ocaml/preprocess/parser_raw.ml" +# 18540 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3170 "src/ocaml/preprocess/parser_raw.mly" +# 3321 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -18276,13 +18552,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18280 "src/ocaml/preprocess/parser_raw.ml" +# 18556 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18286 "src/ocaml/preprocess/parser_raw.ml" +# 18562 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18300,7 +18576,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 18304 "src/ocaml/preprocess/parser_raw.ml" +# 18580 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18332,7 +18608,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 18336 "src/ocaml/preprocess/parser_raw.ml" +# 18612 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18350,7 +18626,7 @@ module Tables = struct let _v : (Parsetree.signature_item list list) = # 211 "" ( [] ) -# 18354 "src/ocaml/preprocess/parser_raw.ml" +# 18630 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18383,21 +18659,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1006 "src/ocaml/preprocess/parser_raw.mly" +# 1072 "src/ocaml/preprocess/parser_raw.mly" ( text_sig _startpos ) -# 18389 "src/ocaml/preprocess/parser_raw.ml" +# 18665 "src/ocaml/preprocess/parser_raw.ml" in -# 1780 "src/ocaml/preprocess/parser_raw.mly" +# 1867 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18395 "src/ocaml/preprocess/parser_raw.ml" +# 18671 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18401 "src/ocaml/preprocess/parser_raw.ml" +# 18677 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18430,21 +18706,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1004 "src/ocaml/preprocess/parser_raw.mly" +# 1070 "src/ocaml/preprocess/parser_raw.mly" ( text_sig _startpos @ [_1] ) -# 18436 "src/ocaml/preprocess/parser_raw.ml" +# 18712 "src/ocaml/preprocess/parser_raw.ml" in -# 1780 "src/ocaml/preprocess/parser_raw.mly" +# 1867 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18442 "src/ocaml/preprocess/parser_raw.ml" +# 18718 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18448 "src/ocaml/preprocess/parser_raw.ml" +# 18724 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18462,7 +18738,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 18466 "src/ocaml/preprocess/parser_raw.ml" +# 18742 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18495,40 +18771,40 @@ module Tables = struct let _1 = let ys = let items = -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1132 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 18501 "src/ocaml/preprocess/parser_raw.ml" +# 18777 "src/ocaml/preprocess/parser_raw.ml" in -# 1511 "src/ocaml/preprocess/parser_raw.mly" +# 1598 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 18506 "src/ocaml/preprocess/parser_raw.ml" +# 18782 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _startpos = _startpos__1_ in -# 1002 "src/ocaml/preprocess/parser_raw.mly" +# 1068 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos ) -# 18514 "src/ocaml/preprocess/parser_raw.ml" +# 18790 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 18520 "src/ocaml/preprocess/parser_raw.ml" +# 18796 "src/ocaml/preprocess/parser_raw.ml" in -# 1527 "src/ocaml/preprocess/parser_raw.mly" +# 1614 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18526 "src/ocaml/preprocess/parser_raw.ml" +# 18802 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18532 "src/ocaml/preprocess/parser_raw.ml" +# 18808 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18580,70 +18856,70 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18586 "src/ocaml/preprocess/parser_raw.ml" +# 18862 "src/ocaml/preprocess/parser_raw.ml" in -# 1518 "src/ocaml/preprocess/parser_raw.mly" +# 1605 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 18591 "src/ocaml/preprocess/parser_raw.ml" +# 18867 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1000 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18599 "src/ocaml/preprocess/parser_raw.ml" +# 18875 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1019 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 18609 "src/ocaml/preprocess/parser_raw.ml" +# 18885 "src/ocaml/preprocess/parser_raw.ml" in -# 1068 "src/ocaml/preprocess/parser_raw.mly" +# 1134 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 18615 "src/ocaml/preprocess/parser_raw.ml" +# 18891 "src/ocaml/preprocess/parser_raw.ml" in -# 1511 "src/ocaml/preprocess/parser_raw.mly" +# 1598 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 18621 "src/ocaml/preprocess/parser_raw.ml" +# 18897 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _startpos = _startpos__1_ in -# 1002 "src/ocaml/preprocess/parser_raw.mly" +# 1068 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos ) -# 18629 "src/ocaml/preprocess/parser_raw.ml" +# 18905 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 18635 "src/ocaml/preprocess/parser_raw.ml" +# 18911 "src/ocaml/preprocess/parser_raw.ml" in -# 1527 "src/ocaml/preprocess/parser_raw.mly" +# 1614 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18641 "src/ocaml/preprocess/parser_raw.ml" +# 18917 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18647 "src/ocaml/preprocess/parser_raw.ml" +# 18923 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18676,21 +18952,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1000 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18682 "src/ocaml/preprocess/parser_raw.ml" +# 18958 "src/ocaml/preprocess/parser_raw.ml" in -# 1527 "src/ocaml/preprocess/parser_raw.mly" +# 1614 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18688 "src/ocaml/preprocess/parser_raw.ml" +# 18964 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18694 "src/ocaml/preprocess/parser_raw.ml" +# 18970 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18708,7 +18984,7 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = # 211 "" ( [] ) -# 18712 "src/ocaml/preprocess/parser_raw.ml" +# 18988 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18740,15 +19016,15 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = let x = let _startpos = _startpos__1_ in -# 1014 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( text_csig _startpos @ [_1] ) -# 18746 "src/ocaml/preprocess/parser_raw.ml" +# 19022 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18752 "src/ocaml/preprocess/parser_raw.ml" +# 19028 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18766,7 +19042,7 @@ module Tables = struct let _v : (Parsetree.class_field list list) = # 211 "" ( [] ) -# 18770 "src/ocaml/preprocess/parser_raw.ml" +# 19046 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18798,15 +19074,15 @@ module Tables = struct let _v : (Parsetree.class_field list list) = let x = let _startpos = _startpos__1_ in -# 1012 "src/ocaml/preprocess/parser_raw.mly" +# 1078 "src/ocaml/preprocess/parser_raw.mly" ( text_cstr _startpos @ [_1] ) -# 18804 "src/ocaml/preprocess/parser_raw.ml" +# 19080 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18810 "src/ocaml/preprocess/parser_raw.ml" +# 19086 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18824,7 +19100,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 18828 "src/ocaml/preprocess/parser_raw.ml" +# 19104 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18856,15 +19132,15 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = let x = let _startpos = _startpos__1_ in -# 1000 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18862 "src/ocaml/preprocess/parser_raw.ml" +# 19138 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18868 "src/ocaml/preprocess/parser_raw.ml" +# 19144 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18882,7 +19158,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = # 211 "" ( [] ) -# 18886 "src/ocaml/preprocess/parser_raw.ml" +# 19162 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18915,32 +19191,32 @@ module Tables = struct let _1 = let x = let _1 = -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1132 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 18921 "src/ocaml/preprocess/parser_raw.ml" +# 19197 "src/ocaml/preprocess/parser_raw.ml" in -# 1298 "src/ocaml/preprocess/parser_raw.mly" +# 1385 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18926 "src/ocaml/preprocess/parser_raw.ml" +# 19202 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 18932 "src/ocaml/preprocess/parser_raw.ml" +# 19208 "src/ocaml/preprocess/parser_raw.ml" in -# 1310 "src/ocaml/preprocess/parser_raw.mly" +# 1397 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18938 "src/ocaml/preprocess/parser_raw.ml" +# 19214 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18944 "src/ocaml/preprocess/parser_raw.ml" +# 19220 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18992,58 +19268,58 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18998 "src/ocaml/preprocess/parser_raw.ml" +# 19274 "src/ocaml/preprocess/parser_raw.ml" in -# 1518 "src/ocaml/preprocess/parser_raw.mly" +# 1605 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 19003 "src/ocaml/preprocess/parser_raw.ml" +# 19279 "src/ocaml/preprocess/parser_raw.ml" in -# 1010 "src/ocaml/preprocess/parser_raw.mly" +# 1076 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 19009 "src/ocaml/preprocess/parser_raw.ml" +# 19285 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1008 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19017 "src/ocaml/preprocess/parser_raw.ml" +# 19293 "src/ocaml/preprocess/parser_raw.ml" in -# 1068 "src/ocaml/preprocess/parser_raw.mly" +# 1134 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 19023 "src/ocaml/preprocess/parser_raw.ml" +# 19299 "src/ocaml/preprocess/parser_raw.ml" in -# 1298 "src/ocaml/preprocess/parser_raw.mly" +# 1385 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19029 "src/ocaml/preprocess/parser_raw.ml" +# 19305 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 19035 "src/ocaml/preprocess/parser_raw.ml" +# 19311 "src/ocaml/preprocess/parser_raw.ml" in -# 1310 "src/ocaml/preprocess/parser_raw.mly" +# 1397 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19041 "src/ocaml/preprocess/parser_raw.ml" +# 19317 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19047 "src/ocaml/preprocess/parser_raw.ml" +# 19323 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19075,27 +19351,27 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = let x = let _1 = let _1 = -# 1010 "src/ocaml/preprocess/parser_raw.mly" +# 1076 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 19081 "src/ocaml/preprocess/parser_raw.ml" +# 19357 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1008 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19087 "src/ocaml/preprocess/parser_raw.ml" +# 19363 "src/ocaml/preprocess/parser_raw.ml" in -# 1310 "src/ocaml/preprocess/parser_raw.mly" +# 1397 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19093 "src/ocaml/preprocess/parser_raw.ml" +# 19369 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19099 "src/ocaml/preprocess/parser_raw.ml" +# 19375 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19130,29 +19406,29 @@ module Tables = struct let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1019 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 19137 "src/ocaml/preprocess/parser_raw.ml" +# 19413 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1008 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19144 "src/ocaml/preprocess/parser_raw.ml" +# 19420 "src/ocaml/preprocess/parser_raw.ml" in -# 1310 "src/ocaml/preprocess/parser_raw.mly" +# 1397 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19150 "src/ocaml/preprocess/parser_raw.ml" +# 19426 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19156 "src/ocaml/preprocess/parser_raw.ml" +# 19432 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19191,7 +19467,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 124 "" ( None ) -# 19195 "src/ocaml/preprocess/parser_raw.ml" +# 19471 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -19199,9 +19475,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19205 "src/ocaml/preprocess/parser_raw.ml" +# 19481 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19209,7 +19485,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3056 "src/ocaml/preprocess/parser_raw.mly" +# 3207 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19223,13 +19499,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19227 "src/ocaml/preprocess/parser_raw.ml" +# 19503 "src/ocaml/preprocess/parser_raw.ml" in -# 1235 "src/ocaml/preprocess/parser_raw.mly" +# 1322 "src/ocaml/preprocess/parser_raw.mly" ( [x], None ) -# 19233 "src/ocaml/preprocess/parser_raw.ml" +# 19509 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19275,7 +19551,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 126 "" ( Some x ) -# 19279 "src/ocaml/preprocess/parser_raw.ml" +# 19555 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -19283,9 +19559,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19289 "src/ocaml/preprocess/parser_raw.ml" +# 19565 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19293,7 +19569,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3056 "src/ocaml/preprocess/parser_raw.mly" +# 3207 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19307,13 +19583,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19311 "src/ocaml/preprocess/parser_raw.ml" +# 19587 "src/ocaml/preprocess/parser_raw.ml" in -# 1235 "src/ocaml/preprocess/parser_raw.mly" +# 1322 "src/ocaml/preprocess/parser_raw.mly" ( [x], None ) -# 19317 "src/ocaml/preprocess/parser_raw.ml" +# 19593 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19376,9 +19652,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19382 "src/ocaml/preprocess/parser_raw.ml" +# 19658 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19386,7 +19662,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3056 "src/ocaml/preprocess/parser_raw.mly" +# 3207 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19400,13 +19676,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19404 "src/ocaml/preprocess/parser_raw.ml" +# 19680 "src/ocaml/preprocess/parser_raw.ml" in -# 1237 "src/ocaml/preprocess/parser_raw.mly" +# 1324 "src/ocaml/preprocess/parser_raw.mly" ( [x], Some y ) -# 19410 "src/ocaml/preprocess/parser_raw.ml" +# 19686 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19462,9 +19738,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19468 "src/ocaml/preprocess/parser_raw.ml" +# 19744 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19472,7 +19748,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3056 "src/ocaml/preprocess/parser_raw.mly" +# 3207 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19486,14 +19762,14 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19490 "src/ocaml/preprocess/parser_raw.ml" +# 19766 "src/ocaml/preprocess/parser_raw.ml" in -# 1241 "src/ocaml/preprocess/parser_raw.mly" +# 1328 "src/ocaml/preprocess/parser_raw.mly" ( let xs, y = tail in x :: xs, y ) -# 19497 "src/ocaml/preprocess/parser_raw.ml" +# 19773 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19554,9 +19830,9 @@ module Tables = struct let _v : (Ast_helper.let_bindings) = let _5 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19560 "src/ocaml/preprocess/parser_raw.ml" +# 19836 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -19564,23 +19840,23 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19570 "src/ocaml/preprocess/parser_raw.ml" +# 19846 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 19576 "src/ocaml/preprocess/parser_raw.ml" +# 19852 "src/ocaml/preprocess/parser_raw.ml" in let _loc__4_ = (_startpos__4_, _endpos__4_) in -# 4102 "src/ocaml/preprocess/parser_raw.mly" +# 4315 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, attr) = _2 in mklbs ext _3 (mklb ~loc:_loc__4_ true _4 (attr@_5)) ) -# 19584 "src/ocaml/preprocess/parser_raw.ml" +# 19860 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19603,9 +19879,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Ast_helper.let_bindings) = -# 4106 "src/ocaml/preprocess/parser_raw.mly" +# 4319 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19609 "src/ocaml/preprocess/parser_raw.ml" +# 19885 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19635,9 +19911,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 4107 "src/ocaml/preprocess/parser_raw.mly" +# 4320 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 19641 "src/ocaml/preprocess/parser_raw.ml" +# 19917 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19674,9 +19950,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.case) = -# 2806 "src/ocaml/preprocess/parser_raw.mly" +# 2932 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 (merloc _endpos__2_ _3) ) -# 19680 "src/ocaml/preprocess/parser_raw.ml" +# 19956 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19727,9 +20003,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.case) = -# 2808 "src/ocaml/preprocess/parser_raw.mly" +# 2934 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 ~guard:(merloc _endpos__2_ _3) (merloc _endpos__4_ _5) ) -# 19733 "src/ocaml/preprocess/parser_raw.ml" +# 20009 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19767,10 +20043,10 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.case) = let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2810 "src/ocaml/preprocess/parser_raw.mly" +# 2936 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 (merloc _endpos__2_ (Exp.unreachable ~loc:(make_loc _loc__3_) ())) ) -# 19774 "src/ocaml/preprocess/parser_raw.ml" +# 20050 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19831,9 +20107,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 19837 "src/ocaml/preprocess/parser_raw.ml" +# 20113 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -19842,49 +20118,49 @@ module Tables = struct let _6 = let _1 = _1_inlined3 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19848 "src/ocaml/preprocess/parser_raw.ml" +# 20124 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19857 "src/ocaml/preprocess/parser_raw.ml" +# 20133 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3484 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19866 "src/ocaml/preprocess/parser_raw.ml" +# 20142 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19873 "src/ocaml/preprocess/parser_raw.ml" +# 20149 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19881 "src/ocaml/preprocess/parser_raw.ml" +# 20157 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3694 "src/ocaml/preprocess/parser_raw.mly" +# 3901 "src/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__4_ with | Some _ as info_before_semi -> info_before_semi @@ -19892,13 +20168,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 19896 "src/ocaml/preprocess/parser_raw.ml" +# 20172 "src/ocaml/preprocess/parser_raw.ml" in -# 3675 "src/ocaml/preprocess/parser_raw.mly" +# 3882 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = tail in (head :: f, c) ) -# 19902 "src/ocaml/preprocess/parser_raw.ml" +# 20178 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19939,15 +20215,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3705 "src/ocaml/preprocess/parser_raw.mly" +# 3912 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 19945 "src/ocaml/preprocess/parser_raw.ml" +# 20221 "src/ocaml/preprocess/parser_raw.ml" in -# 3675 "src/ocaml/preprocess/parser_raw.mly" +# 3882 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = tail in (head :: f, c) ) -# 19951 "src/ocaml/preprocess/parser_raw.ml" +# 20227 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20001,9 +20277,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20007 "src/ocaml/preprocess/parser_raw.ml" +# 20283 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20012,49 +20288,49 @@ module Tables = struct let _6 = let _1 = _1_inlined3 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20018 "src/ocaml/preprocess/parser_raw.ml" +# 20294 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20027 "src/ocaml/preprocess/parser_raw.ml" +# 20303 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3484 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20036 "src/ocaml/preprocess/parser_raw.ml" +# 20312 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20043 "src/ocaml/preprocess/parser_raw.ml" +# 20319 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20051 "src/ocaml/preprocess/parser_raw.ml" +# 20327 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3694 "src/ocaml/preprocess/parser_raw.mly" +# 3901 "src/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__4_ with | Some _ as info_before_semi -> info_before_semi @@ -20062,13 +20338,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20066 "src/ocaml/preprocess/parser_raw.ml" +# 20342 "src/ocaml/preprocess/parser_raw.ml" in -# 3678 "src/ocaml/preprocess/parser_raw.mly" +# 3885 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20072 "src/ocaml/preprocess/parser_raw.ml" +# 20348 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20102,15 +20378,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3705 "src/ocaml/preprocess/parser_raw.mly" +# 3912 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20108 "src/ocaml/preprocess/parser_raw.ml" +# 20384 "src/ocaml/preprocess/parser_raw.ml" in -# 3678 "src/ocaml/preprocess/parser_raw.mly" +# 3885 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20114 "src/ocaml/preprocess/parser_raw.ml" +# 20390 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20150,9 +20426,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20156 "src/ocaml/preprocess/parser_raw.ml" +# 20432 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20161,50 +20437,50 @@ module Tables = struct let _4 = let _1 = _1_inlined2 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20167 "src/ocaml/preprocess/parser_raw.ml" +# 20443 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3484 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20176 "src/ocaml/preprocess/parser_raw.ml" +# 20452 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20183 "src/ocaml/preprocess/parser_raw.ml" +# 20459 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20191 "src/ocaml/preprocess/parser_raw.ml" +# 20467 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3687 "src/ocaml/preprocess/parser_raw.mly" +# 3894 "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 ) -# 20202 "src/ocaml/preprocess/parser_raw.ml" +# 20478 "src/ocaml/preprocess/parser_raw.ml" in -# 3681 "src/ocaml/preprocess/parser_raw.mly" +# 3888 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20208 "src/ocaml/preprocess/parser_raw.ml" +# 20484 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20231,15 +20507,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3705 "src/ocaml/preprocess/parser_raw.mly" +# 3912 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20237 "src/ocaml/preprocess/parser_raw.ml" +# 20513 "src/ocaml/preprocess/parser_raw.ml" in -# 3681 "src/ocaml/preprocess/parser_raw.mly" +# 3888 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20243 "src/ocaml/preprocess/parser_raw.ml" +# 20519 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20262,9 +20538,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.object_field list * Asttypes.closed_flag) = -# 3683 "src/ocaml/preprocess/parser_raw.mly" +# 3890 "src/ocaml/preprocess/parser_raw.mly" ( [], Open ) -# 20268 "src/ocaml/preprocess/parser_raw.ml" +# 20544 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20309,9 +20585,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20315 "src/ocaml/preprocess/parser_raw.ml" +# 20591 "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 @@ -20322,41 +20598,41 @@ module Tables = struct Parsetree.attributes) = let ty = let _1 = _1_inlined2 in -# 3480 "src/ocaml/preprocess/parser_raw.mly" +# 3631 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20328 "src/ocaml/preprocess/parser_raw.ml" +# 20604 "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 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20336 "src/ocaml/preprocess/parser_raw.ml" +# 20612 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20344 "src/ocaml/preprocess/parser_raw.ml" +# 20620 "src/ocaml/preprocess/parser_raw.ml" in let attrs = -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20350 "src/ocaml/preprocess/parser_raw.ml" +# 20626 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3954 "src/ocaml/preprocess/parser_raw.mly" +# 4161 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20355 "src/ocaml/preprocess/parser_raw.ml" +# 20631 "src/ocaml/preprocess/parser_raw.ml" in -# 2130 "src/ocaml/preprocess/parser_raw.mly" +# 2217 "src/ocaml/preprocess/parser_raw.mly" ( (label, private_, Cfk_virtual ty), attrs ) -# 20360 "src/ocaml/preprocess/parser_raw.ml" +# 20636 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20394,9 +20670,9 @@ module Tables = struct } = _menhir_stack in let _5 : (Parsetree.expression) = Obj.magic _5 in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20400 "src/ocaml/preprocess/parser_raw.ml" +# 20676 "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 @@ -20407,36 +20683,36 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20413 "src/ocaml/preprocess/parser_raw.ml" +# 20689 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20421 "src/ocaml/preprocess/parser_raw.ml" +# 20697 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20427 "src/ocaml/preprocess/parser_raw.ml" +# 20703 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20432 "src/ocaml/preprocess/parser_raw.ml" +# 20708 "src/ocaml/preprocess/parser_raw.ml" in -# 2132 "src/ocaml/preprocess/parser_raw.mly" +# 2219 "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 ) -# 20440 "src/ocaml/preprocess/parser_raw.ml" +# 20716 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20480,9 +20756,9 @@ module Tables = struct } = _menhir_stack in let _5 : (Parsetree.expression) = Obj.magic _5 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20486 "src/ocaml/preprocess/parser_raw.ml" +# 20762 "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 @@ -20494,39 +20770,39 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20500 "src/ocaml/preprocess/parser_raw.ml" +# 20776 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20508 "src/ocaml/preprocess/parser_raw.ml" +# 20784 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20516 "src/ocaml/preprocess/parser_raw.ml" +# 20792 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 20522 "src/ocaml/preprocess/parser_raw.ml" +# 20798 "src/ocaml/preprocess/parser_raw.ml" in -# 2132 "src/ocaml/preprocess/parser_raw.mly" +# 2219 "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 ) -# 20530 "src/ocaml/preprocess/parser_raw.ml" +# 20806 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20585,9 +20861,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20591 "src/ocaml/preprocess/parser_raw.ml" +# 20867 "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 @@ -20598,45 +20874,45 @@ module Tables = struct Parsetree.attributes) = let _6 = let _1 = _1_inlined2 in -# 3480 "src/ocaml/preprocess/parser_raw.mly" +# 3631 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20604 "src/ocaml/preprocess/parser_raw.ml" +# 20880 "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 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20613 "src/ocaml/preprocess/parser_raw.ml" +# 20889 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20621 "src/ocaml/preprocess/parser_raw.ml" +# 20897 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20627 "src/ocaml/preprocess/parser_raw.ml" +# 20903 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20632 "src/ocaml/preprocess/parser_raw.ml" +# 20908 "src/ocaml/preprocess/parser_raw.ml" in -# 2138 "src/ocaml/preprocess/parser_raw.mly" +# 2225 "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" +# 20916 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20701,9 +20977,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20707 "src/ocaml/preprocess/parser_raw.ml" +# 20983 "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 @@ -20715,48 +20991,48 @@ module Tables = struct Parsetree.attributes) = let _6 = let _1 = _1_inlined3 in -# 3480 "src/ocaml/preprocess/parser_raw.mly" +# 3631 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20721 "src/ocaml/preprocess/parser_raw.ml" +# 20997 "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 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20730 "src/ocaml/preprocess/parser_raw.ml" +# 21006 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20738 "src/ocaml/preprocess/parser_raw.ml" +# 21014 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20746 "src/ocaml/preprocess/parser_raw.ml" +# 21022 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 20752 "src/ocaml/preprocess/parser_raw.ml" +# 21028 "src/ocaml/preprocess/parser_raw.ml" in -# 2138 "src/ocaml/preprocess/parser_raw.mly" +# 2225 "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 ) -# 20760 "src/ocaml/preprocess/parser_raw.ml" +# 21036 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20836,9 +21112,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20842 "src/ocaml/preprocess/parser_raw.ml" +# 21118 "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 @@ -20847,38 +21123,38 @@ module Tables = struct let _endpos = _endpos__11_ in let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) * Parsetree.attributes) = let _7 = -# 2689 "src/ocaml/preprocess/parser_raw.mly" +# 2809 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 20853 "src/ocaml/preprocess/parser_raw.ml" +# 21129 "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 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20861 "src/ocaml/preprocess/parser_raw.ml" +# 21137 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20869 "src/ocaml/preprocess/parser_raw.ml" +# 21145 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20876 "src/ocaml/preprocess/parser_raw.ml" +# 21152 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20882 "src/ocaml/preprocess/parser_raw.ml" +# 21158 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__11_ in @@ -20894,7 +21170,7 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2144 "src/ocaml/preprocess/parser_raw.mly" +# 2231 "src/ocaml/preprocess/parser_raw.mly" ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in let poly_exp = let exp, poly = @@ -20905,7 +21181,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 20909 "src/ocaml/preprocess/parser_raw.ml" +# 21185 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20991,9 +21267,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20997 "src/ocaml/preprocess/parser_raw.ml" +# 21273 "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 @@ -21003,41 +21279,41 @@ module Tables = struct let _endpos = _endpos__11_ in let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) * Parsetree.attributes) = let _7 = -# 2689 "src/ocaml/preprocess/parser_raw.mly" +# 2809 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 21009 "src/ocaml/preprocess/parser_raw.ml" +# 21285 "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 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21017 "src/ocaml/preprocess/parser_raw.ml" +# 21293 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21025 "src/ocaml/preprocess/parser_raw.ml" +# 21301 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21034 "src/ocaml/preprocess/parser_raw.ml" +# 21310 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 21041 "src/ocaml/preprocess/parser_raw.ml" +# 21317 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__11_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -21052,7 +21328,7 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2144 "src/ocaml/preprocess/parser_raw.mly" +# 2231 "src/ocaml/preprocess/parser_raw.mly" ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in let poly_exp = let exp, poly = @@ -21063,7 +21339,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21067 "src/ocaml/preprocess/parser_raw.ml" +# 21343 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21082,17 +21358,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21088 "src/ocaml/preprocess/parser_raw.ml" +# 21364 "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) = -# 3808 "src/ocaml/preprocess/parser_raw.mly" +# 4015 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21096 "src/ocaml/preprocess/parser_raw.ml" +# 21372 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21123,9 +21399,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21129 "src/ocaml/preprocess/parser_raw.ml" +# 21405 "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 @@ -21133,9 +21409,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 4016 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21139 "src/ocaml/preprocess/parser_raw.ml" +# 21415 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21154,17 +21430,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21160 "src/ocaml/preprocess/parser_raw.ml" +# 21436 "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) = -# 3808 "src/ocaml/preprocess/parser_raw.mly" +# 4015 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21168 "src/ocaml/preprocess/parser_raw.ml" +# 21444 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21195,9 +21471,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21201 "src/ocaml/preprocess/parser_raw.ml" +# 21477 "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 @@ -21205,9 +21481,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 4016 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21211 "src/ocaml/preprocess/parser_raw.ml" +# 21487 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21230,14 +21506,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = let _1 = -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21236 "src/ocaml/preprocess/parser_raw.ml" +# 21512 "src/ocaml/preprocess/parser_raw.ml" in -# 3808 "src/ocaml/preprocess/parser_raw.mly" +# 4015 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21241 "src/ocaml/preprocess/parser_raw.ml" +# 21517 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21275,20 +21551,20 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Longident.t) = let _1 = let _1 = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3995 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 21281 "src/ocaml/preprocess/parser_raw.ml" +# 21557 "src/ocaml/preprocess/parser_raw.ml" in -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21286 "src/ocaml/preprocess/parser_raw.ml" +# 21562 "src/ocaml/preprocess/parser_raw.ml" in -# 3808 "src/ocaml/preprocess/parser_raw.mly" +# 4015 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21292 "src/ocaml/preprocess/parser_raw.ml" +# 21568 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21311,14 +21587,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = let _1 = -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21317 "src/ocaml/preprocess/parser_raw.ml" +# 21593 "src/ocaml/preprocess/parser_raw.ml" in -# 3808 "src/ocaml/preprocess/parser_raw.mly" +# 4015 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21322 "src/ocaml/preprocess/parser_raw.ml" +# 21598 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21357,15 +21633,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let _1 = _1_inlined1 in -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21363 "src/ocaml/preprocess/parser_raw.ml" +# 21639 "src/ocaml/preprocess/parser_raw.ml" in -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 4016 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21369 "src/ocaml/preprocess/parser_raw.ml" +# 21645 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21418,20 +21694,20 @@ module Tables = struct let _v : (Longident.t) = let _3 = let (_2, _1) = (_2_inlined1, _1_inlined1) in let _1 = -# 3788 "src/ocaml/preprocess/parser_raw.mly" +# 3995 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 21424 "src/ocaml/preprocess/parser_raw.ml" +# 21700 "src/ocaml/preprocess/parser_raw.ml" in -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21429 "src/ocaml/preprocess/parser_raw.ml" +# 21705 "src/ocaml/preprocess/parser_raw.ml" in -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 4016 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21435 "src/ocaml/preprocess/parser_raw.ml" +# 21711 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21470,15 +21746,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let _1 = _1_inlined1 in -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 4055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21476 "src/ocaml/preprocess/parser_raw.ml" +# 21752 "src/ocaml/preprocess/parser_raw.ml" in -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 4016 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21482 "src/ocaml/preprocess/parser_raw.ml" +# 21758 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21501,9 +21777,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3808 "src/ocaml/preprocess/parser_raw.mly" +# 4015 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21507 "src/ocaml/preprocess/parser_raw.ml" +# 21783 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21540,9 +21816,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 4016 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21546 "src/ocaml/preprocess/parser_raw.ml" +# 21822 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21561,17 +21837,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21567 "src/ocaml/preprocess/parser_raw.ml" +# 21843 "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) = -# 3808 "src/ocaml/preprocess/parser_raw.mly" +# 4015 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21575 "src/ocaml/preprocess/parser_raw.ml" +# 21851 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21602,9 +21878,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21608 "src/ocaml/preprocess/parser_raw.ml" +# 21884 "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 @@ -21612,9 +21888,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 4016 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21618 "src/ocaml/preprocess/parser_raw.ml" +# 21894 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21633,17 +21909,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21639 "src/ocaml/preprocess/parser_raw.ml" +# 21915 "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) = -# 3808 "src/ocaml/preprocess/parser_raw.mly" +# 4015 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21647 "src/ocaml/preprocess/parser_raw.ml" +# 21923 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21674,9 +21950,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21680 "src/ocaml/preprocess/parser_raw.ml" +# 21956 "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 @@ -21684,9 +21960,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 4016 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21690 "src/ocaml/preprocess/parser_raw.ml" +# 21966 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21709,9 +21985,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3808 "src/ocaml/preprocess/parser_raw.mly" +# 4015 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21715 "src/ocaml/preprocess/parser_raw.ml" +# 21991 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21748,9 +22024,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 4016 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21754 "src/ocaml/preprocess/parser_raw.ml" +# 22030 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21773,9 +22049,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3824 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21779 "src/ocaml/preprocess/parser_raw.ml" +# 22055 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21822,9 +22098,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3826 "src/ocaml/preprocess/parser_raw.mly" +# 4033 "src/ocaml/preprocess/parser_raw.mly" ( lapply ~loc:_sloc _1 _3 ) -# 21828 "src/ocaml/preprocess/parser_raw.ml" +# 22104 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21847,9 +22123,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3821 "src/ocaml/preprocess/parser_raw.mly" +# 4028 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21853 "src/ocaml/preprocess/parser_raw.ml" +# 22129 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21879,9 +22155,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = -# 1587 "src/ocaml/preprocess/parser_raw.mly" +# 1674 "src/ocaml/preprocess/parser_raw.mly" ( me ) -# 21885 "src/ocaml/preprocess/parser_raw.ml" +# 22161 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21926,24 +22202,24 @@ module Tables = struct let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1594 "src/ocaml/preprocess/parser_raw.mly" +# 1681 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_constraint(me, mty) ) -# 21932 "src/ocaml/preprocess/parser_raw.ml" +# 22208 "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 -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1105 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 21941 "src/ocaml/preprocess/parser_raw.ml" +# 22217 "src/ocaml/preprocess/parser_raw.ml" in -# 1598 "src/ocaml/preprocess/parser_raw.mly" +# 1685 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21947 "src/ocaml/preprocess/parser_raw.ml" +# 22223 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21974,25 +22250,25 @@ module Tables = struct let _endpos = _endpos_body_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1596 "src/ocaml/preprocess/parser_raw.mly" +# 1683 "src/ocaml/preprocess/parser_raw.mly" ( let (_, arg) = arg_and_pos in Pmod_functor(arg, body) ) -# 21981 "src/ocaml/preprocess/parser_raw.ml" +# 22257 "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 -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1105 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 21990 "src/ocaml/preprocess/parser_raw.ml" +# 22266 "src/ocaml/preprocess/parser_raw.ml" in -# 1598 "src/ocaml/preprocess/parser_raw.mly" +# 1685 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21996 "src/ocaml/preprocess/parser_raw.ml" +# 22272 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22022,9 +22298,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_mty_ in let _v : (Parsetree.module_type) = -# 1847 "src/ocaml/preprocess/parser_raw.mly" +# 1934 "src/ocaml/preprocess/parser_raw.mly" ( mty ) -# 22028 "src/ocaml/preprocess/parser_raw.ml" +# 22304 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22055,25 +22331,25 @@ module Tables = struct let _endpos = _endpos_body_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1854 "src/ocaml/preprocess/parser_raw.mly" +# 1941 "src/ocaml/preprocess/parser_raw.mly" ( let (_, arg) = arg_and_pos in Pmty_functor(arg, body) ) -# 22062 "src/ocaml/preprocess/parser_raw.ml" +# 22338 "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 -# 1041 "src/ocaml/preprocess/parser_raw.mly" +# 1107 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 22071 "src/ocaml/preprocess/parser_raw.ml" +# 22347 "src/ocaml/preprocess/parser_raw.ml" in -# 1857 "src/ocaml/preprocess/parser_raw.mly" +# 1944 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22077 "src/ocaml/preprocess/parser_raw.ml" +# 22353 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22119,18 +22395,18 @@ module Tables = struct let _v : (Parsetree.module_expr) = let attrs = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22125 "src/ocaml/preprocess/parser_raw.ml" +# 22401 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1411 "src/ocaml/preprocess/parser_raw.mly" +# 1498 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_structure s) ) -# 22134 "src/ocaml/preprocess/parser_raw.ml" +# 22410 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22183,22 +22459,22 @@ module Tables = struct let _v : (Parsetree.module_expr) = let attrs = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22189 "src/ocaml/preprocess/parser_raw.ml" +# 22465 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_me_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1421 "src/ocaml/preprocess/parser_raw.mly" +# 1508 "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 ) ) -# 22202 "src/ocaml/preprocess/parser_raw.ml" +# 22478 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22221,9 +22497,9 @@ module Tables = struct let _startpos = _startpos_me_ in let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = -# 1427 "src/ocaml/preprocess/parser_raw.mly" +# 1514 "src/ocaml/preprocess/parser_raw.mly" ( me ) -# 22227 "src/ocaml/preprocess/parser_raw.ml" +# 22503 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22253,9 +22529,9 @@ module Tables = struct let _startpos = _startpos_me_ in let _endpos = _endpos_attr_ in let _v : (Parsetree.module_expr) = -# 1429 "src/ocaml/preprocess/parser_raw.mly" +# 1516 "src/ocaml/preprocess/parser_raw.mly" ( Mod.attr me attr ) -# 22259 "src/ocaml/preprocess/parser_raw.ml" +# 22535 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22284,30 +22560,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22290 "src/ocaml/preprocess/parser_raw.ml" +# 22566 "src/ocaml/preprocess/parser_raw.ml" in -# 1433 "src/ocaml/preprocess/parser_raw.mly" +# 1520 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_ident x ) -# 22296 "src/ocaml/preprocess/parser_raw.ml" +# 22572 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1105 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22305 "src/ocaml/preprocess/parser_raw.ml" +# 22581 "src/ocaml/preprocess/parser_raw.ml" in -# 1448 "src/ocaml/preprocess/parser_raw.mly" +# 1535 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22311 "src/ocaml/preprocess/parser_raw.ml" +# 22587 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22338,24 +22614,24 @@ module Tables = struct let _endpos = _endpos_me2_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1436 "src/ocaml/preprocess/parser_raw.mly" +# 1523 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_apply(me1, me2) ) -# 22344 "src/ocaml/preprocess/parser_raw.ml" +# 22620 "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 -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1105 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22353 "src/ocaml/preprocess/parser_raw.ml" +# 22629 "src/ocaml/preprocess/parser_raw.ml" in -# 1448 "src/ocaml/preprocess/parser_raw.mly" +# 1535 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22359 "src/ocaml/preprocess/parser_raw.ml" +# 22635 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22393,24 +22669,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1439 "src/ocaml/preprocess/parser_raw.mly" +# 1526 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_apply_unit me ) -# 22399 "src/ocaml/preprocess/parser_raw.ml" +# 22675 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_me_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1105 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22408 "src/ocaml/preprocess/parser_raw.ml" +# 22684 "src/ocaml/preprocess/parser_raw.ml" in -# 1448 "src/ocaml/preprocess/parser_raw.mly" +# 1535 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22414 "src/ocaml/preprocess/parser_raw.ml" +# 22690 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22434,24 +22710,24 @@ module Tables = struct let _endpos = _endpos_ex_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1442 "src/ocaml/preprocess/parser_raw.mly" +# 1529 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_extension ex ) -# 22440 "src/ocaml/preprocess/parser_raw.ml" +# 22716 "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 -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1105 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22449 "src/ocaml/preprocess/parser_raw.ml" +# 22725 "src/ocaml/preprocess/parser_raw.ml" in -# 1448 "src/ocaml/preprocess/parser_raw.mly" +# 1535 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22455 "src/ocaml/preprocess/parser_raw.ml" +# 22731 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22479,25 +22755,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 1445 "src/ocaml/preprocess/parser_raw.mly" +# 1532 "src/ocaml/preprocess/parser_raw.mly" ( let id = mkrhs Ast_helper.hole_txt _loc in Pmod_extension (id, PStr []) ) -# 22486 "src/ocaml/preprocess/parser_raw.ml" +# 22762 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1039 "src/ocaml/preprocess/parser_raw.mly" +# 1105 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22495 "src/ocaml/preprocess/parser_raw.ml" +# 22771 "src/ocaml/preprocess/parser_raw.ml" in -# 1448 "src/ocaml/preprocess/parser_raw.mly" +# 1535 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22501 "src/ocaml/preprocess/parser_raw.ml" +# 22777 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22516,17 +22792,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let x : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) -# 22522 "src/ocaml/preprocess/parser_raw.ml" +# 22798 "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) = -# 1394 "src/ocaml/preprocess/parser_raw.mly" +# 1481 "src/ocaml/preprocess/parser_raw.mly" ( Some x ) -# 22530 "src/ocaml/preprocess/parser_raw.ml" +# 22806 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22549,9 +22825,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string option) = -# 1397 "src/ocaml/preprocess/parser_raw.mly" +# 1484 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 22555 "src/ocaml/preprocess/parser_raw.ml" +# 22831 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22609,9 +22885,9 @@ module Tables = struct let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) -# 22615 "src/ocaml/preprocess/parser_raw.ml" +# 22891 "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 @@ -22622,9 +22898,9 @@ module Tables = struct let _v : (Parsetree.module_substitution * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22628 "src/ocaml/preprocess/parser_raw.ml" +# 22904 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -22634,9 +22910,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22640 "src/ocaml/preprocess/parser_raw.ml" +# 22916 "src/ocaml/preprocess/parser_raw.ml" in let uid = @@ -22645,31 +22921,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22651 "src/ocaml/preprocess/parser_raw.ml" +# 22927 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22659 "src/ocaml/preprocess/parser_raw.ml" +# 22935 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1887 "src/ocaml/preprocess/parser_raw.mly" +# 1974 "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 ) -# 22673 "src/ocaml/preprocess/parser_raw.ml" +# 22949 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22715,18 +22991,18 @@ module Tables = struct let _v : (Parsetree.module_type) = let attrs = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22721 "src/ocaml/preprocess/parser_raw.ml" +# 22997 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1723 "src/ocaml/preprocess/parser_raw.mly" +# 1810 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc ~attrs (Pmty_signature s) ) -# 22730 "src/ocaml/preprocess/parser_raw.ml" +# 23006 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22779,22 +23055,22 @@ module Tables = struct let _v : (Parsetree.module_type) = let attrs = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22785 "src/ocaml/preprocess/parser_raw.ml" +# 23061 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_mty_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1735 "src/ocaml/preprocess/parser_raw.mly" +# 1822 "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 ) ) -# 22798 "src/ocaml/preprocess/parser_raw.ml" +# 23074 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22847,18 +23123,18 @@ module Tables = struct let _v : (Parsetree.module_type) = let _4 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22853 "src/ocaml/preprocess/parser_raw.ml" +# 23129 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1741 "src/ocaml/preprocess/parser_raw.mly" +# 1828 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc ~attrs:_4 (Pmty_typeof _5) ) -# 22862 "src/ocaml/preprocess/parser_raw.ml" +# 23138 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22895,9 +23171,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.module_type) = -# 1743 "src/ocaml/preprocess/parser_raw.mly" +# 1830 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 22901 "src/ocaml/preprocess/parser_raw.ml" +# 23177 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22927,9 +23203,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_type) = -# 1749 "src/ocaml/preprocess/parser_raw.mly" +# 1836 "src/ocaml/preprocess/parser_raw.mly" ( Mty.attr _1 _2 ) -# 22933 "src/ocaml/preprocess/parser_raw.ml" +# 23209 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22958,30 +23234,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22964 "src/ocaml/preprocess/parser_raw.ml" +# 23240 "src/ocaml/preprocess/parser_raw.ml" in -# 1752 "src/ocaml/preprocess/parser_raw.mly" +# 1839 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_ident _1 ) -# 22970 "src/ocaml/preprocess/parser_raw.ml" +# 23246 "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" +# 1107 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 22979 "src/ocaml/preprocess/parser_raw.ml" +# 23255 "src/ocaml/preprocess/parser_raw.ml" in -# 1765 "src/ocaml/preprocess/parser_raw.mly" +# 1852 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22985 "src/ocaml/preprocess/parser_raw.ml" +# 23261 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23026,24 +23302,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1754 "src/ocaml/preprocess/parser_raw.mly" +# 1841 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_functor(Unit, _4) ) -# 23032 "src/ocaml/preprocess/parser_raw.ml" +# 23308 "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 -# 1041 "src/ocaml/preprocess/parser_raw.mly" +# 1107 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23041 "src/ocaml/preprocess/parser_raw.ml" +# 23317 "src/ocaml/preprocess/parser_raw.ml" in -# 1765 "src/ocaml/preprocess/parser_raw.mly" +# 1852 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23047 "src/ocaml/preprocess/parser_raw.ml" +# 23323 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23081,24 +23357,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1757 "src/ocaml/preprocess/parser_raw.mly" +# 1844 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_functor(Named (mknoloc None, _1), _3) ) -# 23087 "src/ocaml/preprocess/parser_raw.ml" +# 23363 "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 -# 1041 "src/ocaml/preprocess/parser_raw.mly" +# 1107 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23096 "src/ocaml/preprocess/parser_raw.ml" +# 23372 "src/ocaml/preprocess/parser_raw.ml" in -# 1765 "src/ocaml/preprocess/parser_raw.mly" +# 1852 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23102 "src/ocaml/preprocess/parser_raw.ml" +# 23378 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23140,18 +23416,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 23144 "src/ocaml/preprocess/parser_raw.ml" +# 23420 "src/ocaml/preprocess/parser_raw.ml" in -# 1130 "src/ocaml/preprocess/parser_raw.mly" +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 23149 "src/ocaml/preprocess/parser_raw.ml" +# 23425 "src/ocaml/preprocess/parser_raw.ml" in -# 1759 "src/ocaml/preprocess/parser_raw.mly" +# 1846 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_with(_1, _3) ) -# 23155 "src/ocaml/preprocess/parser_raw.ml" +# 23431 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -23159,15 +23435,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1041 "src/ocaml/preprocess/parser_raw.mly" +# 1107 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23165 "src/ocaml/preprocess/parser_raw.ml" +# 23441 "src/ocaml/preprocess/parser_raw.ml" in -# 1765 "src/ocaml/preprocess/parser_raw.mly" +# 1852 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23171 "src/ocaml/preprocess/parser_raw.ml" +# 23447 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23191,23 +23467,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1763 "src/ocaml/preprocess/parser_raw.mly" +# 1850 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_extension _1 ) -# 23197 "src/ocaml/preprocess/parser_raw.ml" +# 23473 "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" +# 1107 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23205 "src/ocaml/preprocess/parser_raw.ml" +# 23481 "src/ocaml/preprocess/parser_raw.ml" in -# 1765 "src/ocaml/preprocess/parser_raw.mly" +# 1852 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23211 "src/ocaml/preprocess/parser_raw.ml" +# 23487 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23274,9 +23550,9 @@ module Tables = struct let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23280 "src/ocaml/preprocess/parser_raw.ml" +# 23556 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -23286,31 +23562,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23292 "src/ocaml/preprocess/parser_raw.ml" +# 23568 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23300 "src/ocaml/preprocess/parser_raw.ml" +# 23576 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1669 "src/ocaml/preprocess/parser_raw.mly" +# 1756 "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 ) -# 23314 "src/ocaml/preprocess/parser_raw.ml" +# 23590 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23384,9 +23660,9 @@ module Tables = struct let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23390 "src/ocaml/preprocess/parser_raw.ml" +# 23666 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -23396,31 +23672,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23402 "src/ocaml/preprocess/parser_raw.ml" +# 23678 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23410 "src/ocaml/preprocess/parser_raw.ml" +# 23686 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1945 "src/ocaml/preprocess/parser_raw.mly" +# 2032 "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 ) -# 23424 "src/ocaml/preprocess/parser_raw.ml" +# 23700 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23443,9 +23719,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3833 "src/ocaml/preprocess/parser_raw.mly" +# 4040 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23449 "src/ocaml/preprocess/parser_raw.ml" +# 23725 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23461,9 +23737,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.mutable_flag) = -# 3914 "src/ocaml/preprocess/parser_raw.mly" +# 4121 "src/ocaml/preprocess/parser_raw.mly" ( Immutable ) -# 23467 "src/ocaml/preprocess/parser_raw.ml" +# 23743 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23486,9 +23762,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag) = -# 3915 "src/ocaml/preprocess/parser_raw.mly" +# 4122 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 23492 "src/ocaml/preprocess/parser_raw.ml" +# 23768 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23504,9 +23780,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3923 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Immutable, Concrete ) -# 23510 "src/ocaml/preprocess/parser_raw.ml" +# 23786 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23529,9 +23805,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3925 "src/ocaml/preprocess/parser_raw.mly" +# 4132 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Concrete ) -# 23535 "src/ocaml/preprocess/parser_raw.ml" +# 23811 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23554,9 +23830,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3927 "src/ocaml/preprocess/parser_raw.mly" +# 4134 "src/ocaml/preprocess/parser_raw.mly" ( Immutable, Virtual ) -# 23560 "src/ocaml/preprocess/parser_raw.ml" +# 23836 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23586,9 +23862,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3930 "src/ocaml/preprocess/parser_raw.mly" +# 4137 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Virtual ) -# 23592 "src/ocaml/preprocess/parser_raw.ml" +# 23868 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23618,9 +23894,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 3930 "src/ocaml/preprocess/parser_raw.mly" +# 4137 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Virtual ) -# 23624 "src/ocaml/preprocess/parser_raw.ml" +# 23900 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23650,9 +23926,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3885 "src/ocaml/preprocess/parser_raw.mly" +# 4092 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 23656 "src/ocaml/preprocess/parser_raw.ml" +# 23932 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23671,9 +23947,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 23677 "src/ocaml/preprocess/parser_raw.ml" +# 23953 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -23683,15 +23959,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23689 "src/ocaml/preprocess/parser_raw.ml" +# 23965 "src/ocaml/preprocess/parser_raw.ml" in # 221 "" ( [ x ] ) -# 23695 "src/ocaml/preprocess/parser_raw.ml" +# 23971 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23717,9 +23993,9 @@ module Tables = struct } = _menhir_stack in let xs : (string Location.loc list) = Obj.magic xs in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 23723 "src/ocaml/preprocess/parser_raw.ml" +# 23999 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -23729,15 +24005,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23735 "src/ocaml/preprocess/parser_raw.ml" +# 24011 "src/ocaml/preprocess/parser_raw.ml" in # 223 "" ( x :: xs ) -# 23741 "src/ocaml/preprocess/parser_raw.ml" +# 24017 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23756,22 +24032,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let s : ( -# 837 "src/ocaml/preprocess/parser_raw.mly" +# 903 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 23762 "src/ocaml/preprocess/parser_raw.ml" +# 24038 "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 = -# 3881 "src/ocaml/preprocess/parser_raw.mly" +# 4088 "src/ocaml/preprocess/parser_raw.mly" ( let body, _, _ = s in body ) -# 23770 "src/ocaml/preprocess/parser_raw.ml" +# 24046 "src/ocaml/preprocess/parser_raw.ml" in # 221 "" ( [ x ] ) -# 23775 "src/ocaml/preprocess/parser_raw.ml" +# 24051 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23797,22 +24073,22 @@ module Tables = struct } = _menhir_stack in let xs : (string list) = Obj.magic xs in let s : ( -# 837 "src/ocaml/preprocess/parser_raw.mly" +# 903 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 23803 "src/ocaml/preprocess/parser_raw.ml" +# 24079 "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 = -# 3881 "src/ocaml/preprocess/parser_raw.mly" +# 4088 "src/ocaml/preprocess/parser_raw.mly" ( let body, _, _ = s in body ) -# 23811 "src/ocaml/preprocess/parser_raw.ml" +# 24087 "src/ocaml/preprocess/parser_raw.ml" in # 223 "" ( x :: xs ) -# 23816 "src/ocaml/preprocess/parser_raw.ml" +# 24092 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23835,14 +24111,14 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 4117 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 23841 "src/ocaml/preprocess/parser_raw.ml" +# 24117 "src/ocaml/preprocess/parser_raw.ml" in -# 3190 "src/ocaml/preprocess/parser_raw.mly" +# 3341 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, priv, Some ty) ) -# 23846 "src/ocaml/preprocess/parser_raw.ml" +# 24122 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23872,14 +24148,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3911 "src/ocaml/preprocess/parser_raw.mly" +# 4118 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 23878 "src/ocaml/preprocess/parser_raw.ml" +# 24154 "src/ocaml/preprocess/parser_raw.ml" in -# 3190 "src/ocaml/preprocess/parser_raw.mly" +# 3341 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, priv, Some ty) ) -# 23883 "src/ocaml/preprocess/parser_raw.ml" +# 24159 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23902,26 +24178,26 @@ module Tables = struct let _startpos = _startpos_cs_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 4117 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 23908 "src/ocaml/preprocess/parser_raw.ml" +# 24184 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 23914 "src/ocaml/preprocess/parser_raw.ml" +# 24190 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23919 "src/ocaml/preprocess/parser_raw.ml" +# 24195 "src/ocaml/preprocess/parser_raw.ml" in -# 3194 "src/ocaml/preprocess/parser_raw.mly" +# 3345 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 23925 "src/ocaml/preprocess/parser_raw.ml" +# 24201 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23951,26 +24227,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3911 "src/ocaml/preprocess/parser_raw.mly" +# 4118 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 23957 "src/ocaml/preprocess/parser_raw.ml" +# 24233 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 23963 "src/ocaml/preprocess/parser_raw.ml" +# 24239 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23968 "src/ocaml/preprocess/parser_raw.ml" +# 24244 "src/ocaml/preprocess/parser_raw.ml" in -# 3194 "src/ocaml/preprocess/parser_raw.mly" +# 3345 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 23974 "src/ocaml/preprocess/parser_raw.ml" +# 24250 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24007,33 +24283,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 4117 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24013 "src/ocaml/preprocess/parser_raw.ml" +# 24289 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24020 "src/ocaml/preprocess/parser_raw.ml" +# 24296 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24025 "src/ocaml/preprocess/parser_raw.ml" +# 24301 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24031 "src/ocaml/preprocess/parser_raw.ml" +# 24307 "src/ocaml/preprocess/parser_raw.ml" in -# 3194 "src/ocaml/preprocess/parser_raw.mly" +# 3345 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24037 "src/ocaml/preprocess/parser_raw.ml" +# 24313 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24077,33 +24353,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3911 "src/ocaml/preprocess/parser_raw.mly" +# 4118 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24083 "src/ocaml/preprocess/parser_raw.ml" +# 24359 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24090 "src/ocaml/preprocess/parser_raw.ml" +# 24366 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24095 "src/ocaml/preprocess/parser_raw.ml" +# 24371 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24101 "src/ocaml/preprocess/parser_raw.ml" +# 24377 "src/ocaml/preprocess/parser_raw.ml" in -# 3194 "src/ocaml/preprocess/parser_raw.mly" +# 3345 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24107 "src/ocaml/preprocess/parser_raw.ml" +# 24383 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24126,26 +24402,26 @@ module Tables = struct let _startpos = _startpos__3_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 4117 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24132 "src/ocaml/preprocess/parser_raw.ml" +# 24408 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24138 "src/ocaml/preprocess/parser_raw.ml" +# 24414 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24143 "src/ocaml/preprocess/parser_raw.ml" +# 24419 "src/ocaml/preprocess/parser_raw.ml" in -# 3198 "src/ocaml/preprocess/parser_raw.mly" +# 3349 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24149 "src/ocaml/preprocess/parser_raw.ml" +# 24425 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24175,26 +24451,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3911 "src/ocaml/preprocess/parser_raw.mly" +# 4118 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24181 "src/ocaml/preprocess/parser_raw.ml" +# 24457 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24187 "src/ocaml/preprocess/parser_raw.ml" +# 24463 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24192 "src/ocaml/preprocess/parser_raw.ml" +# 24468 "src/ocaml/preprocess/parser_raw.ml" in -# 3198 "src/ocaml/preprocess/parser_raw.mly" +# 3349 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24198 "src/ocaml/preprocess/parser_raw.ml" +# 24474 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24231,33 +24507,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 4117 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24237 "src/ocaml/preprocess/parser_raw.ml" +# 24513 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24244 "src/ocaml/preprocess/parser_raw.ml" +# 24520 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24249 "src/ocaml/preprocess/parser_raw.ml" +# 24525 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24255 "src/ocaml/preprocess/parser_raw.ml" +# 24531 "src/ocaml/preprocess/parser_raw.ml" in -# 3198 "src/ocaml/preprocess/parser_raw.mly" +# 3349 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24261 "src/ocaml/preprocess/parser_raw.ml" +# 24537 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24301,33 +24577,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3911 "src/ocaml/preprocess/parser_raw.mly" +# 4118 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24307 "src/ocaml/preprocess/parser_raw.ml" +# 24583 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24314 "src/ocaml/preprocess/parser_raw.ml" +# 24590 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24319 "src/ocaml/preprocess/parser_raw.ml" +# 24595 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24325 "src/ocaml/preprocess/parser_raw.ml" +# 24601 "src/ocaml/preprocess/parser_raw.ml" in -# 3198 "src/ocaml/preprocess/parser_raw.mly" +# 3349 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24331 "src/ocaml/preprocess/parser_raw.ml" +# 24607 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24364,26 +24640,26 @@ module Tables = struct let _startpos = _startpos__3_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 4117 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24370 "src/ocaml/preprocess/parser_raw.ml" +# 24646 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24376 "src/ocaml/preprocess/parser_raw.ml" +# 24652 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24381 "src/ocaml/preprocess/parser_raw.ml" +# 24657 "src/ocaml/preprocess/parser_raw.ml" in -# 3202 "src/ocaml/preprocess/parser_raw.mly" +# 3353 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24387 "src/ocaml/preprocess/parser_raw.ml" +# 24663 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24427,26 +24703,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3911 "src/ocaml/preprocess/parser_raw.mly" +# 4118 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24433 "src/ocaml/preprocess/parser_raw.ml" +# 24709 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24439 "src/ocaml/preprocess/parser_raw.ml" +# 24715 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24444 "src/ocaml/preprocess/parser_raw.ml" +# 24720 "src/ocaml/preprocess/parser_raw.ml" in -# 3202 "src/ocaml/preprocess/parser_raw.mly" +# 3353 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24450 "src/ocaml/preprocess/parser_raw.ml" +# 24726 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24497,33 +24773,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 4117 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24503 "src/ocaml/preprocess/parser_raw.ml" +# 24779 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24510 "src/ocaml/preprocess/parser_raw.ml" +# 24786 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24515 "src/ocaml/preprocess/parser_raw.ml" +# 24791 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24521 "src/ocaml/preprocess/parser_raw.ml" +# 24797 "src/ocaml/preprocess/parser_raw.ml" in -# 3202 "src/ocaml/preprocess/parser_raw.mly" +# 3353 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24527 "src/ocaml/preprocess/parser_raw.ml" +# 24803 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24581,33 +24857,136 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 3911 "src/ocaml/preprocess/parser_raw.mly" +# 4118 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24587 "src/ocaml/preprocess/parser_raw.ml" +# 24863 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24594 "src/ocaml/preprocess/parser_raw.ml" +# 24870 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24599 "src/ocaml/preprocess/parser_raw.ml" +# 24875 "src/ocaml/preprocess/parser_raw.ml" in -# 3206 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24605 "src/ocaml/preprocess/parser_raw.ml" +# 24881 "src/ocaml/preprocess/parser_raw.ml" in -# 3202 "src/ocaml/preprocess/parser_raw.mly" +# 3353 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24611 "src/ocaml/preprocess/parser_raw.ml" +# 24887 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = meth_list; + MenhirLib.EngineTypes.startp = _startpos_meth_list_; + MenhirLib.EngineTypes.endp = _endpos_meth_list_; + MenhirLib.EngineTypes.next = { + MenhirLib.EngineTypes.state = _menhir_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 meth_list : (Parsetree.object_field list * Asttypes.closed_flag) = Obj.magic meth_list in + 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 = +# 3777 "src/ocaml/preprocess/parser_raw.mly" + ( let (f, c) = meth_list in Ptyp_object (f, c) ) +# 24927 "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 + +# 1099 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 24936 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3781 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 24942 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = +# 3779 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_object ([], Closed) ) +# 24975 "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 + +# 1099 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 24984 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 3781 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 24990 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24660,37 +25039,37 @@ module Tables = struct let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24666 "src/ocaml/preprocess/parser_raw.ml" +# 25045 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24675 "src/ocaml/preprocess/parser_raw.ml" +# 25054 "src/ocaml/preprocess/parser_raw.ml" in let override = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 24681 "src/ocaml/preprocess/parser_raw.ml" +# 25060 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1688 "src/ocaml/preprocess/parser_raw.mly" +# 1775 "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 ) -# 24694 "src/ocaml/preprocess/parser_raw.ml" +# 25073 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24750,40 +25129,40 @@ module Tables = struct let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24756 "src/ocaml/preprocess/parser_raw.ml" +# 25135 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let attrs1 = let _1 = _1_inlined2 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24765 "src/ocaml/preprocess/parser_raw.ml" +# 25144 "src/ocaml/preprocess/parser_raw.ml" in let override = let _1 = _1_inlined1 in -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 24773 "src/ocaml/preprocess/parser_raw.ml" +# 25152 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1688 "src/ocaml/preprocess/parser_raw.mly" +# 1775 "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 ) -# 24787 "src/ocaml/preprocess/parser_raw.ml" +# 25166 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24836,9 +25215,9 @@ module Tables = struct let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24842 "src/ocaml/preprocess/parser_raw.ml" +# 25221 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -24848,36 +25227,36 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 24854 "src/ocaml/preprocess/parser_raw.ml" +# 25233 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24862 "src/ocaml/preprocess/parser_raw.ml" +# 25241 "src/ocaml/preprocess/parser_raw.ml" in let override = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 24868 "src/ocaml/preprocess/parser_raw.ml" +# 25247 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1790 "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 ) -# 24881 "src/ocaml/preprocess/parser_raw.ml" +# 25260 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24937,9 +25316,9 @@ module Tables = struct let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24943 "src/ocaml/preprocess/parser_raw.ml" +# 25322 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -24949,39 +25328,39 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 24955 "src/ocaml/preprocess/parser_raw.ml" +# 25334 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined2 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24963 "src/ocaml/preprocess/parser_raw.ml" +# 25342 "src/ocaml/preprocess/parser_raw.ml" in let override = let _1 = _1_inlined1 in -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 24971 "src/ocaml/preprocess/parser_raw.ml" +# 25350 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1790 "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 ) -# 24985 "src/ocaml/preprocess/parser_raw.ml" +# 25364 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25000,17 +25379,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 823 "src/ocaml/preprocess/parser_raw.mly" +# 889 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25006 "src/ocaml/preprocess/parser_raw.ml" +# 25385 "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) = -# 3747 "src/ocaml/preprocess/parser_raw.mly" +# 3954 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25014 "src/ocaml/preprocess/parser_raw.ml" +# 25393 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25029,17 +25408,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 781 "src/ocaml/preprocess/parser_raw.mly" +# 847 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25035 "src/ocaml/preprocess/parser_raw.ml" +# 25414 "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" +# 3955 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25043 "src/ocaml/preprocess/parser_raw.ml" +# 25422 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25058,17 +25437,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 782 "src/ocaml/preprocess/parser_raw.mly" +# 848 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25064 "src/ocaml/preprocess/parser_raw.ml" +# 25443 "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) = -# 3749 "src/ocaml/preprocess/parser_raw.mly" +# 3956 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25072 "src/ocaml/preprocess/parser_raw.ml" +# 25451 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25108,17 +25487,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25114 "src/ocaml/preprocess/parser_raw.ml" +# 25493 "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) = -# 3750 "src/ocaml/preprocess/parser_raw.mly" +# 3957 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"(" ^ _3 ^ ")" ) -# 25122 "src/ocaml/preprocess/parser_raw.ml" +# 25501 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25165,17 +25544,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25171 "src/ocaml/preprocess/parser_raw.ml" +# 25550 "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) = -# 3751 "src/ocaml/preprocess/parser_raw.mly" +# 3958 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "(" ^ _3 ^ ")<-" ) -# 25179 "src/ocaml/preprocess/parser_raw.ml" +# 25558 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25215,17 +25594,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25221 "src/ocaml/preprocess/parser_raw.ml" +# 25600 "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) = -# 3752 "src/ocaml/preprocess/parser_raw.mly" +# 3959 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"[" ^ _3 ^ "]" ) -# 25229 "src/ocaml/preprocess/parser_raw.ml" +# 25608 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25272,17 +25651,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25278 "src/ocaml/preprocess/parser_raw.ml" +# 25657 "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) = -# 3753 "src/ocaml/preprocess/parser_raw.mly" +# 3960 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "[" ^ _3 ^ "]<-" ) -# 25286 "src/ocaml/preprocess/parser_raw.ml" +# 25665 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25322,17 +25701,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25328 "src/ocaml/preprocess/parser_raw.ml" +# 25707 "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) = -# 3754 "src/ocaml/preprocess/parser_raw.mly" +# 3961 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"{" ^ _3 ^ "}" ) -# 25336 "src/ocaml/preprocess/parser_raw.ml" +# 25715 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25379,17 +25758,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25385 "src/ocaml/preprocess/parser_raw.ml" +# 25764 "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) = -# 3755 "src/ocaml/preprocess/parser_raw.mly" +# 3962 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "{" ^ _3 ^ "}<-" ) -# 25393 "src/ocaml/preprocess/parser_raw.ml" +# 25772 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25408,17 +25787,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 834 "src/ocaml/preprocess/parser_raw.mly" +# 900 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25414 "src/ocaml/preprocess/parser_raw.ml" +# 25793 "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) = -# 3756 "src/ocaml/preprocess/parser_raw.mly" +# 3963 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25422 "src/ocaml/preprocess/parser_raw.ml" +# 25801 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25441,9 +25820,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3757 "src/ocaml/preprocess/parser_raw.mly" +# 3964 "src/ocaml/preprocess/parser_raw.mly" ( "!" ) -# 25447 "src/ocaml/preprocess/parser_raw.ml" +# 25826 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25462,22 +25841,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 841 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25468 "src/ocaml/preprocess/parser_raw.ml" +# 25847 "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 = -# 3761 "src/ocaml/preprocess/parser_raw.mly" +# 3968 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25476 "src/ocaml/preprocess/parser_raw.ml" +# 25855 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25481 "src/ocaml/preprocess/parser_raw.ml" +# 25860 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25496,22 +25875,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 842 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25502 "src/ocaml/preprocess/parser_raw.ml" +# 25881 "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 = -# 3762 "src/ocaml/preprocess/parser_raw.mly" +# 3969 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25510 "src/ocaml/preprocess/parser_raw.ml" +# 25889 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25515 "src/ocaml/preprocess/parser_raw.ml" +# 25894 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25530,22 +25909,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 777 "src/ocaml/preprocess/parser_raw.mly" +# 843 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25536 "src/ocaml/preprocess/parser_raw.ml" +# 25915 "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 = -# 3763 "src/ocaml/preprocess/parser_raw.mly" +# 3970 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25544 "src/ocaml/preprocess/parser_raw.ml" +# 25923 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25549 "src/ocaml/preprocess/parser_raw.ml" +# 25928 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25564,22 +25943,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 844 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25570 "src/ocaml/preprocess/parser_raw.ml" +# 25949 "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 = -# 3764 "src/ocaml/preprocess/parser_raw.mly" +# 3971 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25578 "src/ocaml/preprocess/parser_raw.ml" +# 25957 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25583 "src/ocaml/preprocess/parser_raw.ml" +# 25962 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25598,22 +25977,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 845 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25604 "src/ocaml/preprocess/parser_raw.ml" +# 25983 "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 = -# 3765 "src/ocaml/preprocess/parser_raw.mly" +# 3972 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25612 "src/ocaml/preprocess/parser_raw.ml" +# 25991 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25617 "src/ocaml/preprocess/parser_raw.ml" +# 25996 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25636,14 +26015,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3766 "src/ocaml/preprocess/parser_raw.mly" +# 3973 "src/ocaml/preprocess/parser_raw.mly" ("+") -# 25642 "src/ocaml/preprocess/parser_raw.ml" +# 26021 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25647 "src/ocaml/preprocess/parser_raw.ml" +# 26026 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25666,14 +26045,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3767 "src/ocaml/preprocess/parser_raw.mly" +# 3974 "src/ocaml/preprocess/parser_raw.mly" ("+.") -# 25672 "src/ocaml/preprocess/parser_raw.ml" +# 26051 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25677 "src/ocaml/preprocess/parser_raw.ml" +# 26056 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25696,14 +26075,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3768 "src/ocaml/preprocess/parser_raw.mly" +# 3975 "src/ocaml/preprocess/parser_raw.mly" ("+=") -# 25702 "src/ocaml/preprocess/parser_raw.ml" +# 26081 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25707 "src/ocaml/preprocess/parser_raw.ml" +# 26086 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25726,14 +26105,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3769 "src/ocaml/preprocess/parser_raw.mly" +# 3976 "src/ocaml/preprocess/parser_raw.mly" ("-") -# 25732 "src/ocaml/preprocess/parser_raw.ml" +# 26111 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25737 "src/ocaml/preprocess/parser_raw.ml" +# 26116 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25756,14 +26135,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3770 "src/ocaml/preprocess/parser_raw.mly" +# 3977 "src/ocaml/preprocess/parser_raw.mly" ("-.") -# 25762 "src/ocaml/preprocess/parser_raw.ml" +# 26141 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25767 "src/ocaml/preprocess/parser_raw.ml" +# 26146 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25786,14 +26165,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3771 "src/ocaml/preprocess/parser_raw.mly" +# 3978 "src/ocaml/preprocess/parser_raw.mly" ("*") -# 25792 "src/ocaml/preprocess/parser_raw.ml" +# 26171 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25797 "src/ocaml/preprocess/parser_raw.ml" +# 26176 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25816,14 +26195,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3772 "src/ocaml/preprocess/parser_raw.mly" +# 3979 "src/ocaml/preprocess/parser_raw.mly" ("%") -# 25822 "src/ocaml/preprocess/parser_raw.ml" +# 26201 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25827 "src/ocaml/preprocess/parser_raw.ml" +# 26206 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25846,14 +26225,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3773 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ("=") -# 25852 "src/ocaml/preprocess/parser_raw.ml" +# 26231 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25857 "src/ocaml/preprocess/parser_raw.ml" +# 26236 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25876,14 +26255,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3774 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ("<") -# 25882 "src/ocaml/preprocess/parser_raw.ml" +# 26261 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25887 "src/ocaml/preprocess/parser_raw.ml" +# 26266 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25906,14 +26285,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3775 "src/ocaml/preprocess/parser_raw.mly" +# 3982 "src/ocaml/preprocess/parser_raw.mly" (">") -# 25912 "src/ocaml/preprocess/parser_raw.ml" +# 26291 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25917 "src/ocaml/preprocess/parser_raw.ml" +# 26296 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25936,14 +26315,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3776 "src/ocaml/preprocess/parser_raw.mly" +# 3983 "src/ocaml/preprocess/parser_raw.mly" ("or") -# 25942 "src/ocaml/preprocess/parser_raw.ml" +# 26321 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25947 "src/ocaml/preprocess/parser_raw.ml" +# 26326 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25966,14 +26345,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3777 "src/ocaml/preprocess/parser_raw.mly" +# 3984 "src/ocaml/preprocess/parser_raw.mly" ("||") -# 25972 "src/ocaml/preprocess/parser_raw.ml" +# 26351 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25977 "src/ocaml/preprocess/parser_raw.ml" +# 26356 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25996,14 +26375,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3778 "src/ocaml/preprocess/parser_raw.mly" +# 3985 "src/ocaml/preprocess/parser_raw.mly" ("&") -# 26002 "src/ocaml/preprocess/parser_raw.ml" +# 26381 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26007 "src/ocaml/preprocess/parser_raw.ml" +# 26386 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26026,14 +26405,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3779 "src/ocaml/preprocess/parser_raw.mly" +# 3986 "src/ocaml/preprocess/parser_raw.mly" ("&&") -# 26032 "src/ocaml/preprocess/parser_raw.ml" +# 26411 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26037 "src/ocaml/preprocess/parser_raw.ml" +# 26416 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26056,14 +26435,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3780 "src/ocaml/preprocess/parser_raw.mly" +# 3987 "src/ocaml/preprocess/parser_raw.mly" (":=") -# 26062 "src/ocaml/preprocess/parser_raw.ml" +# 26441 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26067 "src/ocaml/preprocess/parser_raw.ml" +# 26446 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26086,9 +26465,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (bool) = -# 3660 "src/ocaml/preprocess/parser_raw.mly" +# 3867 "src/ocaml/preprocess/parser_raw.mly" ( true ) -# 26092 "src/ocaml/preprocess/parser_raw.ml" +# 26471 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26104,9 +26483,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (bool) = -# 3661 "src/ocaml/preprocess/parser_raw.mly" +# 3868 "src/ocaml/preprocess/parser_raw.mly" ( false ) -# 26110 "src/ocaml/preprocess/parser_raw.ml" +# 26489 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26124,7 +26503,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26128 "src/ocaml/preprocess/parser_raw.ml" +# 26507 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26149,7 +26528,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26153 "src/ocaml/preprocess/parser_raw.ml" +# 26532 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26167,7 +26546,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26171 "src/ocaml/preprocess/parser_raw.ml" +# 26550 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26192,7 +26571,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26196 "src/ocaml/preprocess/parser_raw.ml" +# 26575 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26210,7 +26589,7 @@ module Tables = struct let _v : (string Location.loc option) = # 114 "" ( None ) -# 26214 "src/ocaml/preprocess/parser_raw.ml" +# 26593 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26235,9 +26614,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 26241 "src/ocaml/preprocess/parser_raw.ml" +# 26620 "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 @@ -26250,21 +26629,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 26256 "src/ocaml/preprocess/parser_raw.ml" +# 26635 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 26262 "src/ocaml/preprocess/parser_raw.ml" +# 26641 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26268 "src/ocaml/preprocess/parser_raw.ml" +# 26647 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26282,7 +26661,7 @@ module Tables = struct let _v : (Parsetree.core_type option) = # 114 "" ( None ) -# 26286 "src/ocaml/preprocess/parser_raw.ml" +# 26665 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26314,12 +26693,67 @@ module Tables = struct let _v : (Parsetree.core_type option) = let x = # 183 "" ( x ) -# 26318 "src/ocaml/preprocess/parser_raw.ml" +# 26697 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26323 "src/ocaml/preprocess/parser_raw.ml" +# 26702 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.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 "" + ( None ) +# 26720 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 "" + ( x ) +# 26752 "src/ocaml/preprocess/parser_raw.ml" + in + +# 116 "" + ( Some x ) +# 26757 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26337,7 +26771,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 26341 "src/ocaml/preprocess/parser_raw.ml" +# 26775 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26369,12 +26803,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 26373 "src/ocaml/preprocess/parser_raw.ml" +# 26807 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26378 "src/ocaml/preprocess/parser_raw.ml" +# 26812 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26392,7 +26826,7 @@ module Tables = struct let _v : (Parsetree.module_type option) = # 114 "" ( None ) -# 26396 "src/ocaml/preprocess/parser_raw.ml" +# 26830 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26424,12 +26858,12 @@ module Tables = struct let _v : (Parsetree.module_type option) = let x = # 183 "" ( x ) -# 26428 "src/ocaml/preprocess/parser_raw.ml" +# 26862 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26433 "src/ocaml/preprocess/parser_raw.ml" +# 26867 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26447,7 +26881,7 @@ module Tables = struct let _v : (Parsetree.pattern option) = # 114 "" ( None ) -# 26451 "src/ocaml/preprocess/parser_raw.ml" +# 26885 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26479,12 +26913,12 @@ module Tables = struct let _v : (Parsetree.pattern option) = let x = # 183 "" ( x ) -# 26483 "src/ocaml/preprocess/parser_raw.ml" +# 26917 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26488 "src/ocaml/preprocess/parser_raw.ml" +# 26922 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26502,7 +26936,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 26506 "src/ocaml/preprocess/parser_raw.ml" +# 26940 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26534,12 +26968,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 26538 "src/ocaml/preprocess/parser_raw.ml" +# 26972 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26543 "src/ocaml/preprocess/parser_raw.ml" +# 26977 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26554,10 +26988,10 @@ module Tables = struct 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) = + let _v : (Parsetree.type_constraint option) = # 114 "" ( None ) -# 26561 "src/ocaml/preprocess/parser_raw.ml" +# 26995 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26575,14 +27009,14 @@ module Tables = struct 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 x : (Parsetree.type_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.core_type option * Parsetree.core_type option) option) = + let _v : (Parsetree.type_constraint option) = # 116 "" ( Some x ) -# 26586 "src/ocaml/preprocess/parser_raw.ml" +# 27020 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26601,17 +27035,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 816 "src/ocaml/preprocess/parser_raw.mly" +# 882 "src/ocaml/preprocess/parser_raw.mly" (string) -# 26607 "src/ocaml/preprocess/parser_raw.ml" +# 27041 "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) = -# 3969 "src/ocaml/preprocess/parser_raw.mly" +# 4176 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26615 "src/ocaml/preprocess/parser_raw.ml" +# 27049 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26643,18 +27077,18 @@ module Tables = struct } = _menhir_stack in let _3 : unit = Obj.magic _3 in let _2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 26649 "src/ocaml/preprocess/parser_raw.ml" +# 27083 "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) = -# 3970 "src/ocaml/preprocess/parser_raw.mly" +# 4177 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 26658 "src/ocaml/preprocess/parser_raw.ml" +# 27092 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26708,9 +27142,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1457 "src/ocaml/preprocess/parser_raw.mly" +# 1544 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc (Pmod_constraint(me, mty)) ) -# 26714 "src/ocaml/preprocess/parser_raw.ml" +# 27148 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26747,9 +27181,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.module_expr) = -# 1464 "src/ocaml/preprocess/parser_raw.mly" +# 1551 "src/ocaml/preprocess/parser_raw.mly" ( me (* TODO consider reloc *) ) -# 26753 "src/ocaml/preprocess/parser_raw.ml" +# 27187 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26800,25 +27234,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.module_expr) = let e = -# 1487 "src/ocaml/preprocess/parser_raw.mly" +# 1574 "src/ocaml/preprocess/parser_raw.mly" ( e ) -# 26806 "src/ocaml/preprocess/parser_raw.ml" +# 27240 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26813 "src/ocaml/preprocess/parser_raw.ml" +# 27247 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1472 "src/ocaml/preprocess/parser_raw.mly" +# 1559 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 26822 "src/ocaml/preprocess/parser_raw.ml" +# 27256 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26889,11 +27323,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3842 "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 ) -# 26897 "src/ocaml/preprocess/parser_raw.ml" +# 27331 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_ty_ = _endpos__1_ in @@ -26901,26 +27335,26 @@ module Tables = struct let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1489 "src/ocaml/preprocess/parser_raw.mly" +# 1576 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_constraint (e, ty)) ) -# 26907 "src/ocaml/preprocess/parser_raw.ml" +# 27341 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26915 "src/ocaml/preprocess/parser_raw.ml" +# 27349 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1472 "src/ocaml/preprocess/parser_raw.mly" +# 1559 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 26924 "src/ocaml/preprocess/parser_raw.ml" +# 27358 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27006,11 +27440,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3842 "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 ) -# 27014 "src/ocaml/preprocess/parser_raw.ml" +# 27448 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_ty2_ = _endpos__1_inlined1_ in @@ -27019,37 +27453,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3842 "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 ) -# 27027 "src/ocaml/preprocess/parser_raw.ml" +# 27461 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_ty2_ in let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1491 "src/ocaml/preprocess/parser_raw.mly" +# 1578 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, Some ty1, ty2)) ) -# 27036 "src/ocaml/preprocess/parser_raw.ml" +# 27470 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27044 "src/ocaml/preprocess/parser_raw.ml" +# 27478 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1472 "src/ocaml/preprocess/parser_raw.mly" +# 1559 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27053 "src/ocaml/preprocess/parser_raw.ml" +# 27487 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27120,11 +27554,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3842 "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 ) -# 27128 "src/ocaml/preprocess/parser_raw.ml" +# 27562 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_ty2_ = _endpos__1_ in @@ -27132,26 +27566,26 @@ module Tables = struct let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1493 "src/ocaml/preprocess/parser_raw.mly" +# 1580 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, None, ty2)) ) -# 27138 "src/ocaml/preprocess/parser_raw.ml" +# 27572 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27146 "src/ocaml/preprocess/parser_raw.ml" +# 27580 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1472 "src/ocaml/preprocess/parser_raw.mly" +# 1559 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27155 "src/ocaml/preprocess/parser_raw.ml" +# 27589 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27181,9 +27615,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1366 "src/ocaml/preprocess/parser_raw.mly" +# 1453 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27187 "src/ocaml/preprocess/parser_raw.ml" +# 27621 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27213,9 +27647,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1351 "src/ocaml/preprocess/parser_raw.mly" +# 1438 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27219 "src/ocaml/preprocess/parser_raw.ml" +# 27653 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27245,9 +27679,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = -# 1326 "src/ocaml/preprocess/parser_raw.mly" +# 1413 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27251 "src/ocaml/preprocess/parser_raw.ml" +# 27685 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27277,9 +27711,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 1331 "src/ocaml/preprocess/parser_raw.mly" +# 1418 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27283 "src/ocaml/preprocess/parser_raw.ml" +# 27717 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27309,9 +27743,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1356 "src/ocaml/preprocess/parser_raw.mly" +# 1443 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27315 "src/ocaml/preprocess/parser_raw.ml" +# 27749 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27341,9 +27775,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1361 "src/ocaml/preprocess/parser_raw.mly" +# 1448 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27347 "src/ocaml/preprocess/parser_raw.ml" +# 27781 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27373,9 +27807,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_expr) = -# 1321 "src/ocaml/preprocess/parser_raw.mly" +# 1408 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27379 "src/ocaml/preprocess/parser_raw.ml" +# 27813 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27405,9 +27839,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_type) = -# 1316 "src/ocaml/preprocess/parser_raw.mly" +# 1403 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27411 "src/ocaml/preprocess/parser_raw.ml" +# 27845 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27437,9 +27871,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1341 "src/ocaml/preprocess/parser_raw.mly" +# 1428 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27443 "src/ocaml/preprocess/parser_raw.ml" +# 27877 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27469,9 +27903,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = -# 1336 "src/ocaml/preprocess/parser_raw.mly" +# 1423 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27475 "src/ocaml/preprocess/parser_raw.ml" +# 27909 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27501,9 +27935,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1346 "src/ocaml/preprocess/parser_raw.mly" +# 1433 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27507 "src/ocaml/preprocess/parser_raw.ml" +# 27941 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27545,15 +27979,15 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2915 "src/ocaml/preprocess/parser_raw.mly" +# 3066 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 27551 "src/ocaml/preprocess/parser_raw.ml" +# 27985 "src/ocaml/preprocess/parser_raw.ml" in -# 2903 "src/ocaml/preprocess/parser_raw.mly" +# 3054 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27557 "src/ocaml/preprocess/parser_raw.ml" +# 27991 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27583,14 +28017,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = -# 2917 "src/ocaml/preprocess/parser_raw.mly" +# 3068 "src/ocaml/preprocess/parser_raw.mly" ( Pat.attr _1 _2 ) -# 27589 "src/ocaml/preprocess/parser_raw.ml" +# 28023 "src/ocaml/preprocess/parser_raw.ml" in -# 2903 "src/ocaml/preprocess/parser_raw.mly" +# 3054 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27594 "src/ocaml/preprocess/parser_raw.ml" +# 28028 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27613,14 +28047,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = -# 2919 "src/ocaml/preprocess/parser_raw.mly" +# 3070 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27619 "src/ocaml/preprocess/parser_raw.ml" +# 28053 "src/ocaml/preprocess/parser_raw.ml" in -# 2903 "src/ocaml/preprocess/parser_raw.mly" +# 3054 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27624 "src/ocaml/preprocess/parser_raw.ml" +# 28058 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27665,15 +28099,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 27671 "src/ocaml/preprocess/parser_raw.ml" +# 28105 "src/ocaml/preprocess/parser_raw.ml" in -# 2922 "src/ocaml/preprocess/parser_raw.mly" +# 3073 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_alias(_1, _3) ) -# 27677 "src/ocaml/preprocess/parser_raw.ml" +# 28111 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -27681,21 +28115,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 27687 "src/ocaml/preprocess/parser_raw.ml" +# 28121 "src/ocaml/preprocess/parser_raw.ml" in -# 2933 "src/ocaml/preprocess/parser_raw.mly" +# 3084 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27693 "src/ocaml/preprocess/parser_raw.ml" +# 28127 "src/ocaml/preprocess/parser_raw.ml" in -# 2903 "src/ocaml/preprocess/parser_raw.mly" +# 3054 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27699 "src/ocaml/preprocess/parser_raw.ml" +# 28133 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27720,29 +28154,29 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2926 "src/ocaml/preprocess/parser_raw.mly" +# 3077 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_tuple(List.rev _1) ) -# 27726 "src/ocaml/preprocess/parser_raw.ml" +# 28160 "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" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 27734 "src/ocaml/preprocess/parser_raw.ml" +# 28168 "src/ocaml/preprocess/parser_raw.ml" in -# 2933 "src/ocaml/preprocess/parser_raw.mly" +# 3084 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27740 "src/ocaml/preprocess/parser_raw.ml" +# 28174 "src/ocaml/preprocess/parser_raw.ml" in -# 2903 "src/ocaml/preprocess/parser_raw.mly" +# 3054 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27746 "src/ocaml/preprocess/parser_raw.ml" +# 28180 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27781,30 +28215,30 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2930 "src/ocaml/preprocess/parser_raw.mly" +# 3081 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_or(_1, _3) ) -# 27787 "src/ocaml/preprocess/parser_raw.ml" +# 28221 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 27796 "src/ocaml/preprocess/parser_raw.ml" +# 28230 "src/ocaml/preprocess/parser_raw.ml" in -# 2933 "src/ocaml/preprocess/parser_raw.mly" +# 3084 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27802 "src/ocaml/preprocess/parser_raw.ml" +# 28236 "src/ocaml/preprocess/parser_raw.ml" in -# 2903 "src/ocaml/preprocess/parser_raw.mly" +# 3054 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27808 "src/ocaml/preprocess/parser_raw.ml" +# 28242 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27852,24 +28286,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27858 "src/ocaml/preprocess/parser_raw.ml" +# 28292 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 27864 "src/ocaml/preprocess/parser_raw.ml" +# 28298 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2905 "src/ocaml/preprocess/parser_raw.mly" +# 3056 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_exception _3) _2) -# 27873 "src/ocaml/preprocess/parser_raw.ml" +# 28307 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27906,9 +28340,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3036 "src/ocaml/preprocess/parser_raw.mly" +# 3187 "src/ocaml/preprocess/parser_raw.mly" ( _3 :: _1 ) -# 27912 "src/ocaml/preprocess/parser_raw.ml" +# 28346 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27945,9 +28379,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3037 "src/ocaml/preprocess/parser_raw.mly" +# 3188 "src/ocaml/preprocess/parser_raw.mly" ( [_3; _1] ) -# 27951 "src/ocaml/preprocess/parser_raw.ml" +# 28385 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27984,9 +28418,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3036 "src/ocaml/preprocess/parser_raw.mly" +# 3187 "src/ocaml/preprocess/parser_raw.mly" ( _3 :: _1 ) -# 27990 "src/ocaml/preprocess/parser_raw.ml" +# 28424 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28023,9 +28457,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3037 "src/ocaml/preprocess/parser_raw.mly" +# 3188 "src/ocaml/preprocess/parser_raw.mly" ( [_3; _1] ) -# 28029 "src/ocaml/preprocess/parser_raw.ml" +# 28463 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28048,9 +28482,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2938 "src/ocaml/preprocess/parser_raw.mly" +# 3089 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28054 "src/ocaml/preprocess/parser_raw.ml" +# 28488 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28086,15 +28520,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28092 "src/ocaml/preprocess/parser_raw.ml" +# 28526 "src/ocaml/preprocess/parser_raw.ml" in -# 2941 "src/ocaml/preprocess/parser_raw.mly" +# 3092 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(_1, Some ([], _2)) ) -# 28098 "src/ocaml/preprocess/parser_raw.ml" +# 28532 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -28102,15 +28536,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28108 "src/ocaml/preprocess/parser_raw.ml" +# 28542 "src/ocaml/preprocess/parser_raw.ml" in -# 2947 "src/ocaml/preprocess/parser_raw.mly" +# 3098 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28114 "src/ocaml/preprocess/parser_raw.ml" +# 28548 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28170,24 +28604,24 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let newtypes = -# 2689 "src/ocaml/preprocess/parser_raw.mly" +# 2809 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 28176 "src/ocaml/preprocess/parser_raw.ml" +# 28610 "src/ocaml/preprocess/parser_raw.ml" in let constr = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28185 "src/ocaml/preprocess/parser_raw.ml" +# 28619 "src/ocaml/preprocess/parser_raw.ml" in -# 2944 "src/ocaml/preprocess/parser_raw.mly" +# 3095 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(constr, Some (newtypes, pat)) ) -# 28191 "src/ocaml/preprocess/parser_raw.ml" +# 28625 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_pat_ in @@ -28195,15 +28629,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28201 "src/ocaml/preprocess/parser_raw.ml" +# 28635 "src/ocaml/preprocess/parser_raw.ml" in -# 2947 "src/ocaml/preprocess/parser_raw.mly" +# 3098 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28207 "src/ocaml/preprocess/parser_raw.ml" +# 28641 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28234,24 +28668,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2946 "src/ocaml/preprocess/parser_raw.mly" +# 3097 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_variant(_1, Some _2) ) -# 28240 "src/ocaml/preprocess/parser_raw.ml" +# 28674 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28249 "src/ocaml/preprocess/parser_raw.ml" +# 28683 "src/ocaml/preprocess/parser_raw.ml" in -# 2947 "src/ocaml/preprocess/parser_raw.mly" +# 3098 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28255 "src/ocaml/preprocess/parser_raw.ml" +# 28689 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28299,24 +28733,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28305 "src/ocaml/preprocess/parser_raw.ml" +# 28739 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 28311 "src/ocaml/preprocess/parser_raw.ml" +# 28745 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2949 "src/ocaml/preprocess/parser_raw.mly" +# 3100 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_lazy _3) _2) -# 28320 "src/ocaml/preprocess/parser_raw.ml" +# 28754 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28358,15 +28792,15 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2915 "src/ocaml/preprocess/parser_raw.mly" +# 3066 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 28364 "src/ocaml/preprocess/parser_raw.ml" +# 28798 "src/ocaml/preprocess/parser_raw.ml" in -# 2910 "src/ocaml/preprocess/parser_raw.mly" +# 3061 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28370 "src/ocaml/preprocess/parser_raw.ml" +# 28804 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28396,14 +28830,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = -# 2917 "src/ocaml/preprocess/parser_raw.mly" +# 3068 "src/ocaml/preprocess/parser_raw.mly" ( Pat.attr _1 _2 ) -# 28402 "src/ocaml/preprocess/parser_raw.ml" +# 28836 "src/ocaml/preprocess/parser_raw.ml" in -# 2910 "src/ocaml/preprocess/parser_raw.mly" +# 3061 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28407 "src/ocaml/preprocess/parser_raw.ml" +# 28841 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28426,14 +28860,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = -# 2919 "src/ocaml/preprocess/parser_raw.mly" +# 3070 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28432 "src/ocaml/preprocess/parser_raw.ml" +# 28866 "src/ocaml/preprocess/parser_raw.ml" in -# 2910 "src/ocaml/preprocess/parser_raw.mly" +# 3061 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28437 "src/ocaml/preprocess/parser_raw.ml" +# 28871 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28478,15 +28912,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28484 "src/ocaml/preprocess/parser_raw.ml" +# 28918 "src/ocaml/preprocess/parser_raw.ml" in -# 2922 "src/ocaml/preprocess/parser_raw.mly" +# 3073 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_alias(_1, _3) ) -# 28490 "src/ocaml/preprocess/parser_raw.ml" +# 28924 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -28494,21 +28928,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28500 "src/ocaml/preprocess/parser_raw.ml" +# 28934 "src/ocaml/preprocess/parser_raw.ml" in -# 2933 "src/ocaml/preprocess/parser_raw.mly" +# 3084 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28506 "src/ocaml/preprocess/parser_raw.ml" +# 28940 "src/ocaml/preprocess/parser_raw.ml" in -# 2910 "src/ocaml/preprocess/parser_raw.mly" +# 3061 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28512 "src/ocaml/preprocess/parser_raw.ml" +# 28946 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28533,29 +28967,29 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2926 "src/ocaml/preprocess/parser_raw.mly" +# 3077 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_tuple(List.rev _1) ) -# 28539 "src/ocaml/preprocess/parser_raw.ml" +# 28973 "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" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28547 "src/ocaml/preprocess/parser_raw.ml" +# 28981 "src/ocaml/preprocess/parser_raw.ml" in -# 2933 "src/ocaml/preprocess/parser_raw.mly" +# 3084 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28553 "src/ocaml/preprocess/parser_raw.ml" +# 28987 "src/ocaml/preprocess/parser_raw.ml" in -# 2910 "src/ocaml/preprocess/parser_raw.mly" +# 3061 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28559 "src/ocaml/preprocess/parser_raw.ml" +# 28993 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28594,30 +29028,30 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 2930 "src/ocaml/preprocess/parser_raw.mly" +# 3081 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_or(_1, _3) ) -# 28600 "src/ocaml/preprocess/parser_raw.ml" +# 29034 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28609 "src/ocaml/preprocess/parser_raw.ml" +# 29043 "src/ocaml/preprocess/parser_raw.ml" in -# 2933 "src/ocaml/preprocess/parser_raw.mly" +# 3084 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28615 "src/ocaml/preprocess/parser_raw.ml" +# 29049 "src/ocaml/preprocess/parser_raw.ml" in -# 2910 "src/ocaml/preprocess/parser_raw.mly" +# 3061 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28621 "src/ocaml/preprocess/parser_raw.ml" +# 29055 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28636,9 +29070,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 28642 "src/ocaml/preprocess/parser_raw.ml" +# 29076 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -28650,30 +29084,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28656 "src/ocaml/preprocess/parser_raw.ml" +# 29090 "src/ocaml/preprocess/parser_raw.ml" in -# 2367 "src/ocaml/preprocess/parser_raw.mly" +# 2485 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_var _1 ) -# 28662 "src/ocaml/preprocess/parser_raw.ml" +# 29096 "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" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28671 "src/ocaml/preprocess/parser_raw.ml" +# 29105 "src/ocaml/preprocess/parser_raw.ml" in -# 2369 "src/ocaml/preprocess/parser_raw.mly" +# 2487 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28677 "src/ocaml/preprocess/parser_raw.ml" +# 29111 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28697,23 +29131,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2368 "src/ocaml/preprocess/parser_raw.mly" +# 2486 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_any ) -# 28703 "src/ocaml/preprocess/parser_raw.ml" +# 29137 "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" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28711 "src/ocaml/preprocess/parser_raw.ml" +# 29145 "src/ocaml/preprocess/parser_raw.ml" in -# 2369 "src/ocaml/preprocess/parser_raw.mly" +# 2487 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28717 "src/ocaml/preprocess/parser_raw.ml" +# 29151 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28736,9 +29170,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.payload) = -# 4081 "src/ocaml/preprocess/parser_raw.mly" +# 4288 "src/ocaml/preprocess/parser_raw.mly" ( PStr _1 ) -# 28742 "src/ocaml/preprocess/parser_raw.ml" +# 29176 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28768,9 +29202,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4082 "src/ocaml/preprocess/parser_raw.mly" +# 4289 "src/ocaml/preprocess/parser_raw.mly" ( PSig _2 ) -# 28774 "src/ocaml/preprocess/parser_raw.ml" +# 29208 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28800,9 +29234,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4083 "src/ocaml/preprocess/parser_raw.mly" +# 4290 "src/ocaml/preprocess/parser_raw.mly" ( PTyp _2 ) -# 28806 "src/ocaml/preprocess/parser_raw.ml" +# 29240 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28832,9 +29266,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4084 "src/ocaml/preprocess/parser_raw.mly" +# 4291 "src/ocaml/preprocess/parser_raw.mly" ( PPat (_2, None) ) -# 28838 "src/ocaml/preprocess/parser_raw.ml" +# 29272 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28878,9 +29312,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.payload) = -# 4085 "src/ocaml/preprocess/parser_raw.mly" +# 4292 "src/ocaml/preprocess/parser_raw.mly" ( PPat (_2, Some _4) ) -# 28884 "src/ocaml/preprocess/parser_raw.ml" +# 29318 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28903,9 +29337,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3474 "src/ocaml/preprocess/parser_raw.mly" +# 3625 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28909 "src/ocaml/preprocess/parser_raw.ml" +# 29343 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28948,24 +29382,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 28952 "src/ocaml/preprocess/parser_raw.ml" +# 29386 "src/ocaml/preprocess/parser_raw.ml" in -# 1098 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 28957 "src/ocaml/preprocess/parser_raw.ml" +# 29391 "src/ocaml/preprocess/parser_raw.ml" in -# 3466 "src/ocaml/preprocess/parser_raw.mly" +# 3617 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28963 "src/ocaml/preprocess/parser_raw.ml" +# 29397 "src/ocaml/preprocess/parser_raw.ml" in -# 3470 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 28969 "src/ocaml/preprocess/parser_raw.ml" +# 29403 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_xs_) in @@ -28973,15 +29407,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 28979 "src/ocaml/preprocess/parser_raw.ml" +# 29413 "src/ocaml/preprocess/parser_raw.ml" in -# 3476 "src/ocaml/preprocess/parser_raw.mly" +# 3627 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28985 "src/ocaml/preprocess/parser_raw.ml" +# 29419 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29004,14 +29438,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = -# 3505 "src/ocaml/preprocess/parser_raw.mly" +# 3656 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29010 "src/ocaml/preprocess/parser_raw.ml" +# 29444 "src/ocaml/preprocess/parser_raw.ml" in -# 3474 "src/ocaml/preprocess/parser_raw.mly" +# 3625 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29015 "src/ocaml/preprocess/parser_raw.ml" +# 29449 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29050,33 +29484,33 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let _3 = -# 3505 "src/ocaml/preprocess/parser_raw.mly" +# 3656 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29056 "src/ocaml/preprocess/parser_raw.ml" +# 29490 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 29063 "src/ocaml/preprocess/parser_raw.ml" +# 29497 "src/ocaml/preprocess/parser_raw.ml" in -# 1098 "src/ocaml/preprocess/parser_raw.mly" +# 1164 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 29068 "src/ocaml/preprocess/parser_raw.ml" +# 29502 "src/ocaml/preprocess/parser_raw.ml" in -# 3466 "src/ocaml/preprocess/parser_raw.mly" +# 3617 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29074 "src/ocaml/preprocess/parser_raw.ml" +# 29508 "src/ocaml/preprocess/parser_raw.ml" in -# 3470 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 29080 "src/ocaml/preprocess/parser_raw.ml" +# 29514 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_xs_ in @@ -29084,15 +29518,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 29090 "src/ocaml/preprocess/parser_raw.ml" +# 29524 "src/ocaml/preprocess/parser_raw.ml" in -# 3476 "src/ocaml/preprocess/parser_raw.mly" +# 3627 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29096 "src/ocaml/preprocess/parser_raw.ml" +# 29530 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29139,9 +29573,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4042 "src/ocaml/preprocess/parser_raw.mly" - ( Attr.mk ~loc:(make_loc _sloc) _2 _3 ) -# 29145 "src/ocaml/preprocess/parser_raw.ml" +# 4249 "src/ocaml/preprocess/parser_raw.mly" + ( mk_attr ~loc:(make_loc _sloc) _2 _3 ) +# 29579 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29222,9 +29656,9 @@ module Tables = struct let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29228 "src/ocaml/preprocess/parser_raw.ml" +# 29662 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -29234,30 +29668,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 29240 "src/ocaml/preprocess/parser_raw.ml" +# 29674 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29248 "src/ocaml/preprocess/parser_raw.ml" +# 29682 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3100 "src/ocaml/preprocess/parser_raw.mly" +# 3251 "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 ) -# 29261 "src/ocaml/preprocess/parser_raw.ml" +# 29695 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29273,14 +29707,14 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.private_flag) = let _1 = -# 3910 "src/ocaml/preprocess/parser_raw.mly" +# 4117 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 29279 "src/ocaml/preprocess/parser_raw.ml" +# 29713 "src/ocaml/preprocess/parser_raw.ml" in -# 3907 "src/ocaml/preprocess/parser_raw.mly" +# 4114 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29284 "src/ocaml/preprocess/parser_raw.ml" +# 29718 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29303,14 +29737,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = let _1 = -# 3911 "src/ocaml/preprocess/parser_raw.mly" +# 4118 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 29309 "src/ocaml/preprocess/parser_raw.ml" +# 29743 "src/ocaml/preprocess/parser_raw.ml" in -# 3907 "src/ocaml/preprocess/parser_raw.mly" +# 4114 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29314 "src/ocaml/preprocess/parser_raw.ml" +# 29748 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29326,9 +29760,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3933 "src/ocaml/preprocess/parser_raw.mly" +# 4140 "src/ocaml/preprocess/parser_raw.mly" ( Public, Concrete ) -# 29332 "src/ocaml/preprocess/parser_raw.ml" +# 29766 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29351,9 +29785,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3934 "src/ocaml/preprocess/parser_raw.mly" +# 4141 "src/ocaml/preprocess/parser_raw.mly" ( Private, Concrete ) -# 29357 "src/ocaml/preprocess/parser_raw.ml" +# 29791 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29376,9 +29810,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3935 "src/ocaml/preprocess/parser_raw.mly" +# 4142 "src/ocaml/preprocess/parser_raw.mly" ( Public, Virtual ) -# 29382 "src/ocaml/preprocess/parser_raw.ml" +# 29816 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29408,9 +29842,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3936 "src/ocaml/preprocess/parser_raw.mly" +# 4143 "src/ocaml/preprocess/parser_raw.mly" ( Private, Virtual ) -# 29414 "src/ocaml/preprocess/parser_raw.ml" +# 29848 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29440,9 +29874,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 3937 "src/ocaml/preprocess/parser_raw.mly" +# 4144 "src/ocaml/preprocess/parser_raw.mly" ( Private, Virtual ) -# 29446 "src/ocaml/preprocess/parser_raw.ml" +# 29880 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29458,9 +29892,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.rec_flag) = -# 3888 "src/ocaml/preprocess/parser_raw.mly" +# 4095 "src/ocaml/preprocess/parser_raw.mly" ( Nonrecursive ) -# 29464 "src/ocaml/preprocess/parser_raw.ml" +# 29898 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29483,9 +29917,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.rec_flag) = -# 3889 "src/ocaml/preprocess/parser_raw.mly" +# 4096 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 29489 "src/ocaml/preprocess/parser_raw.ml" +# 29923 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29511,12 +29945,12 @@ module Tables = struct (Longident.t Location.loc * Parsetree.expression) list) = let eo = # 124 "" ( None ) -# 29515 "src/ocaml/preprocess/parser_raw.ml" +# 29949 "src/ocaml/preprocess/parser_raw.ml" in -# 2835 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( eo, fields ) -# 29520 "src/ocaml/preprocess/parser_raw.ml" +# 29954 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29557,18 +29991,18 @@ module Tables = struct let x = # 191 "" ( x ) -# 29561 "src/ocaml/preprocess/parser_raw.ml" +# 29995 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 29566 "src/ocaml/preprocess/parser_raw.ml" +# 30000 "src/ocaml/preprocess/parser_raw.ml" in -# 2835 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( eo, fields ) -# 29572 "src/ocaml/preprocess/parser_raw.ml" +# 30006 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29593,17 +30027,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3287 "src/ocaml/preprocess/parser_raw.mly" +# 3438 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29602 "src/ocaml/preprocess/parser_raw.ml" +# 30036 "src/ocaml/preprocess/parser_raw.ml" in -# 1208 "src/ocaml/preprocess/parser_raw.mly" +# 1295 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29607 "src/ocaml/preprocess/parser_raw.ml" +# 30041 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29628,17 +30062,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3287 "src/ocaml/preprocess/parser_raw.mly" +# 3438 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29637 "src/ocaml/preprocess/parser_raw.ml" +# 30071 "src/ocaml/preprocess/parser_raw.ml" in -# 1211 "src/ocaml/preprocess/parser_raw.mly" +# 1298 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29642 "src/ocaml/preprocess/parser_raw.ml" +# 30076 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29670,17 +30104,17 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3287 "src/ocaml/preprocess/parser_raw.mly" +# 3438 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29679 "src/ocaml/preprocess/parser_raw.ml" +# 30113 "src/ocaml/preprocess/parser_raw.ml" in -# 1215 "src/ocaml/preprocess/parser_raw.mly" +# 1302 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29684 "src/ocaml/preprocess/parser_raw.ml" +# 30118 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29706,23 +30140,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3404 "src/ocaml/preprocess/parser_raw.mly" +# 3555 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29715 "src/ocaml/preprocess/parser_raw.ml" +# 30149 "src/ocaml/preprocess/parser_raw.ml" in -# 3398 "src/ocaml/preprocess/parser_raw.mly" +# 3549 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29720 "src/ocaml/preprocess/parser_raw.ml" +# 30154 "src/ocaml/preprocess/parser_raw.ml" in -# 1208 "src/ocaml/preprocess/parser_raw.mly" +# 1295 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29726 "src/ocaml/preprocess/parser_raw.ml" +# 30160 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29745,14 +30179,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3400 "src/ocaml/preprocess/parser_raw.mly" +# 3551 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29751 "src/ocaml/preprocess/parser_raw.ml" +# 30185 "src/ocaml/preprocess/parser_raw.ml" in -# 1208 "src/ocaml/preprocess/parser_raw.mly" +# 1295 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29756 "src/ocaml/preprocess/parser_raw.ml" +# 30190 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29778,23 +30212,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3404 "src/ocaml/preprocess/parser_raw.mly" +# 3555 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29787 "src/ocaml/preprocess/parser_raw.ml" +# 30221 "src/ocaml/preprocess/parser_raw.ml" in -# 3398 "src/ocaml/preprocess/parser_raw.mly" +# 3549 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29792 "src/ocaml/preprocess/parser_raw.ml" +# 30226 "src/ocaml/preprocess/parser_raw.ml" in -# 1211 "src/ocaml/preprocess/parser_raw.mly" +# 1298 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29798 "src/ocaml/preprocess/parser_raw.ml" +# 30232 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29817,14 +30251,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3400 "src/ocaml/preprocess/parser_raw.mly" +# 3551 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29823 "src/ocaml/preprocess/parser_raw.ml" +# 30257 "src/ocaml/preprocess/parser_raw.ml" in -# 1211 "src/ocaml/preprocess/parser_raw.mly" +# 1298 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29828 "src/ocaml/preprocess/parser_raw.ml" +# 30262 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29857,23 +30291,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3404 "src/ocaml/preprocess/parser_raw.mly" +# 3555 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29866 "src/ocaml/preprocess/parser_raw.ml" +# 30300 "src/ocaml/preprocess/parser_raw.ml" in -# 3398 "src/ocaml/preprocess/parser_raw.mly" +# 3549 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29871 "src/ocaml/preprocess/parser_raw.ml" +# 30305 "src/ocaml/preprocess/parser_raw.ml" in -# 1215 "src/ocaml/preprocess/parser_raw.mly" +# 1302 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29877 "src/ocaml/preprocess/parser_raw.ml" +# 30311 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29903,14 +30337,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3400 "src/ocaml/preprocess/parser_raw.mly" +# 3551 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29909 "src/ocaml/preprocess/parser_raw.ml" +# 30343 "src/ocaml/preprocess/parser_raw.ml" in -# 1215 "src/ocaml/preprocess/parser_raw.mly" +# 1302 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 29914 "src/ocaml/preprocess/parser_raw.ml" +# 30348 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29935,17 +30369,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3404 "src/ocaml/preprocess/parser_raw.mly" +# 3555 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29944 "src/ocaml/preprocess/parser_raw.ml" +# 30378 "src/ocaml/preprocess/parser_raw.ml" in -# 1208 "src/ocaml/preprocess/parser_raw.mly" +# 1295 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29949 "src/ocaml/preprocess/parser_raw.ml" +# 30383 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29970,17 +30404,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3404 "src/ocaml/preprocess/parser_raw.mly" +# 3555 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 29979 "src/ocaml/preprocess/parser_raw.ml" +# 30413 "src/ocaml/preprocess/parser_raw.ml" in -# 1211 "src/ocaml/preprocess/parser_raw.mly" +# 1298 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 29984 "src/ocaml/preprocess/parser_raw.ml" +# 30418 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30012,17 +30446,17 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3404 "src/ocaml/preprocess/parser_raw.mly" +# 3555 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30021 "src/ocaml/preprocess/parser_raw.ml" +# 30455 "src/ocaml/preprocess/parser_raw.ml" in -# 1215 "src/ocaml/preprocess/parser_raw.mly" +# 1302 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30026 "src/ocaml/preprocess/parser_raw.ml" +# 30460 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30038,9 +30472,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1140 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 30044 "src/ocaml/preprocess/parser_raw.ml" +# 30478 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30097,21 +30531,78 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2247 "src/ocaml/preprocess/parser_raw.mly" +# 2334 "src/ocaml/preprocess/parser_raw.mly" ( _1, _3, make_loc _sloc ) -# 30103 "src/ocaml/preprocess/parser_raw.ml" +# 30537 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 30109 "src/ocaml/preprocess/parser_raw.ml" +# 30543 "src/ocaml/preprocess/parser_raw.ml" in -# 1076 "src/ocaml/preprocess/parser_raw.mly" +# 1142 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30115 "src/ocaml/preprocess/parser_raw.ml" +# 30549 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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.function_param list) = 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.function_param list) = +# 1173 "src/ocaml/preprocess/parser_raw.mly" + ( List.rev x ) +# 30574 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 : (Parsetree.function_param list) = Obj.magic x in + let xs : (Parsetree.function_param 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.function_param list) = +# 1175 "src/ocaml/preprocess/parser_raw.mly" + ( List.rev_append x xs ) +# 30606 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30134,9 +30625,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1088 "src/ocaml/preprocess/parser_raw.mly" +# 1154 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30140 "src/ocaml/preprocess/parser_raw.ml" +# 30631 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30166,9 +30657,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1090 "src/ocaml/preprocess/parser_raw.mly" +# 1156 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30172 "src/ocaml/preprocess/parser_raw.ml" +# 30663 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30191,9 +30682,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Asttypes.arg_label * Parsetree.expression) list) = -# 1088 "src/ocaml/preprocess/parser_raw.mly" +# 1154 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30197 "src/ocaml/preprocess/parser_raw.ml" +# 30688 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30223,9 +30714,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Asttypes.arg_label * Parsetree.expression) list) = -# 1090 "src/ocaml/preprocess/parser_raw.mly" +# 1156 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30229 "src/ocaml/preprocess/parser_raw.ml" +# 30720 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30248,9 +30739,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (string list) = -# 1088 "src/ocaml/preprocess/parser_raw.mly" +# 1154 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30254 "src/ocaml/preprocess/parser_raw.ml" +# 30745 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30280,9 +30771,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (string list) = -# 1090 "src/ocaml/preprocess/parser_raw.mly" +# 1156 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30286 "src/ocaml/preprocess/parser_raw.ml" +# 30777 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30295,9 +30786,9 @@ module Tables = struct 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.semv = _2; + MenhirLib.EngineTypes.startp = _startpos__2_; + MenhirLib.EngineTypes.endp = _endpos__2_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _menhir_s; MenhirLib.EngineTypes.semv = _1; @@ -30306,33 +30797,25 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; }; } = _menhir_stack in - let _1_inlined1 : (string) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _endpos = _endpos__2_ 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 - -# 996 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 30324 "src/ocaml/preprocess/parser_raw.ml" - - in + let _endpos = _endpos__2_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in -# 3462 "src/ocaml/preprocess/parser_raw.mly" - ( _2 ) -# 30330 "src/ocaml/preprocess/parser_raw.ml" +# 3613 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _2 _sloc ) +# 30813 "src/ocaml/preprocess/parser_raw.ml" in -# 1088 "src/ocaml/preprocess/parser_raw.mly" +# 1154 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30336 "src/ocaml/preprocess/parser_raw.ml" +# 30819 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30345,9 +30828,9 @@ module Tables = struct 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.semv = _2; + MenhirLib.EngineTypes.startp = _startpos__2_; + MenhirLib.EngineTypes.endp = _endpos__2_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _1; @@ -30362,34 +30845,26 @@ module Tables = struct }; }; } = _menhir_stack in - let _1_inlined1 : (string) = Obj.magic _1_inlined1 in + let _2 : (string) = Obj.magic _2 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 _endpos = _endpos__2_ 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 - -# 996 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 30381 "src/ocaml/preprocess/parser_raw.ml" - - in + let _endpos = _endpos__2_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in -# 3462 "src/ocaml/preprocess/parser_raw.mly" - ( _2 ) -# 30387 "src/ocaml/preprocess/parser_raw.ml" +# 3613 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _2 _sloc ) +# 30862 "src/ocaml/preprocess/parser_raw.ml" in -# 1090 "src/ocaml/preprocess/parser_raw.mly" +# 1156 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30393 "src/ocaml/preprocess/parser_raw.ml" +# 30868 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30414,12 +30889,12 @@ module Tables = struct let _v : (Parsetree.case list) = let _1 = # 124 "" ( None ) -# 30418 "src/ocaml/preprocess/parser_raw.ml" +# 30893 "src/ocaml/preprocess/parser_raw.ml" in -# 1179 "src/ocaml/preprocess/parser_raw.mly" +# 1266 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30423 "src/ocaml/preprocess/parser_raw.ml" +# 30898 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30453,13 +30928,13 @@ module Tables = struct # 126 "" ( Some x ) -# 30457 "src/ocaml/preprocess/parser_raw.ml" +# 30932 "src/ocaml/preprocess/parser_raw.ml" in -# 1179 "src/ocaml/preprocess/parser_raw.mly" +# 1266 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30463 "src/ocaml/preprocess/parser_raw.ml" +# 30938 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30496,9 +30971,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.case list) = -# 1183 "src/ocaml/preprocess/parser_raw.mly" +# 1270 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30502 "src/ocaml/preprocess/parser_raw.ml" +# 30977 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30522,20 +30997,20 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type list) = let xs = let x = -# 3505 "src/ocaml/preprocess/parser_raw.mly" +# 3656 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30528 "src/ocaml/preprocess/parser_raw.ml" +# 31003 "src/ocaml/preprocess/parser_raw.ml" in -# 1114 "src/ocaml/preprocess/parser_raw.mly" +# 1201 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30533 "src/ocaml/preprocess/parser_raw.ml" +# 31008 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30539 "src/ocaml/preprocess/parser_raw.ml" +# 31014 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30573,20 +31048,20 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type list) = let xs = let x = -# 3505 "src/ocaml/preprocess/parser_raw.mly" +# 3656 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30579 "src/ocaml/preprocess/parser_raw.ml" +# 31054 "src/ocaml/preprocess/parser_raw.ml" in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1205 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30584 "src/ocaml/preprocess/parser_raw.ml" +# 31059 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30590 "src/ocaml/preprocess/parser_raw.ml" +# 31065 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30609,14 +31084,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.with_constraint list) = let xs = -# 1114 "src/ocaml/preprocess/parser_raw.mly" +# 1201 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30615 "src/ocaml/preprocess/parser_raw.ml" +# 31090 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30620 "src/ocaml/preprocess/parser_raw.ml" +# 31095 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30653,14 +31128,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.with_constraint list) = let xs = -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1205 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30659 "src/ocaml/preprocess/parser_raw.ml" +# 31134 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30664 "src/ocaml/preprocess/parser_raw.ml" +# 31139 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30683,14 +31158,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.row_field list) = let xs = -# 1114 "src/ocaml/preprocess/parser_raw.mly" +# 1201 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30689 "src/ocaml/preprocess/parser_raw.ml" +# 31164 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30694 "src/ocaml/preprocess/parser_raw.ml" +# 31169 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30727,14 +31202,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.row_field list) = let xs = -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1205 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30733 "src/ocaml/preprocess/parser_raw.ml" +# 31208 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30738 "src/ocaml/preprocess/parser_raw.ml" +# 31213 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30757,14 +31232,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1114 "src/ocaml/preprocess/parser_raw.mly" +# 1201 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30763 "src/ocaml/preprocess/parser_raw.ml" +# 31238 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30768 "src/ocaml/preprocess/parser_raw.ml" +# 31243 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30801,14 +31276,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1205 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30807 "src/ocaml/preprocess/parser_raw.ml" +# 31282 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30812 "src/ocaml/preprocess/parser_raw.ml" +# 31287 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30831,14 +31306,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = -# 1114 "src/ocaml/preprocess/parser_raw.mly" +# 1201 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30837 "src/ocaml/preprocess/parser_raw.ml" +# 31312 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30842 "src/ocaml/preprocess/parser_raw.ml" +# 31317 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30875,14 +31350,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1205 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30881 "src/ocaml/preprocess/parser_raw.ml" +# 31356 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30886 "src/ocaml/preprocess/parser_raw.ml" +# 31361 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30905,14 +31380,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1114 "src/ocaml/preprocess/parser_raw.mly" +# 1201 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30911 "src/ocaml/preprocess/parser_raw.ml" +# 31386 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30916 "src/ocaml/preprocess/parser_raw.ml" +# 31391 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30949,14 +31424,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1205 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30955 "src/ocaml/preprocess/parser_raw.ml" +# 31430 "src/ocaml/preprocess/parser_raw.ml" in -# 1122 "src/ocaml/preprocess/parser_raw.mly" +# 1209 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 30960 "src/ocaml/preprocess/parser_raw.ml" +# 31435 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30993,9 +31468,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = -# 1145 "src/ocaml/preprocess/parser_raw.mly" +# 1232 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30999 "src/ocaml/preprocess/parser_raw.ml" +# 31474 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31032,9 +31507,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.core_type list) = -# 1149 "src/ocaml/preprocess/parser_raw.mly" +# 1236 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31038 "src/ocaml/preprocess/parser_raw.ml" +# 31513 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31071,9 +31546,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.expression list) = -# 1145 "src/ocaml/preprocess/parser_raw.mly" +# 1232 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31077 "src/ocaml/preprocess/parser_raw.ml" +# 31552 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31110,9 +31585,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.expression list) = -# 1149 "src/ocaml/preprocess/parser_raw.mly" +# 1236 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31116 "src/ocaml/preprocess/parser_raw.ml" +# 31591 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31149,9 +31624,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = -# 1145 "src/ocaml/preprocess/parser_raw.mly" +# 1232 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31155 "src/ocaml/preprocess/parser_raw.ml" +# 31630 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31188,9 +31663,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.core_type list) = -# 1149 "src/ocaml/preprocess/parser_raw.mly" +# 1236 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31194 "src/ocaml/preprocess/parser_raw.ml" +# 31669 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31213,9 +31688,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.row_field) = -# 3645 "src/ocaml/preprocess/parser_raw.mly" +# 3852 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31219 "src/ocaml/preprocess/parser_raw.ml" +# 31694 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31241,9 +31716,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3647 "src/ocaml/preprocess/parser_raw.mly" +# 3854 "src/ocaml/preprocess/parser_raw.mly" ( Rf.inherit_ ~loc:(make_loc _sloc) _1 ) -# 31247 "src/ocaml/preprocess/parser_raw.ml" +# 31722 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31268,12 +31743,12 @@ module Tables = struct let _v : (Parsetree.expression list) = let _2 = # 124 "" ( None ) -# 31272 "src/ocaml/preprocess/parser_raw.ml" +# 31747 "src/ocaml/preprocess/parser_raw.ml" in -# 1166 "src/ocaml/preprocess/parser_raw.mly" +# 1253 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31277 "src/ocaml/preprocess/parser_raw.ml" +# 31752 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31307,13 +31782,13 @@ module Tables = struct # 126 "" ( Some x ) -# 31311 "src/ocaml/preprocess/parser_raw.ml" +# 31786 "src/ocaml/preprocess/parser_raw.ml" in -# 1166 "src/ocaml/preprocess/parser_raw.mly" +# 1253 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31317 "src/ocaml/preprocess/parser_raw.ml" +# 31792 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31350,9 +31825,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.expression list) = -# 1170 "src/ocaml/preprocess/parser_raw.mly" +# 1257 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31356 "src/ocaml/preprocess/parser_raw.ml" +# 31831 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31378,9 +31853,9 @@ module Tables = struct } = _menhir_stack in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31384 "src/ocaml/preprocess/parser_raw.ml" +# 31859 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31388,26 +31863,26 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 31392 "src/ocaml/preprocess/parser_raw.ml" +# 31867 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31399 "src/ocaml/preprocess/parser_raw.ml" +# 31874 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31407 "src/ocaml/preprocess/parser_raw.ml" +# 31882 "src/ocaml/preprocess/parser_raw.ml" in -# 2858 "src/ocaml/preprocess/parser_raw.mly" +# 3009 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31417,13 +31892,13 @@ module Tables = struct label, e in label, e ) -# 31421 "src/ocaml/preprocess/parser_raw.ml" +# 31896 "src/ocaml/preprocess/parser_raw.ml" in -# 1166 "src/ocaml/preprocess/parser_raw.mly" +# 1253 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31427 "src/ocaml/preprocess/parser_raw.ml" +# 31902 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31456,9 +31931,9 @@ module Tables = struct let x : unit = Obj.magic x in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31462 "src/ocaml/preprocess/parser_raw.ml" +# 31937 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31466,26 +31941,26 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 31470 "src/ocaml/preprocess/parser_raw.ml" +# 31945 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31477 "src/ocaml/preprocess/parser_raw.ml" +# 31952 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31485 "src/ocaml/preprocess/parser_raw.ml" +# 31960 "src/ocaml/preprocess/parser_raw.ml" in -# 2858 "src/ocaml/preprocess/parser_raw.mly" +# 3009 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31495,13 +31970,13 @@ module Tables = struct label, e in label, e ) -# 31499 "src/ocaml/preprocess/parser_raw.ml" +# 31974 "src/ocaml/preprocess/parser_raw.ml" in -# 1166 "src/ocaml/preprocess/parser_raw.mly" +# 1253 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31505 "src/ocaml/preprocess/parser_raw.ml" +# 31980 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31541,9 +32016,9 @@ module Tables = struct let _2 : unit = Obj.magic _2 in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31547 "src/ocaml/preprocess/parser_raw.ml" +# 32022 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31551,21 +32026,21 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let x = let label = let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31557 "src/ocaml/preprocess/parser_raw.ml" +# 32032 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31565 "src/ocaml/preprocess/parser_raw.ml" +# 32040 "src/ocaml/preprocess/parser_raw.ml" in -# 2858 "src/ocaml/preprocess/parser_raw.mly" +# 3009 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31575,13 +32050,13 @@ module Tables = struct label, e in label, e ) -# 31579 "src/ocaml/preprocess/parser_raw.ml" +# 32054 "src/ocaml/preprocess/parser_raw.ml" in -# 1170 "src/ocaml/preprocess/parser_raw.mly" +# 1257 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31585 "src/ocaml/preprocess/parser_raw.ml" +# 32060 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31606,12 +32081,12 @@ module Tables = struct let _v : (Parsetree.pattern list) = let _2 = # 124 "" ( None ) -# 31610 "src/ocaml/preprocess/parser_raw.ml" +# 32085 "src/ocaml/preprocess/parser_raw.ml" in -# 1166 "src/ocaml/preprocess/parser_raw.mly" +# 1253 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31615 "src/ocaml/preprocess/parser_raw.ml" +# 32090 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31645,13 +32120,13 @@ module Tables = struct # 126 "" ( Some x ) -# 31649 "src/ocaml/preprocess/parser_raw.ml" +# 32124 "src/ocaml/preprocess/parser_raw.ml" in -# 1166 "src/ocaml/preprocess/parser_raw.mly" +# 1253 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31655 "src/ocaml/preprocess/parser_raw.ml" +# 32130 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31688,9 +32163,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.pattern list) = -# 1170 "src/ocaml/preprocess/parser_raw.mly" +# 1257 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31694 "src/ocaml/preprocess/parser_raw.ml" +# 32169 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31721,7 +32196,7 @@ module Tables = struct }; } = _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 c : (Parsetree.type_constraint 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 @@ -31729,7 +32204,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 31733 "src/ocaml/preprocess/parser_raw.ml" +# 32208 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -31737,9 +32212,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31743 "src/ocaml/preprocess/parser_raw.ml" +# 32218 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -31747,7 +32222,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2841 "src/ocaml/preprocess/parser_raw.mly" +# 2992 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -31757,13 +32232,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 31761 "src/ocaml/preprocess/parser_raw.ml" +# 32236 "src/ocaml/preprocess/parser_raw.ml" in -# 1166 "src/ocaml/preprocess/parser_raw.mly" +# 1253 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31767 "src/ocaml/preprocess/parser_raw.ml" +# 32242 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31801,7 +32276,7 @@ module Tables = struct } = _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 c : (Parsetree.type_constraint 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 @@ -31809,7 +32284,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 31813 "src/ocaml/preprocess/parser_raw.ml" +# 32288 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -31817,9 +32292,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31823 "src/ocaml/preprocess/parser_raw.ml" +# 32298 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -31827,7 +32302,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2841 "src/ocaml/preprocess/parser_raw.mly" +# 2992 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -31837,13 +32312,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 31841 "src/ocaml/preprocess/parser_raw.ml" +# 32316 "src/ocaml/preprocess/parser_raw.ml" in -# 1166 "src/ocaml/preprocess/parser_raw.mly" +# 1253 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31847 "src/ocaml/preprocess/parser_raw.ml" +# 32322 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31888,7 +32363,7 @@ module Tables = struct 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 c : (Parsetree.type_constraint 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 @@ -31899,9 +32374,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31905 "src/ocaml/preprocess/parser_raw.ml" +# 32380 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -31909,7 +32384,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2841 "src/ocaml/preprocess/parser_raw.mly" +# 2992 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -31919,13 +32394,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 31923 "src/ocaml/preprocess/parser_raw.ml" +# 32398 "src/ocaml/preprocess/parser_raw.ml" in -# 1170 "src/ocaml/preprocess/parser_raw.mly" +# 1257 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31929 "src/ocaml/preprocess/parser_raw.ml" +# 32404 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31947,42 +32422,15 @@ module Tables = struct let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in - let _v : (Parsetree.expression) = -# 2336 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 31954 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.expression) = let _1 = +# 2424 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 32429 "src/ocaml/preprocess/parser_raw.ml" in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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) = -# 2337 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 31986 "src/ocaml/preprocess/parser_raw.ml" + +# 2462 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 32434 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31995,107 +32443,97 @@ module Tables = struct 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.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.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 _2 : unit = Obj.magic _2 in - let _1 : (Parsetree.expression) = Obj.magic _1 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__3_ in + let _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = - let _1 = -# 2339 "src/ocaml/preprocess/parser_raw.mly" - ( Pexp_sequence(_1, _3) ) -# 32026 "src/ocaml/preprocess/parser_raw.ml" - in - let _endpos__1_ = _endpos__3_ in - let _endpos = _endpos__1_ in + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 32483 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1278 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 32488 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2928 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 32494 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4262 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 32505 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4275 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 32511 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" - ( mkexp ~loc:_sloc _1 ) -# 32035 "src/ocaml/preprocess/parser_raw.ml" +# 2426 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 32531 "src/ocaml/preprocess/parser_raw.ml" in -# 2340 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 32041 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 2342 "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)) ) -# 32099 "src/ocaml/preprocess/parser_raw.ml" +# 2462 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 32537 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32163,18 +32601,18 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = let attrs = let _1 = _1_inlined4 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32169 "src/ocaml/preprocess/parser_raw.ml" +# 32607 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined4_ in let attrs2 = let _1 = _1_inlined3 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32178 "src/ocaml/preprocess/parser_raw.ml" +# 32616 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -32184,17 +32622,17 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32190 "src/ocaml/preprocess/parser_raw.ml" +# 32628 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32198 "src/ocaml/preprocess/parser_raw.ml" +# 32636 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in @@ -32202,14 +32640,14 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3317 "src/ocaml/preprocess/parser_raw.mly" +# 3468 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let loc = make_loc (_startpos, _endpos_attrs2_) in let docs = symbol_docs _sloc in Te.mk_exception ~attrs (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) , ext ) -# 32213 "src/ocaml/preprocess/parser_raw.ml" +# 32651 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32235,21 +32673,21 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 32239 "src/ocaml/preprocess/parser_raw.ml" +# 32677 "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 -# 989 "src/ocaml/preprocess/parser_raw.mly" +# 1055 "src/ocaml/preprocess/parser_raw.mly" ( extra_sig _startpos _endpos _1 ) -# 32247 "src/ocaml/preprocess/parser_raw.ml" +# 32685 "src/ocaml/preprocess/parser_raw.ml" in -# 1771 "src/ocaml/preprocess/parser_raw.mly" +# 1858 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32253 "src/ocaml/preprocess/parser_raw.ml" +# 32691 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32281,9 +32719,9 @@ module Tables = struct let _v : (Parsetree.signature_item) = let _2 = let _1 = _1_inlined1 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32287 "src/ocaml/preprocess/parser_raw.ml" +# 32725 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -32291,10 +32729,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1786 "src/ocaml/preprocess/parser_raw.mly" +# 1873 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mksig ~loc:_sloc (Psig_extension (_1, (add_docs_attrs docs _2))) ) -# 32298 "src/ocaml/preprocess/parser_raw.ml" +# 32736 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32318,23 +32756,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1790 "src/ocaml/preprocess/parser_raw.mly" +# 1877 "src/ocaml/preprocess/parser_raw.mly" ( Psig_attribute _1 ) -# 32324 "src/ocaml/preprocess/parser_raw.ml" +# 32762 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1037 "src/ocaml/preprocess/parser_raw.mly" +# 1103 "src/ocaml/preprocess/parser_raw.mly" ( mksig ~loc:_sloc _1 ) -# 32332 "src/ocaml/preprocess/parser_raw.ml" +# 32770 "src/ocaml/preprocess/parser_raw.ml" in -# 1792 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32338 "src/ocaml/preprocess/parser_raw.ml" +# 32776 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32358,23 +32796,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1795 "src/ocaml/preprocess/parser_raw.mly" +# 1882 "src/ocaml/preprocess/parser_raw.mly" ( psig_value _1 ) -# 32364 "src/ocaml/preprocess/parser_raw.ml" +# 32802 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32372 "src/ocaml/preprocess/parser_raw.ml" +# 32810 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32378 "src/ocaml/preprocess/parser_raw.ml" +# 32816 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32398,23 +32836,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1797 "src/ocaml/preprocess/parser_raw.mly" +# 1884 "src/ocaml/preprocess/parser_raw.mly" ( psig_value _1 ) -# 32404 "src/ocaml/preprocess/parser_raw.ml" +# 32842 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32412 "src/ocaml/preprocess/parser_raw.ml" +# 32850 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32418 "src/ocaml/preprocess/parser_raw.ml" +# 32856 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32449,26 +32887,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1227 "src/ocaml/preprocess/parser_raw.mly" +# 1314 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 32455 "src/ocaml/preprocess/parser_raw.ml" +# 32893 "src/ocaml/preprocess/parser_raw.ml" in -# 3136 "src/ocaml/preprocess/parser_raw.mly" +# 3287 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32460 "src/ocaml/preprocess/parser_raw.ml" +# 32898 "src/ocaml/preprocess/parser_raw.ml" in -# 3119 "src/ocaml/preprocess/parser_raw.mly" +# 3270 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32466 "src/ocaml/preprocess/parser_raw.ml" +# 32904 "src/ocaml/preprocess/parser_raw.ml" in -# 1799 "src/ocaml/preprocess/parser_raw.mly" +# 1886 "src/ocaml/preprocess/parser_raw.mly" ( psig_type _1 ) -# 32472 "src/ocaml/preprocess/parser_raw.ml" +# 32910 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -32476,15 +32914,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32482 "src/ocaml/preprocess/parser_raw.ml" +# 32920 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32488 "src/ocaml/preprocess/parser_raw.ml" +# 32926 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32519,26 +32957,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1227 "src/ocaml/preprocess/parser_raw.mly" +# 1314 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 32525 "src/ocaml/preprocess/parser_raw.ml" +# 32963 "src/ocaml/preprocess/parser_raw.ml" in -# 3136 "src/ocaml/preprocess/parser_raw.mly" +# 3287 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32530 "src/ocaml/preprocess/parser_raw.ml" +# 32968 "src/ocaml/preprocess/parser_raw.ml" in -# 3124 "src/ocaml/preprocess/parser_raw.mly" +# 3275 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32536 "src/ocaml/preprocess/parser_raw.ml" +# 32974 "src/ocaml/preprocess/parser_raw.ml" in -# 1801 "src/ocaml/preprocess/parser_raw.mly" +# 1888 "src/ocaml/preprocess/parser_raw.mly" ( psig_typesubst _1 ) -# 32542 "src/ocaml/preprocess/parser_raw.ml" +# 32980 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -32546,15 +32984,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32552 "src/ocaml/preprocess/parser_raw.ml" +# 32990 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32558 "src/ocaml/preprocess/parser_raw.ml" +# 32996 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32639,16 +33077,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32645 "src/ocaml/preprocess/parser_raw.ml" +# 33083 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = -# 1219 "src/ocaml/preprocess/parser_raw.mly" +# 1306 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 32652 "src/ocaml/preprocess/parser_raw.ml" +# 33090 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -32656,46 +33094,46 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32662 "src/ocaml/preprocess/parser_raw.ml" +# 33100 "src/ocaml/preprocess/parser_raw.ml" in let _4 = -# 3896 "src/ocaml/preprocess/parser_raw.mly" +# 4103 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 32668 "src/ocaml/preprocess/parser_raw.ml" +# 33106 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32675 "src/ocaml/preprocess/parser_raw.ml" +# 33113 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3391 "src/ocaml/preprocess/parser_raw.mly" +# 3542 "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 ) -# 32687 "src/ocaml/preprocess/parser_raw.ml" +# 33125 "src/ocaml/preprocess/parser_raw.ml" in -# 3378 "src/ocaml/preprocess/parser_raw.mly" +# 3529 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32693 "src/ocaml/preprocess/parser_raw.ml" +# 33131 "src/ocaml/preprocess/parser_raw.ml" in -# 1803 "src/ocaml/preprocess/parser_raw.mly" +# 1890 "src/ocaml/preprocess/parser_raw.mly" ( psig_typext _1 ) -# 32699 "src/ocaml/preprocess/parser_raw.ml" +# 33137 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -32703,15 +33141,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32709 "src/ocaml/preprocess/parser_raw.ml" +# 33147 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32715 "src/ocaml/preprocess/parser_raw.ml" +# 33153 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32803,16 +33241,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32809 "src/ocaml/preprocess/parser_raw.ml" +# 33247 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = -# 1219 "src/ocaml/preprocess/parser_raw.mly" +# 1306 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 32816 "src/ocaml/preprocess/parser_raw.ml" +# 33254 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -32820,9 +33258,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32826 "src/ocaml/preprocess/parser_raw.ml" +# 33264 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -32831,41 +33269,41 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3898 "src/ocaml/preprocess/parser_raw.mly" +# 4105 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 32837 "src/ocaml/preprocess/parser_raw.ml" +# 33275 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32845 "src/ocaml/preprocess/parser_raw.ml" +# 33283 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3391 "src/ocaml/preprocess/parser_raw.mly" +# 3542 "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 ) -# 32857 "src/ocaml/preprocess/parser_raw.ml" +# 33295 "src/ocaml/preprocess/parser_raw.ml" in -# 3378 "src/ocaml/preprocess/parser_raw.mly" +# 3529 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32863 "src/ocaml/preprocess/parser_raw.ml" +# 33301 "src/ocaml/preprocess/parser_raw.ml" in -# 1803 "src/ocaml/preprocess/parser_raw.mly" +# 1890 "src/ocaml/preprocess/parser_raw.mly" ( psig_typext _1 ) -# 32869 "src/ocaml/preprocess/parser_raw.ml" +# 33307 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -32873,15 +33311,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32879 "src/ocaml/preprocess/parser_raw.ml" +# 33317 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32885 "src/ocaml/preprocess/parser_raw.ml" +# 33323 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32905,23 +33343,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1805 "src/ocaml/preprocess/parser_raw.mly" +# 1892 "src/ocaml/preprocess/parser_raw.mly" ( psig_exception _1 ) -# 32911 "src/ocaml/preprocess/parser_raw.ml" +# 33349 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32919 "src/ocaml/preprocess/parser_raw.ml" +# 33357 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32925 "src/ocaml/preprocess/parser_raw.ml" +# 33363 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32984,9 +33422,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32990 "src/ocaml/preprocess/parser_raw.ml" +# 33428 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -32996,37 +33434,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33002 "src/ocaml/preprocess/parser_raw.ml" +# 33440 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33010 "src/ocaml/preprocess/parser_raw.ml" +# 33448 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1836 "src/ocaml/preprocess/parser_raw.mly" +# 1923 "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 ) -# 33024 "src/ocaml/preprocess/parser_raw.ml" +# 33462 "src/ocaml/preprocess/parser_raw.ml" in -# 1807 "src/ocaml/preprocess/parser_raw.mly" +# 1894 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 33030 "src/ocaml/preprocess/parser_raw.ml" +# 33468 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -33034,15 +33472,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33040 "src/ocaml/preprocess/parser_raw.ml" +# 33478 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33046 "src/ocaml/preprocess/parser_raw.ml" +# 33484 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33112,9 +33550,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33118 "src/ocaml/preprocess/parser_raw.ml" +# 33556 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -33125,9 +33563,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33131 "src/ocaml/preprocess/parser_raw.ml" +# 33569 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos_id_, _startpos_id_) = (_endpos__1_, _startpos__1_) in @@ -33135,9 +33573,9 @@ module Tables = struct let _symbolstartpos = _startpos_id_ in let _sloc = (_symbolstartpos, _endpos) in -# 1877 "src/ocaml/preprocess/parser_raw.mly" +# 1964 "src/ocaml/preprocess/parser_raw.mly" ( Mty.alias ~loc:(make_loc _sloc) id ) -# 33141 "src/ocaml/preprocess/parser_raw.ml" +# 33579 "src/ocaml/preprocess/parser_raw.ml" in let name = @@ -33146,37 +33584,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33152 "src/ocaml/preprocess/parser_raw.ml" +# 33590 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33160 "src/ocaml/preprocess/parser_raw.ml" +# 33598 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1868 "src/ocaml/preprocess/parser_raw.mly" +# 1955 "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 ) -# 33174 "src/ocaml/preprocess/parser_raw.ml" +# 33612 "src/ocaml/preprocess/parser_raw.ml" in -# 1809 "src/ocaml/preprocess/parser_raw.mly" +# 1896 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 33180 "src/ocaml/preprocess/parser_raw.ml" +# 33618 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -33184,15 +33622,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33190 "src/ocaml/preprocess/parser_raw.ml" +# 33628 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33196 "src/ocaml/preprocess/parser_raw.ml" +# 33634 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33216,23 +33654,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1811 "src/ocaml/preprocess/parser_raw.mly" +# 1898 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modsubst body, ext) ) -# 33222 "src/ocaml/preprocess/parser_raw.ml" +# 33660 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33230 "src/ocaml/preprocess/parser_raw.ml" +# 33668 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33236 "src/ocaml/preprocess/parser_raw.ml" +# 33674 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33318,9 +33756,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33324 "src/ocaml/preprocess/parser_raw.ml" +# 33762 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -33330,49 +33768,49 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33336 "src/ocaml/preprocess/parser_raw.ml" +# 33774 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33344 "src/ocaml/preprocess/parser_raw.ml" +# 33782 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1913 "src/ocaml/preprocess/parser_raw.mly" +# 2000 "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 ) -# 33358 "src/ocaml/preprocess/parser_raw.ml" +# 33796 "src/ocaml/preprocess/parser_raw.ml" in -# 1227 "src/ocaml/preprocess/parser_raw.mly" +# 1314 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 33364 "src/ocaml/preprocess/parser_raw.ml" +# 33802 "src/ocaml/preprocess/parser_raw.ml" in -# 1902 "src/ocaml/preprocess/parser_raw.mly" +# 1989 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33370 "src/ocaml/preprocess/parser_raw.ml" +# 33808 "src/ocaml/preprocess/parser_raw.ml" in -# 1813 "src/ocaml/preprocess/parser_raw.mly" +# 1900 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_recmodule l, ext) ) -# 33376 "src/ocaml/preprocess/parser_raw.ml" +# 33814 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -33380,15 +33818,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33386 "src/ocaml/preprocess/parser_raw.ml" +# 33824 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33392 "src/ocaml/preprocess/parser_raw.ml" +# 33830 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33412,23 +33850,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1815 "src/ocaml/preprocess/parser_raw.mly" +# 1902 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modtype body, ext) ) -# 33418 "src/ocaml/preprocess/parser_raw.ml" +# 33856 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33426 "src/ocaml/preprocess/parser_raw.ml" +# 33864 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33432 "src/ocaml/preprocess/parser_raw.ml" +# 33870 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33452,23 +33890,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1817 "src/ocaml/preprocess/parser_raw.mly" +# 1904 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modtypesubst body, ext) ) -# 33458 "src/ocaml/preprocess/parser_raw.ml" +# 33896 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33466 "src/ocaml/preprocess/parser_raw.ml" +# 33904 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33472 "src/ocaml/preprocess/parser_raw.ml" +# 33910 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33492,23 +33930,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1819 "src/ocaml/preprocess/parser_raw.mly" +# 1906 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_open body, ext) ) -# 33498 "src/ocaml/preprocess/parser_raw.ml" +# 33936 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33506 "src/ocaml/preprocess/parser_raw.ml" +# 33944 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33512 "src/ocaml/preprocess/parser_raw.ml" +# 33950 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33564,38 +34002,38 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33570 "src/ocaml/preprocess/parser_raw.ml" +# 34008 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33579 "src/ocaml/preprocess/parser_raw.ml" +# 34017 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1653 "src/ocaml/preprocess/parser_raw.mly" +# 1740 "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 ) -# 33593 "src/ocaml/preprocess/parser_raw.ml" +# 34031 "src/ocaml/preprocess/parser_raw.ml" in -# 1821 "src/ocaml/preprocess/parser_raw.mly" +# 1908 "src/ocaml/preprocess/parser_raw.mly" ( psig_include _1 ) -# 33599 "src/ocaml/preprocess/parser_raw.ml" +# 34037 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -33603,15 +34041,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33609 "src/ocaml/preprocess/parser_raw.ml" +# 34047 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33615 "src/ocaml/preprocess/parser_raw.ml" +# 34053 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33688,9 +34126,9 @@ module Tables = struct let cty : (Parsetree.class_type) = Obj.magic cty in let _7 : unit = Obj.magic _7 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 33694 "src/ocaml/preprocess/parser_raw.ml" +# 34132 "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 @@ -33708,9 +34146,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33714 "src/ocaml/preprocess/parser_raw.ml" +# 34152 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -33720,24 +34158,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33726 "src/ocaml/preprocess/parser_raw.ml" +# 34164 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33734 "src/ocaml/preprocess/parser_raw.ml" +# 34172 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2268 "src/ocaml/preprocess/parser_raw.mly" +# 2355 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -33745,25 +34183,25 @@ module Tables = struct ext, Ci.mk id cty ~virt ~params ~attrs ~loc ~docs ) -# 33749 "src/ocaml/preprocess/parser_raw.ml" +# 34187 "src/ocaml/preprocess/parser_raw.ml" in -# 1227 "src/ocaml/preprocess/parser_raw.mly" +# 1314 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 33755 "src/ocaml/preprocess/parser_raw.ml" +# 34193 "src/ocaml/preprocess/parser_raw.ml" in -# 2256 "src/ocaml/preprocess/parser_raw.mly" +# 2343 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33761 "src/ocaml/preprocess/parser_raw.ml" +# 34199 "src/ocaml/preprocess/parser_raw.ml" in -# 1823 "src/ocaml/preprocess/parser_raw.mly" +# 1910 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_class l, ext) ) -# 33767 "src/ocaml/preprocess/parser_raw.ml" +# 34205 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -33771,15 +34209,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33777 "src/ocaml/preprocess/parser_raw.ml" +# 34215 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33783 "src/ocaml/preprocess/parser_raw.ml" +# 34221 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33803,23 +34241,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1825 "src/ocaml/preprocess/parser_raw.mly" +# 1912 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_class_type l, ext) ) -# 33809 "src/ocaml/preprocess/parser_raw.ml" +# 34247 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1120 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33817 "src/ocaml/preprocess/parser_raw.ml" +# 34255 "src/ocaml/preprocess/parser_raw.ml" in -# 1827 "src/ocaml/preprocess/parser_raw.mly" +# 1914 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33823 "src/ocaml/preprocess/parser_raw.ml" +# 34261 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33842,9 +34280,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constant) = -# 3721 "src/ocaml/preprocess/parser_raw.mly" +# 3928 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33848 "src/ocaml/preprocess/parser_raw.ml" +# 34286 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33869,18 +34307,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 785 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33875 "src/ocaml/preprocess/parser_raw.ml" +# 34313 "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) = -# 3722 "src/ocaml/preprocess/parser_raw.mly" +# 3929 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _2 in Pconst_integer("-" ^ n, m) ) -# 33884 "src/ocaml/preprocess/parser_raw.ml" +# 34322 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33905,18 +34343,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 764 "src/ocaml/preprocess/parser_raw.mly" +# 830 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33911 "src/ocaml/preprocess/parser_raw.ml" +# 34349 "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) = -# 3723 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _2 in Pconst_float("-" ^ f, m) ) -# 33920 "src/ocaml/preprocess/parser_raw.ml" +# 34358 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33941,18 +34379,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 785 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33947 "src/ocaml/preprocess/parser_raw.ml" +# 34385 "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) = -# 3724 "src/ocaml/preprocess/parser_raw.mly" +# 3931 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _2 in Pconst_integer (n, m) ) -# 33956 "src/ocaml/preprocess/parser_raw.ml" +# 34394 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33977,18 +34415,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 764 "src/ocaml/preprocess/parser_raw.mly" +# 830 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 33983 "src/ocaml/preprocess/parser_raw.ml" +# 34421 "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) = -# 3725 "src/ocaml/preprocess/parser_raw.mly" +# 3932 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _2 in Pconst_float(f, m) ) -# 33992 "src/ocaml/preprocess/parser_raw.ml" +# 34430 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34029,18 +34467,18 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 3048 "src/ocaml/preprocess/parser_raw.mly" +# 3199 "src/ocaml/preprocess/parser_raw.mly" ( let fields, closed = _1 in let closed = match closed with Some () -> Open | None -> Closed in fields, closed ) -# 34037 "src/ocaml/preprocess/parser_raw.ml" +# 34475 "src/ocaml/preprocess/parser_raw.ml" in -# 3019 "src/ocaml/preprocess/parser_raw.mly" +# 3170 "src/ocaml/preprocess/parser_raw.mly" ( let (fields, closed) = _2 in Ppat_record(fields, closed) ) -# 34044 "src/ocaml/preprocess/parser_raw.ml" +# 34482 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34048,15 +34486,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34054 "src/ocaml/preprocess/parser_raw.ml" +# 34492 "src/ocaml/preprocess/parser_raw.ml" in -# 3033 "src/ocaml/preprocess/parser_raw.mly" +# 3184 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34060 "src/ocaml/preprocess/parser_raw.ml" +# 34498 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34095,15 +34533,15 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _2 = -# 3042 "src/ocaml/preprocess/parser_raw.mly" +# 3193 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 34101 "src/ocaml/preprocess/parser_raw.ml" +# 34539 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 3024 "src/ocaml/preprocess/parser_raw.mly" +# 3175 "src/ocaml/preprocess/parser_raw.mly" ( fst (mktailpat _loc__3_ _2) ) -# 34107 "src/ocaml/preprocess/parser_raw.ml" +# 34545 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34111,15 +34549,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34117 "src/ocaml/preprocess/parser_raw.ml" +# 34555 "src/ocaml/preprocess/parser_raw.ml" in -# 3033 "src/ocaml/preprocess/parser_raw.mly" +# 3184 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34123 "src/ocaml/preprocess/parser_raw.ml" +# 34561 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34158,14 +34596,14 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _2 = -# 3042 "src/ocaml/preprocess/parser_raw.mly" +# 3193 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 34164 "src/ocaml/preprocess/parser_raw.ml" +# 34602 "src/ocaml/preprocess/parser_raw.ml" in -# 3028 "src/ocaml/preprocess/parser_raw.mly" +# 3179 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_array _2 ) -# 34169 "src/ocaml/preprocess/parser_raw.ml" +# 34607 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34173,15 +34611,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34179 "src/ocaml/preprocess/parser_raw.ml" +# 34617 "src/ocaml/preprocess/parser_raw.ml" in -# 3033 "src/ocaml/preprocess/parser_raw.mly" +# 3184 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34185 "src/ocaml/preprocess/parser_raw.ml" +# 34623 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34212,24 +34650,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3030 "src/ocaml/preprocess/parser_raw.mly" +# 3181 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_array [] ) -# 34218 "src/ocaml/preprocess/parser_raw.ml" +# 34656 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34227 "src/ocaml/preprocess/parser_raw.ml" +# 34665 "src/ocaml/preprocess/parser_raw.ml" in -# 3033 "src/ocaml/preprocess/parser_raw.mly" +# 3184 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34233 "src/ocaml/preprocess/parser_raw.ml" +# 34671 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34268,9 +34706,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in let _startpos = _startpos__1_ in -# 4090 "src/ocaml/preprocess/parser_raw.mly" +# 4303 "src/ocaml/preprocess/parser_raw.mly" ( Fake.Meta.code _startpos _endpos _2 ) -# 34274 "src/ocaml/preprocess/parser_raw.ml" +# 34712 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34302,9 +34740,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _endpos = _endpos__2_ in let _startpos = _startpos__1_ in -# 4092 "src/ocaml/preprocess/parser_raw.mly" +# 4305 "src/ocaml/preprocess/parser_raw.mly" ( Fake.Meta.uncode _startpos _endpos _2 ) -# 34308 "src/ocaml/preprocess/parser_raw.ml" +# 34746 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34344,9 +34782,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2512 "src/ocaml/preprocess/parser_raw.mly" +# 2632 "src/ocaml/preprocess/parser_raw.mly" ( reloc_exp ~loc:_sloc _2 ) -# 34350 "src/ocaml/preprocess/parser_raw.ml" +# 34788 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34383,7 +34821,7 @@ module Tables = struct }; } = _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 _3 : (Parsetree.type_constraint) = 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 @@ -34393,9 +34831,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2518 "src/ocaml/preprocess/parser_raw.mly" +# 2638 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_constraint ~loc:_sloc _2 _3 ) -# 34399 "src/ocaml/preprocess/parser_raw.ml" +# 34837 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34447,14 +34885,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2519 "src/ocaml/preprocess/parser_raw.mly" +# 2639 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34453 "src/ocaml/preprocess/parser_raw.ml" +# 34891 "src/ocaml/preprocess/parser_raw.ml" in -# 2398 "src/ocaml/preprocess/parser_raw.mly" +# 2516 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 34458 "src/ocaml/preprocess/parser_raw.ml" +# 34896 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34462,9 +34900,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2520 "src/ocaml/preprocess/parser_raw.mly" +# 2640 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34468 "src/ocaml/preprocess/parser_raw.ml" +# 34906 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34516,14 +34954,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2519 "src/ocaml/preprocess/parser_raw.mly" +# 2639 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34522 "src/ocaml/preprocess/parser_raw.ml" +# 34960 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2518 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 34527 "src/ocaml/preprocess/parser_raw.ml" +# 34965 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34531,9 +34969,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2520 "src/ocaml/preprocess/parser_raw.mly" +# 2640 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34537 "src/ocaml/preprocess/parser_raw.ml" +# 34975 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34585,14 +35023,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2519 "src/ocaml/preprocess/parser_raw.mly" +# 2639 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34591 "src/ocaml/preprocess/parser_raw.ml" +# 35029 "src/ocaml/preprocess/parser_raw.ml" in -# 2402 "src/ocaml/preprocess/parser_raw.mly" +# 2520 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 34596 "src/ocaml/preprocess/parser_raw.ml" +# 35034 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34600,9 +35038,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2520 "src/ocaml/preprocess/parser_raw.mly" +# 2640 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34606 "src/ocaml/preprocess/parser_raw.ml" +# 35044 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34648,9 +35086,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34654 "src/ocaml/preprocess/parser_raw.ml" +# 35092 "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 @@ -34658,31 +35096,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2521 "src/ocaml/preprocess/parser_raw.mly" +# 2641 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34664 "src/ocaml/preprocess/parser_raw.ml" +# 35102 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34669 "src/ocaml/preprocess/parser_raw.ml" +# 35107 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 34675 "src/ocaml/preprocess/parser_raw.ml" +# 35113 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34680 "src/ocaml/preprocess/parser_raw.ml" +# 35118 "src/ocaml/preprocess/parser_raw.ml" in -# 2398 "src/ocaml/preprocess/parser_raw.mly" +# 2516 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 34686 "src/ocaml/preprocess/parser_raw.ml" +# 35124 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34690,9 +35128,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2522 "src/ocaml/preprocess/parser_raw.mly" +# 2642 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34696 "src/ocaml/preprocess/parser_raw.ml" +# 35134 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34750,9 +35188,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34756 "src/ocaml/preprocess/parser_raw.ml" +# 35194 "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 @@ -34762,39 +35200,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2521 "src/ocaml/preprocess/parser_raw.mly" +# 2641 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34768 "src/ocaml/preprocess/parser_raw.ml" +# 35206 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34773 "src/ocaml/preprocess/parser_raw.ml" +# 35211 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 34781 "src/ocaml/preprocess/parser_raw.ml" +# 35219 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 34786 "src/ocaml/preprocess/parser_raw.ml" +# 35224 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34792 "src/ocaml/preprocess/parser_raw.ml" +# 35230 "src/ocaml/preprocess/parser_raw.ml" in -# 2398 "src/ocaml/preprocess/parser_raw.mly" +# 2516 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 34798 "src/ocaml/preprocess/parser_raw.ml" +# 35236 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34802,9 +35240,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2522 "src/ocaml/preprocess/parser_raw.mly" +# 2642 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34808 "src/ocaml/preprocess/parser_raw.ml" +# 35246 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34850,9 +35288,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34856 "src/ocaml/preprocess/parser_raw.ml" +# 35294 "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 @@ -34860,31 +35298,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2521 "src/ocaml/preprocess/parser_raw.mly" +# 2641 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34866 "src/ocaml/preprocess/parser_raw.ml" +# 35304 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34871 "src/ocaml/preprocess/parser_raw.ml" +# 35309 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 34877 "src/ocaml/preprocess/parser_raw.ml" +# 35315 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34882 "src/ocaml/preprocess/parser_raw.ml" +# 35320 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2518 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 34888 "src/ocaml/preprocess/parser_raw.ml" +# 35326 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34892,9 +35330,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2522 "src/ocaml/preprocess/parser_raw.mly" +# 2642 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 34898 "src/ocaml/preprocess/parser_raw.ml" +# 35336 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34952,9 +35390,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34958 "src/ocaml/preprocess/parser_raw.ml" +# 35396 "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 @@ -34964,39 +35402,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2521 "src/ocaml/preprocess/parser_raw.mly" +# 2641 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34970 "src/ocaml/preprocess/parser_raw.ml" +# 35408 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 34975 "src/ocaml/preprocess/parser_raw.ml" +# 35413 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 34983 "src/ocaml/preprocess/parser_raw.ml" +# 35421 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 34988 "src/ocaml/preprocess/parser_raw.ml" +# 35426 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 34994 "src/ocaml/preprocess/parser_raw.ml" +# 35432 "src/ocaml/preprocess/parser_raw.ml" in -# 2400 "src/ocaml/preprocess/parser_raw.mly" +# 2518 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 35000 "src/ocaml/preprocess/parser_raw.ml" +# 35438 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35004,9 +35442,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2522 "src/ocaml/preprocess/parser_raw.mly" +# 2642 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35010 "src/ocaml/preprocess/parser_raw.ml" +# 35448 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35052,9 +35490,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35058 "src/ocaml/preprocess/parser_raw.ml" +# 35496 "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 @@ -35062,31 +35500,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2521 "src/ocaml/preprocess/parser_raw.mly" +# 2641 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35068 "src/ocaml/preprocess/parser_raw.ml" +# 35506 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35073 "src/ocaml/preprocess/parser_raw.ml" +# 35511 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 35079 "src/ocaml/preprocess/parser_raw.ml" +# 35517 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35084 "src/ocaml/preprocess/parser_raw.ml" +# 35522 "src/ocaml/preprocess/parser_raw.ml" in -# 2402 "src/ocaml/preprocess/parser_raw.mly" +# 2520 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35090 "src/ocaml/preprocess/parser_raw.ml" +# 35528 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35094,9 +35532,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2522 "src/ocaml/preprocess/parser_raw.mly" +# 2642 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35100 "src/ocaml/preprocess/parser_raw.ml" +# 35538 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35154,9 +35592,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35160 "src/ocaml/preprocess/parser_raw.ml" +# 35598 "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 @@ -35166,39 +35604,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2521 "src/ocaml/preprocess/parser_raw.mly" +# 2641 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35172 "src/ocaml/preprocess/parser_raw.ml" +# 35610 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35177 "src/ocaml/preprocess/parser_raw.ml" +# 35615 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 35185 "src/ocaml/preprocess/parser_raw.ml" +# 35623 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 35190 "src/ocaml/preprocess/parser_raw.ml" +# 35628 "src/ocaml/preprocess/parser_raw.ml" in -# 2414 "src/ocaml/preprocess/parser_raw.mly" +# 2532 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35196 "src/ocaml/preprocess/parser_raw.ml" +# 35634 "src/ocaml/preprocess/parser_raw.ml" in -# 2402 "src/ocaml/preprocess/parser_raw.mly" +# 2520 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35202 "src/ocaml/preprocess/parser_raw.ml" +# 35640 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35206,9 +35644,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2522 "src/ocaml/preprocess/parser_raw.mly" +# 2642 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35212 "src/ocaml/preprocess/parser_raw.ml" +# 35650 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35262,15 +35700,15 @@ module Tables = struct let attrs = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35268 "src/ocaml/preprocess/parser_raw.ml" +# 35706 "src/ocaml/preprocess/parser_raw.ml" in -# 2535 "src/ocaml/preprocess/parser_raw.mly" +# 2655 "src/ocaml/preprocess/parser_raw.mly" ( e.pexp_desc, (ext, attrs @ e.pexp_attributes) ) -# 35274 "src/ocaml/preprocess/parser_raw.ml" +# 35712 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -35278,10 +35716,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2528 "src/ocaml/preprocess/parser_raw.mly" +# 2648 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35285 "src/ocaml/preprocess/parser_raw.ml" +# 35723 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35330,24 +35768,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35336 "src/ocaml/preprocess/parser_raw.ml" +# 35774 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35342 "src/ocaml/preprocess/parser_raw.ml" +# 35780 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2537 "src/ocaml/preprocess/parser_raw.mly" +# 2657 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct (mkloc (Lident "()") (make_loc _sloc), None), _2 ) -# 35351 "src/ocaml/preprocess/parser_raw.ml" +# 35789 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -35355,10 +35793,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2528 "src/ocaml/preprocess/parser_raw.mly" +# 2648 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35362 "src/ocaml/preprocess/parser_raw.ml" +# 35800 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35408,9 +35846,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 35414 "src/ocaml/preprocess/parser_raw.ml" +# 35852 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -35418,21 +35856,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35424 "src/ocaml/preprocess/parser_raw.ml" +# 35862 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35430 "src/ocaml/preprocess/parser_raw.ml" +# 35868 "src/ocaml/preprocess/parser_raw.ml" in -# 2543 "src/ocaml/preprocess/parser_raw.mly" +# 2663 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_new(_3), _2 ) -# 35436 "src/ocaml/preprocess/parser_raw.ml" +# 35874 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -35440,10 +35878,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2528 "src/ocaml/preprocess/parser_raw.mly" +# 2648 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35447 "src/ocaml/preprocess/parser_raw.ml" +# 35885 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35506,21 +35944,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35512 "src/ocaml/preprocess/parser_raw.ml" +# 35950 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35518 "src/ocaml/preprocess/parser_raw.ml" +# 35956 "src/ocaml/preprocess/parser_raw.ml" in -# 2545 "src/ocaml/preprocess/parser_raw.mly" +# 2665 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_pack _4, _3 ) -# 35524 "src/ocaml/preprocess/parser_raw.ml" +# 35962 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -35528,10 +35966,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2528 "src/ocaml/preprocess/parser_raw.mly" +# 2648 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35535 "src/ocaml/preprocess/parser_raw.ml" +# 35973 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35609,11 +36047,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3842 "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 ) -# 35617 "src/ocaml/preprocess/parser_raw.ml" +# 36055 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -35621,24 +36059,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35627 "src/ocaml/preprocess/parser_raw.ml" +# 36065 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35633 "src/ocaml/preprocess/parser_raw.ml" +# 36071 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2547 "src/ocaml/preprocess/parser_raw.mly" +# 2667 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_constraint (ghexp ~loc:_sloc (Pexp_pack _4), _6), _3 ) -# 35642 "src/ocaml/preprocess/parser_raw.ml" +# 36080 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -35646,10 +36084,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2528 "src/ocaml/preprocess/parser_raw.mly" +# 2648 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35653 "src/ocaml/preprocess/parser_raw.ml" +# 36091 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35714,27 +36152,27 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 35718 "src/ocaml/preprocess/parser_raw.ml" +# 36156 "src/ocaml/preprocess/parser_raw.ml" in -# 2082 "src/ocaml/preprocess/parser_raw.mly" +# 2169 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35723 "src/ocaml/preprocess/parser_raw.ml" +# 36161 "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 -# 990 "src/ocaml/preprocess/parser_raw.mly" +# 1056 "src/ocaml/preprocess/parser_raw.mly" ( extra_cstr _startpos _endpos _1 ) -# 35732 "src/ocaml/preprocess/parser_raw.ml" +# 36170 "src/ocaml/preprocess/parser_raw.ml" in -# 2069 "src/ocaml/preprocess/parser_raw.mly" +# 2156 "src/ocaml/preprocess/parser_raw.mly" ( Cstr.mk _1 _2 ) -# 35738 "src/ocaml/preprocess/parser_raw.ml" +# 36176 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -35742,21 +36180,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35748 "src/ocaml/preprocess/parser_raw.ml" +# 36186 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35754 "src/ocaml/preprocess/parser_raw.ml" +# 36192 "src/ocaml/preprocess/parser_raw.ml" in -# 2553 "src/ocaml/preprocess/parser_raw.mly" +# 2673 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_object _3, _2 ) -# 35760 "src/ocaml/preprocess/parser_raw.ml" +# 36198 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -35764,10 +36202,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2528 "src/ocaml/preprocess/parser_raw.mly" +# 2648 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35771 "src/ocaml/preprocess/parser_raw.ml" +# 36209 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35796,30 +36234,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 35802 "src/ocaml/preprocess/parser_raw.ml" +# 36240 "src/ocaml/preprocess/parser_raw.ml" in -# 2561 "src/ocaml/preprocess/parser_raw.mly" +# 2681 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_ident (_1) ) -# 35808 "src/ocaml/preprocess/parser_raw.ml" +# 36246 "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" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35817 "src/ocaml/preprocess/parser_raw.ml" +# 36255 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35823 "src/ocaml/preprocess/parser_raw.ml" +# 36261 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35843,23 +36281,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2563 "src/ocaml/preprocess/parser_raw.mly" +# 2683 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_constant _1 ) -# 35849 "src/ocaml/preprocess/parser_raw.ml" +# 36287 "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" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35857 "src/ocaml/preprocess/parser_raw.ml" +# 36295 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35863 "src/ocaml/preprocess/parser_raw.ml" +# 36301 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35888,30 +36326,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 35894 "src/ocaml/preprocess/parser_raw.ml" +# 36332 "src/ocaml/preprocess/parser_raw.ml" in -# 2565 "src/ocaml/preprocess/parser_raw.mly" +# 2685 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct(_1, None) ) -# 35900 "src/ocaml/preprocess/parser_raw.ml" +# 36338 "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" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35909 "src/ocaml/preprocess/parser_raw.ml" +# 36347 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35915 "src/ocaml/preprocess/parser_raw.ml" +# 36353 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35935,23 +36373,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2567 "src/ocaml/preprocess/parser_raw.mly" +# 2687 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_variant(_1, None) ) -# 35941 "src/ocaml/preprocess/parser_raw.ml" +# 36379 "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" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 35949 "src/ocaml/preprocess/parser_raw.ml" +# 36387 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35955 "src/ocaml/preprocess/parser_raw.ml" +# 36393 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35977,9 +36415,9 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 823 "src/ocaml/preprocess/parser_raw.mly" +# 889 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35983 "src/ocaml/preprocess/parser_raw.ml" +# 36421 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -35991,15 +36429,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 35997 "src/ocaml/preprocess/parser_raw.ml" +# 36435 "src/ocaml/preprocess/parser_raw.ml" in -# 2569 "src/ocaml/preprocess/parser_raw.mly" +# 2689 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 36003 "src/ocaml/preprocess/parser_raw.ml" +# 36441 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -36007,15 +36445,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36013 "src/ocaml/preprocess/parser_raw.ml" +# 36451 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36019 "src/ocaml/preprocess/parser_raw.ml" +# 36457 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36048,23 +36486,23 @@ module Tables = struct let _1 = let _1 = let _1 = -# 2570 "src/ocaml/preprocess/parser_raw.mly" +# 2690 "src/ocaml/preprocess/parser_raw.mly" ("!") -# 36054 "src/ocaml/preprocess/parser_raw.ml" +# 36492 "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" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 36062 "src/ocaml/preprocess/parser_raw.ml" +# 36500 "src/ocaml/preprocess/parser_raw.ml" in -# 2571 "src/ocaml/preprocess/parser_raw.mly" +# 2691 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 36068 "src/ocaml/preprocess/parser_raw.ml" +# 36506 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -36072,15 +36510,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36078 "src/ocaml/preprocess/parser_raw.ml" +# 36516 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36084 "src/ocaml/preprocess/parser_raw.ml" +# 36522 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36119,14 +36557,14 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2853 "src/ocaml/preprocess/parser_raw.mly" +# 3004 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 36125 "src/ocaml/preprocess/parser_raw.ml" +# 36563 "src/ocaml/preprocess/parser_raw.ml" in -# 2573 "src/ocaml/preprocess/parser_raw.mly" +# 2693 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_override _2 ) -# 36130 "src/ocaml/preprocess/parser_raw.ml" +# 36568 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36134,15 +36572,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36140 "src/ocaml/preprocess/parser_raw.ml" +# 36578 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36146 "src/ocaml/preprocess/parser_raw.ml" +# 36584 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36173,24 +36611,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2579 "src/ocaml/preprocess/parser_raw.mly" +# 2699 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_override [] ) -# 36179 "src/ocaml/preprocess/parser_raw.ml" +# 36617 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36188 "src/ocaml/preprocess/parser_raw.ml" +# 36626 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36194 "src/ocaml/preprocess/parser_raw.ml" +# 36632 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36234,15 +36672,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36240 "src/ocaml/preprocess/parser_raw.ml" +# 36678 "src/ocaml/preprocess/parser_raw.ml" in -# 2581 "src/ocaml/preprocess/parser_raw.mly" +# 2701 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_field(_1, _3) ) -# 36246 "src/ocaml/preprocess/parser_raw.ml" +# 36684 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -36250,15 +36688,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36256 "src/ocaml/preprocess/parser_raw.ml" +# 36694 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36262 "src/ocaml/preprocess/parser_raw.ml" +# 36700 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36316,24 +36754,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36322 "src/ocaml/preprocess/parser_raw.ml" +# 36760 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1712 "src/ocaml/preprocess/parser_raw.mly" +# 1799 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36331 "src/ocaml/preprocess/parser_raw.ml" +# 36769 "src/ocaml/preprocess/parser_raw.ml" in -# 2583 "src/ocaml/preprocess/parser_raw.mly" +# 2703 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, _4) ) -# 36337 "src/ocaml/preprocess/parser_raw.ml" +# 36775 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36341,15 +36779,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36347 "src/ocaml/preprocess/parser_raw.ml" +# 36785 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36353 "src/ocaml/preprocess/parser_raw.ml" +# 36791 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36402,9 +36840,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2853 "src/ocaml/preprocess/parser_raw.mly" +# 3004 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 36408 "src/ocaml/preprocess/parser_raw.ml" +# 36846 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -36412,18 +36850,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36418 "src/ocaml/preprocess/parser_raw.ml" +# 36856 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1712 "src/ocaml/preprocess/parser_raw.mly" +# 1799 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36427 "src/ocaml/preprocess/parser_raw.ml" +# 36865 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_od_ = _startpos__1_ in @@ -36431,10 +36869,10 @@ module Tables = struct let _symbolstartpos = _startpos_od_ in let _sloc = (_symbolstartpos, _endpos) in -# 2585 "src/ocaml/preprocess/parser_raw.mly" +# 2705 "src/ocaml/preprocess/parser_raw.mly" ( (* TODO: review the location of Pexp_override *) Pexp_open(od, mkexp ~loc:_sloc (Pexp_override _4)) ) -# 36438 "src/ocaml/preprocess/parser_raw.ml" +# 36876 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36442,15 +36880,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36448 "src/ocaml/preprocess/parser_raw.ml" +# 36886 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36454 "src/ocaml/preprocess/parser_raw.ml" +# 36892 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36481,9 +36919,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 36487 "src/ocaml/preprocess/parser_raw.ml" +# 36925 "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 @@ -36495,23 +36933,23 @@ module Tables = struct let _3 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36501 "src/ocaml/preprocess/parser_raw.ml" +# 36939 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36509 "src/ocaml/preprocess/parser_raw.ml" +# 36947 "src/ocaml/preprocess/parser_raw.ml" in -# 2592 "src/ocaml/preprocess/parser_raw.mly" +# 2712 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_send(_1, _3) ) -# 36515 "src/ocaml/preprocess/parser_raw.ml" +# 36953 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -36519,15 +36957,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36525 "src/ocaml/preprocess/parser_raw.ml" +# 36963 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36531 "src/ocaml/preprocess/parser_raw.ml" +# 36969 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36559,9 +36997,9 @@ module Tables = struct } = _menhir_stack in let _3 : (Parsetree.expression) = Obj.magic _3 in let _1_inlined1 : ( -# 834 "src/ocaml/preprocess/parser_raw.mly" +# 900 "src/ocaml/preprocess/parser_raw.mly" (string) -# 36565 "src/ocaml/preprocess/parser_raw.ml" +# 37003 "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 @@ -36575,15 +37013,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1023 "src/ocaml/preprocess/parser_raw.mly" +# 1089 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 36581 "src/ocaml/preprocess/parser_raw.ml" +# 37019 "src/ocaml/preprocess/parser_raw.ml" in -# 2594 "src/ocaml/preprocess/parser_raw.mly" +# 2714 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix _1 _2 _3 ) -# 36587 "src/ocaml/preprocess/parser_raw.ml" +# 37025 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36591,15 +37029,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36597 "src/ocaml/preprocess/parser_raw.ml" +# 37035 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36603 "src/ocaml/preprocess/parser_raw.ml" +# 37041 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36623,23 +37061,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2596 "src/ocaml/preprocess/parser_raw.mly" +# 2716 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_extension _1 ) -# 36629 "src/ocaml/preprocess/parser_raw.ml" +# 37067 "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" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36637 "src/ocaml/preprocess/parser_raw.ml" +# 37075 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36643 "src/ocaml/preprocess/parser_raw.ml" +# 37081 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36667,25 +37105,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2598 "src/ocaml/preprocess/parser_raw.mly" +# 2718 "src/ocaml/preprocess/parser_raw.mly" ( let id = mkrhs Ast_helper.hole_txt _loc in Pexp_extension (id, PStr []) ) -# 36674 "src/ocaml/preprocess/parser_raw.ml" +# 37112 "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" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36683 "src/ocaml/preprocess/parser_raw.ml" +# 37121 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36689 "src/ocaml/preprocess/parser_raw.ml" +# 37127 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36733,18 +37171,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2600 "src/ocaml/preprocess/parser_raw.mly" +# 2720 "src/ocaml/preprocess/parser_raw.mly" (Lident "()") -# 36739 "src/ocaml/preprocess/parser_raw.ml" +# 37177 "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 -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36748 "src/ocaml/preprocess/parser_raw.ml" +# 37186 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -36754,25 +37192,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36760 "src/ocaml/preprocess/parser_raw.ml" +# 37198 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1712 "src/ocaml/preprocess/parser_raw.mly" +# 1799 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36769 "src/ocaml/preprocess/parser_raw.ml" +# 37207 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2601 "src/ocaml/preprocess/parser_raw.mly" +# 2721 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:(_loc__3_) (Pexp_construct(_3, None))) ) -# 36776 "src/ocaml/preprocess/parser_raw.ml" +# 37214 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -36780,15 +37218,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36786 "src/ocaml/preprocess/parser_raw.ml" +# 37224 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36792 "src/ocaml/preprocess/parser_raw.ml" +# 37230 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36827,25 +37265,25 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2607 "src/ocaml/preprocess/parser_raw.mly" +# 2727 "src/ocaml/preprocess/parser_raw.mly" ( let (exten, fields) = _2 in Pexp_record(fields, exten) ) -# 36834 "src/ocaml/preprocess/parser_raw.ml" +# 37272 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36843 "src/ocaml/preprocess/parser_raw.ml" +# 37281 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36849 "src/ocaml/preprocess/parser_raw.ml" +# 37287 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36904,27 +37342,27 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36910 "src/ocaml/preprocess/parser_raw.ml" +# 37348 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1712 "src/ocaml/preprocess/parser_raw.mly" +# 1799 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36919 "src/ocaml/preprocess/parser_raw.ml" +# 37357 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in -# 2614 "src/ocaml/preprocess/parser_raw.mly" +# 2734 "src/ocaml/preprocess/parser_raw.mly" ( let (exten, fields) = _4 in Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_record(fields, exten))) ) -# 36928 "src/ocaml/preprocess/parser_raw.ml" +# 37366 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36932,15 +37370,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36938 "src/ocaml/preprocess/parser_raw.ml" +# 37376 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36944 "src/ocaml/preprocess/parser_raw.ml" +# 37382 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36979,14 +37417,14 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 36985 "src/ocaml/preprocess/parser_raw.ml" +# 37423 "src/ocaml/preprocess/parser_raw.ml" in -# 2622 "src/ocaml/preprocess/parser_raw.mly" +# 2742 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_array(_2) ) -# 36990 "src/ocaml/preprocess/parser_raw.ml" +# 37428 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36994,15 +37432,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37000 "src/ocaml/preprocess/parser_raw.ml" +# 37438 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37006 "src/ocaml/preprocess/parser_raw.ml" +# 37444 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37033,24 +37471,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2628 "src/ocaml/preprocess/parser_raw.mly" +# 2748 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_array [] ) -# 37039 "src/ocaml/preprocess/parser_raw.ml" +# 37477 "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 -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37048 "src/ocaml/preprocess/parser_raw.ml" +# 37486 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37054 "src/ocaml/preprocess/parser_raw.ml" +# 37492 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37103,9 +37541,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37109 "src/ocaml/preprocess/parser_raw.ml" +# 37547 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -37113,25 +37551,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37119 "src/ocaml/preprocess/parser_raw.ml" +# 37557 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1712 "src/ocaml/preprocess/parser_raw.mly" +# 1799 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37128 "src/ocaml/preprocess/parser_raw.ml" +# 37566 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in -# 2630 "src/ocaml/preprocess/parser_raw.mly" +# 2750 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array(_4))) ) -# 37135 "src/ocaml/preprocess/parser_raw.ml" +# 37573 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37139,15 +37577,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37145 "src/ocaml/preprocess/parser_raw.ml" +# 37583 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37151 "src/ocaml/preprocess/parser_raw.ml" +# 37589 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37198,26 +37636,26 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37204 "src/ocaml/preprocess/parser_raw.ml" +# 37642 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1712 "src/ocaml/preprocess/parser_raw.mly" +# 1799 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37213 "src/ocaml/preprocess/parser_raw.ml" +# 37651 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in -# 2632 "src/ocaml/preprocess/parser_raw.mly" +# 2752 "src/ocaml/preprocess/parser_raw.mly" ( (* TODO: review the location of Pexp_array *) Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array [])) ) -# 37221 "src/ocaml/preprocess/parser_raw.ml" +# 37659 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -37225,15 +37663,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37231 "src/ocaml/preprocess/parser_raw.ml" +# 37669 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37237 "src/ocaml/preprocess/parser_raw.ml" +# 37675 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37272,15 +37710,15 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37278 "src/ocaml/preprocess/parser_raw.ml" +# 37716 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2640 "src/ocaml/preprocess/parser_raw.mly" +# 2760 "src/ocaml/preprocess/parser_raw.mly" ( fst (mktailexp _loc__3_ _2) ) -# 37284 "src/ocaml/preprocess/parser_raw.ml" +# 37722 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -37288,15 +37726,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37294 "src/ocaml/preprocess/parser_raw.ml" +# 37732 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37300 "src/ocaml/preprocess/parser_raw.ml" +# 37738 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37349,9 +37787,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 2870 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37355 "src/ocaml/preprocess/parser_raw.ml" +# 37793 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -37359,30 +37797,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37365 "src/ocaml/preprocess/parser_raw.ml" +# 37803 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1712 "src/ocaml/preprocess/parser_raw.mly" +# 1799 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37374 "src/ocaml/preprocess/parser_raw.ml" +# 37812 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _loc__5_ = (_startpos__5_, _endpos__5_) in -# 2646 "src/ocaml/preprocess/parser_raw.mly" +# 2766 "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) ) -# 37386 "src/ocaml/preprocess/parser_raw.ml" +# 37824 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37390,15 +37828,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37396 "src/ocaml/preprocess/parser_raw.ml" +# 37834 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37402 "src/ocaml/preprocess/parser_raw.ml" +# 37840 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37446,18 +37884,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2771 "src/ocaml/preprocess/parser_raw.mly" (Lident "[]") -# 37452 "src/ocaml/preprocess/parser_raw.ml" +# 37890 "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 -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37461 "src/ocaml/preprocess/parser_raw.ml" +# 37899 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -37467,25 +37905,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37473 "src/ocaml/preprocess/parser_raw.ml" +# 37911 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1712 "src/ocaml/preprocess/parser_raw.mly" +# 1799 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37482 "src/ocaml/preprocess/parser_raw.ml" +# 37920 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2652 "src/ocaml/preprocess/parser_raw.mly" +# 2772 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:_loc__3_ (Pexp_construct(_3, None))) ) -# 37489 "src/ocaml/preprocess/parser_raw.ml" +# 37927 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -37493,15 +37931,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37499 "src/ocaml/preprocess/parser_raw.ml" +# 37937 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37505 "src/ocaml/preprocess/parser_raw.ml" +# 37943 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37594,11 +38032,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3842 "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 ) -# 37602 "src/ocaml/preprocess/parser_raw.ml" +# 38040 "src/ocaml/preprocess/parser_raw.ml" in let _5 = @@ -37606,15 +38044,15 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37612 "src/ocaml/preprocess/parser_raw.ml" +# 38050 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 37618 "src/ocaml/preprocess/parser_raw.ml" +# 38056 "src/ocaml/preprocess/parser_raw.ml" in let od = @@ -37623,18 +38061,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37629 "src/ocaml/preprocess/parser_raw.ml" +# 38067 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1712 "src/ocaml/preprocess/parser_raw.mly" +# 1799 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37638 "src/ocaml/preprocess/parser_raw.ml" +# 38076 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_od_ = _startpos__1_ in @@ -37642,12 +38080,12 @@ module Tables = struct let _symbolstartpos = _startpos_od_ in let _sloc = (_symbolstartpos, _endpos) in -# 2660 "src/ocaml/preprocess/parser_raw.mly" +# 2780 "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) ) -# 37651 "src/ocaml/preprocess/parser_raw.ml" +# 38089 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__9_ in @@ -37655,15 +38093,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1029 "src/ocaml/preprocess/parser_raw.mly" +# 1095 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37661 "src/ocaml/preprocess/parser_raw.ml" +# 38099 "src/ocaml/preprocess/parser_raw.ml" in -# 2531 "src/ocaml/preprocess/parser_raw.mly" +# 2651 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37667 "src/ocaml/preprocess/parser_raw.ml" +# 38105 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37692,30 +38130,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37698 "src/ocaml/preprocess/parser_raw.ml" +# 38136 "src/ocaml/preprocess/parser_raw.ml" in -# 2953 "src/ocaml/preprocess/parser_raw.mly" +# 3104 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_var (_1) ) -# 37704 "src/ocaml/preprocess/parser_raw.ml" +# 38142 "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" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 37713 "src/ocaml/preprocess/parser_raw.ml" +# 38151 "src/ocaml/preprocess/parser_raw.ml" in -# 2954 "src/ocaml/preprocess/parser_raw.mly" +# 3105 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37719 "src/ocaml/preprocess/parser_raw.ml" +# 38157 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37738,9 +38176,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2955 "src/ocaml/preprocess/parser_raw.mly" +# 3106 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37744 "src/ocaml/preprocess/parser_raw.ml" +# 38182 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37780,9 +38218,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2960 "src/ocaml/preprocess/parser_raw.mly" +# 3111 "src/ocaml/preprocess/parser_raw.mly" ( reloc_pat ~loc:_sloc _2 ) -# 37786 "src/ocaml/preprocess/parser_raw.ml" +# 38224 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37805,9 +38243,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2962 "src/ocaml/preprocess/parser_raw.mly" +# 3113 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37811 "src/ocaml/preprocess/parser_raw.ml" +# 38249 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37870,9 +38308,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37876 "src/ocaml/preprocess/parser_raw.ml" +# 38314 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -37880,24 +38318,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37886 "src/ocaml/preprocess/parser_raw.ml" +# 38324 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 37892 "src/ocaml/preprocess/parser_raw.ml" +# 38330 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2964 "src/ocaml/preprocess/parser_raw.mly" +# 3115 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_unpack _4) _3 ) -# 37901 "src/ocaml/preprocess/parser_raw.ml" +# 38339 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37974,11 +38412,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3842 "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 ) -# 37982 "src/ocaml/preprocess/parser_raw.ml" +# 38420 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -37987,9 +38425,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37993 "src/ocaml/preprocess/parser_raw.ml" +# 38431 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__4_, _startpos__4_) = (_endpos__1_inlined3_, _startpos__1_inlined3_) in @@ -37998,15 +38436,15 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38004 "src/ocaml/preprocess/parser_raw.ml" +# 38442 "src/ocaml/preprocess/parser_raw.ml" in -# 4068 "src/ocaml/preprocess/parser_raw.mly" +# 4275 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 38010 "src/ocaml/preprocess/parser_raw.ml" +# 38448 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in @@ -38014,11 +38452,11 @@ module Tables = struct let _loc__4_ = (_startpos__4_, _endpos__4_) in let _sloc = (_symbolstartpos, _endpos) in -# 2966 "src/ocaml/preprocess/parser_raw.mly" +# 3117 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_constraint(mkpat ~loc:_loc__4_ (Ppat_unpack _4), _6)) _3 ) -# 38022 "src/ocaml/preprocess/parser_raw.ml" +# 38460 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38042,23 +38480,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2974 "src/ocaml/preprocess/parser_raw.mly" +# 3125 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_any ) -# 38048 "src/ocaml/preprocess/parser_raw.ml" +# 38486 "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" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38056 "src/ocaml/preprocess/parser_raw.ml" +# 38494 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38062 "src/ocaml/preprocess/parser_raw.ml" +# 38500 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38082,23 +38520,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2976 "src/ocaml/preprocess/parser_raw.mly" +# 3127 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constant _1 ) -# 38088 "src/ocaml/preprocess/parser_raw.ml" +# 38526 "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" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38096 "src/ocaml/preprocess/parser_raw.ml" +# 38534 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38102 "src/ocaml/preprocess/parser_raw.ml" +# 38540 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38136,24 +38574,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2978 "src/ocaml/preprocess/parser_raw.mly" +# 3129 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_interval (_1, _3) ) -# 38142 "src/ocaml/preprocess/parser_raw.ml" +# 38580 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38151 "src/ocaml/preprocess/parser_raw.ml" +# 38589 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38157 "src/ocaml/preprocess/parser_raw.ml" +# 38595 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38182,30 +38620,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38188 "src/ocaml/preprocess/parser_raw.ml" +# 38626 "src/ocaml/preprocess/parser_raw.ml" in -# 2980 "src/ocaml/preprocess/parser_raw.mly" +# 3131 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(_1, None) ) -# 38194 "src/ocaml/preprocess/parser_raw.ml" +# 38632 "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" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38203 "src/ocaml/preprocess/parser_raw.ml" +# 38641 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38209 "src/ocaml/preprocess/parser_raw.ml" +# 38647 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38229,23 +38667,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2982 "src/ocaml/preprocess/parser_raw.mly" +# 3133 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_variant(_1, None) ) -# 38235 "src/ocaml/preprocess/parser_raw.ml" +# 38673 "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" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38243 "src/ocaml/preprocess/parser_raw.ml" +# 38681 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38249 "src/ocaml/preprocess/parser_raw.ml" +# 38687 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38282,15 +38720,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38288 "src/ocaml/preprocess/parser_raw.ml" +# 38726 "src/ocaml/preprocess/parser_raw.ml" in -# 2984 "src/ocaml/preprocess/parser_raw.mly" +# 3135 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_type (_2) ) -# 38294 "src/ocaml/preprocess/parser_raw.ml" +# 38732 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -38298,15 +38736,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38304 "src/ocaml/preprocess/parser_raw.ml" +# 38742 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38310 "src/ocaml/preprocess/parser_raw.ml" +# 38748 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38349,15 +38787,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38355 "src/ocaml/preprocess/parser_raw.ml" +# 38793 "src/ocaml/preprocess/parser_raw.ml" in -# 2986 "src/ocaml/preprocess/parser_raw.mly" +# 3137 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, _3) ) -# 38361 "src/ocaml/preprocess/parser_raw.ml" +# 38799 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -38365,15 +38803,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38371 "src/ocaml/preprocess/parser_raw.ml" +# 38809 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38377 "src/ocaml/preprocess/parser_raw.ml" +# 38815 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38421,18 +38859,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2987 "src/ocaml/preprocess/parser_raw.mly" +# 3138 "src/ocaml/preprocess/parser_raw.mly" (Lident "[]") -# 38427 "src/ocaml/preprocess/parser_raw.ml" +# 38865 "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 -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38436 "src/ocaml/preprocess/parser_raw.ml" +# 38874 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -38441,18 +38879,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38447 "src/ocaml/preprocess/parser_raw.ml" +# 38885 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2988 "src/ocaml/preprocess/parser_raw.mly" +# 3139 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 38456 "src/ocaml/preprocess/parser_raw.ml" +# 38894 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -38460,15 +38898,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38466 "src/ocaml/preprocess/parser_raw.ml" +# 38904 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38472 "src/ocaml/preprocess/parser_raw.ml" +# 38910 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38516,18 +38954,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2989 "src/ocaml/preprocess/parser_raw.mly" +# 3140 "src/ocaml/preprocess/parser_raw.mly" (Lident "()") -# 38522 "src/ocaml/preprocess/parser_raw.ml" +# 38960 "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 -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38531 "src/ocaml/preprocess/parser_raw.ml" +# 38969 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -38536,18 +38974,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38542 "src/ocaml/preprocess/parser_raw.ml" +# 38980 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2990 "src/ocaml/preprocess/parser_raw.mly" +# 3141 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 38551 "src/ocaml/preprocess/parser_raw.ml" +# 38989 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -38555,15 +38993,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38561 "src/ocaml/preprocess/parser_raw.ml" +# 38999 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38567 "src/ocaml/preprocess/parser_raw.ml" +# 39005 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38620,15 +39058,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38626 "src/ocaml/preprocess/parser_raw.ml" +# 39064 "src/ocaml/preprocess/parser_raw.ml" in -# 2992 "src/ocaml/preprocess/parser_raw.mly" +# 3143 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open (_1, _4) ) -# 38632 "src/ocaml/preprocess/parser_raw.ml" +# 39070 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -38636,15 +39074,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38642 "src/ocaml/preprocess/parser_raw.ml" +# 39080 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38648 "src/ocaml/preprocess/parser_raw.ml" +# 39086 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38696,24 +39134,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3002 "src/ocaml/preprocess/parser_raw.mly" +# 3153 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_2, _4) ) -# 38702 "src/ocaml/preprocess/parser_raw.ml" +# 39140 "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 -# 1031 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38711 "src/ocaml/preprocess/parser_raw.ml" +# 39149 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38717 "src/ocaml/preprocess/parser_raw.ml" +# 39155 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38737,23 +39175,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3013 "src/ocaml/preprocess/parser_raw.mly" +# 3164 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_extension _1 ) -# 38743 "src/ocaml/preprocess/parser_raw.ml" +# 39181 "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" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38751 "src/ocaml/preprocess/parser_raw.ml" +# 39189 "src/ocaml/preprocess/parser_raw.ml" in -# 2970 "src/ocaml/preprocess/parser_raw.mly" +# 3121 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38757 "src/ocaml/preprocess/parser_raw.ml" +# 39195 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38772,17 +39210,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 38778 "src/ocaml/preprocess/parser_raw.ml" +# 39216 "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) = -# 3976 "src/ocaml/preprocess/parser_raw.mly" +# 4183 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38786 "src/ocaml/preprocess/parser_raw.ml" +# 39224 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38801,17 +39239,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) -# 38807 "src/ocaml/preprocess/parser_raw.ml" +# 39245 "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) = -# 3977 "src/ocaml/preprocess/parser_raw.mly" +# 4184 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38815 "src/ocaml/preprocess/parser_raw.ml" +# 39253 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38834,9 +39272,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3978 "src/ocaml/preprocess/parser_raw.mly" +# 4185 "src/ocaml/preprocess/parser_raw.mly" ( "and" ) -# 38840 "src/ocaml/preprocess/parser_raw.ml" +# 39278 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38859,9 +39297,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3979 "src/ocaml/preprocess/parser_raw.mly" +# 4186 "src/ocaml/preprocess/parser_raw.mly" ( "as" ) -# 38865 "src/ocaml/preprocess/parser_raw.ml" +# 39303 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38884,9 +39322,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3980 "src/ocaml/preprocess/parser_raw.mly" +# 4187 "src/ocaml/preprocess/parser_raw.mly" ( "assert" ) -# 38890 "src/ocaml/preprocess/parser_raw.ml" +# 39328 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38909,9 +39347,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3981 "src/ocaml/preprocess/parser_raw.mly" +# 4188 "src/ocaml/preprocess/parser_raw.mly" ( "begin" ) -# 38915 "src/ocaml/preprocess/parser_raw.ml" +# 39353 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38934,9 +39372,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3982 "src/ocaml/preprocess/parser_raw.mly" +# 4189 "src/ocaml/preprocess/parser_raw.mly" ( "class" ) -# 38940 "src/ocaml/preprocess/parser_raw.ml" +# 39378 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38959,9 +39397,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3983 "src/ocaml/preprocess/parser_raw.mly" +# 4190 "src/ocaml/preprocess/parser_raw.mly" ( "constraint" ) -# 38965 "src/ocaml/preprocess/parser_raw.ml" +# 39403 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38984,9 +39422,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3984 "src/ocaml/preprocess/parser_raw.mly" +# 4191 "src/ocaml/preprocess/parser_raw.mly" ( "do" ) -# 38990 "src/ocaml/preprocess/parser_raw.ml" +# 39428 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39009,9 +39447,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3985 "src/ocaml/preprocess/parser_raw.mly" +# 4192 "src/ocaml/preprocess/parser_raw.mly" ( "done" ) -# 39015 "src/ocaml/preprocess/parser_raw.ml" +# 39453 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39034,9 +39472,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3986 "src/ocaml/preprocess/parser_raw.mly" +# 4193 "src/ocaml/preprocess/parser_raw.mly" ( "downto" ) -# 39040 "src/ocaml/preprocess/parser_raw.ml" +# 39478 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39059,9 +39497,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3987 "src/ocaml/preprocess/parser_raw.mly" +# 4194 "src/ocaml/preprocess/parser_raw.mly" ( "else" ) -# 39065 "src/ocaml/preprocess/parser_raw.ml" +# 39503 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39084,9 +39522,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3988 "src/ocaml/preprocess/parser_raw.mly" +# 4195 "src/ocaml/preprocess/parser_raw.mly" ( "end" ) -# 39090 "src/ocaml/preprocess/parser_raw.ml" +# 39528 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39109,9 +39547,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3989 "src/ocaml/preprocess/parser_raw.mly" +# 4196 "src/ocaml/preprocess/parser_raw.mly" ( "exception" ) -# 39115 "src/ocaml/preprocess/parser_raw.ml" +# 39553 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39134,9 +39572,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3990 "src/ocaml/preprocess/parser_raw.mly" +# 4197 "src/ocaml/preprocess/parser_raw.mly" ( "external" ) -# 39140 "src/ocaml/preprocess/parser_raw.ml" +# 39578 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39159,9 +39597,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3991 "src/ocaml/preprocess/parser_raw.mly" +# 4198 "src/ocaml/preprocess/parser_raw.mly" ( "false" ) -# 39165 "src/ocaml/preprocess/parser_raw.ml" +# 39603 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39184,9 +39622,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3992 "src/ocaml/preprocess/parser_raw.mly" +# 4199 "src/ocaml/preprocess/parser_raw.mly" ( "for" ) -# 39190 "src/ocaml/preprocess/parser_raw.ml" +# 39628 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39209,9 +39647,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3993 "src/ocaml/preprocess/parser_raw.mly" +# 4200 "src/ocaml/preprocess/parser_raw.mly" ( "fun" ) -# 39215 "src/ocaml/preprocess/parser_raw.ml" +# 39653 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39234,9 +39672,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3994 "src/ocaml/preprocess/parser_raw.mly" +# 4201 "src/ocaml/preprocess/parser_raw.mly" ( "function" ) -# 39240 "src/ocaml/preprocess/parser_raw.ml" +# 39678 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39259,9 +39697,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3995 "src/ocaml/preprocess/parser_raw.mly" +# 4202 "src/ocaml/preprocess/parser_raw.mly" ( "functor" ) -# 39265 "src/ocaml/preprocess/parser_raw.ml" +# 39703 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39284,9 +39722,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3996 "src/ocaml/preprocess/parser_raw.mly" +# 4203 "src/ocaml/preprocess/parser_raw.mly" ( "if" ) -# 39290 "src/ocaml/preprocess/parser_raw.ml" +# 39728 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39309,9 +39747,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3997 "src/ocaml/preprocess/parser_raw.mly" +# 4204 "src/ocaml/preprocess/parser_raw.mly" ( "in" ) -# 39315 "src/ocaml/preprocess/parser_raw.ml" +# 39753 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39334,9 +39772,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3998 "src/ocaml/preprocess/parser_raw.mly" +# 4205 "src/ocaml/preprocess/parser_raw.mly" ( "include" ) -# 39340 "src/ocaml/preprocess/parser_raw.ml" +# 39778 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39359,9 +39797,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3999 "src/ocaml/preprocess/parser_raw.mly" +# 4206 "src/ocaml/preprocess/parser_raw.mly" ( "inherit" ) -# 39365 "src/ocaml/preprocess/parser_raw.ml" +# 39803 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39384,9 +39822,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4000 "src/ocaml/preprocess/parser_raw.mly" +# 4207 "src/ocaml/preprocess/parser_raw.mly" ( "initializer" ) -# 39390 "src/ocaml/preprocess/parser_raw.ml" +# 39828 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39409,9 +39847,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4001 "src/ocaml/preprocess/parser_raw.mly" +# 4208 "src/ocaml/preprocess/parser_raw.mly" ( "lazy" ) -# 39415 "src/ocaml/preprocess/parser_raw.ml" +# 39853 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39434,9 +39872,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4002 "src/ocaml/preprocess/parser_raw.mly" +# 4209 "src/ocaml/preprocess/parser_raw.mly" ( "let" ) -# 39440 "src/ocaml/preprocess/parser_raw.ml" +# 39878 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39459,9 +39897,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4003 "src/ocaml/preprocess/parser_raw.mly" +# 4210 "src/ocaml/preprocess/parser_raw.mly" ( "match" ) -# 39465 "src/ocaml/preprocess/parser_raw.ml" +# 39903 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39484,9 +39922,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4004 "src/ocaml/preprocess/parser_raw.mly" +# 4211 "src/ocaml/preprocess/parser_raw.mly" ( "method" ) -# 39490 "src/ocaml/preprocess/parser_raw.ml" +# 39928 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39509,9 +39947,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4005 "src/ocaml/preprocess/parser_raw.mly" +# 4212 "src/ocaml/preprocess/parser_raw.mly" ( "module" ) -# 39515 "src/ocaml/preprocess/parser_raw.ml" +# 39953 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39534,9 +39972,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4006 "src/ocaml/preprocess/parser_raw.mly" +# 4213 "src/ocaml/preprocess/parser_raw.mly" ( "mutable" ) -# 39540 "src/ocaml/preprocess/parser_raw.ml" +# 39978 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39559,9 +39997,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4007 "src/ocaml/preprocess/parser_raw.mly" +# 4214 "src/ocaml/preprocess/parser_raw.mly" ( "new" ) -# 39565 "src/ocaml/preprocess/parser_raw.ml" +# 40003 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39584,9 +40022,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4008 "src/ocaml/preprocess/parser_raw.mly" +# 4215 "src/ocaml/preprocess/parser_raw.mly" ( "nonrec" ) -# 39590 "src/ocaml/preprocess/parser_raw.ml" +# 40028 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39609,9 +40047,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4009 "src/ocaml/preprocess/parser_raw.mly" +# 4216 "src/ocaml/preprocess/parser_raw.mly" ( "object" ) -# 39615 "src/ocaml/preprocess/parser_raw.ml" +# 40053 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39634,9 +40072,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4010 "src/ocaml/preprocess/parser_raw.mly" +# 4217 "src/ocaml/preprocess/parser_raw.mly" ( "of" ) -# 39640 "src/ocaml/preprocess/parser_raw.ml" +# 40078 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39659,9 +40097,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4011 "src/ocaml/preprocess/parser_raw.mly" +# 4218 "src/ocaml/preprocess/parser_raw.mly" ( "open" ) -# 39665 "src/ocaml/preprocess/parser_raw.ml" +# 40103 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39684,9 +40122,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4012 "src/ocaml/preprocess/parser_raw.mly" +# 4219 "src/ocaml/preprocess/parser_raw.mly" ( "or" ) -# 39690 "src/ocaml/preprocess/parser_raw.ml" +# 40128 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39709,9 +40147,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4013 "src/ocaml/preprocess/parser_raw.mly" +# 4220 "src/ocaml/preprocess/parser_raw.mly" ( "private" ) -# 39715 "src/ocaml/preprocess/parser_raw.ml" +# 40153 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39734,9 +40172,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4014 "src/ocaml/preprocess/parser_raw.mly" +# 4221 "src/ocaml/preprocess/parser_raw.mly" ( "rec" ) -# 39740 "src/ocaml/preprocess/parser_raw.ml" +# 40178 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39759,9 +40197,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4015 "src/ocaml/preprocess/parser_raw.mly" +# 4222 "src/ocaml/preprocess/parser_raw.mly" ( "sig" ) -# 39765 "src/ocaml/preprocess/parser_raw.ml" +# 40203 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39784,9 +40222,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4016 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( "struct" ) -# 39790 "src/ocaml/preprocess/parser_raw.ml" +# 40228 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39809,9 +40247,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4017 "src/ocaml/preprocess/parser_raw.mly" +# 4224 "src/ocaml/preprocess/parser_raw.mly" ( "then" ) -# 39815 "src/ocaml/preprocess/parser_raw.ml" +# 40253 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39834,9 +40272,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4018 "src/ocaml/preprocess/parser_raw.mly" +# 4225 "src/ocaml/preprocess/parser_raw.mly" ( "to" ) -# 39840 "src/ocaml/preprocess/parser_raw.ml" +# 40278 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39859,9 +40297,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4019 "src/ocaml/preprocess/parser_raw.mly" +# 4226 "src/ocaml/preprocess/parser_raw.mly" ( "true" ) -# 39865 "src/ocaml/preprocess/parser_raw.ml" +# 40303 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39884,9 +40322,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4020 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( "try" ) -# 39890 "src/ocaml/preprocess/parser_raw.ml" +# 40328 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39909,9 +40347,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4021 "src/ocaml/preprocess/parser_raw.mly" +# 4228 "src/ocaml/preprocess/parser_raw.mly" ( "type" ) -# 39915 "src/ocaml/preprocess/parser_raw.ml" +# 40353 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39934,9 +40372,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4022 "src/ocaml/preprocess/parser_raw.mly" +# 4229 "src/ocaml/preprocess/parser_raw.mly" ( "val" ) -# 39940 "src/ocaml/preprocess/parser_raw.ml" +# 40378 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39959,9 +40397,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4023 "src/ocaml/preprocess/parser_raw.mly" +# 4230 "src/ocaml/preprocess/parser_raw.mly" ( "virtual" ) -# 39965 "src/ocaml/preprocess/parser_raw.ml" +# 40403 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39984,9 +40422,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4024 "src/ocaml/preprocess/parser_raw.mly" +# 4231 "src/ocaml/preprocess/parser_raw.mly" ( "when" ) -# 39990 "src/ocaml/preprocess/parser_raw.ml" +# 40428 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40009,9 +40447,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4025 "src/ocaml/preprocess/parser_raw.mly" +# 4232 "src/ocaml/preprocess/parser_raw.mly" ( "while" ) -# 40015 "src/ocaml/preprocess/parser_raw.ml" +# 40453 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40034,9 +40472,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4026 "src/ocaml/preprocess/parser_raw.mly" +# 4233 "src/ocaml/preprocess/parser_raw.mly" ( "with" ) -# 40040 "src/ocaml/preprocess/parser_raw.ml" +# 40478 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40059,9 +40497,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.type_exception * string Location.loc option) = -# 3294 "src/ocaml/preprocess/parser_raw.mly" +# 3445 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40065 "src/ocaml/preprocess/parser_raw.ml" +# 40503 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40135,18 +40573,18 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = let attrs = let _1 = _1_inlined5 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40141 "src/ocaml/preprocess/parser_raw.ml" +# 40579 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined5_ in let attrs2 = let _1 = _1_inlined4 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40150 "src/ocaml/preprocess/parser_raw.ml" +# 40588 "src/ocaml/preprocess/parser_raw.ml" in let lid = @@ -40155,9 +40593,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40161 "src/ocaml/preprocess/parser_raw.ml" +# 40599 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -40166,30 +40604,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40172 "src/ocaml/preprocess/parser_raw.ml" +# 40610 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40180 "src/ocaml/preprocess/parser_raw.ml" +# 40618 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3303 "src/ocaml/preprocess/parser_raw.mly" +# 3454 "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 ) -# 40193 "src/ocaml/preprocess/parser_raw.ml" +# 40631 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40219,9 +40657,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2794 "src/ocaml/preprocess/parser_raw.mly" +# 2907 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 40225 "src/ocaml/preprocess/parser_raw.ml" +# 40663 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40234,90 +40672,44 @@ module Tables = struct 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 - -# 2796 "src/ocaml/preprocess/parser_raw.mly" - ( let (l, o, p) = _1 in ghexp ~loc:_sloc (Pexp_fun(l, o, p, _2)) ) -# 40260 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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.semv = _4; + MenhirLib.EngineTypes.startp = _startpos__4_; + MenhirLib.EngineTypes.endp = _endpos__4_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _4; - MenhirLib.EngineTypes.startp = _startpos__4_; - MenhirLib.EngineTypes.endp = _endpos__4_; + 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.semv = _2; + MenhirLib.EngineTypes.startp = _startpos__2_; + MenhirLib.EngineTypes.endp = _endpos__2_; 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; - }; + MenhirLib.EngineTypes.state = _menhir_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 _4 : (Parsetree.function_body) = Obj.magic _4 in + let _3 : unit = Obj.magic _3 in + let _2 : (Parsetree.type_constraint option) = Obj.magic _2 in + let _1 : (Parsetree.function_param list) = 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 = -# 2689 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 40313 "src/ocaml/preprocess/parser_raw.ml" - in - let _endpos = _endpos__5_ 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 -# 2798 "src/ocaml/preprocess/parser_raw.mly" - ( mk_newtypes ~loc:_sloc _3 _5 ) -# 40321 "src/ocaml/preprocess/parser_raw.ml" +# 2909 "src/ocaml/preprocess/parser_raw.mly" + ( ghexp ~loc:_sloc (mkfunction _1 _2 _4) + ) +# 40713 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40344,39 +40736,39 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 40348 "src/ocaml/preprocess/parser_raw.ml" +# 40740 "src/ocaml/preprocess/parser_raw.ml" in let xs = let items = -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1132 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 40354 "src/ocaml/preprocess/parser_raw.ml" +# 40746 "src/ocaml/preprocess/parser_raw.ml" in -# 1511 "src/ocaml/preprocess/parser_raw.mly" +# 1598 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 40359 "src/ocaml/preprocess/parser_raw.ml" +# 40751 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 40365 "src/ocaml/preprocess/parser_raw.ml" +# 40757 "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 -# 988 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 40374 "src/ocaml/preprocess/parser_raw.ml" +# 40766 "src/ocaml/preprocess/parser_raw.ml" in -# 1504 "src/ocaml/preprocess/parser_raw.mly" +# 1591 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40380 "src/ocaml/preprocess/parser_raw.ml" +# 40772 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40417,7 +40809,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 40421 "src/ocaml/preprocess/parser_raw.ml" +# 40813 "src/ocaml/preprocess/parser_raw.ml" in let xs = let items = @@ -40425,65 +40817,65 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40431 "src/ocaml/preprocess/parser_raw.ml" +# 40823 "src/ocaml/preprocess/parser_raw.ml" in -# 1518 "src/ocaml/preprocess/parser_raw.mly" +# 1605 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 40436 "src/ocaml/preprocess/parser_raw.ml" +# 40828 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1000 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 40444 "src/ocaml/preprocess/parser_raw.ml" +# 40836 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1019 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 40454 "src/ocaml/preprocess/parser_raw.ml" +# 40846 "src/ocaml/preprocess/parser_raw.ml" in -# 1068 "src/ocaml/preprocess/parser_raw.mly" +# 1134 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 40460 "src/ocaml/preprocess/parser_raw.ml" +# 40852 "src/ocaml/preprocess/parser_raw.ml" in -# 1511 "src/ocaml/preprocess/parser_raw.mly" +# 1598 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 40466 "src/ocaml/preprocess/parser_raw.ml" +# 40858 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 40472 "src/ocaml/preprocess/parser_raw.ml" +# 40864 "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 -# 988 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 40481 "src/ocaml/preprocess/parser_raw.ml" +# 40873 "src/ocaml/preprocess/parser_raw.ml" in -# 1504 "src/ocaml/preprocess/parser_raw.mly" +# 1591 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40487 "src/ocaml/preprocess/parser_raw.ml" +# 40879 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40509,9 +40901,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4098 "src/ocaml/preprocess/parser_raw.mly" +# 4311 "src/ocaml/preprocess/parser_raw.mly" ( val_of_lwt_bindings ~loc:_loc _1 ) -# 40515 "src/ocaml/preprocess/parser_raw.ml" +# 40907 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40537,9 +40929,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1533 "src/ocaml/preprocess/parser_raw.mly" +# 1620 "src/ocaml/preprocess/parser_raw.mly" ( val_of_let_bindings ~loc:_sloc _1 ) -# 40543 "src/ocaml/preprocess/parser_raw.ml" +# 40935 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40573,9 +40965,9 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40579 "src/ocaml/preprocess/parser_raw.ml" +# 40971 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -40583,10 +40975,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1536 "src/ocaml/preprocess/parser_raw.mly" +# 1623 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in Pstr_extension (_1, add_docs_attrs docs _2) ) -# 40590 "src/ocaml/preprocess/parser_raw.ml" +# 40982 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -40594,15 +40986,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1035 "src/ocaml/preprocess/parser_raw.mly" +# 1101 "src/ocaml/preprocess/parser_raw.mly" ( mkstr ~loc:_sloc _1 ) -# 40600 "src/ocaml/preprocess/parser_raw.ml" +# 40992 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40606 "src/ocaml/preprocess/parser_raw.ml" +# 40998 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40626,23 +41018,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1539 "src/ocaml/preprocess/parser_raw.mly" +# 1626 "src/ocaml/preprocess/parser_raw.mly" ( Pstr_attribute _1 ) -# 40632 "src/ocaml/preprocess/parser_raw.ml" +# 41024 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1035 "src/ocaml/preprocess/parser_raw.mly" +# 1101 "src/ocaml/preprocess/parser_raw.mly" ( mkstr ~loc:_sloc _1 ) -# 40640 "src/ocaml/preprocess/parser_raw.ml" +# 41032 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40646 "src/ocaml/preprocess/parser_raw.ml" +# 41038 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40666,23 +41058,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1543 "src/ocaml/preprocess/parser_raw.mly" +# 1630 "src/ocaml/preprocess/parser_raw.mly" ( pstr_primitive _1 ) -# 40672 "src/ocaml/preprocess/parser_raw.ml" +# 41064 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40680 "src/ocaml/preprocess/parser_raw.ml" +# 41072 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40686 "src/ocaml/preprocess/parser_raw.ml" +# 41078 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40706,23 +41098,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1545 "src/ocaml/preprocess/parser_raw.mly" +# 1632 "src/ocaml/preprocess/parser_raw.mly" ( pstr_primitive _1 ) -# 40712 "src/ocaml/preprocess/parser_raw.ml" +# 41104 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40720 "src/ocaml/preprocess/parser_raw.ml" +# 41112 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40726 "src/ocaml/preprocess/parser_raw.ml" +# 41118 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40757,26 +41149,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1227 "src/ocaml/preprocess/parser_raw.mly" +# 1314 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 40763 "src/ocaml/preprocess/parser_raw.ml" +# 41155 "src/ocaml/preprocess/parser_raw.ml" in -# 3136 "src/ocaml/preprocess/parser_raw.mly" +# 3287 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40768 "src/ocaml/preprocess/parser_raw.ml" +# 41160 "src/ocaml/preprocess/parser_raw.ml" in -# 3119 "src/ocaml/preprocess/parser_raw.mly" +# 3270 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40774 "src/ocaml/preprocess/parser_raw.ml" +# 41166 "src/ocaml/preprocess/parser_raw.ml" in -# 1547 "src/ocaml/preprocess/parser_raw.mly" +# 1634 "src/ocaml/preprocess/parser_raw.mly" ( pstr_type _1 ) -# 40780 "src/ocaml/preprocess/parser_raw.ml" +# 41172 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -40784,15 +41176,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40790 "src/ocaml/preprocess/parser_raw.ml" +# 41182 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40796 "src/ocaml/preprocess/parser_raw.ml" +# 41188 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40877,16 +41269,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40883 "src/ocaml/preprocess/parser_raw.ml" +# 41275 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = -# 1219 "src/ocaml/preprocess/parser_raw.mly" +# 1306 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 40890 "src/ocaml/preprocess/parser_raw.ml" +# 41282 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -40894,46 +41286,46 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40900 "src/ocaml/preprocess/parser_raw.ml" +# 41292 "src/ocaml/preprocess/parser_raw.ml" in let _4 = -# 3896 "src/ocaml/preprocess/parser_raw.mly" +# 4103 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 40906 "src/ocaml/preprocess/parser_raw.ml" +# 41298 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40913 "src/ocaml/preprocess/parser_raw.ml" +# 41305 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3391 "src/ocaml/preprocess/parser_raw.mly" +# 3542 "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 ) -# 40925 "src/ocaml/preprocess/parser_raw.ml" +# 41317 "src/ocaml/preprocess/parser_raw.ml" in -# 3374 "src/ocaml/preprocess/parser_raw.mly" +# 3525 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40931 "src/ocaml/preprocess/parser_raw.ml" +# 41323 "src/ocaml/preprocess/parser_raw.ml" in -# 1549 "src/ocaml/preprocess/parser_raw.mly" +# 1636 "src/ocaml/preprocess/parser_raw.mly" ( pstr_typext _1 ) -# 40937 "src/ocaml/preprocess/parser_raw.ml" +# 41329 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -40941,15 +41333,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 40947 "src/ocaml/preprocess/parser_raw.ml" +# 41339 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40953 "src/ocaml/preprocess/parser_raw.ml" +# 41345 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41041,16 +41433,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41047 "src/ocaml/preprocess/parser_raw.ml" +# 41439 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = -# 1219 "src/ocaml/preprocess/parser_raw.mly" +# 1306 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 41054 "src/ocaml/preprocess/parser_raw.ml" +# 41446 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -41058,9 +41450,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41064 "src/ocaml/preprocess/parser_raw.ml" +# 41456 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -41069,41 +41461,41 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 3898 "src/ocaml/preprocess/parser_raw.mly" +# 4105 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 41075 "src/ocaml/preprocess/parser_raw.ml" +# 41467 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41083 "src/ocaml/preprocess/parser_raw.ml" +# 41475 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3391 "src/ocaml/preprocess/parser_raw.mly" +# 3542 "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 ) -# 41095 "src/ocaml/preprocess/parser_raw.ml" +# 41487 "src/ocaml/preprocess/parser_raw.ml" in -# 3374 "src/ocaml/preprocess/parser_raw.mly" +# 3525 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41101 "src/ocaml/preprocess/parser_raw.ml" +# 41493 "src/ocaml/preprocess/parser_raw.ml" in -# 1549 "src/ocaml/preprocess/parser_raw.mly" +# 1636 "src/ocaml/preprocess/parser_raw.mly" ( pstr_typext _1 ) -# 41107 "src/ocaml/preprocess/parser_raw.ml" +# 41499 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -41111,15 +41503,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41117 "src/ocaml/preprocess/parser_raw.ml" +# 41509 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41123 "src/ocaml/preprocess/parser_raw.ml" +# 41515 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41143,23 +41535,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1551 "src/ocaml/preprocess/parser_raw.mly" +# 1638 "src/ocaml/preprocess/parser_raw.mly" ( pstr_exception _1 ) -# 41149 "src/ocaml/preprocess/parser_raw.ml" +# 41541 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41157 "src/ocaml/preprocess/parser_raw.ml" +# 41549 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41163 "src/ocaml/preprocess/parser_raw.ml" +# 41555 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41222,9 +41614,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41228 "src/ocaml/preprocess/parser_raw.ml" +# 41620 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41234,36 +41626,36 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41240 "src/ocaml/preprocess/parser_raw.ml" +# 41632 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41248 "src/ocaml/preprocess/parser_raw.ml" +# 41640 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1577 "src/ocaml/preprocess/parser_raw.mly" +# 1664 "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 ) -# 41261 "src/ocaml/preprocess/parser_raw.ml" +# 41653 "src/ocaml/preprocess/parser_raw.ml" in -# 1553 "src/ocaml/preprocess/parser_raw.mly" +# 1640 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41267 "src/ocaml/preprocess/parser_raw.ml" +# 41659 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -41271,15 +41663,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41277 "src/ocaml/preprocess/parser_raw.ml" +# 41669 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41283 "src/ocaml/preprocess/parser_raw.ml" +# 41675 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41358,9 +41750,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41364 "src/ocaml/preprocess/parser_raw.ml" +# 41756 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41370,24 +41762,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41376 "src/ocaml/preprocess/parser_raw.ml" +# 41768 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41384 "src/ocaml/preprocess/parser_raw.ml" +# 41776 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1616 "src/ocaml/preprocess/parser_raw.mly" +# 1703 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in @@ -41395,25 +41787,25 @@ module Tables = struct ext, Mb.mk name body ~attrs ~loc ~docs ) -# 41399 "src/ocaml/preprocess/parser_raw.ml" +# 41791 "src/ocaml/preprocess/parser_raw.ml" in -# 1227 "src/ocaml/preprocess/parser_raw.mly" +# 1314 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 41405 "src/ocaml/preprocess/parser_raw.ml" +# 41797 "src/ocaml/preprocess/parser_raw.ml" in -# 1604 "src/ocaml/preprocess/parser_raw.mly" +# 1691 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41411 "src/ocaml/preprocess/parser_raw.ml" +# 41803 "src/ocaml/preprocess/parser_raw.ml" in -# 1555 "src/ocaml/preprocess/parser_raw.mly" +# 1642 "src/ocaml/preprocess/parser_raw.mly" ( pstr_recmodule _1 ) -# 41417 "src/ocaml/preprocess/parser_raw.ml" +# 41809 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -41421,15 +41813,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41427 "src/ocaml/preprocess/parser_raw.ml" +# 41819 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41433 "src/ocaml/preprocess/parser_raw.ml" +# 41825 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41453,23 +41845,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1557 "src/ocaml/preprocess/parser_raw.mly" +# 1644 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Pstr_modtype body, ext) ) -# 41459 "src/ocaml/preprocess/parser_raw.ml" +# 41851 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41467 "src/ocaml/preprocess/parser_raw.ml" +# 41859 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41473 "src/ocaml/preprocess/parser_raw.ml" +# 41865 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41493,23 +41885,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1559 "src/ocaml/preprocess/parser_raw.mly" +# 1646 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Pstr_open body, ext) ) -# 41499 "src/ocaml/preprocess/parser_raw.ml" +# 41891 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41507 "src/ocaml/preprocess/parser_raw.ml" +# 41899 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41513 "src/ocaml/preprocess/parser_raw.ml" +# 41905 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41579,9 +41971,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 41585 "src/ocaml/preprocess/parser_raw.ml" +# 41977 "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 @@ -41599,9 +41991,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41605 "src/ocaml/preprocess/parser_raw.ml" +# 41997 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41611,24 +42003,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41617 "src/ocaml/preprocess/parser_raw.ml" +# 42009 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41625 "src/ocaml/preprocess/parser_raw.ml" +# 42017 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1970 "src/ocaml/preprocess/parser_raw.mly" +# 2057 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -41636,25 +42028,25 @@ module Tables = struct ext, Ci.mk id body ~virt ~params ~attrs ~loc ~docs ) -# 41640 "src/ocaml/preprocess/parser_raw.ml" +# 42032 "src/ocaml/preprocess/parser_raw.ml" in -# 1227 "src/ocaml/preprocess/parser_raw.mly" +# 1314 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 41646 "src/ocaml/preprocess/parser_raw.ml" +# 42038 "src/ocaml/preprocess/parser_raw.ml" in -# 1959 "src/ocaml/preprocess/parser_raw.mly" +# 2046 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41652 "src/ocaml/preprocess/parser_raw.ml" +# 42044 "src/ocaml/preprocess/parser_raw.ml" in -# 1561 "src/ocaml/preprocess/parser_raw.mly" +# 1648 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Pstr_class l, ext) ) -# 41658 "src/ocaml/preprocess/parser_raw.ml" +# 42050 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -41662,15 +42054,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41668 "src/ocaml/preprocess/parser_raw.ml" +# 42060 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41674 "src/ocaml/preprocess/parser_raw.ml" +# 42066 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41694,23 +42086,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1563 "src/ocaml/preprocess/parser_raw.mly" +# 1650 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Pstr_class_type l, ext) ) -# 41700 "src/ocaml/preprocess/parser_raw.ml" +# 42092 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41708 "src/ocaml/preprocess/parser_raw.ml" +# 42100 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41714 "src/ocaml/preprocess/parser_raw.ml" +# 42106 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41766,38 +42158,38 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41772 "src/ocaml/preprocess/parser_raw.ml" +# 42164 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41781 "src/ocaml/preprocess/parser_raw.ml" +# 42173 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1653 "src/ocaml/preprocess/parser_raw.mly" +# 1740 "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 ) -# 41795 "src/ocaml/preprocess/parser_raw.ml" +# 42187 "src/ocaml/preprocess/parser_raw.ml" in -# 1565 "src/ocaml/preprocess/parser_raw.mly" +# 1652 "src/ocaml/preprocess/parser_raw.mly" ( pstr_include _1 ) -# 41801 "src/ocaml/preprocess/parser_raw.ml" +# 42193 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -41805,15 +42197,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1052 "src/ocaml/preprocess/parser_raw.mly" +# 1118 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41811 "src/ocaml/preprocess/parser_raw.ml" +# 42203 "src/ocaml/preprocess/parser_raw.ml" in -# 1567 "src/ocaml/preprocess/parser_raw.mly" +# 1654 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41817 "src/ocaml/preprocess/parser_raw.ml" +# 42209 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41836,9 +42228,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3961 "src/ocaml/preprocess/parser_raw.mly" +# 4168 "src/ocaml/preprocess/parser_raw.mly" ( "-" ) -# 41842 "src/ocaml/preprocess/parser_raw.ml" +# 42234 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41861,9 +42253,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3962 "src/ocaml/preprocess/parser_raw.mly" +# 4169 "src/ocaml/preprocess/parser_raw.mly" ( "-." ) -# 41867 "src/ocaml/preprocess/parser_raw.ml" +# 42259 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41916,9 +42308,9 @@ module Tables = struct let _v : (Parsetree.row_field) = let _5 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41922 "src/ocaml/preprocess/parser_raw.ml" +# 42314 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined1_ in @@ -41927,18 +42319,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 41931 "src/ocaml/preprocess/parser_raw.ml" +# 42323 "src/ocaml/preprocess/parser_raw.ml" in -# 1130 "src/ocaml/preprocess/parser_raw.mly" +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 41936 "src/ocaml/preprocess/parser_raw.ml" +# 42328 "src/ocaml/preprocess/parser_raw.ml" in -# 3665 "src/ocaml/preprocess/parser_raw.mly" +# 3872 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41942 "src/ocaml/preprocess/parser_raw.ml" +# 42334 "src/ocaml/preprocess/parser_raw.ml" in let _1 = @@ -41946,20 +42338,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41952 "src/ocaml/preprocess/parser_raw.ml" +# 42344 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3651 "src/ocaml/preprocess/parser_raw.mly" +# 3858 "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 ) -# 41963 "src/ocaml/preprocess/parser_raw.ml" +# 42355 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41991,9 +42383,9 @@ module Tables = struct let _v : (Parsetree.row_field) = let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41997 "src/ocaml/preprocess/parser_raw.ml" +# 42389 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -42002,20 +42394,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42008 "src/ocaml/preprocess/parser_raw.ml" +# 42400 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3655 "src/ocaml/preprocess/parser_raw.mly" +# 3862 "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 [] ) -# 42019 "src/ocaml/preprocess/parser_raw.ml" +# 42411 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42047,7 +42439,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase) = let arg = # 124 "" ( None ) -# 42051 "src/ocaml/preprocess/parser_raw.ml" +# 42443 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined1_ in let dir = @@ -42056,18 +42448,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42062 "src/ocaml/preprocess/parser_raw.ml" +# 42454 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3859 "src/ocaml/preprocess/parser_raw.mly" +# 4066 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42071 "src/ocaml/preprocess/parser_raw.ml" +# 42463 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42098,9 +42490,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : ( -# 837 "src/ocaml/preprocess/parser_raw.mly" +# 903 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 42104 "src/ocaml/preprocess/parser_raw.ml" +# 42496 "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 @@ -42111,23 +42503,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3863 "src/ocaml/preprocess/parser_raw.mly" +# 4070 "src/ocaml/preprocess/parser_raw.mly" ( let (s, _, _) = _1 in Pdir_string s ) -# 42117 "src/ocaml/preprocess/parser_raw.ml" +# 42509 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "src/ocaml/preprocess/parser_raw.mly" +# 1123 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42125 "src/ocaml/preprocess/parser_raw.ml" +# 42517 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42131 "src/ocaml/preprocess/parser_raw.ml" +# 42523 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42137,18 +42529,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42143 "src/ocaml/preprocess/parser_raw.ml" +# 42535 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3859 "src/ocaml/preprocess/parser_raw.mly" +# 4066 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42152 "src/ocaml/preprocess/parser_raw.ml" +# 42544 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42179,9 +42571,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : ( -# 785 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 42185 "src/ocaml/preprocess/parser_raw.ml" +# 42577 "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 @@ -42192,23 +42584,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3864 "src/ocaml/preprocess/parser_raw.mly" +# 4071 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _1 in Pdir_int (n ,m) ) -# 42198 "src/ocaml/preprocess/parser_raw.ml" +# 42590 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "src/ocaml/preprocess/parser_raw.mly" +# 1123 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42206 "src/ocaml/preprocess/parser_raw.ml" +# 42598 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42212 "src/ocaml/preprocess/parser_raw.ml" +# 42604 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42218,18 +42610,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42224 "src/ocaml/preprocess/parser_raw.ml" +# 42616 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3859 "src/ocaml/preprocess/parser_raw.mly" +# 4066 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42233 "src/ocaml/preprocess/parser_raw.ml" +# 42625 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42269,23 +42661,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3865 "src/ocaml/preprocess/parser_raw.mly" +# 4072 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_ident _1 ) -# 42275 "src/ocaml/preprocess/parser_raw.ml" +# 42667 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "src/ocaml/preprocess/parser_raw.mly" +# 1123 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42283 "src/ocaml/preprocess/parser_raw.ml" +# 42675 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42289 "src/ocaml/preprocess/parser_raw.ml" +# 42681 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42295,18 +42687,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42301 "src/ocaml/preprocess/parser_raw.ml" +# 42693 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3859 "src/ocaml/preprocess/parser_raw.mly" +# 4066 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42310 "src/ocaml/preprocess/parser_raw.ml" +# 42702 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42346,23 +42738,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3866 "src/ocaml/preprocess/parser_raw.mly" +# 4073 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_ident _1 ) -# 42352 "src/ocaml/preprocess/parser_raw.ml" +# 42744 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "src/ocaml/preprocess/parser_raw.mly" +# 1123 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42360 "src/ocaml/preprocess/parser_raw.ml" +# 42752 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42366 "src/ocaml/preprocess/parser_raw.ml" +# 42758 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42372,18 +42764,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42378 "src/ocaml/preprocess/parser_raw.ml" +# 42770 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3859 "src/ocaml/preprocess/parser_raw.mly" +# 4066 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42387 "src/ocaml/preprocess/parser_raw.ml" +# 42779 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42423,23 +42815,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3867 "src/ocaml/preprocess/parser_raw.mly" +# 4074 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_bool false ) -# 42429 "src/ocaml/preprocess/parser_raw.ml" +# 42821 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "src/ocaml/preprocess/parser_raw.mly" +# 1123 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42437 "src/ocaml/preprocess/parser_raw.ml" +# 42829 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42443 "src/ocaml/preprocess/parser_raw.ml" +# 42835 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42449,18 +42841,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42455 "src/ocaml/preprocess/parser_raw.ml" +# 42847 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3859 "src/ocaml/preprocess/parser_raw.mly" +# 4066 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42464 "src/ocaml/preprocess/parser_raw.ml" +# 42856 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42500,23 +42892,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 3868 "src/ocaml/preprocess/parser_raw.mly" +# 4075 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_bool true ) -# 42506 "src/ocaml/preprocess/parser_raw.ml" +# 42898 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1057 "src/ocaml/preprocess/parser_raw.mly" +# 1123 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42514 "src/ocaml/preprocess/parser_raw.ml" +# 42906 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42520 "src/ocaml/preprocess/parser_raw.ml" +# 42912 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42526,18 +42918,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42532 "src/ocaml/preprocess/parser_raw.ml" +# 42924 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3859 "src/ocaml/preprocess/parser_raw.mly" +# 4066 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42541 "src/ocaml/preprocess/parser_raw.ml" +# 42933 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42577,37 +42969,37 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42583 "src/ocaml/preprocess/parser_raw.ml" +# 42975 "src/ocaml/preprocess/parser_raw.ml" in -# 1518 "src/ocaml/preprocess/parser_raw.mly" +# 1605 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 42588 "src/ocaml/preprocess/parser_raw.ml" +# 42980 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1000 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 42596 "src/ocaml/preprocess/parser_raw.ml" +# 42988 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 988 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 42605 "src/ocaml/preprocess/parser_raw.ml" +# 42997 "src/ocaml/preprocess/parser_raw.ml" in -# 1267 "src/ocaml/preprocess/parser_raw.mly" +# 1354 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def _1 ) -# 42611 "src/ocaml/preprocess/parser_raw.ml" +# 43003 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42640,21 +43032,21 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 42644 "src/ocaml/preprocess/parser_raw.ml" +# 43036 "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 -# 988 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 42652 "src/ocaml/preprocess/parser_raw.ml" +# 43044 "src/ocaml/preprocess/parser_raw.ml" in -# 1271 "src/ocaml/preprocess/parser_raw.mly" +# 1358 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def _1 ) -# 42658 "src/ocaml/preprocess/parser_raw.ml" +# 43050 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42684,9 +43076,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.toplevel_phrase) = -# 1275 "src/ocaml/preprocess/parser_raw.mly" +# 1362 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42690 "src/ocaml/preprocess/parser_raw.ml" +# 43082 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42709,9 +43101,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.toplevel_phrase) = -# 1278 "src/ocaml/preprocess/parser_raw.mly" +# 1365 "src/ocaml/preprocess/parser_raw.mly" ( raise End_of_file ) -# 42715 "src/ocaml/preprocess/parser_raw.ml" +# 43107 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42734,9 +43126,9 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.core_type) = -# 3557 "src/ocaml/preprocess/parser_raw.mly" +# 3708 "src/ocaml/preprocess/parser_raw.mly" ( ty ) -# 42740 "src/ocaml/preprocess/parser_raw.ml" +# 43132 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42764,18 +43156,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 42768 "src/ocaml/preprocess/parser_raw.ml" +# 43160 "src/ocaml/preprocess/parser_raw.ml" in -# 1158 "src/ocaml/preprocess/parser_raw.mly" +# 1245 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 42773 "src/ocaml/preprocess/parser_raw.ml" +# 43165 "src/ocaml/preprocess/parser_raw.ml" in -# 3560 "src/ocaml/preprocess/parser_raw.mly" +# 3711 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_tuple tys ) -# 42779 "src/ocaml/preprocess/parser_raw.ml" +# 43171 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -42783,15 +43175,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 42789 "src/ocaml/preprocess/parser_raw.ml" +# 43181 "src/ocaml/preprocess/parser_raw.ml" in -# 3562 "src/ocaml/preprocess/parser_raw.mly" +# 3713 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42795 "src/ocaml/preprocess/parser_raw.ml" +# 43187 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42820,10 +43212,10 @@ module Tables = struct 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) = -# 2873 "src/ocaml/preprocess/parser_raw.mly" - ( (Some _2, None) ) -# 42827 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.type_constraint) = +# 3024 "src/ocaml/preprocess/parser_raw.mly" + ( Pconstraint _2 ) +# 43219 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42866,10 +43258,10 @@ module Tables = struct 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) = -# 2874 "src/ocaml/preprocess/parser_raw.mly" - ( (Some _2, Some _4) ) -# 42873 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.type_constraint) = +# 3025 "src/ocaml/preprocess/parser_raw.mly" + ( Pcoerce (Some _2, _4) ) +# 43265 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42898,10 +43290,10 @@ module Tables = struct 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) = -# 2875 "src/ocaml/preprocess/parser_raw.mly" - ( (None, Some _2) ) -# 42905 "src/ocaml/preprocess/parser_raw.ml" + let _v : (Parsetree.type_constraint) = +# 3026 "src/ocaml/preprocess/parser_raw.mly" + ( Pcoerce (None, _2) ) +# 43297 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42917,9 +43309,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = -# 3210 "src/ocaml/preprocess/parser_raw.mly" +# 3361 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, Public, None) ) -# 42923 "src/ocaml/preprocess/parser_raw.ml" +# 43315 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42949,9 +43341,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = -# 3212 "src/ocaml/preprocess/parser_raw.mly" +# 3363 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 42955 "src/ocaml/preprocess/parser_raw.ml" +# 43347 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42974,9 +43366,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3818 "src/ocaml/preprocess/parser_raw.mly" +# 4025 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42980 "src/ocaml/preprocess/parser_raw.ml" +# 43372 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43006,9 +43398,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) = -# 3227 "src/ocaml/preprocess/parser_raw.mly" +# 3378 "src/ocaml/preprocess/parser_raw.mly" ( _2, _1 ) -# 43012 "src/ocaml/preprocess/parser_raw.ml" +# 43404 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43024,9 +43416,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = -# 3220 "src/ocaml/preprocess/parser_raw.mly" +# 3371 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 43030 "src/ocaml/preprocess/parser_raw.ml" +# 43422 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43049,9 +43441,9 @@ module Tables = struct let _startpos = _startpos_p_ in let _endpos = _endpos_p_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = -# 3222 "src/ocaml/preprocess/parser_raw.mly" +# 3373 "src/ocaml/preprocess/parser_raw.mly" ( [p] ) -# 43055 "src/ocaml/preprocess/parser_raw.ml" +# 43447 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43091,18 +43483,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 43095 "src/ocaml/preprocess/parser_raw.ml" +# 43487 "src/ocaml/preprocess/parser_raw.ml" in -# 1130 "src/ocaml/preprocess/parser_raw.mly" +# 1217 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 43100 "src/ocaml/preprocess/parser_raw.ml" +# 43492 "src/ocaml/preprocess/parser_raw.ml" in -# 3224 "src/ocaml/preprocess/parser_raw.mly" +# 3375 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 43106 "src/ocaml/preprocess/parser_raw.ml" +# 43498 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43133,24 +43525,24 @@ module Tables = struct let _endpos = _endpos_tyvar_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3232 "src/ocaml/preprocess/parser_raw.mly" +# 3383 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_var tyvar ) -# 43139 "src/ocaml/preprocess/parser_raw.ml" +# 43531 "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 -# 1033 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43148 "src/ocaml/preprocess/parser_raw.ml" +# 43540 "src/ocaml/preprocess/parser_raw.ml" in -# 3235 "src/ocaml/preprocess/parser_raw.mly" +# 3386 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43154 "src/ocaml/preprocess/parser_raw.ml" +# 43546 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43174,23 +43566,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3234 "src/ocaml/preprocess/parser_raw.mly" +# 3385 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 43180 "src/ocaml/preprocess/parser_raw.ml" +# 43572 "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" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43188 "src/ocaml/preprocess/parser_raw.ml" +# 43580 "src/ocaml/preprocess/parser_raw.ml" in -# 3235 "src/ocaml/preprocess/parser_raw.mly" +# 3386 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43194 "src/ocaml/preprocess/parser_raw.ml" +# 43586 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43206,9 +43598,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3239 "src/ocaml/preprocess/parser_raw.mly" +# 3390 "src/ocaml/preprocess/parser_raw.mly" ( NoVariance, NoInjectivity ) -# 43212 "src/ocaml/preprocess/parser_raw.ml" +# 43604 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43231,9 +43623,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3240 "src/ocaml/preprocess/parser_raw.mly" +# 3391 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, NoInjectivity ) -# 43237 "src/ocaml/preprocess/parser_raw.ml" +# 43629 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43256,9 +43648,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3241 "src/ocaml/preprocess/parser_raw.mly" +# 3392 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, NoInjectivity ) -# 43262 "src/ocaml/preprocess/parser_raw.ml" +# 43654 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43281,9 +43673,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3242 "src/ocaml/preprocess/parser_raw.mly" +# 3393 "src/ocaml/preprocess/parser_raw.mly" ( NoVariance, Injective ) -# 43287 "src/ocaml/preprocess/parser_raw.ml" +# 43679 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43313,9 +43705,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3243 "src/ocaml/preprocess/parser_raw.mly" +# 3394 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, Injective ) -# 43319 "src/ocaml/preprocess/parser_raw.ml" +# 43711 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43345,9 +43737,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3243 "src/ocaml/preprocess/parser_raw.mly" +# 3394 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, Injective ) -# 43351 "src/ocaml/preprocess/parser_raw.ml" +# 43743 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43377,9 +43769,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3244 "src/ocaml/preprocess/parser_raw.mly" +# 3395 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, Injective ) -# 43383 "src/ocaml/preprocess/parser_raw.ml" +# 43775 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43409,9 +43801,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3244 "src/ocaml/preprocess/parser_raw.mly" +# 3395 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, Injective ) -# 43415 "src/ocaml/preprocess/parser_raw.ml" +# 43807 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43430,21 +43822,21 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 777 "src/ocaml/preprocess/parser_raw.mly" +# 843 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43436 "src/ocaml/preprocess/parser_raw.ml" +# 43828 "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 -# 3246 "src/ocaml/preprocess/parser_raw.mly" +# 3397 "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) ) -# 43448 "src/ocaml/preprocess/parser_raw.ml" +# 43840 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43463,21 +43855,21 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 823 "src/ocaml/preprocess/parser_raw.mly" +# 889 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43469 "src/ocaml/preprocess/parser_raw.ml" +# 43861 "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 -# 3251 "src/ocaml/preprocess/parser_raw.mly" +# 3402 "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) ) -# 43481 "src/ocaml/preprocess/parser_raw.ml" +# 43873 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43511,39 +43903,39 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 43515 "src/ocaml/preprocess/parser_raw.ml" +# 43907 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _1 = -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1132 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 43521 "src/ocaml/preprocess/parser_raw.ml" +# 43913 "src/ocaml/preprocess/parser_raw.ml" in -# 1298 "src/ocaml/preprocess/parser_raw.mly" +# 1385 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43526 "src/ocaml/preprocess/parser_raw.ml" +# 43918 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 43532 "src/ocaml/preprocess/parser_raw.ml" +# 43924 "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 -# 992 "src/ocaml/preprocess/parser_raw.mly" +# 1058 "src/ocaml/preprocess/parser_raw.mly" ( extra_def _startpos _endpos _1 ) -# 43541 "src/ocaml/preprocess/parser_raw.ml" +# 43933 "src/ocaml/preprocess/parser_raw.ml" in -# 1291 "src/ocaml/preprocess/parser_raw.mly" +# 1378 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43547 "src/ocaml/preprocess/parser_raw.ml" +# 43939 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43591,7 +43983,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 43595 "src/ocaml/preprocess/parser_raw.ml" +# 43987 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _1 = @@ -43599,61 +43991,61 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43605 "src/ocaml/preprocess/parser_raw.ml" +# 43997 "src/ocaml/preprocess/parser_raw.ml" in -# 1518 "src/ocaml/preprocess/parser_raw.mly" +# 1605 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 43610 "src/ocaml/preprocess/parser_raw.ml" +# 44002 "src/ocaml/preprocess/parser_raw.ml" in -# 1010 "src/ocaml/preprocess/parser_raw.mly" +# 1076 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 43616 "src/ocaml/preprocess/parser_raw.ml" +# 44008 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1008 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 43624 "src/ocaml/preprocess/parser_raw.ml" +# 44016 "src/ocaml/preprocess/parser_raw.ml" in -# 1068 "src/ocaml/preprocess/parser_raw.mly" +# 1134 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 43630 "src/ocaml/preprocess/parser_raw.ml" +# 44022 "src/ocaml/preprocess/parser_raw.ml" in -# 1298 "src/ocaml/preprocess/parser_raw.mly" +# 1385 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43636 "src/ocaml/preprocess/parser_raw.ml" +# 44028 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 43642 "src/ocaml/preprocess/parser_raw.ml" +# 44034 "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 -# 992 "src/ocaml/preprocess/parser_raw.mly" +# 1058 "src/ocaml/preprocess/parser_raw.mly" ( extra_def _startpos _endpos _1 ) -# 43651 "src/ocaml/preprocess/parser_raw.ml" +# 44043 "src/ocaml/preprocess/parser_raw.ml" in -# 1291 "src/ocaml/preprocess/parser_raw.mly" +# 1378 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43657 "src/ocaml/preprocess/parser_raw.ml" +# 44049 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43690,9 +44082,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = -# 3735 "src/ocaml/preprocess/parser_raw.mly" +# 3942 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 43696 "src/ocaml/preprocess/parser_raw.ml" +# 44088 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43711,17 +44103,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43717 "src/ocaml/preprocess/parser_raw.ml" +# 44109 "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) = -# 3743 "src/ocaml/preprocess/parser_raw.mly" +# 3950 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43725 "src/ocaml/preprocess/parser_raw.ml" +# 44117 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43744,9 +44136,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3744 "src/ocaml/preprocess/parser_raw.mly" +# 3951 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43750 "src/ocaml/preprocess/parser_raw.ml" +# 44142 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43769,9 +44161,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 3812 "src/ocaml/preprocess/parser_raw.mly" +# 4019 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43775 "src/ocaml/preprocess/parser_raw.ml" +# 44167 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43816,9 +44208,9 @@ module Tables = struct let ty : (Parsetree.core_type) = Obj.magic ty in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43822 "src/ocaml/preprocess/parser_raw.ml" +# 44214 "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 @@ -43829,33 +44221,33 @@ module Tables = struct Parsetree.attributes) = let label = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43835 "src/ocaml/preprocess/parser_raw.ml" +# 44227 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43843 "src/ocaml/preprocess/parser_raw.ml" +# 44235 "src/ocaml/preprocess/parser_raw.ml" in let attrs = -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43849 "src/ocaml/preprocess/parser_raw.ml" +# 44241 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3954 "src/ocaml/preprocess/parser_raw.mly" +# 4161 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 43854 "src/ocaml/preprocess/parser_raw.ml" +# 44246 "src/ocaml/preprocess/parser_raw.ml" in -# 2116 "src/ocaml/preprocess/parser_raw.mly" +# 2203 "src/ocaml/preprocess/parser_raw.mly" ( (label, mutable_, Cfk_virtual ty), attrs ) -# 43859 "src/ocaml/preprocess/parser_raw.ml" +# 44251 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43900,9 +44292,9 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43906 "src/ocaml/preprocess/parser_raw.ml" +# 44298 "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 @@ -43913,33 +44305,33 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43919 "src/ocaml/preprocess/parser_raw.ml" +# 44311 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 43927 "src/ocaml/preprocess/parser_raw.ml" +# 44319 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43933 "src/ocaml/preprocess/parser_raw.ml" +# 44325 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 43938 "src/ocaml/preprocess/parser_raw.ml" +# 44330 "src/ocaml/preprocess/parser_raw.ml" in -# 2118 "src/ocaml/preprocess/parser_raw.mly" +# 2205 "src/ocaml/preprocess/parser_raw.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 43943 "src/ocaml/preprocess/parser_raw.ml" +# 44335 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43990,9 +44382,9 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43996 "src/ocaml/preprocess/parser_raw.ml" +# 44388 "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 @@ -44004,36 +44396,36 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44010 "src/ocaml/preprocess/parser_raw.ml" +# 44402 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44018 "src/ocaml/preprocess/parser_raw.ml" +# 44410 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44026 "src/ocaml/preprocess/parser_raw.ml" +# 44418 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 44032 "src/ocaml/preprocess/parser_raw.ml" +# 44424 "src/ocaml/preprocess/parser_raw.ml" in -# 2118 "src/ocaml/preprocess/parser_raw.mly" +# 2205 "src/ocaml/preprocess/parser_raw.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 44037 "src/ocaml/preprocess/parser_raw.ml" +# 44429 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44083,11 +44475,11 @@ module Tables = struct } = _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 _5 : (Parsetree.type_constraint) = Obj.magic _5 in let _1_inlined1 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44091 "src/ocaml/preprocess/parser_raw.ml" +# 44483 "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 @@ -44098,30 +44490,30 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44104 "src/ocaml/preprocess/parser_raw.ml" +# 44496 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44112 "src/ocaml/preprocess/parser_raw.ml" +# 44504 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44119 "src/ocaml/preprocess/parser_raw.ml" +# 44511 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 44125 "src/ocaml/preprocess/parser_raw.ml" +# 44517 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__7_ in @@ -44137,11 +44529,11 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2121 "src/ocaml/preprocess/parser_raw.mly" +# 2208 "src/ocaml/preprocess/parser_raw.mly" ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 44145 "src/ocaml/preprocess/parser_raw.ml" +# 44537 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44197,11 +44589,11 @@ module Tables = struct } = _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 _5 : (Parsetree.type_constraint) = Obj.magic _5 in let _1_inlined2 : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44205 "src/ocaml/preprocess/parser_raw.ml" +# 44597 "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 @@ -44213,33 +44605,33 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3709 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44219 "src/ocaml/preprocess/parser_raw.ml" +# 44611 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44227 "src/ocaml/preprocess/parser_raw.ml" +# 44619 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44236 "src/ocaml/preprocess/parser_raw.ml" +# 44628 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 44243 "src/ocaml/preprocess/parser_raw.ml" +# 44635 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -44254,11 +44646,11 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2121 "src/ocaml/preprocess/parser_raw.mly" +# 2208 "src/ocaml/preprocess/parser_raw.mly" ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 44262 "src/ocaml/preprocess/parser_raw.ml" +# 44654 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44325,9 +44717,9 @@ module Tables = struct let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4051 "src/ocaml/preprocess/parser_raw.mly" +# 4258 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44331 "src/ocaml/preprocess/parser_raw.ml" +# 44723 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -44337,30 +44729,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44343 "src/ocaml/preprocess/parser_raw.ml" +# 44735 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4262 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44351 "src/ocaml/preprocess/parser_raw.ml" +# 44743 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3081 "src/ocaml/preprocess/parser_raw.mly" +# 3232 "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 ) -# 44364 "src/ocaml/preprocess/parser_raw.ml" +# 44756 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44376,9 +44768,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.virtual_flag) = -# 3918 "src/ocaml/preprocess/parser_raw.mly" +# 4125 "src/ocaml/preprocess/parser_raw.mly" ( Concrete ) -# 44382 "src/ocaml/preprocess/parser_raw.ml" +# 44774 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44401,9 +44793,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.virtual_flag) = -# 3919 "src/ocaml/preprocess/parser_raw.mly" +# 4126 "src/ocaml/preprocess/parser_raw.mly" ( Virtual ) -# 44407 "src/ocaml/preprocess/parser_raw.ml" +# 44799 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44426,9 +44818,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag) = -# 3942 "src/ocaml/preprocess/parser_raw.mly" +# 4149 "src/ocaml/preprocess/parser_raw.mly" ( Immutable ) -# 44432 "src/ocaml/preprocess/parser_raw.ml" +# 44824 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44458,9 +44850,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag) = -# 3943 "src/ocaml/preprocess/parser_raw.mly" +# 4150 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 44464 "src/ocaml/preprocess/parser_raw.ml" +# 44856 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44490,9 +44882,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag) = -# 3944 "src/ocaml/preprocess/parser_raw.mly" +# 4151 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 44496 "src/ocaml/preprocess/parser_raw.ml" +# 44888 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44515,9 +44907,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = -# 3949 "src/ocaml/preprocess/parser_raw.mly" +# 4156 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 44521 "src/ocaml/preprocess/parser_raw.ml" +# 44913 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44547,9 +44939,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3950 "src/ocaml/preprocess/parser_raw.mly" +# 4157 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 44553 "src/ocaml/preprocess/parser_raw.ml" +# 44945 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44579,9 +44971,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3951 "src/ocaml/preprocess/parser_raw.mly" +# 4158 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 44585 "src/ocaml/preprocess/parser_raw.ml" +# 44977 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44643,27 +45035,27 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 44647 "src/ocaml/preprocess/parser_raw.ml" +# 45039 "src/ocaml/preprocess/parser_raw.ml" in -# 1080 "src/ocaml/preprocess/parser_raw.mly" +# 1146 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 44652 "src/ocaml/preprocess/parser_raw.ml" +# 45044 "src/ocaml/preprocess/parser_raw.ml" in -# 3181 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44658 "src/ocaml/preprocess/parser_raw.ml" +# 45050 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos_xs_ in let _5 = let _1 = _1_inlined2 in -# 3505 "src/ocaml/preprocess/parser_raw.mly" +# 3656 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44667 "src/ocaml/preprocess/parser_raw.ml" +# 45059 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -44672,16 +45064,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44678 "src/ocaml/preprocess/parser_raw.ml" +# 45070 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3424 "src/ocaml/preprocess/parser_raw.mly" +# 3575 "src/ocaml/preprocess/parser_raw.mly" ( let lident = loc_last _3 in Pwith_type (_3, @@ -44691,7 +45083,7 @@ module Tables = struct ~manifest:_5 ~priv:_4 ~loc:(make_loc _sloc))) ) -# 44695 "src/ocaml/preprocess/parser_raw.ml" +# 45087 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44744,9 +45136,9 @@ module Tables = struct let _v : (Parsetree.with_constraint) = let _5 = let _1 = _1_inlined2 in -# 3505 "src/ocaml/preprocess/parser_raw.mly" +# 3656 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44750 "src/ocaml/preprocess/parser_raw.ml" +# 45142 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in @@ -44756,16 +45148,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44762 "src/ocaml/preprocess/parser_raw.ml" +# 45154 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3437 "src/ocaml/preprocess/parser_raw.mly" +# 3588 "src/ocaml/preprocess/parser_raw.mly" ( let lident = loc_last _3 in Pwith_typesubst (_3, @@ -44773,7 +45165,7 @@ module Tables = struct ~params:_2 ~manifest:_5 ~loc:(make_loc _sloc))) ) -# 44777 "src/ocaml/preprocess/parser_raw.ml" +# 45169 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44822,9 +45214,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44828 "src/ocaml/preprocess/parser_raw.ml" +# 45220 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -44833,15 +45225,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44839 "src/ocaml/preprocess/parser_raw.ml" +# 45231 "src/ocaml/preprocess/parser_raw.ml" in -# 3445 "src/ocaml/preprocess/parser_raw.mly" +# 3596 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_module (_2, _4) ) -# 44845 "src/ocaml/preprocess/parser_raw.ml" +# 45237 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44890,9 +45282,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44896 "src/ocaml/preprocess/parser_raw.ml" +# 45288 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -44901,15 +45293,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44907 "src/ocaml/preprocess/parser_raw.ml" +# 45299 "src/ocaml/preprocess/parser_raw.ml" in -# 3447 "src/ocaml/preprocess/parser_raw.mly" +# 3598 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modsubst (_2, _4) ) -# 44913 "src/ocaml/preprocess/parser_raw.ml" +# 45305 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44965,15 +45357,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44971 "src/ocaml/preprocess/parser_raw.ml" +# 45363 "src/ocaml/preprocess/parser_raw.ml" in -# 3449 "src/ocaml/preprocess/parser_raw.mly" +# 3600 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modtype (l, rhs) ) -# 44977 "src/ocaml/preprocess/parser_raw.ml" +# 45369 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45029,15 +45421,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 996 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45035 "src/ocaml/preprocess/parser_raw.ml" +# 45427 "src/ocaml/preprocess/parser_raw.ml" in -# 3451 "src/ocaml/preprocess/parser_raw.mly" +# 3602 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modtypesubst (l, rhs) ) -# 45041 "src/ocaml/preprocess/parser_raw.ml" +# 45433 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45060,9 +45452,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = -# 3454 "src/ocaml/preprocess/parser_raw.mly" +# 3605 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 45066 "src/ocaml/preprocess/parser_raw.ml" +# 45458 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45092,9 +45484,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3455 "src/ocaml/preprocess/parser_raw.mly" +# 3606 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 45098 "src/ocaml/preprocess/parser_raw.ml" +# 45490 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45130,9 +45522,9 @@ module MenhirInterpreter = struct | T_VAL : unit terminal | T_UNDERSCORE : unit terminal | T_UIDENT : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 917 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45136 "src/ocaml/preprocess/parser_raw.ml" +# 45528 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_TYPE : unit terminal | T_TRY_LWT : unit terminal @@ -45143,9 +45535,9 @@ module MenhirInterpreter = struct | T_THEN : unit terminal | T_STRUCT : unit terminal | T_STRING : ( -# 837 "src/ocaml/preprocess/parser_raw.mly" +# 903 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 45149 "src/ocaml/preprocess/parser_raw.ml" +# 45541 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_STAR : unit terminal | T_SIG : unit terminal @@ -45156,22 +45548,22 @@ module MenhirInterpreter = struct | T_RBRACKET : unit terminal | T_RBRACE : unit terminal | T_QUOTED_STRING_ITEM : ( -# 842 "src/ocaml/preprocess/parser_raw.mly" +# 908 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 45162 "src/ocaml/preprocess/parser_raw.ml" +# 45554 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_QUOTED_STRING_EXPR : ( -# 839 "src/ocaml/preprocess/parser_raw.mly" +# 905 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 45167 "src/ocaml/preprocess/parser_raw.ml" +# 45559 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_QUOTE : unit terminal | T_QUESTION : unit terminal | T_PRIVATE : unit terminal | T_PREFIXOP : ( -# 823 "src/ocaml/preprocess/parser_raw.mly" +# 889 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45175 "src/ocaml/preprocess/parser_raw.ml" +# 45567 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_PLUSEQ : unit terminal | T_PLUSDOT : unit terminal @@ -45179,9 +45571,9 @@ module MenhirInterpreter = struct | T_PERCENT : unit terminal | T_OR : unit terminal | T_OPTLABEL : ( -# 816 "src/ocaml/preprocess/parser_raw.mly" +# 882 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45185 "src/ocaml/preprocess/parser_raw.ml" +# 45577 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_OPEN : unit terminal | T_OF : unit terminal @@ -45198,15 +45590,15 @@ module MenhirInterpreter = struct | T_MATCH : unit terminal | T_LPAREN : unit terminal | T_LIDENT : ( -# 799 "src/ocaml/preprocess/parser_raw.mly" +# 865 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45204 "src/ocaml/preprocess/parser_raw.ml" +# 45596 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_LET_LWT : unit terminal | T_LETOP : ( -# 781 "src/ocaml/preprocess/parser_raw.mly" +# 847 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45210 "src/ocaml/preprocess/parser_raw.ml" +# 45602 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_LET : unit terminal | T_LESSMINUS : unit terminal @@ -45224,49 +45616,49 @@ module MenhirInterpreter = struct | T_LBRACE : unit terminal | T_LAZY : unit terminal | T_LABEL : ( -# 786 "src/ocaml/preprocess/parser_raw.mly" +# 852 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45230 "src/ocaml/preprocess/parser_raw.ml" +# 45622 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INT : ( -# 785 "src/ocaml/preprocess/parser_raw.mly" +# 851 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 45235 "src/ocaml/preprocess/parser_raw.ml" +# 45627 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INITIALIZER : unit terminal | T_INHERIT : unit terminal | T_INFIXOP4 : ( -# 779 "src/ocaml/preprocess/parser_raw.mly" +# 845 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45242 "src/ocaml/preprocess/parser_raw.ml" +# 45634 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP3 : ( -# 778 "src/ocaml/preprocess/parser_raw.mly" +# 844 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45247 "src/ocaml/preprocess/parser_raw.ml" +# 45639 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP2 : ( -# 777 "src/ocaml/preprocess/parser_raw.mly" +# 843 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45252 "src/ocaml/preprocess/parser_raw.ml" +# 45644 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP1 : ( -# 776 "src/ocaml/preprocess/parser_raw.mly" +# 842 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45257 "src/ocaml/preprocess/parser_raw.ml" +# 45649 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP0 : ( -# 775 "src/ocaml/preprocess/parser_raw.mly" +# 841 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45262 "src/ocaml/preprocess/parser_raw.ml" +# 45654 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INCLUDE : unit terminal | T_IN : unit terminal | T_IF : unit terminal | T_HASHOP : ( -# 834 "src/ocaml/preprocess/parser_raw.mly" +# 900 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45270 "src/ocaml/preprocess/parser_raw.ml" +# 45662 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_HASH : unit terminal | T_GREATERRBRACKET : unit terminal @@ -45279,9 +45671,9 @@ module MenhirInterpreter = struct | T_FOR_LWT : unit terminal | T_FOR : unit terminal | T_FLOAT : ( -# 764 "src/ocaml/preprocess/parser_raw.mly" +# 830 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 45285 "src/ocaml/preprocess/parser_raw.ml" +# 45677 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_FINALLY_LWT : unit terminal | T_FALSE : unit terminal @@ -45295,25 +45687,25 @@ module MenhirInterpreter = struct | T_DOWNTO : unit terminal | T_DOTTILDE : unit terminal | T_DOTOP : ( -# 780 "src/ocaml/preprocess/parser_raw.mly" +# 846 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45301 "src/ocaml/preprocess/parser_raw.ml" +# 45693 "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 : ( -# 859 "src/ocaml/preprocess/parser_raw.mly" +# 925 "src/ocaml/preprocess/parser_raw.mly" (Docstrings.docstring) -# 45310 "src/ocaml/preprocess/parser_raw.ml" +# 45702 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_DO : unit terminal | T_CONSTRAINT : unit terminal | T_COMMENT : ( -# 858 "src/ocaml/preprocess/parser_raw.mly" +# 924 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t) -# 45317 "src/ocaml/preprocess/parser_raw.ml" +# 45709 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_COMMA : unit terminal | T_COLONGREATER : unit terminal @@ -45322,9 +45714,9 @@ module MenhirInterpreter = struct | T_COLON : unit terminal | T_CLASS : unit terminal | T_CHAR : ( -# 744 "src/ocaml/preprocess/parser_raw.mly" +# 810 "src/ocaml/preprocess/parser_raw.mly" (char) -# 45328 "src/ocaml/preprocess/parser_raw.ml" +# 45720 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_BEGIN : unit terminal | T_BARRBRACKET : unit terminal @@ -45335,9 +45727,9 @@ module MenhirInterpreter = struct | T_ASSERT : unit terminal | T_AS : unit terminal | T_ANDOP : ( -# 782 "src/ocaml/preprocess/parser_raw.mly" +# 848 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45341 "src/ocaml/preprocess/parser_raw.ml" +# 45733 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_AND : unit terminal | T_AMPERSAND : unit terminal @@ -45362,7 +45754,7 @@ module MenhirInterpreter = struct | 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_type_constraint : (Parsetree.type_constraint) nonterminal | N_tuple_type : (Parsetree.core_type) nonterminal | N_toplevel_phrase : (Parsetree.toplevel_phrase) nonterminal | N_toplevel_directive : (Parsetree.toplevel_phrase) nonterminal @@ -45401,6 +45793,7 @@ module MenhirInterpreter = struct | 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_nonempty_concat_fun_param_as_list_ : (Parsetree.function_param 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 @@ -45434,12 +45827,13 @@ module MenhirInterpreter = struct | 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_type_constraint_ : (Parsetree.type_constraint 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_COLON_atomic_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 @@ -45447,6 +45841,7 @@ module MenhirInterpreter = struct | 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_object_type : (Parsetree.core_type) 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 @@ -45468,7 +45863,7 @@ module MenhirInterpreter = struct | 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___anonymous_43_ : (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) * @@ -45529,16 +45924,22 @@ module MenhirInterpreter = struct | 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_fun_seq_expr : (Parsetree.expression) nonterminal + | N_fun_params : (Parsetree.function_param list) nonterminal + | N_fun_param_as_list : (Parsetree.function_param list) nonterminal + | N_fun_expr : (Parsetree.expression) nonterminal + | N_fun_body : (Parsetree.function_body) nonterminal | N_formal_class_parameters : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) nonterminal | N_floating_attribute : (Parsetree.attribute) nonterminal + | N_extension_type : (Parsetree.core_type) 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_delimited_type_supporting_local_open : (Parsetree.core_type) nonterminal + | N_delimited_type : (Parsetree.core_type) nonterminal | N_core_type : (Parsetree.core_type) nonterminal | N_constructor_declarations : (Parsetree.constructor_declaration list) nonterminal | N_constructor_arguments : (Parsetree.constructor_arguments) nonterminal @@ -45561,6 +45962,7 @@ module MenhirInterpreter = struct | N_class_field : (Parsetree.class_field) nonterminal | N_class_expr : (Parsetree.class_expr) nonterminal | N_attribute : (Parsetree.attribute) nonterminal + | N_attr_payload : (Parsetree.payload) nonterminal | N_attr_id : (string Location.loc) nonterminal | N_atomic_type : (Parsetree.core_type) nonterminal | N_any_longident : (Longident.t) nonterminal @@ -45855,316 +46257,336 @@ module MenhirInterpreter = struct and nonterminal = fun nt -> match nt with - | 225 -> + | 235 -> X (N N_additive) - | 224 -> + | 234 -> X (N N_alias_type) - | 223 -> + | 233 -> X (N N_and_let_binding) - | 222 -> + | 232 -> X (N N_any_longident) - | 221 -> + | 231 -> X (N N_atomic_type) - | 220 -> + | 230 -> X (N N_attr_id) - | 219 -> + | 229 -> + X (N N_attr_payload) + | 228 -> X (N N_attribute) - | 218 -> + | 227 -> X (N N_class_expr) - | 217 -> + | 226 -> X (N N_class_field) - | 216 -> + | 225 -> X (N N_class_fun_binding) - | 215 -> + | 224 -> X (N N_class_fun_def) - | 214 -> + | 223 -> X (N N_class_longident) - | 213 -> + | 222 -> X (N N_class_self_pattern) - | 212 -> + | 221 -> X (N N_class_self_type) - | 211 -> + | 220 -> X (N N_class_sig_field) - | 210 -> + | 219 -> X (N N_class_signature) - | 209 -> + | 218 -> X (N N_class_simple_expr) - | 208 -> + | 217 -> X (N N_class_type) - | 207 -> + | 216 -> X (N N_class_type_declarations) - | 206 -> + | 215 -> X (N N_clty_longident) - | 205 -> + | 214 -> X (N N_constant) - | 204 -> + | 213 -> X (N N_constr_extra_nonprefix_ident) - | 203 -> + | 212 -> X (N N_constr_ident) - | 202 -> + | 211 -> X (N N_constr_longident) - | 201 -> + | 210 -> X (N N_constrain_field) - | 200 -> + | 209 -> X (N N_constructor_arguments) - | 199 -> + | 208 -> X (N N_constructor_declarations) - | 198 -> + | 207 -> X (N N_core_type) - | 197 -> + | 206 -> + X (N N_delimited_type) + | 205 -> + X (N N_delimited_type_supporting_local_open) + | 204 -> X (N N_direction_flag) - | 196 -> + | 203 -> X (N N_expr) - | 195 -> + | 202 -> X (N N_ext) - | 194 -> + | 201 -> X (N N_extension) - | 193 -> + | 200 -> X (N N_extension_constructor_rebind_BAR_) - | 192 -> + | 199 -> X (N N_extension_constructor_rebind_epsilon_) - | 191 -> + | 198 -> + X (N N_extension_type) + | 197 -> X (N N_floating_attribute) - | 190 -> + | 196 -> X (N N_formal_class_parameters) + | 195 -> + X (N N_fun_body) + | 194 -> + X (N N_fun_expr) + | 193 -> + X (N N_fun_param_as_list) + | 192 -> + X (N N_fun_params) + | 191 -> + X (N N_fun_seq_expr) + | 190 -> + X (N N_function_type) | 189 -> - X (N N_fun_binding) + X (N N_functor_arg) | 188 -> - X (N N_fun_def) + X (N N_functor_args) | 187 -> - X (N N_function_type) + X (N N_generalized_constructor_arguments) | 186 -> - X (N N_functor_arg) + X (N N_generic_constructor_declaration_BAR_) | 185 -> - X (N N_functor_args) + X (N N_generic_constructor_declaration_epsilon_) | 184 -> - X (N N_generalized_constructor_arguments) + X (N N_generic_type_declaration_no_nonrec_flag_type_subst_kind_) | 183 -> - X (N N_generic_constructor_declaration_BAR_) + X (N N_generic_type_declaration_nonrec_flag_type_kind_) | 182 -> - X (N N_generic_constructor_declaration_epsilon_) + X (N N_ident) | 181 -> - X (N N_generic_type_declaration_no_nonrec_flag_type_subst_kind_) + X (N N_implementation) | 180 -> - X (N N_generic_type_declaration_nonrec_flag_type_kind_) + X (N N_index_mod) | 179 -> - X (N N_ident) + X (N N_interface) | 178 -> - X (N N_implementation) + X (N N_item_extension) | 177 -> - X (N N_index_mod) + X (N N_label_declaration) | 176 -> - X (N N_interface) + X (N N_label_declaration_semi) | 175 -> - X (N N_item_extension) + X (N N_label_declarations) | 174 -> - X (N N_label_declaration) + X (N N_label_let_pattern) | 173 -> - X (N N_label_declaration_semi) + X (N N_label_longident) | 172 -> - X (N N_label_declarations) + X (N N_labeled_simple_expr) | 171 -> - X (N N_label_let_pattern) + X (N N_labeled_simple_pattern) | 170 -> - X (N N_label_longident) + X (N N_let_binding_body) | 169 -> - X (N N_labeled_simple_expr) + X (N N_let_binding_body_no_punning) | 168 -> - X (N N_labeled_simple_pattern) + X (N N_let_bindings_ext_) | 167 -> - X (N N_let_binding_body) + X (N N_let_bindings_no_ext_) | 166 -> - X (N N_let_binding_body_no_punning) + X (N N_let_pattern) | 165 -> - X (N N_let_bindings_ext_) + X (N N_letop_binding_body) | 164 -> - X (N N_let_bindings_no_ext_) + X (N N_letop_bindings) | 163 -> - X (N N_let_pattern) + X (N N_list_and_class_declaration_) | 162 -> - X (N N_letop_binding_body) + X (N N_list_and_class_description_) | 161 -> - X (N N_letop_bindings) + X (N N_list_and_class_type_declaration_) | 160 -> - X (N N_list_and_class_declaration_) + X (N N_list_and_module_binding_) | 159 -> - X (N N_list_and_class_description_) + X (N N_list_and_module_declaration_) | 158 -> - X (N N_list_and_class_type_declaration_) + X (N N_list_attribute_) | 157 -> - X (N N_list_and_module_binding_) + X (N N_list_generic_and_type_declaration_type_kind__) | 156 -> - X (N N_list_and_module_declaration_) + X (N N_list_generic_and_type_declaration_type_subst_kind__) | 155 -> - X (N N_list_attribute_) + X (N N_list_post_item_attribute_) | 154 -> - X (N N_list_generic_and_type_declaration_type_kind__) + X (N N_list_signature_element_) | 153 -> - X (N N_list_generic_and_type_declaration_type_subst_kind__) + X (N N_list_structure_element_) | 152 -> - X (N N_list_post_item_attribute_) + X (N N_list_text_csig_class_sig_field__) | 151 -> - X (N N_list_signature_element_) + X (N N_list_text_cstr_class_field__) | 150 -> - X (N N_list_structure_element_) + X (N N_list_text_str_structure_item__) | 149 -> - X (N N_list_text_csig_class_sig_field__) + X (N N_list_use_file_element_) | 148 -> - X (N N_list_text_cstr_class_field__) + X (N N_listx_SEMI_record_pat_field_UNDERSCORE_) | 147 -> - X (N N_list_text_str_structure_item__) + X (N N_lwt_binding) | 146 -> - X (N N_list_use_file_element_) + X (N N_lwt_bindings) | 145 -> - X (N N_listx_SEMI_record_pat_field_UNDERSCORE_) + X (N N_match_case) | 144 -> - X (N N_lwt_binding) + X (N N_meth_list) | 143 -> - X (N N_lwt_bindings) + X (N N_method_) | 142 -> - X (N N_match_case) + X (N N_mk_longident_mod_ext_longident_LIDENT_) | 141 -> - X (N N_meth_list) + X (N N_mk_longident_mod_ext_longident_UIDENT_) | 140 -> - X (N N_method_) + X (N N_mk_longident_mod_ext_longident___anonymous_43_) | 139 -> - X (N N_mk_longident_mod_ext_longident_LIDENT_) + X (N N_mk_longident_mod_ext_longident_ident_) | 138 -> - X (N N_mk_longident_mod_ext_longident_UIDENT_) + X (N N_mk_longident_mod_longident_LIDENT_) | 137 -> - X (N N_mk_longident_mod_ext_longident___anonymous_41_) + X (N N_mk_longident_mod_longident_UIDENT_) | 136 -> - X (N N_mk_longident_mod_ext_longident_ident_) + X (N N_mk_longident_mod_longident_val_ident_) | 135 -> - X (N N_mk_longident_mod_longident_LIDENT_) + X (N N_mod_ext_longident) | 134 -> - X (N N_mk_longident_mod_longident_UIDENT_) + X (N N_mod_longident) | 133 -> - X (N N_mk_longident_mod_longident_val_ident_) + X (N N_module_binding_body) | 132 -> - X (N N_mod_ext_longident) + X (N N_module_declaration_body) | 131 -> - X (N N_mod_longident) + X (N N_module_expr) | 130 -> - X (N N_module_binding_body) + X (N N_module_name) | 129 -> - X (N N_module_declaration_body) + X (N N_module_subst) | 128 -> - X (N N_module_expr) + X (N N_module_type) | 127 -> - X (N N_module_name) + X (N N_module_type_declaration) | 126 -> - X (N N_module_subst) + X (N N_module_type_subst) | 125 -> - X (N N_module_type) + X (N N_mty_longident) | 124 -> - X (N N_module_type_declaration) + X (N N_mutable_flag) | 123 -> - X (N N_module_type_subst) + X (N N_mutable_virtual_flags) | 122 -> - X (N N_mty_longident) + X (N N_name_tag) | 121 -> - X (N N_mutable_flag) + X (N N_nonempty_list_mkrhs_LIDENT__) | 120 -> - X (N N_mutable_virtual_flags) + X (N N_nonempty_list_raw_string_) | 119 -> - X (N N_name_tag) + X (N N_nonempty_type_kind) | 118 -> - X (N N_nonempty_list_mkrhs_LIDENT__) + X (N N_object_type) | 117 -> - X (N N_nonempty_list_raw_string_) + X (N N_open_declaration) | 116 -> - X (N N_nonempty_type_kind) + X (N N_open_description) | 115 -> - X (N N_open_declaration) + X (N N_operator) | 114 -> - X (N N_open_description) + X (N N_opt_ampersand) | 113 -> - X (N N_operator) + X (N N_option_BAR_) | 112 -> - X (N N_opt_ampersand) + X (N N_option_SEMI_) | 111 -> - X (N N_option_BAR_) + X (N N_option_preceded_AS_mkrhs_LIDENT___) | 110 -> - X (N N_option_SEMI_) + X (N N_option_preceded_COLON_atomic_type__) | 109 -> - X (N N_option_preceded_AS_mkrhs_LIDENT___) - | 108 -> X (N N_option_preceded_COLON_core_type__) - | 107 -> + | 108 -> X (N N_option_preceded_EQUAL_expr__) - | 106 -> + | 107 -> X (N N_option_preceded_EQUAL_module_type__) - | 105 -> + | 106 -> X (N N_option_preceded_EQUAL_pattern__) - | 104 -> + | 105 -> X (N N_option_preceded_EQUAL_seq_expr__) - | 103 -> + | 104 -> X (N N_option_type_constraint_) - | 102 -> + | 103 -> X (N N_optlabel) - | 101 -> + | 102 -> X (N N_paren_module_expr) - | 100 -> + | 101 -> X (N N_parse_any_longident) - | 99 -> + | 100 -> X (N N_parse_constr_longident) - | 98 -> + | 99 -> X (N N_parse_core_type) - | 97 -> + | 98 -> X (N N_parse_expression) - | 96 -> + | 97 -> X (N N_parse_mod_ext_longident) - | 95 -> + | 96 -> X (N N_parse_mod_longident) - | 94 -> + | 95 -> X (N N_parse_module_expr) - | 93 -> + | 94 -> X (N N_parse_module_type) - | 92 -> + | 93 -> X (N N_parse_mty_longident) - | 91 -> + | 92 -> X (N N_parse_pattern) - | 90 -> + | 91 -> X (N N_parse_val_longident) - | 89 -> + | 90 -> X (N N_pattern) - | 88 -> + | 89 -> X (N N_pattern_comma_list_pattern_) - | 87 -> + | 88 -> X (N N_pattern_comma_list_pattern_no_exn_) - | 86 -> + | 87 -> X (N N_pattern_gen) - | 85 -> + | 86 -> X (N N_pattern_no_exn) - | 84 -> + | 85 -> X (N N_pattern_var) - | 83 -> + | 84 -> X (N N_payload) - | 82 -> + | 83 -> X (N N_possibly_poly_core_type_) - | 81 -> + | 82 -> X (N N_possibly_poly_core_type_no_attr_) - | 80 -> + | 81 -> X (N N_post_item_attribute) - | 79 -> + | 80 -> X (N N_primitive_declaration) - | 78 -> + | 79 -> X (N N_private_flag) - | 77 -> + | 78 -> X (N N_private_virtual_flags) - | 76 -> + | 77 -> X (N N_rec_flag) - | 75 -> + | 76 -> X (N N_record_expr_content) - | 74 -> + | 75 -> X (N N_reversed_bar_llist_constructor_declaration_) - | 73 -> + | 74 -> X (N N_reversed_bar_llist_extension_constructor_) - | 72 -> + | 73 -> X (N N_reversed_bar_llist_extension_constructor_declaration_) - | 71 -> + | 72 -> X (N N_reversed_llist_preceded_CONSTRAINT_constrain__) + | 71 -> + X (N N_reversed_nonempty_concat_fun_param_as_list_) | 70 -> X (N N_reversed_nonempty_llist_functor_arg_) | 69 -> @@ -46281,22 +46703,22 @@ module MenhirInterpreter = struct 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\000U\000\218\001\185\001\185\001\135\000\132\001\185\000\b\001\135\0017\000\016\000\018\000\022\001\135\0017\000\024\001\135\0017\000\026\000$\0008\000@\000R\001\135\0017\000h\000\016\000F\000\144\000\188\000`\000\144\000\188\000h\000&\000.\000@\000B\000D\000F\000H\000J\000Z\001\135\0017\000\016\000\018\000\255\000.\000\238\000\018\000(\0017\000\014\001\135\0017\000h\000F\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\001c\000.\000r\000\134\001c\0002\000r\000\138\001c\0004\000r\000\234\000\248\000\252\001\004\001\b\001\n\000\227\000.\000j\000/\000\238\000\016\000\018\000:\000\018\000j\001g\000<\000j\000\238\000L\000h\000:\001g\000Z\001\135\0017\000Z\000\020\000P\0017\000\016\000\"\0017\000\020\001\135\0017\000@\000F\000\252\000T\000`\000\252\000h\000\154\000\252\000F\000`\0005\000\016\000:\001g\0007\000;\000{\000.\000\230\000;\0009\000j\000\198\000\018\000>\000h\000j\000\238\000j\000t\000j\000\238\000x\001\185\000*\0006\000D\000F\000N\000\252\001\135\0017\000h\000\014\0017\000V\001\135\0017\000j\001\007\000\218\000\018\000j\001\r\001\015\001\173\001\183\0017\000^\000`\000d\001\135\0017\000f\001\135\0017\000h\000@\000~\000j\000r\000l\001\135\0017\0000\000\153\000~\000\134\0002\000\138\001\015\001#\0004\001U\000\238\000z\000\250\000\223\000|\0002\000\223\000\134\000\168\001\t\000h\001\t\000.\000\218\000\018\001\021\000\218\000j\001\023\001\157\000\250\000\254\001g\000=\000C\000\\\000s\000&\001\023\001\133\001\187\000\168\001\157\000=\000\205\000C\000\\\001w\001\187\000&\001\187\001w\000I\000q\000\127\0002\000\250\000q\000\239\000P\001\b\000\225\000\131\001\b\001w\001\193\001\002\000:\001g\0017\001\193\0017\001\141\001\183\001\193\000I\0002\000q\000\250\000\127\0002\000\127\0002\000\127\0002\000\176\000\137\0002\000\239\000\239\001\141\000\217\000\198\000\140\001\135\0017\000\144\000\168\000=\000\188\000\192\000\242\000/\0001\000W\000Y\000]\000_\000\216\000_\001\155\000\239\001\007\000\218\000h\000.\000\196\001\135\0017\000Y\000\173\000\177\000\230\000\179\000\230\000\179\000\236\000\179\000\250\000\179\001\002\000/\001\183\000\239\000\179\001\133\001\149\000h\000\020\000j\000\237\000\237\000.\000Y\001\149\001\153\000`\000\236\000.\000\179\000.\000\238\001\141\000.\000\179\000\179\000\236\000.\000\179\000.\000\134\0002\000k\0002\000\179\000,\000k\000]\000\179\000\211\000,\000\016\000,\000\221\001#\000\246\000k\000\246\000/\000\030\000h\000j\000\238\001\141\001W\000.\000j\000<\000h\001W\000\198\000n\000/\000L\000\016\000h\000\179\000\238\001\141\001G\000\209\000.\000j\000\169\000h\000\020\000\237\000.\000\142\000Y\000\198\000p\000N\000\252\001\135\0017\000\178\0017\000h\000.\000\255\000\238\000h\000.\000\\\000\178\0017\000\141\001u\001s\000\\\000\245\000\251\000\004\000\020\0009\001U\000\198\000>\000\234\001\193\000\031\001\193\000\143\000\226\001\141\000\198\001\141\000;\000Z\000\020\000\245\000\198\000\251\000\\\000\251\001\183\001\t\000\218\000\018\001g\001\017\001g\001\133\000\234\000\251\001\007\000\198\001\t\000\218\000\234\001\t\000!\000\129\001\006\000!\001u\000\251\000\251\000.\000\251\000.\001s\000\\\000\203\001\001\000h\000.\001\001\000.\000\238\000\251\000.\000\203\001\183\001\007\001\133\001\001\000\162\000\134\000\136\000j\000\198\000\138\000j\000\210\000\214\000\140\001\135\0017\000\244\001\135\0017\000\164\001\135\0017\000\180\001\135\0017\000\250\000\179\000\n\000\182\001\135\0017\000h\000\020\000\237\000.\000\\\000\184\001\135\0017\000\179\000\162\000\186\001\135\0017\000\179\000\198\000\252\000-\000/\000[\000\166\000[\000\168\000j\000\212\000h\001\000\001\135\0017\000[\000\218\000h\000K\000[\000\030\000h\000j\000\232\001\141\000\238\001\141\000\232\001\141\000A\000.\000j\000<\000j\000L\000[\000\239\001\007\000\218\000h\000.\000D\000F\000Z\001\135\0017\001\001\000\238\000\251\000.\000^\000`\000n\000Y\000\238\001\141\000\198\000g\000u\000\230\000\239\000[\001\011\001\133\001\149\001\155\001\031\000\162\000g\001!\001K\000\162\000g\001\137\000&\001\137\000B\001\137\000D\001\137\000F\001\137\000H\001\137\000J\001\137\000^\001\137\000`\001\137\000t\001\137\000\150\001\137\000\152\001\137\000\154\001\137\000\156\001\137\000\158\001\137\000\176\001\137\000\198\001\137\000\230\001\137\000\234\001\137\000\236\001\137\000\248\001\137\001\b\001\137\001\n\001\137\001\183\001\149\000[\001\195\001\137\000,\000H\001\185\000g\000g\001\006\0017\000W\000\238\001\141\000\198\000g\000\171\000\198\000g\000\230\000\179\000\236\000\179\000\250\000\179\001\002\000/\001\183\000\173\000\175\000\230\000\179\001M\001O\000\130\001\185\000<\000\179\000\n\000g\000Z\000\020\001\135\0017\001g\000\198\000\251\000\213\000\161\0011\0011\001\135\0017\0000\000\255\000\198\001\001\000\238\000\251\000\198\001\001\001\005\0011\001\006\0017\000\255\001\005\0011\001;\001u\001\005\001;\000\255\001\005\0011\000v\001\185\000\128\001\185\000\160\001\135\0017\001\001\0011\000\194\001\135\0017\000/\000\238\000\135\000:\001g\000\218\001\141\000\165\000\198\000$\000\235\000\235\0011\001\141\000\196\001\135\0017\000\018\000h\000\236\000.\000\134\001\151\000P\000\138\000X\000\243\000j\000\238\000\135\000\218\001\193\000\163\0017\000,\0017\001\193\001Y\0004\001[\001Y\001]\000y\000&\001\187\001\145\001\187\000\198\000h\001\007\000\218\000h\001\149\0017\0011\000\238\000\135\000\218\001\145\000\\\001\187\001\187\001\145\000\\\001\187\001\187\001q\0017\0011\001\153\000\238\000\020\001\135\0017\000T\0009\000j\000\234\000\134\000\138\001Y\0004\000\216\000\250\001\151\001q\0017\000\149\000\250\001o\000\233\000\143\0011\001m\001o\001\141\000\198\000>\000\138\001Y\0004\000\216\001\143\001\151\001q\0017\000\138\001Y\0004\000\216\001\143\001\143\000?\000\143\0011\000=\000B\000>\000\157\000\145\0011\001o\001m\001o\0009\000j\000\234\000\233\000\143\0011\000?\000\143\0011\000=\000B\000\157\000\145\0011\000*\000N\000\252\001\135\0017\001\t\0011\001\135\0017\001\t\0011\000Z\000\020\001\135\0017\001g\000\234\000\251\0011\001\135\0017\000\018\000\234\001\t\0011\0000\000\255\000\238\000\251\0011\001\006\0017\000\255\000\238\000\251\0011\0019\0019\000\255\000\198\001\007\0011\000\238\000\251\001\003\0011\001u\001\003\000\160\001\135\0017\000\251\0011\000\196\001\135\0017\001\151\000\240\000\020\001\135\0017\000\012\000'\000\134\000{\0002\001}\000j\000\198\000R\0017\000h\001\141\000.\001\169\000\014\0017\000\012\000X\000X\000\012\000\241\000j\000\238\001\141\0011\000b\0017\000\012\000>\000>\000\012\000\155\000j\000\238\000\165\0011\000\148\0017\000p\000N\000\252\0017\001\007\000\162\000\134\000}\0002\001\157\000\230\001\141\001\141\001\133\001\157\001\165\001\183\0017\001\007\000\162\001\165\001\165\0011\000\226\0017\001\141\000\198\001\141\001\147\0011\001+\000\204\001_\0011\001\127\001\167\001+\001\165\0011\001\006\0017\000'\001}\000j\000\198\001\165\0011\001=\001=\001\135\0017\000'\001}\000j\000\238\000j\000\238\000C\000\\\000\134\001\141\000C\000\\\000\205\000C\000\\\001\023\001\133\001\161\001\165\001\161\001\161\001\161\0011\001\006\0017\000'\001}\000j\000\238\001\161\0011\001?\001?\000)\000a\000e\000\159\000\229\000\247\000\249\000\253\001/\001_\0011\001i\001\006\0017\0009\000j\000?\000\143\0011\0015\0015\001k\001\006\0017\0009\000j\000\234\000\233\000\143\0011\0013\0013\001\127\001\159\001/\000c\001/\001\141\000\240\001\135\0017\000'\001}\000j\000\198\000R\0017\001\171\000\014\000\252\0017\000\243\000j\000\198\000g\000A\000\198\000g\000+\0011\0017\000\012\000X\000X\000\012\000%\000j\000\238\001\141\000\243\000j\000\198\000g\000A\000\198\000g\000b\000\252\0017\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\165\000\198\000g\000Q\000Y\001Q\000A\000\198\000g\000Q\001{\001\025\0011\0017\000\012\000>\000>\000\012\000#\000j\000\238\000\165\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\165\000\198\000g\000Q\000\146\0017\000g\0011\000\148\000\252\0017\000h\000p\000H\001\185\0017\000\153\001O\0011\000N\000\252\0017\001\007\000\162\000\134\000}\0002\001\173\000\182\0017\001Q\000\\\001I\000\162\001\133\001\163\000\142\000[\000[\000\139\001S\001S\001\173\001\181\001\183\001\191\001\181\001\175\001\175\001\181\0017\001\007\000\162\001\181\0017\000\153\001O\0011\001\181\000.\000\238\001\161\000.\001\181\001\002\000j\000\219\0011\0017\001\181\000\219\0011\000\226\0017\001\147\0011\001)\000\204\001_\0011\001\127\001\179\001)\001\181\000\238\001\161\000\198\001\181\001Q\001\177\001\177\0011\001\006\0017\000'\001}\000j\001\177\0011\001A\001A\000)\000M\000p\001\135\0017\000\153\001O\0011\000S\000e\000\159\000\231\000\249\001\031\001\191\001-\001K\001\191\001_\0011\001i\0015\001\127\001\159\000O\000g\0011\001-\000\167\0002\001\031\001-\001K\000\167\0002\000\167\0002\0011\001\137\000\171\000\198\000g\001C\000\162\000g\001\004\001E\001E\000\252\000g\000.\000~\000\246\000o\000\246\001\137\000,\000o\000\134\0002\000o\0002\000\136\000m\000\172\000\138\000[\000\004\000i\001U\000A\000\207\000\215\000,\000i\000i\000\151\0004\001\007\000\218\000j\000/\000\212\000h\000o\000.\000r\001\137\000\134\000o\0002\000r\001\137\000\138\000o\0004\000r\001\137\000\218\000h\000g\000.\000r\001\137\000\134\000g\0002\000r\001\137\000\138\000g\0004\000r\001\137\001\007\000\212\000h\000o\000.\000r\001\137\000\134\000o\0002\000r\001\137\000\138\000o\0004\000r\001\137\001U\000r\001\137\000\139\001\137\000g\000.\000\134\000g\0002\000\138\000g\0004\001\007\000\212\000h\000o\000.\000\134\000o\0002\000\138\000o\0004\001U\000o\000.\000\134\000o\0002\000\138\000o\0004\000g\000\028\000\208\001\139\000g\000\224\000g\000\220\000g\000\224\000g\000\220\000\198\000g\001\139\000g\000\224\000g\000\220\000g\000h\000\020\000\237\000.\000\238\001\187\000\\\000g\001Q\001y\001y\001y\001Q\001y\000g\000\\\000g\000\\\000\218\000g\001\029\000\133\000\250\001\029\001\029\000g\000 \001\137\000\206\001\137\000\204\000g\000\204\000[\001\137\000\174\000[\000\151\0004\001\137\000\215\000,\000m\000\172\000m\000\172\000o\0002\000g\001\135\0017\001\001\000\162\000g\000Z\001\135\0017\000\255\001\005\000\162\000g\000\196\001\135\0017\001\151\001q\0017\000\162\000g\000g\001{\000Q\000g\000\209\000.\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\135\000\218\001\141\000\198\000g\000A\000\198\000g\000Q\001O\0011\001\137\000\246\000o\000\246\000[\000Z\001\135\0017\001\001\000.\000\238\000\251\000.\000g\000.\000A\000.\000g\000\004\000\133\000g\000\004\000\133\001\137\000.\000\232\000\251\000.\000\238\000\251\000.\000\232\000\251\000.\001\001\0011\001\135\0017\001\001\0011\000g\0011\001-\001-\000\167\0002\000\163\0017\000,\0017\000\216\001\027\001\187\000,\001\027\000\176\001\027\000\176\000C\000\\\001w\000w\000.\000\168\001\157\000=\000\230\001\141\001\141\000.\000\230\001\141\000\138\001Y\0004\000\216\001\141\001\143\000\233\000=\000B\000\157\000\250\001\151\000\198\001\149\0017\000\147\0011\001o\001\131\001m\001o\001\129\001\131\001\151\000\198\001\149\0017\0009\000j\000=\000B\000\157\000\147\0011\000O\000\204\001\001\000\251\000.\000\165\0011\000c\000\204\000\251\000.\000\179\000.\000\238\001\141\000.\001\171\001)\000\204\000g\000\004\000\133\000g\000\004\000\133\000\190\000g\000\190\000g\000g\000\224\000g\000\220\000\167\0002\0017\000g\000\224\000g\000\220\000O\000\202\001e\000\000\000c\000\202\001a\000\000\000h\000\236\000.\0001\000\201\001\t\000\218\000h\000\236\000.\0001\001g\001\019\001g\001\153\001\189\000\202\000\000\000\199\001\149\000\202\000\000\000\197\001\141\000\202\000\000\000g\000\202\000\195\000\000\000\193\001\t\000\202\000\000\000\191\001\007\000\202\000\000\000\189\001\001\000\202\000\000\000\187\000\251\000\202\000\000\000\185\000\245\000\202\000\000\000\179\000\202\000\183\000\000\000-\000\202\000\181\001\007\000\218\000\000\000\168\001g\000\026\000$\000\144\000\192\000-\001\007\000\202\000E\000G\000*\000M\001'\000g\0011\000*\001'\000*\000\000\000*\000G\000M\001%\001%\000g\0011\001%\001%\0003\000g\0011\001%\000\202\001%\000\202") + (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\000U\000\218\001\205\001\205\001\149\000\132\001\205\000\b\001\149\001=\000\016\000\018\000\022\001\149\001=\000\024\001\149\001=\000\026\000$\0008\000@\000R\001\149\001=\000h\000\016\000F\000\144\000\188\000`\000\144\000\188\000h\000&\000.\000@\000B\000D\000F\000H\000J\000Z\001\149\001=\000\016\000\018\001\005\000.\000\238\000\018\000(\001=\000\014\001\149\001=\000h\000F\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\001i\000.\000r\000\134\001i\0002\000r\000\138\001i\0004\000r\000\234\000\248\000\252\001\004\001\b\001\n\000\231\000.\000j\000/\000\238\000\016\000\018\000:\000\018\000j\001m\000<\000j\000\238\000L\000h\000:\001m\000Z\001\149\001=\000Z\000\020\000P\001=\000\016\000\"\001=\000\020\001\149\001=\000@\000F\000\252\000T\000`\000\252\000h\000\154\000\252\000F\000`\0005\000\016\000:\001m\0007\000;\000{\000.\000\230\000;\0009\000j\000\198\000\018\000>\000h\000j\000\238\000j\000t\000j\000\238\000x\001\205\000*\0006\000D\000F\000N\000\252\001\149\001=\000h\000\014\001=\000V\001\149\001=\000j\001\r\000\218\000\018\000j\001\019\001\021\001\191\001\201\001=\000^\000`\000d\001\149\001=\000f\001\149\001=\000h\000@\000~\000j\000r\000l\001\149\001=\0000\000\155\000~\000\134\0002\000\138\001\021\001)\0004\001[\000\238\000z\000\250\000\227\000|\0002\000\227\000\134\000\168\001\015\000h\001\015\000.\000\218\000\018\001\027\000\218\000j\001\029\001\175\000\250\000\254\001m\000=\000C\000\\\000s\000&\000\237\001\015\000\218\000h\000\207\000C\000\\\001\029\001}\001\141\001\147\001\155\001\157\001\207\000&\001\207\000\168\001\175\000=\001}\001\159\000.\001\201\001\213\001\002\000:\001m\001\155\001\207\001}\000I\000q\000\127\0002\000\250\000q\000\245\000P\001\b\000\229\000\131\001\b\001\213\001=\001\213\001=\001\159\000I\0002\000q\000\250\000\127\0002\000\127\0002\000\127\0002\000\176\000\137\0002\000\245\000\245\001\159\000\219\000\198\000\140\001\149\001=\000\144\000\168\000=\000\188\000\192\000\242\000/\0001\000W\000Y\000]\000_\000\216\000_\001\173\000\245\001\r\000\218\000h\000.\000\196\001\149\001=\000Y\000\175\000\179\000\230\000\181\000\230\000\181\000\236\000\181\000\250\000\181\001\002\000/\001\201\000\245\000\181\001\147\001\167\000h\000\020\000j\000\243\000\243\000.\000Y\001\167\001\171\000`\000\236\000.\000\181\000.\000\238\001\159\000.\000\181\000\181\000\236\000.\000\181\000.\000\134\0002\000k\0002\000\181\000,\000k\000]\000\181\000\213\000,\000\016\000,\000\225\001)\000\246\000k\000\246\000/\000\030\000h\000j\000\238\001\159\001]\000.\000j\000<\000h\001]\000\198\000n\000/\000L\000\016\000h\000\181\000\238\001\159\001M\000\211\000.\000j\000\171\000h\000\020\000\243\000.\000\142\000Y\000\198\000p\000N\000\252\001\149\001=\000\178\001=\000h\000.\001\005\000\238\000h\000.\000\\\000\178\001=\000\141\001{\001y\000\\\000\251\001\001\000\004\000\020\0009\001[\000\198\000>\000\234\001\213\000\031\001\213\000\145\000\226\001\159\000\198\001\159\000;\000Z\000\020\000\251\000\198\001\001\000\\\001\001\001\201\001\015\000\218\000\018\001m\001\023\001m\001\147\000\234\001\001\001\r\000\198\001\015\000\218\000\234\001\015\000!\000\129\001\006\000!\001{\001\001\001\001\000.\001\001\000.\001y\000\\\000\205\001\007\000h\000.\001\007\000.\000\238\001\001\000.\000\205\001\201\001\r\001\147\001\007\000\162\000\134\000\136\000j\000\198\000\138\000j\000\210\000\214\000\140\001\149\001=\000\244\001\149\001=\000\164\001\149\001=\000\180\001\149\001=\000\250\000\181\000\n\000\182\001\149\001=\000Y\000\143\001W\001\131\001\129\000\238\001\207\000\221\000\\\000\180\001\149\001=\000\133\000\250\001#\001#\000\184\001\149\001=\000\181\000\162\000\186\001\149\001=\000\181\000\198\000\252\000-\000/\000[\000\166\000[\000\168\000j\000\212\000h\000\180\001\149\001=\000\133\001\000\001\149\001=\000[\000\218\000h\000K\000[\000\030\000h\000j\000\232\001\159\000\238\001\159\000\232\001\159\000A\000.\000j\000<\000j\000L\000[\000\245\001\r\000\218\000h\000.\000D\000F\000Z\001\149\001=\001\007\000\238\001\001\000.\000^\000`\000n\000Y\000\238\001\159\000\198\000g\000u\000\230\000\245\000[\001\017\001\147\001\167\001\173\001%\000\162\000g\001'\001Q\000\162\000g\001\127\001\133\000&\001\133\000B\001\151\000\230\001\151\001\167\000[\001\215\001\151\000D\001\151\000F\001\151\000H\001\151\000J\001\151\000^\001\151\000`\001\151\000t\001\151\000\150\001\151\000\152\001\151\000\154\001\151\000\156\001\151\000\158\001\151\000\176\001\151\000\198\001\151\000\234\001\151\000\236\001\151\000\248\001\151\001\b\001\151\001\n\001\151\001\201\001\151\000,\000H\001\205\000g\001\151\000g\001\006\001=\000W\000\238\001\159\000\198\000g\000\173\000\198\000g\000\230\000\181\000\236\000\181\000\250\000\181\001\002\000/\001\201\000\175\000\177\000\230\000\181\001S\001U\000\130\001\205\000<\000\181\000\n\000g\000Z\000\020\001\149\001=\001m\000\198\001\001\000\215\000\163\0017\0017\001\149\001=\0000\001\005\000\198\001\007\000\238\001\001\000\198\001\007\001\011\0017\001\006\001=\001\005\001\011\0017\001A\001{\001\011\001A\001\005\001\011\0017\000v\001\205\000\128\001\205\000\160\001\149\001=\001\007\0017\000\194\001\149\001=\000/\000\238\000\135\000:\001m\000\218\001\159\000\167\000\198\000$\000\241\000\241\0017\001\159\000\196\001\149\001=\000\018\000h\000\236\000.\000\134\001\169\000P\000\138\000X\000\249\000j\000\238\000\135\000\218\001\213\000\165\001=\000,\001=\001\213\001_\0004\001a\001_\001c\000y\000&\001\207\001\163\001\207\000\198\000h\001\r\000\218\000h\001\167\001=\0017\000\238\000\135\000\218\001\163\000\\\001\207\001\207\001\163\000\\\001\207\001\207\001w\001=\0017\001\171\000\238\000\020\001\149\001=\000T\0009\000j\000\234\000\134\000\138\001_\0004\000\216\000\250\001\169\001w\001=\000\151\000\250\001u\000\239\000\145\0017\001s\001u\001\159\000\198\000>\000\138\001_\0004\000\216\001\161\001\169\001w\001=\000\138\001_\0004\000\216\001\161\001\161\000?\000\145\0017\000=\000B\000>\000\159\000\147\0017\001u\001s\001u\0009\000j\000\234\000\239\000\145\0017\000?\000\145\0017\000=\000B\000\159\000\147\0017\000*\000N\000\252\001\149\001=\001\015\0017\001\149\001=\001\015\0017\000Z\000\020\001\149\001=\001m\000\234\001\001\0017\001\149\001=\000\018\000\234\001\015\0017\0000\001\005\000\238\001\001\0017\001\006\001=\001\005\000\238\001\001\0017\001?\001?\001\005\000\198\001\r\0017\000\238\001\001\001\t\0017\001{\001\t\000\160\001\149\001=\001\001\0017\000\196\001\149\001=\001\169\000\240\000\020\001\149\001=\000\012\000'\000\134\000{\0002\001\137\000j\000\198\000R\001=\000h\001\159\000.\001\187\000\014\001=\000\012\000X\000X\000\012\000\247\000j\000\238\001\159\0017\000b\001=\000\012\000>\000>\000\012\000\157\000j\000\238\000\167\0017\000\148\001=\000p\000N\000\252\001=\001\r\000\162\000\134\000}\0002\001\175\000\230\001\159\001\159\001\147\001\175\001\183\001\201\001=\001\r\000\162\001\183\001\183\0017\000\226\001=\001\159\000\198\001\159\001\165\0017\0011\000\204\001e\0017\001\139\001\185\0011\001\183\0017\001\006\001=\000'\001\137\000j\000\198\001\183\0017\001C\001C\001\149\001=\000'\001\137\000j\000\238\000j\000\238\000C\000\\\000\134\001\159\000C\000\\\000\207\000C\000\\\001\029\001\147\001\179\001\183\001\179\001\179\001\179\0017\001\006\001=\000'\001\137\000j\000\238\001\179\0017\001E\001E\000)\000a\000e\000\161\000\233\000\253\000\255\001\003\0015\001e\0017\001o\001\006\001=\0009\000j\000?\000\145\0017\001;\001;\001q\001\006\001=\0009\000j\000\234\000\239\000\145\0017\0019\0019\001\139\001\177\0015\000c\0015\001\159\000\240\001\149\001=\000'\001\137\000j\000\198\000R\001=\001\189\000\014\000\252\001=\000\249\000j\000\198\000g\000A\000\198\000g\000+\0017\001=\000\012\000X\000X\000\012\000%\000j\000\238\001\159\000\249\000j\000\198\000g\000A\000\198\000g\000b\000\252\001=\000\159\000j\000\238\000\020\000\243\000\218\001\159\000\198\000g\000\167\000\198\000g\000Q\001\129\000A\000\209\000\198\001\127\001\135\001\131\001\031\0017\001=\000\012\000>\000>\000\012\000#\000j\000\238\000\167\000\159\000j\000\238\000\020\000\243\000\218\001\159\000\198\000g\000\167\000\198\000g\000Q\000\146\001=\000g\0017\000\148\000\252\001=\000h\000p\000H\001\205\001=\000\155\001U\0017\000N\000\252\001=\001\r\000\162\000\134\000}\0002\001\191\000\182\001=\001W\000\\\001O\000\162\001\147\001\181\000\142\000[\000[\000\139\001Y\001Y\001\191\001\199\001\201\001\211\001\199\001\193\001\193\001\199\001=\001\r\000\162\001\199\001=\000\155\001U\0017\001\199\000.\000\238\001\179\000.\001\199\001\002\000j\000\223\0017\001=\001\199\000\223\0017\000\226\001=\001\165\0017\001/\000\204\001e\0017\001\139\001\197\001/\001\199\000\238\001\179\000\198\001\199\001W\001\195\001\195\0017\001\006\001=\000'\001\137\000j\001\195\0017\001G\001G\000)\000M\000p\001\149\001=\000\155\001U\0017\000S\000e\000\161\000\235\000\255\001%\001\211\0013\001Q\001\211\001e\0017\001o\001;\001\139\001\177\000O\000g\0017\0013\000\169\001%\0013\001Q\001\203\0002\000\169\0002\001\203\0002\0017\001\151\000\173\000\198\000g\001I\000\162\000g\001\004\001K\001K\000\252\000g\000.\000~\000\246\000o\000\246\001\151\000,\000o\000\134\0002\000o\0002\000\136\000m\000\172\000\138\000[\000\004\000i\001[\000\209\000\217\000,\000i\000i\000\153\0004\001\r\000\218\000j\000/\000\212\000h\000o\000.\000r\001\151\000\134\000o\0002\000r\001\151\000\138\000o\0004\000r\001\151\000\218\000h\000g\000.\000r\001\151\000\134\000g\0002\000r\001\151\000\138\000g\0004\000r\001\151\001\r\000\212\000h\000o\000.\000r\001\151\000\134\000o\0002\000r\001\151\000\138\000o\0004\000r\001\151\001[\000r\001\151\000\139\001\151\000g\000.\000\134\000g\0002\000\138\000g\0004\001\r\000\212\000h\000o\000.\000\134\000o\0002\000\138\000o\0004\001[\000o\000.\000\134\000o\0002\000\138\000o\0004\000g\000\028\000\208\001\153\000g\000\224\000g\000\220\000g\000\224\000g\000\220\000\198\000g\001\153\000g\000\224\000g\000\220\001\135\000g\000\\\000g\000\\\000\218\000g\001#\000\133\000g\000 \001\151\000\206\001\151\000\204\000g\000\204\000[\001\151\000\174\000[\000\153\0004\001\151\000\217\000,\000m\000\172\000m\000\172\000o\0002\000g\001\149\001=\001\007\000\162\000g\000Z\001\149\001=\001\005\001\011\000\162\000g\000\196\001\149\001=\001\169\001w\001=\000\162\000g\000g\000Q\000g\000\211\000.\000j\000\238\000\020\000\243\000\218\001\159\000\198\000g\000\135\000\218\001\159\000\198\000g\000A\000\198\000g\000Q\001U\0017\001\151\000\246\000o\000\246\000[\000Z\001\149\001=\001\007\000.\000\238\001\001\000.\000g\000.\000A\000.\000g\000\004\000\133\000g\000\004\000\133\001\151\000.\000\232\001\001\000.\000\238\001\001\000.\000\232\001\001\000.\001\007\0017\001\149\001=\001\007\0017\000g\0017\0013\0013\000\169\0002\000\165\001=\000,\001=\000\216\001!\001\207\000,\001!\000\176\001!\000\176\000C\000\\\001}\000w\000.\000\168\001\175\000=\000\230\001\159\001\159\000\230\001\159\000\138\001_\0004\000\216\001\159\001\161\000\239\000=\000B\000\159\000\250\001\169\000\198\001\167\001=\000\149\0017\001u\001\145\001s\001u\001\143\001\145\001\169\000\198\001\167\001=\0009\000j\000=\000B\000\159\000\149\0017\000O\000\204\001\007\001\001\000.\000\167\0017\000c\000\204\001\001\000.\000\181\000.\000\238\001\159\000.\001\189\001/\000\204\000g\000\004\000\133\000g\000\004\000\133\000\190\000g\000\190\000g\000g\000\224\000g\000\220\001\203\0002\001=\000g\000\224\000g\000\220\000O\000\202\001k\000\000\000c\000\202\001g\000\000\000h\000\236\000.\0001\000\203\001\015\000\218\000h\000\236\000.\0001\001m\001\025\001m\001\171\001\209\000\202\000\000\000\201\001\167\000\202\000\000\000\199\001\159\000\202\000\000\000g\000\202\000\197\000\000\000\195\001\015\000\202\000\000\000\193\001\r\000\202\000\000\000\191\001\007\000\202\000\000\000\189\001\001\000\202\000\000\000\187\000\251\000\202\000\000\000\181\000\202\000\185\000\000\000-\000\202\000\183\001\r\000\218\000\000\000\168\001m\000\026\000$\000\144\000\192\000-\001\r\000\202\000E\000G\000*\000M\001-\000g\0017\000*\001-\000*\000\000\000*\000G\000M\001+\001+\000g\0017\001+\001+\0003\000g\0017\001+\000\202\001+\000\202") and rhs = - ((16, "\001e\001a\000\201\000\199\000\197\000\195\000\193\000\191\000\189\000\187\000\185\000\183\000\181\000E\0003\000F\000D\001w\001\193\001\002\000:\001g\001\006\0017\001O\0011\001\019\001\153\000h\001\141\000.\000h\000Z\001\135\0017\000\251\000.\000:\001g\000\016\000=\001\187\000=\000h\000w\000.\000=\000t\001\027\000\176\000t\000\176\000\168\001\157\001\187\000\168\001\157\000h\000w\000.\000\168\001\157\000\134\000I\0002\000\134\000\250\000\127\0002\000\134\000q\000\250\000\127\0002\000|\000\223\000\127\0002\000|\0002\000z\000\223\000\127\0002\000z\000\223\000\127\000\176\000\137\0002\001\133\000U\000U\000\218\001\185\000\132\001\185\000\167\0002\001\163\000\182\0017\001\175\001I\000\162\001\181\000p\000N\0017\001\007\000\162\001\181\000p\000N\000\252\0017\001\007\000\162\001\181\001\181\001\183\001\163\000\139\001\133\000\148\0017\001\181\000\219\0011\000\148\000\252\0017\001\181\000\219\0011\000\014\000+\0011\000b\001\025\0011\000\226\0017\001\147\0011\000\146\0017\000g\0011\001_\0011\001\127\000\198\001\181\000\238\001\161\000\198\001\181\001Q\001\177\001Q\000\\\001\181\001Q\001\175\001\015\000h\000\179\000.\000h\000\179\000\238\001\141\000.\000h\001\141\000.\000\148\0017\001\165\0011\000\014\0017\000\241\000j\000\238\001\141\0011\000b\0017\000\155\000j\000\238\000\165\0011\000\226\0017\001\147\0011\001_\0011\001\127\001\157\000\134\000}\0002\001\157\001\133\000R\0017\001\169\001+\000\204\001\165\001\183\000p\000N\0017\001\007\000\162\001\165\000p\000N\000\252\0017\001\007\000\162\001\165\000h\001\181\000.\001\173\000\134\000}\0002\001\173\000h\001\181\000\238\001\161\000.\000R\0017\001\171\001)\000\204\001\165\000\205\000C\000\\\001\161\000j\000\238\000C\000\\\001\161\000C\000\\\001\161\000\240\000\020\001\135\0017\000'\001}\000j\000\198\001\165\0011\001=\001\023\000\144\000\242\000$\000\188\000\134\0002\000h\000.\000\192\000\026\000\018\000h\000\236\000.\001\153\001\007\001\007\000\218\000h\000\236\000.\000h\000\236\000.\001\153\001\141\000\198\001\141\001\187\000y\000&\001\187\000\138\001Y\0004\000\250\000\149\001\193\001\141\001\183\000\028\000\208\001\031\000\162\000g\000d\001\135\0017\000g\000\004\000\133\000\022\001\135\0017\000g\000\022\001\135\0017\000g\000\004\000\133\000\022\001\135\0017\000g\000\190\000g\000\022\001\135\0017\000g\000\004\000\133\000\190\000g\000\006\001\135\0017\000g\000\224\000g\000\220\000\184\001\135\0017\000\179\000\198\000g\001\139\000g\000\224\000g\000\220\000\184\001\135\0017\000\179\000\162\000g\000\224\000g\000\220\000[\000p\000Z\001\135\0017\000\255\001\005\000\162\000g\000p\000\196\001\135\0017\001\151\001q\0017\000\162\000g\000p\000N\001\135\0017\001\001\000\162\000g\000p\000N\000\252\001\135\0017\001\001\000\162\000g\000\180\001\135\0017\000\133\000\182\001\135\0017\001Q\001y\000\182\001\135\0017\000h\000\020\000\237\000.\001y\000f\001\135\0017\000g\000\004\000\133\000\024\001\135\0017\000g\000\004\000\133\000\164\001\135\0017\000g\000 \001\137\000\206\001\137\000\164\001\135\0017\000g\000 \001\137\000\b\001\135\0017\000g\000\224\000g\000\220\000\186\001\135\0017\000\179\000\198\000g\001\139\000g\000\224\000g\000\220\001\000\001\135\0017\000[\000\140\001\135\0017\000[\000[\000\139\000u\001\149\000[\000\239\000[\001\137\000\158\001\137\001\137\000\156\001\137\001\137\000\154\001\137\001\137\000\152\001\137\001\137\000\150\001\137\001\137\000F\001\137\001\137\000D\001\137\001\137\000B\001\137\001\137\000`\001\137\001\137\000^\001\137\001\137\000&\001\137\001\137\000H\001\137\001\137\000\198\001\137\001\137\000t\001\137\001\137\000\176\001\137\001\137\000J\001\137\001\137\000\248\001\137\001\137\001\b\001\137\001\137\001\n\001\137\001\137\000\234\001\137\000K\001\137\001\195\001\137\001K\000\162\000g\000n\001C\000\162\000g\001\137\000\236\001\137\000j\000r\001\137\000[\000\218\001U\000r\001\137\000[\000\218\000h\000g\000.\000r\001\137\000[\000\218\000\138\000g\0004\000r\001\137\000[\000\218\000\134\000g\0002\000r\001\137\000[\000\212\000h\000o\000.\000r\001\137\000[\000\218\001\007\000\212\000h\000o\000.\000r\001\137\000[\000\212\000\138\000o\0004\000r\001\137\000[\000\218\001\007\000\212\000\138\000o\0004\000r\001\137\000[\000\212\000\134\000o\0002\000r\001\137\000[\000\218\001\007\000\212\000\134\000o\0002\000r\001\137\001\137\001\183\000H\001\185\000x\001\185\000\167\0002\0008\000\250\001\151\000\198\001\149\0017\001\151\000\198\001\149\0017\000\128\001\185\000\167\0002\000\134\000{\0002\000Q\000A\000\198\000g\000\\\000g\000\238\001\187\000\\\000g\001Q\001y\000h\000\020\000\237\000.\001y\000C\000\205\000C\000\\\001w\000j\000\238\000C\000\\\001w\000C\000\\\001w\000h\000.\000h\000\255\000\238\000\251\000.\000\141\000P\001\145\000\238\001\145\000\\\001\187\000\238\000\135\000\218\001\145\000\\\001\187\000\238\001\187\000\238\000\135\000\218\001\187\000\250\001\151\001q\0017\001\151\001q\0017\000\020\001\135\0017\0009\000j\000\234\000\233\000\143\0011\000\020\001\135\0017\000T\0009\000j\000\234\000\233\000\143\0011\000\020\001\135\0017\0009\000j\000?\000\143\0011\000\020\001\135\0017\000T\0009\000j\000?\000\143\0011\000\018\000j\000O\000\202\000,\000\216\000c\000\202\000v\001\185\000\167\0002\0006\000\243\000j\000\238\000\163\0017\000\243\000j\000\238\000\163\0017\000,\0017\001]\001[\001[\001Y\000j\000j\000\238\001\141\001\015\000[\000\142\000[\000\030\000j\000\030\000h\000j\000A\000.\000<\000j\000L\000[\000<\000h\001W\000\209\000.\000<\000j\000L\000h\001G\000\209\000.\000L\000\169\000\030\000h\001W\000.\000\030\000j\000\142\000Y\000Y\001M\000/\000/\000Q\000/\000A\000\198\000g\000/\000\238\000\135\000\218\001\141\000\198\000g\000/\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\171\000\198\000g\000W\000\238\001\141\000\198\000g\000p\001\135\0017\000\153\001O\0011\001K\001\191\000p\0017\000\153\001O\0011\000p\000H\001\185\0017\000\153\001O\0011\001I\001\191\000\179\000\179\000\238\001\141\000/\000Q\000/\000Y\000\238\001\141\000\198\000g\000\171\000\198\000g\001E\001C\001\004\001E\001\006\0017\000'\001}\000j\001\177\0011\001A\001\006\0017\000'\001}\000j\000\238\001\161\0011\001?\001\006\0017\000'\001}\000j\000\198\001\165\0011\001=\001\006\0017\000\255\001\005\0011\001;\001\006\0017\000\255\000\238\000\251\0011\0019\001\183\0017\001\006\0017\0009\000j\000?\000\143\0011\0015\001\006\0017\0009\000j\000\234\000\233\000\143\0011\0013\000\161\0011\000*\001/\000a\001/\000*\001-\000*\000g\0011\001-\000M\001-\001\167\001+\001\179\001)\000M\001'\000*\001%\000*\000g\0011\001%\000M\001%\000G\001%\001U\000\217\000\211\001U\000\217\000\211\000,\001U\000\217\000\211\000,\000\016\000\221\001U\000\217\000\211\000,\001#\000l\001\135\0017\000\153\001O\0011\001!\001\031\001\191\000\179\000\\\000g\000\179\000\n\000g\000\\\000g\000\179\000\\\000\218\000j\000\238\000\163\0017\000,\0017\001\027\001\187\000,\001\027\000j\000\238\000\163\0017\000,\0017\001\187\000,\000j\000\238\000\163\0017\001\187\000\216\0017\000#\000j\000\238\000\165\0017\000\157\000j\000Q\000\252\0017\000\157\000j\000Q\0017\000\157\000j\000\238\000\165\000\198\000g\000\252\0017\000\157\000j\000\238\000\165\000\198\000g\0017\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000\252\0017\000\157\000j\000\238\000\020\000\237\000\218\001\141\000\198\000g\000j\001\t\000\218\000j\000\018\001\t\000\218\000\018\001g\000h\000\236\000.\0001\001\t\000\218\001g\001\t\000\218\000h\000\236\000.\001\t\000\218\0001\001g\001\t\000\218\001g\000j\001\007\000\218\000j\000\018\001\007\000\218\000\018\000/\001\007\000\218\000/\001\021\001\t\000h\001\t\000.\001\r\000\198\001\001\000\238\000\251\000\198\001\001\001u\001\005\000\238\000\251\001u\001\003\000\"\0017\000O\000\204\000\178\0017\001s\000\\\001\001\000\203\001\001\001\183\001\007\001\001\000\203\001\001\000h\000.\001\133\000\016\000\018\000\016\000Z\001\135\0017\000\018\000\234\001\t\0011\000(\0017\000c\000\204\000\178\0017\001s\000\\\000\251\000Z\000\020\000P\0017\001\001\000h\000\251\000.\000\251\001\183\000\245\000h\000.\000\\\000\251\000\251\000\\\000\251\000\251\000\004\000\129\001\133\000Z\000\020\001\135\0017\001g\000\213\0011\000Z\000\020\001\135\0017\001g\000\234\000\251\0011\001\017\000X\000X\000\012\000X\000\012\000\012\000X\000\254\001g\000j\000j\000\237\000$\000$\000\235\001\141\000>\001\141\001\143\000>\001\143\001\141\000\198\001\143\001\141\000\198\000>\001\143\000\216\000>\000\216\001\141\000\198\000\216\001\141\000\198\000>\000\216\000\138\001Y\0004\000>\000\138\001Y\0004\001\141\000\198\000\138\001Y\0004\001\141\000\198\000>\000\138\001Y\0004\000N\001\135\0017\001\001\0011\000N\000\252\001\135\0017\001\001\0011\000N\001\135\0017\001\t\0011\000N\000\252\001\135\0017\001\t\0011\000@\000n\001\004\000\212\000h\001c\000.\000\212\000h\001c\000.\000r\000\212\000\134\001c\0002\000\212\000\134\001c\0002\000r\000\212\000\138\001c\0004\000\212\000\138\001c\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\141\000\198\001\137\000\198\000\251\000\198\000\179\000\198\000g\000A\000L\000<\000j\000\238\000h\001\001\000\238\000\251\000.\000h\001\001\000.\000h\000\014\0017\001\137\000.\000h\000\014\0017\001\137\000\238\000\251\000.\000h\000\014\0017\001\137\000\238\000\251\000\232\000\251\000.\000h\000\014\0017\001\137\000\232\000\251\000.\001\189\000\202\001\149\000\202\001\141\000\202\000g\000\202\001\t\000\202\001\007\000\202\001\001\000\202\000\251\000\202\000\245\000\202\000\179\000\202\000-\000\202\000\179\000\236\000\179\000\179\001\183\000\173\000\179\001\002\000/\000\177\000\179\000\250\000\179\000\196\001\135\0017\000\179\000\177\000\230\000\179\000\179\000\230\000\179\000\175\000\230\000\179\000\171\000\230\000\179\000Y\001\149\000\179\001\149\000h\000\020\000\237\000.\000Y\000\239\000\179\000\140\001\135\0017\000Y\000\171\000\236\000\179\000\171\001\183\000\173\000\171\001\002\000/\000\175\000\171\000\250\000\179\000j\000\016\000O\000\238\000c\000\238\001\141\000<\000\179\000<\000\179\000\n\000g\001\141\000\135\000\218\001\141\001\193\000\135\000\218\001\193\000\130\001\185\000\167\0002\000\194\001\135\0017\000/\000\238\000\165\000\198\000\235\0011\000>\000>\000\012\000>\000\012\000\012\000>\0000\000i\000[\000\004\000i\001m\001o\000\149\001o\001m\001\129\001o\001\131\000\147\001o\000\147\001\131\001m\001o\000\145\001o\000\143\000\226\001\141\000\198\001\141\001u\000\141\001u\001S\000\139\001S\000\239\000\137\000\239\000:\001g\000\135\000:\001g\001\029\000\250\001\029\000\133\000\250\001\029\001\193\000\131\001\b\001\193\000!\000\129\001\006\000!\000q\000\127\000\250\000q\001\141\000}\000\230\001\141\000;\000{\000\230\000;\001\187\000y\000&\001\187\000w\000\230\001\141\001\141\000\230\001\141\000u\000\230\001\137\001\137\000\230\001\137\000s\000&\001\187\001\187\000&\001\187\000I\001\141\001\137\001\137\000,\001\137\000,\000o\000j\000\215\000j\000\215\000,\000j\000\215\000,\000m\000\179\000\179\000,\000\179\000,\000k\001U\000\207\000\215\001U\000\207\000\215\000,\001U\000\207\000\215\000,\000i\001\137\001\137\000,\001\137\000,\000g\001\137\000,\000H\001\185\000g\000\196\001\135\0017\001\151\001q\0017\0011\001/\001_\0011\001\127\000)\000\159\001i\0015\001k\0013\000\020\001\135\0017\0009\000=\000B\000\157\000\145\0011\000\020\001\135\0017\000T\0009\000=\000B\000\157\000\145\0011\000e\000Z\001\135\0017\000\255\001\003\0011\000Z\001\135\0017\000\255\000\198\001\007\0011\000\253\000Z\001\135\0017\0000\000\255\000\238\000\251\0011\0019\000\249\000\247\000\229\000\160\001\135\0017\000\251\0011\000\240\001\135\0017\000'\001}\000j\000\238\001\161\0011\001?\001\159\001\155\000`\000\144\000`\000\188\000F\000\144\000F\000\188\000\138\001#\0004\000\134\000k\0002\000~\000k\000\246\000~\000\246\000\214\001\137\000\174\000\210\000[\000h\000g\000.\000h\000g\000A\000.\000[\000\218\000h\000g\000.\000[\000\218\000\138\000g\0004\000[\000\218\000\134\000g\0002\000[\000\212\000h\000o\000.\000[\000\218\001\007\000\212\000h\000o\000.\000[\000\212\000\138\000o\0004\000[\000\218\001\007\000\212\000\138\000o\0004\000[\000\212\000\134\000o\0002\000[\000\218\001\007\000\212\000\134\000o\0002\000\244\001\135\0017\000g\000\204\000\244\001\135\0017\000\204\000V\001\135\0017\001\173\000h\000Z\001\135\0017\001\001\000.\000h\000Z\001\135\0017\001\001\000\238\000\251\000.\000R\001\135\0017\001\171\001)\000\204\000-\001\155\001\149\000\239\000@\000[\000\252\000[\000\136\000m\000\172\000\136\000\172\000[\000\218\001U\001\007\000\218\000h\000g\000.\001\007\000\218\000\136\000m\000\172\000[\000\168\000j\000[\000\166\000[\001\133\000\016\001\007\000\218\000h\000.\000\138\000\151\0004\001\007\000\218\000\138\000\151\0004\000~\000o\000\246\000~\000\246\001\007\000\218\000~\000o\000\246\001\007\000\218\000~\000\246\000\134\000o\0002\001\007\000\218\000\134\000o\0002\001\007\000\218\000\134\0002\001\007\000\218\000h\000Z\001\135\0017\001\001\000\238\000\251\000.\000/\000W\000h\000\179\000.\000]\000h\000Z\001\135\0017\000\255\000.\000h\000Z\001\135\0017\000\255\000\238\000\251\000.\000\016\000_\000_\000\216\000_\001\149\000\239\000\168\000=\001\007\000\218\000]\001\007\000\218\000\134\0002\001\007\000\218\000h\000.\001\007\000\218\000h\000\179\000.\000h\000\179\000\238\001\141\000.\001\133\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\000e\000\196\001\135\0017\001\151\000\198\001\149\0017\0011\000\198\000g\001Q\001{\000h\000\020\000\237\000.\001{\001-\000g\0011\001-\001\031\001K\001_\0011\001\127\000\159\000)\001i\0015\000\020\001\135\0017\0009\000=\000B\000\157\000\147\0011\000\020\001\135\0017\000T\0009\000=\000B\000\157\000\147\0011\000S\000Z\001\135\0017\000\255\001\005\0011\000Z\001\135\0017\0000\000\255\001\005\0011\001;\000\249\000\231\000\240\001\135\0017\000'\001}\000j\001\177\0011\001A\001\159\000\160\001\135\0017\001\001\0011\000`\000^\000\239\000P\000\225\000\131\0017\000\239\0017\000\168\001g\000\168\001g\000$\000\168\001g\000\144\000\168\001g\000-\000\168\001g\001\007\000\168\001g\000\192\000\168\001g\000\026\000g\0011\000*\001'\000*\000G\000*\000\202\001\187\000s\000\238\001\141\000\238\001\141\000\232\001\141\000\232\001\141\000\198\000\233\001\023\0005\0007\000;\000h\000{\000.\000:\001g\000\016\000F\000`\000\252\000F\000\252\000\252\000F\000`\000\252\000\252\000`\000\154\000@\001%\000\202\000g\0011\001%\000\202\000h\000\227\000.\000j\0001\001\011\0017\000%\000j\000\238\001\141\0017\000\243\000j\000\198\000g\000\252\0017\000\243\000j\000\198\000g\0017\000\243\000j\000A\000\198\000g\000\252\0017\000\243\000j\000A\000\198\000g\000\014\001\135\0017\000/\000\238\000\165\0011\000\012\000\012\000X\000\012\000\012\000X\000\012\000>\000\012\000\012\000>\000\020\0009\001U\000\031\001\193\000\143\000\020\0009\001U\000\234\001\193\000Z\001\007\000\198\001\t\000Z\001\007\000\234\001\t\000Z\000\020\000\245\000\198\000\251\000Z\000\020\000\245\000\234\000\251\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\017\000\018\000\022\000\026\000\027\000\028\000\031\000%\000'\000(\000)\000+\000/\0002\0004\0006\0009\000>\000A\000E\000J\000N\000P\000T\000Z\000[\000\\\000_\000c\000d\000g\000j\000p\000w\000y\000{\000|\000\129\000\135\000\138\000\141\000\145\000\149\000\151\000\152\000\154\000\158\000\160\000\163\000\165\000\166\000\169\000\174\000\174\000\177\000\177\000\181\000\188\000\195\000\199\000\201\000\202\000\203\000\207\000\208\000\213\000\215\000\221\000\228\000\231\000\232\000\236\000\241\000\246\000\247\000\251\001\000\001\003\001\014\001\015\001\016\001\017\001\018\001\019\001\021\001\023\001\024\001\025\001\026\001\029\001\030\001\031\001$\001'\001(\001+\001,\001/\0012\0013\0014\0015\0017\0018\0019\001<\001B\001F\001L\001R\001Z\001a\001l\001u\001v\001~\001\135\001\142\001\150\001\154\001\159\001\167\001\173\001\179\001\187\001\193\001\200\001\211\001\215\001\219\001\221\001\222\001\224\001\226\001\229\001\232\001\235\001\238\001\241\001\244\001\247\001\250\001\253\002\000\002\003\002\006\002\t\002\012\002\015\002\018\002\021\002\024\002\027\002\030\002 \002\"\002%\002)\002,\002/\0024\002;\002B\002I\002P\002Y\002`\002i\002p\002y\002{\002{\002}\002\129\002\130\002\135\002\139\002\143\002\143\002\146\002\147\002\150\002\152\002\156\002\158\002\163\002\164\002\168\002\173\002\176\002\178\002\183\002\184\002\184\002\186\002\190\002\196\002\198\002\202\002\206\002\209\002\218\002\228\002\236\002\245\002\246\002\247\002\249\002\249\002\251\002\253\003\001\003\002\003\007\003\014\003\015\003\016\003\018\003\019\003\022\003\023\003\024\003\026\003\028\003!\003#\003%\003*\003,\0031\0033\0037\0039\003;\003<\003=\003>\003@\003D\003K\003S\003V\003[\003a\003c\003h\003o\003q\003r\003u\003w\003x\003}\003\128\003\129\003\132\003\132\003\140\003\140\003\149\003\149\003\158\003\158\003\164\003\164\003\171\003\171\003\173\003\173\003\181\003\181\003\190\003\190\003\192\003\192\003\194\003\196\003\196\003\198\003\202\003\204\003\204\003\206\003\206\003\208\003\208\003\210\003\210\003\212\003\216\003\218\003\220\003\223\003\227\003\233\003\238\003\244\003\245\003\247\003\250\003\255\004\002\004\t\004\012\004\018\004\020\004\024\004\025\004\026\004\031\004#\004(\004/\0047\004A\004L\004M\004P\004Q\004T\004U\004X\004Y\004\\\004a\004d\004e\004h\004i\004l\004m\004p\004q\004t\004u\004y\004z\004|\004\128\004\130\004\132\004\134\004\138\004\143\004\144\004\146\004\147\004\149\004\152\004\153\004\154\004\155\004\156\004\163\004\167\004\172\004\177\004\180\004\182\004\183\004\187\004\190\004\193\004\194\004\201\004\209\004\210\004\210\004\211\004\211\004\212\004\213\004\215\004\217\004\219\004\220\004\222\004\223\004\225\004\226\004\228\004\229\004\231\004\234\004\238\004\239\004\241\004\244\004\248\004\251\004\255\005\004\005\n\005\015\005\021\005\026\005 \005!\005\"\005#\005'\005,\0050\0055\0059\005>\005?\005@\005A\005B\005C\005D\005E\005F\005G\005H\005I\005J\005K\005L\005M\005N\005O\005P\005Q\005R\005S\005T\005U\005U\005U\005V\005V\005W\005W\005Y\005Y\005[\005[\005]\005]\005_\005_\005a\005a\005c\005c\005d\005e\005h\005m\005p\005u\005|\005\133\005\140\005\142\005\144\005\146\005\148\005\150\005\152\005\154\005\156\005\158\005\160\005\162\005\165\005\167\005\168\005\171\005\172\005\175\005\179\005\182\005\185\005\188\005\191\005\192\005\194\005\200\005\202\005\206\005\209\005\211\005\212\005\215\005\216\005\219\005\220\005\221\005\222\005\224\005\226\005\228\005\232\005\233\005\236\005\237\005\240\005\244\005\253\005\253\005\254\005\254\005\255\006\000\006\002\006\004\006\004\006\005\006\006\006\t\006\n\006\011\006\r\006\014\006\015\006\016\006\017\006\019\006\021\006\022\006\023\006\025\006\025\006\030\006\031\006!\006\"\006$\006%\006'\006)\006,\006-\006/\0062\0063\0066\0067\006:\006;\006>\006?\006B\006C\006F\006G\006J\006M\006P\006S\006V\006Y\006\\\006]\006^\006_\006a\006d\006f\006i\006m\006n\006p\006s\006v\006z\006\127\006\128\006\130\006\133\006\138\006\145\006\146\006\148\006\149\006\150\006\151\006\153\006\155\006\164\006\174\006\175\006\181\006\188\006\189\006\198\006\199\006\200\006\201\006\206\006\216\006\217\006\218\006\220\006\222\006\224\006\226\006\229\006\232\006\235\006\237\006\240\006\242\006\245\006\249\006\254\007\003\007\b\007\r\007\020\007\025\007 \007%\007,\0071\0075\0079\007?\007G\007M\007N\007O\007P\007Q\007S\007U\007X\007Z\007]\007b\007g\007j\007m\007n\007o\007s\007v\007{\007~\007\128\007\133\007\137\007\140\007\145\007\149\007\159\007\160\007\161\007\164\007\165\007\171\007\179\007\180\007\181\007\184\007\185\007\186\007\188\007\191\007\195\007\199\007\204\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\238\007\239\007\240\007\241\007\242\007\243\007\244\007\245\007\246\007\247\007\248\007\249\007\250\007\251\007\252\007\253\007\254\007\255\b\000\b\001\b\002\b\003\b\004\b\005\b\006\b\014\b\016\b\018\b\023\b\024\b\027\b\028\b\029\b\031\b \b!\b\"\b$\b-\b7\b8\b>\bF\bG\bH\bQ\bR\bW\bX\bY\b^\b`\bb\be\bh\bk\bn\bq\bt\bw\by\b{\b|\b}\b~\b\128\b\132\b\134\b\134\b\136\b\137\b\139\b\139\b\140\b\143\b\145\b\146\b\146\b\147\b\148\b\149\b\151\b\153\b\155\b\157\b\158\b\159\b\161\b\165\b\168\b\169\b\170\b\171\b\176\b\181\b\187\b\193\b\200\b\207\b\207\b\208\b\209\b\211\b\213\b\214\b\216\b\218\b\224\b\229\b\233\b\237\b\242\b\247\b\248\b\250")) + ((16, "\001k\001g\000\203\000\201\000\199\000\197\000\195\000\193\000\191\000\189\000\187\000\185\000\183\000E\0003\000F\000D\001}\001\213\001\002\000:\001m\001\006\001=\001U\0017\001\025\001\171\001\157\000=\001\207\000=\000h\000w\000.\000=\000\168\001\175\001\207\000\168\001\175\000h\000w\000.\000\168\001\175\001\015\000\218\001\155\000:\001m\000\016\000U\000U\000\218\001\205\000\169\000\132\001\205\001\203\0002\001\181\000\182\001=\001\193\001O\000\162\001\199\000p\000N\001=\001\r\000\162\001\199\000p\000N\000\252\001=\001\r\000\162\001\199\001\199\001\201\001\181\000\139\001\147\000\148\001=\001\199\000\223\0017\000\148\000\252\001=\001\199\000\223\0017\000\014\000+\0017\000b\001\031\0017\000\226\001=\001\165\0017\000\146\001=\000g\0017\001e\0017\001\139\000\198\001\199\000\238\001\179\000\198\001\199\001W\001\195\001W\000\\\001\199\001W\001\193\001\021\000h\000\181\000.\000h\000\181\000\238\001\159\000.\000h\001\159\000.\000\148\001=\001\183\0017\000\014\001=\000\247\000j\000\238\001\159\0017\000b\001=\000\157\000j\000\238\000\167\0017\000\226\001=\001\165\0017\001e\0017\001\139\001\175\000\134\000}\0002\001\175\001\147\000R\001=\001\187\0011\000\204\001\183\001\201\000p\000N\001=\001\r\000\162\001\183\000p\000N\000\252\001=\001\r\000\162\001\183\000h\001\199\000.\001\191\000\134\000}\0002\001\191\000h\001\199\000\238\001\179\000.\000R\001=\001\189\001/\000\204\001\183\000\207\000C\000\\\001\179\000j\000\238\000C\000\\\001\179\000C\000\\\001\179\000\240\000\020\001\149\001=\000'\001\137\000j\000\198\001\183\0017\001C\001\029\000\144\000\242\000$\000\188\000\134\0002\000h\000.\000\192\000\026\000\018\000h\000\236\000.\001\171\001\r\001\r\000\218\000h\000\236\000.\000h\000\236\000.\001\171\001\159\000\198\001\159\001\207\000y\000&\001\207\000\138\001_\0004\000\250\000\151\001\213\001\159\001\201\000\237\001\141\001\155\000h\001\159\000.\000h\000Z\001\149\001=\001\001\000.\000\134\000I\0002\000\134\000\250\000\127\0002\000\134\000q\000\250\000\127\0002\000|\000\227\000\127\0002\000|\0002\000z\000\227\000\127\0002\000z\000\227\000\127\000\176\000\137\0002\000\028\000\208\001%\000\162\000g\000d\001\149\001=\000g\000\004\000\133\000\022\001\149\001=\000g\000\022\001\149\001=\000g\000\004\000\133\000\022\001\149\001=\000g\000\190\000g\000\022\001\149\001=\000g\000\004\000\133\000\190\000g\000\006\001\149\001=\000g\000\224\000g\000\220\000\184\001\149\001=\000\181\000\198\000g\001\153\000g\000\224\000g\000\220\000\184\001\149\001=\000\181\000\162\000g\000\224\000g\000\220\001\133\000\180\001\149\001=\000\133\000H\001\205\000x\001\205\000\169\0002\0008\000\250\001\169\000\198\001\167\001=\001\169\000\198\001\167\001=\001\147\000\128\001\205\001\203\0002\000\134\000{\0002\000\180\001\149\001=\000\133\001\127\000[\000p\000Z\001\149\001=\001\005\001\011\000\162\000g\000p\000\196\001\149\001=\001\169\001w\001=\000\162\000g\000p\000N\001\149\001=\001\007\000\162\000g\000p\000N\000\252\001\149\001=\001\007\000\162\000g\000\182\001\149\001=\001\129\000\221\000\\\001\135\000f\001\149\001=\000g\000\004\000\133\000\024\001\149\001=\000g\000\004\000\133\000\164\001\149\001=\000g\000 \001\151\000\206\001\151\000\164\001\149\001=\000g\000 \001\151\000\b\001\149\001=\000g\000\224\000g\000\220\000\186\001\149\001=\000\181\000\198\000g\001\153\000g\000\224\000g\000\220\001\000\001\149\001=\000[\000\140\001\149\001=\000[\000[\000\139\000u\001\167\000[\000\245\000[\001\133\000\158\001\151\001\133\000\156\001\151\001\133\000\154\001\151\001\133\000\152\001\151\001\133\000\150\001\151\001\133\000F\001\151\001\133\000D\001\151\001\133\000B\001\151\001\133\000`\001\151\001\133\000^\001\151\001\133\000&\001\151\001\133\000H\001\151\001\133\000\198\001\151\001\133\000t\001\151\001\133\000\176\001\151\001\133\000J\001\151\001\133\000\248\001\151\001\133\001\b\001\151\001\133\001\n\001\151\001\133\000\234\001\151\000K\001\151\001\215\001\151\001Q\000\162\000g\000n\001I\000\162\000g\001\133\000\236\001\151\000j\000r\001\151\000[\000\218\001[\000r\001\151\000[\000\218\000h\000g\000.\000r\001\151\000[\000\218\000\138\000g\0004\000r\001\151\000[\000\218\000\134\000g\0002\000r\001\151\000[\000\212\000h\000o\000.\000r\001\151\000[\000\218\001\r\000\212\000h\000o\000.\000r\001\151\000[\000\212\000\138\000o\0004\000r\001\151\000[\000\218\001\r\000\212\000\138\000o\0004\000r\001\151\000[\000\212\000\134\000o\0002\000r\001\151\000[\000\218\001\r\000\212\000\134\000o\0002\000r\001\151\001\133\001\201\000h\000\020\000\243\000.\001W\000\143\001\133\001\133\000,\001\133\000,\000g\001\133\000,\000H\001\205\000g\000C\000\207\000C\000\\\001}\000j\000\238\000C\000\\\001}\000C\000\\\001}\000h\000.\000h\001\005\000\238\001\001\000.\000\141\000P\001\163\000\238\001\163\000\\\001\207\000\238\000\135\000\218\001\163\000\\\001\207\000\238\001\207\000\238\000\135\000\218\001\207\000\250\001\169\001w\001=\001\169\001w\001=\000\020\001\149\001=\0009\000j\000\234\000\239\000\145\0017\000\020\001\149\001=\000T\0009\000j\000\234\000\239\000\145\0017\000\020\001\149\001=\0009\000j\000?\000\145\0017\000\020\001\149\001=\000T\0009\000j\000?\000\145\0017\000\018\000j\000O\000\202\000,\000\216\000c\000\202\000v\001\205\000\169\0002\0006\000\249\000j\000\238\000\165\001=\000\249\000j\000\238\000\165\001=\000,\001=\001c\001a\001a\001_\000j\000j\000\238\001\159\001\021\000[\000\142\000[\000\030\000j\000\030\000h\000j\000A\000.\000<\000j\000L\000[\000<\000h\001]\000\211\000.\000<\000j\000L\000h\001M\000\211\000.\000L\000\171\000\030\000h\001]\000.\000\030\000j\000\142\000Y\000Y\001S\000/\000/\000Q\000/\000A\000\198\000g\000/\000\238\000\135\000\218\001\159\000\198\000g\000/\000\238\000\020\000\243\000\218\001\159\000\198\000g\000\173\000\198\000g\000W\000\238\001\159\000\198\000g\000p\001\149\001=\000\155\001U\0017\001Q\001\211\000p\001=\000\155\001U\0017\000p\000H\001\205\001=\000\155\001U\0017\001O\001\211\000\181\000\181\000\238\001\159\000/\000Q\000/\000Y\000\238\001\159\000\198\000g\000\173\000\198\000g\001K\001I\001\004\001K\001\006\001=\000'\001\137\000j\001\195\0017\001G\001\006\001=\000'\001\137\000j\000\238\001\179\0017\001E\001\006\001=\000'\001\137\000j\000\198\001\183\0017\001C\001\006\001=\001\005\001\011\0017\001A\001\006\001=\001\005\000\238\001\001\0017\001?\001\201\001=\001\006\001=\0009\000j\000?\000\145\0017\001;\001\006\001=\0009\000j\000\234\000\239\000\145\0017\0019\000\163\0017\000*\0015\000a\0015\000*\0013\000*\000g\0017\0013\000M\0013\001\185\0011\001\197\001/\000M\001-\000*\001+\000*\000g\0017\001+\000M\001+\000G\001+\001[\000\219\000\213\001[\000\219\000\213\000,\001[\000\219\000\213\000,\000\016\000\225\001[\000\219\000\213\000,\001)\000l\001\149\001=\000\155\001U\0017\001'\001%\001\211\000\181\000\\\000g\000\181\000\n\000g\000\\\000g\000\181\000\\\000\218\000j\000\238\000\165\001=\000,\001=\001!\001\207\000,\001!\000j\000\238\000\165\001=\000,\001=\001\207\000,\000j\000\238\000\165\001=\001\207\000\216\001=\000#\000j\000\238\000\167\001=\000\159\000j\000Q\000\252\001=\000\159\000j\000Q\001=\000\159\000j\000\238\000\167\000\198\000g\000\252\001=\000\159\000j\000\238\000\167\000\198\000g\001=\000\159\000j\000\238\000\020\000\243\000\218\001\159\000\198\000g\000\252\001=\000\159\000j\000\238\000\020\000\243\000\218\001\159\000\198\000g\000j\001\015\000\218\000j\000\018\001\015\000\218\000\018\001m\000h\000\236\000.\0001\001\015\000\218\001m\001\015\000\218\000h\000\236\000.\001\015\000\218\0001\001m\001\015\000\218\001m\000j\001\r\000\218\000j\000\018\001\r\000\218\000\018\000/\001\r\000\218\000/\001\027\001\015\000h\001\015\000.\001\019\000\198\001\007\000\238\001\001\000\198\001\007\001{\001\011\000\238\001\001\001{\001\t\000\"\001=\000O\000\204\000\178\001=\001y\000\\\001\007\000\205\001\007\001\201\001\r\001\007\000\205\001\007\000h\000.\001\147\000\016\000\018\000\016\000Z\001\149\001=\000\018\000\234\001\015\0017\000(\001=\000c\000\204\000\178\001=\001y\000\\\001\001\000Z\000\020\000P\001=\001\007\000h\001\001\000.\001\001\001\201\000\251\000h\000.\000\\\001\001\001\001\000\\\001\001\001\001\000\004\000\129\001\147\000Z\000\020\001\149\001=\001m\000\215\0017\000Z\000\020\001\149\001=\001m\000\234\001\001\0017\001\023\000X\000X\000\012\000X\000\012\000\012\000X\000\254\001m\000j\000j\000\243\000$\000$\000\241\001\159\000>\001\159\001\161\000>\001\161\001\159\000\198\001\161\001\159\000\198\000>\001\161\000\216\000>\000\216\001\159\000\198\000\216\001\159\000\198\000>\000\216\000\138\001_\0004\000>\000\138\001_\0004\001\159\000\198\000\138\001_\0004\001\159\000\198\000>\000\138\001_\0004\000t\001!\000\176\000t\000\176\000N\001\149\001=\001\007\0017\000N\000\252\001\149\001=\001\007\0017\000N\001\149\001=\001\015\0017\000N\000\252\001\149\001=\001\015\0017\000@\000n\001\004\000\212\000h\001i\000.\000\212\000h\001i\000.\000r\000\212\000\134\001i\0002\000\212\000\134\001i\0002\000r\000\212\000\138\001i\0004\000\212\000\138\001i\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\207\000\238\001\159\000\198\001\151\000\198\001\001\000\198\000\181\000\198\000g\000A\000L\000<\000j\000\238\000h\001\007\000\238\001\001\000.\000h\001\007\000.\000h\000\014\001=\001\151\000.\000h\000\014\001=\001\151\000\238\001\001\000.\000h\000\014\001=\001\151\000\238\001\001\000\232\001\001\000.\000h\000\014\001=\001\151\000\232\001\001\000.\001\209\000\202\001\167\000\202\001\159\000\202\000g\000\202\001\015\000\202\001\r\000\202\001\007\000\202\001\001\000\202\000\251\000\202\000\181\000\202\000-\000\202\000\181\000\236\000\181\000\181\001\201\000\175\000\181\001\002\000/\000\179\000\181\000\250\000\181\000\196\001\149\001=\000\181\000\179\000\230\000\181\000\181\000\230\000\181\000\177\000\230\000\181\000\173\000\230\000\181\000Y\001\167\000\181\001\167\000h\000\020\000\243\000.\000Y\000\245\000\181\000\140\001\149\001=\000Y\000\173\000\236\000\181\000\173\001\201\000\175\000\173\001\002\000/\000\177\000\173\000\250\000\181\000j\000\016\000O\000\238\000c\000\238\001\159\000<\000\181\000<\000\181\000\n\000g\001\159\000\135\000\218\001\159\001\213\000\135\000\218\001\213\000\130\001\205\001\203\0002\000\194\001\149\001=\000/\000\238\000\167\000\198\000\241\0017\000>\000>\000\012\000>\000\012\000\012\000>\0000\000i\000[\000\004\000i\001s\001u\000\151\001u\001s\001\143\001u\001\145\000\149\001u\000\149\001\145\001s\001u\000\147\001u\000\145\000\226\001\159\000\198\001\159\001\131\000\143\001\131\001{\000\141\001{\001Y\000\139\001Y\000\245\000\137\000\245\000:\001m\000\135\000:\001m\001#\000\250\001#\000\133\000\250\001#\001\213\000\131\001\b\001\213\000!\000\129\001\006\000!\000q\000\127\000\250\000q\001\159\000}\000\230\001\159\000;\000{\000\230\000;\001\207\000y\000&\001\207\000w\000\230\001\159\001\159\000\230\001\159\000u\000\230\001\151\001\151\000\230\001\151\000s\000&\001\207\001\207\000&\001\207\000I\001\159\001\151\001\151\000,\001\151\000,\000o\000j\000\217\000j\000\217\000,\000j\000\217\000,\000m\000\181\000\181\000,\000\181\000,\000k\001[\000\209\000\217\001[\000\209\000\217\000,\001[\000\209\000\217\000,\000i\001\127\000\180\001\149\001=\000\133\000\196\001\149\001=\001\169\001w\001=\0017\0015\001e\0017\001\139\000)\000\161\001o\001;\001q\0019\000\020\001\149\001=\0009\000=\000B\000\159\000\147\0017\000\020\001\149\001=\000T\0009\000=\000B\000\159\000\147\0017\000e\000Z\001\149\001=\001\005\001\t\0017\000Z\001\149\001=\001\005\000\198\001\r\0017\001\003\000Z\001\149\001=\0000\001\005\000\238\001\001\0017\001?\000\255\000\253\000\233\000\160\001\149\001=\001\001\0017\000\240\001\149\001=\000'\001\137\000j\000\238\001\179\0017\001E\001\177\001\173\000`\000\144\000`\000\188\000F\000\144\000F\000\188\000\138\001)\0004\000\134\000k\0002\000~\000k\000\246\000~\000\246\000\214\001\151\000\174\000\210\000[\000h\000g\000.\000h\000g\000A\000.\000[\000\218\000h\000g\000.\000[\000\218\000\138\000g\0004\000[\000\218\000\134\000g\0002\000[\000\212\000h\000o\000.\000[\000\218\001\r\000\212\000h\000o\000.\000[\000\212\000\138\000o\0004\000[\000\218\001\r\000\212\000\138\000o\0004\000[\000\212\000\134\000o\0002\000[\000\218\001\r\000\212\000\134\000o\0002\000\244\001\149\001=\000g\000\204\000\244\001\149\001=\000\204\000V\001\149\001=\001\191\000h\000Z\001\149\001=\001\007\000.\000h\000Z\001\149\001=\001\007\000\238\001\001\000.\000R\001\149\001=\001\189\001/\000\204\000-\001\173\001\167\000\245\000@\000[\000\252\000[\000\136\000m\000\172\000\136\000\172\000[\000\218\001[\001\r\000\218\000h\000g\000.\001\r\000\218\000\136\000m\000\172\000[\000\168\000j\000[\000\166\000[\001\147\000\016\001\r\000\218\000h\000.\000\138\000\153\0004\001\r\000\218\000\138\000\153\0004\000~\000o\000\246\000~\000\246\001\r\000\218\000~\000o\000\246\001\r\000\218\000~\000\246\000\134\000o\0002\001\r\000\218\000\134\000o\0002\001\r\000\218\000\134\0002\001\r\000\218\000h\000Z\001\149\001=\001\007\000\238\001\001\000.\000/\000W\000h\000\181\000.\000]\000h\000Z\001\149\001=\001\005\000.\000h\000Z\001\149\001=\001\005\000\238\001\001\000.\000\016\000_\000_\000\216\000_\001\167\000\245\000\168\000=\001\r\000\218\000]\001\r\000\218\000\134\0002\001\r\000\218\000h\000.\001\r\000\218\000h\000\181\000.\000h\000\181\000\238\001\159\000.\001\147\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\000e\000\196\001\149\001=\001\169\000\198\001\167\001=\0017\000\198\000g\001\129\000\209\000\198\001\135\0013\000g\0017\0013\001%\001Q\001e\0017\001\139\000\161\000)\001o\001;\000\020\001\149\001=\0009\000=\000B\000\159\000\149\0017\000\020\001\149\001=\000T\0009\000=\000B\000\159\000\149\0017\000S\000Z\001\149\001=\001\005\001\011\0017\000Z\001\149\001=\0000\001\005\001\011\0017\001A\000\255\000\235\000\240\001\149\001=\000'\001\137\000j\001\195\0017\001G\001\177\000\160\001\149\001=\001\007\0017\000`\000^\000\245\000P\000\229\000\131\001=\000\245\001=\000\168\001m\000\168\001m\000$\000\168\001m\000\144\000\168\001m\000-\000\168\001m\001\r\000\168\001m\000\192\000\168\001m\000\026\000g\0017\000*\001-\000*\000G\000*\000\202\001\207\000s\000\238\001\159\000\238\001\159\000\232\001\159\000\232\001\159\000\198\000\239\001\029\0005\0007\000;\000h\000{\000.\000:\001m\000\016\000F\000`\000\252\000F\000\252\000\252\000F\000`\000\252\000\252\000`\000\154\000@\001+\000\202\000g\0017\001+\000\202\000h\000\231\000.\000j\0001\001\017\001=\000%\000j\000\238\001\159\001=\000\249\000j\000\198\000g\000\252\001=\000\249\000j\000\198\000g\001=\000\249\000j\000A\000\198\000g\000\252\001=\000\249\000j\000A\000\198\000g\000\014\001\149\001=\000/\000\238\000\167\0017\000\012\000\012\000X\000\012\000\012\000X\000\012\000>\000\012\000\012\000>\000\020\0009\001[\000\031\001\213\000\145\000\020\0009\001[\000\234\001\213\000Z\001\r\000\198\001\015\000Z\001\r\000\234\001\015\000Z\000\020\000\251\000\198\001\001\000Z\000\020\000\251\000\234\001\001\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\017\000\018\000\022\000\026\000\027\000\028\000\029\000\030\000 \000$\000&\000)\000.\0001\0003\0004\0005\0008\0009\000=\000>\000A\000D\000J\000Q\000S\000U\000V\000[\000a\000d\000g\000k\000o\000q\000r\000t\000x\000z\000}\000\127\000\128\000\131\000\136\000\136\000\139\000\139\000\143\000\150\000\157\000\161\000\163\000\164\000\165\000\169\000\170\000\175\000\177\000\183\000\190\000\193\000\194\000\198\000\203\000\208\000\209\000\213\000\218\000\221\000\232\000\233\000\234\000\235\000\236\000\237\000\239\000\241\000\242\000\243\000\244\000\247\000\248\000\249\000\254\001\001\001\002\001\005\001\006\001\t\001\012\001\r\001\014\001\015\001\017\001\018\001\019\001\020\001\023\001\029\001 \001$\001)\001-\001/\0013\0019\001:\001;\001>\001D\001H\001N\001T\001\\\001c\001n\001w\001x\001|\001|\001~\001\130\001\131\001\136\001\140\001\141\001\145\001\145\001\148\001\152\001\153\001\154\001\162\001\171\001\178\001\186\001\193\001\199\001\205\001\213\001\219\001\226\001\237\001\241\001\245\001\247\001\248\001\250\001\252\001\255\002\002\002\005\002\b\002\011\002\014\002\017\002\020\002\023\002\026\002\029\002 \002#\002&\002)\002,\002/\0022\0025\0028\002:\002<\002?\002C\002F\002I\002N\002U\002\\\002c\002j\002s\002z\002\131\002\138\002\147\002\149\002\153\002\154\002\155\002\156\002\158\002\161\002\166\002\167\002\171\002\176\002\179\002\181\002\186\002\187\002\187\002\189\002\193\002\199\002\201\002\205\002\209\002\212\002\221\002\231\002\239\002\248\002\249\002\250\002\252\002\252\002\254\003\000\003\004\003\005\003\n\003\017\003\018\003\019\003\021\003\022\003\025\003\026\003\027\003\029\003\031\003$\003&\003(\003-\003/\0034\0036\003:\003<\003>\003?\003@\003A\003C\003G\003N\003V\003Y\003^\003d\003f\003k\003r\003t\003u\003x\003z\003{\003\128\003\131\003\132\003\135\003\135\003\143\003\143\003\152\003\152\003\161\003\161\003\167\003\167\003\174\003\174\003\176\003\176\003\184\003\184\003\193\003\193\003\195\003\195\003\197\003\199\003\199\003\201\003\205\003\207\003\207\003\209\003\209\003\211\003\211\003\213\003\213\003\215\003\219\003\221\003\223\003\226\003\230\003\236\003\241\003\247\003\248\003\250\003\253\004\002\004\005\004\012\004\015\004\021\004\023\004\027\004\028\004\029\004\"\004&\004+\0042\004:\004D\004O\004P\004S\004T\004W\004X\004[\004\\\004_\004d\004g\004h\004k\004l\004o\004p\004s\004t\004w\004x\004|\004}\004\127\004\131\004\133\004\135\004\137\004\141\004\146\004\147\004\149\004\150\004\152\004\155\004\156\004\157\004\158\004\159\004\166\004\170\004\175\004\180\004\183\004\185\004\186\004\190\004\193\004\196\004\197\004\204\004\212\004\213\004\213\004\214\004\214\004\215\004\216\004\218\004\220\004\222\004\223\004\225\004\226\004\228\004\229\004\231\004\232\004\234\004\237\004\241\004\242\004\244\004\247\004\251\004\254\005\002\005\007\005\r\005\016\005\018\005\023\005\029\005\"\005(\005)\005*\005+\005/\0054\0058\005=\005A\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^\005^\005_\005_\005a\005a\005c\005c\005e\005e\005g\005g\005i\005i\005k\005k\005m\005m\005n\005o\005r\005w\005z\005\127\005\134\005\143\005\150\005\152\005\154\005\156\005\158\005\160\005\162\005\164\005\166\005\168\005\170\005\172\005\175\005\177\005\178\005\181\005\182\005\185\005\189\005\192\005\195\005\198\005\201\005\202\005\204\005\210\005\212\005\216\005\219\005\221\005\222\005\225\005\226\005\229\005\230\005\231\005\232\005\234\005\236\005\238\005\242\005\243\005\246\005\247\005\250\005\254\006\007\006\007\006\b\006\b\006\t\006\n\006\012\006\014\006\014\006\015\006\016\006\019\006\020\006\021\006\023\006\024\006\025\006\026\006\027\006\029\006\031\006 \006!\006#\006#\006(\006)\006+\006,\006.\006/\0061\0062\0064\0066\0069\006:\006<\006?\006@\006C\006D\006G\006H\006K\006L\006O\006P\006S\006T\006W\006Z\006]\006`\006c\006f\006i\006j\006k\006l\006n\006q\006s\006v\006z\006{\006}\006\128\006\131\006\135\006\140\006\141\006\145\006\152\006\153\006\155\006\156\006\157\006\158\006\160\006\162\006\171\006\181\006\182\006\188\006\195\006\196\006\205\006\206\006\207\006\208\006\213\006\223\006\224\006\225\006\227\006\229\006\231\006\233\006\236\006\239\006\242\006\244\006\247\006\249\006\252\007\000\007\005\007\n\007\015\007\020\007\027\007 \007'\007,\0073\0078\007<\007@\007F\007N\007T\007U\007V\007W\007X\007Z\007\\\007_\007a\007d\007i\007n\007q\007t\007u\007v\007z\007}\007\130\007\133\007\135\007\140\007\144\007\147\007\152\007\156\007\166\007\167\007\168\007\171\007\172\007\178\007\186\007\187\007\188\007\191\007\192\007\193\007\195\007\198\007\202\007\206\007\211\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\238\007\239\007\240\007\241\007\242\007\243\007\244\007\245\007\246\007\247\007\248\007\249\007\250\007\251\007\252\007\253\007\254\007\255\b\000\b\001\b\002\b\003\b\004\b\005\b\006\b\007\b\b\b\t\b\n\b\011\b\012\b\r\b\021\b\023\b\027\b\028\b\031\b \b!\b#\b$\b%\b&\b(\b1\b;\b<\bB\bJ\bK\bL\bU\bV\b[\b\\\b]\bb\bd\bf\bi\bl\bo\br\bu\bx\b{\b}\b\127\b\128\b\129\b\130\b\132\b\136\b\138\b\138\b\140\b\141\b\143\b\143\b\144\b\147\b\149\b\150\b\150\b\151\b\152\b\153\b\155\b\157\b\159\b\161\b\162\b\163\b\165\b\169\b\172\b\173\b\174\b\175\b\180\b\185\b\191\b\197\b\204\b\211\b\211\b\212\b\213\b\215\b\217\b\218\b\220\b\222\b\228\b\233\b\237\b\241\b\246\b\251\b\252\b\254")) 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\001y\001z\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\001w\001x\001\146\001\147\001\148\001{\001|\001}\001~\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\251\001\252\001\253\001\254\001\255\002\000\002\001\002\002\002\003\002\004\001\249\001\250\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\024\002\025\002\026\002\027\002\028\002\029\002\030\002\031\002 \002!\002\"\002#\002$\002%\002&\002'\002(\002)\002*\002+\002,\002-\002.\002/\0020\0021\0022\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\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\002Y\002Z\002[\002\\\002S\002T\002W\002X\002_\002`\002a\002b\002c\002d\002e\002f\002g\002h\002i\002j\002k\002l\002m\002n\002o\002p\002U\002V\002]\002^\005\192\005\193\002\135\002\136\002\137\002\138\002\139\002\140\002\141\002\142\002\143\002\144\002\145\002\146\002\147\002\148\002\149\002\150\002\151\002\152\002\169\002\170\002\195\002\196\002\197\002\198\002\199\002\200\002\201\002\202\002\203\002\204\002\153\002\154\002\159\002\160\002\171\002\172\002\155\002\156\002\157\002\158\002\161\002\162\002\163\002\164\002\165\002\166\002\167\002\168\002\173\002\174\002\175\002\176\002\187\002\188\002\177\002\178\002\179\002\180\002\181\002\182\002\189\002\190\002\191\002\192\002\193\002\194\002\183\002\184\002\185\002\186\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\232\002\233\002\234\002\235\002\236\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\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\003\017\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#\003$\003%\003&\003'\003(\003)\003*\003+\003,\003-\003.\003/\0030\0031\0032\0033\0034\0035\0036\0037\0038\0039\003:\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\003U\003V\003W\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\003u\003v\003w\003x\003y\003z\003{\003|\003}\003~\003\127\003\128\003\129\003\130\003\131\003\132\003\133\003\134\003\135\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\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\225\003\226\003\227\003\228\003\229\003\230\003\231\003\232\003\233\003\234\003\235\003\236\003\237\003\238\003\239\003\240\003\241\003\242\003\243\003\244\003\245\003\246\003\247\003\248\003\249\003\250\003\251\003\252\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\194\005\195\005\196\005\197\005\198\005\199\005\200\005\201\005\202\005\203\005\204\005o\005p\005q\005\205\005\206\005\207\005\208\005\209\005\210\005\211\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\212\005\213\005\214\005\215\005\216\005\217\005\218\005\219\002\134\005_\005`\005a\005b\005c\005d\005e\005f\005g\005h\005i\005j\005k\005l\005m\005n\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\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\0073\0074\0075\0076\0077\0078\0079\007:\007;\007<\007=\007>\007?\007@\007A\007B\007C\007D\007E\007F\007G") + (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\131\001\132\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\129\001\130\001\156\001\157\001\158\001\133\001\134\001\135\001\136\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\005\002\006\002\007\002\b\002\t\002\n\002\011\002\012\002\r\002\014\002\003\002\004\002\015\002\016\002\017\002\018\002\019\002\020\002\021\002\022\002\023\002\024\002\025\002\026\002\027\002\028\002\029\002\030\002\031\002 \002!\002\"\002#\002$\002%\002&\002'\002(\002)\002*\002+\002,\002-\002.\002/\0020\0021\0022\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\002\138\002\139\002\140\002\141\002\142\002\143\002\144\002\145\002\146\002\147\002\148\002\149\002\150\002\151\002\152\002\153\002\154\002\155\002\156\002\157\002\158\002r\002s\002t\002u\002h\002i\002l\002m\002n\002o\002p\002q\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\002j\002k\002v\002w\005\220\005\221\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\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\181\002\182\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\232\002\233\002\234\002\235\002\236\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\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\003\017\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#\003$\003%\003&\003'\003(\003)\003*\003+\003,\003-\003.\003/\0030\0031\0032\0033\0034\0035\0036\0037\0038\0039\003:\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\003U\003V\003W\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\003u\003v\003w\003x\003y\003z\003{\003|\003}\003~\003\127\003\128\003\129\003\130\003\131\003\132\003\133\003\134\003\135\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\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\225\003\226\003\227\003\228\003\229\003\230\003\231\003\232\003\233\003\234\003\235\003\236\003\237\003\238\003\239\003\240\003\241\003\242\003\243\003\244\003\245\003\246\003\247\003\248\003\249\003\250\003\251\003\252\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\222\005\223\005\224\005\225\005\226\005\227\005\228\005\229\005\230\005\231\005\232\005\140\005\141\005\142\005\233\005\234\005\235\005\236\005\237\005\238\005\239\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\240\005\241\005\242\005\243\005\244\005\245\005\246\005\247\002\159\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\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\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\0073\0074\0075\0076\0077\0078\0079\007:\007;\007<\007=\007>\007?\007@\007A\007B\007C\007D\007E\007F\007G\007H\007I\007J\007K\007L\007M\007N\007O\007P") and lr0_items = - ((32, "\000\000\000\000\000\001\252\001\000\002\240\001\000\011t\001\000\011p\001\000\011l\001\000\011h\001\000\011d\001\000\n\176\001\000\011`\001\000\011\\\001\000\011X\001\000\011T\001\000\011P\001\000\011L\001\000\011H\001\000\011D\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\n\172\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\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\000\172\001\000\000\168\001\000\000\172\002\000\000\172\003\000\002\240\002\000\001\252\002\000\000\176\001\000\000\176\002\000\0028\001\000\0028\002\000\0028\003\000\n4\001\000\005h\001\000\001\248\001\000\001\244\001\000\001\240\001\000\001\236\001\000\001\248\002\000\001\244\002\000\001\240\002\000\001\236\002\000\001\248\003\000\001\244\003\000\001\240\003\000\001\236\003\000\002,\001\000\002,\002\000\002,\003\000\001\156\001\000\001\136\001\000\002\248\001\000\n\012\001\000\t\248\001\000\t\248\002\000\t\248\003\000\001\016\001\000\001\012\001\000\n|\001\000\t\156\001\000\t\152\001\000\t\152\002\000\t\156\002\000\t\148\001\000\t\144\001\000\t\144\002\000\t\148\002\000\012|\001\000\n\164\001\000\nx\001\000\nt\001\000\nl\001\000\001\180\001\000\001\148\001\000\006\200\001\000\001\148\002\000\006t\001\000\006\188\001\000\006\184\001\000\t\156\001\000\t\152\001\000\006\180\001\000\006\204\001\000\006\220\001\000\nx\002\000\nt\002\000\nx\003\000\nt\003\000\nx\004\000\nt\004\000\005\192\001\000\005\188\001\000\nx\005\000\nt\005\000\nt\006\000\nx\006\000\0058\001\000\003t\001\000\005\200\001\000\005\200\002\000\012\160\001\000\012\160\002\000\012\160\003\000\012|\001\000\006\180\001\000\006\196\001\000\006\192\001\000\006x\001\000\006\212\001\000\006\176\001\000\006\172\001\000\006\168\001\000\006\164\001\000\006\160\001\000\006\152\001\000\006\216\001\000\006\208\001\000\006\148\001\000\006\144\001\000\006\140\001\000\006\136\001\000\006\132\001\000\006\128\001\000\006\132\002\000\006\128\002\000\003\132\001\000\003\132\002\000\006\132\003\000\006\128\003\000\006\132\004\000\006\128\004\000\006\132\005\000\006\140\002\000\006\136\002\000\006\140\003\000\006\136\003\000\006\140\004\000\006\136\004\000\006\140\005\000\006\148\002\000\006\144\002\000\006\148\003\000\006\144\003\000\006\148\004\000\006\144\004\000\006\148\005\000\006\236\001\000\006\224\001\000\006\156\001\000\006|\001\000\006\228\001\000\006\232\001\000\012|\002\000\012|\003\000\012\128\001\000\012\160\004\000\012\160\005\000\000d\001\000\0058\001\000\b\148\001\000\000`\001\000\003t\001\000\003x\001\000\b\148\002\000\000`\002\000\007D\001\000\007D\002\000\007D\003\000\007@\001\000\000\132\001\000\000p\001\000\000\\\001\000\000X\001\000\000`\001\000\000`\002\000\000\\\002\000\000\\\003\000\000\\\004\000\005\208\001\000\005\208\002\000\005\208\003\000\005\208\004\000\005\184\001\000\005\152\001\000\005\152\002\000\011\180\001\000\011\176\001\000\003p\001\000\003l\001\000\011\180\002\000\011\176\002\000\003p\002\000\003l\002\000\011\180\003\000\011\176\003\000\003p\003\000\003l\003\000\012p\001\000\012\\\001\000\012P\001\000\012\\\002\000\011\180\004\000\003p\004\000\012d\001\000\012T\001\000\012d\002\000\012@\001\000\012l\001\000\012h\001\000\012`\001\000\012X\001\000\012`\002\000\012h\002\000\0124\001\000\012H\001\000\012D\001\000\012D\002\000\0124\002\000\b\200\001\000\012@\002\000\b\204\001\000\012@\003\000\b\204\002\000\b\204\003\000\011\180\005\000\003p\005\000\0050\001\000\003p\006\000\012,\001\000\0058\001\000\001\160\001\000\006X\001\000\006H\001\000\0068\001\000\0060\001\000\001\164\001\000\001\148\001\000\000\132\001\000\000p\001\000\000\\\001\000\000X\001\000\0050\001\000\0030\001\000\0030\002\000\0050\001\000\000x\001\000\000t\001\000\0050\001\000\005\b\001\000\005\000\001\000\004\248\001\000\005\b\002\000\005\000\002\000\004\248\002\000\002\244\001\000\002\244\002\000\004\156\001\000\004\152\001\000\003\144\001\000\000@\001\000\000<\001\000\006h\001\000\006d\001\000\006h\002\000\006h\003\000\006h\004\000\007\\\001\000\007X\001\000\007T\001\000\007P\001\000\007L\001\000\007H\001\000\007\\\002\000\007X\002\000\007T\002\000\007P\002\000\007\\\003\000\007X\003\000\007T\003\000\007P\003\000\t\236\001\000\t\236\002\000\t\236\003\000\005`\001\000\005l\001\000\005d\001\000\005l\002\000\005d\002\000\005l\003\000\005d\003\000\005\128\001\000\001\b\001\000\t\236\004\000\004l\001\000\004l\002\000\011\220\001\000\011\216\001\000\001\232\001\000\001\232\002\000\001\232\003\000\002(\001\000\002(\002\000\002(\003\000\012|\001\000\t\244\001\000\t\240\001\000\t\188\001\000\t\184\001\000\001\180\001\000\001\148\001\000\n\012\001\000\006t\001\000\nH\001\000\nD\001\000\012\128\001\000\002\188\001\000\002\188\002\000\004\224\001\000\004\224\002\000\004\224\003\000\b8\001\000\004\224\004\000\t\172\001\000\t\168\001\000\t\164\001\000\001\144\001\000\001\144\002\000\t\160\001\000\003\176\001\000\t\160\002\000\t\160\003\000\004\220\001\000\004\216\001\000\004\212\001\000\004\208\001\000\007\020\001\000\000\160\001\000\000\156\001\000\006\252\001\000\000\160\002\000\000\156\002\000\000\152\001\000\000\148\001\000\000\152\002\000\000\148\002\000\000\144\001\000\000\140\001\000\000\136\001\000\000|\001\000\005|\001\000\005<\001\000\0054\001\000\005|\002\000\005|\003\000\005|\001\000\005<\001\000\005|\004\000\005<\002\000\005<\003\000\005x\001\000\005<\002\000\0054\002\000\0054\003\000\001|\001\000\000|\002\000\000\140\002\000\006\024\001\000\006\024\002\000\000h\001\000\0034\001\000\003(\001\000\0034\002\000\012\024\001\000\b\232\001\000\b\232\002\000\0120\001\000\000\164\001\000\b\232\003\000\000\128\001\000\000l\001\000\000\128\002\000\000\128\003\000\000l\002\000\003,\001\000\003,\002\000\003,\003\000\003,\004\000\012\020\001\000\b\236\001\000\000\128\001\000\000l\001\000\b\236\002\000\b\236\003\000\000\128\001\000\000l\001\000\0034\003\000\b\240\001\000\b\184\001\000\b\188\001\000\000\140\003\000\000\140\004\000\b\188\002\000\b\188\003\000\011\228\001\000\011\224\001\000\011\224\002\000\006\240\001\000\011\224\003\000\011\224\004\000\b\172\001\000\b\172\002\000\000D\001\000\b\172\003\000\000H\001\000\000H\002\000\000H\003\000\000H\004\000\011\224\005\000\b\168\001\000\000H\001\000\011\228\002\000\b\244\001\000\001\216\001\000\001\216\002\000\001\212\001\000\000H\001\000\b\240\001\000\000\136\002\000\000\136\003\000\000\144\002\000\000\144\003\000\b\188\001\000\000\144\004\000\000\144\005\000\b\188\001\000\000\148\003\000\000\148\004\000\b\188\001\000\000\160\003\000\000\156\003\000\000\156\004\000\000\160\004\000\b\144\001\000\000\160\005\000\000\160\006\000\b\144\002\000\b\140\001\000\007\020\002\000\001\216\001\000\004\220\002\000\004\216\002\000\004\212\002\000\004\208\002\000\007,\001\000\007\200\001\000\007\200\002\000\007\200\003\000\001\128\001\000\n\144\001\000\n\144\002\000\001\140\001\000\001\152\001\000\001\132\001\000\nd\001\000\012\132\001\000\nh\001\000\007\200\004\000\np\001\000\n\132\001\000\n\128\001\000\n\132\002\000\n\132\003\000\t\140\001\000\n\140\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\005l\001\000\001\176\001\000\001\172\001\000\n\160\002\000\n\156\002\000\n\152\002\000\n\148\002\000\005l\002\000\001\176\002\000\n\160\003\000\n\156\003\000\001\176\003\000\n\156\004\000\007\164\001\000\007\164\002\000\007\164\003\000\007\184\001\000\007\148\001\000\007\168\001\000\007\156\001\000\007\168\002\000\007\172\001\000\007\168\003\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\172\002\000\007\172\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\140\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\003\000\007\140\001\000\007\160\002\000\007\172\001\000\007\160\003\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\152\002\000\007\152\003\000\007\144\002\000\n\140\001\000\007\196\001\000\007\196\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\n\168\001\000\n\136\001\000\007\192\001\000\007\188\001\000\012|\001\000\n\164\001\000\nx\001\000\nt\001\000\nl\001\000\007\192\002\000\001\180\001\000\001\148\001\000\007\192\003\000\006 \001\000\006\028\001\000\006 \002\000\007\192\004\000\007\192\005\000\007\192\006\000\n\136\001\000\001\184\001\000\t\148\001\000\t\144\001\000\006\192\001\000\001\180\002\000\001\180\003\000\n\164\002\000\nl\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\nl\003\000\n\164\003\000\n\164\004\000\001\216\001\000\n\164\005\000\007\188\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\172\001\000\007\164\004\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\001\176\004\000\001\176\005\000\n\160\004\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\n\160\005\000\n\152\003\000\t\164\001\000\n\152\004\000\t\164\002\000\t\164\003\000\t\024\001\000\t\020\001\000\t\016\001\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\t\024\002\000\t\020\002\000\t\024\003\000\n\148\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007,\002\000\004\220\003\000\004\216\003\000\004\212\003\000\004\208\003\000\004\220\004\000\004\216\004\000\004\212\004\000\004\216\005\000\007\004\001\000\004\216\006\000\004\220\005\000\t\172\002\000\t\168\002\000\t\168\003\000\nd\001\000\004\000\001\000\003\252\001\000\003\248\001\000\003\244\001\000\003\240\001\000\003\224\001\000\003\220\001\000\003\220\002\000\003\172\001\000\003\168\001\000\003\172\002\000\003\172\003\000\001\216\001\000\003\220\003\000\003\220\004\000\003\224\002\000\003\208\001\000\003\204\001\000\003\204\002\000\003\204\003\000\0074\001\000\002\180\001\000\nd\001\000\004,\001\000\004(\001\000\003\216\001\000\003\212\001\000\007\232\001\000\003\212\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\004$\001\000\004 \001\000\004$\002\000\004$\003\000\001\216\001\000\003\212\003\000\003\212\004\000\003\212\005\000\007\228\001\000\003\216\002\000\012|\001\000\011\136\001\000\n\164\001\000\nx\001\000\nt\001\000\nl\001\000\001\180\001\000\001\148\001\000\011\136\002\000\011\136\003\000\011\136\004\000\003\228\001\000\003\228\002\000\011\128\001\000\004\012\001\000\002\024\001\000\002\020\001\000\002\016\001\000\002\012\001\000\002\024\002\000\002\020\002\000\002\024\003\000\002\024\004\000\002\024\005\000\005\156\001\000\005\156\002\000\003<\001\000\0038\001\000\0038\002\000\003<\002\000\003<\003\000\005\224\001\000\005\212\001\000\005\224\002\000\005\224\003\000\005\204\001\000\005\204\002\000\b\128\001\000\003@\001\000\b\128\002\000\005\204\003\000\005\204\004\000\005\220\001\000\005\232\001\000\005\228\001\000\005\216\001\000\005\204\005\000\005\232\002\000\012\200\001\000\012\196\001\000\012\200\002\000\012\196\002\000\012\200\003\000\012\196\003\000\012\224\001\000\012\220\001\000\012\224\002\000\012\200\004\000\012\200\005\000\000H\001\000\012\196\004\000\012\196\005\000\000H\001\000\012\196\006\000\bx\001\000\bx\002\000\bx\003\000\001\216\001\000\bx\004\000\bx\005\000\001\216\001\000\012<\001\000\012\216\001\000\012\212\001\000\012\208\001\000\012\204\001\000\012\216\002\000\012\212\002\000\012\216\003\000\012\212\003\000\012\212\004\000\012\212\005\000\005\232\001\000\005\228\001\000\005\216\001\000\005\228\002\000\005\232\001\000\005\228\003\000\005\228\001\000\005\216\001\000\005\216\002\000\005|\001\000\005\\\001\000\005<\001\000\005\\\002\000\005<\002\000\005<\003\000\003t\001\000\005\\\003\000\005\248\001\000\005X\001\000\005\236\001\000\012\216\004\000\012\216\005\000\005\232\001\000\005\228\001\000\005\216\001\000\012\208\002\000\012\204\002\000\005l\001\000\012\204\003\000\012\204\004\000\005|\001\000\005<\001\000\005l\002\000\012\208\003\000\012\208\004\000\005|\001\000\005<\001\000\b\176\001\000\b\180\001\000\005\232\003\000\b\180\002\000\b\180\003\000\b|\001\000\005\232\001\000\005\228\001\000\005\224\004\000\005\216\001\000\005\232\001\000\005\228\001\000\005\216\001\000\005\212\002\000\005\212\003\000\005\232\001\000\005\228\001\000\005\216\001\000\003<\004\000\003<\005\000\005\156\003\000\005\156\004\000\005\160\001\000\005\176\001\000\005\172\001\000\005\164\001\000\005\156\005\000\007\\\001\000\007X\001\000\007T\001\000\007P\001\000\007L\001\000\007H\001\000\005\176\002\000\005\176\003\000\007L\002\000\007H\002\000\005\176\001\000\005\172\001\000\005\164\001\000\007L\003\000\007H\003\000\007H\004\000\005\232\001\000\005\228\001\000\005\216\001\000\007H\005\000\005\172\002\000\005\164\002\000\005\168\001\000\005l\001\000\005\180\001\000\005\176\001\000\005\172\001\000\005\164\001\000\002\024\006\000\002\024\007\000\nT\001\000\001\144\001\000\n\024\001\000\n\020\001\000\t\012\001\000\t\b\001\000\t\004\001\000\007\028\001\000\n<\001\000\012\128\001\000\005`\001\000\t\180\001\000\t\176\001\000\002D\001\000\002D\002\000\002D\003\000\t\232\001\000\t\228\001\000\t\232\002\000\t\228\002\000\t\232\003\000\t\228\003\000\0024\001\000\0020\001\000\0024\002\000\0020\002\000\0024\003\000\0020\003\000\002\028\001\000\002\028\002\000\002\028\003\000\b\160\001\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\004\244\001\000\004\240\001\000\004\236\001\000\004\240\002\000\002$\001\000\002 \001\000\002$\002\000\002 \002\000\002$\003\000\002 \003\000\012|\001\000\n\164\001\000\nx\001\000\nt\001\000\nl\001\000\002$\004\000\001\180\001\000\001\148\001\000\002$\005\000\002$\006\000\002$\007\000\003\024\001\000\002\004\001\000\002\000\001\000\002\004\002\000\002\000\002\000\002\004\003\000\002\000\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\002\004\004\000\002\000\004\000\002\004\005\000\002<\001\000\002<\002\000\002<\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\002<\004\000\002<\005\000\n\016\001\000\t\252\001\000\005p\001\000\n,\001\000\n(\001\000\n\028\001\000\n\016\002\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\n,\002\000\n,\003\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\n(\002\000\n(\003\000\t\220\002\000\t\212\002\000\t\204\002\000\t\204\003\000\002@\001\000\002@\002\000\002@\003\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\002@\004\000\n\028\002\000\t\224\002\000\t\216\002\000\t\208\002\000\t\200\002\000\t\196\002\000\t\192\002\000\t\192\003\000\002\168\001\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\002\228\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\002H\001\000\002\b\001\000\003\192\001\000\003\188\001\000\003\192\002\000\003\192\003\000\012$\001\000\012$\002\000\001\216\001\000\012 \001\000\012\028\001\000\012 \002\000\012\028\002\000\001\216\001\000\012 \003\000\012 \004\000\001\216\001\000\003\192\004\000\003\192\005\000\003\188\002\000\003\196\001\000\003\196\002\000\003\200\001\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\003\200\002\000\n\b\001\000\n`\001\000\n\\\001\000\nX\001\000\nP\001\000\nL\001\000\n@\001\000\n8\001\000\n$\001\000\n \001\000\005t\001\000\005l\001\000\001\176\001\000\001\172\001\000\n`\002\000\n\\\002\000\nX\002\000\nP\002\000\nL\002\000\n@\002\000\n8\002\000\n$\002\000\n \002\000\005t\002\000\005l\002\000\001\176\002\000\012|\001\000\n`\003\000\n8\003\000\n \003\000\001\176\003\000\n8\004\000\006\184\001\000\000@\001\000\006\180\001\000\000<\001\000\n`\004\000\n`\005\000\n`\006\000\n`\007\000\005\176\001\000\005\172\001\000\005\164\001\000\n`\b\000\n`\t\000\005\232\001\000\005\228\001\000\005\216\001\000\n`\n\000\011\220\001\000\006\196\001\000\011\216\001\000\006\192\001\000\006x\001\000\002\180\001\000\007\184\001\000\0040\001\000\0040\002\000\0040\003\000\001\216\001\000\0040\004\000\0040\005\000\b\224\001\000\002L\001\000\b\224\002\000\n\b\001\000\002T\001\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\002T\002\000\012\136\001\000\n0\001\000\n\004\001\000\n\000\001\000\004\232\001\000\001\228\001\000\001\228\002\000\001\228\003\000\004\228\001\000\004\016\001\000\002\176\001\000\002\176\002\000\002\176\003\000\t4\001\000\t0\001\000\t,\001\000\t(\001\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\128\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002p\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002l\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\132\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\148\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002|\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002x\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\140\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002h\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002d\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002`\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\\\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002X\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\144\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\136\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\b\228\002\000\b\228\003\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\164\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\003\000\002\164\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\002\184\002\000\b\228\001\000\002\232\001\000\002\184\003\000\002\184\001\000\002\164\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\002\152\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\156\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\160\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\002\232\002\000\n\004\001\000\002P\001\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\002P\002\000\002\172\001\000\b\228\001\000\002\232\001\000\002\184\001\000\002\172\002\000\002\164\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\t4\002\000\t0\002\000\t,\002\000\t4\003\000\t4\004\000\t4\005\000\t0\003\000\000L\001\000\000L\002\000\nh\001\000\004\b\001\000\004\b\002\000\004\b\003\000\001\216\001\000\004\b\004\000\004\b\005\000\007\224\001\000\007\216\001\000\007\208\001\000\007\204\001\000\007\180\001\000\004\004\001\000\004\004\002\000\004\004\003\000\007\180\002\000\007\180\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\204\002\000\007\204\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\224\002\000\007\224\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\216\002\000\007\216\003\000\007\208\002\000\007\212\001\000\007\220\001\000\007\176\001\000\007\176\002\000\007\176\003\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\003\236\001\000\000L\003\000\b\016\001\000\b\016\002\000\007\252\001\000\007\248\001\000\007\252\002\000\007\248\002\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\252\003\000\007\252\004\000\011\192\001\000\011\188\001\000\005\240\001\000\005\240\002\000\005\240\003\000\005\240\004\000\005\240\005\000\007$\001\000\007$\002\000\005\232\001\000\005\228\001\000\005\216\001\000\005\240\006\000\004\132\001\000\004\132\002\000\005\240\007\000\011\192\002\000\011\188\002\000\011\192\003\000\011\188\003\000\011\192\004\000\011\192\005\000\005\132\001\000\005\176\001\000\005\172\001\000\005\164\001\000\005\132\002\000\005\136\001\000\005\232\001\000\005\228\001\000\005\216\001\000\005\136\002\000\005\136\003\000\005\176\001\000\005\172\001\000\005\164\001\000\005\136\004\000\011\192\006\000\011\192\007\000\004\\\001\000\004\\\002\000\004\\\003\000\004\\\004\000\004\\\005\000\004\\\006\000\005\140\001\000\005\140\002\000\011\192\b\000\011\188\004\000\011\188\005\000\011\188\006\000\003\140\001\000\003\140\002\000\003\004\001\000\003\004\002\000\011\212\001\000\011\212\002\000\011\212\003\000\011\212\004\000\005\176\001\000\005\172\001\000\005\164\001\000\011\212\005\000\b\020\001\000\b\020\002\000\b\020\003\000\b\020\004\000\b\020\005\000\b\152\001\000\b\004\001\000\b\152\002\000\b\152\003\000\b\004\002\000\b\004\003\000\001\216\001\000\b\020\006\000\b\020\007\000\006(\001\000\006$\001\000\006(\002\000\b\020\b\000\b\020\t\000\b\000\001\000\001\216\001\000\011|\001\000\t8\001\000\011|\002\000\t8\002\000\011|\003\000\t8\003\000\001\160\001\000\001\164\001\000\001\148\001\000\001\164\002\000\001\164\003\000\001\144\001\000\011|\004\000\t8\004\000\003H\001\000\001\200\001\000\006\000\001\000\003\152\001\000\003\148\001\000\003\152\002\000\003\148\002\000\003\152\003\000\003\148\003\000\b\152\001\000\b\012\001\000\b\012\002\000\b\012\003\000\000H\001\000\003\152\004\000\003\148\004\000\003\152\005\000\003\148\005\000\003\152\006\000\003\152\007\000\b\b\001\000\000H\001\000\001\200\002\000\001\200\003\000\003\164\001\000\003\160\001\000\003\164\002\000\003\156\001\000\b\212\001\000\001\196\001\000\b\212\002\000\001\196\002\000\b\212\003\000\001\196\003\000\000\128\001\000\000l\001\000\003H\002\000\b\208\001\000\001\192\001\000\000\128\001\000\000l\001\000\011|\005\000\001\180\001\000\001\148\001\000\005l\001\000\001\176\001\000\001\172\001\000\005l\002\000\001\176\002\000\001\176\003\000\011|\006\000\011|\007\000\011|\b\000\003X\001\000\003T\001\000\003P\001\000\003L\001\000\b\152\001\000\003X\002\000\003P\002\000\003X\003\000\003P\003\000\003P\004\000\003P\005\000\003P\006\000\000\128\001\000\000l\001\000\b\208\001\000\003X\004\000\001\192\001\000\000\128\001\000\000l\001\000\003L\002\000\003L\003\000\003L\004\000\000\128\001\000\000l\001\000\b\208\001\000\003T\002\000\001\192\001\000\000\128\001\000\000l\001\000\t8\005\000\t8\006\000\t8\007\000\001\168\001\000\007\244\001\000\007\240\001\000\t\\\001\000\tX\001\000\003p\001\000\003l\001\000\003h\001\000\003d\001\000\t\\\002\000\tX\002\000\003p\002\000\003l\002\000\003h\002\000\003d\002\000\t\\\003\000\tX\003\000\003p\003\000\003l\003\000\003h\003\000\003d\003\000\t\\\004\000\003p\004\000\003h\004\000\t\\\005\000\003p\005\000\003h\005\000\0050\001\000\003p\006\000\003h\006\000\003h\007\000\001\144\001\000\000\144\001\000\000\140\001\000\000\136\001\000\006T\001\000\006T\002\000\006T\003\000\006D\001\000\003\\\001\000\001\204\001\000\003\\\002\000\003\\\003\000\003\\\004\000\bL\001\000\001\208\001\000\003\\\001\000\bL\002\000\003h\b\000\bx\001\000\003h\t\000\003h\n\000\bD\001\000\bH\001\000\006`\001\000\006\\\001\000\006P\001\000\006L\001\000\006@\001\000\006<\001\000\006,\001\000\001\216\001\000\006`\002\000\006\\\002\000\006P\002\000\006L\002\000\006@\002\000\006<\002\000\006`\003\000\006P\003\000\006@\003\000\006`\004\000\006`\005\000\006`\006\000\006P\004\000\006@\004\000\003`\001\000\003`\002\000\003`\003\000\006\\\003\000\006\\\004\000\006\\\005\000\006L\003\000\006<\003\000\0064\001\000\003p\007\000\bx\001\000\003p\b\000\003p\t\000\t\\\006\000\t\\\007\000\b\028\001\000\t\\\b\000\t\\\t\000\bp\001\000\t\\\n\000\bp\002\000\bh\001\000\bl\001\000\tX\004\000\003l\004\000\003d\004\000\0050\001\000\003l\005\000\003d\005\000\003d\006\000\003d\007\000\bx\001\000\003d\b\000\003d\t\000\003l\006\000\bx\001\000\003l\007\000\003l\b\000\tX\005\000\tX\006\000\tX\007\000\tX\b\000\bp\001\000\tX\t\000\004\140\001\000\006p\001\000\006l\001\000\006p\002\000\006p\003\000\006p\004\000\006p\005\000\005|\001\000\005<\001\000\006p\006\000\006l\002\000\006l\003\000\006l\004\000\005|\001\000\005<\001\000\006l\005\000\tp\001\000\th\001\000\td\001\000\005\244\001\000\005\240\001\000\005\196\001\000\005\244\002\000\005\240\002\000\005\244\003\000\005\240\003\000\005\244\004\000\005\240\004\000\005\244\005\000\005\240\005\000\005\244\006\000\005\244\007\000\005\232\001\000\005\228\001\000\005\216\001\000\005\244\b\000\tp\002\000\th\002\000\td\002\000\005\196\002\000\tp\003\000\th\003\000\td\003\000\005\196\003\000\005\196\004\000\005\188\001\000\005\196\005\000\005\196\006\000\005|\001\000\005<\001\000\005\196\007\000\tp\004\000\tp\005\000\tp\006\000\tp\007\000\005\232\001\000\005\228\001\000\005\216\001\000\tp\b\000\004d\001\000\004d\002\000\004d\003\000\004d\004\000\005\232\001\000\005\228\001\000\005\216\001\000\004d\005\000\004d\006\000\004d\007\000\tp\t\000\th\004\000\td\004\000\th\005\000\th\006\000\005l\001\000\th\007\000\005\144\001\000\005\232\001\000\005\228\001\000\005\216\001\000\005\144\002\000\td\005\000\td\006\000\005\148\001\000\005\148\002\000\t\128\001\000\t\128\002\000\t\128\003\000\t\128\004\000\005\232\001\000\005\228\001\000\005\216\001\000\t\128\005\000\t8\001\000\t8\002\000\t8\003\000\t8\004\000\t\132\001\000\001x\001\000\001x\002\000\001x\003\000\001x\004\000\012\168\001\000\001x\005\000\003\012\001\000\b\204\001\000\003\012\002\000\003\012\003\000\001x\006\000\001x\007\000\001x\b\000\001D\001\000\001D\002\000\001\024\001\000\001\216\001\000\001\024\002\000\001\024\003\000\001D\003\000\001$\001\000\001$\002\000\006\020\001\000\006\012\001\000\006\020\002\000\006\016\001\000\006\b\001\000\006\016\002\000\001$\003\000\001$\004\000\001$\005\000\001\216\001\000\001$\006\000\001$\007\000\001(\001\000\001(\002\000\b0\001\000\b(\001\000\b0\002\000\b,\001\000\b$\001\000\b,\002\000\001(\003\000\001(\004\000\001(\005\000\001(\006\000\001(\007\000\001 \001\000\001 \002\000\001P\001\000\001L\001\000\001P\002\000\001L\002\000\001P\003\000\001P\004\000\005l\001\000\001P\005\000\001P\006\000\001<\001\000\b\196\001\000\001<\002\000\001<\003\000\001<\004\000\b\196\002\000\b\196\003\000\001\216\001\000\b\192\001\000\001\216\001\000\001@\001\000\0018\001\000\001P\007\000\001H\001\000\001H\002\000\001L\003\000\005l\001\000\001L\004\000\001L\005\000\001L\006\000\001H\001\000\001H\001\000\001 \003\000\001 \004\000\001,\001\000\001,\002\000\001\216\001\000\001\188\001\000\001\188\002\000\001\216\001\000\001\188\003\000\001,\003\000\001,\004\000\001D\004\000\001D\005\000\0010\001\000\0010\002\000\0014\001\000\004\168\001\000\004\168\002\000\001x\t\000\001H\001\000\001x\n\000\004T\001\000\004T\002\000\004T\003\000\004T\004\000\004T\005\000\004T\006\000\004T\007\000\001H\001\000\004T\b\000\004T\t\000\001x\011\000\t\132\002\000\t\132\003\000\t\132\004\000\t\132\005\000\t\132\006\000\t\132\007\000\0050\001\000\001p\001\000\001p\002\000\001p\003\000\001p\004\000\001<\001\000\000\144\001\000\000\140\001\000\000\136\001\000\b\244\001\000\b\192\001\000\001\216\001\000\001t\001\000\001t\002\000\001l\001\000\001l\002\000\001l\003\000\0120\001\000\001|\001\000\001@\001\000\000\164\001\000\001l\004\000\001h\001\000\001H\001\000\001t\003\000\001p\005\000\t\132\b\000\t\132\t\000\004L\001\000\004L\002\000\004L\003\000\004L\004\000\004L\005\000\004L\006\000\004L\007\000\004L\b\000\004L\t\000\t\132\n\000\tH\001\000\004\144\001\000\t`\001\000\tL\001\000\t|\001\000\tx\001\000\tt\001\000\tl\001\000\004\144\002\000\t@\001\000\t@\002\000\tP\001\000\004t\001\000\004t\002\000\004t\003\000\004t\004\000\004t\005\000\bx\001\000\004t\006\000\004t\007\000\004t\b\000\tP\002\000\tT\001\000\004|\001\000\004|\002\000\004|\003\000\004|\004\000\004|\005\000\004|\006\000\bx\001\000\004|\007\000\004|\b\000\004|\t\000\tT\002\000\tD\001\000\t\136\001\000\004\140\002\000\007\240\002\000\t<\001\000\007\244\002\000\001\216\001\000\011\204\001\000\001x\001\000\011\204\002\000\011\204\003\000\011\204\004\000\011\204\005\000\011\204\006\000\000\244\001\000\001d\001\000\001d\002\000\001d\003\000\000\220\001\000\012\156\001\000\012\148\001\000\012\156\002\000\012\148\002\000\012\156\003\000\012\148\003\000\012\156\004\000\012\148\004\000\012\148\005\000\012\148\006\000\012\156\005\000\012\156\006\000\012\156\007\000\000\220\002\000\000\220\003\000\012\152\001\000\012\144\001\000\012\140\001\000\012\180\001\000\012\172\001\000\012\180\002\000\012\176\001\000\006\000\001\000\012\176\002\000\012\140\002\000\012\140\003\000\012\140\004\000\012\140\005\000\001\216\001\000\012\152\002\000\012\144\002\000\012\152\003\000\012\144\003\000\012\144\004\000\012\144\005\000\012\152\004\000\012\152\005\000\012\152\006\000\000\224\001\000\005,\001\000\005$\001\000\005\028\001\000\005,\002\000\005$\002\000\005\028\002\000\005,\003\000\005$\003\000\005\028\003\000\005,\004\000\005$\004\000\005\028\004\000\005,\005\000\005$\005\000\005,\006\000\005,\007\000\005,\b\000\005,\t\000\001\216\001\000\005,\n\000\005,\011\000\005$\006\000\005$\007\000\005$\b\000\005\028\005\000\003\232\001\000\011\132\001\000\003\020\001\000\003\020\002\000\003\020\003\000\003\016\001\000\011\132\002\000\000\224\002\000\000\224\003\000\005(\001\000\005 \001\000\005\024\001\000\005\020\001\000\012\192\001\000\012\184\001\000\012\192\002\000\012\188\001\000\b\028\001\000\012\188\002\000\005\020\002\000\005\020\003\000\005\020\004\000\005\020\005\000\005(\002\000\005 \002\000\005\024\002\000\005(\003\000\005 \003\000\005\024\003\000\005(\004\000\005 \004\000\005(\005\000\005(\006\000\005(\007\000\005(\b\000\001\216\001\000\005(\t\000\005(\n\000\005 \005\000\005 \006\000\005 \007\000\005\024\004\000\000\232\001\000\000\232\002\000\000\232\003\000\000\232\004\000\000\216\001\000\000\212\001\000\000\216\002\000\000\216\003\000\001`\001\000\001T\001\000\004\024\001\000\004\020\001\000\000\196\001\000\000\192\001\000\004\024\002\000\004\024\003\000\004\024\004\000\004\024\005\000\004\024\006\000\004\024\007\000\000\196\002\000\000\192\002\000\000\196\003\000\000\196\004\000\005l\001\000\000\196\005\000\000\196\006\000\001\\\001\000\b\196\001\000\001\\\002\000\001\\\003\000\001\\\004\000\000\184\001\000\000\184\002\000\001\004\001\000\001\000\001\000\001\000\002\000\004\028\001\000\000\188\001\000\000\188\002\000\000\208\001\000\000\204\001\000\000\180\001\000\003\184\001\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\003\184\002\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\003\180\001\000\b\136\001\000\000\204\002\000\b\136\002\000\b\132\001\000\001X\001\000\000\200\001\000\000\188\003\000\000\200\002\000\004\028\002\000\001\000\003\000\000\200\001\000\001\004\002\000\000\184\003\000\000\200\001\000\000\196\007\000\000\192\003\000\005l\001\000\000\192\004\000\000\192\005\000\000\200\001\000\000\192\006\000\004\020\002\000\004\020\003\000\004\020\004\000\004\020\005\000\001`\002\000\001T\002\000\000\200\001\000\001T\003\000\001`\003\000\001`\004\000\001`\005\000\000\216\004\000\000\200\001\000\007\012\001\000\007\012\002\000\000\216\005\000\000\216\006\000\000\212\002\000\000\212\003\000\000\200\001\000\000\212\004\000\000\212\005\000\000\228\001\000\000\228\002\000\000\228\003\000\000\228\004\000\001d\004\000\001d\005\000\000\236\001\000\000\236\002\000\000\240\001\000\004\176\001\000\004\176\002\000\000\244\002\000\000\200\001\000\000\248\001\000\000\248\002\000\000\248\003\000\000\248\004\000\000\200\001\000\000\252\001\000\000\252\002\000\011\204\007\000\011\204\b\000\004D\001\000\004D\002\000\004D\003\000\004D\004\000\004D\005\000\004D\006\000\004D\007\000\004D\b\000\011\204\t\000\011\168\001\000\004\160\001\000\004\012\001\000\004\012\002\000\004\012\003\000\004\012\004\000\004\012\005\000\004\012\006\000\011\184\001\000\011x\001\000\011\164\001\000\011\200\001\000\011\196\001\000\011\148\001\000\004\232\001\000\004\232\002\000\004\160\002\000\011\152\001\000\004\016\001\000\004\016\002\000\011\156\001\000\011\156\002\000\011\172\001\000\011\172\002\000\011\160\001\000\011\208\001\000\007\236\001\000\011\144\001\000\011\144\002\000\011\144\003\000\003\004\003\000\003\004\004\000\011\148\001\000\004\232\001\000\001\228\001\000\011\140\001\000\011\152\001\000\004\016\001\000\002\176\001\000\003\140\003\000\003\140\004\000\b\016\003\000\b\016\004\000\000L\004\000\b\228\001\000\b\224\003\000\002\232\001\000\002\184\001\000\002\164\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\007\224\001\000\007\216\001\000\007\208\001\000\007\204\001\000\007\180\001\000\0044\001\000\0044\002\000\0044\003\000\004<\001\000\002\180\002\000\002\180\003\000\002\180\004\000\004<\002\000\004<\003\000\0048\001\000\n\016\001\000\006\156\001\000\n \004\000\n \005\000\nP\003\000\nL\003\000\nP\004\000\nL\004\000\nL\005\000\t\000\001\000\b\252\001\000\b\248\001\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\t\000\002\000\b\252\002\000\t\000\003\000\n\\\003\000\nX\003\000\n\\\004\000\nX\004\000\nX\005\000\n$\003\000\n$\004\000\n$\005\000\n@\003\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\b@\001\000\b@\002\000\b@\003\000\t$\001\000\t \001\000\t\028\001\000\007<\001\000\t$\002\000\t \002\000\t\028\002\000\t$\003\000\t \003\000\t\028\003\000\t$\004\000\t \004\000\t$\005\000\b<\001\000\n@\004\000\n@\005\000\n`\001\000\n\\\001\000\nX\001\000\nP\001\000\nL\001\000\n@\001\000\n8\001\000\n$\001\000\n \001\000\005t\001\000\005l\001\000\005d\001\000\001\176\001\000\001\172\001\000\n`\002\000\n\\\002\000\nX\002\000\nP\002\000\nL\002\000\n@\002\000\n8\002\000\n$\002\000\n \002\000\005t\002\000\005l\002\000\005d\002\000\001\176\002\000\012\128\001\000\005d\003\000\005t\003\000\t\220\002\000\t\212\002\000\t\204\002\000\002\224\002\000\002\216\002\000\002\208\002\000\t\204\003\000\002\208\003\000\t\204\004\000\002\208\004\000\t\204\005\000\002\208\005\000\002\208\006\000\b\228\001\000\002\232\001\000\002\208\007\000\002\184\001\000\002\164\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\t\220\003\000\002\224\003\000\t\220\004\000\002\224\004\000\t\220\005\000\002\224\005\000\002\224\006\000\b\228\001\000\002\232\001\000\002\224\007\000\002\184\001\000\002\164\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\t\212\003\000\002\216\003\000\t\212\004\000\002\216\004\000\t\212\005\000\002\216\005\000\002\216\006\000\b\228\001\000\002\232\001\000\002\216\007\000\002\184\001\000\002\164\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\n\028\002\000\t\224\002\000\t\216\002\000\t\208\002\000\t\200\002\000\t\196\002\000\t\192\002\000\002\228\002\000\002\220\002\000\002\212\002\000\002\204\002\000\002\200\002\000\002\196\002\000\002\192\002\000\t\192\003\000\002\196\003\000\t\192\004\000\002\196\004\000\t\192\005\000\002\196\005\000\002\196\006\000\b\228\001\000\002\232\001\000\002\196\007\000\002\184\001\000\002\164\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\t\200\003\000\002\204\003\000\t\200\004\000\002\204\004\000\t\200\005\000\002\204\005\000\002\204\006\000\b\228\001\000\002\232\001\000\002\204\007\000\002\184\001\000\002\164\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\t\196\003\000\002\200\003\000\t\196\004\000\002\200\004\000\t\196\005\000\002\200\005\000\002\200\006\000\b\228\001\000\002\232\001\000\002\200\007\000\002\184\001\000\002\164\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\t\224\003\000\t\216\003\000\t\208\003\000\005l\001\000\005d\001\000\002\228\003\000\002\220\003\000\002\212\003\000\t\224\004\000\t\216\004\000\t\208\004\000\002\228\004\000\002\220\004\000\002\212\004\000\t\208\005\000\002\212\005\000\t\208\006\000\002\212\006\000\t\208\007\000\002\212\007\000\002\212\b\000\b\228\001\000\002\232\001\000\002\212\t\000\002\184\001\000\002\164\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\t\224\005\000\002\228\005\000\t\224\006\000\002\228\006\000\t\224\007\000\002\228\007\000\002\228\b\000\b\228\001\000\002\232\001\000\002\228\t\000\002\184\001\000\002\164\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\t\216\005\000\002\220\005\000\t\216\006\000\002\220\006\000\t\216\007\000\002\220\007\000\002\220\b\000\b\228\001\000\002\232\001\000\002\220\t\000\002\184\001\000\002\164\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\n\028\003\000\002\192\003\000\002\192\004\000\b\228\001\000\002\232\001\000\002\192\005\000\002\184\001\000\002\164\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\b\136\001\000\002H\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\168\002\000\002\164\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\t\192\004\000\t\192\005\000\t\200\003\000\t\200\004\000\t\200\005\000\t\196\003\000\t\196\004\000\t\196\005\000\t\224\003\000\t\216\003\000\t\208\003\000\005l\001\000\005d\001\000\t\224\004\000\t\216\004\000\t\208\004\000\t\208\005\000\t\208\006\000\t\208\007\000\t\224\005\000\t\224\006\000\t\224\007\000\t\216\005\000\t\216\006\000\t\216\007\000\n\028\003\000\t\204\004\000\t\204\005\000\t\220\003\000\t\220\004\000\t\220\005\000\t\212\003\000\t\212\004\000\t\212\005\000\002<\006\000\001\220\001\000\001\224\001\000\002<\007\000\002<\b\000\002<\t\000\002<\n\000\002<\011\000\002\004\006\000\002\004\007\000\002\004\b\000\002\004\t\000\002\000\005\000\002\000\006\000\002\000\007\000\002\000\b\000\002\000\t\000\002\000\n\000\002\000\011\000\003\024\002\000\012|\001\000\n\164\001\000\nx\001\000\nt\001\000\nl\001\000\003$\001\000\001\180\001\000\001\148\001\000\003$\002\000\003$\003\000\003$\004\000\003\028\001\000\003\028\002\000\000\128\001\000\000l\001\000\003\028\003\000\003\028\004\000\003 \001\000\003 \002\000\003$\005\000\002$\b\000\002 \004\000\002 \005\000\004\240\003\000\004\240\004\000\004\240\005\000\004\244\002\000\004\236\002\000\004\244\003\000\004\236\003\000\b\160\002\000\b\164\001\000\002\028\004\000\b\164\002\000\b\164\003\000\b\156\001\000\0024\004\000\0020\004\000\0024\005\000\0020\005\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\0024\006\000\0020\006\000\0020\007\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\0020\b\000\t\232\004\000\t\228\004\000\t\228\005\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\002D\004\000\t\176\002\000\b\228\001\000\002\232\001\000\002\184\001\000\002\164\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\t\176\003\000\n,\001\000\n(\001\000\n\028\001\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\180\002\000\n<\002\000\n<\003\000\b\228\001\000\007\028\002\000\002\232\001\000\002\184\001\000\002\164\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\t\012\002\000\t\b\002\000\t\004\002\000\t\012\003\000\t\b\003\000\t\012\004\000\n\024\002\000\n\020\002\000\n\020\003\000\nT\002\000\nT\003\000\002\024\b\000\002\020\003\000\002\020\004\000\005\176\001\000\005\172\001\000\005\164\001\000\002\020\005\000\002\020\006\000\002\020\007\000\002\012\002\000\002\012\003\000\002\012\004\000\002\012\005\000\002\012\006\000\002\012\007\000\002\012\b\000\002\016\002\000\002\016\003\000\002\016\004\000\002\016\005\000\002\016\006\000\002\016\007\000\002\016\b\000\002\016\t\000\011\128\002\000\011\136\005\000\004(\002\000\0074\002\000\003\204\004\000\003\204\005\000\003\208\002\000\012 \001\000\012\028\001\000\004\000\002\000\003\252\002\000\004\000\003\000\004\000\004\000\004\000\005\000\004\000\006\000\001\216\001\000\004\000\007\000\004\000\b\000\b\152\001\000\003\252\003\000\003\252\004\000\003\252\005\000\001\216\001\000\003\252\006\000\003\252\007\000\003\248\002\000\003\248\003\000\003\248\004\000\003\244\002\000\004\224\005\000\004\224\006\000\b\228\001\000\002\232\001\000\002\188\003\000\002\184\001\000\002\164\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\nH\002\000\nD\002\000\nD\003\000\n,\001\000\n(\001\000\n\028\001\000\n\012\002\000\t\224\001\000\t\220\001\000\t\216\001\000\t\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\t\196\001\000\t\192\001\000\t\244\002\000\t\240\002\000\t\244\003\000\t\240\003\000\t\244\004\000\t\240\004\000\t\244\005\000\t\240\005\000\005\176\001\000\005\172\001\000\005\164\001\000\t\240\006\000\t\244\006\000\t\244\007\000\005\232\001\000\005\228\001\000\005\216\001\000\t\244\b\000\t\188\002\000\t\184\002\000\t\184\003\000\t\188\003\000\t\188\004\000\002(\004\000\002(\005\000\b\164\001\000\002(\006\000\001\232\004\000\001\232\005\000\b\164\001\000\001\232\006\000\b\228\001\000\007\\\004\000\007X\004\000\007T\004\000\007P\004\000\002\232\001\000\002\184\001\000\002\164\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\007P\005\000\007\\\005\000\007\\\006\000\005\232\001\000\005\228\001\000\005\216\001\000\007\\\007\000\007X\005\000\007T\005\000\007X\006\000\007T\006\000\005\232\001\000\005\228\001\000\005\216\001\000\007T\007\000\007X\007\000\007X\b\000\005\232\001\000\005\228\001\000\005\216\001\000\007X\t\000\006h\005\000\005\176\001\000\005\172\001\000\005\164\001\000\006h\006\000\006d\002\000\006d\003\000\006d\004\000\005\176\001\000\005\172\001\000\005\164\001\000\006d\005\000\004\156\002\000\004\156\003\000\004\156\004\000\004\152\002\000\002\244\003\000\002\244\004\000\005\b\003\000\005\000\003\000\004\248\003\000\005\b\004\000\005\000\004\000\004\248\004\000\005\000\005\000\004\248\005\000\005\000\006\000\004\248\006\000\005\016\001\000\004\248\007\000\005\012\001\000\005\004\001\000\004\252\001\000\000\128\001\000\000l\001\000\005\004\002\000\004\252\002\000\004\252\003\000\000x\002\000\000t\002\000\000t\003\000\0030\003\000\0030\004\000\0030\005\000\b\216\001\000\000\132\002\000\000p\002\000\000\132\003\000\000p\003\000\000\132\004\000\000\132\005\000\000p\004\000\b\216\002\000\b\216\003\000\001\216\001\000\b\220\001\000\001\216\001\000\000X\002\000\000X\003\000\b\220\002\000\b\220\003\000\001\216\001\000\006X\002\000\006X\003\000\006X\004\000\006H\002\000\0060\002\000\001\216\001\000\0068\002\000\012,\002\000\011\180\006\000\011\180\007\000\011\180\b\000\003\\\001\000\002\252\001\000\003\\\002\000\002\252\002\000\002\252\003\000\002\252\004\000\002\252\005\000\011\180\t\000\bd\001\000\b`\001\000\011\180\n\000\b`\002\000\bd\002\000\bP\001\000\bX\001\000\bT\001\000\b\\\001\000\003`\001\000\003\000\001\000\003\000\002\000\003\000\003\000\003\000\004\000\011\176\004\000\003l\004\000\0050\001\000\003l\005\000\011\176\005\000\011\176\006\000\011\176\007\000\011\176\b\000\bd\001\000\b`\001\000\011\176\t\000\005\152\003\000\005\152\004\000\005\208\005\000\005\176\001\000\005\172\001\000\005\164\001\000\005\232\001\000\005\228\001\000\005\216\001\000\000\\\005\000\000\\\006\000\012\160\006\000\012\160\007\000\005\200\003\000\005\200\004\000\nx\007\000\005\232\001\000\005\228\001\000\005\216\001\000\nx\b\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\001\016\002\000\001\012\002\000\001\012\003\000\001\016\003\000\001\216\001\000\001\016\004\000\001\016\005\000\t\248\004\000\t\248\005\000\t\248\006\000\002,\004\000\002,\005\000\b\164\001\000\002,\006\000\001\248\004\000\001\244\004\000\001\240\004\000\001\236\004\000\001\248\005\000\001\240\005\000\b\164\001\000\001\248\006\000\001\240\006\000\001\248\007\000\001\248\b\000\001\244\005\000\001\244\006\000\0028\004\000\0028\005\000\0028\006\000\0028\007\000\000\176\003\000\000\176\004\000\001\252\003\000\001\252\004\000\001\252\005\000\001\252\006\000\001\252\007\000\003|\001\000\003|\002\000\000\000\001\000\000\004\000\000\003\136\001\000\003\136\002\000\000\004\001\000\000\b\000\000\012|\001\000\005D\001\000\001\148\001\000\005D\002\000\005D\003\000\005H\001\000\000\b\001\000\005|\001\000\005T\001\000\005P\001\000\005L\001\000\005<\001\000\005T\002\000\005P\002\000\005L\002\000\005<\002\000\012|\001\000\005P\003\000\005P\004\000\005P\005\000\005T\003\000\005L\003\000\000P\001\000\005@\001\000\000T\001\000\007`\001\000\007`\002\000\000\012\000\000\000\012\001\000\007d\001\000\007d\002\000\000\016\000\000\000\016\001\000\007h\001\000\001\216\001\000\007h\002\000\000\020\000\000\007l\001\000\007l\002\000\000\020\001\000\000\024\000\000\000\024\001\000\007p\001\000\005|\001\000\005<\001\000\007p\002\000\000\028\000\000\000\028\001\000\007t\001\000\005l\001\000\007t\002\000\000 \000\000\000 \001\000\007x\001\000\005\176\001\000\005\172\001\000\005\164\001\000\007x\002\000\000$\000\000\000$\001\000\007|\001\000\005\232\001\000\005\228\001\000\005\216\001\000\007|\002\000\000(\000\000\000(\001\000\007\128\001\000\007\128\002\000\000,\000\000\007\172\001\000\007\160\001\000\007\152\001\000\007\144\001\000\007\140\001\000\007\132\001\000\007\132\002\000\000,\001\000\0000\000\000\007\136\001\000\007\136\002\000\0000\001\000\005t\001\000\005l\001\000\005t\002\000\005l\002\000\0004\000\000\012\000\001\000\011\252\001\000\011\248\001\000\011\244\001\000\011\240\001\000\011\236\001\000\011\232\001\000\012\000\002\000\011\252\002\000\011\248\002\000\011\244\002\000\011\240\002\000\011\236\002\000\011\232\002\000\012\000\003\000\011\236\003\000\011\240\003\000\011\252\003\000\011\244\003\000\011\248\003\000\005t\001\000\005l\001\000\012\016\001\000\0004\001\000\012\012\001\000\012\012\002\000\004\184\001\000\004\184\002\000\012\004\001\000\012\004\002\000\012\004\003\000\012\b\001\000\012\b\002\000\0008\000\000\004\196\001\000\004\192\001\000\004\204\001\000\004\200\001\000\004\200\002\000\004\204\002\000\004\196\002\000\004\196\003\000\004\196\004\000\004\192\002\000\0008\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\000[\000\\\000^\000_\000`\000b\000c\000d\000k\000l\000m\000n\000o\000p\000s\000t\000u\000w\000y\000{\000|\000}\000\127\000\128\000\129\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\156\000\158\000\159\000\160\000\162\000\164\000\165\000\167\000\169\000\171\000\172\000\174\000\176\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\194\000\195\000\196\000\198\000\199\000\200\000\201\000\202\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\222\000\226\000\230\000\231\000\233\000\234\000\236\000\238\000\239\000\240\000\241\000\244\000\245\000\246\000\247\000\248\000\249\000\250\000\251\000\252\000\254\000\255\001\000\001\001\001\003\001\005\001\006\001\b\001\012\001\018\001\020\001\021\001\022\001\024\001\028\001\031\001 \001!\001#\001$\001%\001&\001(\001)\001*\001+\0011\0015\0019\001:\001;\001<\001=\001?\001A\001B\001C\001D\001E\001F\001G\001H\001I\001J\001K\001L\001M\001N\001O\001P\001W\001Y\001[\001]\001^\001_\001`\001a\001b\001c\001e\001g\001h\001i\001j\001k\001l\001p\001q\001s\001t\001v\001x\001y\001z\001}\001~\001\129\001\130\001\133\001\134\001\135\001\136\001\137\001\139\001\140\001\141\001\142\001\143\001\144\001\145\001\146\001\148\001\149\001\151\001\152\001\153\001\154\001\157\001\158\001\159\001\160\001\161\001\162\001\163\001\164\001\168\001\169\001\172\001\173\001\174\001\175\001\177\001\178\001\179\001\180\001\182\001\183\001\184\001\185\001\187\001\188\001\189\001\191\001\192\001\193\001\194\001\195\001\197\001\198\001\200\001\201\001\203\001\205\001\206\001\207\001\208\001\210\001\211\001\213\001\214\001\217\001\218\001\219\001\221\001\222\001\223\001\224\001\226\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\247\001\248\001\249\001\250\001\251\002\002\002\b\002\011\002\012\002\r\002\014\002\015\002\016\002\017\002\019\002\020\002\026\002\027\002!\002\"\002(\002)\002/\0020\0021\0022\0024\002:\002;\002>\002F\002G\002I\002J\002K\002L\002M\002N\002O\002R\002S\002T\002[\002\\\002]\002_\002`\002f\002l\002m\002n\002t\002u\002w\002x\002y\002z\002\130\002\132\002\133\002\134\002\140\002\144\002\147\002\148\002\149\002\150\002\151\002\152\002\153\002\154\002\160\002\162\002\163\002\165\002\166\002\168\002\169\002\170\002\171\002\173\002\174\002\175\002\176\002\177\002\180\002\182\002\183\002\184\002\191\002\192\002\194\002\195\002\196\002\197\002\198\002\199\002\207\002\208\002\209\002\210\002\211\002\212\002\213\002\218\002\220\002\221\002\222\002\223\002\224\002\225\002\227\002\228\002\229\002\230\002\232\002\233\002\234\002\235\002\236\002\238\002\239\002\240\002\241\002\242\002\246\002\247\002\249\002\251\002\253\002\255\003\000\003\001\003\003\003\004\003\006\003\b\003\t\003\011\003\012\003\014\003\015\003\019\003\021\003\023\003\024\003\028\003\029\003!\003\"\003%\003'\003)\003*\003+\003,\003-\003.\0032\0035\0036\0039\003:\003;\003>\003?\003A\003B\003C\003D\003H\003L\003M\003Q\003R\003S\003T\003U\003Y\003`\003a\003f\003g\003h\003l\003m\003n\003o\003q\003r\003v\003w\003y\003{\003~\003\127\003\128\003\130\003\131\003\132\003\133\003\134\003\135\003\137\003\139\003\141\003\143\003\145\003\147\003\148\003\149\003\150\003\151\003\159\003\160\003\162\003\164\003\166\003\174\003\175\003\176\003\177\003\178\003\180\003\182\003\184\003\191\003\192\003\193\003\194\003\195\003\201\003\202\003\203\003\204\003\205\003\218\003\219\003\232\003\233\003\234\003\237\003\238\003\239\003\240\003\241\003\254\004\005\004\006\004\007\004\031\004!\004\"\004#\004$\004&\004(\004+\004,\004.\004/\0040\0041\0042\0043\0044\004A\004B\004O\004[\004`\004a\004c\004e\004f\004g\004h\004l\004m\004q\004r\004t\004v\004x\004z\004{\004}\004~\004\127\004\129\004\130\004\132\004\145\004\146\004\147\004\148\004\149\004\151\004\152\004\153\004\154\004\156\004\157\004\158\004\185\004\186\004\210\004\211\004\235\004\236\005\004\005\005\005\029\005\030\0056\0057\005O\005P\005h\005i\005\129\005\130\005\154\005\155\005\179\005\180\005\204\005\205\005\229\005\230\005\254\005\255\006\023\006\024\0060\0061\006I\006J\006b\006c\006{\006|\006\148\006\149\006\173\006\174\006\198\006\199\006\223\006\224\006\226\006\239\006\240\007\b\007\011\007\012\007\r\007\014\007\015\007\016\007\017\007\019\007\020\007\022\007\023\007\024\007\030\007\031\007 \007!\007'\007(\007.\007/\0075\0076\0077\0078\0079\007;\007<\007B\007C\007D\007E\007F\007H\007O\007P\007Q\007T\007U\007V\007W\007X\007Y\007]\007^\007_\007`\007a\007c\007e\007f\007g\007h\007l\007m\007q\007r\007v\007w\007x\007y\007z\007{\007|\007}\007~\007\127\007\128\007\129\007\130\007\131\007\132\007\133\007\134\007\135\007\136\007\137\007\138\007\139\007\143\007\144\007\145\007\146\007\147\007\148\007\149\007\151\007\152\007\153\007\154\007\156\007\157\007\158\007\160\007\161\007\162\007\163\007\165\007\167\007\169\007\171\007\172\007\174\007\175\007\176\007\177\007\179\007\180\007\181\007\182\007\184\007\186\007\188\007\190\007\191\007\193\007\195\007\197\007\198\007\199\007\201\007\202\007\203\007\205\007\206\007\207\007\209\007\211\007\215\007\216\007\220\007\221\007\223\007\226\007\228\007\229\007\230\007\231\007\232\007\236\007\239\007\241\007\242\007\243\007\246\007\251\007\252\007\253\b\000\b\005\b\006\b\007\b\b\b\t\b\011\b\017\b\023\b\029\b \b#\b&\b'\b+\b,\b-\b.\b/\b1\b2\b3\b4\b6\b7\b8\b9\b;\b<\b=\b>\bF\bL\bO\bP\bQ\bR\bS\bT\bU\bV\bW\bX\bY\bZ\b[\b\\\b]\b^\b`\ba\bb\bc\bd\be\bg\bh\bi\bj\bk\bn\bq\br\bs\bu\bv\bw\by\bz\b{\b|\b}\b\127\b\128\b\129\b\131\b\132\b\133\b\134\b\137\b\138\b\139\b\140\b\143\b\144\b\150\b\152\b\154\b\156\b\158\b\159\b\163\b\164\b\168\b\172\b\174\b\175\b\178\b\179\b\180\b\181\b\182\b\186\b\187\b\188\b\189\b\190\b\191\b\195\b\196\b\197\b\198\b\200\b\201\b\203\b\204\b\205\b\209\b\210\b\211\b\212\b\213\b\214\b\215\b\216\b\220\b\221\b\222\b\223\b\224\b\225\b\227\b\228\b\229\b\230\b\231\b\232\b\233\b\235\b\236\b\237\b\238\b\239\b\240\b\241\b\242\b\244\b\245\b\246\b\247\b\248\b\250\b\251\b\253\b\254\b\255\t\000\t\001\t\003\t\004\t\005\t\006\t\b\t\t\t\011\t\012\t\r\t\014\t\015\t\016\t\017\t\018\t\019\t\021\t\023\t\024\t\025\t\027\t\028\t\029\t\031\t \t!\t\"\t$\t&\t'\t(\t*\t+\t,\t.\t/\t1\t3\t4\t5\t6\t8\t9\t;\t<\t=\t>\t?\t@\tA\tB\tC\tD\tF\tG\tH\tI\tJ\tK\tL\tM\tO\tP\tQ\tR\tS\tT\tU\tV\tW\tX\tZ\t[\t\\\t]\ta\td\te\tf\tg\th\ti\tk\tm\tn\tp\tq\tr\ts\tt\tu\tv\tw\tx\ty\tz\t{\t|\t}\t~\t\127\t\128\t\129\t\130\t\131\t\132\t\133\t\134\t\135\t\136\t\137\t\138\t\139\t\140\t\141\t\142\t\143\t\145\t\146\t\147\t\148\t\149\t\150\t\151\t\152\t\153\t\154\t\155\t\157\t\158\t\159\t\160\t\161\t\162\t\163\t\164\t\165\t\167\t\169\t\170\t\171\t\172\t\173\t\174\t\175\t\176\t\177\t\178\t\179\t\181\t\183\t\185\t\187\t\188\t\189\t\190\t\191\t\192\t\193\t\194\t\197\t\199\t\200\t\202\t\203\t\204\t\205\t\206\t\208\t\210\t\212\t\213\t\214\t\215\t\216\t\217\t\218\t\221\t\224\t\227\t\230\t\232\t\233\t\234\t\235\t\237\t\238\t\239\t\240\t\241\t\242\t\243\t\244\t\245\t\246\t\247\t\248\t\249\t\250\t\251\t\252\n\000\n\002\n\003\n\005\n\006\n\007\n\b\n\t\n\n\n\r\n\016\n\018\n\019\n\020\n\021\n\023\n\024\n\025\n\026\n\027\n\028\n\029\n\030\n\031\n \n!\n#\n$\n%\n'\n+\n,\n-\n.\n/\n0\n1\n3\n4\n5\n7\n8\n9\n;\n<\n=\n>\n?\nA\nB\nD\nE\nF\nH\nI\nV\nc\ne\nf\ng\nh\nj\nk\nl\nn\no\np\nr\ns\nu\nv\nx\ny\nz\n{\n|\n\127\n\128\n\129\n\130\n\131\n\133\n\134\n\135\n\136\n\137\n\138\n\140\n\141\n\142\n\143\n\144\n\145\n\146\n\147\n\148\n\149\n\150\n\151\n\152\n\153\n\155\n\156\n\157\n\158\n\160\n\161\n\162\n\163\n\164\n\165\n\166\n\167\n\168\n\169\n\170\n\171\n\172\n\173\n\174\n\175\n\176\n\177\n\178\n\179\n\180\n\181\n\182\n\183\n\184\n\185\n\186\n\188\n\189\n\190\n\192\n\193\n\194\n\195\n\196\n\197\n\198\n\199\n\200\n\201\n\202\n\203\n\204\n\205\n\208\n\209\n\212\n\213\n\214\n\215\n\216\n\217\n\241\n\247\n\248\n\249\n\251\n\252\n\253\n\254\n\255\011\000\011\002\011\003\011\004\011\006\011\007\011\b\011\t\011#\011%\011&\011(\011)\011*\011+\011,\011-\011.\011/\011<\011=\011>\011A\011B\011E\011H\011J\011K\011L\011M\011N\011\\\011i\011k\011l\011r\011t\011v\011x\011y\011\145\011\147\011\149\011\151\011\152\011\176\011\178\011\180\011\182\011\183\011\207\011\221\011\223\011\225\011\227\011\228\011\252\011\254\012\000\012\002\012\003\012\027\012\029\012\031\012!\012\"\012:\012B\012H\012J\012L\012N\012O\012g\012i\012k\012m\012n\012\134\012\136\012\138\012\140\012\141\012\165\012\167\012\168\012\192\012\194\012\218\012\219\012\220\012\221\012\222\012\223\012\224\012\225\012\226\012\231\012\234\012\235\012\236\012\237\012\238\012\239\012\240\012\241\012\242\012\243\012\244\012\245\012\246\012\247\012\248\012\249\012\250\012\251\012\252\012\253\012\254\012\255\r\000\r\001\r\002\r\003\r\004\r\005\r\006\r\007\r\b\r\t\r\n\r\011\r\012\r\r\r\014\r\015\r\016\r\024\r\025\r\026\r\027\r\028\r\031\r \r!\r\"\r#\r$\r%\r&\r'\r(\r)\r*\r,\r-\r.\r/\r1\r2\r3\r4\r6\r8\rQ\rR\rj\rk\rl\rm\rz\r\146\r\147\r\160\r\161\r\162\r\186\r\189\r\191\r\192\r\193\r\194\r\195\r\196\r\197\r\198\r\199\r\200\r\204\r\205\r\206\r\207\r\208\r\209\r\210\r\211\r\212\r\213\r\214\r\215\r\216\r\217\r\218\r\219\r\220\r\221\r\222\r\223\r\224\r\225\r\226\r\227\r\228\r\232\r\233\r\234\r\235\r\237\r\238\r\239\r\241\r\242\r\244\r\245\r\246\r\247\r\248\r\249\r\250\r\251\r\252\014\020\014\021\014\022\014\023\014$\014&\014(\014*\014/\0140\0141\0145\0146\0148\0149\014:\014;\014<\014=\014?\014@\014A\014C\014^\014_\014`\014d\014e\014g\014l\014m\014n\014r\014s\014w\014x\014y\014z\014~\014\127\014\128\014\129\014\130\014\131\014\132\014\133\014\136\014\139\014\141\014\143\014\144\014\145\014\150\014\152\014\153\014\154\014\155\014\156\014\157\014\158\014\159\014\162\014\164\014\165\014\166\014\167\014\168\014\170\014\173\014\174\014\175\014\177\014\178\014\179\014\180\014\181\014\183\014\184\014\185\014\186\014\187\014\188\014\190\014\192\014\193\014\194\014\195\014\198\014\199\014\200\014\201\014\202\014\203\014\204\014\205\014\207\014\208\014\209\014\210\014\212\014\214\014\215\014\216\014\217\014\220\014\221\014\222\014\223\014\227\014\231\014\232\014\233\014\234\014\235\014\236\014\240\014\241\014\248\014\249\014\250\014\252\014\253\014\254\014\255\015\000\015\001\015\002\015\004\015\b\015\n\015\r\015\014\015\015\015\016\015\017\015\018\015\019\015\020\015\021\015\022\015\023\015\024\015\025\015\026\015\027\015\028\015\029\015\030\015\031\015 \015!\015\"\015#\015$\015'\015(\015)\015*\015+\0150\0154\0156\0157\0158\0159\015:\015;\015<\015=\015>\015?\015@\015A\015B\015C\015D\015E\015G\015H\015I\015J\015K\015L\015M\015N\015Q\015R\015S\015T\015V\015W\015X\015Y\015]\015^\015_\015`\015d\015e\015f\015g\015h\015i\015j\015p\015q\015r\015s\015t\015u\015v\015x\015z\015{\015\130\015\137\015\138\015\139\015\140\015\141\015\142\015\145\015\146\015\147\015\148\015\149\015\150\015\151\015\152\015\153\015\154\015\155\015\156\015\157\015\159\015\160\015\161\015\162\015\163\015\164\015\165\015\166\015\167\015\168\015\169\015\170\015\171\015\172\015\173\015\174")) + ((32, "\000\000\000\000\000\002\b\001\000\002 \001\000\011\160\001\000\011\156\001\000\011\152\001\000\011\148\001\000\011\144\001\000\n\220\001\000\011\140\001\000\011\136\001\000\011\132\001\000\011\128\001\000\011|\001\000\011x\001\000\011t\001\000\011p\001\000\011l\001\000\011h\001\000\011d\001\000\011`\001\000\011\\\001\000\011X\001\000\011T\001\000\011P\001\000\011L\001\000\011H\001\000\011D\001\000\n\216\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\244\001\000\n\240\001\000\n\236\001\000\n\232\001\000\n\228\001\000\n\224\001\000\000\132\001\000\000\128\001\000\000\132\002\000\000\132\003\000\002 \002\000\002\b\002\000\000\140\001\000\000\140\002\000\002t\001\000\002t\002\000\002t\003\000\n`\001\000\005\132\001\000\002\004\001\000\002\000\001\000\001\252\001\000\001\248\001\000\002\004\002\000\002\000\002\000\001\252\002\000\001\248\002\000\002\004\003\000\002\000\003\000\001\252\003\000\001\248\003\000\002h\001\000\002h\002\000\002h\003\000\001x\001\000\001d\001\000\002(\001\000\n8\001\000\n$\001\000\n$\002\000\n$\003\000\000\236\001\000\000\232\001\000\n\168\001\000\t\200\001\000\t\196\001\000\t\196\002\000\t\200\002\000\t\192\001\000\t\188\001\000\t\188\002\000\t\192\002\000\012\164\001\000\n\208\001\000\n\164\001\000\n\160\001\000\n\152\001\000\001\144\001\000\001p\001\000\006\236\001\000\001p\002\000\006\152\001\000\006\224\001\000\006\220\001\000\t\200\001\000\t\196\001\000\006\216\001\000\006\240\001\000\007\000\001\000\n\164\002\000\n\160\002\000\n\164\003\000\n\160\003\000\n\164\004\000\n\160\004\000\005\220\001\000\005\216\001\000\n\164\005\000\n\160\005\000\n\160\006\000\n\164\006\000\005T\001\000\003\144\001\000\005\228\001\000\005\228\002\000\012\200\001\000\012\200\002\000\012\200\003\000\012\164\001\000\006\216\001\000\006\232\001\000\006\228\001\000\006\156\001\000\006\248\001\000\006\212\001\000\006\208\001\000\006\204\001\000\006\200\001\000\006\196\001\000\006\188\001\000\006\252\001\000\006\244\001\000\006\184\001\000\006\180\001\000\006\176\001\000\006\172\001\000\006\168\001\000\006\164\001\000\006\168\002\000\006\164\002\000\003\160\001\000\003\160\002\000\006\168\003\000\006\164\003\000\006\168\004\000\006\164\004\000\006\168\005\000\006\176\002\000\006\172\002\000\006\176\003\000\006\172\003\000\006\176\004\000\006\172\004\000\006\176\005\000\006\184\002\000\006\180\002\000\006\184\003\000\006\180\003\000\006\184\004\000\006\180\004\000\006\184\005\000\007\016\001\000\007\004\001\000\006\192\001\000\006\160\001\000\007\b\001\000\007\012\001\000\012\164\002\000\012\164\003\000\012\168\001\000\012\200\004\000\012\200\005\000\000|\001\000\005T\001\000\b\200\001\000\000x\001\000\003\144\001\000\003\148\001\000\b\200\002\000\000x\002\000\007p\001\000\007p\002\000\007p\003\000\007l\001\000\001\200\001\000\001\196\001\000\000p\001\000\000d\001\000\000x\001\000\000x\002\000\001\200\002\000\001\200\003\000\001\200\004\000\005\236\001\000\005\236\002\000\005\236\003\000\005\236\004\000\005\212\001\000\005\180\001\000\005\180\002\000\011\220\001\000\011\216\001\000\003\140\001\000\003\136\001\000\011\220\002\000\011\216\002\000\003\140\002\000\003\136\002\000\011\220\003\000\011\216\003\000\003\140\003\000\003\136\003\000\012\152\001\000\012\132\001\000\012x\001\000\012\132\002\000\011\220\004\000\003\140\004\000\012\140\001\000\012|\001\000\012\140\002\000\012h\001\000\012\148\001\000\012\144\001\000\012\136\001\000\012\128\001\000\012\136\002\000\012\144\002\000\012\\\001\000\012p\001\000\012l\001\000\012l\002\000\012\\\002\000\b\252\001\000\012h\002\000\t\000\001\000\012h\003\000\t\000\002\000\t\000\003\000\011\220\005\000\003\140\005\000\005L\001\000\003\140\006\000\012T\001\000\005T\001\000\001|\001\000\006t\001\000\006d\001\000\006T\001\000\006L\001\000\001\200\001\000\001\196\001\000\001\128\001\000\001p\001\000\000p\001\000\000d\001\000\005L\001\000\003L\001\000\003L\002\000\005L\001\000\006\132\001\000\006\128\001\000\005L\001\000\005$\001\000\005\028\001\000\005\020\001\000\005$\002\000\005\028\002\000\005\020\002\000\002$\001\000\002$\002\000\004\184\001\000\004\180\001\000\003\172\001\000\000@\001\000\000<\001\000\006\140\001\000\006\136\001\000\006\140\002\000\006\140\003\000\006\140\004\000\007\136\001\000\007\132\001\000\007\128\001\000\007|\001\000\007x\001\000\007t\001\000\007\136\002\000\007\132\002\000\007\128\002\000\007|\002\000\007\136\003\000\007\132\003\000\007\128\003\000\007|\003\000\n\024\001\000\n\024\002\000\n\024\003\000\005|\001\000\005\136\001\000\005\128\001\000\005\136\002\000\005\128\002\000\005\136\003\000\005\128\003\000\005\156\001\000\000\228\001\000\n\024\004\000\004\136\001\000\004\136\002\000\012\004\001\000\012\000\001\000\001\244\001\000\001\244\002\000\001\244\003\000\002d\001\000\002d\002\000\002d\003\000\012\164\001\000\n \001\000\n\028\001\000\t\232\001\000\t\228\001\000\001\144\001\000\001p\001\000\n8\001\000\006\152\001\000\nt\001\000\np\001\000\012\168\001\000\002\248\001\000\002\248\002\000\004\252\001\000\004\252\002\000\004\252\003\000\bd\001\000\004\252\004\000\t\216\001\000\t\212\001\000\t\208\001\000\001l\001\000\001l\002\000\t\204\001\000\003\204\001\000\t\204\002\000\t\204\003\000\004\248\001\000\004\244\001\000\004\240\001\000\004\236\001\000\007@\001\000\001\228\001\000\001\224\001\000\007 \001\000\001\228\002\000\001\224\002\000\001\220\001\000\001\216\001\000\001\220\002\000\001\216\002\000\001\212\001\000\001\208\001\000\001\204\001\000\000h\001\000\005\152\001\000\005X\001\000\005P\001\000\005\152\002\000\005\152\003\000\005\152\001\000\005X\001\000\005\152\004\000\005X\002\000\005X\003\000\005\148\001\000\005X\002\000\005P\002\000\005P\003\000\001X\001\000\000h\002\000\001\208\002\000\0064\001\000\0064\002\000\000\\\001\000\003P\001\000\003D\001\000\003P\002\000\012@\001\000\t\028\001\000\t\028\002\000\001\184\001\000\005\152\001\000\005X\001\000\005P\001\000\000t\001\000\005X\002\000\005P\002\000\000t\002\000\001\200\001\000\001\196\001\000\003H\001\000\003H\002\000\003H\003\000\012X\001\000\003H\004\000\001\188\001\000\0024\001\000\001\192\001\000\000X\001\000\012<\001\000\t \001\000\000l\001\000\000`\001\000\t \002\000\t \003\000\000l\001\000\000`\001\000\000l\002\000\000l\003\000\000`\002\000\000D\001\000\001\196\002\000\001\180\001\000\001\196\003\000\001\180\002\000\001\176\001\000\000H\001\000\000H\002\000\000H\003\000\000H\004\000\000t\003\000\t\028\003\000\000l\001\000\000`\001\000\003P\003\000\t$\001\000\b\236\001\000\b\240\001\000\001\208\003\000\001\208\004\000\b\240\002\000\b\240\003\000\012\012\001\000\012\b\001\000\012\b\002\000\007\020\001\000\012\b\003\000\012\b\004\000\b\224\001\000\b\224\002\000\b\224\003\000\000H\001\000\012\b\005\000\b\220\001\000\000H\001\000\012\012\002\000\t(\001\000\001\180\001\000\t$\001\000\001\204\002\000\001\204\003\000\001\212\002\000\001\212\003\000\b\240\001\000\001\212\004\000\001\212\005\000\b\240\001\000\001\216\003\000\001\216\004\000\b\240\001\000\001\228\003\000\001\224\003\000\001\224\004\000\001\228\004\000\b\196\001\000\001\228\005\000\001\228\006\000\b\196\002\000\b\192\001\000\007@\002\000\001\180\001\000\004\248\002\000\004\244\002\000\004\240\002\000\004\236\002\000\007X\001\000\007\244\001\000\007\244\002\000\007\244\003\000\001\\\001\000\n\188\001\000\n\188\002\000\001h\001\000\001t\001\000\001`\001\000\n\144\001\000\012\172\001\000\n\148\001\000\007\244\004\000\n\156\001\000\n\176\001\000\n\172\001\000\n\176\002\000\n\176\003\000\t\184\001\000\n\184\001\000\n\204\001\000\n\200\001\000\n\196\001\000\n\192\001\000\005\136\001\000\001\140\001\000\001\136\001\000\n\204\002\000\n\200\002\000\n\196\002\000\n\192\002\000\005\136\002\000\001\140\002\000\n\204\003\000\n\200\003\000\001\140\003\000\n\200\004\000\007\208\001\000\007\208\002\000\007\208\003\000\007\228\001\000\007\192\001\000\007\212\001\000\007\200\001\000\007\212\002\000\007\216\001\000\007\212\003\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\216\002\000\007\216\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\184\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\003\000\007\184\001\000\007\204\002\000\007\216\001\000\007\204\003\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\196\002\000\007\196\003\000\007\188\002\000\n\184\001\000\007\240\001\000\007\240\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\n\212\001\000\n\180\001\000\007\236\001\000\007\232\001\000\012\164\001\000\n\208\001\000\n\164\001\000\n\160\001\000\n\152\001\000\007\236\002\000\001\144\001\000\001p\001\000\007\236\003\000\006<\001\000\0068\001\000\006<\002\000\007\236\004\000\007\236\005\000\007\236\006\000\n\180\001\000\001\148\001\000\t\192\001\000\t\188\001\000\006\228\001\000\001\144\002\000\001\144\003\000\n\208\002\000\n\152\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\n\152\003\000\n\208\003\000\n\208\004\000\001\180\001\000\n\208\005\000\007\232\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\216\001\000\007\208\004\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\001\140\004\000\001\140\005\000\n\204\004\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\n\204\005\000\n\196\003\000\t\208\001\000\n\196\004\000\t\208\002\000\t\208\003\000\tL\001\000\tH\001\000\tD\001\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\tL\002\000\tH\002\000\tL\003\000\n\192\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007X\002\000\004\248\003\000\004\244\003\000\004\240\003\000\004\236\003\000\004\248\004\000\004\244\004\000\004\240\004\000\004\244\005\000\007(\001\000\004\244\006\000\004\248\005\000\t\216\002\000\t\212\002\000\t\212\003\000\n\144\001\000\004\028\001\000\004\024\001\000\004\020\001\000\004\016\001\000\004\012\001\000\003\252\001\000\003\248\001\000\003\248\002\000\003\200\001\000\003\196\001\000\003\200\002\000\003\200\003\000\001\180\001\000\003\248\003\000\003\248\004\000\003\252\002\000\003\236\001\000\003\232\001\000\003\232\002\000\003\232\003\000\007`\001\000\002\240\001\000\n\144\001\000\004H\001\000\004D\001\000\003\244\001\000\003\240\001\000\b\020\001\000\003\240\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\004@\001\000\004<\001\000\004@\002\000\004@\003\000\001\180\001\000\003\240\003\000\003\240\004\000\003\240\005\000\b\016\001\000\003\244\002\000\012\164\001\000\n\208\001\000\n\164\001\000\n\160\001\000\n\152\001\000\003(\001\000\001\144\001\000\001p\001\000\003(\002\000\003(\003\000\003(\004\000\004\000\001\000\004\000\002\000\011\172\001\000\004(\001\000\002\\\001\000\002X\001\000\002T\001\000\002P\001\000\002\\\002\000\002X\002\000\002\\\003\000\002\\\004\000\002\\\005\000\005\184\001\000\005\184\002\000\003X\001\000\003T\001\000\003T\002\000\003X\002\000\003X\003\000\005\252\001\000\005\240\001\000\005\252\002\000\005\252\003\000\005\232\001\000\005\232\002\000\b\180\001\000\003\\\001\000\b\180\002\000\005\232\003\000\005\232\004\000\005\248\001\000\006\004\001\000\006\000\001\000\005\244\001\000\005\232\005\000\006\004\002\000\012\240\001\000\012\236\001\000\012\240\002\000\012\236\002\000\012\240\003\000\012\236\003\000\r\b\001\000\r\004\001\000\r\b\002\000\012\240\004\000\012\240\005\000\000H\001\000\012\236\004\000\012\236\005\000\000H\001\000\012\236\006\000\b\164\001\000\b\164\002\000\b\164\003\000\001\180\001\000\b\164\004\000\b\164\005\000\001\180\001\000\012d\001\000\r\000\001\000\012\252\001\000\012\248\001\000\012\244\001\000\r\000\002\000\012\252\002\000\r\000\003\000\012\252\003\000\012\252\004\000\012\252\005\000\006\004\001\000\006\000\001\000\005\244\001\000\006\000\002\000\006\004\001\000\006\000\003\000\006\000\001\000\005\244\001\000\005\244\002\000\005\152\001\000\005x\001\000\005X\001\000\005x\002\000\005X\002\000\005X\003\000\003\144\001\000\005x\003\000\006\020\001\000\005t\001\000\006\b\001\000\r\000\004\000\r\000\005\000\006\004\001\000\006\000\001\000\005\244\001\000\012\248\002\000\012\244\002\000\005\136\001\000\012\244\003\000\012\244\004\000\005\152\001\000\005X\001\000\005\136\002\000\012\248\003\000\012\248\004\000\005\152\001\000\005X\001\000\b\228\001\000\b\232\001\000\006\004\003\000\b\232\002\000\b\232\003\000\b\176\001\000\006\004\001\000\006\000\001\000\005\252\004\000\005\244\001\000\006\004\001\000\006\000\001\000\005\244\001\000\005\240\002\000\005\240\003\000\006\004\001\000\006\000\001\000\005\244\001\000\003X\004\000\003X\005\000\005\184\003\000\005\184\004\000\005\188\001\000\005\204\001\000\005\200\001\000\005\192\001\000\005\184\005\000\007\136\001\000\007\132\001\000\007\128\001\000\007|\001\000\007x\001\000\007t\001\000\005\204\002\000\005\204\003\000\007x\002\000\007t\002\000\005\204\001\000\005\200\001\000\005\192\001\000\007x\003\000\007t\003\000\007t\004\000\006\004\001\000\006\000\001\000\005\244\001\000\007t\005\000\005\200\002\000\005\192\002\000\005\196\001\000\005\136\001\000\005\208\001\000\005\204\001\000\005\200\001\000\005\192\001\000\002\\\006\000\002\\\007\000\n\128\001\000\001l\001\000\nD\001\000\n@\001\000\t@\001\000\t<\001\000\t8\001\000\007H\001\000\nh\001\000\012\168\001\000\005|\001\000\t\224\001\000\t\220\001\000\002\128\001\000\002\128\002\000\002\128\003\000\n\020\001\000\n\016\001\000\n\020\002\000\n\016\002\000\n\020\003\000\n\016\003\000\002p\001\000\002l\001\000\002p\002\000\002l\002\000\002p\003\000\002l\003\000\t`\001\000\002\024\001\000\t`\002\000\002\024\002\000\t`\003\000\002\024\003\000\b\212\001\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\005\016\001\000\005\012\001\000\005\b\001\000\005\012\002\000\002`\001\000\002`\002\000\002`\003\000\004\004\001\000\b\172\001\000\0030\001\000\003,\001\000\b\172\002\000\002`\004\000\0078\001\000\0078\002\000\000l\001\000\000`\001\000\002`\005\000\002`\006\000\002D\001\000\002\024\001\000\002D\002\000\002\024\002\000\002D\003\000\002\024\003\000\b\216\001\000\002D\004\000\002\024\004\000\b\216\002\000\b\216\003\000\b\208\001\000\002\016\001\000\002\012\001\000\002\016\002\000\002\012\002\000\002\016\003\000\002\012\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\002\016\004\000\002\012\004\000\002\016\005\000\002x\001\000\002x\002\000\002x\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\002x\004\000\002x\005\000\n<\001\000\n(\001\000\005\140\001\000\nX\001\000\nT\001\000\nH\001\000\n<\002\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\nX\002\000\nX\003\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\nT\002\000\nT\003\000\n\b\002\000\n\000\002\000\t\248\002\000\t\248\003\000\002\024\001\000\002\024\002\000\002\024\003\000\b\216\001\000\002\024\004\000\002|\001\000\002|\002\000\002|\003\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\002|\004\000\nH\002\000\n\012\002\000\n\004\002\000\t\252\002\000\t\244\002\000\t\240\002\000\t\236\002\000\t\236\003\000\002\228\001\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\003 \001\000\003\028\001\000\003\024\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\132\001\000\002L\001\000\003\220\001\000\003\216\001\000\003\220\002\000\003\220\003\000\012L\001\000\012L\002\000\001\180\001\000\012H\001\000\012D\001\000\012H\002\000\012D\002\000\001\180\001\000\012H\003\000\012H\004\000\001\180\001\000\003\220\004\000\003\220\005\000\003\216\002\000\003\224\001\000\003\224\002\000\003\228\001\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\003\228\002\000\n4\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n|\001\000\nx\001\000\nl\001\000\nd\001\000\nP\001\000\nL\001\000\005\144\001\000\005\136\001\000\001\140\001\000\001\136\001\000\n\140\002\000\n\136\002\000\n\132\002\000\n|\002\000\nx\002\000\nl\002\000\nd\002\000\nP\002\000\nL\002\000\005\144\002\000\005\136\002\000\001\140\002\000\012\164\001\000\n\140\003\000\nd\003\000\nL\003\000\001\140\003\000\nd\004\000\006\220\001\000\000@\001\000\006\216\001\000\000<\001\000\n\140\004\000\n\140\005\000\n\140\006\000\n\140\007\000\005\204\001\000\005\200\001\000\005\192\001\000\n\140\b\000\n\140\t\000\006\004\001\000\006\000\001\000\005\244\001\000\n\140\n\000\012\004\001\000\006\232\001\000\012\000\001\000\006\228\001\000\006\156\001\000\002\240\001\000\007\228\001\000\004L\001\000\004L\002\000\004L\003\000\001\180\001\000\004L\004\000\004L\005\000\t\020\001\000\002\136\001\000\t\020\002\000\n4\001\000\002\144\001\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\002\144\002\000\012\176\001\000\n\\\001\000\n0\001\000\n,\001\000\005\004\001\000\001\240\001\000\001\240\002\000\001\240\003\000\005\000\001\000\004,\001\000\002\236\001\000\002\236\002\000\002\236\003\000\t\\\001\000\003@\001\000\003<\001\000\0038\001\000\0034\001\000\003$\001\000\002\244\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\020\001\000\002\188\002\000\003$\001\000\002\244\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\020\001\000\002\176\002\000\t\024\001\000\002\176\003\000\t\024\002\000\t\024\003\000\t\024\001\000\n0\001\000\002\140\001\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\002\140\002\000\002\232\001\000\t\024\001\000\002\232\002\000\002\172\002\000\t\024\001\000\002\172\003\000\002\168\002\000\t\024\001\000\002\168\003\000\002\192\002\000\t\024\001\000\002\192\003\000\002\208\002\000\t\024\001\000\002\208\003\000\002\184\002\000\t\024\001\000\002\184\003\000\002\180\002\000\t\024\001\000\002\180\003\000\002\200\002\000\t\024\001\000\002\200\003\000\002\164\002\000\t\024\001\000\002\164\003\000\002\160\002\000\t\024\001\000\002\160\003\000\002\156\002\000\t\024\001\000\002\156\003\000\002\152\002\000\t\024\001\000\002\152\003\000\002\148\002\000\t\024\001\000\002\148\003\000\002\204\002\000\t\024\001\000\002\204\003\000\002\196\002\000\t\024\001\000\002\196\003\000\002\224\002\000\t\024\001\000\002\224\003\000\002\244\002\000\t\024\001\000\002\244\003\000\002\212\002\000\t\024\001\000\002\212\003\000\002\216\002\000\t\024\001\000\002\216\003\000\002\220\002\000\t\024\001\000\002\220\003\000\003$\002\000\t\024\001\000\002\188\003\000\003@\002\000\003<\002\000\0038\002\000\003@\003\000\003@\004\000\003@\005\000\t\024\001\000\003<\003\000\000L\001\000\000L\002\000\n\148\001\000\004$\001\000\004$\002\000\004$\003\000\001\180\001\000\004$\004\000\004$\005\000\b\012\001\000\b\004\001\000\007\252\001\000\007\248\001\000\007\224\001\000\004 \001\000\004 \002\000\004 \003\000\007\224\002\000\007\224\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\248\002\000\007\248\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\b\012\002\000\b\012\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\b\004\002\000\b\004\003\000\007\252\002\000\b\000\001\000\b\b\001\000\007\220\001\000\007\220\002\000\007\220\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\004\b\001\000\000L\003\000\b<\001\000\b<\002\000\b(\001\000\b$\001\000\b(\002\000\b$\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\b(\003\000\b(\004\000\011\232\001\000\011\228\001\000\006\012\001\000\006\012\002\000\006\012\003\000\006\012\004\000\006\012\005\000\007P\001\000\007P\002\000\006\004\001\000\006\000\001\000\005\244\001\000\006\012\006\000\004\160\001\000\004\160\002\000\006\012\007\000\011\232\002\000\011\228\002\000\011\232\003\000\011\228\003\000\011\232\004\000\011\232\005\000\005\160\001\000\005\204\001\000\005\200\001\000\005\192\001\000\005\160\002\000\005\164\001\000\006\004\001\000\006\000\001\000\005\244\001\000\005\164\002\000\005\164\003\000\005\204\001\000\005\200\001\000\005\192\001\000\005\164\004\000\011\232\006\000\011\232\007\000\004x\001\000\004x\002\000\004x\003\000\004x\004\000\004x\005\000\004x\006\000\005\168\001\000\005\168\002\000\011\232\b\000\011\228\004\000\011\228\005\000\011\228\006\000\003\168\001\000\003\168\002\000\0028\001\000\0028\002\000\011\252\001\000\011\252\002\000\011\252\003\000\011\252\004\000\005\204\001\000\005\200\001\000\005\192\001\000\011\252\005\000\b@\001\000\b@\002\000\b@\003\000\b@\004\000\b@\005\000\b\204\001\000\b0\001\000\b\204\002\000\b\204\003\000\b0\002\000\b0\003\000\001\180\001\000\b@\006\000\b@\007\000\006D\001\000\006@\001\000\006D\002\000\b@\b\000\b@\t\000\b,\001\000\001\180\001\000\011\168\001\000\td\001\000\011\168\002\000\td\002\000\011\168\003\000\td\003\000\001|\001\000\001\128\001\000\001p\001\000\001\128\002\000\001\128\003\000\001l\001\000\011\168\004\000\td\004\000\003d\001\000\001\164\001\000\006\028\001\000\003\180\001\000\003\176\001\000\003\180\002\000\003\176\002\000\003\180\003\000\003\176\003\000\b\204\001\000\b8\001\000\b8\002\000\b8\003\000\000H\001\000\003\180\004\000\003\176\004\000\003\180\005\000\003\176\005\000\003\180\006\000\003\180\007\000\b4\001\000\000H\001\000\001\164\002\000\001\164\003\000\003\192\001\000\003\188\001\000\003\192\002\000\003\184\001\000\t\b\001\000\001\160\001\000\t\b\002\000\001\160\002\000\t\b\003\000\001\160\003\000\000l\001\000\000`\001\000\003d\002\000\t\004\001\000\001\156\001\000\000l\001\000\000`\001\000\011\168\005\000\001\144\001\000\001p\001\000\005\136\001\000\001\140\001\000\001\136\001\000\005\136\002\000\001\140\002\000\001\140\003\000\011\168\006\000\011\168\007\000\011\168\b\000\003t\001\000\003p\001\000\003l\001\000\003h\001\000\b\204\001\000\003t\002\000\003l\002\000\003t\003\000\003l\003\000\003l\004\000\003l\005\000\003l\006\000\000l\001\000\000`\001\000\t\004\001\000\003t\004\000\001\156\001\000\000l\001\000\000`\001\000\003h\002\000\003h\003\000\003h\004\000\000l\001\000\000`\001\000\t\004\001\000\003p\002\000\001\156\001\000\000l\001\000\000`\001\000\td\005\000\td\006\000\td\007\000\001\132\001\000\b \001\000\b\028\001\000\t\136\001\000\t\132\001\000\003\140\001\000\003\136\001\000\003\132\001\000\003\128\001\000\t\136\002\000\t\132\002\000\003\140\002\000\003\136\002\000\003\132\002\000\003\128\002\000\t\136\003\000\t\132\003\000\003\140\003\000\003\136\003\000\003\132\003\000\003\128\003\000\t\136\004\000\003\140\004\000\003\132\004\000\t\136\005\000\003\140\005\000\003\132\005\000\005L\001\000\003\140\006\000\003\132\006\000\003\132\007\000\001\212\001\000\001\208\001\000\001\204\001\000\001l\001\000\006p\001\000\006p\002\000\006p\003\000\006`\001\000\003x\001\000\001\168\001\000\003x\002\000\003x\003\000\003x\004\000\bx\001\000\001\172\001\000\003x\001\000\bx\002\000\003\132\b\000\b\164\001\000\003\132\t\000\003\132\n\000\bp\001\000\bt\001\000\006|\001\000\006x\001\000\006l\001\000\006h\001\000\006\\\001\000\006X\001\000\006H\001\000\001\180\001\000\006|\002\000\006x\002\000\006l\002\000\006h\002\000\006\\\002\000\006X\002\000\006|\003\000\006l\003\000\006\\\003\000\006|\004\000\006|\005\000\006|\006\000\006l\004\000\006\\\004\000\003|\001\000\003|\002\000\003|\003\000\006x\003\000\006x\004\000\006x\005\000\006h\003\000\006X\003\000\006P\001\000\003\140\007\000\b\164\001\000\003\140\b\000\003\140\t\000\t\136\006\000\t\136\007\000\bH\001\000\t\136\b\000\t\136\t\000\b\156\001\000\t\136\n\000\b\156\002\000\b\148\001\000\b\152\001\000\t\132\004\000\003\136\004\000\003\128\004\000\005L\001\000\003\136\005\000\003\128\005\000\003\128\006\000\003\128\007\000\b\164\001\000\003\128\b\000\003\128\t\000\003\136\006\000\b\164\001\000\003\136\007\000\003\136\b\000\t\132\005\000\t\132\006\000\t\132\007\000\t\132\b\000\b\156\001\000\t\132\t\000\004\168\001\000\006\148\001\000\006\144\001\000\006\148\002\000\006\148\003\000\006\148\004\000\006\148\005\000\005\152\001\000\005X\001\000\006\148\006\000\006\144\002\000\006\144\003\000\006\144\004\000\005\152\001\000\005X\001\000\006\144\005\000\t\156\001\000\t\148\001\000\t\144\001\000\006\016\001\000\006\012\001\000\005\224\001\000\006\016\002\000\006\012\002\000\006\016\003\000\006\012\003\000\006\016\004\000\006\012\004\000\006\016\005\000\006\012\005\000\006\016\006\000\006\016\007\000\006\004\001\000\006\000\001\000\005\244\001\000\006\016\b\000\t\156\002\000\t\148\002\000\t\144\002\000\005\224\002\000\t\156\003\000\t\148\003\000\t\144\003\000\005\224\003\000\005\224\004\000\005\216\001\000\005\224\005\000\005\224\006\000\005\152\001\000\005X\001\000\005\224\007\000\t\156\004\000\t\156\005\000\t\156\006\000\t\156\007\000\006\004\001\000\006\000\001\000\005\244\001\000\t\156\b\000\004\128\001\000\004\128\002\000\004\128\003\000\004\128\004\000\006\004\001\000\006\000\001\000\005\244\001\000\004\128\005\000\004\128\006\000\004\128\007\000\t\156\t\000\t\148\004\000\t\144\004\000\t\148\005\000\t\148\006\000\005\136\001\000\t\148\007\000\005\172\001\000\006\004\001\000\006\000\001\000\005\244\001\000\005\172\002\000\t\144\005\000\t\144\006\000\005\176\001\000\005\176\002\000\t\172\001\000\t\172\002\000\t\172\003\000\t\172\004\000\006\004\001\000\006\000\001\000\005\244\001\000\t\172\005\000\td\001\000\td\002\000\td\003\000\td\004\000\t\176\001\000\001T\001\000\001T\002\000\001T\003\000\001T\004\000\012\208\001\000\001T\005\000\002@\001\000\t\000\001\000\002@\002\000\002@\003\000\001T\006\000\001T\007\000\001T\b\000\001 \001\000\001 \002\000\000\244\001\000\001\180\001\000\000\244\002\000\000\244\003\000\001 \003\000\001\000\001\000\001\000\002\000\0060\001\000\006(\001\000\0060\002\000\006,\001\000\006$\001\000\006,\002\000\001\000\003\000\001\000\004\000\001\000\005\000\001\180\001\000\001\000\006\000\001\000\007\000\001\004\001\000\001\004\002\000\b\\\001\000\bT\001\000\b\\\002\000\bX\001\000\bP\001\000\bX\002\000\001\004\003\000\001\004\004\000\001\004\005\000\001\004\006\000\001\004\007\000\000\252\001\000\000\252\002\000\001,\001\000\001(\001\000\001,\002\000\001(\002\000\001,\003\000\001,\004\000\005\136\001\000\001,\005\000\001,\006\000\001\024\001\000\b\248\001\000\001\024\002\000\001\024\003\000\001\024\004\000\b\248\002\000\b\248\003\000\001\180\001\000\b\244\001\000\001\180\001\000\001\028\001\000\001\020\001\000\001,\007\000\001$\001\000\001$\002\000\001(\003\000\005\136\001\000\001(\004\000\001(\005\000\001(\006\000\001$\001\000\001$\001\000\000\252\003\000\000\252\004\000\001\b\001\000\001\b\002\000\001\180\001\000\001\152\001\000\001\152\002\000\001\180\001\000\001\152\003\000\001\b\003\000\001\b\004\000\001 \004\000\001 \005\000\001\012\001\000\001\012\002\000\001\016\001\000\004\196\001\000\004\196\002\000\001T\t\000\001$\001\000\001T\n\000\004p\001\000\004p\002\000\004p\003\000\004p\004\000\004p\005\000\004p\006\000\004p\007\000\001$\001\000\004p\b\000\004p\t\000\001T\011\000\t\176\002\000\t\176\003\000\t\176\004\000\t\176\005\000\t\176\006\000\t\176\007\000\005L\001\000\001L\001\000\001L\002\000\001L\003\000\001L\004\000\001\212\001\000\001\208\001\000\001\204\001\000\001\024\001\000\t(\001\000\b\244\001\000\001\180\001\000\001P\001\000\001P\002\000\001H\001\000\001H\002\000\001H\003\000\012X\001\000\001X\001\000\0024\001\000\001\028\001\000\001H\004\000\001D\001\000\001$\001\000\001P\003\000\001L\005\000\t\176\b\000\t\176\t\000\004h\001\000\004h\002\000\004h\003\000\004h\004\000\004h\005\000\004h\006\000\004h\007\000\004h\b\000\004h\t\000\t\176\n\000\tt\001\000\004\172\001\000\t\140\001\000\tx\001\000\t\168\001\000\t\164\001\000\t\160\001\000\t\152\001\000\004\172\002\000\tl\001\000\tl\002\000\t|\001\000\004\144\001\000\004\144\002\000\004\144\003\000\004\144\004\000\004\144\005\000\b\164\001\000\004\144\006\000\004\144\007\000\004\144\b\000\t|\002\000\t\128\001\000\004\152\001\000\004\152\002\000\004\152\003\000\004\152\004\000\004\152\005\000\004\152\006\000\b\164\001\000\004\152\007\000\004\152\b\000\004\152\t\000\t\128\002\000\tp\001\000\t\180\001\000\004\168\002\000\b\028\002\000\th\001\000\b \002\000\001\180\001\000\011\244\001\000\001T\001\000\011\244\002\000\011\244\003\000\011\244\004\000\011\244\005\000\011\244\006\000\000\208\001\000\001@\001\000\001@\002\000\001@\003\000\000\184\001\000\012\196\001\000\012\188\001\000\012\196\002\000\012\188\002\000\012\196\003\000\012\188\003\000\012\196\004\000\012\188\004\000\012\188\005\000\012\188\006\000\012\196\005\000\012\196\006\000\012\196\007\000\000\184\002\000\000\184\003\000\012\192\001\000\012\184\001\000\012\180\001\000\012\220\001\000\012\212\001\000\012\220\002\000\012\216\001\000\006\028\001\000\012\216\002\000\012\180\002\000\012\180\003\000\012\180\004\000\012\180\005\000\001\180\001\000\012\192\002\000\012\184\002\000\012\192\003\000\012\184\003\000\012\184\004\000\012\184\005\000\012\192\004\000\012\192\005\000\012\192\006\000\000\188\001\000\005H\001\000\005@\001\000\0058\001\000\005H\002\000\005@\002\000\0058\002\000\005H\003\000\005@\003\000\0058\003\000\005H\004\000\005@\004\000\0058\004\000\005H\005\000\005@\005\000\005H\006\000\005H\007\000\005H\b\000\005H\t\000\001\180\001\000\005H\n\000\005H\011\000\005@\006\000\005@\007\000\005@\b\000\0058\005\000\011\176\001\000\007h\001\000\011\176\002\000\011\176\003\000\002H\001\000\011\176\004\000\b\168\001\000\000\188\002\000\000\188\003\000\005D\001\000\005<\001\000\0054\001\000\0050\001\000\012\232\001\000\012\224\001\000\012\232\002\000\012\228\001\000\bH\001\000\012\228\002\000\0050\002\000\0050\003\000\0050\004\000\0050\005\000\005D\002\000\005<\002\000\0054\002\000\005D\003\000\005<\003\000\0054\003\000\005D\004\000\005<\004\000\005D\005\000\005D\006\000\005D\007\000\005D\b\000\001\180\001\000\005D\t\000\005D\n\000\005<\005\000\005<\006\000\005<\007\000\0054\004\000\000\196\001\000\000\196\002\000\000\196\003\000\000\196\004\000\000\180\001\000\000\176\001\000\000\180\002\000\000\180\003\000\001<\001\000\0010\001\000\0044\001\000\0040\001\000\000\160\001\000\000\156\001\000\0044\002\000\0044\003\000\0044\004\000\0044\005\000\0044\006\000\0044\007\000\000\160\002\000\000\156\002\000\000\160\003\000\000\160\004\000\005\136\001\000\000\160\005\000\000\160\006\000\0018\001\000\b\248\001\000\0018\002\000\0018\003\000\0018\004\000\000\148\001\000\000\148\002\000\000\224\001\000\000\220\001\000\000\220\002\000\0048\001\000\000\152\001\000\000\152\002\000\000\172\001\000\000\168\001\000\000\144\001\000\003\212\001\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\003\212\002\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\003\208\001\000\b\188\001\000\000\168\002\000\b\188\002\000\b\184\001\000\0014\001\000\000\164\001\000\000\152\003\000\000\164\002\000\0048\002\000\000\220\003\000\000\164\001\000\000\224\002\000\000\148\003\000\000\164\001\000\000\160\007\000\000\156\003\000\005\136\001\000\000\156\004\000\000\156\005\000\000\164\001\000\000\156\006\000\0040\002\000\0040\003\000\0040\004\000\0040\005\000\001<\002\000\0010\002\000\000\164\001\000\0010\003\000\001<\003\000\001<\004\000\001<\005\000\000\180\004\000\000\164\001\000\0070\001\000\0070\002\000\000\180\005\000\000\180\006\000\000\176\002\000\000\176\003\000\000\164\001\000\000\176\004\000\000\176\005\000\000\192\001\000\000\192\002\000\000\192\003\000\000\192\004\000\001@\004\000\001@\005\000\000\200\001\000\000\200\002\000\000\204\001\000\004\204\001\000\004\204\002\000\000\208\002\000\000\164\001\000\000\212\001\000\000\212\002\000\000\212\003\000\000\212\004\000\000\164\001\000\000\216\001\000\000\216\002\000\011\244\007\000\011\244\b\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\011\244\t\000\011\208\001\000\004\188\001\000\004(\001\000\004(\002\000\004(\003\000\004(\004\000\004(\005\000\004(\006\000\011\224\001\000\011\164\001\000\011\204\001\000\011\240\001\000\011\236\001\000\011\188\001\000\005\004\001\000\005\004\002\000\004\188\002\000\011\192\001\000\004,\001\000\004,\002\000\011\196\001\000\011\196\002\000\011\212\001\000\011\212\002\000\011\200\001\000\011\248\001\000\b\024\001\000\011\184\001\000\011\184\002\000\011\184\003\000\000\136\001\000\011\188\001\000\005\004\001\000\001\240\001\000\011\180\001\000\011\192\001\000\004,\001\000\002\236\001\000\0028\003\000\0028\004\000\003\168\003\000\003\168\004\000\b<\003\000\b<\004\000\000L\004\000\t\024\001\000\t\020\003\000\b\012\001\000\b\004\001\000\007\252\001\000\007\248\001\000\007\224\001\000\004P\001\000\004P\002\000\004P\003\000\004X\001\000\002\240\002\000\002\240\003\000\002\240\004\000\004X\002\000\004X\003\000\004T\001\000\n<\001\000\006\192\001\000\nL\004\000\nL\005\000\n|\003\000\nx\003\000\n|\004\000\nx\004\000\nx\005\000\t4\001\000\t0\001\000\t,\001\000\t\024\001\000\t4\002\000\t0\002\000\t4\003\000\n\136\003\000\n\132\003\000\n\136\004\000\n\132\004\000\n\132\005\000\nP\003\000\nP\004\000\nP\005\000\nl\003\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\bl\001\000\bl\002\000\bl\003\000\tX\001\000\tT\001\000\tP\001\000\tX\002\000\tT\002\000\tP\002\000\tX\003\000\tT\003\000\tP\003\000\tX\004\000\tT\004\000\tX\005\000\bh\001\000\nl\004\000\nl\005\000\n\140\001\000\n\136\001\000\n\132\001\000\n|\001\000\nx\001\000\nl\001\000\nd\001\000\nP\001\000\nL\001\000\005\144\001\000\005\136\001\000\005\128\001\000\001\140\001\000\001\136\001\000\n\140\002\000\n\136\002\000\n\132\002\000\n|\002\000\nx\002\000\nl\002\000\nd\002\000\nP\002\000\nL\002\000\005\144\002\000\005\136\002\000\005\128\002\000\001\140\002\000\012\168\001\000\005\128\003\000\005\144\003\000\n\b\002\000\n\000\002\000\t\248\002\000\003\028\002\000\003\020\002\000\003\012\002\000\t\248\003\000\003\012\003\000\t\248\004\000\003\012\004\000\t\248\005\000\003\012\005\000\003\012\006\000\t\024\001\000\003\012\007\000\n\b\003\000\003\028\003\000\n\b\004\000\003\028\004\000\n\b\005\000\003\028\005\000\003\028\006\000\t\024\001\000\003\028\007\000\n\000\003\000\003\020\003\000\n\000\004\000\003\020\004\000\n\000\005\000\003\020\005\000\003\020\006\000\t\024\001\000\003\020\007\000\nH\002\000\n\012\002\000\n\004\002\000\t\252\002\000\t\244\002\000\t\240\002\000\t\236\002\000\003 \002\000\003\024\002\000\003\016\002\000\003\b\002\000\003\004\002\000\003\000\002\000\002\252\002\000\t\236\003\000\003\000\003\000\t\236\004\000\003\000\004\000\t\236\005\000\003\000\005\000\003\000\006\000\t\024\001\000\003\000\007\000\t\244\003\000\003\b\003\000\t\244\004\000\003\b\004\000\t\244\005\000\003\b\005\000\003\b\006\000\t\024\001\000\003\b\007\000\t\240\003\000\003\004\003\000\t\240\004\000\003\004\004\000\t\240\005\000\003\004\005\000\003\004\006\000\t\024\001\000\003\004\007\000\n\012\003\000\n\004\003\000\t\252\003\000\005\136\001\000\005\128\001\000\003 \003\000\003\024\003\000\003\016\003\000\n\012\004\000\n\004\004\000\t\252\004\000\003 \004\000\003\024\004\000\003\016\004\000\t\252\005\000\003\016\005\000\t\252\006\000\003\016\006\000\t\252\007\000\003\016\007\000\003\016\b\000\t\024\001\000\003\016\t\000\n\012\005\000\003 \005\000\n\012\006\000\003 \006\000\n\012\007\000\003 \007\000\003 \b\000\t\024\001\000\003 \t\000\n\004\005\000\003\024\005\000\n\004\006\000\003\024\006\000\n\004\007\000\003\024\007\000\003\024\b\000\t\024\001\000\003\024\t\000\nH\003\000\002\252\003\000\002\252\004\000\t\024\001\000\002\252\005\000\b\188\001\000\002\132\002\000\t\024\001\000\002\228\002\000\t\236\004\000\t\236\005\000\t\244\003\000\t\244\004\000\t\244\005\000\t\240\003\000\t\240\004\000\t\240\005\000\n\012\003\000\n\004\003\000\t\252\003\000\005\136\001\000\005\128\001\000\n\012\004\000\n\004\004\000\t\252\004\000\t\252\005\000\t\252\006\000\t\252\007\000\n\012\005\000\n\012\006\000\n\012\007\000\n\004\005\000\n\004\006\000\n\004\007\000\nH\003\000\t\248\004\000\t\248\005\000\n\b\003\000\n\b\004\000\n\b\005\000\n\000\003\000\n\000\004\000\n\000\005\000\002x\006\000\001\232\001\000\001\236\001\000\002x\007\000\002x\b\000\002x\t\000\002x\n\000\002x\011\000\002\016\006\000\002\016\007\000\002\016\b\000\002\016\t\000\002\012\005\000\002\012\006\000\002\012\007\000\002\012\b\000\002\012\t\000\002\012\n\000\002\012\011\000\002`\007\000\005\012\003\000\005\012\004\000\005\012\005\000\005\016\002\000\005\b\002\000\005\016\003\000\005\b\003\000\b\212\002\000\t`\004\000\b\216\001\000\002\024\004\000\002p\004\000\002l\004\000\002p\005\000\002l\005\000\t\024\001\000\002p\006\000\002l\006\000\002l\007\000\t\024\001\000\002l\b\000\n\020\004\000\n\016\004\000\n\016\005\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\002\128\004\000\t\220\002\000\t\024\001\000\t\220\003\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\t\224\002\000\nh\002\000\nh\003\000\t\024\001\000\007H\002\000\t@\002\000\t<\002\000\t8\002\000\t@\003\000\t<\003\000\t@\004\000\nD\002\000\n@\002\000\n@\003\000\n\128\002\000\n\128\003\000\002\\\b\000\002X\003\000\002X\004\000\005\204\001\000\005\200\001\000\005\192\001\000\002X\005\000\002X\006\000\002X\007\000\002P\002\000\002P\003\000\002P\004\000\002P\005\000\002P\006\000\002P\007\000\002P\b\000\002T\002\000\002T\003\000\002T\004\000\002T\005\000\002T\006\000\002T\007\000\002T\b\000\002T\t\000\011\172\002\000\004D\002\000\007`\002\000\003\232\004\000\003\232\005\000\003\236\002\000\012H\001\000\012D\001\000\004\028\002\000\004\024\002\000\004\028\003\000\004\028\004\000\004\028\005\000\004\028\006\000\001\180\001\000\004\028\007\000\004\028\b\000\b\204\001\000\004\024\003\000\004\024\004\000\004\024\005\000\001\180\001\000\004\024\006\000\004\024\007\000\004\020\002\000\004\020\003\000\004\020\004\000\004\016\002\000\004\252\005\000\004\252\006\000\t\024\001\000\002\248\003\000\nt\002\000\np\002\000\np\003\000\nX\001\000\nT\001\000\nH\001\000\n8\002\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\n \002\000\n\028\002\000\n \003\000\n\028\003\000\n \004\000\n\028\004\000\n \005\000\n\028\005\000\005\204\001\000\005\200\001\000\005\192\001\000\n\028\006\000\n \006\000\n \007\000\006\004\001\000\006\000\001\000\005\244\001\000\n \b\000\t\232\002\000\t\228\002\000\t\228\003\000\t\232\003\000\t\232\004\000\002d\004\000\002d\005\000\b\216\001\000\002d\006\000\001\244\004\000\001\244\005\000\b\216\001\000\001\244\006\000\t\024\001\000\007\136\004\000\007\132\004\000\007\128\004\000\007|\004\000\007|\005\000\007\136\005\000\007\136\006\000\006\004\001\000\006\000\001\000\005\244\001\000\007\136\007\000\007\132\005\000\007\128\005\000\007\132\006\000\007\128\006\000\006\004\001\000\006\000\001\000\005\244\001\000\007\128\007\000\007\132\007\000\007\132\b\000\006\004\001\000\006\000\001\000\005\244\001\000\007\132\t\000\006\140\005\000\005\204\001\000\005\200\001\000\005\192\001\000\006\140\006\000\006\136\002\000\006\136\003\000\006\136\004\000\005\204\001\000\005\200\001\000\005\192\001\000\006\136\005\000\004\184\002\000\004\184\003\000\004\184\004\000\004\180\002\000\002$\003\000\002$\004\000\005$\003\000\005\028\003\000\005\020\003\000\005$\004\000\005\028\004\000\005\020\004\000\005\028\005\000\005\020\005\000\005\028\006\000\005\020\006\000\005,\001\000\005\020\007\000\005(\001\000\005 \001\000\005\024\001\000\000l\001\000\000`\001\000\005 \002\000\005\024\002\000\005\024\003\000\006\132\002\000\006\128\002\000\006\128\003\000\003L\003\000\003L\004\000\003L\005\000\t\012\001\000\000p\002\000\000d\002\000\000p\003\000\000d\003\000\000p\004\000\000p\005\000\000d\004\000\t\012\002\000\t\012\003\000\001\180\001\000\t\016\001\000\001\196\002\000\001\180\001\000\t\016\002\000\t\016\003\000\001\180\001\000\006t\002\000\006t\003\000\006t\004\000\006d\002\000\006L\002\000\001\180\001\000\006T\002\000\012T\002\000\011\220\006\000\011\220\007\000\011\220\b\000\003x\001\000\002,\001\000\003x\002\000\002,\002\000\002,\003\000\002,\004\000\002,\005\000\011\220\t\000\b\144\001\000\b\140\001\000\011\220\n\000\b\140\002\000\b\144\002\000\b|\001\000\b\132\001\000\b\128\001\000\b\136\001\000\003|\001\000\0020\001\000\0020\002\000\0020\003\000\0020\004\000\011\216\004\000\003\136\004\000\005L\001\000\003\136\005\000\011\216\005\000\011\216\006\000\011\216\007\000\011\216\b\000\b\144\001\000\b\140\001\000\011\216\t\000\005\180\003\000\005\180\004\000\005\236\005\000\005\204\001\000\005\200\001\000\005\192\001\000\006\004\001\000\006\000\001\000\005\244\001\000\001\200\005\000\001\200\006\000\012\200\006\000\012\200\007\000\005\228\003\000\005\228\004\000\n\164\007\000\006\004\001\000\006\000\001\000\005\244\001\000\n\164\b\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\000\236\002\000\000\232\002\000\000\232\003\000\000\236\003\000\001\180\001\000\000\236\004\000\000\236\005\000\n$\004\000\n$\005\000\n$\006\000\002h\004\000\002h\005\000\b\216\001\000\002h\006\000\002\004\004\000\002\000\004\000\001\252\004\000\001\248\004\000\002\004\005\000\001\252\005\000\b\216\001\000\002\004\006\000\001\252\006\000\002\004\007\000\002\004\b\000\002\000\005\000\002\000\006\000\002t\004\000\002t\005\000\002t\006\000\002t\007\000\000\140\003\000\000\140\004\000\002\b\003\000\002\b\004\000\002\b\005\000\002\b\006\000\002\b\007\000\003\152\001\000\003\152\002\000\000\000\001\000\000\004\000\000\003\164\001\000\003\164\002\000\000\004\001\000\000\b\000\000\012\164\001\000\005`\001\000\001p\001\000\005`\002\000\005`\003\000\005d\001\000\000\b\001\000\005\152\001\000\005p\001\000\005l\001\000\005h\001\000\005X\001\000\005p\002\000\005l\002\000\005h\002\000\005X\002\000\012\164\001\000\005l\003\000\005l\004\000\005l\005\000\005p\003\000\005h\003\000\000P\001\000\005\\\001\000\000T\001\000\007\140\001\000\007\140\002\000\000\012\000\000\000\012\001\000\007\144\001\000\007\144\002\000\000\016\000\000\000\016\001\000\007\148\001\000\001\180\001\000\007\148\002\000\000\020\000\000\007\152\001\000\007\152\002\000\000\020\001\000\000\024\000\000\000\024\001\000\007\156\001\000\005\152\001\000\005X\001\000\007\156\002\000\000\028\000\000\000\028\001\000\007\160\001\000\005\136\001\000\007\160\002\000\000 \000\000\000 \001\000\007\164\001\000\005\204\001\000\005\200\001\000\005\192\001\000\007\164\002\000\000$\000\000\000$\001\000\007\168\001\000\006\004\001\000\006\000\001\000\005\244\001\000\007\168\002\000\000(\000\000\000(\001\000\007\172\001\000\007\172\002\000\000,\000\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\176\001\000\007\176\002\000\000,\001\000\0000\000\000\007\180\001\000\007\180\002\000\0000\001\000\005\144\001\000\005\136\001\000\005\144\002\000\005\136\002\000\0004\000\000\012(\001\000\012$\001\000\012 \001\000\012\028\001\000\012\024\001\000\012\020\001\000\012\016\001\000\012(\002\000\012$\002\000\012 \002\000\012\028\002\000\012\024\002\000\012\020\002\000\012\016\002\000\012(\003\000\012\020\003\000\012\024\003\000\012$\003\000\012\028\003\000\012 \003\000\005\144\001\000\005\136\001\000\0128\001\000\0004\001\000\0124\001\000\0124\002\000\004\212\001\000\004\212\002\000\012,\001\000\012,\002\000\012,\003\000\0120\001\000\0120\002\000\0008\000\000\004\224\001\000\004\220\001\000\004\232\001\000\004\228\001\000\004\228\002\000\004\232\002\000\004\224\002\000\004\224\003\000\004\224\004\000\004\220\002\000\0008\001\000\012\160\001\000\012\160\002\000\012\160\003\000\012\160\004\000\012\156\001\000\012\156\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\000[\000\\\000^\000_\000`\000b\000c\000d\000k\000l\000m\000n\000o\000p\000s\000t\000u\000w\000y\000{\000|\000}\000\127\000\128\000\129\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\156\000\158\000\159\000\160\000\162\000\164\000\165\000\167\000\169\000\171\000\172\000\174\000\176\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\194\000\195\000\196\000\198\000\199\000\200\000\201\000\202\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\222\000\226\000\230\000\231\000\233\000\234\000\236\000\238\000\239\000\240\000\241\000\244\000\245\000\246\000\247\000\248\000\249\000\250\000\251\000\252\000\254\000\255\001\000\001\001\001\003\001\005\001\006\001\b\001\012\001\018\001\020\001\021\001\022\001\024\001\028\001\031\001 \001!\001#\001$\001%\001&\001(\001)\001*\001+\0011\0015\0019\001:\001;\001<\001=\001?\001A\001B\001C\001D\001E\001F\001G\001H\001I\001J\001K\001L\001M\001N\001O\001P\001W\001Y\001[\001]\001^\001_\001`\001a\001b\001c\001e\001g\001h\001i\001j\001k\001l\001p\001q\001s\001t\001v\001x\001y\001z\001}\001~\001\129\001\130\001\133\001\134\001\135\001\136\001\137\001\139\001\140\001\141\001\142\001\143\001\144\001\145\001\146\001\148\001\149\001\151\001\152\001\153\001\157\001\160\001\162\001\163\001\164\001\165\001\166\001\167\001\168\001\169\001\170\001\171\001\175\001\176\001\179\001\180\001\181\001\182\001\183\001\185\001\186\001\187\001\189\001\190\001\191\001\192\001\193\001\196\001\197\001\198\001\199\001\201\001\202\001\203\001\204\001\206\001\207\001\208\001\209\001\211\001\212\001\214\001\215\001\217\001\218\001\220\001\222\001\223\001\224\001\225\001\227\001\228\001\230\001\231\001\234\001\235\001\236\001\238\001\239\001\240\001\241\001\243\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\b\002\t\002\n\002\011\002\012\002\019\002\025\002\028\002\029\002\030\002\031\002 \002!\002\"\002$\002%\002+\002,\0022\0023\0029\002:\002@\002A\002B\002C\002E\002K\002L\002O\002W\002X\002Z\002[\002\\\002]\002^\002_\002`\002c\002d\002e\002l\002m\002n\002p\002q\002w\002}\002~\002\127\002\133\002\134\002\136\002\137\002\138\002\139\002\147\002\149\002\150\002\151\002\157\002\161\002\164\002\165\002\166\002\167\002\168\002\169\002\170\002\171\002\177\002\179\002\180\002\182\002\183\002\185\002\186\002\187\002\188\002\190\002\191\002\192\002\193\002\194\002\197\002\199\002\200\002\201\002\208\002\209\002\211\002\212\002\213\002\214\002\215\002\216\002\224\002\225\002\226\002\227\002\228\002\229\002\230\002\235\002\237\002\238\002\239\002\240\002\241\002\242\002\244\002\245\002\246\002\247\002\249\002\250\002\251\002\252\002\253\002\255\003\000\003\001\003\002\003\003\003\007\003\b\003\n\003\012\003\014\003\016\003\017\003\018\003\020\003\021\003\023\003\025\003\026\003\028\003\029\003\031\003 \003$\003&\003(\003)\003-\003.\0032\0033\0036\0038\003:\003;\003<\003=\003>\003?\003C\003F\003G\003J\003K\003L\003O\003P\003R\003S\003T\003U\003Y\003]\003^\003b\003c\003d\003e\003f\003j\003q\003r\003w\003x\003y\003}\003~\003\127\003\128\003\130\003\131\003\135\003\136\003\138\003\140\003\143\003\144\003\145\003\147\003\148\003\149\003\150\003\151\003\152\003\154\003\156\003\158\003\160\003\162\003\164\003\166\003\168\003\170\003\171\003\179\003\180\003\181\003\182\003\183\003\184\003\186\003\187\003\188\003\189\003\190\003\193\003\194\003\195\003\197\003\199\003\201\003\204\003\205\003\206\003\207\003\209\003\211\003\213\003\220\003\221\003\222\003\223\003\224\003\230\003\231\003\232\003\233\003\234\003\247\003\248\004\005\004\006\004\007\004\n\004\011\004\012\004\r\004\014\004\016\004\017\004\018\004\019\004 \004'\004(\004)\004A\004C\004D\004E\004F\004H\004J\004M\004N\004P\004Q\004R\004S\004T\004U\004V\004c\004d\004q\004}\004\130\004\131\004\133\004\135\004\136\004\137\004\138\004\142\004\143\004\147\004\148\004\150\004\152\004\154\004\156\004\157\004\159\004\160\004\161\004\163\004\164\004\166\004\179\004\180\004\181\004\182\004\183\004\185\004\186\004\187\004\188\004\190\004\191\004\192\004\193\004\220\004\221\004\244\004\245\004\247\004\248\004\250\004\252\005\t\005\n\005\012\005\r\005\015\005\016\005\018\005\019\005\021\005\022\005\024\005\025\005\027\005\028\005\030\005\031\005!\005\"\005$\005%\005'\005(\005*\005+\005-\005.\0050\0051\0053\0054\0056\0057\0059\005:\005<\005=\005?\005@\005B\005C\005E\005F\005H\005K\005L\005M\005N\005O\005P\005Q\005R\005T\005U\005W\005X\005Y\005_\005`\005a\005b\005h\005i\005o\005p\005v\005w\005x\005y\005z\005|\005}\005\131\005\132\005\133\005\134\005\135\005\137\005\144\005\145\005\146\005\149\005\150\005\151\005\152\005\153\005\154\005\158\005\159\005\160\005\161\005\162\005\164\005\166\005\167\005\168\005\169\005\173\005\174\005\178\005\179\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\208\005\209\005\210\005\211\005\212\005\213\005\214\005\216\005\217\005\218\005\219\005\221\005\222\005\223\005\225\005\226\005\227\005\228\005\230\005\232\005\234\005\236\005\237\005\239\005\240\005\241\005\242\005\244\005\245\005\246\005\247\005\249\005\251\005\253\005\255\006\000\006\002\006\004\006\006\006\007\006\b\006\n\006\011\006\012\006\014\006\015\006\016\006\018\006\020\006\024\006\025\006\029\006\030\006 \006#\006%\006&\006'\006(\006)\006-\0060\0062\0063\0064\0067\006<\006=\006>\006A\006F\006G\006H\006I\006J\006L\006R\006X\006^\006a\006d\006g\006h\006l\006m\006n\006o\006p\006r\006s\006t\006u\006w\006x\006y\006z\006|\006}\006~\006\127\006\135\006\141\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\161\006\162\006\163\006\164\006\165\006\166\006\168\006\169\006\170\006\171\006\172\006\175\006\178\006\179\006\180\006\182\006\183\006\184\006\186\006\187\006\188\006\189\006\190\006\192\006\193\006\194\006\196\006\197\006\198\006\199\006\202\006\203\006\204\006\205\006\208\006\209\006\215\006\217\006\219\006\221\006\223\006\224\006\228\006\229\006\233\006\237\006\239\006\240\006\243\006\244\006\245\006\246\006\247\006\251\006\252\006\253\006\254\006\255\007\000\007\004\007\005\007\006\007\007\007\t\007\n\007\012\007\r\007\014\007\018\007\019\007\020\007\021\007\022\007\023\007\024\007\025\007\029\007\030\007\031\007 \007!\007\"\007$\007%\007&\007'\007(\007)\007*\007,\007-\007.\007/\0070\0071\0072\0073\0075\0076\0077\0078\0079\007;\007<\007>\007?\007@\007A\007B\007D\007E\007F\007G\007I\007J\007L\007M\007N\007O\007P\007Q\007R\007S\007T\007V\007X\007Y\007Z\007\\\007]\007^\007`\007a\007b\007c\007e\007g\007h\007i\007k\007l\007m\007o\007p\007r\007t\007u\007v\007w\007y\007z\007|\007}\007~\007\127\007\128\007\129\007\130\007\131\007\132\007\133\007\135\007\136\007\137\007\138\007\139\007\140\007\141\007\142\007\144\007\145\007\146\007\147\007\148\007\149\007\150\007\151\007\152\007\153\007\155\007\156\007\157\007\158\007\162\007\165\007\166\007\167\007\168\007\169\007\170\007\172\007\174\007\175\007\177\007\178\007\179\007\180\007\181\007\182\007\183\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\210\007\211\007\212\007\213\007\214\007\215\007\216\007\217\007\218\007\219\007\220\007\222\007\223\007\224\007\225\007\226\007\227\007\228\007\229\007\230\007\232\007\234\007\235\007\236\007\237\007\238\007\239\007\240\007\241\007\242\007\243\007\244\007\246\007\248\007\250\007\252\007\253\007\254\007\255\b\000\b\001\b\002\b\003\b\006\b\b\b\t\b\011\b\012\b\r\b\014\b\015\b\017\b\019\b\021\b\022\b\023\b\024\b\025\b\026\b\027\b\030\b!\b$\b'\b)\b*\b+\b,\b.\b/\b0\b1\b2\b3\b4\b5\b6\b7\b8\b9\b:\b;\b<\b=\bA\bC\bD\bF\bG\bH\bI\bJ\bK\bN\bQ\bS\bT\bU\bV\bX\bY\bZ\b[\b\\\b]\b^\b_\b`\ba\bb\bd\be\bf\bh\bl\bm\bn\bo\bp\bq\br\bt\bu\bv\bx\by\bz\b|\b}\b~\b\127\b\128\b\130\b\131\b\133\b\134\b\135\b\137\b\138\b\151\b\164\b\166\b\167\b\168\b\169\b\171\b\172\b\173\b\175\b\176\b\177\b\179\b\180\b\182\b\183\b\185\b\186\b\187\b\188\b\189\b\192\b\193\b\194\b\195\b\196\b\198\b\199\b\200\b\201\b\202\b\203\b\205\b\206\b\207\b\208\b\209\b\210\b\211\b\212\b\213\b\214\b\215\b\216\b\217\b\218\b\220\b\221\b\222\b\223\b\225\b\226\b\227\b\228\b\229\b\230\b\231\b\232\b\233\b\234\b\235\b\236\b\237\b\238\b\239\b\240\b\241\b\242\b\243\b\244\b\245\b\246\b\247\b\248\b\249\b\250\b\251\b\253\b\254\b\255\t\001\t\002\t\003\t\004\t\005\t\006\t\007\t\b\t\t\t\n\t\011\t\012\t\r\t\016\t\017\t\020\t\021\t\022\t\023\t\024\t\025\t\026\t\027\t\029\t#\t$\t%\t'\t(\t)\t*\t+\t,\t.\t/\t0\t2\t3\t4\t5\t9\t;\t<\t>\t?\t@\tA\tB\tC\tD\tE\tR\tS\tT\tW\tZ\t]\t_\t`\ta\tb\tc\tq\t~\t\128\t\129\t\135\t\137\t\139\t\141\t\142\t\144\t\146\t\148\t\150\t\151\t\153\t\155\t\157\t\159\t\160\t\162\t\176\t\178\t\180\t\182\t\183\t\185\t\187\t\189\t\191\t\192\t\194\t\196\t\198\t\200\t\201\t\203\t\211\t\217\t\219\t\221\t\223\t\224\t\226\t\228\t\230\t\232\t\233\t\235\t\237\t\239\t\241\t\242\t\244\t\246\t\247\t\249\t\251\t\253\t\254\t\255\n\000\n\001\n\002\n\003\n\004\n\005\n\n\n\r\n\014\n\015\n\016\n\017\n\018\n\019\n\020\n\021\n\022\n\023\n\024\n\025\n\026\n\027\n\028\n\029\n\030\n\031\n \n!\n\"\n#\n$\n%\n&\n'\n(\n)\n*\n+\n,\n-\n.\n/\n0\n1\n2\n3\n4\n5\n6\n8\n9\n:\n;\n>\n@\nB\nE\nF\nH\nI\nJ\nK\nX\nZ\n[\nh\ni\nj\nl\no\nq\nr\ns\nt\nu\nv\nw\nx\ny\nz\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\140\n\141\n\142\n\143\n\144\n\145\n\146\n\147\n\148\n\149\n\153\n\154\n\155\n\156\n\158\n\159\n\160\n\162\n\163\n\165\n\166\n\167\n\168\n\169\n\170\n\171\n\172\n\173\n\175\n\176\n\177\n\178\n\191\n\193\n\195\n\197\n\202\n\203\n\204\n\208\n\209\n\211\n\212\n\213\n\214\n\215\n\216\n\218\n\219\n\220\n\222\n\227\n\228\n\229\n\233\n\234\n\236\n\241\n\242\n\243\n\247\n\248\n\252\n\253\n\254\n\255\011\003\011\004\011\005\011\006\011\007\011\b\011\t\011\n\011\r\011\016\011\018\011\020\011\021\011\022\011\027\011\029\011\030\011\031\011 \011!\011\"\011#\011$\011'\011)\011*\011+\011,\011-\011/\0112\0113\0115\0116\0117\0118\0119\011;\011<\011=\011>\011?\011@\011B\011D\011E\011F\011G\011J\011K\011L\011M\011N\011O\011P\011Q\011S\011T\011U\011V\011X\011Z\011[\011\\\011]\011`\011a\011b\011c\011g\011k\011l\011m\011n\011o\011p\011t\011u\011|\011}\011~\011\128\011\129\011\130\011\131\011\132\011\133\011\134\011\136\011\140\011\142\011\145\011\146\011\147\011\148\011\149\011\150\011\151\011\152\011\153\011\154\011\155\011\156\011\157\011\158\011\159\011\160\011\161\011\162\011\163\011\164\011\165\011\166\011\167\011\168\011\171\011\172\011\173\011\174\011\175\011\180\011\184\011\186\011\187\011\188\011\189\011\190\011\191\011\192\011\193\011\194\011\195\011\196\011\197\011\198\011\199\011\200\011\201\011\203\011\204\011\205\011\206\011\207\011\208\011\209\011\210\011\213\011\214\011\215\011\216\011\218\011\219\011\220\011\221\011\225\011\226\011\227\011\228\011\232\011\233\011\234\011\235\011\236\011\237\011\238\011\244\011\245\011\246\011\247\011\248\011\249\011\250\011\252\011\254\011\255\012\006\012\r\012\014\012\015\012\016\012\017\012\018\012\021\012\022\012\023\012\024\012\025\012\026\012\027\012\028\012\029\012\030\012\031\012 \012!\012#\012$\012%\012&\012'\012(\012)\012*\012+\012,\012-\012.\012/\0120\0121\0122")) and nullable = - "\000\000\016)\001\000@\000\001\014\016\000\001\255\128\192\000\000?\255\128\000@\130\016\000\012\000\000" + "\000\000\016)\001\000@\000\000\135\b\000\000\255\224\024\000\000\007\255\240\000\b\016\b \000\006\004\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@\b\b\000\004\012\b\000\000\000@\000\000\000\000\000\006\002\000@\000\000@@\000\000\002\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\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\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\000\000\b\128\000\000\000\001\128\002\000\000\000\016\000\000\000\000\001 \004\016\001\004\000\016\128\000\128\000d\000\000\128\000\207\225 \197\138\173\252\204\244\005\001\247\"\128\007\028\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000@\000\000\000\b\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\001\000\000\000\000\004\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\000\000\000\b\004\000 \000\000\000\000\000\000\002\000\002\000\000\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\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\001\159\194A\139\021[\249\153\232\n\131\238E\000\0148\000\000\000\000H\000@\000\000\002\000\000\000\000\000\001\000\002\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\146\000\017\000\000\000\128\000\000\000\000\000@\000\128\000\004\144\000\128\000\000\004\000\000\000\000\000\002\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000\000\012\000\000\192\000\000\194\225\000\000\128\000\000\000\000\000\012\254\018\012X\170\223\204\207@T\031r(\000q\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\001\128\000\000\000\000\000\000\000\000\000\000\t\000\000\128\b \020\132\000\004\000\003\000\000\004\000\006\127\t\006,Uo\230g\160(\015\184\020\0008\224\001\138@\020$\001\024\018+\000\016\005 \000\000\130\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\023\183d@\130\254*@\0010p:q\193`Ph\003\016\128 @\002 $R\000 \n\000\000\001\004\000\024\132\001\002\000\017\129\"\144\001\000P\000\000\b \000\196 \b\128P\012\t\028\128\000\002\128P\000c\000\000\000\000\000\000\000\000\b\160\000\000\000\000\000\000\000\000\000\b\000\004\000 \000\000 \000\000\128\000\000\016\000\002@\000 \002\b\000!\000\001\000\000\192\000\001\000\000\018\000A\000\016@\001\b\000\b\000\006\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\196 \b\016\000\140\t\022\128\b\002\160\000\000A\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\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\002\000\012\000\000\192\000\000\194\225\000\000\128\000\000\000\000\000\012n\016\004X(\223\196\143@\016\031@(\0001\192\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000\024\000\001\128\000\001\133\194\000\001\000\000\000\000\000\000\000\128\000\004\144\000\128\000\000\004\000\000\000\000\000\002\000\006\000\000p\016\000ap\128\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\b\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\000b\016\004\b\000F\004\139@\004\001P\000\000\"\128\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\197 \n\130P\012\t\029\128\000\002\128P\000c\000\000\000\000\000\000\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\136\000\000\000\000\016\000 \000\000\001\000\000\000\b\000\004@\000\000\000\000\128\001\000\000\000\b\000\000\000@\000\"\000\000\000\000\004\000\b\000\000\000@\000\000\002\000\003\016\128\"\001@0$r\000\000\n\001@\001\140\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\002\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\016\000\000\000\000\000\000\000\000\000\000\000\000\128\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\007\001\000\006\023\b\000\004\000\000\000\000\000\000g\240\144j\197V\254fz\002\128\251\129@\007\142\000\016\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\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\160\000\000\016@\001\136@\016 \001\024\018-\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\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@\b\b\000\004\012\b\000\000\000@\000\000\000\000\000\006\002\000@\000\000@@\000\000\002\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\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\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\000\000\b\128\000\000\000\001\128\002\000\000\000\016\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\016\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\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\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\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\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\001\000\015\192\024\018\000\001\241\b\001\002\000@\162\192\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\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\000\000\000\000\000 \000\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\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\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\128\000\000\000\000\000\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\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\001\128\128\016\000\000\016\016\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\004\000\000\000\000\000\b\000\000\128\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\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\000\128\000\000\000\000\b\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@\000\000 \000\000\128\004\000\000\000\000\000\000\000@\000\192\000\012\000\000\012.\016\000\b\000\000\b\000\000\000\006!\000@\128\004`H\180\000@\021\000\000\002\b\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\004\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\144\002\b\000\130\001H@\000D\0000\000\000@\000\004\128\000@\004\016\nB\000\002\000\001\128\000\002\000\000 \000\002\000\000\b\002\016\012\000\000\000\000\b\000\000\001\000\000\016\000\000@\016\128 \000\000\000\000@\000\000\t\000 \128\b \020\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\128\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\128\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 \012B\000\129\000\b\192\145h\000\128(\000\000\004\016\000b\016\004\b\000F\004\139@\004\001@\000\000 \128\003\016\128 @\0020$Z\000 \n\128\000\001\004\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\006!\000@\128\004`H\180\000@\020\000\000\002\b\0001\b\002\004\000#\002E\160\002\000\160\000\000\016@\001\138@\020$\001\024\018+\000\016\005\000\000\000\130\000\012R\000\168%\000\192\145\216\000\000(\005\000\0060\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\001\000\128\000\000\000\000\000\000\000\000\000\000\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\004\000\000\000\004\000\000\000\000\000\000\000\000\000\002@\b \002\b\000!\000\001\000\000\200\000\001\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@P\031r(\000q\192\001\000\000\000\000\000\016\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\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\000\001\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\002\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\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000\024\164\001B@Q\129\"\176\001\000P\000\000( \000\197 \n\018\000\140\t\021\128\b\002\144\000\tA\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\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\004\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\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\002\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\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\001\000\001\128\000\024\000\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\004\000\b\000\000\000@\000\000\000\000\001\016\000\000\000\000 \000@\000\000\002\000\000\000\000\000\000\128\000\000\000\001\000\002\000\000\000\016\000\000\000\000\000\000 \000\000\000\000\000\000\128\000\002\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\001\128\000\028\004\128\025\\ \000\016\000\000\000\000\000\000\004\000\000\000\004\000\192\001\000\000\000\000\000\000\000\000\000 \000\004\000 \002D\b\000\000\000\000\000\000\000\000\004\000\000@\000\001\000B\000\128\000\000\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\b\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\0001H\002\132\128#\002E`\002\000\160\000\000\016@\001\138@\020$\001\024\018+\000\016\005 \000\002\130\000\016\000\001\000\000\004\001\b\006\000\000\000\000\004\000\000\000 \000\004\000 \006D\b\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\005\237\217\016 \191\138\144\000L\028\014\156pX\020\026\000\192\000\012\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000") + (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@\b\b\000\004\012\b\000\000\000@\000\000\000\000\000\006\002\000@\000\000@@\000\000\002\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\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\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\000\000\b\128\000\000\000\001\128\002\000\000\000\016\000\000\000\000\001 \004\016\001\004\000\016\128\000\128\000d\000\000\128\000\207\225 \197\138\173\252\204\244\005\001\247\"\128\007\028\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000@\000\000\000\b\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\001\000\000\000\000\004\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\000\000\000\b\004\000 \000\000\000\000\000\000\002\000\002\000\000\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\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\001\159\194A\139\021[\249\153\232\n\131\238E\000\0148\000\000\000\000H\000@\000\000\002\000\000\000\000\000\001\000\002\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\146\000\017\000\000\000\128\000\000\000\000\000@\000\128\000\004\144\000\128\000\000\004\000\000\000\000\000\002\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000\000\012\000\000\192\000\000\194\225\000\000\128\000\000\000\000\000\012\254\018\012X\170\223\204\207@T\031r(\000q\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\001\128\000\000\000\000\000\000\000\000\000\000\t\000\000\128\b \020\132\000\004\000\003\000\000\004\000\006\127\t\006,Uo\230g\160(\015\184\020\0008\224\001\138@\020$\001\024\018+\000\016\005 \000\000\130\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\023\183d@\130\254*@\0010p:q\193`Ph\003\016\128 @\002 $R\000 \n\000\000\001\004\000\024\132\001\002\000\017\129\"\144\001\000P\000\000\b \000\196 \b\128P\012\t\028\128\000\002\128P\000c\000\000\000\000\000\000\000\000\b\160\000\000\000\000\000\000\000\000\000\b\000\004\000 \000\000 \000\000\128\000\000\016\000\002@\000 \002\b\000!\000\001\000\000\192\000\001\000\000\018\000A\000\016@\001\b\000\b\000\006\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\196 \b\016\000\140\t\022\128\b\002\160\000\000A\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\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\002\000\012\000\000\192\000\000\194\225\000\000\128\000\000\000\000\000\012n\016\004X(\223\196\143@\016\031@(\0001\192\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000\024\000\001\128\000\001\133\194\000\001\000\000\000\000\000\000\000\128\000\004\144\000\128\000\000\004\000\000\000\000\000\002\000\006\000\000p\016\000ap\128\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\b\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\000b\016\004\b\000F\004\139@\004\001P\000\000\"\128\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\197 \n\130P\012\t\029\128\000\002\128P\000c\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\0001H\002\132\128#\002E`\002\000\160\000\000\016@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\004@\000\000\000\000\128\001\000\000\000\b\000\000\000@\000\"\000\000\000\000\004\000\b\000\000\000@\000\000\002\000\001\016\000\000\000\000 \000@\000\000\002\000\000\000\016\000\024\132\001\016\n\001\129#\144\000\000P\n\000\012`\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\016\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\128\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\003\000\0008\b\0000\184@\000 \000\000\000\000\000\003?\132\131V*\183\2433\208\020\007\220\n\000\228P\000\227\128\002\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\004@\000\000\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\002\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\004\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\006\000\000p\016\000ap\128\000@\000\000\000\000\000\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\001\138@\020$\001\024\018+\000\016\005\000\000\000\130\000\012R\000\161 \b\192\145X\000\128(\000\000\004\016\012n\016\004X(\223\196\143@\016\031@(\0001\192cp\128\"\193F\254$z\000\128\250\001@\001\142\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\128\000\000\000\000\000\000\000\000\000\000\000@\000\000\000@\000\000\000\000\000\000\000\000\000\017\000\000\000\000\002\000\004\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\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\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\000@\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\b\006\016\000\000\000\000\000\000\000\000\000\000\000@\000\000Ap\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\136\000\000\000\000\016\000 \000\000\001\000\000\000\b\000\012\000\000\192\000\000\194\225@\000\128\000\000\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\000\000\b\128\000\000\000\001\000\002\000\000\000\016\000\000\000\000\000\004\000\000\000\000\b\000\016\000\000\000\128\000\000\000\000\000\001\000\000\000\000\000\000\004\000\000\016\000\000\002\000\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\001\000\000\012\000\000\224$\000\202\225\000\000\128\000\000\000\000\000\000 \000\000\000 \006\000\b\000\000\000\000\000\000\000\000\001\000\000 \001\000\018 @\000\000\000\000\000\000\000\000 \000\002\000\000\b\002\016\004\000\000\000\000\b\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\016\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\000\000\130\000\012R\000\161 \b\192\145X\000\128)\000\000\020\016\000\128\000\b\000\000 \b@0\000\000\000\000 \000\000\001\000\000 \001\0002 @\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\025\252$\026\177U\191\153\158\128\160>\224P\001\227\129{vD\b/\226\164\000\019\007\003\167\028\022\005\006\1280\000\003\000\000\003\011\132\000\002\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\000\000\000\000\000\000\000\000\000\001\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\000\000\192\000\000\000\000\000\000\000\000\000\000\000\000") end) (ET) (TI) @@ -46304,59 +46726,59 @@ end let use_file = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1847 lexer lexbuf) : (Parsetree.toplevel_phrase list)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1856 lexer lexbuf) : (Parsetree.toplevel_phrase list)) and toplevel_phrase = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1827 lexer lexbuf) : (Parsetree.toplevel_phrase)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1836 lexer lexbuf) : (Parsetree.toplevel_phrase)) and parse_val_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1821 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1830 lexer lexbuf) : (Longident.t)) and parse_pattern = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1817 lexer lexbuf) : (Parsetree.pattern)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1826 lexer lexbuf) : (Parsetree.pattern)) and parse_mty_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1813 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1822 lexer lexbuf) : (Longident.t)) and parse_module_type = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1809 lexer lexbuf) : (Parsetree.module_type)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1818 lexer lexbuf) : (Parsetree.module_type)) and parse_module_expr = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1805 lexer lexbuf) : (Parsetree.module_expr)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1814 lexer lexbuf) : (Parsetree.module_expr)) and parse_mod_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1801 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1810 lexer lexbuf) : (Longident.t)) and parse_mod_ext_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1797 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1806 lexer lexbuf) : (Longident.t)) and parse_expression = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1793 lexer lexbuf) : (Parsetree.expression)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1802 lexer lexbuf) : (Parsetree.expression)) and parse_core_type = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1789 lexer lexbuf) : (Parsetree.core_type)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1798 lexer lexbuf) : (Parsetree.core_type)) and parse_constr_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1785 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1794 lexer lexbuf) : (Longident.t)) and parse_any_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1767 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1776 lexer lexbuf) : (Longident.t)) and interface = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1763 lexer lexbuf) : (Parsetree.signature)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1772 lexer lexbuf) : (Parsetree.signature)) and implementation = fun lexer lexbuf -> @@ -46366,59 +46788,59 @@ module Incremental = struct let use_file = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1847 initial_position) : (Parsetree.toplevel_phrase list) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1856 initial_position) : (Parsetree.toplevel_phrase list) MenhirInterpreter.checkpoint) and toplevel_phrase = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1827 initial_position) : (Parsetree.toplevel_phrase) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1836 initial_position) : (Parsetree.toplevel_phrase) MenhirInterpreter.checkpoint) and parse_val_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1821 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1830 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_pattern = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1817 initial_position) : (Parsetree.pattern) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1826 initial_position) : (Parsetree.pattern) MenhirInterpreter.checkpoint) and parse_mty_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1813 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1822 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_module_type = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1809 initial_position) : (Parsetree.module_type) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1818 initial_position) : (Parsetree.module_type) MenhirInterpreter.checkpoint) and parse_module_expr = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1805 initial_position) : (Parsetree.module_expr) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1814 initial_position) : (Parsetree.module_expr) MenhirInterpreter.checkpoint) and parse_mod_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1801 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1810 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_mod_ext_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1797 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1806 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_expression = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1793 initial_position) : (Parsetree.expression) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1802 initial_position) : (Parsetree.expression) MenhirInterpreter.checkpoint) and parse_core_type = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1789 initial_position) : (Parsetree.core_type) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1798 initial_position) : (Parsetree.core_type) MenhirInterpreter.checkpoint) and parse_constr_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1785 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1794 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_any_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1767 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1776 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and interface = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1763 initial_position) : (Parsetree.signature) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1772 initial_position) : (Parsetree.signature) MenhirInterpreter.checkpoint) and implementation = fun initial_position -> @@ -46426,12 +46848,12 @@ module Incremental = struct end -# 4142 "src/ocaml/preprocess/parser_raw.mly" +# 4355 "src/ocaml/preprocess/parser_raw.mly" -# 46433 "src/ocaml/preprocess/parser_raw.ml" +# 46855 "src/ocaml/preprocess/parser_raw.ml" # 269 "" -# 46438 "src/ocaml/preprocess/parser_raw.ml" +# 46860 "src/ocaml/preprocess/parser_raw.ml" diff --git a/src/ocaml/preprocess/parser_raw.mli b/src/ocaml/preprocess/parser_raw.mli index 128ee3f63e..9818215e61 100644 --- a/src/ocaml/preprocess/parser_raw.mli +++ b/src/ocaml/preprocess/parser_raw.mli @@ -336,7 +336,7 @@ module MenhirInterpreter : sig | 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_type_constraint : (Parsetree.type_constraint) nonterminal | N_tuple_type : (Parsetree.core_type) nonterminal | N_toplevel_phrase : (Parsetree.toplevel_phrase) nonterminal | N_toplevel_directive : (Parsetree.toplevel_phrase) nonterminal @@ -375,6 +375,7 @@ module MenhirInterpreter : sig | 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_nonempty_concat_fun_param_as_list_ : (Parsetree.function_param 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 @@ -408,12 +409,13 @@ module MenhirInterpreter : sig | 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_type_constraint_ : (Parsetree.type_constraint 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_COLON_atomic_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 @@ -421,6 +423,7 @@ module MenhirInterpreter : sig | 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_object_type : (Parsetree.core_type) 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 @@ -442,7 +445,7 @@ module MenhirInterpreter : sig | 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___anonymous_43_ : (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) * @@ -503,16 +506,22 @@ module MenhirInterpreter : sig | 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_fun_seq_expr : (Parsetree.expression) nonterminal + | N_fun_params : (Parsetree.function_param list) nonterminal + | N_fun_param_as_list : (Parsetree.function_param list) nonterminal + | N_fun_expr : (Parsetree.expression) nonterminal + | N_fun_body : (Parsetree.function_body) nonterminal | N_formal_class_parameters : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) nonterminal | N_floating_attribute : (Parsetree.attribute) nonterminal + | N_extension_type : (Parsetree.core_type) 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_delimited_type_supporting_local_open : (Parsetree.core_type) nonterminal + | N_delimited_type : (Parsetree.core_type) nonterminal | N_core_type : (Parsetree.core_type) nonterminal | N_constructor_declarations : (Parsetree.constructor_declaration list) nonterminal | N_constructor_arguments : (Parsetree.constructor_arguments) nonterminal @@ -535,6 +544,7 @@ module MenhirInterpreter : sig | N_class_field : (Parsetree.class_field) nonterminal | N_class_expr : (Parsetree.class_expr) nonterminal | N_attribute : (Parsetree.attribute) nonterminal + | N_attr_payload : (Parsetree.payload) nonterminal | N_attr_id : (string Location.loc) nonterminal | N_atomic_type : (Parsetree.core_type) nonterminal | N_any_longident : (Longident.t) nonterminal diff --git a/src/ocaml/preprocess/parser_raw.mly b/src/ocaml/preprocess/parser_raw.mly index f0e8f80cda..aec0e10473 100644 --- a/src/ocaml/preprocess/parser_raw.mly +++ b/src/ocaml/preprocess/parser_raw.mly @@ -26,6 +26,9 @@ [@@@ocaml.warning "-9"] +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + open Asttypes open Longident open Parsetree @@ -167,6 +170,10 @@ let mkuplus ~oploc name arg = | _ -> Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg]) +let mk_attr ~loc name payload = + Builtin_attributes.(register_attr Parser name); + Attr.mk ~loc name payload + (* 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 *) @@ -209,11 +216,13 @@ let rec mktailpat nilloc = let open Location in function 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 -> mkexp ~loc (Pexp_constraint(e, t)) - | _, Some t -> mkexp ~loc (Pexp_coerce(e, t1, t)) - | None, None -> assert false +let mkexp_desc_constraint e t = + match t with + | Pconstraint t -> Pexp_constraint(e, t) + | Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) + +let mkexp_constraint ~loc e t = + mkexp ~loc (mkexp_desc_constraint e t) let mkexp_opt_constraint ~loc e = function | None -> e @@ -597,6 +606,64 @@ let class_of_let_bindings ~loc lbs body = assert (lbs.lbs_extension = None); mkclass ~loc (Pcl_let (lbs.lbs_rec, List.rev bindings, body)) +(* If all the parameters are [Pparam_newtype x], then return [Some xs] where + [xs] is the corresponding list of values [x]. This function is optimized for + the common case, where a list of parameters contains at least one value + parameter. +*) +let all_params_as_newtypes = + let is_newtype { pparam_desc; _ } = + match pparam_desc with + | Pparam_newtype _ -> true + | Pparam_val _ -> false + in + let as_newtype { pparam_desc; pparam_loc } = + match pparam_desc with + | Pparam_newtype x -> Some (x, pparam_loc) + | Pparam_val _ -> None + in + fun params -> + if List.for_all is_newtype params + then Some (List.filter_map as_newtype params) + else None + +(* Given a construct [fun (type a b c) : t -> e], we construct + [Pexp_newtype(a, Pexp_newtype(b, Pexp_newtype(c, Pexp_constraint(e, t))))] + rather than a [Pexp_function]. +*) +let mkghost_newtype_function_body newtypes body_constraint body = + let wrapped_body = + match body_constraint with + | None -> body + | Some body_constraint -> + let loc = { body.pexp_loc with loc_ghost = true } in + Exp.mk (mkexp_desc_constraint body body_constraint) ~loc + in + let expr = + List.fold_right + (fun (newtype, newtype_loc) e -> + (* Mints a ghost location that approximates the newtype's "extent" as + being from the start of the newtype param until the end of the + function body. + *) + let loc = (newtype_loc.Location.loc_start, body.pexp_loc.loc_end) in + ghexp (Pexp_newtype (newtype, e)) ~loc) + newtypes + wrapped_body + in + expr.pexp_desc + +let mkfunction params body_constraint body = + match body with + | Pfunction_cases _ -> Pexp_function (params, body_constraint, body) + | Pfunction_body body_exp -> + (* If all the params are newtypes, then we don't create a function node; + we create nested newtype nodes. *) + match all_params_as_newtypes params with + | None -> Pexp_function (params, body_constraint, body) + | Some newtypes -> + mkghost_newtype_function_body newtypes body_constraint body_exp + (* 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. *) @@ -608,11 +675,11 @@ let package_type_of_module_type pmty = | Pwith_type (lid, ptyp) -> let loc = ptyp.ptype_loc in if ptyp.ptype_params <> [] then - err loc "parametrized types are not supported"; + err loc Syntaxerr.Parameterized_types; if ptyp.ptype_cstrs <> [] then - err loc "constrained types are not supported"; + err loc Syntaxerr.Constrained_types; if ptyp.ptype_private <> Public then - err loc "private types are not supported"; + err loc Syntaxerr.Private_types; (* restrictions below are checked by the 'with_constraint' rule *) (* assert (ptyp.ptype_kind = Ptype_abstract); *) @@ -622,7 +689,7 @@ let package_type_of_module_type pmty = | None -> None end | _ -> - err pmty.pmty_loc "only 'with type t =' constraints are supported"; + err pmty.pmty_loc Not_with_type; None in match pmty with @@ -630,8 +697,7 @@ let package_type_of_module_type pmty = | {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" + err pmty.pmty_loc Neither_identifier_nor_with_type ; (Location.mkloc (Lident "_") pmty.pmty_loc, [], []) let mk_directive_arg ~loc k = @@ -1097,6 +1163,27 @@ reversed_nonempty_llist(X): xs = rev(reversed_nonempty_llist(X)) { xs } +(* [reversed_nonempty_concat(X)] recognizes a nonempty sequence of [X]s (each of + which is a list), and produces an OCaml list of their concatenation in + reverse order -- that is, the last element of the last list in the input text + appears first in the list. +*) +reversed_nonempty_concat(X): + x = X + { List.rev x } +| xs = reversed_nonempty_concat(X) x = X + { List.rev_append x xs } + +(* [nonempty_concat(X)] recognizes a nonempty sequence of [X]s + (each of which is a list), and produces an OCaml list of their concatenation + in direct order -- that is, the first element of the first list in the input + text appears first in the list. +*) + +%inline nonempty_concat(X): + xs = rev(reversed_nonempty_concat(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 @@ -2332,17 +2419,48 @@ class_type_declarations: /* Core expressions */ -seq_expr: - | expr %prec below_SEMI { $1 } - | expr SEMI { $1 } - | mkexp(expr SEMI seq_expr +%inline or_function(EXPR): + | EXPR + { $1 } + | FUNCTION ext_attributes match_cases + { let loc = make_loc $sloc in + let cases = $3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:$sloc desc $2 + } +; + +(* [fun_seq_expr] (and [fun_expr]) are legal expression bodies of a function. + [seq_expr] (and [expr]) are expressions that appear in other contexts + (e.g. subexpressions of the expression body of a function). + + [fun_seq_expr] can't be a bare [function _ -> ...]. [seq_expr] can. + + This distinction exists because [function _ -> ...] is parsed as a *function + cases* body of a function, not an expression body. This so functions can be + parsed with the intended arity. +*) +fun_seq_expr: + | fun_expr %prec below_SEMI { $1 } + | fun_expr SEMI { $1 } + | mkexp(fun_expr SEMI seq_expr { Pexp_sequence($1, $3) }) { $1 } - | expr SEMI PERCENT attr_id seq_expr + | fun_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)) } ; +seq_expr: + | or_function(fun_seq_expr) { $1 } +; labeled_simple_pattern: QUESTION LPAREN label_let_pattern opt_default RPAREN { (Optional (fst $3), $4, snd $3) } @@ -2413,10 +2531,10 @@ let_pattern [@recovery default_pattern ()]: %inline qualified_dotop: ioption(DOT mod_longident {$2}) DOTOP { $1, $2 }; -%public expr [@recovery default_expr ()]: +fun_expr: simple_expr %prec below_HASH { $1 } - | expr_attrs + | fun_expr_attrs { let desc, attrs = $1 in mkexp_attrs ~loc:$sloc desc attrs } | mkexp(expr_) @@ -2429,7 +2547,7 @@ let_pattern [@recovery default_pattern ()]: 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 + | fun_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)) } @@ -2439,7 +2557,7 @@ let_pattern [@recovery default_pattern ()]: { 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 + | fun_expr attribute { Exp.attr $1 $2 } (* /* BEGIN AVOID */ @@ -2448,7 +2566,10 @@ let_pattern [@recovery default_pattern ()]: /* END AVOID */ *) ; -%inline expr_attrs: +%public expr [@recovery default_expr ()]: + | or_function(fun_expr) { $1 } +; +%inline fun_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 @@ -2457,13 +2578,12 @@ let_pattern [@recovery default_pattern ()]: { 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 } + /* Cf #5939: we used to accept (fun p when e0 -> e) */ + | FUN ext_attributes fun_params preceded(COLON, atomic_type)? + MINUSGREATER fun_body + { let body_constraint = Option.map (fun x -> Pconstraint x) $4 in + mkfunction $3 body_constraint $6, $2 + } | MATCH ext_attributes seq_expr WITH match_cases { Pexp_match($3, $5), $2 } | TRY ext_attributes seq_expr WITH match_cases @@ -2499,7 +2619,7 @@ let_pattern [@recovery default_pattern ()]: { 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 + | e1 = fun_expr op = op(infix_operator) e2 = expr { mkinfix e1 op e2 } | subtractive expr %prec prec_unary_minus { mkuminus ~oploc:$loc($1) $1 $2 } @@ -2698,10 +2818,9 @@ let_binding_body_no_punning: { let v = $1 in (* PR#7344 *) let t = match $2 with - Some t, None -> + Pconstraint t -> Pvc_constraint { locally_abstract_univars = []; typ=t } - | ground, Some coercion -> Pvc_coercion { ground; coercion} - | _ -> assert false + | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion} in (v, $4, Some t) } @@ -2783,19 +2902,26 @@ letop_bindings: 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 } + | fun_params type_constraint? EQUAL fun_body + { ghexp ~loc:$sloc (mkfunction $1 $2 $4) + } +; +fun_body: + | FUNCTION ext_attributes match_cases + { let ext, attrs = $2 in + match ext with + | None -> Pfunction_cases ($3, make_loc $sloc, attrs) + | Some _ -> + (* function%foo extension nodes interrupt the arity *) + let cases = Pfunction_cases ($3, make_loc $sloc, []) in + Pfunction_body + (mkexp_attrs ~loc:$sloc (mkfunction [] None cases) $2) + } + | fun_seq_expr + { Pfunction_body $1 } ; %inline match_cases: xs = preceded_or_separated_nonempty_llist(BAR, match_case) @@ -2810,6 +2936,7 @@ match_case: { Exp.case $1 (merloc $endpos($2) (Exp.unreachable ~loc:(make_loc $loc($3)) ())) } ; +(* fun_def: MINUSGREATER seq_expr { (merloc $endpos($1) $2) } @@ -2825,6 +2952,30 @@ fun_def: | LPAREN TYPE lident_list RPAREN fun_def { mk_newtypes ~loc:$sloc $3 $5 } ; +*) +fun_param_as_list: + | LPAREN TYPE ty_params = lident_list RPAREN + { (* We desugar (type a b c) to (type a) (type b) (type c). + If we do this desugaring, the loc for each parameter is a ghost. + *) + let loc = + match ty_params with + | [] -> assert false (* lident_list is non-empty *) + | [_] -> make_loc $sloc + | _ :: _ :: _ -> ghost_loc $sloc + in + List.map + (fun x -> { pparam_loc = loc; pparam_desc = Pparam_newtype x }) + ty_params + } + | labeled_simple_pattern + { let a, b, c = $1 in + [ { pparam_loc = make_loc $sloc; pparam_desc = Pparam_val (a, b, c) } ] + } +; +fun_params: + | nonempty_concat(fun_param_as_list) { $1 } +; %inline expr_comma_list: es = separated_nontrivial_llist(COMMA, expr) { es } @@ -2870,9 +3021,9 @@ record_expr_content: { 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 core_type { Pconstraint $2 } + | COLON core_type COLONGREATER core_type { Pcoerce (Some $2, $4) } + | COLONGREATER core_type { Pcoerce (None, $2) } (*| COLON error { syntax_error() } *) (*| COLONGREATER error { syntax_error() } *) ; @@ -3458,8 +3609,8 @@ with_type_binder: /* Polymorphic types */ %inline typevar: - QUOTE mkrhs(ident) - { $2 } + QUOTE ident + { mkrhs $2 $sloc } ; %inline typevar_list: nonempty_llist(typevar) @@ -3513,7 +3664,7 @@ alias_type: function_type { $1 } | mktyp( - ty = alias_type AS QUOTE tyvar = ident + ty = alias_type AS tyvar = typevar { Ptyp_alias(ty, tyvar) } ) { $1 } @@ -3570,44 +3721,100 @@ tuple_type: - applications of type constructors: int, int list, int option list - variant types: [`A] *) + + +(* + Delimited types: + - parenthesised type (type) + - first-class module types (module S) + - object types < x: t; ... > + - variant types [ `A ] + - extension [%foo ...] + + We support local opens on the following classes of types: + - parenthesised + - first-class module types + - variant types + + Object types are not support for local opens due to a potential + conflict with MetaOCaml syntax: + M.< x: t, y: t > + and quoted expressions: + .< e >. + + Extension types are not support for local opens merely as a precaution. +*) +delimited_type_supporting_local_open: + | LPAREN type_ = core_type RPAREN + { type_ } + | LPAREN MODULE attrs = ext_attributes package_type = package_type RPAREN + { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc package_type) attrs } + | mktyp( + LBRACKET field = tag_field RBRACKET + { Ptyp_variant([ field ], Closed, None) } + | LBRACKET BAR fields = row_field_list RBRACKET + { Ptyp_variant(fields, Closed, None) } + | LBRACKET field = row_field BAR fields = row_field_list RBRACKET + { Ptyp_variant(field :: fields, Closed, None) } + | LBRACKETGREATER BAR? fields = row_field_list RBRACKET + { Ptyp_variant(fields, Open, None) } + | LBRACKETGREATER RBRACKET + { Ptyp_variant([], Open, None) } + | LBRACKETLESS BAR? fields = row_field_list RBRACKET + { Ptyp_variant(fields, Closed, Some []) } + | LBRACKETLESS BAR? fields = row_field_list + GREATER + tags = name_tag_list + RBRACKET + { Ptyp_variant(fields, Closed, Some tags) } + ) + { $1 } +; + +object_type: + | mktyp( + LESS meth_list = meth_list GREATER + { let (f, c) = meth_list in Ptyp_object (f, c) } + | LESS GREATER + { Ptyp_object ([], Closed) } + ) + { $1 } +; + +extension_type: + | mktyp ( + ext = extension + { Ptyp_extension ext } + ) + { $1 } +; + +delimited_type: + | object_type + | extension_type + | delimited_type_supporting_local_open + { $1 } +; + 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 } + | type_ = delimited_type + { type_ } | mktyp( /* begin mktyp group */ - QUOTE ident - { Ptyp_var $2 } - | UNDERSCORE - { Ptyp_any } - | tys = actual_type_parameters + 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) } + { Ptyp_constr (tid, tys) } | 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 } + { Ptyp_class (cid, tys) } + | mod_ident = mkrhs(mod_ext_longident) + DOT + type_ = delimited_type_supporting_local_open + { Ptyp_open (mod_ident, type_) } + | QUOTE ident = ident + { Ptyp_var ident } + | UNDERSCORE + { Ptyp_any } ) { $1 } /* end mktyp group */ ; @@ -3626,7 +3833,7 @@ atomic_type: | /* empty */ { [] } | ty = atomic_type - { [ty] } + { [ ty ] } | LPAREN tys = separated_nontrivial_llist(COMMA, core_type) RPAREN { tys } ; @@ -4034,17 +4241,17 @@ attr_id: ) { $1 } ; attribute: - LBRACKETAT attr_id payload RBRACKET - { Attr.mk ~loc:(make_loc $sloc) $2 $3 } + LBRACKETAT attr_id attr_payload RBRACKET + { mk_attr ~loc:(make_loc $sloc) $2 $3 } ; post_item_attribute: - LBRACKETATAT attr_id payload RBRACKET - { Attr.mk ~loc:(make_loc $sloc) $2 $3 } + LBRACKETATAT attr_id attr_payload RBRACKET + { mk_attr ~loc:(make_loc $sloc) $2 $3 } ; floating_attribute: - LBRACKETATATAT attr_id payload RBRACKET + LBRACKETATATAT attr_id attr_payload RBRACKET { mark_symbol_docs $sloc; - Attr.mk ~loc:(make_loc $sloc) $2 $3 } + mk_attr ~loc:(make_loc $sloc) $2 $3 } ; %inline post_item_attributes: post_item_attribute* @@ -4055,7 +4262,7 @@ floating_attribute: { $1 } ; ext: - | /* empty */ { None } + | /* empty */ { None } | PERCENT attr_id { Some $2 } ; %inline no_ext: @@ -4084,6 +4291,12 @@ payload: | QUESTION pattern { PPat ($2, None) } | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) } ; +attr_payload: + payload + { Builtin_attributes.mark_payload_attrs_used $1; + $1 + } +; %public simple_expr: | DOTLESS expr GREATERDOT diff --git a/src/ocaml/preprocess/parser_recover.ml b/src/ocaml/preprocess/parser_recover.ml index 542f452b63..5183a550d5 100644 --- a/src/ocaml/preprocess/parser_recover.ml +++ b/src/ocaml/preprocess/parser_recover.ml @@ -206,6 +206,7 @@ module Default = struct | 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_nonempty_concat_fun_param_as_list_ -> 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 @@ -244,6 +245,7 @@ module Default = struct | 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_COLON_atomic_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 @@ -251,6 +253,7 @@ module Default = struct | 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_object_type -> 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 @@ -272,7 +275,7 @@ module Default = struct | 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___anonymous_43_ -> 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 @@ -323,16 +326,22 @@ module Default = struct | 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_fun_seq_expr -> raise Not_found + | MenhirInterpreter.N MenhirInterpreter.N_fun_params -> raise Not_found + | MenhirInterpreter.N MenhirInterpreter.N_fun_param_as_list -> raise Not_found + | MenhirInterpreter.N MenhirInterpreter.N_fun_expr -> raise Not_found + | MenhirInterpreter.N MenhirInterpreter.N_fun_body -> 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_type -> 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_delimited_type_supporting_local_open -> raise Not_found + | MenhirInterpreter.N MenhirInterpreter.N_delimited_type -> 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 @@ -355,6 +364,7 @@ module Default = struct | 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_payload -> 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 @@ -379,7 +389,7 @@ type decision = | 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;1;2;2;1;2;2;1;1;2;1;1;1;1;1;1;2;3;4;1;1;5;6;6;1;1;2;1;2;3;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;1;4;5;1;1;1;1;1;2;1;2;3;1;1;1;2;2;3;4;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;1;1;1;2;3;4;1;2;3;1;2;3;1;1;2;3;3;1;1;4;1;2;1;1;1;2;3;1;2;3;1;1;1;1;2;1;2;3;1;4;1;1;2;1;1;2;3;1;1;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;2;2;1;1;2;3;1;1;2;1;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;1;2;3;2;3;2;3;3;4;5;2;3;2;3;2;4;4;5;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;2;3;1;2;1;2;3;4;1;5;2;1;2;3;1;2;4;5;4;5;6;2;3;4;5;1;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;4;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;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;3;1;2;1;2;3;4;4;5;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;1;2;1;2;3;4;1;2;3;4;5;1;2;6;1;2;7;2;3;4;5;1;2;1;2;3;4;6;7;1;2;3;4;5;6;1;2;8;4;5;6;1;2;1;2;1;2;3;4;5;1;2;3;4;5;1;2;3;2;3;6;7;1;2;8;9;1;1;2;3;1;1;2;3;1;4;1;1;1;1;2;3;1;2;3;4;5;6;7;1;2;3;1;2;1;1;2;3;2;1;5;1;1;2;3;6;7;8;1;2;3;4;5;6;4;2;3;4;2;5;6;7;1;1;1;2;3;4;5;6;7;1;1;2;3;1;1;2;3;4;1;1;2;8;9;10;1;1;1;2;3;4;5;6;4;4;1;2;3;3;4;5;3;3;1;7;8;9;6;7;1;8;9;10;2;1;1;4;5;6;7;8;9;6;7;8;5;6;7;8;9;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;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;6;7;8;5;1;1;1;2;3;1;2;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;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;1;2;1;2;2;1;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;2;3;4;5;6;1;1;1;1;1;1;2;2;1;2;1;2;1;2;1;1;1;1;2;3;3;4;1;1;1;3;4;3;4;4;3;3;4;5;3;4;5;3;4;5;6;7;1;2;3;5;6;7;5;6;7;3;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;2;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;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;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;8;3;4;5;6;7;2;3;4;5;6;7;8;2;3;4;5;6;7;8;9;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;2;2;3;2;2;3;4;5;6;6;7;8;2;3;3;4;4;5;6;4;5;6;4;5;5;6;7;5;6;7;7;8;9;5;6;2;3;4;5;2;3;4;2;3;4;3;4;5;6;1;7;1;2;3;2;2;3;3;4;5;2;3;4;5;4;2;3;2;3;2;3;2;3;4;2;2;2;2;6;7;8;1;2;3;4;5;9;10;2;2;1;1;1;1;1;2;3;4;4;5;5;6;7;8;9;3;4;5;5;6;6;7;3;4;7;8;2;3;3;4;5;4;5;6;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;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;|] + [|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;1;2;2;1;2;2;1;1;2;1;1;1;1;1;1;2;3;4;1;1;5;6;6;1;1;2;1;2;3;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;1;4;5;1;1;1;1;1;2;1;2;3;1;1;1;2;2;3;4;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;1;1;1;2;3;4;1;2;3;1;2;3;1;1;2;3;3;1;1;4;1;2;1;1;1;2;3;1;2;3;1;1;1;1;2;1;2;3;1;4;1;1;2;1;1;2;3;1;1;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;2;1;1;2;3;1;4;1;1;1;1;1;2;3;2;3;2;1;2;3;2;1;2;3;4;3;3;3;1;1;3;4;2;3;1;2;1;3;4;2;3;5;1;2;1;2;3;2;3;4;5;3;4;3;4;4;5;6;2;1;2;2;1;1;2;3;1;1;2;1;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;1;2;3;2;3;2;3;3;4;5;2;3;2;3;2;4;4;5;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;2;3;1;2;1;2;3;4;1;5;2;1;2;3;1;2;4;5;4;5;6;2;3;4;5;1;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;4;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;2;3;1;2;3;1;2;3;1;2;3;1;1;2;1;2;3;1;1;1;2;4;1;2;5;6;1;2;3;4;2;3;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;2;3;4;1;1;1;2;3;1;2;1;2;3;4;4;5;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;1;2;1;2;3;1;2;1;2;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;2;3;2;3;4;5;1;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;1;2;1;2;3;4;1;2;3;4;5;1;2;6;1;2;7;2;3;4;5;1;2;1;2;3;4;6;7;1;2;3;4;5;6;1;2;8;4;5;6;1;2;1;2;1;2;3;4;5;1;2;3;4;5;1;2;3;2;3;6;7;1;2;8;9;1;1;2;3;1;1;2;3;1;4;1;1;1;1;2;3;1;2;3;4;5;6;7;1;2;3;1;2;1;1;2;3;2;1;5;1;1;2;3;6;7;8;1;2;3;4;5;6;4;2;3;4;2;5;6;7;1;1;1;2;3;4;5;6;7;1;1;2;3;1;1;2;3;4;1;1;2;8;9;10;1;1;1;2;3;4;5;6;4;4;1;2;3;3;4;5;3;3;1;7;8;9;6;7;1;8;9;10;2;1;1;4;5;6;7;8;9;6;7;8;5;6;7;8;9;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;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;6;7;8;5;1;1;2;3;1;4;1;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;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;1;2;1;2;2;1;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;2;3;4;5;6;1;1;1;1;1;1;2;2;1;2;1;2;1;2;1;1;1;1;2;3;1;1;1;1;3;4;3;4;3;4;4;3;3;4;5;3;4;5;3;4;5;6;7;1;2;3;5;6;7;5;6;7;3;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;2;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;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;7;3;4;5;2;3;3;2;4;4;5;6;7;8;4;4;5;4;2;3;2;2;3;2;2;3;4;2;2;3;2;3;8;3;4;5;6;7;2;3;4;5;6;7;8;2;3;4;5;6;7;8;9;2;2;2;4;5;2;2;3;4;5;6;7;8;3;4;5;6;7;2;3;4;2;5;6;3;2;2;3;2;2;3;4;5;6;6;7;8;2;3;3;4;4;5;6;4;5;6;4;5;5;6;7;5;6;7;7;8;9;5;6;2;3;4;5;2;3;4;2;3;4;3;4;5;6;1;7;1;2;3;2;2;3;3;4;5;2;3;4;5;4;2;3;2;2;3;2;3;4;2;2;2;2;6;7;8;1;2;3;4;5;9;10;2;2;1;1;1;1;1;2;3;4;4;5;5;6;7;8;9;3;4;5;5;6;6;7;3;4;7;8;2;3;3;4;5;4;5;6;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;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 @@ -494,3070 +504,3093 @@ let can_pop (type a) : a terminal -> bool = function | _ -> false let recover = - let r0 = [R 586] in - let r1 = S (N N_expr) :: r0 in - let r2 = [R 127] 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 282 :: r6 in - let r8 = [R 685] in - let r9 = S (T T_AND) :: r8 in - let r10 = [R 42] in - let r11 = Sub (r9) :: r10 in - let r12 = [R 188] in - let r13 = [R 43] in - let r14 = [R 507] in - let r15 = S (N N_structure) :: r14 in - let r16 = [R 44] in - let r17 = S (T T_RBRACKET) :: r16 in - let r18 = Sub (r15) :: r17 in - let r19 = [R 142] 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 282 :: r23 in - let r25 = [R 653] in - let r26 = [R 346] in - let r27 = [R 123] in - let r28 = Sub (r1) :: r27 in - let r29 = R 282 :: r28 in - let r30 = [R 315] 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 551] in - let r35 = Sub (r33) :: r34 in - let r36 = [R 139] in - let r37 = Sub (r35) :: r36 in - let r38 = S (T T_WITH) :: r37 in - let r39 = Sub (r1) :: r38 in - let r40 = R 282 :: r39 in - let r41 = [R 190] in - let r42 = S (T T_UNDERSCORE) :: r25 in - let r43 = [R 643] in - let r44 = [R 638] in - let r45 = S (T T_END) :: r44 in - let r46 = R 299 :: r45 in - let r47 = R 69 :: r46 in - let r48 = R 282 :: r47 in - let r49 = [R 67] in - let r50 = S (T T_RPAREN) :: r49 in - let r51 = [R 671] in - let r52 = [R 614] in - let r53 = [R 612] in - let r54 = [R 101] in - let r55 = [R 667] in + let r0 = [R 664] in + let r1 = S (T T_UNDERSCORE) :: r0 in + let r2 = [R 147] in + let r3 = Sub (r1) :: r2 in + let r4 = [R 205] in + let r5 = Sub (r3) :: r4 in + let r6 = [R 599] in + let r7 = Sub (r5) :: r6 in + let r8 = [R 130] in + let r9 = S (T T_DONE) :: r8 in + let r10 = Sub (r7) :: r9 in + let r11 = S (T T_DO) :: r10 in + let r12 = Sub (r7) :: r11 in + let r13 = R 289 :: r12 in + let r14 = [R 696] in + let r15 = S (T T_AND) :: r14 in + let r16 = [R 32] in + let r17 = Sub (r15) :: r16 in + let r18 = [R 136] in + let r19 = [R 33] in + let r20 = [R 518] in + let r21 = S (N N_structure) :: r20 in + let r22 = [R 34] in + let r23 = Sub (r21) :: r22 in + let r24 = [R 35] in + let r25 = S (T T_RBRACKET) :: r24 in + let r26 = Sub (r23) :: r25 in + let r27 = [R 157] in + let r28 = S (T T_DONE) :: r27 in + let r29 = Sub (r7) :: r28 in + let r30 = S (T T_DO) :: r29 in + let r31 = Sub (r7) :: r30 in + let r32 = R 289 :: r31 in + let r33 = [R 353] in + let r34 = [R 126] in + let r35 = Sub (r7) :: r34 in + let r36 = R 289 :: r35 in + let r37 = [R 322] in + let r38 = Sub (r7) :: r37 in + let r39 = S (T T_MINUSGREATER) :: r38 in + let r40 = S (N N_pattern) :: r39 in + let r41 = [R 564] in + let r42 = Sub (r40) :: r41 in + let r43 = [R 154] in + let r44 = Sub (r42) :: r43 in + let r45 = S (T T_WITH) :: r44 in + let r46 = Sub (r7) :: r45 in + let r47 = R 289 :: r46 in + let r48 = [R 138] in + let r49 = [R 654] in + let r50 = [R 649] in + let r51 = S (T T_END) :: r50 in + let r52 = R 306 :: r51 in + let r53 = R 60 :: r52 in + let r54 = R 289 :: r53 in + let r55 = [R 58] in let r56 = S (T T_RPAREN) :: r55 in - let r57 = [R 442] in - let r58 = S (T T_AMPERAMPER) :: r57 in - let r59 = [R 799] in - let r60 = S (T T_RPAREN) :: r59 in - let r61 = Sub (r58) :: r60 in - let r62 = [R 368] in - let r63 = S (T T_UNDERSCORE) :: r62 in - let r64 = [R 669] in - let r65 = S (T T_RPAREN) :: r64 in - let r66 = Sub (r63) :: r65 in - let r67 = R 282 :: r66 in - let r68 = [R 670] in - let r69 = S (T T_RPAREN) :: r68 in - let r70 = [R 334] in - let r71 = [R 591] in - let r72 = R 290 :: r71 in - let r73 = [R 370] in - let r74 = S (T T_END) :: r73 in - let r75 = Sub (r72) :: r74 in - let r76 = [R 800] in - let r77 = S (T T_LIDENT) :: r76 in - let r78 = [R 25] in - let r79 = S (T T_UNDERSCORE) :: r78 in - let r80 = [R 773] in - let r81 = Sub (r79) :: r80 in - let r82 = [R 202] in - let r83 = Sub (r81) :: r82 in - let r84 = [R 17] in - let r85 = Sub (r83) :: r84 in - let r86 = [R 117] in + let r57 = [R 682] in + let r58 = [R 625] in + let r59 = [R 623] in + let r60 = [R 92] in + let r61 = [R 678] in + let r62 = S (T T_RPAREN) :: r61 in + let r63 = [R 451] in + let r64 = S (T T_AMPERAMPER) :: r63 in + let r65 = [R 809] in + let r66 = S (T T_RPAREN) :: r65 in + let r67 = Sub (r64) :: r66 in + let r68 = [R 375] in + let r69 = S (T T_UNDERSCORE) :: r68 in + let r70 = [R 680] in + let r71 = S (T T_RPAREN) :: r70 in + let r72 = Sub (r69) :: r71 in + let r73 = R 289 :: r72 in + let r74 = [R 681] in + let r75 = S (T T_RPAREN) :: r74 in + let r76 = [R 341] in + let r77 = [R 602] in + let r78 = R 297 :: r77 in + let r79 = [R 377] in + let r80 = S (T T_END) :: r79 in + let r81 = Sub (r78) :: r80 in + let r82 = [R 810] in + let r83 = S (T T_LIDENT) :: r82 in + let r84 = [R 31] in + let r85 = S (T T_UNDERSCORE) :: r84 in + let r86 = [R 783] in let r87 = Sub (r85) :: r86 in - let r88 = [R 512] in + let r88 = [R 209] in let r89 = Sub (r87) :: r88 in - let r90 = [R 808] in - let r91 = R 288 :: r90 in - let r92 = Sub (r89) :: r91 in - let r93 = S (T T_COLON) :: r92 in - let r94 = Sub (r77) :: r93 in - let r95 = R 282 :: r94 in - let r96 = [R 416] in - let r97 = S (T T_RPAREN) :: r96 in - let r98 = R 224 :: r97 in - let r99 = [R 225] in - let r100 = [R 418] in - let r101 = S (T T_RBRACKET) :: r100 in - let r102 = [R 420] in - let r103 = S (T T_RBRACE) :: r102 in - let r104 = [R 222] in - let r105 = S (T T_LIDENT) :: r104 in - let r106 = [R 24] in - let r107 = Sub (r105) :: r106 in - let r108 = [R 549] in - let r109 = [R 465] in - let r110 = S (T T_COLON) :: r109 in - let r111 = [R 23] in - let r112 = S (T T_RPAREN) :: r111 in - let r113 = S (N N_module_type) :: r112 in - let r114 = R 282 :: r113 in - let r115 = R 187 :: r114 in - let r116 = [R 372] in - let r117 = S (N N_module_expr) :: r116 in - let r118 = R 282 :: r117 in - let r119 = S (T T_OF) :: r118 in - let r120 = [R 358] in - let r121 = S (T T_END) :: r120 in - let r122 = S (N N_structure) :: r121 in - let r123 = [R 332] in - let r124 = S (T T_LIDENT) :: r123 in - let r125 = [R 780] in - let r126 = Sub (r124) :: r125 in - let r127 = [R 102] in - let r128 = S (T T_FALSE) :: r127 in - let r129 = [R 106] in - let r130 = Sub (r128) :: r129 in - let r131 = [R 216] in - let r132 = R 282 :: r131 in - let r133 = R 209 :: r132 in - let r134 = Sub (r130) :: r133 in - let r135 = [R 532] in + let r90 = [R 17] in + let r91 = Sub (r89) :: r90 in + let r92 = [R 108] in + let r93 = Sub (r91) :: r92 in + let r94 = [R 523] in + let r95 = Sub (r93) :: r94 in + let r96 = [R 818] in + let r97 = R 295 :: r96 in + let r98 = Sub (r95) :: r97 in + let r99 = S (T T_COLON) :: r98 in + let r100 = Sub (r83) :: r99 in + let r101 = R 289 :: r100 in + let r102 = [R 425] in + let r103 = S (T T_RPAREN) :: r102 in + let r104 = R 231 :: r103 in + let r105 = [R 232] in + let r106 = [R 427] in + let r107 = S (T T_RBRACKET) :: r106 in + let r108 = [R 429] in + let r109 = S (T T_RBRACE) :: r108 in + let r110 = [R 229] in + let r111 = S (T T_LIDENT) :: r110 in + let r112 = [R 30] in + let r113 = Sub (r111) :: r112 in + let r114 = [R 562] in + let r115 = [R 476] in + let r116 = S (T T_COLON) :: r115 in + let r117 = [R 114] in + let r118 = S (T T_RPAREN) :: r117 in + let r119 = S (N N_module_type) :: r118 in + let r120 = R 289 :: r119 in + let r121 = R 135 :: r120 in + let r122 = [R 379] in + let r123 = S (N N_module_expr) :: r122 in + let r124 = R 289 :: r123 in + let r125 = S (T T_OF) :: r124 in + let r126 = [R 365] in + let r127 = S (T T_END) :: r126 in + let r128 = S (N N_structure) :: r127 in + let r129 = [R 339] in + let r130 = S (T T_LIDENT) :: r129 in + let r131 = [R 790] in + let r132 = Sub (r130) :: r131 in + let r133 = [R 93] in + let r134 = S (T T_FALSE) :: r133 in + let r135 = [R 97] in let r136 = Sub (r134) :: r135 in - let r137 = [R 748] in - let r138 = R 288 :: r137 in - let r139 = Sub (r136) :: r138 in - let r140 = R 518 :: r139 in - let r141 = S (T T_PLUSEQ) :: r140 in - let r142 = Sub (r126) :: r141 in - let r143 = R 782 :: r142 in - let r144 = R 282 :: r143 in - let r145 = [R 219] in - let r146 = R 288 :: r145 in - let r147 = R 541 :: r146 in - let r148 = R 778 :: r147 in - let r149 = S (T T_LIDENT) :: r148 in - let r150 = R 782 :: r149 in - let r151 = R 282 :: r150 in - let r152 = R 187 :: r151 in - let r153 = [R 749] in - let r154 = R 288 :: r153 in - let r155 = Sub (r136) :: r154 in - let r156 = R 518 :: r155 in - let r157 = S (T T_PLUSEQ) :: r156 in - let r158 = Sub (r126) :: r157 in - let r159 = [R 220] in - let r160 = R 288 :: r159 in - let r161 = R 541 :: r160 in - let r162 = R 778 :: r161 in - let r163 = S (T T_LIDENT) :: r162 in - let r164 = R 782 :: r163 in - let r165 = [R 786] in - let r166 = S (T T_UNDERSCORE) :: r165 in - let r167 = [R 781] in - let r168 = Sub (r166) :: r167 in - let r169 = R 787 :: r168 in - let r170 = [R 562] in - let r171 = Sub (r169) :: r170 in - let r172 = [R 784] in - let r173 = S (T T_RPAREN) :: r172 in - let r174 = [R 785] in - let r175 = [R 563] in - let r176 = [R 401] in - let r177 = S (T T_DOTDOT) :: r176 in - let r178 = [R 779] in - let r179 = [R 402] in - let r180 = [R 105] in - let r181 = S (T T_RPAREN) :: r180 in - let r182 = [R 204] in - let r183 = Sub (r83) :: r182 in - let r184 = S (T T_MINUSGREATER) :: r183 in - let r185 = Sub (r81) :: r184 in - let r186 = [R 30] in - let r187 = [R 514] in - let r188 = Sub (r85) :: r187 in - let r189 = [R 322] in - let r190 = R 282 :: r189 in - let r191 = Sub (r188) :: r190 in - let r192 = [R 189] in - let r193 = S (T T_RBRACKET) :: r192 in - let r194 = Sub (r15) :: r193 in - let r195 = [R 294] in - let r196 = [R 409] in - let r197 = R 288 :: r196 in - let r198 = S (N N_module_expr) :: r197 in - let r199 = R 282 :: r198 in - let r200 = [R 410] in - let r201 = R 288 :: r200 in - let r202 = S (N N_module_expr) :: r201 in - let r203 = R 282 :: r202 in - let r204 = [R 467] in - let r205 = S (T T_RPAREN) :: r204 in - let r206 = [R 468] in - let r207 = S (T T_RPAREN) :: r206 in - let r208 = S (N N_expr) :: r207 in - let r209 = [R 344] in - let r210 = S (T T_LIDENT) :: r209 in - let r211 = [R 66] in - let r212 = Sub (r210) :: r211 in - let r213 = [R 635] in - let r214 = Sub (r212) :: r213 in - let r215 = R 282 :: r214 in - let r216 = [R 345] in - let r217 = S (T T_LIDENT) :: r216 in - let r218 = [R 347] in - let r219 = [R 352] in - let r220 = [R 283] in - let r221 = [R 122] in - let r222 = Sub (r35) :: r221 in - let r223 = S (T T_WITH) :: r222 in - let r224 = Sub (r1) :: r223 in - let r225 = R 282 :: r224 in - let r226 = [R 138] in - let r227 = Sub (r35) :: r226 in - let r228 = S (T T_WITH) :: r227 in - let r229 = Sub (r1) :: r228 in - let r230 = R 282 :: r229 in - let r231 = [R 622] in - let r232 = S (T T_RPAREN) :: r231 in - let r233 = [R 658] in - let r234 = [R 175] in - let r235 = [R 252] in - let r236 = Sub (r77) :: r235 in - let r237 = [R 312] in - let r238 = R 288 :: r237 in - let r239 = Sub (r236) :: r238 in - let r240 = R 525 :: r239 in - let r241 = R 282 :: r240 in - let r242 = [R 619] in - let r243 = [R 100] in - let r244 = [R 580] in - let r245 = S (N N_pattern) :: r244 in - let r246 = [R 617] in - let r247 = S (T T_RBRACKET) :: r246 in - let r248 = [R 236] in - let r249 = Sub (r210) :: r248 in - let r250 = [R 308] in - let r251 = R 458 :: r250 in - let r252 = R 452 :: r251 in - let r253 = Sub (r249) :: r252 in - let r254 = [R 616] in - let r255 = S (T T_RBRACE) :: r254 in - let r256 = [R 453] in - let r257 = [R 573] in - let r258 = Sub (r87) :: r257 in - let r259 = [R 558] in - let r260 = Sub (r258) :: r259 in - let r261 = [R 39] in - let r262 = S (T T_RBRACKET) :: r261 in - let r263 = Sub (r260) :: r262 in - let r264 = [R 38] in - let r265 = [R 37] in - let r266 = S (T T_RBRACKET) :: r265 in - let r267 = [R 390] in - let r268 = Sub (r105) :: r267 in - let r269 = S (T T_BACKQUOTE) :: r268 in - let r270 = [R 761] in - let r271 = R 282 :: r270 in + let r137 = [R 223] in + let r138 = R 289 :: r137 in + let r139 = R 216 :: r138 in + let r140 = Sub (r136) :: r139 in + let r141 = [R 543] in + let r142 = Sub (r140) :: r141 in + let r143 = [R 758] in + let r144 = R 295 :: r143 in + let r145 = Sub (r142) :: r144 in + let r146 = R 529 :: r145 in + let r147 = S (T T_PLUSEQ) :: r146 in + let r148 = Sub (r132) :: r147 in + let r149 = R 792 :: r148 in + let r150 = R 289 :: r149 in + let r151 = [R 226] in + let r152 = R 295 :: r151 in + let r153 = R 552 :: r152 in + let r154 = R 788 :: r153 in + let r155 = S (T T_LIDENT) :: r154 in + let r156 = R 792 :: r155 in + let r157 = R 289 :: r156 in + let r158 = R 135 :: r157 in + let r159 = [R 759] in + let r160 = R 295 :: r159 in + let r161 = Sub (r142) :: r160 in + let r162 = R 529 :: r161 in + let r163 = S (T T_PLUSEQ) :: r162 in + let r164 = Sub (r132) :: r163 in + let r165 = [R 227] in + let r166 = R 295 :: r165 in + let r167 = R 552 :: r166 in + let r168 = R 788 :: r167 in + let r169 = S (T T_LIDENT) :: r168 in + let r170 = R 792 :: r169 in + let r171 = [R 796] in + let r172 = S (T T_UNDERSCORE) :: r171 in + let r173 = [R 791] in + let r174 = Sub (r172) :: r173 in + let r175 = R 797 :: r174 in + let r176 = [R 575] in + let r177 = Sub (r175) :: r176 in + let r178 = [R 794] in + let r179 = S (T T_RPAREN) :: r178 in + let r180 = [R 795] in + let r181 = [R 576] in + let r182 = [R 408] in + let r183 = S (T T_DOTDOT) :: r182 in + let r184 = [R 789] in + let r185 = [R 409] in + let r186 = [R 96] in + let r187 = S (T T_RPAREN) :: r186 in + let r188 = [R 211] in + let r189 = Sub (r89) :: r188 in + let r190 = S (T T_MINUSGREATER) :: r189 in + let r191 = Sub (r87) :: r190 in + let r192 = [R 417] in + let r193 = [R 525] in + let r194 = Sub (r91) :: r193 in + let r195 = [R 329] in + let r196 = R 289 :: r195 in + let r197 = Sub (r194) :: r196 in + let r198 = [R 137] in + let r199 = S (T T_RBRACKET) :: r198 in + let r200 = Sub (r21) :: r199 in + let r201 = [R 301] in + let r202 = [R 418] in + let r203 = R 295 :: r202 in + let r204 = S (N N_module_expr) :: r203 in + let r205 = R 289 :: r204 in + let r206 = [R 419] in + let r207 = R 295 :: r206 in + let r208 = S (N N_module_expr) :: r207 in + let r209 = R 289 :: r208 in + let r210 = [R 478] in + let r211 = S (T T_RPAREN) :: r210 in + let r212 = [R 479] in + let r213 = S (T T_RPAREN) :: r212 in + let r214 = S (N N_expr) :: r213 in + let r215 = [R 351] in + let r216 = S (T T_LIDENT) :: r215 in + let r217 = [R 57] in + let r218 = Sub (r216) :: r217 in + let r219 = [R 646] in + let r220 = Sub (r218) :: r219 in + let r221 = R 289 :: r220 in + let r222 = [R 352] in + let r223 = S (T T_LIDENT) :: r222 in + let r224 = [R 354] in + let r225 = [R 359] in + let r226 = [R 290] in + let r227 = [R 125] in + let r228 = Sub (r42) :: r227 in + let r229 = S (T T_WITH) :: r228 in + let r230 = Sub (r7) :: r229 in + let r231 = R 289 :: r230 in + let r232 = [R 153] in + let r233 = Sub (r42) :: r232 in + let r234 = S (T T_WITH) :: r233 in + let r235 = Sub (r7) :: r234 in + let r236 = R 289 :: r235 in + let r237 = [R 647] in + let r238 = S (T T_RPAREN) :: r237 in + let r239 = S (N N_module_expr) :: r238 in + let r240 = R 289 :: r239 in + let r241 = R 135 :: r240 in + let r242 = [R 669] in + let r243 = [R 190] in + let r244 = [R 259] in + let r245 = Sub (r83) :: r244 in + let r246 = [R 319] in + let r247 = R 295 :: r246 in + let r248 = Sub (r245) :: r247 in + let r249 = R 536 :: r248 in + let r250 = R 289 :: r249 in + let r251 = [R 630] in + let r252 = [R 91] in + let r253 = [R 593] in + let r254 = S (N N_pattern) :: r253 in + let r255 = [R 628] in + let r256 = S (T T_RBRACKET) :: r255 in + let r257 = [R 243] in + let r258 = Sub (r216) :: r257 in + let r259 = [R 315] in + let r260 = R 469 :: r259 in + let r261 = R 463 :: r260 in + let r262 = Sub (r258) :: r261 in + let r263 = [R 627] in + let r264 = S (T T_RBRACE) :: r263 in + let r265 = [R 464] in + let r266 = [R 586] in + let r267 = Sub (r93) :: r266 in + let r268 = [R 571] in + let r269 = Sub (r267) :: r268 in + let r270 = [R 120] in + let r271 = S (T T_RBRACKET) :: r270 in let r272 = Sub (r269) :: r271 in - let r273 = [R 34] in + let r273 = [R 119] in let r274 = S (T T_RBRACKET) :: r273 in - let r275 = [R 95] in - let r276 = Sub (r124) :: r275 in - let r277 = [R 31] in - let r278 = [R 335] in - let r279 = S (T T_UIDENT) :: r278 in - let r280 = S (T T_DOT) :: r279 in - let r281 = [R 333] in - let r282 = S (T T_LIDENT) :: r281 in - let r283 = S (T T_UIDENT) :: r70 in - let r284 = [R 350] in - let r285 = Sub (r283) :: r284 in - let r286 = [R 351] in - let r287 = S (T T_RPAREN) :: r286 in - let r288 = [R 35] in - let r289 = S (T T_RBRACKET) :: r288 in - let r290 = [R 205] in - let r291 = [R 570] in - let r292 = [R 32] in - let r293 = [R 203] in - let r294 = Sub (r83) :: r293 in - let r295 = S (T T_MINUSGREATER) :: r294 in - let r296 = [R 571] in - let r297 = [R 559] in - let r298 = [R 554] in - let r299 = Sub (r85) :: r298 in - let r300 = [R 760] in - let r301 = R 282 :: r300 in - let r302 = Sub (r299) :: r301 in - let r303 = [R 555] in - let r304 = [R 18] in - let r305 = Sub (r105) :: r304 in - let r306 = [R 36] in - let r307 = S (T T_RBRACKET) :: r306 in - let r308 = Sub (r260) :: r307 in - let r309 = [R 547] in - let r310 = Sub (r269) :: r309 in - let r311 = [R 40] in - let r312 = S (T T_RBRACKET) :: r311 in - let r313 = [R 459] in - let r314 = S (T T_UNDERSCORE) :: r51 in - let r315 = [R 666] in - let r316 = Sub (r314) :: r315 in - let r317 = [R 498] in - let r318 = Sub (r316) :: r317 in - let r319 = R 282 :: r318 in - let r320 = [R 96] in - let r321 = [R 676] in - let r322 = S (T T_INT) :: r320 in - let r323 = [R 611] in - let r324 = Sub (r322) :: r323 in - let r325 = [R 673] in - let r326 = [R 678] in + let r275 = [R 118] in + let r276 = S (T T_RBRACKET) :: r275 in + let r277 = [R 397] in + let r278 = Sub (r111) :: r277 in + let r279 = S (T T_BACKQUOTE) :: r278 in + let r280 = [R 771] in + let r281 = R 289 :: r280 in + let r282 = Sub (r279) :: r281 in + let r283 = [R 115] in + let r284 = S (T T_RBRACKET) :: r283 in + let r285 = [R 86] in + let r286 = Sub (r130) :: r285 in + let r287 = [R 26] in + let r288 = [R 340] in + let r289 = S (T T_LIDENT) :: r288 in + let r290 = S (T T_DOT) :: r289 in + let r291 = S (T T_UIDENT) :: r76 in + let r292 = [R 357] in + let r293 = Sub (r291) :: r292 in + let r294 = [R 358] in + let r295 = S (T T_RPAREN) :: r294 in + let r296 = [R 342] in + let r297 = S (T T_UIDENT) :: r296 in + let r298 = [R 116] in + let r299 = S (T T_RBRACKET) :: r298 in + let r300 = [R 212] in + let r301 = [R 583] in + let r302 = S (T T_DOT) :: r297 in + let r303 = S (T T_LBRACKETGREATER) :: r274 in + let r304 = [R 29] in + let r305 = Sub (r303) :: r304 in + let r306 = [R 210] in + let r307 = Sub (r89) :: r306 in + let r308 = S (T T_MINUSGREATER) :: r307 in + let r309 = [R 584] in + let r310 = [R 27] in + let r311 = [R 113] in + let r312 = [R 18] in + let r313 = Sub (r111) :: r312 in + let r314 = [R 572] in + let r315 = [R 567] in + let r316 = Sub (r91) :: r315 in + let r317 = [R 770] in + let r318 = R 289 :: r317 in + let r319 = Sub (r316) :: r318 in + let r320 = [R 568] in + let r321 = [R 117] in + let r322 = S (T T_RBRACKET) :: r321 in + let r323 = Sub (r269) :: r322 in + let r324 = [R 560] in + let r325 = Sub (r279) :: r324 in + let r326 = [R 121] in let r327 = S (T T_RBRACKET) :: r326 in - let r328 = S (T T_LBRACKET) :: r327 in - let r329 = [R 679] in - let r330 = [R 489] in - let r331 = S (N N_pattern) :: r330 in - let r332 = R 282 :: r331 in - let r333 = [R 490] in - let r334 = [R 483] in - let r335 = [R 497] in - let r336 = [R 495] in - let r337 = [R 391] in - let r338 = S (T T_LIDENT) :: r337 in - let r339 = [R 496] in - let r340 = Sub (r316) :: r339 in - let r341 = S (T T_RPAREN) :: r340 in - let r342 = [R 110] in - let r343 = [R 109] in - let r344 = S (T T_RPAREN) :: r343 in - let r345 = [R 491] in - let r346 = [R 681] in - let r347 = S (T T_RPAREN) :: r346 in - let r348 = [R 488] in - let r349 = [R 486] in - let r350 = [R 108] in - let r351 = S (T T_RPAREN) :: r350 in - let r352 = [R 680] in - let r353 = [R 310] in - let r354 = [R 618] in - let r355 = [R 248] in - let r356 = [R 234] in - let r357 = S (T T_LIDENT) :: r356 in - let r358 = [R 247] in + let r328 = [R 470] in + let r329 = S (T T_UNDERSCORE) :: r57 in + let r330 = [R 677] in + let r331 = Sub (r329) :: r330 in + let r332 = [R 509] in + let r333 = Sub (r331) :: r332 in + let r334 = R 289 :: r333 in + let r335 = [R 87] in + let r336 = [R 687] in + let r337 = S (T T_INT) :: r335 in + let r338 = [R 622] in + let r339 = Sub (r337) :: r338 in + let r340 = [R 684] in + let r341 = [R 689] in + let r342 = S (T T_RBRACKET) :: r341 in + let r343 = S (T T_LBRACKET) :: r342 in + let r344 = [R 690] in + let r345 = [R 500] in + let r346 = S (N N_pattern) :: r345 in + let r347 = R 289 :: r346 in + let r348 = [R 501] in + let r349 = [R 494] in + let r350 = [R 508] in + let r351 = [R 506] in + let r352 = [R 398] in + let r353 = S (T T_LIDENT) :: r352 in + let r354 = [R 507] in + let r355 = Sub (r331) :: r354 in + let r356 = S (T T_RPAREN) :: r355 in + let r357 = [R 101] in + let r358 = [R 100] in let r359 = S (T T_RPAREN) :: r358 in - let r360 = [R 235] in - let r361 = [R 244] in - let r362 = [R 243] in - let r363 = S (T T_RPAREN) :: r362 in - let r364 = R 460 :: r363 in - let r365 = [R 461] in - let r366 = [R 267] in - let r367 = Sub (r77) :: r366 in - let r368 = [R 270] in - let r369 = Sub (r367) :: r368 in - let r370 = [R 173] in - let r371 = Sub (r1) :: r370 in - let r372 = S (T T_IN) :: r371 in - let r373 = [R 506] in - let r374 = S (T T_UNDERSCORE) :: r373 in - let r375 = [R 246] in - let r376 = [R 245] in - let r377 = S (T T_RPAREN) :: r376 in - let r378 = R 460 :: r377 in - let r379 = [R 265] in - let r380 = [R 736] in - let r381 = Sub (r1) :: r380 in - let r382 = S (T T_EQUAL) :: r381 in - let r383 = [R 196] in + let r360 = [R 502] in + let r361 = [R 692] in + let r362 = S (T T_RPAREN) :: r361 in + let r363 = [R 499] in + let r364 = [R 497] in + let r365 = [R 99] in + let r366 = S (T T_RPAREN) :: r365 in + let r367 = [R 691] in + let r368 = [R 317] in + let r369 = [R 629] in + let r370 = [R 255] in + let r371 = [R 241] in + let r372 = S (T T_LIDENT) :: r371 in + let r373 = [R 254] in + let r374 = S (T T_RPAREN) :: r373 in + let r375 = [R 242] in + let r376 = [R 251] in + let r377 = [R 250] in + let r378 = S (T T_RPAREN) :: r377 in + let r379 = R 471 :: r378 in + let r380 = [R 472] in + let r381 = [R 274] in + let r382 = Sub (r83) :: r381 in + let r383 = [R 277] in let r384 = Sub (r382) :: r383 in - let r385 = [R 738] in - let r386 = Sub (r384) :: r385 in - let r387 = S (T T_RPAREN) :: r386 in - let r388 = Sub (r338) :: r387 in - let r389 = [R 249] in - let r390 = [R 133] in - let r391 = Sub (r1) :: r390 in - let r392 = S (T T_IN) :: r391 in - let r393 = S (N N_module_expr) :: r392 in - let r394 = R 282 :: r393 in - let r395 = R 187 :: r394 in - let r396 = [R 259] in - let r397 = R 288 :: r396 in - let r398 = Sub (r236) :: r397 in - let r399 = R 525 :: r398 in - let r400 = R 282 :: r399 in - let r401 = R 187 :: r400 in - let r402 = [R 134] in - let r403 = Sub (r1) :: r402 in - let r404 = S (T T_IN) :: r403 in - let r405 = S (N N_module_expr) :: r404 in - let r406 = R 282 :: r405 in - let r407 = [R 359] in - let r408 = S (N N_module_expr) :: r407 in - let r409 = S (T T_MINUSGREATER) :: r408 in - let r410 = S (N N_functor_args) :: r409 in - let r411 = [R 206] in - let r412 = [R 207] in - let r413 = S (T T_RPAREN) :: r412 in - let r414 = S (N N_module_type) :: r413 in - let r415 = [R 373] in - let r416 = S (T T_RPAREN) :: r415 in - let r417 = [R 376] in - let r418 = S (N N_module_type) :: r417 in - let r419 = [R 371] in - let r420 = S (N N_module_type) :: r419 in - let r421 = S (T T_MINUSGREATER) :: r420 in - let r422 = S (N N_functor_args) :: r421 in - let r423 = [R 342] in - let r424 = Sub (r105) :: r423 in - let r425 = [R 382] in - let r426 = Sub (r424) :: r425 in - let r427 = [R 821] in + let r385 = [R 188] in + let r386 = Sub (r7) :: r385 in + let r387 = S (T T_IN) :: r386 in + let r388 = [R 517] in + let r389 = S (T T_UNDERSCORE) :: r388 in + let r390 = [R 253] in + let r391 = [R 252] in + let r392 = S (T T_RPAREN) :: r391 in + let r393 = R 471 :: r392 in + let r394 = [R 272] in + let r395 = [R 202] in + let r396 = S (T T_RPAREN) :: r395 in + let r397 = [R 256] in + let r398 = [R 747] in + let r399 = Sub (r7) :: r398 in + let r400 = [R 266] in + let r401 = R 295 :: r400 in + let r402 = Sub (r245) :: r401 in + let r403 = R 536 :: r402 in + let r404 = R 289 :: r403 in + let r405 = R 135 :: r404 in + let r406 = [R 150] in + let r407 = Sub (r7) :: r406 in + let r408 = S (T T_IN) :: r407 in + let r409 = S (N N_module_expr) :: r408 in + let r410 = R 289 :: r409 in + let r411 = R 135 :: r410 in + let r412 = [R 151] in + let r413 = Sub (r7) :: r412 in + let r414 = S (T T_IN) :: r413 in + let r415 = S (N N_module_expr) :: r414 in + let r416 = R 289 :: r415 in + let r417 = [R 366] in + let r418 = S (N N_module_expr) :: r417 in + let r419 = S (T T_MINUSGREATER) :: r418 in + let r420 = S (N N_functor_args) :: r419 in + let r421 = [R 213] in + let r422 = [R 214] in + let r423 = S (T T_RPAREN) :: r422 in + let r424 = S (N N_module_type) :: r423 in + let r425 = [R 380] in + let r426 = S (T T_RPAREN) :: r425 in + let r427 = [R 383] in let r428 = S (N N_module_type) :: r427 in - let r429 = S (T T_EQUAL) :: r428 in - let r430 = Sub (r426) :: r429 in - let r431 = S (T T_TYPE) :: r430 in - let r432 = S (T T_MODULE) :: r431 in - let r433 = [R 556] in - let r434 = Sub (r432) :: r433 in - let r435 = [R 378] in - let r436 = [R 818] in - let r437 = Sub (r85) :: r436 in - let r438 = S (T T_COLONEQUAL) :: r437 in - let r439 = Sub (r249) :: r438 in - let r440 = [R 817] in - let r441 = R 541 :: r440 in - let r442 = [R 542] in - let r443 = Sub (r87) :: r442 in - let r444 = S (T T_EQUAL) :: r443 in - let r445 = [R 343] in - let r446 = Sub (r105) :: r445 in - let r447 = [R 822] in - let r448 = [R 377] in - let r449 = [R 819] in - let r450 = Sub (r285) :: r449 in - let r451 = S (T T_UIDENT) :: r218 in - let r452 = [R 820] in - let r453 = [R 557] in - let r454 = [R 364] in - let r455 = [R 466] in - let r456 = S (T T_RPAREN) :: r455 in - let r457 = [R 574] in - let r458 = S (N N_expr) :: r457 in - let r459 = [R 661] in - let r460 = S (T T_RBRACKET) :: r459 in - let r461 = [R 646] in - let r462 = [R 577] in - let r463 = R 454 :: r462 in - let r464 = [R 455] in - let r465 = [R 583] in - let r466 = R 454 :: r465 in - let r467 = R 462 :: r466 in - let r468 = Sub (r249) :: r467 in - let r469 = [R 527] in - let r470 = Sub (r468) :: r469 in - let r471 = [R 655] in - let r472 = S (T T_RBRACE) :: r471 in - let r473 = [R 621] in - let r474 = [R 620] in - let r475 = S (T T_GREATERDOT) :: r474 in - let r476 = [R 145] in - let r477 = Sub (r42) :: r476 in - let r478 = R 282 :: r477 in - let r479 = [R 634] in - let r480 = S (T T_END) :: r479 in - let r481 = R 282 :: r480 in - let r482 = [R 141] in - let r483 = S (N N_expr) :: r482 in - let r484 = S (T T_THEN) :: r483 in - let r485 = Sub (r1) :: r484 in - let r486 = R 282 :: r485 in - let r487 = [R 135] in - let r488 = Sub (r35) :: r487 in - let r489 = R 282 :: r488 in - let r490 = [R 552] in - let r491 = [R 316] in - let r492 = Sub (r1) :: r491 in - let r493 = S (T T_MINUSGREATER) :: r492 in - let r494 = [R 250] in - let r495 = Sub (r316) :: r494 in - let r496 = [R 198] in - let r497 = Sub (r1) :: r496 in - let r498 = S (T T_MINUSGREATER) :: r497 in - let r499 = [R 136] in - let r500 = Sub (r498) :: r499 in - let r501 = Sub (r495) :: r500 in - let r502 = R 282 :: r501 in - let r503 = [R 137] in - let r504 = Sub (r498) :: r503 in - let r505 = S (T T_RPAREN) :: r504 in - let r506 = [R 129] in - let r507 = S (T T_DONE) :: r506 in - let r508 = Sub (r1) :: r507 in - let r509 = S (T T_DO) :: r508 in - let r510 = Sub (r1) :: r509 in - let r511 = S (T T_IN) :: r510 in - let r512 = S (N N_pattern) :: r511 in - let r513 = R 282 :: r512 in - let r514 = [R 120] in - let r515 = S (T T_DOWNTO) :: r514 in - let r516 = [R 143] in - let r517 = S (T T_DONE) :: r516 in - let r518 = Sub (r1) :: r517 in - let r519 = S (T T_DO) :: r518 in - let r520 = Sub (r1) :: r519 in - let r521 = Sub (r515) :: r520 in - let r522 = Sub (r1) :: r521 in - let r523 = S (T T_EQUAL) :: r522 in - let r524 = S (N N_pattern) :: r523 in - let r525 = R 282 :: r524 in - let r526 = [R 644] in - let r527 = [R 654] in - let r528 = S (T T_RPAREN) :: r527 in - let r529 = S (T T_LPAREN) :: r528 in - let r530 = S (T T_DOT) :: r529 in - let r531 = [R 664] in - let r532 = S (T T_RPAREN) :: r531 in - let r533 = S (N N_module_type) :: r532 in - let r534 = S (T T_COLON) :: r533 in - let r535 = S (N N_module_expr) :: r534 in - let r536 = R 282 :: r535 in - let r537 = [R 268] in - let r538 = Sub (r1) :: r537 in - let r539 = S (T T_EQUAL) :: r538 in - let r540 = [R 144] in - let r541 = Sub (r42) :: r540 in - let r542 = R 282 :: r541 in - let r543 = [R 651] in - let r544 = [R 627] in - let r545 = S (T T_RPAREN) :: r544 in - let r546 = Sub (r458) :: r545 in - let r547 = S (T T_LPAREN) :: r546 in - let r548 = [R 170] in - let r549 = [R 239] in - let r550 = [R 775] in - let r551 = Sub (r87) :: r550 in - let r552 = S (T T_COLON) :: r551 in - let r553 = [R 240] in - let r554 = S (T T_RPAREN) :: r553 in - let r555 = Sub (r552) :: r554 in - let r556 = [R 777] in - let r557 = [R 776] in - let r558 = [R 241] in - let r559 = [R 242] in - let r560 = [R 650] in - let r561 = [R 624] in - let r562 = S (T T_RPAREN) :: r561 in - let r563 = Sub (r1) :: r562 in - let r564 = S (T T_LPAREN) :: r563 in - let r565 = [R 568] in - let r566 = [R 121] in - let r567 = Sub (r1) :: r566 in - let r568 = [R 172] in - let r569 = Sub (r1) :: r568 in - let r570 = [R 160] in - let r571 = [R 154] in - let r572 = [R 171] in - let r573 = [R 589] in - let r574 = Sub (r1) :: r573 in - let r575 = [R 157] in - let r576 = [R 161] in - let r577 = [R 153] in - let r578 = [R 156] in - let r579 = [R 155] in - let r580 = [R 165] in - let r581 = [R 159] in - let r582 = [R 158] in - let r583 = [R 163] in - let r584 = [R 152] in - let r585 = [R 151] in - let r586 = [R 174] in - let r587 = [R 150] in - let r588 = [R 164] in - let r589 = [R 162] in - let r590 = [R 166] in - let r591 = [R 167] in - let r592 = [R 168] in - let r593 = [R 569] in - let r594 = [R 169] in - let r595 = [R 19] in - let r596 = R 288 :: r595 in - let r597 = Sub (r236) :: r596 in - let r598 = [R 258] in - let r599 = Sub (r1) :: r598 in - let r600 = S (T T_EQUAL) :: r599 in - let r601 = [R 257] in - let r602 = Sub (r1) :: r601 in - let r603 = [R 493] in - let r604 = [R 499] in - let r605 = [R 504] in - let r606 = [R 502] in - let r607 = [R 492] in - let r608 = [R 516] in - let r609 = S (T T_RBRACKET) :: r608 in - let r610 = Sub (r15) :: r609 in - let r611 = [R 510] in - let r612 = [R 511] in - let r613 = [R 353] in - let r614 = S (N N_module_expr) :: r613 in - let r615 = S (T T_EQUAL) :: r614 in - let r616 = [R 751] in - let r617 = R 288 :: r616 in - let r618 = Sub (r615) :: r617 in - let r619 = Sub (r63) :: r618 in - let r620 = R 282 :: r619 in - let r621 = [R 380] in - let r622 = R 288 :: r621 in - let r623 = R 456 :: r622 in - let r624 = Sub (r105) :: r623 in - let r625 = R 282 :: r624 in - let r626 = R 187 :: r625 in - let r627 = [R 457] in - let r628 = [R 289] in - let r629 = [R 752] in - let r630 = R 278 :: r629 in - let r631 = R 288 :: r630 in - let r632 = Sub (r615) :: r631 in - let r633 = [R 354] in - let r634 = S (N N_module_expr) :: r633 in - let r635 = S (T T_EQUAL) :: r634 in - let r636 = [R 279] in - let r637 = R 278 :: r636 in - let r638 = R 288 :: r637 in - let r639 = Sub (r615) :: r638 in - let r640 = Sub (r63) :: r639 in - let r641 = [R 355] in - let r642 = [R 227] in - let r643 = S (T T_RBRACKET) :: r642 in - let r644 = Sub (r15) :: r643 in - let r645 = [R 193] in - let r646 = S (T T_RBRACKET) :: r645 in - let r647 = Sub (r15) :: r646 in - let r648 = [R 757] in - let r649 = R 288 :: r648 in - let r650 = S (N N_module_expr) :: r649 in - let r651 = R 282 :: r650 in - let r652 = [R 393] in - let r653 = S (T T_STRING) :: r652 in - let r654 = [R 517] in - let r655 = R 288 :: r654 in - let r656 = Sub (r653) :: r655 in - let r657 = S (T T_EQUAL) :: r656 in - let r658 = Sub (r89) :: r657 in - let r659 = S (T T_COLON) :: r658 in - let r660 = Sub (r77) :: r659 in - let r661 = R 282 :: r660 in - let r662 = [R 513] in - let r663 = Sub (r87) :: r662 in - let r664 = [R 550] in - let r665 = Sub (r128) :: r342 in - let r666 = [R 735] in - let r667 = R 288 :: r666 in - let r668 = R 282 :: r667 in - let r669 = Sub (r665) :: r668 in - let r670 = S (T T_EQUAL) :: r669 in - let r671 = Sub (r130) :: r670 in - let r672 = R 282 :: r671 in - let r673 = [R 590] in - let r674 = R 288 :: r673 in - let r675 = R 282 :: r674 in - let r676 = R 209 :: r675 in - let r677 = Sub (r130) :: r676 in - let r678 = R 282 :: r677 in - let r679 = R 187 :: r678 in - let r680 = [R 112] in - let r681 = Sub (r79) :: r680 in - let r682 = [R 210] in - let r683 = [R 229] in - let r684 = R 282 :: r683 in - let r685 = Sub (r188) :: r684 in - let r686 = S (T T_COLON) :: r685 in - let r687 = S (T T_LIDENT) :: r686 in - let r688 = R 383 :: r687 in - let r689 = [R 231] in - let r690 = Sub (r688) :: r689 in - let r691 = [R 114] in - let r692 = S (T T_RBRACE) :: r691 in - let r693 = [R 230] in - let r694 = R 282 :: r693 in - let r695 = S (T T_SEMI) :: r694 in - let r696 = R 282 :: r695 in - let r697 = Sub (r188) :: r696 in - let r698 = S (T T_COLON) :: r697 in - let r699 = [R 515] in - let r700 = Sub (r85) :: r699 in - let r701 = [R 113] in - let r702 = Sub (r79) :: r701 in - let r703 = S (T T_COLONCOLON) :: r351 in - let r704 = [R 213] in - let r705 = [R 214] in - let r706 = Sub (r79) :: r705 in - let r707 = [R 212] in - let r708 = Sub (r79) :: r707 in - let r709 = [R 211] in - let r710 = Sub (r79) :: r709 in - let r711 = [R 508] in - let r712 = [R 538] in - let r713 = Sub (r134) :: r712 in - let r714 = [R 598] in - let r715 = R 288 :: r714 in - let r716 = Sub (r713) :: r715 in - let r717 = R 518 :: r716 in - let r718 = S (T T_PLUSEQ) :: r717 in - let r719 = Sub (r126) :: r718 in - let r720 = R 782 :: r719 in - let r721 = R 282 :: r720 in - let r722 = [R 599] in - let r723 = R 288 :: r722 in - let r724 = Sub (r713) :: r723 in - let r725 = R 518 :: r724 in - let r726 = S (T T_PLUSEQ) :: r725 in - let r727 = Sub (r126) :: r726 in - let r728 = [R 218] in - let r729 = R 288 :: r728 in - let r730 = R 541 :: r729 in - let r731 = [R 405] in - let r732 = S (T T_RBRACE) :: r731 in - let r733 = [R 215] in - let r734 = R 282 :: r733 in - let r735 = R 209 :: r734 in - let r736 = Sub (r130) :: r735 in - let r737 = [R 403] in - let r738 = [R 404] in - let r739 = [R 408] in - let r740 = S (T T_RBRACE) :: r739 in - let r741 = [R 407] in - let r742 = S (T T_RBRACE) :: r741 in - let r743 = [R 217] in - let r744 = R 288 :: r743 in - let r745 = R 541 :: r744 in - let r746 = [R 291] in - let r747 = [R 411] in - let r748 = R 288 :: r747 in - let r749 = Sub (r285) :: r748 in - let r750 = R 282 :: r749 in - let r751 = [R 412] in - let r752 = R 288 :: r751 in - let r753 = Sub (r285) :: r752 in - let r754 = R 282 :: r753 in - let r755 = [R 356] in - let r756 = S (N N_module_type) :: r755 in - let r757 = S (T T_COLON) :: r756 in - let r758 = [R 601] in - let r759 = R 288 :: r758 in - let r760 = Sub (r757) :: r759 in - let r761 = Sub (r63) :: r760 in - let r762 = R 282 :: r761 in - let r763 = [R 381] in - let r764 = R 288 :: r763 in - let r765 = S (N N_module_type) :: r764 in - let r766 = S (T T_COLONEQUAL) :: r765 in - let r767 = Sub (r105) :: r766 in - let r768 = R 282 :: r767 in - let r769 = [R 369] in - let r770 = R 288 :: r769 in - let r771 = [R 604] in - let r772 = R 280 :: r771 in - let r773 = R 288 :: r772 in - let r774 = S (N N_module_type) :: r773 in - let r775 = S (T T_COLON) :: r774 in - let r776 = [R 281] in - let r777 = R 280 :: r776 in - let r778 = R 288 :: r777 in - let r779 = S (N N_module_type) :: r778 in - let r780 = S (T T_COLON) :: r779 in - let r781 = Sub (r63) :: r780 in - let r782 = S (T T_UIDENT) :: r26 in - let r783 = Sub (r782) :: r219 in - let r784 = [R 602] in - let r785 = R 288 :: r784 in - let r786 = [R 357] in - let r787 = [R 608] in - let r788 = R 288 :: r787 in + let r429 = [R 378] in + let r430 = S (N N_module_type) :: r429 in + let r431 = S (T T_MINUSGREATER) :: r430 in + let r432 = S (N N_functor_args) :: r431 in + let r433 = [R 349] in + let r434 = Sub (r111) :: r433 in + let r435 = [R 389] in + let r436 = Sub (r434) :: r435 in + let r437 = [R 831] in + let r438 = S (N N_module_type) :: r437 in + let r439 = S (T T_EQUAL) :: r438 in + let r440 = Sub (r436) :: r439 in + let r441 = S (T T_TYPE) :: r440 in + let r442 = S (T T_MODULE) :: r441 in + let r443 = [R 569] in + let r444 = Sub (r442) :: r443 in + let r445 = [R 385] in + let r446 = [R 828] in + let r447 = Sub (r91) :: r446 in + let r448 = S (T T_COLONEQUAL) :: r447 in + let r449 = Sub (r258) :: r448 in + let r450 = [R 827] in + let r451 = R 552 :: r450 in + let r452 = [R 553] in + let r453 = Sub (r93) :: r452 in + let r454 = S (T T_EQUAL) :: r453 in + let r455 = [R 350] in + let r456 = Sub (r111) :: r455 in + let r457 = [R 832] in + let r458 = [R 384] in + let r459 = [R 829] in + let r460 = Sub (r293) :: r459 in + let r461 = S (T T_UIDENT) :: r224 in + let r462 = [R 830] in + let r463 = [R 570] in + let r464 = [R 371] in + let r465 = [R 477] in + let r466 = S (T T_RPAREN) :: r465 in + let r467 = [R 587] in + let r468 = S (N N_expr) :: r467 in + let r469 = [R 672] in + let r470 = S (T T_RBRACKET) :: r469 in + let r471 = [R 657] in + let r472 = [R 590] in + let r473 = R 465 :: r472 in + let r474 = [R 466] in + let r475 = [R 596] in + let r476 = R 465 :: r475 in + let r477 = R 473 :: r476 in + let r478 = Sub (r258) :: r477 in + let r479 = [R 538] in + let r480 = Sub (r478) :: r479 in + let r481 = [R 666] in + let r482 = S (T T_RBRACE) :: r481 in + let r483 = [R 632] in + let r484 = [R 631] in + let r485 = S (T T_GREATERDOT) :: r484 in + let r486 = [R 160] in + let r487 = Sub (r1) :: r486 in + let r488 = R 289 :: r487 in + let r489 = [R 645] in + let r490 = S (T T_END) :: r489 in + let r491 = R 289 :: r490 in + let r492 = [R 156] in + let r493 = S (N N_expr) :: r492 in + let r494 = S (T T_THEN) :: r493 in + let r495 = Sub (r7) :: r494 in + let r496 = R 289 :: r495 in + let r497 = [R 600] in + let r498 = Sub (r42) :: r497 in + let r499 = R 289 :: r498 in + let r500 = [R 565] in + let r501 = [R 323] in + let r502 = Sub (r7) :: r501 in + let r503 = S (T T_MINUSGREATER) :: r502 in + let r504 = [R 257] in + let r505 = Sub (r331) :: r504 in + let r506 = [R 203] in + let r507 = Sub (r505) :: r506 in + let r508 = [R 554] in + let r509 = Sub (r507) :: r508 in + let r510 = [R 204] in + let r511 = Sub (r509) :: r510 in + let r512 = [R 146] in + let r513 = Sub (r5) :: r512 in + let r514 = [R 152] in + let r515 = Sub (r513) :: r514 in + let r516 = S (T T_MINUSGREATER) :: r515 in + let r517 = R 461 :: r516 in + let r518 = Sub (r511) :: r517 in + let r519 = R 289 :: r518 in + let r520 = [R 462] in + let r521 = [R 145] in + let r522 = Sub (r42) :: r521 in + let r523 = R 289 :: r522 in + let r524 = [R 566] in + let r525 = [R 132] in + let r526 = S (T T_DONE) :: r525 in + let r527 = Sub (r7) :: r526 in + let r528 = S (T T_DO) :: r527 in + let r529 = Sub (r7) :: r528 in + let r530 = S (T T_IN) :: r529 in + let r531 = S (N N_pattern) :: r530 in + let r532 = R 289 :: r531 in + let r533 = [R 123] in + let r534 = S (T T_DOWNTO) :: r533 in + let r535 = [R 158] in + let r536 = S (T T_DONE) :: r535 in + let r537 = Sub (r7) :: r536 in + let r538 = S (T T_DO) :: r537 in + let r539 = Sub (r7) :: r538 in + let r540 = Sub (r534) :: r539 in + let r541 = Sub (r7) :: r540 in + let r542 = S (T T_EQUAL) :: r541 in + let r543 = S (N N_pattern) :: r542 in + let r544 = R 289 :: r543 in + let r545 = [R 655] in + let r546 = [R 665] in + let r547 = S (T T_RPAREN) :: r546 in + let r548 = S (T T_LPAREN) :: r547 in + let r549 = S (T T_DOT) :: r548 in + let r550 = [R 675] in + let r551 = S (T T_RPAREN) :: r550 in + let r552 = S (N N_module_type) :: r551 in + let r553 = S (T T_COLON) :: r552 in + let r554 = S (N N_module_expr) :: r553 in + let r555 = R 289 :: r554 in + let r556 = [R 275] in + let r557 = Sub (r7) :: r556 in + let r558 = S (T T_EQUAL) :: r557 in + let r559 = [R 159] in + let r560 = Sub (r1) :: r559 in + let r561 = R 289 :: r560 in + let r562 = [R 662] in + let r563 = [R 638] in + let r564 = S (T T_RPAREN) :: r563 in + let r565 = Sub (r468) :: r564 in + let r566 = S (T T_LPAREN) :: r565 in + let r567 = [R 134] in + let r568 = Sub (r42) :: r567 in + let r569 = R 289 :: r568 in + let r570 = [R 185] in + let r571 = [R 246] in + let r572 = [R 785] in + let r573 = Sub (r93) :: r572 in + let r574 = S (T T_COLON) :: r573 in + let r575 = [R 247] in + let r576 = S (T T_RPAREN) :: r575 in + let r577 = Sub (r574) :: r576 in + let r578 = [R 787] in + let r579 = [R 786] in + let r580 = [R 248] in + let r581 = [R 249] in + let r582 = [R 661] in + let r583 = [R 658] in + let r584 = Sub (r258) :: r583 in + let r585 = [R 635] in + let r586 = S (T T_RPAREN) :: r585 in + let r587 = Sub (r7) :: r586 in + let r588 = [R 581] in + let r589 = [R 124] in + let r590 = Sub (r7) :: r589 in + let r591 = [R 187] in + let r592 = Sub (r7) :: r591 in + let r593 = [R 175] in + let r594 = [R 172] in + let r595 = [R 186] in + let r596 = [R 171] in + let r597 = [R 170] in + let r598 = [R 176] in + let r599 = [R 180] in + let r600 = [R 174] in + let r601 = [R 173] in + let r602 = [R 178] in + let r603 = [R 169] in + let r604 = [R 168] in + let r605 = [R 167] in + let r606 = [R 166] in + let r607 = [R 165] in + let r608 = [R 179] in + let r609 = [R 177] in + let r610 = [R 184] in + let r611 = [R 582] in + let r612 = S (N N_expr) :: r611 in + let r613 = [R 189] in + let r614 = [R 181] in + let r615 = [R 182] in + let r616 = [R 183] in + let r617 = [R 208] in + let r618 = Sub (r7) :: r617 in + let r619 = [R 19] in + let r620 = R 295 :: r619 in + let r621 = Sub (r245) :: r620 in + let r622 = [R 265] in + let r623 = Sub (r7) :: r622 in + let r624 = S (T T_EQUAL) :: r623 in + let r625 = [R 264] in + let r626 = Sub (r7) :: r625 in + let r627 = [R 504] in + let r628 = [R 510] in + let r629 = [R 515] in + let r630 = [R 513] in + let r631 = [R 503] in + let r632 = [R 527] in + let r633 = S (T T_RBRACKET) :: r632 in + let r634 = Sub (r23) :: r633 in + let r635 = [R 521] in + let r636 = [R 522] in + let r637 = [R 360] in + let r638 = S (N N_module_expr) :: r637 in + let r639 = S (T T_EQUAL) :: r638 in + let r640 = [R 761] in + let r641 = R 295 :: r640 in + let r642 = Sub (r639) :: r641 in + let r643 = Sub (r69) :: r642 in + let r644 = R 289 :: r643 in + let r645 = [R 387] in + let r646 = R 295 :: r645 in + let r647 = R 467 :: r646 in + let r648 = Sub (r111) :: r647 in + let r649 = R 289 :: r648 in + let r650 = R 135 :: r649 in + let r651 = [R 468] in + let r652 = [R 296] in + let r653 = [R 762] in + let r654 = R 285 :: r653 in + let r655 = R 295 :: r654 in + let r656 = Sub (r639) :: r655 in + let r657 = [R 361] in + let r658 = S (N N_module_expr) :: r657 in + let r659 = S (T T_EQUAL) :: r658 in + let r660 = [R 286] in + let r661 = R 285 :: r660 in + let r662 = R 295 :: r661 in + let r663 = Sub (r639) :: r662 in + let r664 = Sub (r69) :: r663 in + let r665 = [R 362] in + let r666 = [R 234] in + let r667 = S (T T_RBRACKET) :: r666 in + let r668 = Sub (r21) :: r667 in + let r669 = [R 142] in + let r670 = S (T T_RBRACKET) :: r669 in + let r671 = Sub (r23) :: r670 in + let r672 = [R 767] in + let r673 = R 295 :: r672 in + let r674 = S (N N_module_expr) :: r673 in + let r675 = R 289 :: r674 in + let r676 = [R 400] in + let r677 = S (T T_STRING) :: r676 in + let r678 = [R 528] in + let r679 = R 295 :: r678 in + let r680 = Sub (r677) :: r679 in + let r681 = S (T T_EQUAL) :: r680 in + let r682 = Sub (r95) :: r681 in + let r683 = S (T T_COLON) :: r682 in + let r684 = Sub (r83) :: r683 in + let r685 = R 289 :: r684 in + let r686 = [R 524] in + let r687 = Sub (r93) :: r686 in + let r688 = [R 563] in + let r689 = Sub (r134) :: r357 in + let r690 = [R 746] in + let r691 = R 295 :: r690 in + let r692 = R 289 :: r691 in + let r693 = Sub (r689) :: r692 in + let r694 = S (T T_EQUAL) :: r693 in + let r695 = Sub (r136) :: r694 in + let r696 = R 289 :: r695 in + let r697 = [R 601] in + let r698 = R 295 :: r697 in + let r699 = R 289 :: r698 in + let r700 = R 216 :: r699 in + let r701 = Sub (r136) :: r700 in + let r702 = R 289 :: r701 in + let r703 = R 135 :: r702 in + let r704 = [R 103] in + let r705 = Sub (r85) :: r704 in + let r706 = [R 217] in + let r707 = [R 236] in + let r708 = R 289 :: r707 in + let r709 = Sub (r194) :: r708 in + let r710 = S (T T_COLON) :: r709 in + let r711 = S (T T_LIDENT) :: r710 in + let r712 = R 390 :: r711 in + let r713 = [R 238] in + let r714 = Sub (r712) :: r713 in + let r715 = [R 105] in + let r716 = S (T T_RBRACE) :: r715 in + let r717 = [R 237] in + let r718 = R 289 :: r717 in + let r719 = S (T T_SEMI) :: r718 in + let r720 = R 289 :: r719 in + let r721 = Sub (r194) :: r720 in + let r722 = S (T T_COLON) :: r721 in + let r723 = [R 526] in + let r724 = Sub (r91) :: r723 in + let r725 = [R 104] in + let r726 = Sub (r85) :: r725 in + let r727 = S (T T_COLONCOLON) :: r366 in + let r728 = [R 220] in + let r729 = [R 221] in + let r730 = Sub (r85) :: r729 in + let r731 = [R 219] in + let r732 = Sub (r85) :: r731 in + let r733 = [R 218] in + let r734 = Sub (r85) :: r733 in + let r735 = [R 519] in + let r736 = [R 549] in + let r737 = Sub (r140) :: r736 in + let r738 = [R 609] in + let r739 = R 295 :: r738 in + let r740 = Sub (r737) :: r739 in + let r741 = R 529 :: r740 in + let r742 = S (T T_PLUSEQ) :: r741 in + let r743 = Sub (r132) :: r742 in + let r744 = R 792 :: r743 in + let r745 = R 289 :: r744 in + let r746 = [R 610] in + let r747 = R 295 :: r746 in + let r748 = Sub (r737) :: r747 in + let r749 = R 529 :: r748 in + let r750 = S (T T_PLUSEQ) :: r749 in + let r751 = Sub (r132) :: r750 in + let r752 = [R 225] in + let r753 = R 295 :: r752 in + let r754 = R 552 :: r753 in + let r755 = [R 412] in + let r756 = S (T T_RBRACE) :: r755 in + let r757 = [R 222] in + let r758 = R 289 :: r757 in + let r759 = R 216 :: r758 in + let r760 = Sub (r136) :: r759 in + let r761 = [R 410] in + let r762 = [R 411] in + let r763 = [R 415] in + let r764 = S (T T_RBRACE) :: r763 in + let r765 = [R 414] in + let r766 = S (T T_RBRACE) :: r765 in + let r767 = [R 224] in + let r768 = R 295 :: r767 in + let r769 = R 552 :: r768 in + let r770 = [R 298] in + let r771 = [R 420] in + let r772 = R 295 :: r771 in + let r773 = Sub (r293) :: r772 in + let r774 = R 289 :: r773 in + let r775 = [R 421] in + let r776 = R 295 :: r775 in + let r777 = Sub (r293) :: r776 in + let r778 = R 289 :: r777 in + let r779 = [R 363] in + let r780 = S (N N_module_type) :: r779 in + let r781 = S (T T_COLON) :: r780 in + let r782 = [R 612] in + let r783 = R 295 :: r782 in + let r784 = Sub (r781) :: r783 in + let r785 = Sub (r69) :: r784 in + let r786 = R 289 :: r785 in + let r787 = [R 388] in + let r788 = R 295 :: r787 in let r789 = S (N N_module_type) :: r788 in - let r790 = R 282 :: r789 in - let r791 = S (T T_QUOTED_STRING_EXPR) :: r41 in - let r792 = [R 80] in - let r793 = Sub (r791) :: r792 in - let r794 = [R 90] in - let r795 = Sub (r793) :: r794 in - let r796 = [R 609] in - let r797 = R 274 :: r796 in - let r798 = R 288 :: r797 in - let r799 = Sub (r795) :: r798 in - let r800 = S (T T_COLON) :: r799 in - let r801 = S (T T_LIDENT) :: r800 in - let r802 = R 194 :: r801 in - let r803 = R 809 :: r802 in - let r804 = R 282 :: r803 in - let r805 = [R 94] in - let r806 = R 276 :: r805 in - let r807 = R 288 :: r806 in - let r808 = Sub (r793) :: r807 in - let r809 = S (T T_EQUAL) :: r808 in - let r810 = S (T T_LIDENT) :: r809 in - let r811 = R 194 :: r810 in - let r812 = R 809 :: r811 in - let r813 = R 282 :: r812 in - let r814 = [R 195] in - let r815 = S (T T_RBRACKET) :: r814 in - let r816 = [R 81] in - let r817 = S (T T_END) :: r816 in - let r818 = R 297 :: r817 in - let r819 = R 71 :: r818 in - let r820 = [R 70] in - let r821 = S (T T_RPAREN) :: r820 in - let r822 = [R 73] in - let r823 = R 288 :: r822 in - let r824 = Sub (r87) :: r823 in - let r825 = S (T T_COLON) :: r824 in - let r826 = S (T T_LIDENT) :: r825 in - let r827 = R 385 :: r826 in - let r828 = [R 74] in - let r829 = R 288 :: r828 in - let r830 = Sub (r89) :: r829 in - let r831 = S (T T_COLON) :: r830 in - let r832 = S (T T_LIDENT) :: r831 in - let r833 = R 520 :: r832 in - let r834 = [R 72] in - let r835 = R 288 :: r834 in - let r836 = Sub (r793) :: r835 in - let r837 = [R 83] in - let r838 = Sub (r793) :: r837 in - let r839 = S (T T_IN) :: r838 in - let r840 = Sub (r783) :: r839 in - let r841 = R 282 :: r840 in - let r842 = [R 84] in - let r843 = Sub (r793) :: r842 in - let r844 = S (T T_IN) :: r843 in - let r845 = Sub (r783) :: r844 in - let r846 = [R 560] in - let r847 = Sub (r87) :: r846 in - let r848 = [R 79] in - let r849 = Sub (r276) :: r848 in - let r850 = S (T T_RBRACKET) :: r849 in - let r851 = Sub (r847) :: r850 in - let r852 = [R 561] in - let r853 = [R 111] in - let r854 = Sub (r87) :: r853 in - let r855 = S (T T_EQUAL) :: r854 in - let r856 = Sub (r87) :: r855 in - let r857 = [R 75] in - let r858 = R 288 :: r857 in - let r859 = Sub (r856) :: r858 in - let r860 = [R 76] in - let r861 = [R 298] in - let r862 = [R 277] in - let r863 = R 276 :: r862 in - let r864 = R 288 :: r863 in - let r865 = Sub (r793) :: r864 in - let r866 = S (T T_EQUAL) :: r865 in - let r867 = S (T T_LIDENT) :: r866 in - let r868 = R 194 :: r867 in - let r869 = R 809 :: r868 in - let r870 = [R 92] in - let r871 = Sub (r795) :: r870 in - let r872 = S (T T_MINUSGREATER) :: r871 in - let r873 = Sub (r81) :: r872 in - let r874 = [R 93] in - let r875 = Sub (r795) :: r874 in - let r876 = [R 91] in - let r877 = Sub (r795) :: r876 in - let r878 = S (T T_MINUSGREATER) :: r877 in - let r879 = [R 275] in - let r880 = R 274 :: r879 in - let r881 = R 288 :: r880 in - let r882 = Sub (r795) :: r881 in - let r883 = S (T T_COLON) :: r882 in - let r884 = S (T T_LIDENT) :: r883 in - let r885 = R 194 :: r884 in - let r886 = R 809 :: r885 in - let r887 = [R 292] in - let r888 = [R 592] in - let r889 = [R 596] in - let r890 = [R 285] in - let r891 = R 284 :: r890 in - let r892 = R 288 :: r891 in - let r893 = R 541 :: r892 in - let r894 = R 778 :: r893 in - let r895 = S (T T_LIDENT) :: r894 in - let r896 = R 782 :: r895 in - let r897 = [R 597] in - let r898 = [R 287] in - let r899 = R 286 :: r898 in - let r900 = R 288 :: r899 in - let r901 = R 541 :: r900 in - let r902 = Sub (r177) :: r901 in - let r903 = S (T T_COLONEQUAL) :: r902 in - let r904 = S (T T_LIDENT) :: r903 in - let r905 = R 782 :: r904 in - let r906 = [R 52] in - let r907 = Sub (r791) :: r906 in - let r908 = [R 61] in - let r909 = Sub (r907) :: r908 in - let r910 = S (T T_EQUAL) :: r909 in - let r911 = [R 755] in - let r912 = R 272 :: r911 in - let r913 = R 288 :: r912 in - let r914 = Sub (r910) :: r913 in - let r915 = S (T T_LIDENT) :: r914 in - let r916 = R 194 :: r915 in - let r917 = R 809 :: r916 in - let r918 = R 282 :: r917 in - let r919 = [R 89] in - let r920 = S (T T_END) :: r919 in - let r921 = R 299 :: r920 in - let r922 = R 69 :: r921 in - let r923 = [R 804] in - let r924 = Sub (r1) :: r923 in - let r925 = S (T T_EQUAL) :: r924 in - let r926 = S (T T_LIDENT) :: r925 in - let r927 = R 383 :: r926 in - let r928 = R 282 :: r927 in - let r929 = [R 55] in - let r930 = R 288 :: r929 in - let r931 = [R 805] in - let r932 = Sub (r1) :: r931 in - let r933 = S (T T_EQUAL) :: r932 in - let r934 = S (T T_LIDENT) :: r933 in - let r935 = R 383 :: r934 in - let r936 = [R 807] in - let r937 = Sub (r1) :: r936 in - let r938 = [R 803] in - let r939 = Sub (r87) :: r938 in - let r940 = S (T T_COLON) :: r939 in - let r941 = [R 806] in - let r942 = Sub (r1) :: r941 in - let r943 = [R 326] in - let r944 = Sub (r382) :: r943 in - let r945 = S (T T_LIDENT) :: r944 in - let r946 = R 518 :: r945 in - let r947 = R 282 :: r946 in - let r948 = [R 56] in - let r949 = R 288 :: r948 in - let r950 = [R 327] in - let r951 = Sub (r382) :: r950 in - let r952 = S (T T_LIDENT) :: r951 in - let r953 = R 518 :: r952 in - let r954 = [R 329] in - let r955 = Sub (r1) :: r954 in - let r956 = S (T T_EQUAL) :: r955 in - let r957 = [R 331] in - let r958 = Sub (r1) :: r957 in - let r959 = S (T T_EQUAL) :: r958 in - let r960 = Sub (r87) :: r959 in - let r961 = S (T T_DOT) :: r960 in - let r962 = [R 737] in - let r963 = [R 197] in - let r964 = Sub (r1) :: r963 in - let r965 = [R 325] in - let r966 = Sub (r89) :: r965 in - let r967 = S (T T_COLON) :: r966 in - let r968 = [R 328] in - let r969 = Sub (r1) :: r968 in - let r970 = S (T T_EQUAL) :: r969 in - let r971 = [R 330] in - let r972 = Sub (r1) :: r971 in - let r973 = S (T T_EQUAL) :: r972 in - let r974 = Sub (r87) :: r973 in - let r975 = S (T T_DOT) :: r974 in - let r976 = [R 58] in - let r977 = R 288 :: r976 in - let r978 = Sub (r1) :: r977 in - let r979 = [R 53] in - let r980 = R 288 :: r979 in - let r981 = R 450 :: r980 in - let r982 = Sub (r907) :: r981 in - let r983 = [R 54] in - let r984 = R 288 :: r983 in - let r985 = R 450 :: r984 in - let r986 = Sub (r907) :: r985 in - let r987 = [R 85] in - let r988 = S (T T_RPAREN) :: r987 in - let r989 = [R 48] in - let r990 = Sub (r907) :: r989 in - let r991 = S (T T_IN) :: r990 in - let r992 = Sub (r783) :: r991 in - let r993 = R 282 :: r992 in - let r994 = [R 262] in - let r995 = R 288 :: r994 in - let r996 = Sub (r236) :: r995 in - let r997 = R 525 :: r996 in - let r998 = R 282 :: r997 in - let r999 = [R 49] in - let r1000 = Sub (r907) :: r999 in - let r1001 = S (T T_IN) :: r1000 in - let r1002 = Sub (r783) :: r1001 in - let r1003 = [R 87] in - let r1004 = Sub (r212) :: r1003 in - let r1005 = S (T T_RBRACKET) :: r1004 in - let r1006 = [R 64] in - let r1007 = Sub (r907) :: r1006 in - let r1008 = S (T T_MINUSGREATER) :: r1007 in - let r1009 = Sub (r495) :: r1008 in - let r1010 = [R 46] in - let r1011 = Sub (r1009) :: r1010 in - let r1012 = [R 47] in - let r1013 = Sub (r907) :: r1012 in - let r1014 = [R 238] in - let r1015 = [R 261] in - let r1016 = R 288 :: r1015 in - let r1017 = Sub (r236) :: r1016 in - let r1018 = [R 88] in - let r1019 = S (T T_RPAREN) :: r1018 in - let r1020 = [R 451] in - let r1021 = [R 57] in - let r1022 = R 288 :: r1021 in - let r1023 = Sub (r856) :: r1022 in - let r1024 = [R 59] in - let r1025 = [R 300] in - let r1026 = [R 62] in - let r1027 = Sub (r907) :: r1026 in - let r1028 = S (T T_EQUAL) :: r1027 in - let r1029 = [R 63] in - let r1030 = [R 273] in - let r1031 = R 272 :: r1030 in - let r1032 = R 288 :: r1031 in - let r1033 = Sub (r910) :: r1032 in - let r1034 = S (T T_LIDENT) :: r1033 in - let r1035 = R 194 :: r1034 in - let r1036 = R 809 :: r1035 in - let r1037 = [R 296] in - let r1038 = [R 743] in - let r1039 = [R 747] in - let r1040 = [R 740] in - let r1041 = R 293 :: r1040 in - let r1042 = [R 626] in - let r1043 = S (T T_RBRACKET) :: r1042 in - let r1044 = Sub (r1) :: r1043 in - let r1045 = [R 625] in - let r1046 = S (T T_RBRACE) :: r1045 in - let r1047 = Sub (r1) :: r1046 in - let r1048 = [R 628] in - let r1049 = S (T T_RPAREN) :: r1048 in - let r1050 = Sub (r458) :: r1049 in - let r1051 = S (T T_LPAREN) :: r1050 in - let r1052 = [R 632] in - let r1053 = S (T T_RBRACKET) :: r1052 in - let r1054 = Sub (r458) :: r1053 in - let r1055 = [R 630] in - let r1056 = S (T T_RBRACE) :: r1055 in - let r1057 = Sub (r458) :: r1056 in - let r1058 = [R 180] in - let r1059 = [R 631] in - let r1060 = S (T T_RBRACKET) :: r1059 in - let r1061 = Sub (r458) :: r1060 in - let r1062 = [R 184] in - let r1063 = [R 629] in - let r1064 = S (T T_RBRACE) :: r1063 in - let r1065 = Sub (r458) :: r1064 in - let r1066 = [R 182] in - let r1067 = [R 177] in - let r1068 = [R 179] in - let r1069 = [R 178] in - let r1070 = [R 181] in - let r1071 = [R 185] in - let r1072 = [R 183] in - let r1073 = [R 176] in - let r1074 = [R 269] in - let r1075 = Sub (r1) :: r1074 in - let r1076 = [R 271] in - let r1077 = [R 648] in - let r1078 = [R 660] in - let r1079 = [R 659] in - let r1080 = [R 663] in - let r1081 = [R 662] in - let r1082 = S (T T_LIDENT) :: r463 in - let r1083 = [R 649] in - let r1084 = S (T T_GREATERRBRACE) :: r1083 in - let r1085 = [R 656] in - let r1086 = S (T T_RBRACE) :: r1085 in - let r1087 = [R 528] in - let r1088 = Sub (r468) :: r1087 in - let r1089 = [R 128] in - let r1090 = S (T T_DONE) :: r1089 in - let r1091 = Sub (r1) :: r1090 in - let r1092 = S (T T_DO) :: r1091 in - let r1093 = Sub (r1) :: r1092 in - let r1094 = Sub (r515) :: r1093 in - let r1095 = [R 201] in - let r1096 = Sub (r498) :: r1095 in - let r1097 = S (T T_RPAREN) :: r1096 in - let r1098 = [R 199] in - let r1099 = Sub (r1) :: r1098 in - let r1100 = S (T T_MINUSGREATER) :: r1099 in - let r1101 = [R 200] in - let r1102 = [R 553] in - let r1103 = [R 140] in - let r1104 = [R 633] in - let r1105 = [R 645] in - let r1106 = [R 131] in - let r1107 = Sub (r1) :: r1106 in - let r1108 = S (T T_IN) :: r1107 in - let r1109 = Sub (r615) :: r1108 in - let r1110 = Sub (r63) :: r1109 in - let r1111 = R 282 :: r1110 in - let r1112 = [R 132] in - let r1113 = Sub (r1) :: r1112 in - let r1114 = S (T T_IN) :: r1113 in - let r1115 = R 282 :: r1114 in - let r1116 = R 209 :: r1115 in - let r1117 = Sub (r130) :: r1116 in - let r1118 = R 282 :: r1117 in - let r1119 = [R 256] in - let r1120 = Sub (r1) :: r1119 in - let r1121 = S (T T_EQUAL) :: r1120 in - let r1122 = Sub (r87) :: r1121 in - let r1123 = S (T T_DOT) :: r1122 in - let r1124 = [R 255] in - let r1125 = Sub (r1) :: r1124 in - let r1126 = S (T T_EQUAL) :: r1125 in - let r1127 = Sub (r87) :: r1126 in - let r1128 = [R 254] in - let r1129 = Sub (r1) :: r1128 in - let r1130 = [R 657] in - let r1131 = [R 636] in - let r1132 = S (T T_RPAREN) :: r1131 in - let r1133 = S (N N_module_expr) :: r1132 in - let r1134 = R 282 :: r1133 in - let r1135 = [R 637] in - let r1136 = S (T T_RPAREN) :: r1135 in - let r1137 = [R 623] in - let r1138 = [R 471] in - let r1139 = S (T T_RPAREN) :: r1138 in - let r1140 = [R 469] in - let r1141 = S (T T_RPAREN) :: r1140 in - let r1142 = [R 470] in - let r1143 = S (T T_RPAREN) :: r1142 in - let r1144 = [R 295] in - let r1145 = R 293 :: r1144 in - let r1146 = [R 320] in - let r1147 = [R 29] in - let r1148 = [R 28] in - let r1149 = Sub (r126) :: r1148 in - let r1150 = [R 33] in - let r1151 = [R 566] in - let r1152 = [R 22] in - let r1153 = [R 567] in - let r1154 = [R 406] in - let r1155 = S (T T_RBRACE) :: r1154 in - let r1156 = [R 191] in - let r1157 = R 282 :: r1156 in - let r1158 = [R 192] in - let r1159 = R 282 :: r1158 in - let r1160 = [R 68] in - let r1161 = S (T T_RPAREN) :: r1160 in - let r1162 = [R 124] in - let r1163 = [R 126] in - let r1164 = [R 125] in - let r1165 = [R 223] in - let r1166 = [R 226] in - let r1167 = [R 337] in - let r1168 = [R 340] in - let r1169 = S (T T_RPAREN) :: r1168 in - let r1170 = S (T T_COLONCOLON) :: r1169 in - let r1171 = S (T T_LPAREN) :: r1170 in - let r1172 = [R 472] in - let r1173 = [R 473] in - let r1174 = [R 474] in - let r1175 = [R 475] in - let r1176 = [R 476] in - let r1177 = [R 477] in - let r1178 = [R 478] in - let r1179 = [R 479] in - let r1180 = [R 480] in - let r1181 = [R 481] in - let r1182 = [R 482] in - let r1183 = [R 762] in - let r1184 = [R 771] in - let r1185 = [R 302] in - let r1186 = [R 769] in - let r1187 = S (T T_SEMISEMI) :: r1186 in - let r1188 = [R 770] in - let r1189 = [R 304] in - let r1190 = [R 307] in - let r1191 = [R 306] in - let r1192 = [R 305] in - let r1193 = R 303 :: r1192 in - let r1194 = [R 798] in - let r1195 = S (T T_EOF) :: r1194 in - let r1196 = R 303 :: r1195 in - let r1197 = [R 797] in + let r790 = S (T T_COLONEQUAL) :: r789 in + let r791 = Sub (r111) :: r790 in + let r792 = R 289 :: r791 in + let r793 = [R 376] in + let r794 = R 295 :: r793 in + let r795 = [R 615] in + let r796 = R 287 :: r795 in + let r797 = R 295 :: r796 in + let r798 = S (N N_module_type) :: r797 in + let r799 = S (T T_COLON) :: r798 in + let r800 = [R 288] in + let r801 = R 287 :: r800 in + let r802 = R 295 :: r801 in + let r803 = S (N N_module_type) :: r802 in + let r804 = S (T T_COLON) :: r803 in + let r805 = Sub (r69) :: r804 in + let r806 = S (T T_UIDENT) :: r33 in + let r807 = Sub (r806) :: r225 in + let r808 = [R 613] in + let r809 = R 295 :: r808 in + let r810 = [R 364] in + let r811 = [R 619] in + let r812 = R 295 :: r811 in + let r813 = S (N N_module_type) :: r812 in + let r814 = R 289 :: r813 in + let r815 = S (T T_QUOTED_STRING_EXPR) :: r48 in + let r816 = [R 71] in + let r817 = Sub (r815) :: r816 in + let r818 = [R 81] in + let r819 = Sub (r817) :: r818 in + let r820 = [R 620] in + let r821 = R 281 :: r820 in + let r822 = R 295 :: r821 in + let r823 = Sub (r819) :: r822 in + let r824 = S (T T_COLON) :: r823 in + let r825 = S (T T_LIDENT) :: r824 in + let r826 = R 143 :: r825 in + let r827 = R 819 :: r826 in + let r828 = R 289 :: r827 in + let r829 = [R 85] in + let r830 = R 283 :: r829 in + let r831 = R 295 :: r830 in + let r832 = Sub (r817) :: r831 in + let r833 = S (T T_EQUAL) :: r832 in + let r834 = S (T T_LIDENT) :: r833 in + let r835 = R 143 :: r834 in + let r836 = R 819 :: r835 in + let r837 = R 289 :: r836 in + let r838 = [R 144] in + let r839 = S (T T_RBRACKET) :: r838 in + let r840 = [R 72] in + let r841 = S (T T_END) :: r840 in + let r842 = R 304 :: r841 in + let r843 = R 62 :: r842 in + let r844 = [R 61] in + let r845 = S (T T_RPAREN) :: r844 in + let r846 = [R 64] in + let r847 = R 295 :: r846 in + let r848 = Sub (r93) :: r847 in + let r849 = S (T T_COLON) :: r848 in + let r850 = S (T T_LIDENT) :: r849 in + let r851 = R 392 :: r850 in + let r852 = [R 65] in + let r853 = R 295 :: r852 in + let r854 = Sub (r95) :: r853 in + let r855 = S (T T_COLON) :: r854 in + let r856 = S (T T_LIDENT) :: r855 in + let r857 = R 531 :: r856 in + let r858 = [R 63] in + let r859 = R 295 :: r858 in + let r860 = Sub (r817) :: r859 in + let r861 = [R 74] in + let r862 = Sub (r817) :: r861 in + let r863 = S (T T_IN) :: r862 in + let r864 = Sub (r807) :: r863 in + let r865 = R 289 :: r864 in + let r866 = [R 75] in + let r867 = Sub (r817) :: r866 in + let r868 = S (T T_IN) :: r867 in + let r869 = Sub (r807) :: r868 in + let r870 = [R 573] in + let r871 = Sub (r93) :: r870 in + let r872 = [R 70] in + let r873 = Sub (r286) :: r872 in + let r874 = S (T T_RBRACKET) :: r873 in + let r875 = Sub (r871) :: r874 in + let r876 = [R 574] in + let r877 = [R 102] in + let r878 = Sub (r93) :: r877 in + let r879 = S (T T_EQUAL) :: r878 in + let r880 = Sub (r93) :: r879 in + let r881 = [R 66] in + let r882 = R 295 :: r881 in + let r883 = Sub (r880) :: r882 in + let r884 = [R 67] in + let r885 = [R 305] in + let r886 = [R 284] in + let r887 = R 283 :: r886 in + let r888 = R 295 :: r887 in + let r889 = Sub (r817) :: r888 in + let r890 = S (T T_EQUAL) :: r889 in + let r891 = S (T T_LIDENT) :: r890 in + let r892 = R 143 :: r891 in + let r893 = R 819 :: r892 in + let r894 = [R 83] in + let r895 = Sub (r819) :: r894 in + let r896 = S (T T_MINUSGREATER) :: r895 in + let r897 = Sub (r87) :: r896 in + let r898 = [R 84] in + let r899 = Sub (r819) :: r898 in + let r900 = [R 82] in + let r901 = Sub (r819) :: r900 in + let r902 = S (T T_MINUSGREATER) :: r901 in + let r903 = [R 282] in + let r904 = R 281 :: r903 in + let r905 = R 295 :: r904 in + let r906 = Sub (r819) :: r905 in + let r907 = S (T T_COLON) :: r906 in + let r908 = S (T T_LIDENT) :: r907 in + let r909 = R 143 :: r908 in + let r910 = R 819 :: r909 in + let r911 = [R 299] in + let r912 = [R 603] in + let r913 = [R 607] in + let r914 = [R 292] in + let r915 = R 291 :: r914 in + let r916 = R 295 :: r915 in + let r917 = R 552 :: r916 in + let r918 = R 788 :: r917 in + let r919 = S (T T_LIDENT) :: r918 in + let r920 = R 792 :: r919 in + let r921 = [R 608] in + let r922 = [R 294] in + let r923 = R 293 :: r922 in + let r924 = R 295 :: r923 in + let r925 = R 552 :: r924 in + let r926 = Sub (r183) :: r925 in + let r927 = S (T T_COLONEQUAL) :: r926 in + let r928 = S (T T_LIDENT) :: r927 in + let r929 = R 792 :: r928 in + let r930 = [R 43] in + let r931 = Sub (r815) :: r930 in + let r932 = [R 52] in + let r933 = Sub (r931) :: r932 in + let r934 = S (T T_EQUAL) :: r933 in + let r935 = [R 765] in + let r936 = R 279 :: r935 in + let r937 = R 295 :: r936 in + let r938 = Sub (r934) :: r937 in + let r939 = S (T T_LIDENT) :: r938 in + let r940 = R 143 :: r939 in + let r941 = R 819 :: r940 in + let r942 = R 289 :: r941 in + let r943 = [R 80] in + let r944 = S (T T_END) :: r943 in + let r945 = R 306 :: r944 in + let r946 = R 60 :: r945 in + let r947 = [R 814] in + let r948 = Sub (r7) :: r947 in + let r949 = S (T T_EQUAL) :: r948 in + let r950 = S (T T_LIDENT) :: r949 in + let r951 = R 390 :: r950 in + let r952 = R 289 :: r951 in + let r953 = [R 46] in + let r954 = R 295 :: r953 in + let r955 = [R 815] in + let r956 = Sub (r7) :: r955 in + let r957 = S (T T_EQUAL) :: r956 in + let r958 = S (T T_LIDENT) :: r957 in + let r959 = R 390 :: r958 in + let r960 = [R 817] in + let r961 = Sub (r7) :: r960 in + let r962 = [R 813] in + let r963 = Sub (r93) :: r962 in + let r964 = S (T T_COLON) :: r963 in + let r965 = [R 816] in + let r966 = Sub (r7) :: r965 in + let r967 = S (T T_EQUAL) :: r399 in + let r968 = [R 333] in + let r969 = Sub (r967) :: r968 in + let r970 = S (T T_LIDENT) :: r969 in + let r971 = R 529 :: r970 in + let r972 = R 289 :: r971 in + let r973 = [R 47] in + let r974 = R 295 :: r973 in + let r975 = [R 334] in + let r976 = Sub (r967) :: r975 in + let r977 = S (T T_LIDENT) :: r976 in + let r978 = R 529 :: r977 in + let r979 = [R 336] in + let r980 = Sub (r7) :: r979 in + let r981 = S (T T_EQUAL) :: r980 in + let r982 = [R 338] in + let r983 = Sub (r7) :: r982 in + let r984 = S (T T_EQUAL) :: r983 in + let r985 = Sub (r93) :: r984 in + let r986 = S (T T_DOT) :: r985 in + let r987 = [R 748] in + let r988 = Sub (r513) :: r987 in + let r989 = S (T T_EQUAL) :: r988 in + let r990 = [R 332] in + let r991 = Sub (r95) :: r990 in + let r992 = S (T T_COLON) :: r991 in + let r993 = [R 335] in + let r994 = Sub (r7) :: r993 in + let r995 = S (T T_EQUAL) :: r994 in + let r996 = [R 337] in + let r997 = Sub (r7) :: r996 in + let r998 = S (T T_EQUAL) :: r997 in + let r999 = Sub (r93) :: r998 in + let r1000 = S (T T_DOT) :: r999 in + let r1001 = [R 49] in + let r1002 = R 295 :: r1001 in + let r1003 = Sub (r7) :: r1002 in + let r1004 = [R 44] in + let r1005 = R 295 :: r1004 in + let r1006 = R 459 :: r1005 in + let r1007 = Sub (r931) :: r1006 in + let r1008 = [R 45] in + let r1009 = R 295 :: r1008 in + let r1010 = R 459 :: r1009 in + let r1011 = Sub (r931) :: r1010 in + let r1012 = [R 76] in + let r1013 = S (T T_RPAREN) :: r1012 in + let r1014 = [R 39] in + let r1015 = Sub (r931) :: r1014 in + let r1016 = S (T T_IN) :: r1015 in + let r1017 = Sub (r807) :: r1016 in + let r1018 = R 289 :: r1017 in + let r1019 = [R 269] in + let r1020 = R 295 :: r1019 in + let r1021 = Sub (r245) :: r1020 in + let r1022 = R 536 :: r1021 in + let r1023 = R 289 :: r1022 in + let r1024 = [R 40] in + let r1025 = Sub (r931) :: r1024 in + let r1026 = S (T T_IN) :: r1025 in + let r1027 = Sub (r807) :: r1026 in + let r1028 = [R 78] in + let r1029 = Sub (r218) :: r1028 in + let r1030 = S (T T_RBRACKET) :: r1029 in + let r1031 = [R 55] in + let r1032 = Sub (r931) :: r1031 in + let r1033 = S (T T_MINUSGREATER) :: r1032 in + let r1034 = Sub (r505) :: r1033 in + let r1035 = [R 37] in + let r1036 = Sub (r1034) :: r1035 in + let r1037 = [R 38] in + let r1038 = Sub (r931) :: r1037 in + let r1039 = [R 245] in + let r1040 = [R 268] in + let r1041 = R 295 :: r1040 in + let r1042 = Sub (r245) :: r1041 in + let r1043 = [R 79] in + let r1044 = S (T T_RPAREN) :: r1043 in + let r1045 = [R 460] in + let r1046 = [R 48] in + let r1047 = R 295 :: r1046 in + let r1048 = Sub (r880) :: r1047 in + let r1049 = [R 50] in + let r1050 = [R 307] in + let r1051 = [R 53] in + let r1052 = Sub (r931) :: r1051 in + let r1053 = S (T T_EQUAL) :: r1052 in + let r1054 = [R 54] in + let r1055 = [R 280] in + let r1056 = R 279 :: r1055 in + let r1057 = R 295 :: r1056 in + let r1058 = Sub (r934) :: r1057 in + let r1059 = S (T T_LIDENT) :: r1058 in + let r1060 = R 143 :: r1059 in + let r1061 = R 819 :: r1060 in + let r1062 = [R 303] in + let r1063 = [R 753] in + let r1064 = [R 757] in + let r1065 = [R 750] in + let r1066 = R 300 :: r1065 in + let r1067 = [R 637] in + let r1068 = S (T T_RBRACKET) :: r1067 in + let r1069 = Sub (r7) :: r1068 in + let r1070 = [R 636] in + let r1071 = S (T T_RBRACE) :: r1070 in + let r1072 = Sub (r7) :: r1071 in + let r1073 = [R 639] in + let r1074 = S (T T_RPAREN) :: r1073 in + let r1075 = Sub (r468) :: r1074 in + let r1076 = S (T T_LPAREN) :: r1075 in + let r1077 = [R 643] in + let r1078 = S (T T_RBRACKET) :: r1077 in + let r1079 = Sub (r468) :: r1078 in + let r1080 = [R 641] in + let r1081 = S (T T_RBRACE) :: r1080 in + let r1082 = Sub (r468) :: r1081 in + let r1083 = [R 195] in + let r1084 = [R 642] in + let r1085 = S (T T_RBRACKET) :: r1084 in + let r1086 = Sub (r468) :: r1085 in + let r1087 = [R 199] in + let r1088 = [R 640] in + let r1089 = S (T T_RBRACE) :: r1088 in + let r1090 = Sub (r468) :: r1089 in + let r1091 = [R 197] in + let r1092 = [R 192] in + let r1093 = [R 194] in + let r1094 = [R 193] in + let r1095 = [R 196] in + let r1096 = [R 200] in + let r1097 = [R 198] in + let r1098 = [R 191] in + let r1099 = [R 276] in + let r1100 = Sub (r7) :: r1099 in + let r1101 = [R 278] in + let r1102 = [R 659] in + let r1103 = [R 671] in + let r1104 = [R 670] in + let r1105 = [R 674] in + let r1106 = [R 673] in + let r1107 = S (T T_LIDENT) :: r473 in + let r1108 = [R 660] in + let r1109 = S (T T_GREATERRBRACE) :: r1108 in + let r1110 = [R 667] in + let r1111 = S (T T_RBRACE) :: r1110 in + let r1112 = [R 539] in + let r1113 = Sub (r478) :: r1112 in + let r1114 = [R 131] in + let r1115 = S (T T_DONE) :: r1114 in + let r1116 = Sub (r7) :: r1115 in + let r1117 = S (T T_DO) :: r1116 in + let r1118 = Sub (r7) :: r1117 in + let r1119 = Sub (r534) :: r1118 in + let r1120 = [R 155] in + let r1121 = [R 644] in + let r1122 = [R 656] in + let r1123 = [R 148] in + let r1124 = Sub (r7) :: r1123 in + let r1125 = S (T T_IN) :: r1124 in + let r1126 = Sub (r639) :: r1125 in + let r1127 = Sub (r69) :: r1126 in + let r1128 = R 289 :: r1127 in + let r1129 = [R 149] in + let r1130 = Sub (r7) :: r1129 in + let r1131 = S (T T_IN) :: r1130 in + let r1132 = R 289 :: r1131 in + let r1133 = R 216 :: r1132 in + let r1134 = Sub (r136) :: r1133 in + let r1135 = R 289 :: r1134 in + let r1136 = [R 263] in + let r1137 = Sub (r7) :: r1136 in + let r1138 = S (T T_EQUAL) :: r1137 in + let r1139 = Sub (r93) :: r1138 in + let r1140 = S (T T_DOT) :: r1139 in + let r1141 = [R 262] in + let r1142 = Sub (r7) :: r1141 in + let r1143 = S (T T_EQUAL) :: r1142 in + let r1144 = Sub (r93) :: r1143 in + let r1145 = [R 261] in + let r1146 = Sub (r7) :: r1145 in + let r1147 = [R 668] in + let r1148 = [R 648] in + let r1149 = S (T T_RPAREN) :: r1148 in + let r1150 = [R 633] in + let r1151 = [R 634] in + let r1152 = [R 482] in + let r1153 = S (T T_RPAREN) :: r1152 in + let r1154 = [R 480] in + let r1155 = S (T T_RPAREN) :: r1154 in + let r1156 = [R 481] in + let r1157 = S (T T_RPAREN) :: r1156 in + let r1158 = [R 302] in + let r1159 = R 300 :: r1158 in + let r1160 = [R 327] in + let r1161 = [R 416] in + let r1162 = [R 25] in + let r1163 = Sub (r132) :: r1162 in + let r1164 = [R 28] in + let r1165 = [R 579] in + let r1166 = [R 580] in + let r1167 = [R 413] in + let r1168 = S (T T_RBRACE) :: r1167 in + let r1169 = [R 139] in + let r1170 = R 289 :: r1169 in + let r1171 = [R 140] in + let r1172 = R 289 :: r1171 in + let r1173 = [R 59] in + let r1174 = S (T T_RPAREN) :: r1173 in + let r1175 = [R 127] in + let r1176 = [R 129] in + let r1177 = [R 128] in + let r1178 = [R 230] in + let r1179 = [R 233] in + let r1180 = [R 344] in + let r1181 = [R 347] in + let r1182 = S (T T_RPAREN) :: r1181 in + let r1183 = S (T T_COLONCOLON) :: r1182 in + let r1184 = S (T T_LPAREN) :: r1183 in + let r1185 = [R 483] in + let r1186 = [R 484] in + let r1187 = [R 485] in + let r1188 = [R 486] in + let r1189 = [R 487] in + let r1190 = [R 488] in + let r1191 = [R 489] in + let r1192 = [R 490] in + let r1193 = [R 491] in + let r1194 = [R 492] in + let r1195 = [R 493] in + let r1196 = [R 772] in + let r1197 = [R 781] in + let r1198 = [R 309] in + let r1199 = [R 779] in + let r1200 = S (T T_SEMISEMI) :: r1199 in + let r1201 = [R 780] in + let r1202 = [R 311] in + let r1203 = [R 314] in + let r1204 = [R 313] in + let r1205 = [R 312] in + let r1206 = R 310 :: r1205 in + let r1207 = [R 808] in + let r1208 = S (T T_EOF) :: r1207 in + let r1209 = R 310 :: r1208 in + let r1210 = [R 807] in function - | 0 | 1763 | 1767 | 1785 | 1789 | 1793 | 1797 | 1801 | 1805 | 1809 | 1813 | 1817 | 1821 | 1827 | 1847 -> Nothing - | 1762 -> One ([R 0]) - | 1766 -> One ([R 1]) - | 1772 -> One ([R 2]) - | 1786 -> One ([R 3]) - | 1790 -> One ([R 4]) - | 1796 -> One ([R 5]) - | 1798 -> One ([R 6]) - | 1802 -> One ([R 7]) - | 1806 -> One ([R 8]) - | 1810 -> One ([R 9]) - | 1814 -> One ([R 10]) - | 1820 -> One ([R 11]) - | 1824 -> One ([R 12]) - | 1837 -> One ([R 13]) - | 1857 -> One ([R 14]) + | 0 | 1772 | 1776 | 1794 | 1798 | 1802 | 1806 | 1810 | 1814 | 1818 | 1822 | 1826 | 1830 | 1836 | 1856 -> Nothing + | 1771 -> One ([R 0]) + | 1775 -> One ([R 1]) + | 1781 -> One ([R 2]) + | 1795 -> One ([R 3]) + | 1799 -> One ([R 4]) + | 1805 -> One ([R 5]) + | 1807 -> One ([R 6]) + | 1811 -> One ([R 7]) + | 1815 -> One ([R 8]) + | 1819 -> One ([R 9]) + | 1823 -> One ([R 10]) + | 1829 -> One ([R 11]) + | 1833 -> One ([R 12]) + | 1846 -> One ([R 13]) + | 1866 -> One ([R 14]) | 214 -> One ([R 15]) | 213 -> One ([R 16]) - | 1780 -> One ([R 20]) - | 1782 -> One ([R 21]) - | 284 -> One ([R 26]) - | 294 -> One ([R 27]) - | 290 -> One ([R 41]) - | 1271 -> One ([R 45]) - | 1280 -> One ([R 50]) - | 1275 -> One ([R 51]) - | 1316 -> One ([R 60]) - | 1283 -> One ([R 65]) - | 1067 -> One ([R 77]) - | 1047 -> One ([R 78]) - | 1049 -> One ([R 82]) - | 1278 -> One ([R 86]) - | 352 -> One ([R 97]) - | 73 -> One ([R 98]) - | 350 -> One ([R 99]) - | 72 -> One ([R 103]) - | 200 | 813 -> One ([R 104]) - | 845 -> One ([R 107]) - | 879 -> One ([R 115]) - | 883 -> One ([R 116]) - | 324 -> One ([R 118]) - | 1501 -> One ([R 119]) - | 625 -> One ([R 130]) - | 1449 -> One ([R 146]) - | 648 -> One ([R 147]) - | 670 -> One ([R 148]) - | 651 -> One ([R 149]) - | 668 -> One ([R 186]) - | 1 -> One (R 187 :: r7) - | 61 -> One (R 187 :: r24) - | 66 -> One (R 187 :: r29) - | 69 -> One (R 187 :: r40) - | 76 -> One (R 187 :: r48) - | 96 -> One (R 187 :: r67) - | 107 -> One (R 187 :: r95) - | 215 -> One (R 187 :: r199) - | 216 -> One (R 187 :: r203) - | 222 -> One (R 187 :: r215) - | 237 -> One (R 187 :: r225) - | 240 -> One (R 187 :: r230) - | 248 -> One (R 187 :: r241) - | 344 -> One (R 187 :: r319) - | 367 -> One (R 187 :: r332) - | 464 -> One (R 187 :: r406) - | 558 -> One (R 187 :: r478) - | 561 -> One (R 187 :: r481) - | 564 -> One (R 187 :: r486) - | 567 -> One (R 187 :: r489) - | 573 -> One (R 187 :: r502) - | 581 -> One (R 187 :: r513) - | 586 -> One (R 187 :: r525) - | 602 -> One (R 187 :: r536) - | 616 -> One (R 187 :: r542) - | 749 -> One (R 187 :: r620) - | 788 -> One (R 187 :: r651) - | 793 -> One (R 187 :: r661) - | 935 -> One (R 187 :: r750) - | 936 -> One (R 187 :: r754) - | 945 -> One (R 187 :: r762) - | 982 -> One (R 187 :: r790) - | 991 -> One (R 187 :: r804) - | 992 -> One (R 187 :: r813) - | 1155 -> One (R 187 :: r918) - | 1574 -> One (R 187 :: r1111) - | 1581 -> One (R 187 :: r1118) - | 1619 -> One (R 187 :: r1134) - | 478 -> One ([R 208]) - | 153 -> One ([R 221]) - | 131 -> One (R 224 :: r101) - | 135 -> One (R 224 :: r103) - | 212 -> One ([R 228]) - | 835 -> One ([R 232]) - | 836 -> One ([R 233]) - | 1274 -> One ([R 237]) - | 741 -> One ([R 251]) - | 1611 -> One ([R 253]) - | 1354 -> One ([R 260]) - | 1281 -> One ([R 263]) - | 447 -> One ([R 264]) - | 1591 -> One ([R 266]) - | 105 -> One (R 282 :: r75) - | 171 -> One (R 282 :: r122) - | 220 -> One (R 282 :: r208) - | 233 -> One (R 282 :: r220) - | 467 -> One (R 282 :: r410) - | 476 -> One (R 282 :: r422) - | 718 -> One (R 282 :: r597) - | 772 -> One (R 282 :: r640) - | 964 -> One (R 282 :: r781) - | 1003 -> One (R 282 :: r819) - | 1009 -> One (R 282 :: r827) - | 1020 -> One (R 282 :: r833) - | 1031 -> One (R 282 :: r836) - | 1035 -> One (R 282 :: r845) - | 1056 -> One (R 282 :: r859) - | 1072 -> One (R 282 :: r869) - | 1107 -> One (R 282 :: r886) - | 1129 -> One (R 282 :: r896) - | 1139 -> One (R 282 :: r905) - | 1162 -> One (R 282 :: r922) - | 1166 -> One (R 282 :: r935) - | 1194 -> One (R 282 :: r953) - | 1240 -> One (R 282 :: r978) - | 1244 -> One (R 282 :: r982) - | 1245 -> One (R 282 :: r986) - | 1256 -> One (R 282 :: r1002) - | 1264 -> One (R 282 :: r1011) - | 1308 -> One (R 282 :: r1023) - | 1328 -> One (R 282 :: r1036) - | 1662 -> One (R 282 :: r1146) - | 1128 -> One (R 284 :: r889) - | 1357 -> One (R 284 :: r1039) - | 1138 -> One (R 286 :: r897) - | 757 -> One (R 288 :: r628) - | 1065 -> One (R 288 :: r860) - | 1126 -> One (R 288 :: r888) - | 1314 -> One (R 288 :: r1024) - | 1355 -> One (R 288 :: r1038) - | 1362 -> One (R 288 :: r1041) - | 1654 -> One (R 288 :: r1145) - | 1842 -> One (R 288 :: r1187) - | 1853 -> One (R 288 :: r1193) - | 1858 -> One (R 288 :: r1196) - | 934 -> One (R 290 :: r746) - | 1118 -> One (R 290 :: r887) - | 211 -> One (R 293 :: r195) - | 1338 -> One (R 293 :: r1037) - | 1068 -> One (R 297 :: r861) - | 1317 -> One (R 299 :: r1025) - | 1840 -> One (R 301 :: r1185) - | 1848 -> One (R 303 :: r1189) - | 1849 -> One (R 303 :: r1190) - | 1850 -> One (R 303 :: r1191) - | 421 -> One ([R 309]) - | 425 -> One ([R 311]) - | 659 -> One ([R 313]) - | 1351 -> One ([R 314]) - | 1538 -> One ([R 317]) - | 1665 -> One ([R 318]) - | 1668 -> One ([R 319]) - | 1667 -> One ([R 321]) - | 1666 -> One ([R 323]) - | 1664 -> One ([R 324]) - | 1781 -> One ([R 336]) - | 1771 -> One ([R 338]) - | 1779 -> One ([R 339]) - | 1778 -> One ([R 341]) - | 593 -> One ([R 348]) - | 1499 -> One ([R 349]) - | 535 -> One ([R 360]) - | 545 -> One ([R 361]) - | 546 -> One ([R 362]) - | 544 -> One ([R 363]) - | 547 -> One ([R 365]) - | 170 -> One ([R 366]) - | 100 | 955 -> One ([R 367]) - | 505 -> One ([R 374]) - | 482 -> One ([R 375]) - | 512 -> One ([R 379]) - | 821 | 1180 -> One ([R 384]) - | 1013 -> One ([R 386]) - | 1011 -> One ([R 387]) - | 1014 -> One ([R 388]) - | 1012 -> One ([R 389]) - | 385 -> One ([R 392]) - | 806 -> One ([R 394]) - | 891 -> One ([R 395]) - | 1690 -> One ([R 396]) - | 907 -> One ([R 397]) - | 1691 -> One ([R 398]) - | 906 -> One ([R 399]) - | 898 -> One ([R 400]) - | 90 | 244 -> One ([R 413]) - | 114 | 611 -> One ([R 414]) - | 142 -> One ([R 415]) - | 130 -> One ([R 417]) - | 134 -> One ([R 419]) - | 138 -> One ([R 421]) - | 121 -> One ([R 422]) - | 141 | 1469 -> One ([R 423]) - | 120 -> One ([R 424]) - | 119 -> One ([R 425]) - | 118 -> One ([R 426]) - | 117 -> One ([R 427]) - | 116 -> One ([R 428]) - | 93 | 111 | 601 -> One ([R 429]) - | 92 | 600 -> One ([R 430]) - | 91 -> One ([R 431]) - | 113 | 391 | 610 -> One ([R 432]) - | 112 | 609 -> One ([R 433]) - | 88 -> One ([R 434]) - | 94 -> One ([R 435]) - | 123 -> One ([R 436]) - | 115 -> One ([R 437]) - | 122 -> One ([R 438]) - | 95 -> One ([R 439]) - | 140 -> One ([R 440]) - | 143 -> One ([R 441]) - | 139 -> One ([R 443]) - | 311 -> One ([R 444]) - | 310 -> One (R 445 :: r302) - | 262 -> One (R 446 :: r263) - | 263 -> One ([R 447]) - | 422 -> One (R 448 :: r353) - | 423 -> One ([R 449]) - | 1488 -> One ([R 463]) - | 159 -> One ([R 464]) - | 377 -> One ([R 484]) - | 371 -> One ([R 485]) - | 372 -> One ([R 487]) - | 370 | 612 -> One ([R 494]) - | 736 -> One ([R 500]) - | 737 -> One ([R 501]) - | 738 -> One ([R 503]) - | 453 -> One ([R 505]) - | 1154 -> One ([R 509]) - | 913 | 1221 -> One ([R 519]) - | 1024 -> One ([R 521]) - | 1022 -> One ([R 522]) - | 1025 -> One ([R 523]) - | 1023 -> One ([R 524]) - | 1290 -> One (R 525 :: r1017) - | 251 -> One ([R 526]) - | 889 -> One ([R 529]) - | 890 -> One ([R 530]) - | 885 -> One ([R 531]) - | 1707 -> One ([R 533]) - | 1706 -> One ([R 534]) - | 1708 -> One ([R 535]) - | 1703 -> One ([R 536]) - | 1704 -> One ([R 537]) - | 919 -> One ([R 539]) + | 1789 -> One ([R 20]) + | 1791 -> One ([R 21]) + | 301 -> One ([R 22]) + | 284 -> One ([R 23]) + | 307 -> One ([R 24]) + | 1299 -> One ([R 36]) + | 1308 -> One ([R 41]) + | 1303 -> One ([R 42]) + | 1344 -> One ([R 51]) + | 1311 -> One ([R 56]) + | 1095 -> One ([R 68]) + | 1075 -> One ([R 69]) + | 1077 -> One ([R 73]) + | 1306 -> One ([R 77]) + | 362 -> One ([R 88]) + | 73 -> One ([R 89]) + | 360 -> One ([R 90]) + | 72 -> One ([R 94]) + | 200 | 841 -> One ([R 95]) + | 873 -> One ([R 98]) + | 907 -> One ([R 106]) + | 911 -> One ([R 107]) + | 311 -> One ([R 109]) + | 289 -> One ([R 110]) + | 298 -> One ([R 111]) + | 300 -> One ([R 112]) + | 1529 -> One ([R 122]) + | 691 -> One ([R 133]) + | 1 -> One (R 135 :: r13) + | 61 -> One (R 135 :: r32) + | 66 -> One (R 135 :: r36) + | 69 -> One (R 135 :: r47) + | 76 -> One (R 135 :: r54) + | 96 -> One (R 135 :: r73) + | 107 -> One (R 135 :: r101) + | 215 -> One (R 135 :: r205) + | 216 -> One (R 135 :: r209) + | 222 -> One (R 135 :: r221) + | 237 -> One (R 135 :: r231) + | 240 -> One (R 135 :: r236) + | 248 -> One (R 135 :: r250) + | 354 -> One (R 135 :: r334) + | 377 -> One (R 135 :: r347) + | 474 -> One (R 135 :: r416) + | 568 -> One (R 135 :: r488) + | 571 -> One (R 135 :: r491) + | 574 -> One (R 135 :: r496) + | 577 -> One (R 135 :: r499) + | 583 -> One (R 135 :: r519) + | 595 -> One (R 135 :: r523) + | 602 -> One (R 135 :: r532) + | 607 -> One (R 135 :: r544) + | 623 -> One (R 135 :: r555) + | 637 -> One (R 135 :: r561) + | 645 -> One (R 135 :: r569) + | 777 -> One (R 135 :: r644) + | 816 -> One (R 135 :: r675) + | 821 -> One (R 135 :: r685) + | 963 -> One (R 135 :: r774) + | 964 -> One (R 135 :: r778) + | 973 -> One (R 135 :: r786) + | 1010 -> One (R 135 :: r814) + | 1019 -> One (R 135 :: r828) + | 1020 -> One (R 135 :: r837) + | 1183 -> One (R 135 :: r942) + | 1585 -> One (R 135 :: r1128) + | 1592 -> One (R 135 :: r1135) + | 299 -> One ([R 141]) + | 1478 -> One ([R 161]) + | 673 -> One ([R 162]) + | 695 -> One ([R 163]) + | 676 -> One ([R 164]) + | 738 -> One ([R 201]) + | 740 -> One ([R 206]) + | 745 -> One ([R 207]) + | 488 -> One ([R 215]) + | 153 -> One ([R 228]) + | 131 -> One (R 231 :: r107) + | 135 -> One (R 231 :: r109) + | 212 -> One ([R 235]) + | 863 -> One ([R 239]) + | 864 -> One ([R 240]) + | 1302 -> One ([R 244]) + | 769 -> One ([R 258]) + | 1621 -> One ([R 260]) + | 1382 -> One ([R 267]) + | 1309 -> One ([R 270]) + | 457 -> One ([R 271]) + | 1601 -> One ([R 273]) + | 105 -> One (R 289 :: r81) + | 171 -> One (R 289 :: r128) + | 220 -> One (R 289 :: r214) + | 233 -> One (R 289 :: r226) + | 477 -> One (R 289 :: r420) + | 486 -> One (R 289 :: r432) + | 746 -> One (R 289 :: r621) + | 800 -> One (R 289 :: r664) + | 992 -> One (R 289 :: r805) + | 1031 -> One (R 289 :: r843) + | 1037 -> One (R 289 :: r851) + | 1048 -> One (R 289 :: r857) + | 1059 -> One (R 289 :: r860) + | 1063 -> One (R 289 :: r869) + | 1084 -> One (R 289 :: r883) + | 1100 -> One (R 289 :: r893) + | 1135 -> One (R 289 :: r910) + | 1157 -> One (R 289 :: r920) + | 1167 -> One (R 289 :: r929) + | 1190 -> One (R 289 :: r946) + | 1194 -> One (R 289 :: r959) + | 1222 -> One (R 289 :: r978) + | 1268 -> One (R 289 :: r1003) + | 1272 -> One (R 289 :: r1007) + | 1273 -> One (R 289 :: r1011) + | 1284 -> One (R 289 :: r1027) + | 1292 -> One (R 289 :: r1036) + | 1336 -> One (R 289 :: r1048) + | 1356 -> One (R 289 :: r1061) + | 1672 -> One (R 289 :: r1160) + | 1156 -> One (R 291 :: r913) + | 1385 -> One (R 291 :: r1064) + | 1166 -> One (R 293 :: r921) + | 785 -> One (R 295 :: r652) + | 1093 -> One (R 295 :: r884) + | 1154 -> One (R 295 :: r912) + | 1342 -> One (R 295 :: r1049) + | 1383 -> One (R 295 :: r1063) + | 1390 -> One (R 295 :: r1066) + | 1664 -> One (R 295 :: r1159) + | 1851 -> One (R 295 :: r1200) + | 1862 -> One (R 295 :: r1206) + | 1867 -> One (R 295 :: r1209) + | 962 -> One (R 297 :: r770) + | 1146 -> One (R 297 :: r911) + | 211 -> One (R 300 :: r201) + | 1366 -> One (R 300 :: r1062) + | 1096 -> One (R 304 :: r885) + | 1345 -> One (R 306 :: r1050) + | 1849 -> One (R 308 :: r1198) + | 1857 -> One (R 310 :: r1202) + | 1858 -> One (R 310 :: r1203) + | 1859 -> One (R 310 :: r1204) + | 431 -> One ([R 316]) + | 435 -> One ([R 318]) + | 684 -> One ([R 320]) + | 1379 -> One ([R 321]) + | 1552 -> One ([R 324]) + | 1675 -> One ([R 325]) + | 1678 -> One ([R 326]) + | 1677 -> One ([R 328]) + | 1676 -> One ([R 330]) + | 1674 -> One ([R 331]) + | 1790 -> One ([R 343]) + | 1780 -> One ([R 345]) + | 1788 -> One ([R 346]) + | 1787 -> One ([R 348]) + | 614 -> One ([R 355]) + | 1527 -> One ([R 356]) + | 545 -> One ([R 367]) + | 555 -> One ([R 368]) + | 556 -> One ([R 369]) + | 554 -> One ([R 370]) + | 557 -> One ([R 372]) + | 170 -> One ([R 373]) + | 100 | 983 -> One ([R 374]) + | 515 -> One ([R 381]) + | 492 -> One ([R 382]) + | 522 -> One ([R 386]) + | 849 | 1208 -> One ([R 391]) + | 1041 -> One ([R 393]) + | 1039 -> One ([R 394]) + | 1042 -> One ([R 395]) + | 1040 -> One ([R 396]) + | 395 -> One ([R 399]) + | 834 -> One ([R 401]) + | 919 -> One ([R 402]) + | 1699 -> One ([R 403]) + | 935 -> One ([R 404]) + | 1700 -> One ([R 405]) + | 934 -> One ([R 406]) + | 926 -> One ([R 407]) + | 90 | 244 -> One ([R 422]) + | 114 | 632 -> One ([R 423]) + | 142 -> One ([R 424]) + | 130 -> One ([R 426]) + | 134 -> One ([R 428]) + | 138 -> One ([R 430]) + | 121 -> One ([R 431]) + | 141 | 1498 -> One ([R 432]) + | 120 -> One ([R 433]) + | 119 -> One ([R 434]) + | 118 -> One ([R 435]) + | 117 -> One ([R 436]) + | 116 -> One ([R 437]) + | 93 | 111 | 622 -> One ([R 438]) + | 92 | 621 -> One ([R 439]) + | 91 -> One ([R 440]) + | 113 | 401 | 631 -> One ([R 441]) + | 112 | 630 -> One ([R 442]) + | 88 -> One ([R 443]) + | 94 -> One ([R 444]) + | 123 -> One ([R 445]) + | 115 -> One ([R 446]) + | 122 -> One ([R 447]) + | 95 -> One ([R 448]) + | 140 -> One ([R 449]) + | 143 -> One ([R 450]) + | 139 -> One ([R 452]) + | 327 -> One ([R 453]) + | 326 -> One (R 454 :: r319) + | 262 -> One (R 455 :: r272) + | 263 -> One ([R 456]) + | 432 -> One (R 457 :: r368) + | 433 -> One ([R 458]) + | 1237 -> One (R 473 :: r989) + | 1238 -> One ([R 474]) + | 159 -> One ([R 475]) + | 387 -> One ([R 495]) + | 381 -> One ([R 496]) + | 382 -> One ([R 498]) + | 380 | 633 -> One ([R 505]) + | 764 -> One ([R 511]) + | 765 -> One ([R 512]) + | 766 -> One ([R 514]) + | 463 -> One ([R 516]) + | 1182 -> One ([R 520]) + | 941 | 1249 -> One ([R 530]) + | 1052 -> One ([R 532]) + | 1050 -> One ([R 533]) + | 1053 -> One ([R 534]) + | 1051 -> One ([R 535]) + | 1318 -> One (R 536 :: r1042) + | 251 -> One ([R 537]) | 917 -> One ([R 540]) - | 527 -> One ([R 543]) - | 479 -> One ([R 544]) - | 1277 -> One ([R 545]) - | 1276 -> One ([R 546]) - | 339 -> One ([R 548]) - | 303 -> One ([R 572]) - | 1388 -> One ([R 575]) - | 1389 -> One ([R 576]) - | 1561 -> One ([R 578]) - | 1562 -> One ([R 579]) - | 416 -> One ([R 581]) - | 417 -> One ([R 582]) - | 1491 -> One ([R 584]) - | 1492 -> One ([R 585]) - | 673 -> One ([R 587]) - | 677 -> One ([R 588]) - | 1149 -> One ([R 593]) - | 1117 -> One ([R 594]) - | 1120 -> One ([R 595]) - | 1119 -> One ([R 600]) - | 1124 -> One ([R 603]) - | 1123 -> One ([R 605]) - | 1122 -> One ([R 606]) - | 1121 -> One ([R 607]) - | 1150 -> One ([R 610]) - | 86 -> One ([R 613]) - | 83 -> One ([R 615]) - | 592 -> One ([R 639]) - | 655 -> One ([R 640]) - | 654 | 669 -> One ([R 641]) - | 595 | 650 -> One ([R 642]) - | 1396 | 1446 -> One ([R 647]) - | 653 -> One ([R 652]) - | 353 -> One ([R 665]) - | 357 -> One ([R 668]) - | 358 -> One ([R 672]) - | 389 -> One ([R 674]) - | 362 -> One ([R 675]) - | 418 -> One ([R 677]) - | 380 -> One ([R 682]) - | 28 -> One ([R 683]) - | 8 -> One ([R 684]) - | 52 -> One ([R 686]) - | 51 -> One ([R 687]) - | 50 -> One ([R 688]) - | 49 -> One ([R 689]) - | 48 -> One ([R 690]) - | 47 -> One ([R 691]) - | 46 -> One ([R 692]) - | 45 -> One ([R 693]) - | 44 -> One ([R 694]) - | 43 -> One ([R 695]) - | 42 -> One ([R 696]) - | 41 -> One ([R 697]) - | 40 -> One ([R 698]) - | 39 -> One ([R 699]) - | 38 -> One ([R 700]) - | 37 -> One ([R 701]) - | 36 -> One ([R 702]) - | 35 -> One ([R 703]) - | 34 -> One ([R 704]) - | 33 -> One ([R 705]) - | 32 -> One ([R 706]) - | 31 -> One ([R 707]) - | 30 -> One ([R 708]) - | 29 -> One ([R 709]) - | 27 -> One ([R 710]) - | 26 -> One ([R 711]) - | 25 -> One ([R 712]) - | 24 -> One ([R 713]) - | 23 -> One ([R 714]) - | 22 -> One ([R 715]) - | 21 -> One ([R 716]) - | 20 -> One ([R 717]) - | 19 -> One ([R 718]) - | 18 -> One ([R 719]) - | 17 -> One ([R 720]) - | 16 -> One ([R 721]) - | 15 -> One ([R 722]) - | 14 -> One ([R 723]) - | 13 -> One ([R 724]) - | 12 -> One ([R 725]) - | 11 -> One ([R 726]) - | 10 -> One ([R 727]) - | 9 -> One ([R 728]) - | 7 -> One ([R 729]) - | 6 -> One ([R 730]) - | 5 -> One ([R 731]) - | 4 -> One ([R 732]) - | 3 -> One ([R 733]) - | 1346 -> One ([R 734]) - | 1368 -> One ([R 739]) - | 1350 | 1367 -> One ([R 741]) - | 1353 | 1369 -> One ([R 742]) - | 1359 -> One ([R 744]) - | 1347 -> One ([R 745]) - | 1337 -> One ([R 746]) - | 1345 -> One ([R 750]) - | 1349 -> One ([R 753]) - | 1348 -> One ([R 754]) - | 1360 -> One ([R 756]) - | 236 -> One ([R 758]) - | 235 -> One ([R 759]) - | 1831 -> One ([R 763]) - | 1832 -> One ([R 764]) - | 1834 -> One ([R 765]) - | 1835 -> One ([R 766]) - | 1833 -> One ([R 767]) - | 1830 -> One ([R 768]) - | 1836 -> One ([R 772]) - | 287 -> One ([R 774]) - | 485 -> One (R 782 :: r439) - | 499 -> One ([R 783]) - | 177 -> One ([R 788]) - | 180 -> One ([R 789]) - | 184 -> One ([R 790]) - | 178 -> One ([R 791]) - | 185 -> One ([R 792]) - | 181 -> One ([R 793]) - | 186 -> One ([R 794]) - | 183 -> One ([R 795]) - | 176 -> One ([R 796]) - | 354 -> One ([R 801]) - | 652 -> One ([R 802]) - | 995 -> One ([R 810]) - | 1178 -> One ([R 811]) - | 1181 -> One ([R 812]) - | 1179 -> One ([R 813]) - | 1219 -> One ([R 814]) - | 1222 -> One ([R 815]) - | 1220 -> One ([R 816]) - | 488 -> One ([R 823]) - | 489 -> One ([R 824]) - | 1484 -> One (S (T T_WITH) :: r1088) - | 166 -> One (S (T T_TYPE) :: r119) - | 455 -> One (S (T T_TYPE) :: r388) - | 838 -> One (S (T T_STAR) :: r702) - | 1838 -> One (S (T T_SEMISEMI) :: r1184) - | 1845 -> One (S (T T_SEMISEMI) :: r1188) - | 1768 -> One (S (T T_RPAREN) :: r54) - | 365 -> One (S (T T_RPAREN) :: r329) - | 409 -> One (S (T T_RPAREN) :: r352) - | 469 -> One (S (T T_RPAREN) :: r411) - | 537 -> One (S (T T_RPAREN) :: r454) - | 1470 -> One (S (T T_RPAREN) :: r1077) - | 1629 -> One (S (T T_RPAREN) :: r1137) - | 1675 -> One (S (T T_RPAREN) :: r1149) - | 1682 -> One (S (T T_RPAREN) :: r1152) - | 1769 -> One (S (T T_RPAREN) :: r1167) - | 817 | 874 -> One (S (T T_RBRACKET) :: r243) - | 265 -> One (S (T T_RBRACKET) :: r264) - | 1476 -> One (S (T T_RBRACKET) :: r1080) - | 1478 -> One (S (T T_RBRACKET) :: r1081) - | 317 -> One (S (T T_QUOTE) :: r305) - | 1033 -> One (S (T T_OPEN) :: r841) - | 1248 -> One (S (T T_OPEN) :: r993) - | 160 -> One (S (T T_MODULE) :: r115) - | 474 -> One (S (T T_MINUSGREATER) :: r418) - | 854 -> One (S (T T_MINUSGREATER) :: r708) - | 858 -> One (S (T T_MINUSGREATER) :: r710) - | 1094 -> One (S (T T_MINUSGREATER) :: r875) - | 124 -> One (S (T T_LPAREN) :: r98) - | 156 -> One (S (T T_LIDENT) :: r110) - | 430 -> One (S (T T_LIDENT) :: r355) - | 438 -> One (S (T T_LIDENT) :: r361) - | 626 -> One (S (T T_LIDENT) :: r549) - | 627 -> One (S (T T_LIDENT) :: r555) - | 638 -> One (S (T T_LIDENT) :: r558) - | 642 -> One (S (T T_LIDENT) :: r560) - | 822 -> One (S (T T_LIDENT) :: r698) - | 1182 -> One (S (T T_LIDENT) :: r940) - | 1223 -> One (S (T T_LIDENT) :: r967) - | 1300 -> One (S (T T_LIDENT) :: r1020) - | 81 -> One (S (T T_INT) :: r52) - | 84 -> One (S (T T_INT) :: r53) - | 656 -> One (S (T T_IN) :: r567) - | 660 -> One (S (T T_IN) :: r569) - | 1268 -> One (S (T T_IN) :: r1013) - | 551 -> One (S (T T_GREATERRBRACE) :: r461) - | 1564 -> One (S (T T_GREATERRBRACE) :: r1105) - | 206 -> One (S (T T_GREATER) :: r186) - | 1670 -> One (S (T T_GREATER) :: r1147) - | 517 -> One (S (T T_EQUAL) :: r450) - | 725 -> One (S (T T_EQUAL) :: r602) - | 1172 -> One (S (T T_EQUAL) :: r937) - | 1190 -> One (S (T T_EQUAL) :: r942) - | 1211 -> One (S (T T_EQUAL) :: r964) - | 1460 -> One (S (T T_EQUAL) :: r1075) - | 1608 -> One (S (T T_EQUAL) :: r1129) - | 1760 -> One (S (T T_EOF) :: r1165) - | 1764 -> One (S (T T_EOF) :: r1166) - | 1783 -> One (S (T T_EOF) :: r1172) - | 1787 -> One (S (T T_EOF) :: r1173) - | 1791 -> One (S (T T_EOF) :: r1174) - | 1794 -> One (S (T T_EOF) :: r1175) - | 1799 -> One (S (T T_EOF) :: r1176) - | 1803 -> One (S (T T_EOF) :: r1177) - | 1807 -> One (S (T T_EOF) :: r1178) - | 1811 -> One (S (T T_EOF) :: r1179) - | 1815 -> One (S (T T_EOF) :: r1180) - | 1818 -> One (S (T T_EOF) :: r1181) - | 1822 -> One (S (T T_EOF) :: r1182) - | 1862 -> One (S (T T_EOF) :: r1197) - | 1551 -> One (S (T T_END) :: r1104) - | 126 -> One (S (T T_DOTDOT) :: r99) - | 201 -> One (S (T T_DOTDOT) :: r179) - | 892 -> One (S (T T_DOTDOT) :: r737) - | 893 -> One (S (T T_DOTDOT) :: r738) - | 226 | 1382 | 1429 -> One (S (T T_DOT) :: r217) - | 1825 -> One (S (T T_DOT) :: r451) - | 798 -> One (S (T T_DOT) :: r663) - | 825 -> One (S (T T_DOT) :: r700) - | 852 -> One (S (T T_DOT) :: r706) - | 1603 -> One (S (T T_DOT) :: r1127) - | 1773 -> One (S (T T_DOT) :: r1171) - | 202 | 814 -> One (S (T T_COLONCOLON) :: r181) - | 207 -> One (S (T T_COLON) :: r191) - | 471 -> One (S (T T_COLON) :: r414) - | 1088 -> One (S (T T_COLON) :: r873) - | 245 -> One (S (T T_BARRBRACKET) :: r233) - | 253 -> One (S (T T_BARRBRACKET) :: r242) - | 427 -> One (S (T T_BARRBRACKET) :: r354) - | 1472 -> One (S (T T_BARRBRACKET) :: r1078) - | 1474 -> One (S (T T_BARRBRACKET) :: r1079) - | 1616 -> One (S (T T_BARRBRACKET) :: r1130) - | 328 -> One (S (T T_BAR) :: r308) - | 79 -> One (S (N N_pattern) :: r50) - | 382 | 576 | 1520 -> One (S (N N_pattern) :: r56) - | 343 -> One (S (N N_pattern) :: r313) - | 373 -> One (S (N N_pattern) :: r333) - | 375 -> One (S (N N_pattern) :: r334) - | 396 -> One (S (N N_pattern) :: r345) - | 401 -> One (S (N N_pattern) :: r348) - | 728 -> One (S (N N_pattern) :: r603) - | 730 -> One (S (N N_pattern) :: r604) - | 732 -> One (S (N N_pattern) :: r605) - | 739 -> One (S (N N_pattern) :: r607) - | 745 -> One (S (N N_pattern) :: r611) - | 103 -> One (S (N N_module_type) :: r69) - | 473 -> One (S (N N_module_type) :: r416) - | 513 -> One (S (N N_module_type) :: r447) - | 515 -> One (S (N N_module_type) :: r448) - | 541 -> One (S (N N_module_type) :: r456) - | 754 -> One (S (N N_module_type) :: r627) - | 766 -> One (S (N N_module_type) :: r635) - | 1624 -> One (S (N N_module_type) :: r1136) - | 1639 -> One (S (N N_module_type) :: r1139) - | 1642 -> One (S (N N_module_type) :: r1141) - | 1645 -> One (S (N N_module_type) :: r1143) - | 219 -> One (S (N N_module_expr) :: r205) - | 446 -> One (S (N N_let_pattern) :: r378) - | 247 -> One (S (N N_expr) :: r234) - | 553 -> One (S (N N_expr) :: r464) - | 557 -> One (S (N N_expr) :: r475) - | 624 -> One (S (N N_expr) :: r548) - | 649 -> One (S (N N_expr) :: r565) - | 664 -> One (S (N N_expr) :: r570) - | 666 -> One (S (N N_expr) :: r571) - | 671 -> One (S (N N_expr) :: r572) - | 678 -> One (S (N N_expr) :: r575) - | 680 -> One (S (N N_expr) :: r576) - | 682 -> One (S (N N_expr) :: r577) - | 684 -> One (S (N N_expr) :: r578) - | 686 -> One (S (N N_expr) :: r579) - | 688 -> One (S (N N_expr) :: r580) - | 690 -> One (S (N N_expr) :: r581) - | 692 -> One (S (N N_expr) :: r582) - | 694 -> One (S (N N_expr) :: r583) - | 696 -> One (S (N N_expr) :: r584) - | 698 -> One (S (N N_expr) :: r585) - | 700 -> One (S (N N_expr) :: r586) - | 702 -> One (S (N N_expr) :: r587) - | 704 -> One (S (N N_expr) :: r588) - | 706 -> One (S (N N_expr) :: r589) - | 708 -> One (S (N N_expr) :: r590) - | 710 -> One (S (N N_expr) :: r591) - | 712 -> One (S (N N_expr) :: r592) - | 714 -> One (S (N N_expr) :: r593) - | 716 -> One (S (N N_expr) :: r594) - | 1401 -> One (S (N N_expr) :: r1058) - | 1406 -> One (S (N N_expr) :: r1062) - | 1411 -> One (S (N N_expr) :: r1066) - | 1417 -> One (S (N N_expr) :: r1067) - | 1422 -> One (S (N N_expr) :: r1068) - | 1427 -> One (S (N N_expr) :: r1069) - | 1434 -> One (S (N N_expr) :: r1070) - | 1439 -> One (S (N N_expr) :: r1071) - | 1444 -> One (S (N N_expr) :: r1072) - | 1447 -> One (S (N N_expr) :: r1073) - | 1548 -> One (S (N N_expr) :: r1103) - | 441 -> One (Sub (r1) :: r365) - | 572 -> One (Sub (r1) :: r493) - | 747 -> One (Sub (r1) :: r612) - | 1512 -> One (Sub (r1) :: r1094) - | 1745 -> One (Sub (r1) :: r1163) - | 1747 -> One (Sub (r1) :: r1164) - | 2 -> One (Sub (r11) :: r12) - | 55 -> One (Sub (r11) :: r13) - | 59 -> One (Sub (r11) :: r18) - | 209 -> One (Sub (r11) :: r194) - | 674 -> One (Sub (r11) :: r574) - | 743 -> One (Sub (r11) :: r610) - | 784 -> One (Sub (r11) :: r644) - | 786 -> One (Sub (r11) :: r647) - | 1249 -> One (Sub (r11) :: r998) - | 570 -> One (Sub (r33) :: r490) - | 1542 -> One (Sub (r33) :: r1102) - | 1743 -> One (Sub (r35) :: r1162) - | 75 -> One (Sub (r42) :: r43) - | 556 -> One (Sub (r42) :: r473) - | 591 -> One (Sub (r42) :: r526) - | 620 -> One (Sub (r42) :: r543) - | 640 -> One (Sub (r42) :: r559) - | 1272 -> One (Sub (r42) :: r1014) - | 762 -> One (Sub (r63) :: r632) - | 959 -> One (Sub (r63) :: r775) - | 866 -> One (Sub (r72) :: r711) - | 403 -> One (Sub (r77) :: r349) - | 734 -> One (Sub (r77) :: r606) - | 288 -> One (Sub (r79) :: r291) - | 300 -> One (Sub (r79) :: r296) - | 851 -> One (Sub (r79) :: r704) - | 1524 -> One (Sub (r79) :: r1100) - | 295 -> One (Sub (r81) :: r295) - | 1096 -> One (Sub (r81) :: r878) - | 286 -> One (Sub (r83) :: r290) - | 314 -> One (Sub (r85) :: r303) - | 492 -> One (Sub (r85) :: r441) - | 261 -> One (Sub (r87) :: r256) - | 398 -> One (Sub (r87) :: r347) - | 433 -> One (Sub (r87) :: r360) - | 448 -> One (Sub (r87) :: r379) - | 495 -> One (Sub (r87) :: r444) - | 613 -> One (Sub (r87) :: r539) - | 629 -> One (Sub (r87) :: r556) - | 633 -> One (Sub (r87) :: r557) - | 721 -> One (Sub (r87) :: r600) - | 1005 -> One (Sub (r87) :: r821) - | 1043 -> One (Sub (r87) :: r852) - | 1680 -> One (Sub (r87) :: r1151) - | 1684 -> One (Sub (r87) :: r1153) - | 1733 -> One (Sub (r87) :: r1161) - | 1198 -> One (Sub (r89) :: r956) - | 1229 -> One (Sub (r89) :: r970) - | 189 -> One (Sub (r105) :: r174) - | 799 -> One (Sub (r105) :: r664) - | 1828 -> One (Sub (r105) :: r1183) - | 348 -> One (Sub (r126) :: r321) - | 195 -> One (Sub (r169) :: r175) - | 182 -> One (Sub (r171) :: r173) - | 997 -> One (Sub (r171) :: r815) - | 199 -> One (Sub (r177) :: r178) - | 873 -> One (Sub (r177) :: r730) - | 922 -> One (Sub (r177) :: r745) - | 256 -> One (Sub (r253) :: r255) - | 307 -> One (Sub (r258) :: r297) - | 267 -> One (Sub (r260) :: r266) - | 281 -> One (Sub (r260) :: r289) - | 268 -> One (Sub (r272) :: r274) - | 269 -> One (Sub (r276) :: r277) - | 292 -> One (Sub (r276) :: r292) - | 1677 -> One (Sub (r276) :: r1150) - | 271 -> One (Sub (r285) :: r287) - | 521 -> One (Sub (r285) :: r452) - | 956 -> One (Sub (r285) :: r770) - | 336 -> One (Sub (r310) :: r312) - | 459 -> One (Sub (r316) :: r389) - | 359 -> One (Sub (r324) :: r325) - | 383 -> One (Sub (r338) :: r341) - | 577 -> One (Sub (r338) :: r505) - | 1199 -> One (Sub (r338) :: r961) - | 1230 -> One (Sub (r338) :: r975) - | 1521 -> One (Sub (r338) :: r1097) - | 1597 -> One (Sub (r338) :: r1123) - | 431 -> One (Sub (r357) :: r359) - | 439 -> One (Sub (r357) :: r364) - | 1466 -> One (Sub (r367) :: r1076) - | 442 -> One (Sub (r369) :: r372) - | 444 -> One (Sub (r374) :: r375) - | 1210 -> One (Sub (r384) :: r962) - | 525 -> One (Sub (r432) :: r453) - | 484 -> One (Sub (r434) :: r435) - | 554 -> One (Sub (r470) :: r472) - | 1483 -> One (Sub (r470) :: r1086) - | 1528 -> One (Sub (r498) :: r1101) - | 778 -> One (Sub (r615) :: r641) - | 1698 -> One (Sub (r665) :: r1157) - | 1710 -> One (Sub (r665) :: r1159) - | 819 -> One (Sub (r681) :: r682) - | 820 -> One (Sub (r690) :: r692) - | 875 -> One (Sub (r690) :: r732) - | 894 -> One (Sub (r690) :: r740) - | 902 -> One (Sub (r690) :: r742) - | 1686 -> One (Sub (r690) :: r1155) - | 980 -> One (Sub (r757) :: r786) - | 973 -> One (Sub (r783) :: r785) - | 1296 -> One (Sub (r795) :: r1019) - | 1320 -> One (Sub (r795) :: r1028) - | 1260 -> One (Sub (r847) :: r1005) - | 1247 -> One (Sub (r907) :: r988) - | 1324 -> One (Sub (r910) :: r1029) - | 1165 -> One (Sub (r928) :: r930) - | 1193 -> One (Sub (r947) :: r949) - | 1480 -> One (Sub (r1082) :: r1084) - | 663 -> One (r0) - | 1759 -> One (r2) - | 1758 -> One (r3) - | 1757 -> One (r4) - | 1756 -> One (r5) - | 1755 -> One (r6) - | 58 -> One (r7) - | 53 -> One (r8) - | 54 -> One (r10) - | 57 -> One (r12) - | 56 -> One (r13) - | 1361 -> One (r14) - | 1754 -> One (r16) - | 1753 -> One (r17) - | 60 -> One (r18) - | 1752 -> One (r19) - | 1751 -> One (r20) - | 1750 -> One (r21) - | 1749 -> One (r22) - | 63 -> One (r23) - | 62 -> One (r24) - | 64 -> One (r25) - | 65 -> One (r26) - | 1742 -> One (r27) - | 68 -> One (r28) - | 67 -> One (r29) - | 1539 -> One (r30) - | 1537 -> One (r31) - | 571 -> One (r32) - | 1544 -> One (r34) - | 1741 -> One (r36) - | 1740 -> One (r37) - | 1739 -> One (r38) - | 71 -> One (r39) - | 70 -> One (r40) - | 74 -> One (r41) - | 1618 -> One (r43) - | 1738 -> One (r44) - | 1737 -> One (r45) - | 1736 -> One (r46) - | 78 -> One (r47) - | 77 -> One (r48) - | 1732 -> One (r49) - | 1731 -> One (r50) - | 80 -> One (r51) - | 82 -> One (r52) - | 85 -> One (r53) - | 89 -> One (r54) - | 395 -> One (r55) - | 394 -> One (r56) - | 144 -> One (r57) - | 146 -> One (r59) - | 145 -> One (r60) - | 110 -> One (r61) - | 99 -> One (r62) - | 102 -> One (r64) - | 101 -> One (r65) - | 98 -> One (r66) - | 97 -> One (r67) - | 1730 -> One (r68) - | 1729 -> One (r69) - | 104 | 151 -> One (r70) - | 1153 -> One (r71) - | 1728 -> One (r73) - | 1727 -> One (r74) - | 106 -> One (r75) - | 147 | 246 | 555 | 1498 -> One (r76) - | 150 -> One (r78) - | 299 -> One (r80) - | 285 -> One (r82) - | 315 -> One (r84) - | 325 -> One (r86) - | 809 -> One (r88) - | 1726 -> One (r90) - | 1725 -> One (r91) - | 149 -> One (r92) - | 148 -> One (r93) - | 109 -> One (r94) - | 108 -> One (r95) - | 129 -> One (r96) - | 128 -> One (r97) - | 125 -> One (r98) - | 127 -> One (r99) - | 133 -> One (r100) - | 132 -> One (r101) - | 137 -> One (r102) - | 136 -> One (r103) - | 154 -> One (r104) - | 162 -> One (r106) - | 161 -> One (r107) - | 158 -> One (r109) - | 157 -> One (r110) - | 1724 -> One (r111) - | 1723 -> One (r112) - | 165 -> One (r113) - | 164 -> One (r114) - | 163 -> One (r115) - | 1722 -> One (r116) - | 169 -> One (r117) - | 168 -> One (r118) - | 167 -> One (r119) - | 1721 -> One (r120) - | 1720 -> One (r121) - | 172 -> One (r122) - | 205 -> One (r123) - | 289 -> One (r125) - | 351 -> One (r127) - | 865 -> One (r129) - | 901 -> One (r131) - | 900 -> One (r132) - | 899 | 1709 -> One (r133) - | 1705 -> One (r135) - | 1719 -> One (r137) - | 1718 -> One (r138) - | 1717 -> One (r139) - | 1716 -> One (r140) - | 1715 -> One (r141) - | 928 -> One (r145) - | 927 -> One (r146) - | 926 -> One (r147) - | 1702 -> One (r153) - | 1701 -> One (r154) - | 1695 -> One (r155) - | 1694 -> One (r156) - | 1693 -> One (r157) - | 910 -> One (r159) - | 909 -> One (r160) - | 908 -> One (r161) - | 188 -> One (r165) - | 191 -> One (r167) - | 187 -> One (r168) - | 192 -> One (r170) - | 194 -> One (r172) - | 193 -> One (r173) - | 190 -> One (r174) - | 196 -> One (r175) - | 878 -> One (r176) - | 1692 -> One (r178) - | 1689 -> One (r179) - | 816 -> One (r180) - | 815 -> One (r181) - | 1674 -> One (r182) - | 1673 -> One (r183) - | 1672 -> One (r184) - | 204 -> One (r185) - | 1669 -> One (r186) - | 832 -> One (r187) - | 1661 -> One (r189) - | 1660 -> One (r190) - | 208 -> One (r191) - | 1659 -> One (r192) - | 1658 -> One (r193) - | 210 -> One (r194) - | 1657 -> One (r195) - | 1653 -> One (r196) - | 1652 -> One (r197) - | 1651 -> One (r198) - | 1650 -> One (r199) - | 1649 -> One (r200) - | 1648 -> One (r201) - | 218 -> One (r202) - | 217 -> One (r203) - | 540 -> One (r204) - | 539 -> One (r205) - | 1638 -> One (r206) - | 1637 -> One (r207) - | 221 -> One (r208) - | 225 -> One (r209) - | 231 -> One (r211) - | 232 -> One (r213) - | 224 -> One (r214) - | 223 -> One (r215) - | 229 -> One (r216) - | 227 -> One (r217) - | 228 -> One (r218) - | 230 -> One (r219) - | 234 -> One (r220) - | 1636 -> One (r221) - | 1635 -> One (r222) - | 1634 -> One (r223) - | 239 -> One (r224) - | 238 -> One (r225) - | 1633 -> One (r226) - | 1632 -> One (r227) - | 1631 -> One (r228) - | 242 -> One (r229) - | 241 -> One (r230) - | 1628 -> One (r231) - | 1627 -> One (r232) - | 1615 -> One (r233) - | 1614 -> One (r234) - | 429 -> One (r235) - | 1613 -> One (r237) - | 1612 -> One (r238) - | 252 -> One (r239) - | 250 -> One (r240) - | 249 -> One (r241) - | 426 -> One (r242) - | 255 -> One (r243) - | 415 -> One (r244) - | 414 -> One (r246) - | 413 -> One (r247) - | 257 -> One (r248) - | 420 -> One (r250) - | 342 -> One (r251) - | 260 -> One (r252) - | 259 -> One (r254) - | 258 -> One (r255) - | 341 -> One (r256) - | 323 -> One (r257) - | 304 -> One (r259) - | 335 -> One (r261) - | 334 -> One (r262) - | 264 -> One (r263) - | 266 -> One (r264) - | 333 -> One (r265) - | 332 -> One (r266) - | 283 -> One (r267) - | 282 -> One (r268) - | 322 -> One (r270) - | 309 -> One (r271) - | 327 -> One (r273) - | 326 -> One (r274) - | 279 | 1099 -> One (r275) - | 280 -> One (r277) - | 275 -> One (r278) - | 274 -> One (r279) - | 278 -> One (r281) - | 276 -> One (r284) - | 273 -> One (r286) - | 272 -> One (r287) - | 306 -> One (r288) - | 305 -> One (r289) - | 302 -> One (r290) - | 291 -> One (r291) - | 293 -> One (r292) - | 298 -> One (r293) - | 297 -> One (r294) - | 296 -> One (r295) - | 301 -> One (r296) - | 308 -> One (r297) - | 321 -> One (r298) - | 320 -> One (r300) - | 313 -> One (r301) - | 312 -> One (r302) - | 316 -> One (r303) - | 319 -> One (r304) - | 318 -> One (r305) - | 331 -> One (r306) - | 330 -> One (r307) - | 329 -> One (r308) - | 340 -> One (r309) - | 338 -> One (r311) - | 337 -> One (r312) - | 419 -> One (r313) - | 355 | 720 -> One (r315) - | 356 -> One (r317) - | 346 -> One (r318) - | 345 -> One (r319) - | 347 -> One (r320) - | 349 -> One (r321) - | 361 -> One (r323) - | 360 -> One (r325) - | 412 -> One (r326) - | 411 -> One (r327) - | 364 -> One (r328) - | 366 -> One (r329) - | 406 -> One (r330) - | 369 -> One (r331) - | 368 -> One (r332) - | 374 -> One (r333) - | 376 -> One (r334) - | 379 -> One (r335) - | 405 -> One (r336) - | 384 -> One (r337) - | 388 -> One (r339) - | 387 -> One (r340) - | 386 -> One (r341) - | 390 -> One (r342) - | 393 -> One (r343) - | 392 -> One (r344) - | 397 -> One (r345) - | 400 -> One (r346) - | 399 -> One (r347) - | 402 -> One (r348) - | 404 -> One (r349) - | 408 -> One (r350) - | 407 -> One (r351) - | 410 -> One (r352) - | 424 -> One (r353) - | 428 -> One (r354) - | 437 -> One (r355) - | 432 -> One (r356) - | 436 -> One (r358) - | 435 -> One (r359) - | 434 -> One (r360) - | 1595 -> One (r361) - | 1594 -> One (r362) - | 1593 -> One (r363) - | 440 -> One (r364) - | 1592 -> One (r365) - | 443 -> One (r366) - | 1468 -> One (r368) - | 1465 -> One (r370) - | 1464 -> One (r371) - | 1463 -> One (r372) - | 445 -> One (r373) - | 454 -> One (r375) - | 452 -> One (r376) - | 451 -> One (r377) - | 450 -> One (r378) - | 449 -> One (r379) - | 1589 -> One (r380) - | 461 -> One (r381) - | 1214 -> One (r383) - | 1590 -> One (r385) - | 458 -> One (r386) - | 457 -> One (r387) - | 456 -> One (r388) - | 460 -> One (r389) - | 1573 -> One (r390) - | 1572 -> One (r391) - | 1571 -> One (r392) - | 1570 -> One (r393) - | 1569 -> One (r394) - | 463 -> One (r395) - | 1344 -> One (r396) - | 1343 -> One (r397) - | 1342 -> One (r398) - | 1341 -> One (r399) - | 1340 -> One (r400) - | 1339 -> One (r401) - | 1568 -> One (r402) - | 549 -> One (r403) - | 548 -> One (r404) - | 466 -> One (r405) - | 465 -> One (r406) - | 536 -> One (r407) - | 534 -> One (r408) - | 533 -> One (r409) - | 468 -> One (r410) - | 470 -> One (r411) - | 532 -> One (r412) - | 531 -> One (r413) - | 472 -> One (r414) - | 530 -> One (r415) - | 529 -> One (r416) - | 528 -> One (r417) - | 475 -> One (r418) - | 483 -> One (r419) - | 481 -> One (r420) + | 918 -> One ([R 541]) + | 913 -> One ([R 542]) + | 1716 -> One ([R 544]) + | 1715 -> One ([R 545]) + | 1717 -> One ([R 546]) + | 1712 -> One ([R 547]) + | 1713 -> One ([R 548]) + | 947 -> One ([R 550]) + | 945 -> One ([R 551]) + | 589 -> One ([R 555]) + | 537 -> One ([R 556]) + | 489 -> One ([R 557]) + | 1305 -> One ([R 558]) + | 1304 -> One ([R 559]) + | 349 -> One ([R 561]) + | 319 -> One ([R 585]) + | 1417 -> One ([R 588]) + | 1418 -> One ([R 589]) + | 1572 -> One ([R 591]) + | 1573 -> One ([R 592]) + | 426 -> One ([R 594]) + | 427 -> One ([R 595]) + | 1519 -> One ([R 597]) + | 1520 -> One ([R 598]) + | 1177 -> One ([R 604]) + | 1145 -> One ([R 605]) + | 1148 -> One ([R 606]) + | 1147 -> One ([R 611]) + | 1152 -> One ([R 614]) + | 1151 -> One ([R 616]) + | 1150 -> One ([R 617]) + | 1149 -> One ([R 618]) + | 1178 -> One ([R 621]) + | 86 -> One ([R 624]) + | 83 -> One ([R 626]) + | 613 -> One ([R 650]) + | 680 -> One ([R 651]) + | 679 | 694 -> One ([R 652]) + | 616 | 675 -> One ([R 653]) + | 678 -> One ([R 663]) + | 363 -> One ([R 676]) + | 367 -> One ([R 679]) + | 368 -> One ([R 683]) + | 399 -> One ([R 685]) + | 372 -> One ([R 686]) + | 428 -> One ([R 688]) + | 390 -> One ([R 693]) + | 28 -> One ([R 694]) + | 8 -> One ([R 695]) + | 52 -> One ([R 697]) + | 51 -> One ([R 698]) + | 50 -> One ([R 699]) + | 49 -> One ([R 700]) + | 48 -> One ([R 701]) + | 47 -> One ([R 702]) + | 46 -> One ([R 703]) + | 45 -> One ([R 704]) + | 44 -> One ([R 705]) + | 43 -> One ([R 706]) + | 42 -> One ([R 707]) + | 41 -> One ([R 708]) + | 40 -> One ([R 709]) + | 39 -> One ([R 710]) + | 38 -> One ([R 711]) + | 37 -> One ([R 712]) + | 36 -> One ([R 713]) + | 35 -> One ([R 714]) + | 34 -> One ([R 715]) + | 33 -> One ([R 716]) + | 32 -> One ([R 717]) + | 31 -> One ([R 718]) + | 30 -> One ([R 719]) + | 29 -> One ([R 720]) + | 27 -> One ([R 721]) + | 26 -> One ([R 722]) + | 25 -> One ([R 723]) + | 24 -> One ([R 724]) + | 23 -> One ([R 725]) + | 22 -> One ([R 726]) + | 21 -> One ([R 727]) + | 20 -> One ([R 728]) + | 19 -> One ([R 729]) + | 18 -> One ([R 730]) + | 17 -> One ([R 731]) + | 16 -> One ([R 732]) + | 15 -> One ([R 733]) + | 14 -> One ([R 734]) + | 13 -> One ([R 735]) + | 12 -> One ([R 736]) + | 11 -> One ([R 737]) + | 10 -> One ([R 738]) + | 9 -> One ([R 739]) + | 7 -> One ([R 740]) + | 6 -> One ([R 741]) + | 5 -> One ([R 742]) + | 4 -> One ([R 743]) + | 3 -> One ([R 744]) + | 1374 -> One ([R 745]) + | 1395 -> One ([R 749]) + | 1378 | 1394 -> One ([R 751]) + | 1381 | 1396 -> One ([R 752]) + | 1387 -> One ([R 754]) + | 1375 -> One ([R 755]) + | 1365 -> One ([R 756]) + | 1373 -> One ([R 760]) + | 1377 -> One ([R 763]) + | 1376 -> One ([R 764]) + | 1388 -> One ([R 766]) + | 236 -> One ([R 768]) + | 235 -> One ([R 769]) + | 1840 -> One ([R 773]) + | 1841 -> One ([R 774]) + | 1843 -> One ([R 775]) + | 1844 -> One ([R 776]) + | 1842 -> One ([R 777]) + | 1839 -> One ([R 778]) + | 1845 -> One ([R 782]) + | 287 -> One ([R 784]) + | 495 -> One (R 792 :: r449) + | 509 -> One ([R 793]) + | 177 -> One ([R 798]) + | 180 -> One ([R 799]) + | 184 -> One ([R 800]) + | 178 -> One ([R 801]) + | 185 -> One ([R 802]) + | 181 -> One ([R 803]) + | 186 -> One ([R 804]) + | 183 -> One ([R 805]) + | 176 -> One ([R 806]) + | 364 -> One ([R 811]) + | 677 -> One ([R 812]) + | 1023 -> One ([R 820]) + | 1206 -> One ([R 821]) + | 1209 -> One ([R 822]) + | 1207 -> One ([R 823]) + | 1247 -> One ([R 824]) + | 1250 -> One ([R 825]) + | 1248 -> One ([R 826]) + | 498 -> One ([R 833]) + | 499 -> One ([R 834]) + | 1513 -> One (S (T T_WITH) :: r1113) + | 166 -> One (S (T T_TYPE) :: r125) + | 866 -> One (S (T T_STAR) :: r726) + | 1847 -> One (S (T T_SEMISEMI) :: r1197) + | 1854 -> One (S (T T_SEMISEMI) :: r1201) + | 1777 -> One (S (T T_RPAREN) :: r60) + | 309 | 1692 -> One (S (T T_RPAREN) :: r311) + | 375 -> One (S (T T_RPAREN) :: r344) + | 419 -> One (S (T T_RPAREN) :: r367) + | 479 -> One (S (T T_RPAREN) :: r421) + | 547 -> One (S (T T_RPAREN) :: r464) + | 1499 -> One (S (T T_RPAREN) :: r1102) + | 1637 -> One (S (T T_RPAREN) :: r1150) + | 1639 -> One (S (T T_RPAREN) :: r1151) + | 1685 -> One (S (T T_RPAREN) :: r1163) + | 1778 -> One (S (T T_RPAREN) :: r1180) + | 845 | 902 -> One (S (T T_RBRACKET) :: r252) + | 1505 -> One (S (T T_RBRACKET) :: r1105) + | 1507 -> One (S (T T_RBRACKET) :: r1106) + | 313 -> One (S (T T_QUOTE) :: r313) + | 1061 -> One (S (T T_OPEN) :: r865) + | 1276 -> One (S (T T_OPEN) :: r1018) + | 160 | 292 -> One (S (T T_MODULE) :: r121) + | 484 -> One (S (T T_MINUSGREATER) :: r428) + | 882 -> One (S (T T_MINUSGREATER) :: r732) + | 886 -> One (S (T T_MINUSGREATER) :: r734) + | 1122 -> One (S (T T_MINUSGREATER) :: r899) + | 124 -> One (S (T T_LPAREN) :: r104) + | 156 -> One (S (T T_LIDENT) :: r116) + | 440 -> One (S (T T_LIDENT) :: r370) + | 448 -> One (S (T T_LIDENT) :: r376) + | 651 -> One (S (T T_LIDENT) :: r571) + | 652 -> One (S (T T_LIDENT) :: r577) + | 663 -> One (S (T T_LIDENT) :: r580) + | 667 -> One (S (T T_LIDENT) :: r582) + | 850 -> One (S (T T_LIDENT) :: r722) + | 1210 -> One (S (T T_LIDENT) :: r964) + | 1251 -> One (S (T T_LIDENT) :: r992) + | 1328 -> One (S (T T_LIDENT) :: r1045) + | 81 -> One (S (T T_INT) :: r58) + | 84 -> One (S (T T_INT) :: r59) + | 681 -> One (S (T T_IN) :: r590) + | 685 -> One (S (T T_IN) :: r592) + | 1296 -> One (S (T T_IN) :: r1038) + | 561 -> One (S (T T_GREATERRBRACE) :: r471) + | 1575 -> One (S (T T_GREATERRBRACE) :: r1122) + | 206 -> One (S (T T_GREATER) :: r192) + | 1680 -> One (S (T T_GREATER) :: r1161) + | 527 -> One (S (T T_EQUAL) :: r460) + | 753 -> One (S (T T_EQUAL) :: r626) + | 1200 -> One (S (T T_EQUAL) :: r961) + | 1218 -> One (S (T T_EQUAL) :: r966) + | 1489 -> One (S (T T_EQUAL) :: r1100) + | 1618 -> One (S (T T_EQUAL) :: r1146) + | 1769 -> One (S (T T_EOF) :: r1178) + | 1773 -> One (S (T T_EOF) :: r1179) + | 1792 -> One (S (T T_EOF) :: r1185) + | 1796 -> One (S (T T_EOF) :: r1186) + | 1800 -> One (S (T T_EOF) :: r1187) + | 1803 -> One (S (T T_EOF) :: r1188) + | 1808 -> One (S (T T_EOF) :: r1189) + | 1812 -> One (S (T T_EOF) :: r1190) + | 1816 -> One (S (T T_EOF) :: r1191) + | 1820 -> One (S (T T_EOF) :: r1192) + | 1824 -> One (S (T T_EOF) :: r1193) + | 1827 -> One (S (T T_EOF) :: r1194) + | 1831 -> One (S (T T_EOF) :: r1195) + | 1871 -> One (S (T T_EOF) :: r1210) + | 1562 -> One (S (T T_END) :: r1121) + | 126 -> One (S (T T_DOTDOT) :: r105) + | 201 -> One (S (T T_DOTDOT) :: r185) + | 920 -> One (S (T T_DOTDOT) :: r761) + | 921 -> One (S (T T_DOTDOT) :: r762) + | 226 | 1411 | 1458 -> One (S (T T_DOT) :: r223) + | 1834 -> One (S (T T_DOT) :: r461) + | 826 -> One (S (T T_DOT) :: r687) + | 853 -> One (S (T T_DOT) :: r724) + | 880 -> One (S (T T_DOT) :: r730) + | 1613 -> One (S (T T_DOT) :: r1144) + | 1782 -> One (S (T T_DOT) :: r1184) + | 744 -> One (S (T T_COMMA) :: r612) + | 202 | 842 -> One (S (T T_COLONCOLON) :: r187) + | 207 -> One (S (T T_COLON) :: r197) + | 481 -> One (S (T T_COLON) :: r424) + | 1116 -> One (S (T T_COLON) :: r897) + | 245 -> One (S (T T_BARRBRACKET) :: r242) + | 253 -> One (S (T T_BARRBRACKET) :: r251) + | 437 -> One (S (T T_BARRBRACKET) :: r369) + | 1501 -> One (S (T T_BARRBRACKET) :: r1103) + | 1503 -> One (S (T T_BARRBRACKET) :: r1104) + | 1626 -> One (S (T T_BARRBRACKET) :: r1147) + | 338 -> One (S (T T_BAR) :: r323) + | 79 -> One (S (N N_pattern) :: r56) + | 392 | 465 -> One (S (N N_pattern) :: r62) + | 353 -> One (S (N N_pattern) :: r328) + | 383 -> One (S (N N_pattern) :: r348) + | 385 -> One (S (N N_pattern) :: r349) + | 406 -> One (S (N N_pattern) :: r360) + | 411 -> One (S (N N_pattern) :: r363) + | 756 -> One (S (N N_pattern) :: r627) + | 758 -> One (S (N N_pattern) :: r628) + | 760 -> One (S (N N_pattern) :: r629) + | 767 -> One (S (N N_pattern) :: r631) + | 773 -> One (S (N N_pattern) :: r635) + | 103 -> One (S (N N_module_type) :: r75) + | 483 -> One (S (N N_module_type) :: r426) + | 523 -> One (S (N N_module_type) :: r457) + | 525 -> One (S (N N_module_type) :: r458) + | 551 -> One (S (N N_module_type) :: r466) + | 782 -> One (S (N N_module_type) :: r651) + | 794 -> One (S (N N_module_type) :: r659) + | 1634 -> One (S (N N_module_type) :: r1149) + | 1649 -> One (S (N N_module_type) :: r1153) + | 1652 -> One (S (N N_module_type) :: r1155) + | 1655 -> One (S (N N_module_type) :: r1157) + | 219 -> One (S (N N_module_expr) :: r211) + | 456 -> One (S (N N_let_pattern) :: r393) + | 247 -> One (S (N N_expr) :: r243) + | 563 -> One (S (N N_expr) :: r474) + | 567 -> One (S (N N_expr) :: r485) + | 649 -> One (S (N N_expr) :: r570) + | 674 -> One (S (N N_expr) :: r588) + | 690 -> One (S (N N_expr) :: r593) + | 692 -> One (S (N N_expr) :: r594) + | 696 -> One (S (N N_expr) :: r595) + | 698 -> One (S (N N_expr) :: r596) + | 700 -> One (S (N N_expr) :: r597) + | 702 -> One (S (N N_expr) :: r598) + | 704 -> One (S (N N_expr) :: r599) + | 706 -> One (S (N N_expr) :: r600) + | 708 -> One (S (N N_expr) :: r601) + | 710 -> One (S (N N_expr) :: r602) + | 712 -> One (S (N N_expr) :: r603) + | 714 -> One (S (N N_expr) :: r604) + | 716 -> One (S (N N_expr) :: r605) + | 718 -> One (S (N N_expr) :: r606) + | 720 -> One (S (N N_expr) :: r607) + | 722 -> One (S (N N_expr) :: r608) + | 724 -> One (S (N N_expr) :: r609) + | 726 -> One (S (N N_expr) :: r610) + | 730 -> One (S (N N_expr) :: r613) + | 732 -> One (S (N N_expr) :: r614) + | 734 -> One (S (N N_expr) :: r615) + | 736 -> One (S (N N_expr) :: r616) + | 1430 -> One (S (N N_expr) :: r1083) + | 1435 -> One (S (N N_expr) :: r1087) + | 1440 -> One (S (N N_expr) :: r1091) + | 1446 -> One (S (N N_expr) :: r1092) + | 1451 -> One (S (N N_expr) :: r1093) + | 1456 -> One (S (N N_expr) :: r1094) + | 1463 -> One (S (N N_expr) :: r1095) + | 1468 -> One (S (N N_expr) :: r1096) + | 1473 -> One (S (N N_expr) :: r1097) + | 1476 -> One (S (N N_expr) :: r1098) + | 1559 -> One (S (N N_expr) :: r1120) + | 75 -> One (Sub (r1) :: r49) + | 566 -> One (Sub (r1) :: r483) + | 612 -> One (Sub (r1) :: r545) + | 641 -> One (Sub (r1) :: r562) + | 665 -> One (Sub (r1) :: r581) + | 1300 -> One (Sub (r1) :: r1039) + | 451 -> One (Sub (r7) :: r380) + | 582 -> One (Sub (r7) :: r503) + | 775 -> One (Sub (r7) :: r636) + | 1540 -> One (Sub (r7) :: r1119) + | 1754 -> One (Sub (r7) :: r1176) + | 1756 -> One (Sub (r7) :: r1177) + | 2 -> One (Sub (r17) :: r18) + | 55 -> One (Sub (r17) :: r19) + | 59 -> One (Sub (r17) :: r26) + | 209 -> One (Sub (r17) :: r200) + | 741 -> One (Sub (r17) :: r618) + | 771 -> One (Sub (r17) :: r634) + | 812 -> One (Sub (r17) :: r668) + | 814 -> One (Sub (r17) :: r671) + | 1277 -> One (Sub (r17) :: r1023) + | 580 -> One (Sub (r40) :: r500) + | 599 -> One (Sub (r40) :: r524) + | 1752 -> One (Sub (r42) :: r1175) + | 790 -> One (Sub (r69) :: r656) + | 987 -> One (Sub (r69) :: r799) + | 894 -> One (Sub (r78) :: r735) + | 413 -> One (Sub (r83) :: r364) + | 762 -> One (Sub (r83) :: r630) + | 288 -> One (Sub (r85) :: r301) + | 303 -> One (Sub (r85) :: r309) + | 591 -> One (Sub (r85) :: r520) + | 879 -> One (Sub (r85) :: r728) + | 293 -> One (Sub (r87) :: r308) + | 1124 -> One (Sub (r87) :: r902) + | 286 -> One (Sub (r89) :: r300) + | 330 -> One (Sub (r91) :: r320) + | 502 -> One (Sub (r91) :: r451) + | 261 -> One (Sub (r93) :: r265) + | 408 -> One (Sub (r93) :: r362) + | 443 -> One (Sub (r93) :: r375) + | 458 -> One (Sub (r93) :: r394) + | 505 -> One (Sub (r93) :: r454) + | 634 -> One (Sub (r93) :: r558) + | 654 -> One (Sub (r93) :: r578) + | 658 -> One (Sub (r93) :: r579) + | 749 -> One (Sub (r93) :: r624) + | 1033 -> One (Sub (r93) :: r845) + | 1071 -> One (Sub (r93) :: r876) + | 1690 -> One (Sub (r93) :: r1165) + | 1693 -> One (Sub (r93) :: r1166) + | 1742 -> One (Sub (r93) :: r1174) + | 1226 -> One (Sub (r95) :: r981) + | 1257 -> One (Sub (r95) :: r995) + | 189 -> One (Sub (r111) :: r180) + | 827 -> One (Sub (r111) :: r688) + | 1837 -> One (Sub (r111) :: r1196) + | 358 -> One (Sub (r132) :: r336) + | 195 -> One (Sub (r175) :: r181) + | 182 -> One (Sub (r177) :: r179) + | 1025 -> One (Sub (r177) :: r839) + | 199 -> One (Sub (r183) :: r184) + | 901 -> One (Sub (r183) :: r754) + | 950 -> One (Sub (r183) :: r769) + | 256 -> One (Sub (r262) :: r264) + | 323 -> One (Sub (r267) :: r314) + | 267 -> One (Sub (r269) :: r276) + | 281 -> One (Sub (r269) :: r299) + | 268 -> One (Sub (r282) :: r284) + | 269 -> One (Sub (r286) :: r287) + | 305 -> One (Sub (r286) :: r310) + | 1687 -> One (Sub (r286) :: r1164) + | 271 -> One (Sub (r293) :: r295) + | 531 -> One (Sub (r293) :: r462) + | 984 -> One (Sub (r293) :: r794) + | 346 -> One (Sub (r325) :: r327) + | 469 -> One (Sub (r331) :: r397) + | 369 -> One (Sub (r339) :: r340) + | 393 -> One (Sub (r353) :: r356) + | 466 -> One (Sub (r353) :: r396) + | 1227 -> One (Sub (r353) :: r986) + | 1258 -> One (Sub (r353) :: r1000) + | 1607 -> One (Sub (r353) :: r1140) + | 441 -> One (Sub (r372) :: r374) + | 449 -> One (Sub (r372) :: r379) + | 1495 -> One (Sub (r382) :: r1101) + | 452 -> One (Sub (r384) :: r387) + | 454 -> One (Sub (r389) :: r390) + | 535 -> One (Sub (r442) :: r463) + | 494 -> One (Sub (r444) :: r445) + | 564 -> One (Sub (r480) :: r482) + | 1512 -> One (Sub (r480) :: r1111) + | 806 -> One (Sub (r639) :: r665) + | 1707 -> One (Sub (r689) :: r1170) + | 1719 -> One (Sub (r689) :: r1172) + | 847 -> One (Sub (r705) :: r706) + | 848 -> One (Sub (r714) :: r716) + | 903 -> One (Sub (r714) :: r756) + | 922 -> One (Sub (r714) :: r764) + | 930 -> One (Sub (r714) :: r766) + | 1695 -> One (Sub (r714) :: r1168) + | 1008 -> One (Sub (r781) :: r810) + | 1001 -> One (Sub (r807) :: r809) + | 1324 -> One (Sub (r819) :: r1044) + | 1348 -> One (Sub (r819) :: r1053) + | 1288 -> One (Sub (r871) :: r1030) + | 1275 -> One (Sub (r931) :: r1013) + | 1352 -> One (Sub (r934) :: r1054) + | 1193 -> One (Sub (r952) :: r954) + | 1221 -> One (Sub (r972) :: r974) + | 1509 -> One (Sub (r1107) :: r1109) + | 64 -> One (r0) + | 650 -> One (r2) + | 689 -> One (r4) + | 688 -> One (r6) + | 1768 -> One (r8) + | 1767 -> One (r9) + | 1766 -> One (r10) + | 1765 -> One (r11) + | 1764 -> One (r12) + | 58 -> One (r13) + | 53 -> One (r14) + | 54 -> One (r16) + | 57 -> One (r18) + | 56 -> One (r19) + | 1389 -> One (r20) + | 1393 -> One (r22) + | 1763 -> One (r24) + | 1762 -> One (r25) + | 60 -> One (r26) + | 1761 -> One (r27) + | 1760 -> One (r28) + | 1759 -> One (r29) + | 1758 -> One (r30) + | 63 -> One (r31) + | 62 -> One (r32) + | 65 -> One (r33) + | 1751 -> One (r34) + | 68 -> One (r35) + | 67 -> One (r36) + | 1553 -> One (r37) + | 1551 -> One (r38) + | 581 -> One (r39) + | 601 -> One (r41) + | 1750 -> One (r43) + | 1749 -> One (r44) + | 1748 -> One (r45) + | 71 -> One (r46) + | 70 -> One (r47) + | 74 -> One (r48) + | 1628 -> One (r49) + | 1747 -> One (r50) + | 1746 -> One (r51) + | 1745 -> One (r52) + | 78 -> One (r53) + | 77 -> One (r54) + | 1741 -> One (r55) + | 1740 -> One (r56) + | 80 -> One (r57) + | 82 -> One (r58) + | 85 -> One (r59) + | 89 -> One (r60) + | 405 -> One (r61) + | 404 -> One (r62) + | 144 -> One (r63) + | 146 -> One (r65) + | 145 -> One (r66) + | 110 -> One (r67) + | 99 -> One (r68) + | 102 -> One (r70) + | 101 -> One (r71) + | 98 -> One (r72) + | 97 -> One (r73) + | 1739 -> One (r74) + | 1738 -> One (r75) + | 104 | 151 -> One (r76) + | 1181 -> One (r77) + | 1737 -> One (r79) + | 1736 -> One (r80) + | 106 -> One (r81) + | 147 | 246 | 565 | 1526 -> One (r82) + | 150 -> One (r84) + | 302 -> One (r86) + | 285 -> One (r88) + | 308 -> One (r90) + | 312 -> One (r92) + | 837 -> One (r94) + | 1735 -> One (r96) + | 1734 -> One (r97) + | 149 -> One (r98) + | 148 -> One (r99) + | 109 -> One (r100) + | 108 -> One (r101) + | 129 -> One (r102) + | 128 -> One (r103) + | 125 -> One (r104) + | 127 -> One (r105) + | 133 -> One (r106) + | 132 -> One (r107) + | 137 -> One (r108) + | 136 -> One (r109) + | 154 -> One (r110) + | 162 -> One (r112) + | 161 -> One (r113) + | 158 -> One (r115) + | 157 -> One (r116) + | 1733 -> One (r117) + | 1732 -> One (r118) + | 165 -> One (r119) + | 164 -> One (r120) + | 163 -> One (r121) + | 1731 -> One (r122) + | 169 -> One (r123) + | 168 -> One (r124) + | 167 -> One (r125) + | 1730 -> One (r126) + | 1729 -> One (r127) + | 172 -> One (r128) + | 205 -> One (r129) + | 296 -> One (r131) + | 361 -> One (r133) + | 893 -> One (r135) + | 929 -> One (r137) + | 928 -> One (r138) + | 927 | 1718 -> One (r139) + | 1714 -> One (r141) + | 1728 -> One (r143) + | 1727 -> One (r144) + | 1726 -> One (r145) + | 1725 -> One (r146) + | 1724 -> One (r147) + | 956 -> One (r151) + | 955 -> One (r152) + | 954 -> One (r153) + | 1711 -> One (r159) + | 1710 -> One (r160) + | 1704 -> One (r161) + | 1703 -> One (r162) + | 1702 -> One (r163) + | 938 -> One (r165) + | 937 -> One (r166) + | 936 -> One (r167) + | 188 -> One (r171) + | 191 -> One (r173) + | 187 -> One (r174) + | 192 -> One (r176) + | 194 -> One (r178) + | 193 -> One (r179) + | 190 -> One (r180) + | 196 -> One (r181) + | 906 -> One (r182) + | 1701 -> One (r184) + | 1698 -> One (r185) + | 844 -> One (r186) + | 843 -> One (r187) + | 1684 -> One (r188) + | 1683 -> One (r189) + | 1682 -> One (r190) + | 204 -> One (r191) + | 1679 -> One (r192) + | 860 -> One (r193) + | 1671 -> One (r195) + | 1670 -> One (r196) + | 208 -> One (r197) + | 1669 -> One (r198) + | 1668 -> One (r199) + | 210 -> One (r200) + | 1667 -> One (r201) + | 1663 -> One (r202) + | 1662 -> One (r203) + | 1661 -> One (r204) + | 1660 -> One (r205) + | 1659 -> One (r206) + | 1658 -> One (r207) + | 218 -> One (r208) + | 217 -> One (r209) + | 550 -> One (r210) + | 549 -> One (r211) + | 1648 -> One (r212) + | 1647 -> One (r213) + | 221 -> One (r214) + | 225 -> One (r215) + | 231 -> One (r217) + | 232 -> One (r219) + | 224 -> One (r220) + | 223 -> One (r221) + | 229 -> One (r222) + | 227 -> One (r223) + | 228 -> One (r224) + | 230 -> One (r225) + | 234 -> One (r226) + | 1646 -> One (r227) + | 1645 -> One (r228) + | 1644 -> One (r229) + | 239 -> One (r230) + | 238 -> One (r231) + | 1643 -> One (r232) + | 1642 -> One (r233) + | 1641 -> One (r234) + | 242 -> One (r235) + | 241 -> One (r236) + | 1633 -> One (r237) + | 1632 -> One (r238) + | 1631 -> One (r239) + | 1630 -> One (r240) + | 1629 -> One (r241) + | 1625 -> One (r242) + | 1624 -> One (r243) + | 439 -> One (r244) + | 1623 -> One (r246) + | 1622 -> One (r247) + | 252 -> One (r248) + | 250 -> One (r249) + | 249 -> One (r250) + | 436 -> One (r251) + | 255 -> One (r252) + | 425 -> One (r253) + | 424 -> One (r255) + | 423 -> One (r256) + | 257 -> One (r257) + | 430 -> One (r259) + | 352 -> One (r260) + | 260 -> One (r261) + | 259 -> One (r263) + | 258 -> One (r264) + | 351 -> One (r265) + | 335 -> One (r266) + | 320 -> One (r268) + | 345 -> One (r270) + | 344 -> One (r271) + | 264 -> One (r272) + | 266 -> One (r273) + | 265 -> One (r274) + | 343 -> One (r275) + | 342 -> One (r276) + | 283 -> One (r277) + | 282 -> One (r278) + | 334 -> One (r280) + | 325 -> One (r281) + | 337 -> One (r283) + | 336 -> One (r284) + | 279 | 1127 -> One (r285) + | 280 -> One (r287) + | 278 -> One (r288) + | 277 -> One (r289) + | 270 -> One (r290) + | 276 -> One (r292) + | 273 -> One (r294) + | 272 -> One (r295) + | 275 -> One (r296) + | 274 -> One (r297) + | 322 -> One (r298) + | 321 -> One (r299) + | 318 -> One (r300) + | 317 -> One (r301) + | 316 -> One (r304) + | 297 -> One (r306) + | 295 -> One (r307) + | 294 -> One (r308) + | 304 -> One (r309) + | 306 -> One (r310) + | 310 -> One (r311) + | 315 -> One (r312) + | 314 -> One (r313) + | 324 -> One (r314) + | 333 -> One (r315) + | 332 -> One (r317) + | 329 -> One (r318) + | 328 -> One (r319) + | 331 -> One (r320) + | 341 -> One (r321) + | 340 -> One (r322) + | 339 -> One (r323) + | 350 -> One (r324) + | 348 -> One (r326) + | 347 -> One (r327) + | 429 -> One (r328) + | 365 | 748 -> One (r330) + | 366 -> One (r332) + | 356 -> One (r333) + | 355 -> One (r334) + | 357 -> One (r335) + | 359 -> One (r336) + | 371 -> One (r338) + | 370 -> One (r340) + | 422 -> One (r341) + | 421 -> One (r342) + | 374 -> One (r343) + | 376 -> One (r344) + | 416 -> One (r345) + | 379 -> One (r346) + | 378 -> One (r347) + | 384 -> One (r348) + | 386 -> One (r349) + | 389 -> One (r350) + | 415 -> One (r351) + | 394 -> One (r352) + | 398 -> One (r354) + | 397 -> One (r355) + | 396 -> One (r356) + | 400 -> One (r357) + | 403 -> One (r358) + | 402 -> One (r359) + | 407 -> One (r360) + | 410 -> One (r361) + | 409 -> One (r362) + | 412 -> One (r363) + | 414 -> One (r364) + | 418 -> One (r365) + | 417 -> One (r366) + | 420 -> One (r367) + | 434 -> One (r368) + | 438 -> One (r369) + | 447 -> One (r370) + | 442 -> One (r371) + | 446 -> One (r373) + | 445 -> One (r374) + | 444 -> One (r375) + | 1605 -> One (r376) + | 1604 -> One (r377) + | 1603 -> One (r378) + | 450 -> One (r379) + | 1602 -> One (r380) + | 453 -> One (r381) + | 1497 -> One (r383) + | 1494 -> One (r385) + | 1493 -> One (r386) + | 1492 -> One (r387) + | 455 -> One (r388) + | 464 -> One (r390) + | 462 -> One (r391) + | 461 -> One (r392) + | 460 -> One (r393) + | 459 -> One (r394) + | 468 -> One (r395) + | 467 -> One (r396) + | 470 -> One (r397) + | 1600 -> One (r398) + | 471 -> One (r399) + | 1372 -> One (r400) + | 1371 -> One (r401) + | 1370 -> One (r402) + | 1369 -> One (r403) + | 1368 -> One (r404) + | 1367 -> One (r405) + | 1584 -> One (r406) + | 1583 -> One (r407) + | 1582 -> One (r408) + | 1581 -> One (r409) + | 1580 -> One (r410) + | 473 -> One (r411) + | 1579 -> One (r412) + | 559 -> One (r413) + | 558 -> One (r414) + | 476 -> One (r415) + | 475 -> One (r416) + | 546 -> One (r417) + | 544 -> One (r418) + | 543 -> One (r419) + | 478 -> One (r420) | 480 -> One (r421) - | 477 -> One (r422) - | 511 -> One (r423) - | 510 -> One (r425) - | 504 -> One (r427) - | 503 -> One (r428) - | 502 -> One (r429) - | 501 -> One (r430) - | 500 -> One (r431) - | 523 -> One (r433) - | 524 -> One (r435) - | 491 -> One (r436) - | 490 -> One (r437) - | 487 -> One (r438) - | 486 -> One (r439) - | 494 -> One (r440) - | 493 -> One (r441) - | 498 -> One (r442) - | 497 -> One (r443) - | 496 -> One (r444) - | 509 -> One (r445) - | 514 -> One (r447) - | 516 -> One (r448) - | 519 -> One (r449) - | 518 -> One (r450) - | 520 | 1826 -> One (r451) - | 522 -> One (r452) - | 526 -> One (r453) - | 538 -> One (r454) - | 543 -> One (r455) - | 542 -> One (r456) - | 1387 -> One (r457) - | 1567 -> One (r459) - | 1566 -> One (r460) - | 1563 -> One (r461) - | 1560 -> One (r462) - | 552 -> One (r463) - | 1559 -> One (r464) - | 1490 -> One (r465) - | 1489 -> One (r466) - | 1487 -> One (r467) - | 1493 -> One (r469) - | 1558 -> One (r471) - | 1557 -> One (r472) - | 1556 -> One (r473) - | 1555 -> One (r474) - | 1554 -> One (r475) - | 1553 -> One (r476) - | 560 -> One (r477) - | 559 -> One (r478) - | 1550 -> One (r479) - | 563 -> One (r480) - | 562 -> One (r481) - | 1547 -> One (r482) - | 1546 -> One (r483) - | 1545 -> One (r484) - | 566 -> One (r485) - | 565 -> One (r486) - | 1541 -> One (r487) + | 542 -> One (r422) + | 541 -> One (r423) + | 482 -> One (r424) + | 540 -> One (r425) + | 539 -> One (r426) + | 538 -> One (r427) + | 485 -> One (r428) + | 493 -> One (r429) + | 491 -> One (r430) + | 490 -> One (r431) + | 487 -> One (r432) + | 521 -> One (r433) + | 520 -> One (r435) + | 514 -> One (r437) + | 513 -> One (r438) + | 512 -> One (r439) + | 511 -> One (r440) + | 510 -> One (r441) + | 533 -> One (r443) + | 534 -> One (r445) + | 501 -> One (r446) + | 500 -> One (r447) + | 497 -> One (r448) + | 496 -> One (r449) + | 504 -> One (r450) + | 503 -> One (r451) + | 508 -> One (r452) + | 507 -> One (r453) + | 506 -> One (r454) + | 519 -> One (r455) + | 524 -> One (r457) + | 526 -> One (r458) + | 529 -> One (r459) + | 528 -> One (r460) + | 530 | 1835 -> One (r461) + | 532 -> One (r462) + | 536 -> One (r463) + | 548 -> One (r464) + | 553 -> One (r465) + | 552 -> One (r466) + | 1416 -> One (r467) + | 1578 -> One (r469) + | 1577 -> One (r470) + | 1574 -> One (r471) + | 1571 -> One (r472) + | 562 -> One (r473) + | 1570 -> One (r474) + | 1518 -> One (r475) + | 1517 -> One (r476) + | 1516 -> One (r477) + | 1521 -> One (r479) + | 1569 -> One (r481) + | 1568 -> One (r482) + | 1567 -> One (r483) + | 1566 -> One (r484) + | 1565 -> One (r485) + | 1564 -> One (r486) + | 570 -> One (r487) | 569 -> One (r488) - | 568 -> One (r489) - | 1540 -> One (r490) - | 1536 -> One (r491) - | 1535 -> One (r492) - | 1534 -> One (r493) - | 1209 -> One (r494) - | 1519 -> One (r496) - | 580 -> One (r497) - | 1533 -> One (r499) - | 1532 -> One (r500) - | 575 -> One (r501) - | 574 -> One (r502) - | 1531 -> One (r503) - | 579 -> One (r504) - | 578 -> One (r505) - | 1511 -> One (r506) - | 1510 -> One (r507) - | 1509 -> One (r508) - | 1508 -> One (r509) - | 585 -> One (r510) - | 584 -> One (r511) - | 583 -> One (r512) - | 582 -> One (r513) - | 1502 -> One (r514) - | 1507 -> One (r516) - | 1506 -> One (r517) - | 1505 -> One (r518) - | 1504 -> One (r519) - | 1503 -> One (r520) - | 1500 -> One (r521) - | 590 -> One (r522) - | 589 -> One (r523) - | 588 -> One (r524) - | 587 -> One (r525) - | 594 -> One (r526) - | 599 -> One (r527) - | 598 -> One (r528) - | 597 | 1497 -> One (r529) - | 1496 -> One (r530) - | 608 -> One (r531) - | 607 -> One (r532) - | 606 -> One (r533) - | 605 -> One (r534) - | 604 -> One (r535) - | 603 -> One (r536) - | 1459 -> One (r537) - | 615 -> One (r538) - | 614 -> One (r539) - | 619 -> One (r540) - | 618 -> One (r541) - | 617 -> One (r542) - | 621 -> One (r543) - | 1400 | 1452 -> One (r544) - | 1399 | 1451 -> One (r545) - | 623 | 1398 -> One (r546) - | 622 | 1397 -> One (r547) - | 1450 -> One (r548) - | 637 -> One (r549) - | 632 -> One (r550) - | 631 | 1596 -> One (r551) - | 636 -> One (r553) - | 635 -> One (r554) - | 628 -> One (r555) - | 630 -> One (r556) - | 634 -> One (r557) - | 639 -> One (r558) - | 641 -> One (r559) - | 643 -> One (r560) - | 647 | 1416 -> One (r561) - | 646 | 1415 -> One (r562) - | 645 | 1414 -> One (r563) - | 644 | 1413 -> One (r564) - | 1375 -> One (r565) - | 658 -> One (r566) - | 657 -> One (r567) - | 662 -> One (r568) - | 661 -> One (r569) - | 665 -> One (r570) - | 667 -> One (r571) - | 672 -> One (r572) - | 676 -> One (r573) - | 675 -> One (r574) - | 679 -> One (r575) - | 681 -> One (r576) - | 683 -> One (r577) - | 685 -> One (r578) - | 687 -> One (r579) - | 689 -> One (r580) - | 691 -> One (r581) - | 693 -> One (r582) - | 695 -> One (r583) - | 697 -> One (r584) - | 699 -> One (r585) - | 701 -> One (r586) - | 703 -> One (r587) - | 705 -> One (r588) - | 707 -> One (r589) - | 709 -> One (r590) - | 711 -> One (r591) - | 713 -> One (r592) - | 715 -> One (r593) - | 717 -> One (r594) - | 1374 -> One (r595) - | 742 -> One (r596) - | 719 -> One (r597) - | 724 -> One (r598) - | 723 -> One (r599) - | 722 -> One (r600) - | 727 -> One (r601) - | 726 -> One (r602) - | 729 -> One (r603) - | 731 -> One (r604) - | 733 -> One (r605) - | 735 -> One (r606) - | 740 -> One (r607) - | 1373 -> One (r608) - | 1372 -> One (r609) - | 744 -> One (r610) - | 746 -> One (r611) - | 748 -> One (r612) - | 765 -> One (r613) - | 764 -> One (r614) - | 783 -> One (r616) - | 782 -> One (r617) - | 781 -> One (r618) - | 761 -> One (r619) - | 760 -> One (r620) - | 759 -> One (r621) - | 756 -> One (r622) - | 753 -> One (r623) - | 752 -> One (r624) - | 751 -> One (r625) - | 750 -> One (r626) - | 755 -> One (r627) - | 758 -> One (r628) - | 780 -> One (r629) - | 771 -> One (r630) - | 770 -> One (r631) - | 763 -> One (r632) - | 769 -> One (r633) - | 768 -> One (r634) - | 767 -> One (r635) - | 777 -> One (r636) - | 776 -> One (r637) - | 775 -> One (r638) - | 774 -> One (r639) - | 773 -> One (r640) - | 779 -> One (r641) - | 1371 -> One (r642) - | 1370 -> One (r643) - | 785 -> One (r644) - | 1366 -> One (r645) - | 1365 -> One (r646) - | 787 -> One (r647) - | 792 -> One (r648) - | 791 -> One (r649) - | 790 -> One (r650) - | 789 -> One (r651) - | 805 -> One (r652) - | 808 -> One (r654) - | 807 -> One (r655) - | 804 -> One (r656) - | 803 -> One (r657) - | 797 -> One (r658) - | 796 -> One (r659) - | 795 -> One (r660) - | 794 -> One (r661) - | 802 -> One (r662) - | 801 -> One (r663) - | 800 -> One (r664) - | 850 -> One (r666) - | 849 -> One (r667) - | 848 -> One (r668) - | 843 -> One (r669) - | 864 -> One (r673) - | 863 -> One (r674) - | 862 -> One (r675) - | 990 -> One (r676) - | 989 -> One (r677) - | 988 -> One (r678) - | 987 -> One (r679) - | 842 -> One (r680) - | 841 -> One (r682) - | 837 -> One (r689) - | 834 -> One (r691) - | 833 -> One (r692) - | 831 -> One (r693) - | 830 -> One (r694) - | 829 -> One (r695) - | 828 -> One (r696) - | 824 -> One (r697) - | 823 -> One (r698) - | 827 -> One (r699) - | 826 -> One (r700) - | 840 -> One (r701) - | 839 -> One (r702) - | 847 -> One (r703) - | 861 -> One (r704) - | 857 -> One (r705) - | 853 -> One (r706) - | 856 -> One (r707) - | 855 -> One (r708) - | 860 -> One (r709) - | 859 -> One (r710) - | 1152 -> One (r711) - | 918 -> One (r712) - | 933 -> One (r714) - | 932 -> One (r715) - | 931 -> One (r716) - | 930 -> One (r717) - | 929 -> One (r718) - | 916 -> One (r722) - | 915 -> One (r723) - | 914 -> One (r724) - | 912 -> One (r725) - | 911 -> One (r726) - | 888 -> One (r728) - | 887 -> One (r729) - | 886 -> One (r730) - | 877 -> One (r731) - | 876 -> One (r732) - | 882 -> One (r733) - | 881 -> One (r734) - | 880 | 1697 -> One (r735) - | 884 | 1696 -> One (r736) - | 905 -> One (r737) - | 897 -> One (r738) - | 896 -> One (r739) - | 895 -> One (r740) - | 904 -> One (r741) - | 903 -> One (r742) - | 925 -> One (r743) - | 924 -> One (r744) - | 923 -> One (r745) - | 1151 -> One (r746) - | 944 -> One (r747) - | 943 -> One (r748) - | 942 -> One (r749) - | 941 -> One (r750) - | 940 -> One (r751) - | 939 -> One (r752) - | 938 -> One (r753) - | 937 -> One (r754) - | 977 -> One (r755) - | 976 -> One (r756) - | 979 -> One (r758) - | 978 -> One (r759) - | 972 -> One (r760) - | 954 -> One (r761) - | 953 -> One (r762) - | 952 -> One (r763) - | 951 -> One (r764) - | 950 -> One (r765) - | 958 -> One (r769) - | 957 -> One (r770) - | 971 -> One (r771) - | 963 -> One (r772) - | 962 -> One (r773) - | 961 -> One (r774) - | 960 -> One (r775) - | 970 -> One (r776) - | 969 -> One (r777) - | 968 -> One (r778) - | 967 -> One (r779) - | 966 -> One (r780) - | 965 -> One (r781) - | 975 -> One (r784) - | 974 -> One (r785) + | 1561 -> One (r489) + | 573 -> One (r490) + | 572 -> One (r491) + | 1558 -> One (r492) + | 1557 -> One (r493) + | 1556 -> One (r494) + | 576 -> One (r495) + | 575 -> One (r496) + | 1555 -> One (r497) + | 579 -> One (r498) + | 578 -> One (r499) + | 1554 -> One (r500) + | 1550 -> One (r501) + | 1549 -> One (r502) + | 1548 -> One (r503) + | 586 -> One (r504) + | 588 -> One (r506) + | 1243 -> One (r508) + | 587 -> One (r510) + | 1241 -> One (r512) + | 1547 -> One (r514) + | 594 -> One (r515) + | 593 -> One (r516) + | 590 -> One (r517) + | 585 -> One (r518) + | 584 -> One (r519) + | 592 -> One (r520) + | 598 -> One (r521) + | 597 -> One (r522) + | 596 -> One (r523) + | 600 -> One (r524) + | 1539 -> One (r525) + | 1538 -> One (r526) + | 1537 -> One (r527) + | 1536 -> One (r528) + | 606 -> One (r529) + | 605 -> One (r530) + | 604 -> One (r531) + | 603 -> One (r532) + | 1530 -> One (r533) + | 1535 -> One (r535) + | 1534 -> One (r536) + | 1533 -> One (r537) + | 1532 -> One (r538) + | 1531 -> One (r539) + | 1528 -> One (r540) + | 611 -> One (r541) + | 610 -> One (r542) + | 609 -> One (r543) + | 608 -> One (r544) + | 615 -> One (r545) + | 620 -> One (r546) + | 619 -> One (r547) + | 618 | 1525 -> One (r548) + | 1524 -> One (r549) + | 629 -> One (r550) + | 628 -> One (r551) + | 627 -> One (r552) + | 626 -> One (r553) + | 625 -> One (r554) + | 624 -> One (r555) + | 1488 -> One (r556) + | 636 -> One (r557) + | 635 -> One (r558) + | 640 -> One (r559) + | 639 -> One (r560) + | 638 -> One (r561) + | 642 -> One (r562) + | 1429 | 1481 -> One (r563) + | 1428 | 1480 -> One (r564) + | 644 | 1427 -> One (r565) + | 643 | 1426 -> One (r566) + | 648 -> One (r567) + | 647 -> One (r568) + | 646 -> One (r569) + | 1479 -> One (r570) + | 662 -> One (r571) + | 657 -> One (r572) + | 656 | 1606 -> One (r573) + | 661 -> One (r575) + | 660 -> One (r576) + | 653 -> One (r577) + | 655 -> One (r578) + | 659 -> One (r579) + | 664 -> One (r580) + | 666 -> One (r581) + | 668 -> One (r582) + | 1425 | 1475 -> One (r583) + | 669 | 1442 -> One (r584) + | 672 | 1445 -> One (r585) + | 671 | 1444 -> One (r586) + | 670 | 1443 -> One (r587) + | 1404 -> One (r588) + | 683 -> One (r589) + | 682 -> One (r590) + | 687 -> One (r591) + | 686 -> One (r592) + | 739 -> One (r593) + | 693 -> One (r594) + | 697 -> One (r595) + | 699 -> One (r596) + | 701 -> One (r597) + | 703 -> One (r598) + | 705 -> One (r599) + | 707 -> One (r600) + | 709 -> One (r601) + | 711 -> One (r602) + | 713 -> One (r603) + | 715 -> One (r604) + | 717 -> One (r605) + | 719 -> One (r606) + | 721 -> One (r607) + | 723 -> One (r608) + | 725 -> One (r609) + | 727 -> One (r610) + | 729 -> One (r611) + | 728 -> One (r612) + | 731 -> One (r613) + | 733 -> One (r614) + | 735 -> One (r615) + | 737 -> One (r616) + | 743 -> One (r617) + | 742 -> One (r618) + | 1403 -> One (r619) + | 770 -> One (r620) + | 747 -> One (r621) + | 752 -> One (r622) + | 751 -> One (r623) + | 750 -> One (r624) + | 755 -> One (r625) + | 754 -> One (r626) + | 757 -> One (r627) + | 759 -> One (r628) + | 761 -> One (r629) + | 763 -> One (r630) + | 768 -> One (r631) + | 1402 -> One (r632) + | 1401 -> One (r633) + | 772 -> One (r634) + | 774 -> One (r635) + | 776 -> One (r636) + | 793 -> One (r637) + | 792 -> One (r638) + | 811 -> One (r640) + | 810 -> One (r641) + | 809 -> One (r642) + | 789 -> One (r643) + | 788 -> One (r644) + | 787 -> One (r645) + | 784 -> One (r646) + | 781 -> One (r647) + | 780 -> One (r648) + | 779 -> One (r649) + | 778 -> One (r650) + | 783 -> One (r651) + | 786 -> One (r652) + | 808 -> One (r653) + | 799 -> One (r654) + | 798 -> One (r655) + | 791 -> One (r656) + | 797 -> One (r657) + | 796 -> One (r658) + | 795 -> One (r659) + | 805 -> One (r660) + | 804 -> One (r661) + | 803 -> One (r662) + | 802 -> One (r663) + | 801 -> One (r664) + | 807 -> One (r665) + | 1400 -> One (r666) + | 1399 -> One (r667) + | 813 -> One (r668) + | 1398 -> One (r669) + | 1397 -> One (r670) + | 815 -> One (r671) + | 820 -> One (r672) + | 819 -> One (r673) + | 818 -> One (r674) + | 817 -> One (r675) + | 833 -> One (r676) + | 836 -> One (r678) + | 835 -> One (r679) + | 832 -> One (r680) + | 831 -> One (r681) + | 825 -> One (r682) + | 824 -> One (r683) + | 823 -> One (r684) + | 822 -> One (r685) + | 830 -> One (r686) + | 829 -> One (r687) + | 828 -> One (r688) + | 878 -> One (r690) + | 877 -> One (r691) + | 876 -> One (r692) + | 871 -> One (r693) + | 892 -> One (r697) + | 891 -> One (r698) + | 890 -> One (r699) + | 1018 -> One (r700) + | 1017 -> One (r701) + | 1016 -> One (r702) + | 1015 -> One (r703) + | 870 -> One (r704) + | 869 -> One (r706) + | 865 -> One (r713) + | 862 -> One (r715) + | 861 -> One (r716) + | 859 -> One (r717) + | 858 -> One (r718) + | 857 -> One (r719) + | 856 -> One (r720) + | 852 -> One (r721) + | 851 -> One (r722) + | 855 -> One (r723) + | 854 -> One (r724) + | 868 -> One (r725) + | 867 -> One (r726) + | 875 -> One (r727) + | 889 -> One (r728) + | 885 -> One (r729) + | 881 -> One (r730) + | 884 -> One (r731) + | 883 -> One (r732) + | 888 -> One (r733) + | 887 -> One (r734) + | 1180 -> One (r735) + | 946 -> One (r736) + | 961 -> One (r738) + | 960 -> One (r739) + | 959 -> One (r740) + | 958 -> One (r741) + | 957 -> One (r742) + | 944 -> One (r746) + | 943 -> One (r747) + | 942 -> One (r748) + | 940 -> One (r749) + | 939 -> One (r750) + | 916 -> One (r752) + | 915 -> One (r753) + | 914 -> One (r754) + | 905 -> One (r755) + | 904 -> One (r756) + | 910 -> One (r757) + | 909 -> One (r758) + | 908 | 1706 -> One (r759) + | 912 | 1705 -> One (r760) + | 933 -> One (r761) + | 925 -> One (r762) + | 924 -> One (r763) + | 923 -> One (r764) + | 932 -> One (r765) + | 931 -> One (r766) + | 953 -> One (r767) + | 952 -> One (r768) + | 951 -> One (r769) + | 1179 -> One (r770) + | 972 -> One (r771) + | 971 -> One (r772) + | 970 -> One (r773) + | 969 -> One (r774) + | 968 -> One (r775) + | 967 -> One (r776) + | 966 -> One (r777) + | 965 -> One (r778) + | 1005 -> One (r779) + | 1004 -> One (r780) + | 1007 -> One (r782) + | 1006 -> One (r783) + | 1000 -> One (r784) + | 982 -> One (r785) | 981 -> One (r786) - | 986 -> One (r787) - | 985 -> One (r788) - | 984 -> One (r789) - | 983 -> One (r790) - | 1046 | 1100 -> One (r792) - | 1102 -> One (r794) - | 1116 -> One (r796) - | 1106 -> One (r797) - | 1105 -> One (r798) - | 1087 -> One (r799) - | 1086 -> One (r800) - | 1085 -> One (r801) - | 1084 -> One (r802) - | 1083 -> One (r803) - | 1082 -> One (r804) - | 1081 -> One (r805) - | 1071 -> One (r806) - | 1070 -> One (r807) - | 1002 -> One (r808) - | 1001 -> One (r809) - | 1000 -> One (r810) - | 996 -> One (r811) - | 994 -> One (r812) - | 993 -> One (r813) - | 999 -> One (r814) - | 998 -> One (r815) - | 1064 -> One (r816) - | 1063 -> One (r817) - | 1008 -> One (r818) - | 1004 -> One (r819) - | 1007 -> One (r820) - | 1006 -> One (r821) - | 1019 -> One (r822) - | 1018 -> One (r823) - | 1017 -> One (r824) - | 1016 -> One (r825) - | 1015 -> One (r826) - | 1010 -> One (r827) - | 1030 -> One (r828) - | 1029 -> One (r829) - | 1028 -> One (r830) - | 1027 -> One (r831) - | 1026 -> One (r832) - | 1021 -> One (r833) - | 1055 -> One (r834) - | 1054 -> One (r835) - | 1032 -> One (r836) - | 1053 -> One (r837) - | 1052 -> One (r838) - | 1051 -> One (r839) - | 1050 -> One (r840) - | 1034 -> One (r841) - | 1048 -> One (r842) - | 1038 -> One (r843) - | 1037 -> One (r844) - | 1036 -> One (r845) - | 1045 | 1093 -> One (r846) - | 1042 -> One (r848) - | 1041 -> One (r849) - | 1040 -> One (r850) - | 1039 | 1092 -> One (r851) - | 1044 -> One (r852) - | 1060 -> One (r853) - | 1059 -> One (r854) - | 1058 -> One (r855) - | 1062 -> One (r857) - | 1061 -> One (r858) - | 1057 -> One (r859) - | 1066 -> One (r860) - | 1069 -> One (r861) + | 980 -> One (r787) + | 979 -> One (r788) + | 978 -> One (r789) + | 986 -> One (r793) + | 985 -> One (r794) + | 999 -> One (r795) + | 991 -> One (r796) + | 990 -> One (r797) + | 989 -> One (r798) + | 988 -> One (r799) + | 998 -> One (r800) + | 997 -> One (r801) + | 996 -> One (r802) + | 995 -> One (r803) + | 994 -> One (r804) + | 993 -> One (r805) + | 1003 -> One (r808) + | 1002 -> One (r809) + | 1009 -> One (r810) + | 1014 -> One (r811) + | 1013 -> One (r812) + | 1012 -> One (r813) + | 1011 -> One (r814) + | 1074 | 1128 -> One (r816) + | 1130 -> One (r818) + | 1144 -> One (r820) + | 1134 -> One (r821) + | 1133 -> One (r822) + | 1115 -> One (r823) + | 1114 -> One (r824) + | 1113 -> One (r825) + | 1112 -> One (r826) + | 1111 -> One (r827) + | 1110 -> One (r828) + | 1109 -> One (r829) + | 1099 -> One (r830) + | 1098 -> One (r831) + | 1030 -> One (r832) + | 1029 -> One (r833) + | 1028 -> One (r834) + | 1024 -> One (r835) + | 1022 -> One (r836) + | 1021 -> One (r837) + | 1027 -> One (r838) + | 1026 -> One (r839) + | 1092 -> One (r840) + | 1091 -> One (r841) + | 1036 -> One (r842) + | 1032 -> One (r843) + | 1035 -> One (r844) + | 1034 -> One (r845) + | 1047 -> One (r846) + | 1046 -> One (r847) + | 1045 -> One (r848) + | 1044 -> One (r849) + | 1043 -> One (r850) + | 1038 -> One (r851) + | 1058 -> One (r852) + | 1057 -> One (r853) + | 1056 -> One (r854) + | 1055 -> One (r855) + | 1054 -> One (r856) + | 1049 -> One (r857) + | 1083 -> One (r858) + | 1082 -> One (r859) + | 1060 -> One (r860) + | 1081 -> One (r861) | 1080 -> One (r862) | 1079 -> One (r863) | 1078 -> One (r864) - | 1077 -> One (r865) + | 1062 -> One (r865) | 1076 -> One (r866) - | 1075 -> One (r867) - | 1074 -> One (r868) - | 1073 -> One (r869) - | 1104 -> One (r870) - | 1091 -> One (r871) - | 1090 -> One (r872) - | 1089 -> One (r873) - | 1103 -> One (r874) - | 1095 -> One (r875) - | 1101 -> One (r876) - | 1098 -> One (r877) - | 1097 -> One (r878) - | 1115 -> One (r879) - | 1114 -> One (r880) - | 1113 -> One (r881) - | 1112 -> One (r882) - | 1111 -> One (r883) - | 1110 -> One (r884) - | 1109 -> One (r885) + | 1066 -> One (r867) + | 1065 -> One (r868) + | 1064 -> One (r869) + | 1073 | 1121 -> One (r870) + | 1070 -> One (r872) + | 1069 -> One (r873) + | 1068 -> One (r874) + | 1067 | 1120 -> One (r875) + | 1072 -> One (r876) + | 1088 -> One (r877) + | 1087 -> One (r878) + | 1086 -> One (r879) + | 1090 -> One (r881) + | 1089 -> One (r882) + | 1085 -> One (r883) + | 1094 -> One (r884) + | 1097 -> One (r885) | 1108 -> One (r886) - | 1125 -> One (r887) - | 1127 -> One (r888) - | 1137 -> One (r889) - | 1136 -> One (r890) - | 1135 -> One (r891) - | 1134 -> One (r892) - | 1133 -> One (r893) + | 1107 -> One (r887) + | 1106 -> One (r888) + | 1105 -> One (r889) + | 1104 -> One (r890) + | 1103 -> One (r891) + | 1102 -> One (r892) + | 1101 -> One (r893) | 1132 -> One (r894) - | 1131 -> One (r895) - | 1130 -> One (r896) - | 1148 -> One (r897) - | 1147 -> One (r898) - | 1146 -> One (r899) - | 1145 -> One (r900) - | 1144 -> One (r901) - | 1143 -> One (r902) - | 1142 -> One (r903) - | 1141 -> One (r904) - | 1140 -> One (r905) - | 1270 -> One (r906) - | 1319 -> One (r908) - | 1161 -> One (r909) - | 1336 -> One (r911) - | 1327 -> One (r912) - | 1326 -> One (r913) - | 1160 -> One (r914) - | 1159 -> One (r915) - | 1158 -> One (r916) - | 1157 -> One (r917) - | 1156 -> One (r918) - | 1313 -> One (r919) - | 1312 -> One (r920) - | 1164 -> One (r921) - | 1163 -> One (r922) - | 1189 -> One (r923) - | 1188 -> One (r924) - | 1187 -> One (r925) - | 1186 -> One (r926) - | 1177 -> One (r927) - | 1176 -> One (r929) - | 1175 -> One (r930) - | 1171 -> One (r931) - | 1170 -> One (r932) - | 1169 -> One (r933) - | 1168 -> One (r934) - | 1167 -> One (r935) - | 1174 -> One (r936) - | 1173 -> One (r937) - | 1185 -> One (r938) - | 1184 -> One (r939) - | 1183 -> One (r940) - | 1192 -> One (r941) - | 1191 -> One (r942) - | 1239 -> One (r943) - | 1228 -> One (r944) - | 1227 -> One (r945) - | 1218 -> One (r946) - | 1217 -> One (r948) - | 1216 -> One (r949) - | 1208 -> One (r950) - | 1197 -> One (r951) - | 1196 -> One (r952) - | 1195 -> One (r953) - | 1207 -> One (r954) - | 1206 -> One (r955) - | 1205 -> One (r956) - | 1204 -> One (r957) - | 1203 -> One (r958) - | 1202 -> One (r959) - | 1201 -> One (r960) - | 1200 -> One (r961) - | 1215 -> One (r962) - | 1213 -> One (r963) - | 1212 -> One (r964) - | 1226 -> One (r965) - | 1225 -> One (r966) - | 1224 -> One (r967) - | 1238 -> One (r968) - | 1237 -> One (r969) - | 1236 -> One (r970) - | 1235 -> One (r971) - | 1234 -> One (r972) - | 1233 -> One (r973) - | 1232 -> One (r974) - | 1231 -> One (r975) - | 1243 -> One (r976) - | 1242 -> One (r977) - | 1241 -> One (r978) - | 1307 -> One (r979) - | 1306 -> One (r980) - | 1305 -> One (r981) - | 1304 -> One (r982) - | 1303 -> One (r983) - | 1302 -> One (r984) - | 1299 -> One (r985) - | 1246 -> One (r986) - | 1295 -> One (r987) - | 1294 -> One (r988) - | 1289 -> One (r989) - | 1288 -> One (r990) - | 1287 -> One (r991) - | 1286 -> One (r992) - | 1255 -> One (r993) - | 1254 -> One (r994) - | 1253 -> One (r995) - | 1252 -> One (r996) - | 1251 -> One (r997) - | 1250 -> One (r998) - | 1285 -> One (r999) + | 1119 -> One (r895) + | 1118 -> One (r896) + | 1117 -> One (r897) + | 1131 -> One (r898) + | 1123 -> One (r899) + | 1129 -> One (r900) + | 1126 -> One (r901) + | 1125 -> One (r902) + | 1143 -> One (r903) + | 1142 -> One (r904) + | 1141 -> One (r905) + | 1140 -> One (r906) + | 1139 -> One (r907) + | 1138 -> One (r908) + | 1137 -> One (r909) + | 1136 -> One (r910) + | 1153 -> One (r911) + | 1155 -> One (r912) + | 1165 -> One (r913) + | 1164 -> One (r914) + | 1163 -> One (r915) + | 1162 -> One (r916) + | 1161 -> One (r917) + | 1160 -> One (r918) + | 1159 -> One (r919) + | 1158 -> One (r920) + | 1176 -> One (r921) + | 1175 -> One (r922) + | 1174 -> One (r923) + | 1173 -> One (r924) + | 1172 -> One (r925) + | 1171 -> One (r926) + | 1170 -> One (r927) + | 1169 -> One (r928) + | 1168 -> One (r929) + | 1298 -> One (r930) + | 1347 -> One (r932) + | 1189 -> One (r933) + | 1364 -> One (r935) + | 1355 -> One (r936) + | 1354 -> One (r937) + | 1188 -> One (r938) + | 1187 -> One (r939) + | 1186 -> One (r940) + | 1185 -> One (r941) + | 1184 -> One (r942) + | 1341 -> One (r943) + | 1340 -> One (r944) + | 1192 -> One (r945) + | 1191 -> One (r946) + | 1217 -> One (r947) + | 1216 -> One (r948) + | 1215 -> One (r949) + | 1214 -> One (r950) + | 1205 -> One (r951) + | 1204 -> One (r953) + | 1203 -> One (r954) + | 1199 -> One (r955) + | 1198 -> One (r956) + | 1197 -> One (r957) + | 1196 -> One (r958) + | 1195 -> One (r959) + | 1202 -> One (r960) + | 1201 -> One (r961) + | 1213 -> One (r962) + | 1212 -> One (r963) + | 1211 -> One (r964) + | 1220 -> One (r965) + | 1219 -> One (r966) + | 1267 -> One (r968) + | 1256 -> One (r969) + | 1255 -> One (r970) + | 1246 -> One (r971) + | 1245 -> One (r973) + | 1244 -> One (r974) + | 1236 -> One (r975) + | 1225 -> One (r976) + | 1224 -> One (r977) + | 1223 -> One (r978) + | 1235 -> One (r979) + | 1234 -> One (r980) + | 1233 -> One (r981) + | 1232 -> One (r982) + | 1231 -> One (r983) + | 1230 -> One (r984) + | 1229 -> One (r985) + | 1228 -> One (r986) + | 1242 -> One (r987) + | 1240 -> One (r988) + | 1239 -> One (r989) + | 1254 -> One (r990) + | 1253 -> One (r991) + | 1252 -> One (r992) + | 1266 -> One (r993) + | 1265 -> One (r994) + | 1264 -> One (r995) + | 1263 -> One (r996) + | 1262 -> One (r997) + | 1261 -> One (r998) + | 1260 -> One (r999) | 1259 -> One (r1000) - | 1258 -> One (r1001) - | 1257 -> One (r1002) - | 1263 -> One (r1003) - | 1262 -> One (r1004) - | 1261 -> One (r1005) - | 1282 -> One (r1006) - | 1267 -> One (r1007) - | 1266 -> One (r1008) - | 1284 -> One (r1010) - | 1265 -> One (r1011) - | 1279 -> One (r1012) - | 1269 -> One (r1013) - | 1273 -> One (r1014) - | 1293 -> One (r1015) - | 1292 -> One (r1016) - | 1291 -> One (r1017) - | 1298 -> One (r1018) - | 1297 -> One (r1019) - | 1301 -> One (r1020) - | 1311 -> One (r1021) - | 1310 -> One (r1022) - | 1309 -> One (r1023) - | 1315 -> One (r1024) - | 1318 -> One (r1025) - | 1323 -> One (r1026) - | 1322 -> One (r1027) - | 1321 -> One (r1028) - | 1325 -> One (r1029) - | 1335 -> One (r1030) - | 1334 -> One (r1031) - | 1333 -> One (r1032) - | 1332 -> One (r1033) - | 1331 -> One (r1034) - | 1330 -> One (r1035) - | 1329 -> One (r1036) - | 1352 -> One (r1037) - | 1356 -> One (r1038) - | 1358 -> One (r1039) - | 1364 -> One (r1040) - | 1363 -> One (r1041) - | 1378 | 1421 -> One (r1042) - | 1377 | 1420 -> One (r1043) - | 1376 | 1419 -> One (r1044) - | 1381 | 1426 -> One (r1045) - | 1380 | 1425 -> One (r1046) - | 1379 | 1424 -> One (r1047) - | 1386 | 1433 -> One (r1048) - | 1385 | 1432 -> One (r1049) - | 1384 | 1431 -> One (r1050) - | 1383 | 1430 -> One (r1051) - | 1392 | 1438 -> One (r1052) - | 1391 | 1437 -> One (r1053) - | 1390 | 1436 -> One (r1054) - | 1395 | 1443 -> One (r1055) - | 1394 | 1442 -> One (r1056) - | 1393 | 1441 -> One (r1057) - | 1402 -> One (r1058) - | 1405 | 1455 -> One (r1059) - | 1404 | 1454 -> One (r1060) - | 1403 | 1453 -> One (r1061) - | 1407 -> One (r1062) - | 1410 | 1458 -> One (r1063) - | 1409 | 1457 -> One (r1064) - | 1408 | 1456 -> One (r1065) - | 1412 -> One (r1066) - | 1418 -> One (r1067) - | 1423 -> One (r1068) - | 1428 -> One (r1069) - | 1435 -> One (r1070) - | 1440 -> One (r1071) - | 1445 -> One (r1072) - | 1448 -> One (r1073) - | 1462 -> One (r1074) - | 1461 -> One (r1075) - | 1467 -> One (r1076) - | 1471 -> One (r1077) - | 1473 -> One (r1078) - | 1475 -> One (r1079) - | 1477 -> One (r1080) - | 1479 -> One (r1081) - | 1482 -> One (r1083) - | 1481 -> One (r1084) - | 1495 -> One (r1085) - | 1494 -> One (r1086) - | 1486 -> One (r1087) - | 1485 -> One (r1088) - | 1518 -> One (r1089) - | 1517 -> One (r1090) - | 1516 -> One (r1091) - | 1515 -> One (r1092) - | 1514 -> One (r1093) - | 1513 -> One (r1094) - | 1530 -> One (r1095) - | 1523 -> One (r1096) - | 1522 -> One (r1097) - | 1527 -> One (r1098) - | 1526 -> One (r1099) - | 1525 -> One (r1100) - | 1529 -> One (r1101) - | 1543 -> One (r1102) - | 1549 -> One (r1103) - | 1552 -> One (r1104) - | 1565 -> One (r1105) - | 1580 -> One (r1106) - | 1579 -> One (r1107) - | 1578 -> One (r1108) - | 1577 -> One (r1109) - | 1576 -> One (r1110) - | 1575 -> One (r1111) - | 1588 -> One (r1112) - | 1587 -> One (r1113) - | 1586 -> One (r1114) - | 1585 -> One (r1115) - | 1584 -> One (r1116) - | 1583 -> One (r1117) - | 1582 -> One (r1118) - | 1602 -> One (r1119) - | 1601 -> One (r1120) - | 1600 -> One (r1121) - | 1599 -> One (r1122) - | 1598 -> One (r1123) - | 1607 -> One (r1124) - | 1606 -> One (r1125) - | 1605 -> One (r1126) - | 1604 -> One (r1127) - | 1610 -> One (r1128) - | 1609 -> One (r1129) - | 1617 -> One (r1130) - | 1623 -> One (r1131) - | 1622 -> One (r1132) - | 1621 -> One (r1133) - | 1620 -> One (r1134) - | 1626 -> One (r1135) - | 1625 -> One (r1136) - | 1630 -> One (r1137) - | 1641 -> One (r1138) - | 1640 -> One (r1139) - | 1644 -> One (r1140) - | 1643 -> One (r1141) - | 1647 -> One (r1142) - | 1646 -> One (r1143) - | 1656 -> One (r1144) - | 1655 -> One (r1145) - | 1663 -> One (r1146) - | 1671 -> One (r1147) - | 1679 -> One (r1148) - | 1676 -> One (r1149) - | 1678 -> One (r1150) - | 1681 -> One (r1151) - | 1683 -> One (r1152) - | 1685 -> One (r1153) - | 1688 -> One (r1154) - | 1687 -> One (r1155) - | 1700 -> One (r1156) - | 1699 -> One (r1157) - | 1712 -> One (r1158) - | 1711 -> One (r1159) - | 1735 -> One (r1160) - | 1734 -> One (r1161) - | 1744 -> One (r1162) - | 1746 -> One (r1163) - | 1748 -> One (r1164) - | 1761 -> One (r1165) - | 1765 -> One (r1166) - | 1770 -> One (r1167) - | 1777 -> One (r1168) - | 1776 -> One (r1169) - | 1775 -> One (r1170) - | 1774 -> One (r1171) - | 1784 -> One (r1172) - | 1788 -> One (r1173) - | 1792 -> One (r1174) - | 1795 -> One (r1175) - | 1800 -> One (r1176) - | 1804 -> One (r1177) - | 1808 -> One (r1178) - | 1812 -> One (r1179) - | 1816 -> One (r1180) - | 1819 -> One (r1181) - | 1823 -> One (r1182) - | 1829 -> One (r1183) - | 1839 -> One (r1184) - | 1841 -> One (r1185) - | 1844 -> One (r1186) - | 1843 -> One (r1187) - | 1846 -> One (r1188) - | 1856 -> One (r1189) - | 1852 -> One (r1190) - | 1851 -> One (r1191) - | 1855 -> One (r1192) - | 1854 -> One (r1193) - | 1861 -> One (r1194) - | 1860 -> One (r1195) - | 1859 -> One (r1196) - | 1863 -> One (r1197) - | 363 -> Select (function - | -1 -> [R 107] - | _ -> S (T T_DOT) :: r328) - | 596 -> Select (function - | -1 -> [R 107] - | _ -> r530) + | 1271 -> One (r1001) + | 1270 -> One (r1002) + | 1269 -> One (r1003) + | 1335 -> One (r1004) + | 1334 -> One (r1005) + | 1333 -> One (r1006) + | 1332 -> One (r1007) + | 1331 -> One (r1008) + | 1330 -> One (r1009) + | 1327 -> One (r1010) + | 1274 -> One (r1011) + | 1323 -> One (r1012) + | 1322 -> One (r1013) + | 1317 -> One (r1014) + | 1316 -> One (r1015) + | 1315 -> One (r1016) + | 1314 -> One (r1017) + | 1283 -> One (r1018) + | 1282 -> One (r1019) + | 1281 -> One (r1020) + | 1280 -> One (r1021) + | 1279 -> One (r1022) + | 1278 -> One (r1023) + | 1313 -> One (r1024) + | 1287 -> One (r1025) + | 1286 -> One (r1026) + | 1285 -> One (r1027) + | 1291 -> One (r1028) + | 1290 -> One (r1029) + | 1289 -> One (r1030) + | 1310 -> One (r1031) + | 1295 -> One (r1032) + | 1294 -> One (r1033) + | 1312 -> One (r1035) + | 1293 -> One (r1036) + | 1307 -> One (r1037) + | 1297 -> One (r1038) + | 1301 -> One (r1039) + | 1321 -> One (r1040) + | 1320 -> One (r1041) + | 1319 -> One (r1042) + | 1326 -> One (r1043) + | 1325 -> One (r1044) + | 1329 -> One (r1045) + | 1339 -> One (r1046) + | 1338 -> One (r1047) + | 1337 -> One (r1048) + | 1343 -> One (r1049) + | 1346 -> One (r1050) + | 1351 -> One (r1051) + | 1350 -> One (r1052) + | 1349 -> One (r1053) + | 1353 -> One (r1054) + | 1363 -> One (r1055) + | 1362 -> One (r1056) + | 1361 -> One (r1057) + | 1360 -> One (r1058) + | 1359 -> One (r1059) + | 1358 -> One (r1060) + | 1357 -> One (r1061) + | 1380 -> One (r1062) + | 1384 -> One (r1063) + | 1386 -> One (r1064) + | 1392 -> One (r1065) + | 1391 -> One (r1066) + | 1407 | 1450 -> One (r1067) + | 1406 | 1449 -> One (r1068) + | 1405 | 1448 -> One (r1069) + | 1410 | 1455 -> One (r1070) + | 1409 | 1454 -> One (r1071) + | 1408 | 1453 -> One (r1072) + | 1415 | 1462 -> One (r1073) + | 1414 | 1461 -> One (r1074) + | 1413 | 1460 -> One (r1075) + | 1412 | 1459 -> One (r1076) + | 1421 | 1467 -> One (r1077) + | 1420 | 1466 -> One (r1078) + | 1419 | 1465 -> One (r1079) + | 1424 | 1472 -> One (r1080) + | 1423 | 1471 -> One (r1081) + | 1422 | 1470 -> One (r1082) + | 1431 -> One (r1083) + | 1434 | 1484 -> One (r1084) + | 1433 | 1483 -> One (r1085) + | 1432 | 1482 -> One (r1086) + | 1436 -> One (r1087) + | 1439 | 1487 -> One (r1088) + | 1438 | 1486 -> One (r1089) + | 1437 | 1485 -> One (r1090) + | 1441 -> One (r1091) + | 1447 -> One (r1092) + | 1452 -> One (r1093) + | 1457 -> One (r1094) + | 1464 -> One (r1095) + | 1469 -> One (r1096) + | 1474 -> One (r1097) + | 1477 -> One (r1098) + | 1491 -> One (r1099) + | 1490 -> One (r1100) + | 1496 -> One (r1101) + | 1500 -> One (r1102) + | 1502 -> One (r1103) + | 1504 -> One (r1104) + | 1506 -> One (r1105) + | 1508 -> One (r1106) + | 1511 -> One (r1108) + | 1510 -> One (r1109) + | 1523 -> One (r1110) + | 1522 -> One (r1111) + | 1515 -> One (r1112) + | 1514 -> One (r1113) + | 1546 -> One (r1114) + | 1545 -> One (r1115) + | 1544 -> One (r1116) + | 1543 -> One (r1117) + | 1542 -> One (r1118) + | 1541 -> One (r1119) + | 1560 -> One (r1120) + | 1563 -> One (r1121) + | 1576 -> One (r1122) + | 1591 -> One (r1123) + | 1590 -> One (r1124) + | 1589 -> One (r1125) + | 1588 -> One (r1126) + | 1587 -> One (r1127) + | 1586 -> One (r1128) + | 1599 -> One (r1129) + | 1598 -> One (r1130) + | 1597 -> One (r1131) + | 1596 -> One (r1132) + | 1595 -> One (r1133) + | 1594 -> One (r1134) + | 1593 -> One (r1135) + | 1612 -> One (r1136) + | 1611 -> One (r1137) + | 1610 -> One (r1138) + | 1609 -> One (r1139) + | 1608 -> One (r1140) + | 1617 -> One (r1141) + | 1616 -> One (r1142) + | 1615 -> One (r1143) + | 1614 -> One (r1144) + | 1620 -> One (r1145) + | 1619 -> One (r1146) + | 1627 -> One (r1147) + | 1636 -> One (r1148) + | 1635 -> One (r1149) + | 1638 -> One (r1150) + | 1640 -> One (r1151) + | 1651 -> One (r1152) + | 1650 -> One (r1153) + | 1654 -> One (r1154) + | 1653 -> One (r1155) + | 1657 -> One (r1156) + | 1656 -> One (r1157) + | 1666 -> One (r1158) + | 1665 -> One (r1159) + | 1673 -> One (r1160) + | 1681 -> One (r1161) + | 1689 -> One (r1162) + | 1686 -> One (r1163) + | 1688 -> One (r1164) + | 1691 -> One (r1165) + | 1694 -> One (r1166) + | 1697 -> One (r1167) + | 1696 -> One (r1168) + | 1709 -> One (r1169) + | 1708 -> One (r1170) + | 1721 -> One (r1171) + | 1720 -> One (r1172) + | 1744 -> One (r1173) + | 1743 -> One (r1174) + | 1753 -> One (r1175) + | 1755 -> One (r1176) + | 1757 -> One (r1177) + | 1770 -> One (r1178) + | 1774 -> One (r1179) + | 1779 -> One (r1180) + | 1786 -> One (r1181) + | 1785 -> One (r1182) + | 1784 -> One (r1183) + | 1783 -> One (r1184) + | 1793 -> One (r1185) + | 1797 -> One (r1186) + | 1801 -> One (r1187) + | 1804 -> One (r1188) + | 1809 -> One (r1189) + | 1813 -> One (r1190) + | 1817 -> One (r1191) + | 1821 -> One (r1192) + | 1825 -> One (r1193) + | 1828 -> One (r1194) + | 1832 -> One (r1195) + | 1838 -> One (r1196) + | 1848 -> One (r1197) + | 1850 -> One (r1198) + | 1853 -> One (r1199) + | 1852 -> One (r1200) + | 1855 -> One (r1201) + | 1865 -> One (r1202) + | 1861 -> One (r1203) + | 1860 -> One (r1204) + | 1864 -> One (r1205) + | 1863 -> One (r1206) + | 1870 -> One (r1207) + | 1869 -> One (r1208) + | 1868 -> One (r1209) + | 1872 -> One (r1210) + | 373 -> Select (function + | -1 -> [R 98] + | _ -> S (T T_DOT) :: r343) + | 617 -> Select (function + | -1 -> [R 98] + | _ -> r549) | 173 -> Select (function - | -1 -> r152 - | _ -> R 187 :: r144) - | 810 -> Select (function - | -1 -> r679 - | _ -> R 187 :: r672) - | 867 -> Select (function - | -1 -> r152 - | _ -> R 187 :: r721) - | 946 -> Select (function - | -1 -> r626 - | _ -> R 187 :: r768) - | 508 -> Select (function - | -1 -> r278 - | _ -> [R 221]) - | 381 -> Select (function - | -1 -> [R 674] - | _ -> S (N N_pattern) :: r336) - | 378 -> Select (function - | -1 -> [R 675] - | _ -> S (N N_pattern) :: r335) + | -1 -> r158 + | _ -> R 135 :: r150) + | 838 -> Select (function + | -1 -> r703 + | _ -> R 135 :: r696) + | 895 -> Select (function + | -1 -> r158 + | _ -> R 135 :: r745) + | 974 -> Select (function + | -1 -> r650 + | _ -> R 135 :: r792) + | 518 -> Select (function + | -1 -> r296 + | _ -> [R 228]) + | 391 -> Select (function + | -1 -> [R 685] + | _ -> S (N N_pattern) :: r351) + | 388 -> Select (function + | -1 -> [R 686] + | _ -> S (N N_pattern) :: r350) | 179 -> Select (function - | -1 -> r164 - | _ -> R 782 :: r158) - | 870 -> Select (function - | -1 -> r164 - | _ -> R 782 :: r727) - | 844 -> Select (function - | -1 -> S (T T_RPAREN) :: r54 - | _ -> S (T T_COLONCOLON) :: r344) - | 87 -> Select (function - | 252 | 442 | 611 | 719 | 1252 | 1291 | 1342 | 1466 -> r61 - | -1 -> S (T T_RPAREN) :: r54 - | _ -> S (N N_pattern) :: r56) + | -1 -> r170 + | _ -> R 792 :: r164) + | 898 -> Select (function + | -1 -> r170 + | _ -> R 792 :: r751) | 243 -> Select (function - | -1 -> S (T T_RPAREN) :: r54 - | _ -> Sub (r1) :: r232) + | -1 -> S (T T_RPAREN) :: r60 + | _ -> S (T T_MODULE) :: r241) + | 872 -> Select (function + | -1 -> S (T T_RPAREN) :: r60 + | _ -> S (T T_COLONCOLON) :: r359) + | 87 -> Select (function + | 252 | 452 | 632 | 747 | 1280 | 1319 | 1370 | 1495 -> r67 + | -1 -> S (T T_RPAREN) :: r60 + | _ -> S (N N_pattern) :: r62) | 254 -> Select (function - | -1 -> S (T T_RBRACKET) :: r243 - | _ -> Sub (r245) :: r247) - | 550 -> Select (function - | -1 -> S (T T_RBRACKET) :: r243 - | _ -> Sub (r458) :: r460) - | 462 -> Select (function - | 60 | 172 | 210 | 744 | 785 | 787 -> r401 - | _ -> S (T T_OPEN) :: r395) - | 846 -> Select (function - | -1 -> r451 - | _ -> S (T T_LPAREN) :: r703) - | 270 -> Select (function - | -1 -> r280 - | _ -> S (T T_DOT) :: r282) - | 506 -> Select (function - | -1 -> r280 - | _ -> S (T T_DOT) :: r446) + | -1 -> S (T T_RBRACKET) :: r252 + | _ -> Sub (r254) :: r256) + | 560 -> Select (function + | -1 -> S (T T_RBRACKET) :: r252 + | _ -> Sub (r468) :: r470) + | 472 -> Select (function + | -1 | 60 | 172 | 210 | 211 | 772 | 813 | 815 | 1857 -> r405 + | _ -> S (T T_OPEN) :: r411) + | 874 -> Select (function + | -1 -> r461 + | _ -> S (T T_LPAREN) :: r727) + | 290 -> Select (function + | 1115 | 1119 | 1123 | 1126 | 1140 | 1324 | 1348 -> r290 + | -1 -> r302 + | _ -> S (T T_DOT) :: r305) + | 516 -> Select (function + | -1 -> r302 + | _ -> S (T T_DOT) :: r456) | 203 -> Select (function - | -1 -> r123 - | _ -> S (T T_COLON) :: r185) + | -1 -> r129 + | _ -> S (T T_COLON) :: r191) | 152 -> Select (function - | 851 | 1596 -> r107 - | _ -> Sub (r105) :: r108) + | 879 | 1606 -> r113 + | _ -> Sub (r111) :: r114) | 155 -> Select (function - | 851 | 1596 -> r106 - | _ -> r108) - | 1714 -> Select (function - | -1 -> r148 - | _ -> r123) + | 879 | 1606 -> r112 + | _ -> r114) + | 1723 -> Select (function + | -1 -> r154 + | _ -> r129) | 198 -> Select (function - | -1 -> r162 - | _ -> r123) - | 921 -> Select (function - | -1 -> r148 - | _ -> r123) - | 872 -> Select (function - | -1 -> r162 - | _ -> r123) - | 1713 -> Select (function - | -1 -> r149 - | _ -> r142) + | -1 -> r168 + | _ -> r129) + | 949 -> Select (function + | -1 -> r154 + | _ -> r129) + | 900 -> Select (function + | -1 -> r168 + | _ -> r129) + | 1722 -> Select (function + | -1 -> r155 + | _ -> r148) | 175 -> Select (function - | -1 -> r150 - | _ -> r143) + | -1 -> r156 + | _ -> r149) | 174 -> Select (function - | -1 -> r151 - | _ -> r144) - | 920 -> Select (function - | -1 -> r149 - | _ -> r719) - | 869 -> Select (function - | -1 -> r150 - | _ -> r720) - | 868 -> Select (function - | -1 -> r151 - | _ -> r721) - | 197 -> Select (function - | -1 -> r163 - | _ -> r158) - | 871 -> Select (function - | -1 -> r163 - | _ -> r727) - | 277 -> Select (function - | -1 -> r279 - | _ -> r282) - | 507 -> Select (function - | -1 -> r279 - | _ -> r446) - | 949 -> Select (function - | -1 -> r623 - | _ -> r766) + | -1 -> r157 + | _ -> r150) | 948 -> Select (function - | -1 -> r624 - | _ -> r767) - | 947 -> Select (function - | -1 -> r625 - | _ -> r768) - | 818 -> Select (function - | -1 -> r676 - | _ -> r670) - | 812 -> Select (function - | -1 -> r677 - | _ -> r671) - | 811 -> Select (function - | -1 -> r678 - | _ -> r672) + | -1 -> r155 + | _ -> r743) + | 897 -> Select (function + | -1 -> r156 + | _ -> r744) + | 896 -> Select (function + | -1 -> r157 + | _ -> r745) + | 197 -> Select (function + | -1 -> r169 + | _ -> r164) + | 899 -> Select (function + | -1 -> r169 + | _ -> r751) + | 291 -> Select (function + | 1115 | 1119 | 1123 | 1126 | 1140 | 1324 | 1348 -> r289 + | -1 -> r297 + | _ -> r305) + | 517 -> Select (function + | -1 -> r297 + | _ -> r456) + | 977 -> Select (function + | -1 -> r647 + | _ -> r790) + | 976 -> Select (function + | -1 -> r648 + | _ -> r791) + | 975 -> Select (function + | -1 -> r649 + | _ -> r792) + | 846 -> Select (function + | -1 -> r700 + | _ -> r694) + | 840 -> Select (function + | -1 -> r701 + | _ -> r695) + | 839 -> Select (function + | -1 -> r702 + | _ -> r696) | _ -> raise Not_found diff --git a/src/ocaml/typing/btype.ml b/src/ocaml/typing/btype.ml index 2191cad4f2..5ce396ecd2 100644 --- a/src/ocaml/typing/btype.ml +++ b/src/ocaml/typing/btype.ml @@ -46,9 +46,11 @@ end module TransientTypeHash = Hashtbl.Make(TransientTypeOps) module TypeHash = struct include TransientTypeHash + let mem hash = wrap_repr (mem hash) let add hash = wrap_repr (add hash) let remove hash = wrap_repr (remove hash) let find hash = wrap_repr (find hash) + let find_opt hash = wrap_repr (find_opt hash) let iter f = TransientTypeHash.iter (wrap_type_expr f) end module TransientTypePairs = @@ -125,6 +127,12 @@ let newmarkedgenvar () = let is_Tvar ty = match get_desc ty with Tvar _ -> true | _ -> false let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false +let type_kind_is_abstract decl = + match decl.type_kind with Type_abstract _ -> true | _ -> false +let type_origin decl = + match decl.type_kind with + | Type_abstract origin -> origin + | Type_variant _ | Type_record _ | Type_open -> Definition let dummy_method = "*dummy method*" @@ -323,7 +331,7 @@ let map_type_expr_cstr_args f = function 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_abstract _ -> () | Type_variant (cstrs, _) -> List.iter (fun cd -> diff --git a/src/ocaml/typing/btype.mli b/src/ocaml/typing/btype.mli index d79b8d2748..71dd67b74a 100644 --- a/src/ocaml/typing/btype.mli +++ b/src/ocaml/typing/btype.mli @@ -39,9 +39,11 @@ module TypeMap : sig end module TypeHash : sig include Hashtbl.S with type key = transient_expr + val mem: 'a t -> type_expr -> bool val add: 'a t -> type_expr -> 'a -> unit - val remove : 'a t -> type_expr -> unit + val remove: 'a t -> type_expr -> unit val find: 'a t -> type_expr -> 'a + val find_opt: 'a t -> type_expr -> 'a option val iter: (type_expr -> 'a -> unit) -> 'a t -> unit end module TypePairs : sig @@ -78,6 +80,8 @@ val is_Tvar: type_expr -> bool val is_Tunivar: type_expr -> bool val is_Tconstr: type_expr -> bool val dummy_method: label +val type_kind_is_abstract: type_declaration -> bool +val type_origin : type_declaration -> type_origin (**** polymorphic variants ****) diff --git a/src/ocaml/typing/cmi_format.ml b/src/ocaml/typing/cmi_format.ml index b4934e27e7..3fae802d60 100644 --- a/src/ocaml/typing/cmi_format.ml +++ b/src/ocaml/typing/cmi_format.ml @@ -35,7 +35,7 @@ type cmi_infos = { } let input_cmi ic = - let (name, sign) = (Ocaml_compression.input_value ic : header) in + let (name, sign) = (input_value ic : header) in let crcs = (input_value ic : crcs) in let flags = (input_value ic : flags) in { @@ -74,14 +74,17 @@ let read_cmi filename = raise (Error e) let output_cmi filename oc cmi = + ignore (filename, oc, cmi); "" +(* (* beware: the provided signature must have been substituted for saving *) output_string oc Config.cmi_magic_number; - Ocaml_compression.output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header); + Marshal.(to_channel oc ((cmi.cmi_name, cmi.cmi_sign) : header) [Compression]); 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/cmt_format.ml b/src/ocaml/typing/cmt_format.ml index 6fbc314f0a..418a9d676e 100644 --- a/src/ocaml/typing/cmt_format.ml +++ b/src/ocaml/typing/cmt_format.ml @@ -70,27 +70,68 @@ type cmt_infos = { cmt_args : string array; cmt_sourcefile : string option; cmt_builddir : string; - cmt_loadpath : string list; + cmt_loadpath : Load_path.paths; 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; - cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; cmt_impl_shape : Shape.t option; (* None for mli *) + cmt_ident_occurrences : + (Longident.t Location.loc * Shape_reduce.result) list } type error = Not_a_typedtree of string +let iter_on_parts (it : Tast_iterator.iterator) = function + | Partial_structure s -> it.structure it s + | Partial_structure_item s -> it.structure_item it s + | Partial_expression e -> it.expr it e + | Partial_pattern (_category, p) -> it.pat it p + | Partial_class_expr ce -> it.class_expr it ce + | Partial_signature s -> it.signature it s + | Partial_signature_item s -> it.signature_item it s + | Partial_module_type s -> it.module_type it s + +let iter_on_annots (it : Tast_iterator.iterator) = function + | Implementation s -> it.structure it s + | Interface s -> it.signature it s + | Packed _ -> () + | Partial_implementation array -> Array.iter (iter_on_parts it) array + | Partial_interface array -> Array.iter (iter_on_parts it) array + +let iter_on_declaration f decl = + match decl with + | Value vd -> f vd.val_val.val_uid decl; + | Value_binding vb -> + let bound_idents = let_bound_idents_full [vb] in + List.iter ~f:(fun (_, _, _, uid) -> f uid decl) bound_idents + | Type td -> + if not (Btype.is_row_name (Ident.name td.typ_id)) then + f td.typ_type.type_uid (Type td) + | Constructor cd -> f cd.cd_uid decl + | Extension_constructor ec -> f ec.ext_type.ext_uid decl; + | Label ld -> f ld.ld_uid decl + | Module md -> f md.md_uid decl + | Module_type mtd -> f mtd.mtd_uid decl + | Module_substitution ms -> f ms.ms_uid decl + | Module_binding mb -> f mb.mb_uid decl + | Class cd -> f cd.ci_decl.cty_uid decl + | Class_type ct -> f ct.ci_decl.cty_uid decl + +let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) = { + Tast_iterator.default_iterator with + item_declaration = (fun _sub decl -> iter_on_declaration f decl); +} + 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} @@ -119,13 +160,250 @@ let clear_env binary_annots = else binary_annots +(* Every typedtree node with a located longident corresponding to user-facing + syntax should be indexed. *) +let iter_on_occurrences + ~(f : namespace:Shape.Sig_component_kind.t -> + Env.t -> Path.t -> Longident.t Location.loc -> + unit) = + let path_in_type typ name = + match Types.get_desc typ with + | Tconstr (type_path, _, _) -> + Some (Path.Pdot (type_path, name)) + | _ -> None + in + let add_constructor_description env lid = + function + | { Types.cstr_tag = Cstr_extension (path, _); _ } -> + f ~namespace:Extension_constructor env path lid + | { Types.cstr_uid = Predef name; _} -> + let id = List.assoc name Predef.builtin_idents in + f ~namespace:Constructor env (Pident id) lid + | { Types.cstr_res; cstr_name; _ } -> + let path = path_in_type cstr_res cstr_name in + Option.iter ~f:(fun path -> f ~namespace:Constructor env path lid) path + in + let add_label env lid { Types.lbl_name; lbl_res; _ } = + let path = path_in_type lbl_res lbl_name in + Option.iter ~f:(fun path -> f ~namespace:Label env path lid) path + in + let with_constraint ~env (_path, _lid, with_constraint) = + match with_constraint with + | Twith_module (path', lid') | Twith_modsubst (path', lid') -> + f ~namespace:Module env path' lid' + | _ -> () + in + Tast_iterator.{ default_iterator with + + expr = (fun sub ({ exp_desc; exp_env; _ } as e) -> + (match exp_desc with + | Texp_ident (path, lid, _) -> + f ~namespace:Value exp_env path lid + | Texp_construct (lid, constr_desc, _) -> + add_constructor_description exp_env lid constr_desc + | Texp_field (_, lid, label_desc) + | Texp_setfield (_, lid, label_desc, _) -> + add_label exp_env lid label_desc + | Texp_new (path, lid, _) -> + f ~namespace:Class exp_env path lid + | Texp_record { fields; _ } -> + Array.iter (fun (label_descr, record_label_definition) -> + match record_label_definition with + | Overridden ( + { Location.txt; loc}, + {exp_loc; _}) + when not exp_loc.loc_ghost + && loc.loc_start = exp_loc.loc_start + && loc.loc_end = exp_loc.loc_end -> + (* In the presence of punning we want to index the label + even if it is ghosted *) + let lid = { Location.txt; loc = {loc with loc_ghost = false} } in + add_label exp_env lid label_descr + | Overridden (lid, _) -> add_label exp_env lid label_descr + | Kept _ -> ()) fields + | Texp_instvar (_self_path, path, name) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env path lid + | Texp_setinstvar (_self_path, path, name, _) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env path lid + | Texp_override (_self_path, modifs) -> + List.iter ~f:(fun (id, (name : string Location.loc), _exp) -> + let lid = { name with txt = Longident.Lident name.txt } in + f ~namespace:Value exp_env (Path.Pident id) lid) + modifs + | Texp_extension_constructor (lid, path) -> + f ~namespace:Extension_constructor exp_env path lid + | Texp_constant _ | Texp_let _ | Texp_function _ | Texp_apply _ + | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_variant _ | Texp_array _ + | Texp_ifthenelse _ | Texp_sequence _ | Texp_while _ | Texp_for _ + | Texp_send _ + | Texp_letmodule _ | Texp_letexception _ | Texp_assert _ | Texp_lazy _ + | Texp_object _ | Texp_pack _ | Texp_letop _ | Texp_unreachable + | Texp_open _ | Texp_hole -> ()); + default_iterator.expr sub e); + + (* Remark: some types get iterated over twice due to how constraints are + encoded in the typedtree. For example, in [let x : t = 42], [t] is + present in both a [Tpat_constraint] and a [Texp_constraint] node) *) + typ = + (fun sub ({ ctyp_desc; ctyp_env; _ } as ct) -> + (match ctyp_desc with + | Ttyp_constr (path, lid, _ctyps) -> + f ~namespace:Type ctyp_env path lid + | Ttyp_package {pack_path; pack_txt} -> + f ~namespace:Module_type ctyp_env pack_path pack_txt + | Ttyp_class (path, lid, _typs) -> + (* Deprecated syntax to extend a polymorphic variant *) + f ~namespace:Type ctyp_env path lid + | Ttyp_open (path, lid, _ct) -> + f ~namespace:Module ctyp_env path lid + | Ttyp_any | Ttyp_var _ | Ttyp_arrow _ | Ttyp_tuple _ | Ttyp_object _ + | Ttyp_alias _ | Ttyp_variant _ | Ttyp_poly _ -> ()); + default_iterator.typ sub ct); + + pat = + (fun (type a) sub + ({ pat_desc; pat_extra; pat_env; _ } as pat : a general_pattern) -> + (match pat_desc with + | Tpat_construct (lid, constr_desc, _, _) -> + add_constructor_description pat_env lid constr_desc + | Tpat_record (fields, _) -> + List.iter ~f:(fun (lid, label_descr, pat) -> + let lid = + let open Location in + (* In the presence of punning we want to index the label + even if it is ghosted *) + if (not pat.pat_loc.loc_ghost + && lid.loc.loc_start = pat.pat_loc.loc_start + && lid.loc.loc_end = pat.pat_loc.loc_end) + then {lid with loc = {lid.loc with loc_ghost = false}} + else lid + in + add_label pat_env lid label_descr) + fields + | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _ + | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _ + | Tpat_exception _ | Tpat_or _ -> ()); + List.iter ~f:(fun (pat_extra, _, _) -> + match pat_extra with + | Tpat_open (path, lid, _) -> + f ~namespace:Module pat_env path lid + | Tpat_type (path, lid) -> + f ~namespace:Type pat_env path lid + | Tpat_constraint _ | Tpat_unpack -> ()) + pat_extra; + default_iterator.pat sub pat); + + binding_op = (fun sub ({bop_op_path; bop_op_name; bop_exp; _} as bop) -> + let lid = { bop_op_name with txt = Longident.Lident bop_op_name.txt } in + f ~namespace:Value bop_exp.exp_env bop_op_path lid; + default_iterator.binding_op sub bop); + + module_expr = + (fun sub ({ mod_desc; mod_env; _ } as me) -> + (match mod_desc with + | Tmod_ident (path, lid) -> f ~namespace:Module mod_env path lid + | Tmod_structure _ | Tmod_functor _ | Tmod_apply _ | Tmod_apply_unit _ + | Tmod_constraint _ | Tmod_unpack _ | Tmod_hole -> ()); + default_iterator.module_expr sub me); + + open_description = + (fun sub ({ open_expr = (path, lid); open_env; _ } as od) -> + f ~namespace:Module open_env path lid; + default_iterator.open_description sub od); + + module_type = + (fun sub ({ mty_desc; mty_env; _ } as mty) -> + (match mty_desc with + | Tmty_ident (path, lid) -> + f ~namespace:Module_type mty_env path lid + | Tmty_with (_mty, l) -> + List.iter ~f:(with_constraint ~env:mty_env) l + | Tmty_alias (path, lid) -> + f ~namespace:Module mty_env path lid + | Tmty_signature _ | Tmty_functor _ | Tmty_typeof _ -> ()); + default_iterator.module_type sub mty); + + class_expr = + (fun sub ({ cl_desc; cl_env; _} as ce) -> + (match cl_desc with + | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid + | Tcl_structure _ | Tcl_fun _ | Tcl_apply _ | Tcl_let _ + | Tcl_constraint _ | Tcl_open _ -> ()); + default_iterator.class_expr sub ce); + + class_type = + (fun sub ({ cltyp_desc; cltyp_env; _} as ct) -> + (match cltyp_desc with + | Tcty_constr (path, lid, _) -> f ~namespace:Class_type cltyp_env path lid + | Tcty_signature _ | Tcty_arrow _ | Tcty_open _ -> ()); + default_iterator.class_type sub ct); + + signature_item = + (fun sub ({ sig_desc; sig_env; _ } as sig_item) -> + (match sig_desc with + | Tsig_exception { + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> + f ~namespace:Extension_constructor sig_env path lid + | Tsig_modsubst { ms_manifest; ms_txt } -> + f ~namespace:Module sig_env ms_manifest ms_txt + | Tsig_typext { tyext_path; tyext_txt } -> + f ~namespace:Type sig_env tyext_path tyext_txt + | Tsig_value _ | Tsig_type _ | Tsig_typesubst _ | Tsig_exception _ + | Tsig_module _ | Tsig_recmodule _ | Tsig_modtype _ | Tsig_modtypesubst _ + | Tsig_open _ | Tsig_include _ | Tsig_class _ | Tsig_class_type _ + | Tsig_attribute _ -> ()); + default_iterator.signature_item sub sig_item); + + structure_item = + (fun sub ({ str_desc; str_env; _ } as str_item) -> + (match str_desc with + | Tstr_exception { + tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} -> + f ~namespace:Extension_constructor str_env path lid + | Tstr_typext { tyext_path; tyext_txt } -> + f ~namespace:Type str_env tyext_path tyext_txt + | Tstr_eval _ | Tstr_value _ | Tstr_primitive _ | Tstr_type _ + | Tstr_exception _ | Tstr_module _ | Tstr_recmodule _ + | Tstr_modtype _ | Tstr_open _ | Tstr_class _ | Tstr_class_type _ + | Tstr_include _ | Tstr_attribute _ -> ()); + default_iterator.structure_item sub str_item) +} + +let index_declarations binary_annots = + let index : item_declaration Types.Uid.Tbl.t = Types.Uid.Tbl.create 16 in + let f uid fragment = Types.Uid.Tbl.add index uid fragment in + iter_on_annots (iter_on_declarations ~f) binary_annots; + index + +let index_occurrences binary_annots = + let index : (Longident.t Location.loc * Shape_reduce.result) list ref = + ref [] + in + let f ~namespace env path lid = + let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in + if not_ghost lid then + match Env.shape_of_path ~namespace env path with + | exception Not_found -> () + | { uid = Some (Predef _); _ } -> () + | path_shape -> + let result = Shape_reduce.local_reduce_for_uid env path_shape in + index := (lid, result) :: !index + in + iter_on_annots (iter_on_occurrences ~f) binary_annots; + !index + exception Error of error -let input_cmt ic = (Ocaml_compression.input_value ic : cmt_infos) +let input_cmt ic = (input_value ic : cmt_infos) let output_cmt oc cmt = + ignore (oc, cmt) + (* output_string oc Config.cmt_magic_number; - Ocaml_compression.output_value oc (cmt : cmt_infos) + Marshal.(to_channel oc (cmt : cmt_infos) [Compression]) + *) let read filename = (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) @@ -182,20 +460,29 @@ let set_saved_types l = saved_types := l let record_value_dependency _vd1 _vd2 = () -let save_cmt filename modname binary_annots sourcefile initial_env cmi shape = +let save_cmt target binary_annots initial_env cmi shape = if !Clflags.binary_annotations && not !Clflags.print_types then begin Misc.output_to_file_via_temporary - ~mode:[Open_binary] filename + ~mode:[Open_binary] (Unit_info.Artifact.filename target) (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 sourcefile = Unit_info.Artifact.source_file target in + let cmt_ident_occurrences = + if !Clflags.store_occurrences then + index_occurrences binary_annots + else + [] + in + let cmt_annots = clear_env binary_annots in + let cmt_uid_to_decl = index_declarations cmt_annots in let source_digest = Option.map ~f:Digest.file sourcefile in let cmt = { - cmt_modname = modname; - cmt_annots = clear_env binary_annots; + cmt_modname = Unit_info.Artifact.modname target; + cmt_annots; cmt_value_dependencies = !value_deps; cmt_comments = []; cmt_args = Sys.argv; @@ -208,8 +495,9 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape = cmt_imports = List.sort ~cmp:compare (Env.imports ()); cmt_interface_digest = this_crc; cmt_use_summaries = need_to_clear_env; - cmt_uid_to_loc = Env.get_uid_to_loc_tbl (); + cmt_uid_to_decl; cmt_impl_shape = shape; + cmt_ident_occurrences; } in output_cmt oc cmt) end; diff --git a/src/ocaml/typing/cmt_format.mli b/src/ocaml/typing/cmt_format.mli index 43e09f1236..d27f56bccb 100644 --- a/src/ocaml/typing/cmt_format.mli +++ b/src/ocaml/typing/cmt_format.mli @@ -59,14 +59,16 @@ type cmt_infos = { cmt_args : string array; cmt_sourcefile : string option; cmt_builddir : string; - cmt_loadpath : string list; + cmt_loadpath : Load_path.paths; cmt_source_digest : string option; cmt_initial_env : Env.t; cmt_imports : crcs; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; - cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t; + cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t; cmt_impl_shape : Shape.t option; (* None for mli *) + cmt_ident_occurrences : + (Longident.t Location.loc * Shape_reduce.result) list } type error = @@ -90,10 +92,8 @@ 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 *) + Unit_info.Artifact.t -> binary_annots -> - string option -> (* source file *) Env.t -> (* initial env *) Cmi_format.cmi_infos option -> (* if a .cmi was generated *) Shape.t option -> @@ -112,7 +112,6 @@ 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 diff --git a/src/ocaml/typing/ctype.ml b/src/ocaml/typing/ctype.ml index b70965ec86..d4364f161a 100644 --- a/src/ocaml/typing/ctype.ml +++ b/src/ocaml/typing/ctype.ml @@ -122,11 +122,14 @@ let () = Location.register_error_of_exn (function | Tags (l, l') -> + let pp_tag ppf s = Format.fprintf ppf "`%s" s in + let inline_tag = Misc.Style.as_inline_code pp_tag in 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' + "In this program,@ variant constructors@ %a and %a@ \ + have the same hash value.@ Change one of them." + inline_tag l inline_tag l' ) | _ -> None ) @@ -277,88 +280,127 @@ let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) let none = newty (Ttuple []) (* Clearly ill-formed type *) +(**** information for [Typecore.unify_pat_*] ****) + +module Pattern_env : sig + type t = private + { mutable env : Env.t; + equations_scope : int; + allow_recursive_equations : bool; } + val make: Env.t -> equations_scope:int -> allow_recursive_equations:bool -> t + val copy: ?equations_scope:int -> t -> t + val set_env: t -> Env.t -> unit +end = struct + type t = + { mutable env : Env.t; + equations_scope : int; + allow_recursive_equations : bool; } + let make env ~equations_scope ~allow_recursive_equations = + { env; + equations_scope; + allow_recursive_equations; } + let copy ?equations_scope penv = + let equations_scope = + match equations_scope with None -> penv.equations_scope | Some s -> s in + { penv with equations_scope } + let set_env penv env = penv.env <- env +end + (**** unification mode ****) type equations_generation = | Forbidden | Allowed of { equated_types : TypePairs.t } -type unification_mode = - | Expression (* unification in expression *) +type unification_environment = + | Expression of + { env : Env.t; + in_subst : bool; } + (* normal unification mode *) | Pattern of - { equations_generation : equations_generation; + { penv : Pattern_env.t; + equations_generation : equations_generation; assume_injective : bool; - allow_recursive_equations : bool; } - (* unification in pattern which may add local constraints *) - | Subst - (* unification during type constructor expansion; more - relaxed than [Expression] in some cases. *) - -let umode = ref Expression - -let in_pattern_mode () = - match !umode with - | Expression | Subst -> false + unify_eq_set : TypePairs.t; } + (* GADT constraint unification mode: + only used for type indices of GADT constructors + during pattern matching. + This allows adding local constraints. *) + +let get_env = function + | Expression {env} -> env + | Pattern {penv} -> penv.env + +let set_env uenv env = + match uenv with + | Expression _ -> invalid_arg "Ctype.set_env" + | Pattern {penv} -> Pattern_env.set_env penv env + +let in_pattern_mode = function + | Expression _ -> false | Pattern _ -> true -let in_subst_mode () = - match !umode with - | Expression | Pattern _ -> false - | Subst -> true +let get_equations_scope = function + | Expression _ -> invalid_arg "Ctype.get_equations_scope" + | Pattern r -> r.penv.equations_scope -let can_generate_equations () = - match !umode with - | Expression | Subst | Pattern { equations_generation = Forbidden } -> false +let order_type_pair t1 t2 = + if get_id t1 <= get_id t2 then (t1, t2) else (t2, t1) + +let add_type_equality uenv t1 t2 = + match uenv with + | Expression _ -> invalid_arg "Ctype.add_type_equality" + | Pattern r -> TypePairs.add r.unify_eq_set (order_type_pair t1 t2) + +let unify_eq uenv t1 t2 = + eq_type t1 t2 || + match uenv with + | Expression _ -> false + | Pattern r -> TypePairs.mem r.unify_eq_set (order_type_pair t1 t2) + +(* unification during type constructor expansion: + This mode disables the propagation of the level and scope of + the row variable to the whole type during the unification. + (see unify_{row, fields} and PR #11771) *) +let in_subst_mode = function + | Expression {in_subst} -> in_subst + | Pattern _ -> false + +let can_generate_equations = function + | Expression _ | Pattern { equations_generation = Forbidden } -> false | Pattern { equations_generation = Allowed _ } -> true (* Can only be called when generate_equations is true *) -let record_equation t1 t2 = - match !umode with - | Expression | Subst | Pattern { equations_generation = Forbidden } -> - assert false +let record_equation uenv t1 t2 = + match uenv with + | Expression _ | Pattern { equations_generation = Forbidden } -> + invalid_arg "Ctype.record_equation" | Pattern { equations_generation = Allowed { equated_types } } -> TypePairs.add equated_types (t1, t2) -let can_assume_injective () = - match !umode with - | Expression | Subst -> false +let can_assume_injective = function + | Expression _ -> false | Pattern { assume_injective } -> assume_injective -let in_counterexample () = - match !umode with - | Expression | Subst -> false - | Pattern { allow_recursive_equations } -> allow_recursive_equations +let in_counterexample uenv = + match uenv with + | Expression _ -> false + | Pattern { penv } -> penv.allow_recursive_equations -let allow_recursive_equations () = - !Clflags.recursive_types - || match !umode with - | Expression | Subst -> false - | Pattern { allow_recursive_equations } -> allow_recursive_equations +let allow_recursive_equations uenv = + !Clflags.recursive_types || in_counterexample uenv -let set_mode_pattern ~allow_recursive_equations ~equated_types f = - let equations_generation = Allowed { equated_types } in - let assume_injective = true in - let new_umode = - Pattern - { equations_generation; - assume_injective; - allow_recursive_equations } - in - Misc.protect_refs [ Misc.R (umode, new_umode) ] f - -let without_assume_injective f = - match !umode with - | Expression | Subst -> f () - | Pattern r -> - let new_umode = Pattern { r with assume_injective = false } in - Misc.protect_refs [ Misc.R (umode, new_umode) ] f - -let without_generating_equations f = - match !umode with - | Expression | Subst -> f () - | Pattern r -> - let new_umode = Pattern { r with equations_generation = Forbidden } in - Misc.protect_refs [ Misc.R (umode, new_umode) ] f +(* Though without_* functions can be in a direct style, + CPS clarifies the structure of the code better. *) +let without_assume_injective uenv f = + match uenv with + | Expression _ as uenv -> f uenv + | Pattern r -> f (Pattern { r with assume_injective = false }) + +let without_generating_equations uenv f = + match uenv with + | Expression _ as uenv -> f uenv + | Pattern r -> f (Pattern { r with equations_generation = Forbidden }) (*** Checks for type definitions ***) @@ -375,7 +417,7 @@ let in_pervasives p = let is_datatype decl= match decl.type_kind with Type_record _ | Type_variant _ | Type_open -> true - | Type_abstract -> false + | Type_abstract _ -> false (**********************************************) @@ -577,7 +619,7 @@ let closed_type_decl decl = try List.iter mark_type decl.type_params; begin match decl.type_kind with - Type_abstract -> + Type_abstract _ -> () | Type_variant (v, _rep) -> List.iter @@ -908,7 +950,7 @@ let rec lower_contravariant env var_level visited contra ty = try let typ = Env.find_type path env in typ.type_variance, - typ.type_kind = Type_abstract + type_kind_is_abstract typ with Not_found -> (* See testsuite/tests/typing-missing-cmi-2 for an example *) List.map (fun _ -> Variance.unknown) tyl, @@ -971,46 +1013,42 @@ let correct_levels ty = (* Only generalize the type ty0 in ty *) let limited_generalize ty0 ty = - let graph = Hashtbl.create 17 in - let idx = ref lowest_level in + let graph = TypeHash.create 17 in let roots = ref [] in let rec inverse pty ty = - let level = get_level ty in - if (level > !current_level) || (level = generic_level) then begin - decr idx; - Hashtbl.add graph !idx (ty, ref pty); - if (level = generic_level) || eq_type ty ty0 then - roots := ty :: !roots; - set_level ty !idx; - iter_type_expr (inverse [ty]) ty - end else if level < lowest_level then begin - let (_, parents) = Hashtbl.find graph level in - parents := pty @ !parents - end + match TypeHash.find_opt graph ty with + | Some parents -> parents := pty @ !parents + | None -> + let level = get_level ty in + if level > !current_level then begin + TypeHash.add graph ty (ref pty); + (* XXX: why generic_level needs to be a root *) + if (level = generic_level) || eq_type ty ty0 then + roots := ty :: !roots; + iter_type_expr (inverse [ty]) ty + end + in - and generalize_parents ty = - let idx = get_level ty in - if idx <> generic_level then begin + let rec generalize_parents ~is_root ty = + if is_root || get_level ty <> generic_level then begin set_level ty generic_level; - List.iter generalize_parents !(snd (Hashtbl.find graph idx)); + List.iter (generalize_parents ~is_root:false) !(TypeHash.find graph ty); (* Special case for rows: must generalize the row variable *) match get_desc ty with Tvariant row -> let more = row_more row in let lv = get_level more in - if (lv < lowest_level || lv > !current_level) - && lv <> generic_level then set_level more generic_level + if (TypeHash.mem graph more || lv > !current_level) + && lv <> generic_level then set_level more generic_level | _ -> () end in inverse [] ty; - if get_level ty0 < lowest_level then - iter_type_expr (inverse []) ty0; - List.iter generalize_parents !roots; - Hashtbl.iter - (fun _ (ty, _) -> + List.iter (generalize_parents ~is_root:true) !roots; + TypeHash.iter + (fun ty _ -> if get_level ty <> generic_level then set_level ty !current_level) graph @@ -1236,8 +1274,6 @@ let instance_list schl = (* Create unique names to new type constructors. Used for existential types and local constraints. *) let get_new_abstract_name env s = - (* unique names are needed only for error messages *) - if in_counterexample () then s else let name index = if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else Printf.sprintf "%s%d" s index @@ -1250,7 +1286,7 @@ let get_new_abstract_name env s = let index = Misc.find_first_mono check in name index -let new_local_type ?(loc = Location.none) ?manifest_and_scope () = +let new_local_type ?(loc = Location.none) ?manifest_and_scope origin = let manifest, expansion_scope = match manifest_and_scope with None -> None, Btype.lowest_level @@ -1259,7 +1295,7 @@ let new_local_type ?(loc = Location.none) ?manifest_and_scope () = { type_params = []; type_arity = 0; - type_kind = Type_abstract; + type_kind = Type_abstract origin; type_private = Public; type_manifest = manifest; type_variance = []; @@ -1273,28 +1309,37 @@ let new_local_type ?(loc = Location.none) ?manifest_and_scope () = type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } -let existential_name cstr ty = - match get_desc ty with - | Tvar (Some name) -> "$" ^ cstr.cstr_name ^ "_'" ^ name - | _ -> "$" ^ cstr.cstr_name +let existential_name name_counter ty = + let name = + match get_desc ty with + | Tvar (Some name) -> name + | _ -> + let name = Misc.letter_of_int !name_counter in + incr name_counter; + name + in + "$" ^ name type existential_treatment = | Keep_existentials_flexible - | Make_existentials_abstract of { env: Env.t ref; scope: int } + | Make_existentials_abstract of Pattern_env.t let instance_constructor existential_treatment cstr = For_copy.with_scope (fun copy_scope -> + let name_counter = ref 0 in let copy_existential = match existential_treatment with | Keep_existentials_flexible -> copy copy_scope - | Make_existentials_abstract {env; scope = fresh_constr_scope} -> + | Make_existentials_abstract penv -> fun existential -> - let decl = new_local_type () in - let name = existential_name cstr existential in + let env = penv.env in + let fresh_constr_scope = penv.equations_scope in + let decl = new_local_type (Existential cstr.cstr_name) in + let name = existential_name name_counter existential in let (id, new_env) = - Env.enter_type (get_new_abstract_name !env name) decl !env + Env.enter_type (get_new_abstract_name env name) decl env ~scope:fresh_constr_scope in - env := new_env; + Pattern_env.set_env penv new_env; let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in let tv = copy copy_scope existential in assert (is_Tvar tv); @@ -1315,7 +1360,7 @@ let instance_parameterized_type ?keep_names sch_args sch = ) let map_kind f = function - | Type_abstract -> Type_abstract + | Type_abstract r -> Type_abstract r | Type_open -> Type_open | Type_variant (cl, rep) -> Type_variant ( @@ -1404,7 +1449,7 @@ let copy_sep ~copy_scope ~fixed ~(visited : type_expr TypeHash.t) sch = let delayed_copies = ref [] in let add_delayed_copy t ty = delayed_copies := - lazy (Transient_expr.set_stub_desc t (Tlink (copy copy_scope ty))) :: + (fun () -> Transient_expr.set_stub_desc t (Tlink (copy copy_scope ty))) :: !delayed_copies in let rec copy_rec ~may_share (ty : type_expr) = @@ -1445,10 +1490,10 @@ let copy_sep ~copy_scope ~fixed ~(visited : type_expr TypeHash.t) sch = end in let ty = copy_rec ~may_share:true sch in - List.iter Lazy.force !delayed_copies; + List.iter (fun force -> force ()) !delayed_copies; ty -let instance_poly' copy_scope ~keep_names fixed univars sch = +let instance_poly' copy_scope ~keep_names ~fixed univars sch = (* In order to compute univars below, [sch] should not contain [Tsubst] *) let copy_var ty = match get_desc ty with @@ -1461,17 +1506,17 @@ let instance_poly' copy_scope ~keep_names fixed univars sch = let ty = copy_sep ~copy_scope ~fixed ~visited sch in vars, ty -let instance_poly ?(keep_names=false) fixed univars sch = +let instance_poly ?(keep_names=false) ~fixed univars sch = For_copy.with_scope (fun copy_scope -> - instance_poly' copy_scope ~keep_names fixed univars sch + instance_poly' copy_scope ~keep_names ~fixed univars sch ) -let instance_label fixed lbl = +let instance_label ~fixed lbl = For_copy.with_scope (fun copy_scope -> let vars, ty_arg = match get_desc lbl.lbl_arg with Tpoly (ty, tl) -> - instance_poly' copy_scope ~keep_names:false fixed tl ty + instance_poly' copy_scope ~keep_names:false ~fixed tl ty | _ -> [], copy copy_scope lbl.lbl_arg in @@ -1505,17 +1550,14 @@ let subst env level priv abbrev oty params args body = abbreviations := abbrev; let (params', body') = instance_parameterized_type params body in abbreviations := ref Mnil; - let old_umode = !umode in - umode := Subst; + let uenv = Expression {env; in_subst = true} in try - !unify_var' env body0 body'; - List.iter2 (!unify_var' env) params' args; + !unify_var' uenv body0 body'; + List.iter2 (!unify_var' uenv) params' args; current_level := old_level; - umode := old_umode; body' with Unify _ -> current_level := old_level; - umode := old_umode; undo_abbrev (); raise Cannot_subst @@ -1526,28 +1568,27 @@ let subst env level priv abbrev oty params args body = care about efficiency here. *) let apply ?(use_current_level = false) env params body args = + simple_abbrevs := Mnil; let level = if use_current_level then !current_level else generic_level in try subst env 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. + be correct anymore, and so we flush the cache. The test used + checks whether any of types, modules, or local constraints have + been changed. *) 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 + if not (Env.same_type_declarations env !previous_env) then begin (* prerr_endline "cleanup expansion cache"; *) cleanup_abbrev (); previous_env := env @@ -1573,59 +1614,55 @@ let check_abbrev_env env = and this other expansion fails. *) let expand_abbrev_gen kind find_type_expansion env ty = + let path, args, abbrev = match get_desc ty with + | Tconstr (path,args,abbrev) -> path, args, abbrev + | _ -> assert false + in check_abbrev_env env; - match get_desc ty with - Tconstr (path, args, abbrev) -> - let level = get_level ty in - let scope = get_scope ty in - let lookup_abbrev = proper_abbrevs args abbrev in - begin match find_expans kind path !lookup_abbrev with - Some ty' -> + let level = get_level ty in + let scope = get_scope ty in + let lookup_abbrev = proper_abbrevs args abbrev in + let expansion = + (* first look for an existing expansion *) + match find_expans kind path !lookup_abbrev with + | None -> None + | Some ty' -> try + (* prerr_endline + ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) + if level <> generic_level then update_level env level ty'; + update_scope scope ty'; + Some ty' + with Escape _ -> + (* in case of Escape, discard the stale expansion and re-expand *) + forget_abbrev lookup_abbrev path; + None + in + begin match expansion with + | Some ty' -> ty' + | None -> + (* attempt to (re-)expand *) + 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 - ("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; + ("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 (get_scope ty) in + update_scope scope ty; + update_scope scope ty'; 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 (get_scope ty) in - update_scope scope ty; - update_scope scope ty'; - ty' - end - | _ -> - assert false + end (* Expand respecting privacy *) let expand_abbrev env ty = @@ -1703,7 +1740,7 @@ let rec extract_concrete_typedecl env ty = begin match Env.find_type p env with | exception Not_found -> May_have_typedecl | decl -> - if decl.type_kind <> Type_abstract then Typedecl(p, p, decl) + if not (type_kind_is_abstract decl) then Typedecl(p, p, decl) else begin match try_expand_safe env ty with | exception Cannot_expand -> May_have_typedecl @@ -1791,7 +1828,7 @@ let generic_abbrev env path = let generic_private_abbrev env path = try match Env.find_type path env with - {type_kind = Type_abstract; + {type_kind = Type_abstract _; type_private = Private; type_manifest = Some body} -> get_level body = generic_level @@ -1841,8 +1878,9 @@ 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 = allow_recursive_equations () in +let occur uenv ty0 ty = + let env = get_env uenv in + let allow_recursive = allow_recursive_equations uenv in let old = !type_changed in try while @@ -1856,13 +1894,13 @@ let occur env ty0 ty = merge type_changed old; raise exn -let occur_for tr_exn env t1 t2 = +let occur_for tr_exn uenv t1 t2 = try - occur env t1 t2 + occur uenv 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 + try occur (Expression {env; in_subst = false}) 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 *) @@ -1901,8 +1939,9 @@ let rec local_non_recursive_abbrev ~allow_rec strict visited env p ty = (local_non_recursive_abbrev ~allow_rec true visited env p) ty end -let local_non_recursive_abbrev env p ty = - let allow_rec = allow_recursive_equations () in +let local_non_recursive_abbrev uenv p ty = + let env = get_env uenv in + let allow_rec = allow_recursive_equations uenv 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; @@ -1916,14 +1955,12 @@ let local_non_recursive_abbrev env p ty = (* 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',_) -> eq_type t t') cl in - Some r - with Not_found -> None + List.find_map (fun (t', r) -> + if eq_type t t' then Some r else None + ) cl in begin match find_univ t1 cl1, find_univ t2 cl2 with Some {contents=Some t'2}, Some _ when eq_type t2 t'2 -> @@ -2171,28 +2208,26 @@ let deep_occur t0 ty = 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 +(* 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 + They need to be removed using this function. + This function is called only in [Pattern] mode. *) +let reify uenv t = + let fresh_constr_scope = get_equations_scope uenv in let create_fresh_constr lev name = let name = match name with Some s -> "$'"^s | _ -> "$" in - let decl = new_local_type () in + let decl = new_local_type Definition in + let env = get_env uenv in + let new_name = + (* unique names are needed only for error messages *) + if in_counterexample uenv then name else get_new_abstract_name env name + in let (id, new_env) = - Env.enter_type (get_new_abstract_name !env name) decl !env - ~scope:fresh_constr_scope in + Env.enter_type new_name decl env ~scope:fresh_constr_scope in let path = Path.Pident id in - let t = newty2 ~level:lev (Tconstr (path,[],ref Mnil)) in - env := new_env; + let t = newty2 ~level:lev (Tconstr (path,[],ref Mnil)) in + set_env uenv new_env; path, t in let visited = ref TypeSet.empty in @@ -2242,7 +2277,7 @@ let non_aliasable p decl = let is_instantiable env p = try let decl = Env.find_type p env in - decl.type_kind = Type_abstract && + type_kind_is_abstract decl && decl.type_private = Public && decl.type_arity = 0 && decl.type_manifest = None && @@ -2425,9 +2460,9 @@ and mcomp_type_decl type_pairs env p1 p2 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') -> () + | 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 -> () @@ -2491,30 +2526,32 @@ let find_lowest_level ty = end in find ty; unmark_type ty; !lowest -let add_gadt_equation env source destination = +(* This function can be called only in [Pattern] mode. *) +let add_gadt_equation uenv 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 env = get_env uenv in + if has_free_univars env destination then + occur_univar ~inj_only:true env destination + else if local_non_recursive_abbrev uenv source destination then begin let destination = duplicate_type destination in let expansion_scope = - Int.max (Path.scope source) (get_gadt_equations_level ()) + Int.max (Path.scope source) (get_equations_scope uenv) + in + let type_origin = + match Env.find_type source env with + | decl -> type_origin decl + | exception Not_found -> assert false in let decl = - new_local_type ~manifest_and_scope:(destination, expansion_scope) () in - env := Env.add_local_type source decl !env; + new_local_type + ~manifest_and_scope:(destination, expansion_scope) + type_origin + in + set_env uenv (Env.add_local_constraint source decl env); cleanup_abbrev () end -let unify_eq_set = TypePairs.create 11 - -let order_type_pair t1 t2 = - if get_id t1 <= get_id t2 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) @@ -2563,7 +2600,7 @@ let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = | (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_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 @@ -2573,7 +2610,7 @@ let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = else raise Exit end - | (_, {type_arity = 0; type_kind = Type_abstract; + | (_, {type_arity = 0; type_kind = Type_abstract _; type_private = Public; type_manifest = None}) when allow_absent -> complete nl fl2 @@ -2596,16 +2633,15 @@ let unify_package env unify_list lv1 p1 fl1 lv2 p2 fl2 = (* force unification in Reither when one side has a non-conjunctive type *) +(* Code smell: this could also be put in unification_environment. + Only modified by expand_head_rigid, but the corresponding unification + environment is built in subst. *) let rigid_variants = ref false -let unify_eq t1 t2 = - eq_type t1 t2 - || (in_pattern_mode () - && TypePairs.mem unify_eq_set (order_type_pair t1 t2)) - -let unify1_var env t1 t2 = +let unify1_var uenv t1 t2 = assert (is_Tvar t1); - occur_for Unify env t1 t2; + occur_for Unify uenv t1 t2; + let env = get_env uenv in match occur_univar_for Unify env t2 with | () -> begin @@ -2617,20 +2653,20 @@ let unify1_var env t1 t2 = end; link_type t1 t2; true - | exception Unify_trace _ when in_pattern_mode () -> + | exception Unify_trace _ when in_pattern_mode uenv -> false (* Called from unify3 *) -let unify3_var env t1' t2 t2' = - occur_for Unify !env t1' t2; - match occur_univar_for Unify !env t2 with +let unify3_var uenv t1' t2 t2' = + occur_for Unify uenv t1' t2; + match occur_univar_for Unify (get_env uenv) t2 with | () -> link_type t1' t2 - | exception Unify_trace _ when in_pattern_mode () -> - reify env t1'; - reify env t2'; - if can_generate_equations () then begin - occur_univar ~inj_only:true !env t2'; - record_equation t1' t2'; + | exception Unify_trace _ when in_pattern_mode uenv -> + reify uenv t1'; + reify uenv t2'; + if can_generate_equations uenv then begin + occur_univar ~inj_only:true (get_env uenv) t2'; + record_equation uenv t1' t2'; end (* @@ -2657,82 +2693,84 @@ let unify3_var env t1' t2 t2' = information is indeed lost, but it probably does not worth it. *) -let rec unify (env:Env.t ref) t1 t2 = +let rec unify uenv t1 t2 = (* First step: special cases (optimizations) *) - if unify_eq t1 t2 then () else - let reset_tracing = check_trace_gadt_instances !env in + if unify_eq uenv t1 t2 then () else + let reset_tracing = check_trace_gadt_instances (get_env uenv) in try type_changed := true; begin match (get_desc t1, get_desc t2) with (Tvar _, Tconstr _) when deep_occur t1 t2 -> - unify2 env t1 t2 + unify2 uenv t1 t2 | (Tconstr _, Tvar _) when deep_occur t2 t1 -> - unify2 env t1 t2 + unify2 uenv t1 t2 | (Tvar _, _) -> - if unify1_var !env t1 t2 then () else unify2 env t1 t2 + if unify1_var uenv t1 t2 then () else unify2 uenv t1 t2 | (_, Tvar _) -> - if unify1_var !env t2 t1 then () else unify2 env t1 t2 + if unify1_var uenv t2 t1 then () else unify2 uenv t1 t2 | (Tunivar _, Tunivar _) -> unify_univar_for Unify t1 t2 !univar_pairs; - update_level_for Unify !env (get_level t1) t2; + update_level_for Unify (get_env uenv) (get_level t1) t2; update_scope_for Unify (get_scope t1) t2; link_type t1 t2 | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) - when Path.same p1 p2 (* && actual_mode !env = Old *) + when Path.same p1 p2 (* 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 (get_level t1) t2; + update_level_for Unify (get_env uenv) (get_level t1) t2; update_scope_for Unify (get_scope t1) t2; link_type t1 t2 - | (Tconstr _, Tconstr _) when Env.has_local_constraints !env -> - unify2_rec env t1 t1 t2 t2 + | (Tconstr _, Tconstr _) when Env.has_local_constraints (get_env uenv) -> + unify2_rec uenv t1 t1 t2 t2 | _ -> - unify2 env t1 t2 + unify2 uenv t1 t2 end; reset_trace_gadt_instances reset_tracing; with Unify_trace trace -> reset_trace_gadt_instances reset_tracing; raise_trace_for Unify (Diff {got = t1; expected = t2} :: trace) -and unify2 env t1 t2 = unify2_expand env t1 t1 t2 t2 +and unify2 uenv t1 t2 = unify2_expand uenv t1 t1 t2 t2 -and unify2_rec env t10 t1 t20 t2 = - if unify_eq t1 t2 then () else +and unify2_rec uenv t10 t1 t20 t2 = + if unify_eq uenv t1 t2 then () else try match (get_desc t1, get_desc t2) with | (Tconstr (p1, tl1, a1), Tconstr (p2, tl2, a2)) -> if Path.same p1 p2 && tl1 = [] && tl2 = [] && not (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) then begin - update_level_for Unify !env (get_level t1) t2; + update_level_for Unify (get_env uenv) (get_level t1) t2; update_scope_for Unify (get_scope t1) t2; link_type t1 t2 end else - if find_expansion_scope !env p1 > find_expansion_scope !env p2 - then unify2_rec env t10 t1 t20 (try_expand_safe !env t2) - else unify2_rec env t10 (try_expand_safe !env t1) t20 t2 + let env = get_env uenv in + if find_expansion_scope env p1 > find_expansion_scope env p2 + then unify2_rec uenv t10 t1 t20 (try_expand_safe env t2) + else unify2_rec uenv t10 (try_expand_safe env t1) t20 t2 | _ -> raise Cannot_expand with Cannot_expand -> - unify2_expand env t10 t1 t20 t2 + unify2_expand uenv t10 t1 t20 t2 -and unify2_expand env t1 t1' t2 t2' = +and unify2_expand uenv t1 t1' t2 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 env = get_env uenv in + 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 (get_level t1') (get_level t2') in let scope = Int.max (get_scope t1') (get_scope t2') in - update_level_for Unify !env lv t2; - update_level_for Unify !env lv t1; + 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 + if unify_eq uenv t1' t2' then () else let t1, t2 = if !Clflags.principal @@ -2743,13 +2781,13 @@ and unify2_expand env t1 t1' t2 t2' = (match get_desc t2 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' + if unify_eq uenv t1 t1' || not (unify_eq uenv t2 t2') then + unify3 uenv t1 t1' t2 t2' else - try unify3 env t2 t2' t1 t1' with Unify_trace trace -> + try unify3 uenv t2 t2' t1 t1' with Unify_trace trace -> raise_trace_for Unify (swap_trace trace) -and unify3 env t1 t1' t2 t2' = +and unify3 uenv t1 t1' t2 t2' = (* Third step: truly unification *) (* Assumes either [t1 == t1'] or [t2 != t2'] *) let tt1' = Transient_expr.repr t1' in @@ -2762,24 +2800,24 @@ and unify3 env t1 t1' t2 t2' = unify_univar_for Unify t1' t2' !univar_pairs; link_type t1' t2' | (Tvar _, _) -> - unify3_var env t1' t2 t2' + unify3_var uenv t1' t2 t2' | (_, Tvar _) -> - unify3_var env t2' t1 t1' + unify3_var uenv t2' t1 t1' | (Tfield _, Tfield _) -> (* special case for GADTs *) - unify_fields env t1' t2' + unify_fields uenv t1' t2' | _ -> - if in_pattern_mode () then - add_type_equality t1' t2' + if in_pattern_mode uenv then + add_type_equality uenv t1' t2' else begin - occur_for Unify !env t1' t2; + occur_for Unify uenv t1' t2; link_type t1' t2 end; try begin match (d1, d2) with (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 || - (!Clflags.classic || in_pattern_mode ()) && + (!Clflags.classic || in_pattern_mode uenv) && not (is_optional l1 || is_optional l2) -> - unify env t1 t2; unify env u1 u2; + unify uenv t1 t2; unify uenv u1 u2; begin match is_commu_ok c1, is_commu_ok c2 with | false, true -> set_commu_ok c1 | true, false -> set_commu_ok c2 @@ -2787,64 +2825,67 @@ and unify3 env t1 t1' t2 t2' = | true, true -> () end | (Ttuple tl1, Ttuple tl2) -> - unify_list env tl1 tl2 + unify_list uenv tl1 tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> - if not (can_generate_equations ()) then - unify_list env tl1 tl2 - else if can_assume_injective () then - without_assume_injective (fun () -> unify_list env tl1 tl2) + if not (can_generate_equations uenv) then + unify_list uenv tl1 tl2 + else if can_assume_injective uenv then + without_assume_injective uenv (fun uenv -> unify_list uenv tl1 tl2) else if in_current_module p1 (* || in_pervasives p1 *) - || List.exists (expands_to_datatype !env) [t1'; t1; t2] + || List.exists (expands_to_datatype (get_env uenv)) [t1'; t1; t2] then - unify_list env tl1 tl2 + unify_list uenv tl1 tl2 else let inj = try List.map Variance.(mem Inj) - (Env.find_type p1 !env).type_variance + (Env.find_type p1 (get_env uenv)).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 - without_generating_equations - begin fun () -> + if i then unify uenv t1 t2 else + without_generating_equations uenv + begin fun uenv -> let snap = snapshot () in - try unify env t1 t2 with Unify_trace _ -> + try unify uenv t1 t2 with Unify_trace _ -> backtrack snap; - reify env t1; - reify env t2 + reify uenv t1; + reify uenv t2 end) inj (List.combine tl1 tl2) | (Tconstr (path,[],_), Tconstr (path',[],_)) - when is_instantiable !env path && is_instantiable !env path' - && can_generate_equations () -> + when let env = get_env uenv in + is_instantiable env path && is_instantiable env path' + && can_generate_equations uenv -> 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 + record_equation uenv t1' t2'; + add_gadt_equation uenv 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' + when is_instantiable (get_env uenv) path + && can_generate_equations uenv -> + reify uenv t2'; + record_equation uenv t1' t2'; + add_gadt_equation uenv 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 in_pattern_mode () -> - reify env t1'; - reify env t2'; - if can_generate_equations () then ( - mcomp_for Unify !env t1' t2'; - record_equation t1' t2' + when is_instantiable (get_env uenv) path + && can_generate_equations uenv -> + reify uenv t1'; + record_equation uenv t1' t2'; + add_gadt_equation uenv path t1' + | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when in_pattern_mode uenv -> + reify uenv t1'; + reify uenv t2'; + if can_generate_equations uenv then ( + mcomp_for Unify (get_env uenv) t1' t2'; + record_equation uenv t1' t2' ) | (Tobject (fi1, nm1), Tobject (fi2, _)) -> - unify_fields env fi1 fi2; + unify_fields uenv fi1 fi2; (* Type [t2'] may have been instantiated by [unify_fields] *) (* XXX One should do some kind of unification... *) begin match get_desc t2' with @@ -2855,26 +2896,26 @@ and unify3 env t1 t1' t2 t2' = | _ -> () end | (Tvariant row1, Tvariant row2) -> - if not (in_pattern_mode ()) then - unify_row env row1 row2 + if not (in_pattern_mode uenv) then + unify_row uenv row1 row2 else begin let snap = snapshot () in - try unify_row env row1 row2 + try unify_row uenv row1 row2 with Unify_trace _ -> backtrack snap; - reify env t1'; - reify env t2'; - if can_generate_equations () then ( - mcomp_for Unify !env t1' t2'; - record_equation t1' t2' + reify uenv t1'; + reify uenv t2'; + if can_generate_equations uenv then ( + mcomp_for Unify (get_env uenv) t1' t2'; + record_equation uenv t1' t2' ) end | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) -> begin match field_kind_repr kind with Fprivate when f <> dummy_method -> link_kind ~inside:kind field_absent; - if d2 = Tnil then unify env rem t2' - else unify env (newgenty Tnil) rem + if d2 = Tnil then unify uenv rem t2' + else unify uenv (newgenty Tnil) rem | _ -> if f = dummy_method then raise_for Unify (Obj Self_cannot_be_closed) @@ -2886,16 +2927,17 @@ and unify3 env t1 t1' t2 t2' = | (Tnil, Tnil) -> () | (Tpoly (t1, []), Tpoly (t2, [])) -> - unify env t1 t2 + unify uenv t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly_for Unify !env univar_pairs t1 tl1 t2 tl2 (unify env) + enter_poly_for Unify (get_env uenv) univar_pairs t1 tl1 t2 tl2 + (unify uenv) | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> begin try - unify_package !env (unify_list env) + unify_package (get_env uenv) (unify_list uenv) (get_level t1) p1 fl1 (get_level t2) p2 fl2 with Not_found -> - if not (in_pattern_mode ()) then raise_unexplained_for Unify; - List.iter (fun (_n, ty) -> reify env ty) (fl1 @ fl2); + if not (in_pattern_mode uenv) then raise_unexplained_for Unify; + List.iter (fun (_n, ty) -> reify uenv ty) (fl1 @ fl2); (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) end | (Tnil, Tconstr _ ) -> @@ -2910,7 +2952,7 @@ and unify3 env t1 t1' t2 t2' = match get_desc t2 with Tconstr (p, tl, abbrev) -> forget_abbrev abbrev p; - let t2'' = expand_head_unif !env t2 in + let t2'' = expand_head_unif (get_env uenv) t2 in if not (closed_parameterized_type tl t2'') then link_type t2 t2' | _ -> @@ -2945,7 +2987,7 @@ and make_rowvar level use1 rest1 use2 rest2 = if use1 then rest1 else if use2 then rest2 else newty2 ~level (Tvar name) -and unify_fields env ty1 ty2 = (* Optimization *) +and unify_fields uenv 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 @@ -2954,18 +2996,18 @@ and unify_fields env ty1 ty2 = (* Optimization *) let tr1 = Transient_expr.repr rest1 and tr2 = Transient_expr.repr rest2 in let d1 = tr1.desc and d2 = tr2.desc in try - unify env (build_fields l1 miss1 va) rest2; - unify env rest1 (build_fields l2 miss2 va); + unify uenv (build_fields l1 miss1 va) rest2; + unify uenv rest1 (build_fields l2 miss2 va); List.iter (fun (name, k1, t1, k2, t2) -> unify_kind k1 k2; try - if !trace_gadt_instances && not (in_subst_mode ()) then begin + if !trace_gadt_instances && not (in_subst_mode uenv) then begin (* in_subst_mode: see PR#11771 *) - update_level_for Unify !env (get_level va) t1; + update_level_for Unify (get_env uenv) (get_level va) t1; update_scope_for Unify (get_scope va) t1 end; - unify env t1 t2 + unify uenv t1 t2 with Unify_trace trace -> raise_trace_for Unify (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) @@ -2983,12 +3025,12 @@ and unify_kind k1 k2 = | (Fpublic, Fpublic) -> () | _ -> assert false -and unify_row env row1 row2 = +and unify_row uenv row1 row2 = let Row {fields = row1_fields; more = rm1; closed = row1_closed; name = row1_name} = row_repr row1 in let Row {fields = row2_fields; more = rm2; closed = row2_closed; name = row2_name} = row_repr row2 in - if unify_eq rm1 rm2 then () else + if unify_eq uenv rm1 rm2 then () else let r1, r2, pairs = merge_row_fields row1_fields row2_fields in if r1 <> [] && r2 <> [] then begin let ht = Hashtbl.create (List.length r1) in @@ -3053,18 +3095,19 @@ and unify_row env row1 row2 = (* 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 && not (in_subst_mode ()) then + if !trace_gadt_instances && not (in_subst_mode uenv) then (* in_subst_mode: see PR#11771 *) - update_level_for Unify !env (get_level rm) (newgenty (Tvariant row)); + update_level_for Unify (get_env uenv) (get_level rm) + (newgenty (Tvariant row)); if has_fixed_explanation row then if eq_type more rm then () else - if is_Tvar rm then link_type rm more else unify env rm more + if is_Tvar rm then link_type rm more else unify uenv rm more else let ty = newgenty (Tvariant (create_row ~fields:rest ~more ~closed ~fixed ~name)) in - update_level_for Unify !env (get_level rm) ty; + update_level_for Unify (get_env uenv) (get_level rm) ty; update_scope_for Unify (get_scope rm) ty; link_type rm ty in @@ -3075,7 +3118,7 @@ and unify_row env row1 row2 = set_more First row1 r2; List.iter (fun (l,f1,f2) -> - try unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 + try unify_row_field uenv fixed1 fixed2 rm1 rm2 l f1 f2 with Unify_trace trace -> raise_trace_for Unify (Variant (Incompatible_types_for l) :: trace) ) @@ -3090,7 +3133,7 @@ and unify_row env row1 row2 = raise exn end -and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = +and unify_row_field uenv fixed1 fixed2 rm1 rm2 l f1 f2 = let if_not_fixed (pos,fixed) f = match fixed with | None -> f () @@ -3103,7 +3146,7 @@ and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = | _ -> true in if f1 == f2 then () else match row_field_repr f1, row_field_repr f2 with - Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 + Rpresent(Some t1), Rpresent(Some t2) -> unify uenv t1 t2 | Rpresent None, Rpresent None -> () | Reither(c1, tl1, m1), Reither(c2, tl2, m2) -> if eq_row_field_ext f1 f2 then () else @@ -3113,7 +3156,7 @@ and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = (* PR#7496 *) let f = rf_either [] ~no_arg ~matched in link_row_field_ext ~inside:f1 f; link_row_field_ext ~inside:f2 f; - List.iter2 (unify env) tl1 tl2 + List.iter2 (unify uenv) tl1 tl2 end else let redo = (m1 || m2 || either_fixed || @@ -3122,29 +3165,31 @@ and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = | t1 :: tl -> if no_arg then raise_unexplained_for Unify; Types.changed_row_field_exts [f1;f2] (fun () -> - List.iter (unify env t1) tl + List.iter (unify uenv t1) tl ) end in - if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else + if redo then unify_row_field uenv fixed1 fixed2 rm1 rm2 l f1 f2 else let remq tl = List.filter (fun ty -> not (List.exists (eq_type ty) 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 + let env = get_env uenv in + 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) + List.iter (unify uenv tu1) (tlu1@tlu2) | (tu::_, []) | ([], tu::_) -> - occur_univar_for Unify !env tu + occur_univar_for Unify env tu end; (* Is this handling of levels really principal? *) let update_levels rm = + let env = get_env uenv in List.iter (fun ty -> - update_level_for Unify !env (get_level rm) ty; + update_level_for Unify env (get_level rm) ty; update_scope_for Unify (get_scope rm) ty) in update_levels rm2 tl1'; @@ -3161,60 +3206,71 @@ and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = if_not_fixed first (fun () -> let s = snapshot () in link_row_field_ext ~inside:f1 f2; - update_level_for Unify !env (get_level rm1) t2; + update_level_for Unify (get_env uenv) (get_level rm1) t2; update_scope_for Unify (get_scope rm1) t2; - (try List.iter (fun t1 -> unify env t1 t2) tl + (try List.iter (fun t1 -> unify uenv t1 t2) tl with exn -> undo_first_change_after s; raise exn) ) | Rpresent(Some t1), Reither(false, tl, _) -> if_not_fixed second (fun () -> let s = snapshot () in link_row_field_ext ~inside:f2 f1; - update_level_for Unify !env (get_level rm2) t1; + update_level_for Unify (get_env uenv) (get_level rm2) t1; update_scope_for Unify (get_scope rm2) t1; - (try List.iter (unify env t1) tl + (try List.iter (unify uenv t1) tl with exn -> undo_first_change_after s; raise exn) ) | Reither(true, [], _), Rpresent None -> if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) | Rpresent None, Reither(true, [], _) -> if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) - | _ -> raise_unexplained_for Unify - -let unify env ty1 ty2 = + | Rabsent, (Rpresent _ | Reither(_,_,true)) -> + raise_trace_for Unify [Variant(No_tags(First, [l,f1]))] + | (Rpresent _ | Reither (_,_,true)), Rabsent -> + raise_trace_for Unify [Variant(No_tags(Second, [l,f2]))] + | (Rpresent (Some _) | Reither(false,_,_)), + (Rpresent None | Reither(true,_,_)) + | (Rpresent None | Reither(true,_,_)), + (Rpresent (Some _) | Reither(false,_,_)) -> + (* constructor arity mismatch: 0 <> 1 *) + raise_unexplained_for Unify + | Reither(true, _ :: _, _ ), Rpresent _ + | Rpresent _ , Reither(true, _ :: _, _ ) -> + (* inconsistent conjunction on a non-absent field *) + raise_unexplained_for Unify + +let unify uenv ty1 ty2 = let snap = Btype.snapshot () in try - unify env ty1 ty2 + unify uenv ty1 ty2 with Unify_trace trace -> undo_compress snap; - raise (Unify (expand_to_unification_error !env trace)) + raise (Unify (expand_to_unification_error (get_env uenv) trace)) -let unify_gadt ~equations_level:lev ~allow_recursive_equations - (env:Env.t ref) ty1 ty2 = - try - univar_pairs := []; - gadt_equations_level := Some lev; - let equated_types = TypePairs.create 0 in - set_mode_pattern ~allow_recursive_equations ~equated_types - (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 unify_gadt (penv : Pattern_env.t) ty1 ty2 = + univar_pairs := []; + let equated_types = TypePairs.create 0 in + let equations_generation = Allowed { equated_types } in + let uenv = Pattern + { penv; + equations_generation; + assume_injective = true; + unify_eq_set = TypePairs.create 11; } + in + unify uenv ty1 ty2; + equated_types + +let unify_var uenv t1 t2 = if eq_type t1 t2 then () else match get_desc t1, get_desc t2 with Tvar _, Tconstr _ when deep_occur t1 t2 -> - unify (ref env) t1 t2 + unify uenv t1 t2 | Tvar _, _ -> + let env = get_env uenv in let reset_tracing = check_trace_gadt_instances env in begin try - occur_for Unify env t1 t2; + occur_for Unify uenv t1 t2; update_level_for Unify env (get_level t1) t2; update_scope_for Unify (get_scope t1) t2; link_type t1 t2; @@ -3226,16 +3282,20 @@ let unify_var env t1 t2 = (Diff { got = t1; expected = t2 } :: trace))) end | _ -> - unify (ref env) t1 t2 + unify uenv t1 t2 let _ = unify_var' := unify_var +(* the final versions of unification functions *) +let unify_var env ty1 ty2 = + unify_var (Expression {env; in_subst = false}) ty1 ty2 + let unify_pairs env ty1 ty2 pairs = univar_pairs := pairs; - unify env ty1 ty2 + unify (Expression {env; in_subst = false}) ty1 ty2 let unify env ty1 ty2 = - unify_pairs (ref env) ty1 ty2 [] + unify_pairs env ty1 ty2 [] (* Lower the level of a type to the current level *) let enforce_current_level env ty = unify_var env (newvar ()) ty @@ -3696,7 +3756,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = (Tvar _, _) when may_instantiate inst_nongen t1 -> moregen_occur env (get_level t1) t2; update_scope_for Moregen (get_scope t1) t2; - occur_for Moregen env t1 t2; + occur_for Moregen (Expression {env; in_subst = false}) t1 t2; link_type t1 t2 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () @@ -4265,9 +4325,9 @@ let rec equal_private env params1 ty1 params2 ty2 = type class_match_failure = CM_Virtual_class | CM_Parameter_arity_mismatch of int * int - | CM_Type_parameter_mismatch of Env.t * equality_error + | CM_Type_parameter_mismatch of int * Env.t * equality_error | CM_Class_type_mismatch of Env.t * class_type * class_type - | CM_Parameter_mismatch of Env.t * moregen_error + | CM_Parameter_mismatch of int * Env.t * moregen_error | CM_Val_type_mismatch of string * Env.t * comparison_error | CM_Meth_type_mismatch of string * Env.t * comparison_error | CM_Non_mutable_value of string @@ -4335,20 +4395,24 @@ let match_class_sig_shape ~strict sign1 sign2 = else err) sign1.csig_vars errors -let rec moregen_clty trace type_pairs env cty1 cty2 = +(* [arrow_index] is the number of [Cty_arrow] + constructors we've seen so far. *) +let rec moregen_clty ~arrow_index trace type_pairs env cty1 cty2 = try match cty1, cty2 with | Cty_constr (_, _, cty1), _ -> - moregen_clty true type_pairs env cty1 cty2 + moregen_clty ~arrow_index true type_pairs env cty1 cty2 | _, Cty_constr (_, _, cty2) -> - moregen_clty true type_pairs env cty1 cty2 + moregen_clty ~arrow_index true type_pairs env cty1 cty2 | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 -> + let arrow_index = arrow_index + 1 in begin try moregen true type_pairs env ty1 ty2 with Moregen_trace trace -> raise (Failure [ - CM_Parameter_mismatch (env, expand_to_moregen_error env trace)]) + CM_Parameter_mismatch + (arrow_index, env, expand_to_moregen_error env trace)]) end; - moregen_clty false type_pairs env cty1' cty2' + moregen_clty ~arrow_index false type_pairs env cty1' cty2' | Cty_signature sign1, Cty_signature sign2 -> Meths.iter (fun lab (_, _, ty) -> @@ -4392,6 +4456,9 @@ let rec moregen_clty trace type_pairs env cty1 cty2 = Failure error when trace || error = [] -> raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) +let moregen_clty trace type_pairs env cty1 cty2 = + moregen_clty ~arrow_index:0 trace type_pairs env cty1 cty2 + let match_class_types ?(trace=true) env pat_sch subj_sch = let sign1 = signature_of_class_type pat_sch in let sign2 = signature_of_class_type subj_sch in @@ -4506,11 +4573,11 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = let ls = List.length subj_params in if lp <> ls then raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]); - List.iter2 (fun p s -> + Std.List.iteri2 ~f:(fun n p s -> try eqtype true type_pairs subst env p s with Equality_trace trace -> raise (Failure [CM_Type_parameter_mismatch - (env, expand_to_equality_error env trace !subst)])) + (n+1, env, expand_to_equality_error env trace !subst)])) 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; @@ -4857,7 +4924,7 @@ let rec subtype_rec env trace t1 t2 cstrs = | (Tpoly (u1, []), Tpoly (u2, [])) -> subtype_rec env trace u1 u2 cstrs | (Tpoly (u1, tl1), Tpoly (u2, [])) -> - let _, u1' = instance_poly false tl1 u1 in + let _, u1' = instance_poly ~fixed:false tl1 u1 in subtype_rec env trace u1' u2 cstrs | (Tpoly (u1, tl1), Tpoly (u2,tl2)) -> begin try @@ -5017,7 +5084,7 @@ let subtype env ty1 ty2 = function () -> List.iter (function (trace0, t1, t2, pairs) -> - try unify_pairs (ref env) t1 t2 pairs with Unify {trace} -> + try unify_pairs env t1 t2 pairs with Unify {trace} -> subtype_error ~env ~trace:trace0 ~unification_trace:(List.tl trace)) (List.rev cstrs) @@ -5350,7 +5417,7 @@ let nondep_type_decl env mid is_covariant decl = 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 + with Nondep_cannot_erase _ when is_covariant -> Type_abstract Definition and tm, priv = match decl.type_manifest with | None -> None, decl.type_private diff --git a/src/ocaml/typing/ctype.mli b/src/ocaml/typing/ctype.mli index be4fddbe5b..c6759b06c4 100644 --- a/src/ocaml/typing/ctype.mli +++ b/src/ocaml/typing/ctype.mli @@ -178,12 +178,25 @@ 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 + ?manifest_and_scope:(type_expr * int) -> + type_origin -> type_declaration + +module Pattern_env : sig + type t = private + { mutable env : Env.t; + equations_scope : int; + (* scope for local type declarations *) + allow_recursive_equations : bool; + (* true iff checking counter examples *) + } + val make: Env.t -> equations_scope:int -> allow_recursive_equations:bool -> t + val copy: ?equations_scope:int -> t -> t + val set_env: t -> Env.t -> unit +end type existential_treatment = | Keep_existentials_flexible - | Make_existentials_abstract of { env: Env.t ref; scope: int } + | Make_existentials_abstract of Pattern_env.t val instance_constructor: existential_treatment -> constructor_description -> type_expr list * type_expr * type_expr list @@ -198,12 +211,13 @@ 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 + ?keep_names:bool -> fixed: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 + fixed:bool -> + label_description -> type_expr list * type_expr * type_expr (* Same, for a label *) val apply: ?use_current_level:bool -> @@ -255,8 +269,7 @@ val extract_concrete_typedecl: 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_equations:bool -> - Env.t ref -> type_expr -> type_expr -> Btype.TypePairs.t + Pattern_env.t -> type_expr -> type_expr -> Btype.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. *) @@ -312,9 +325,9 @@ exception Filter_method_failed of filter_method_failure type class_match_failure = CM_Virtual_class | CM_Parameter_arity_mismatch of int * int - | CM_Type_parameter_mismatch of Env.t * Errortrace.equality_error + | CM_Type_parameter_mismatch of int * Env.t * Errortrace.equality_error | CM_Class_type_mismatch of Env.t * class_type * class_type - | CM_Parameter_mismatch of Env.t * Errortrace.moregen_error + | CM_Parameter_mismatch of int * Env.t * Errortrace.moregen_error | CM_Val_type_mismatch of string * Env.t * Errortrace.comparison_error | CM_Meth_type_mismatch of string * Env.t * Errortrace.comparison_error | CM_Non_mutable_value of string diff --git a/src/ocaml/typing/datarepr.ml b/src/ocaml/typing/datarepr.ml index 004859ee34..9213fe8337 100644 --- a/src/ocaml/typing/datarepr.ml +++ b/src/ocaml/typing/datarepr.ml @@ -228,11 +228,11 @@ 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 -> [] + | 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 -> [] + | Type_variant _ | Type_abstract _ | Type_open -> [] diff --git a/src/ocaml/typing/dune b/src/ocaml/typing/dune index 132d16157e..b59003ad8a 100644 --- a/src/ocaml/typing/dune +++ b/src/ocaml/typing/dune @@ -6,5 +6,5 @@ -open Ocaml_parsing -open Merlin_utils (:standard -w -9)) - (modules_without_implementation annot outcometree) + (modules_without_implementation annot outcometree value_rec_types) (libraries merlin_utils ocaml_compression ocaml_parsing ocaml_utils)) diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml index 986b46d8d7..4beeb037d1 100644 --- a/src/ocaml/typing/env.ml +++ b/src/ocaml/typing/env.ml @@ -40,13 +40,6 @@ 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 -let uid_to_loc : Location.t Types.Uid.Tbl.t ref = - s_table Types.Uid.Tbl.create 16 - -let register_uid uid loc = Types.Uid.Tbl.add !uid_to_loc uid loc - -let get_uid_to_loc_tbl () = !uid_to_loc - type constructor_usage = Positive | Pattern | Exported_private | Exported type constructor_usages = { @@ -709,6 +702,11 @@ let error err = raise (Error err) let lookup_error loc env err = error (Lookup_error(loc, env, err)) +let same_type_declarations e1 e2 = + e1.types == e2.types && + e1.modules == e2.modules && + e1.local_constraints == e2.local_constraints + let same_constr = ref (fun _ _ _ -> assert false) let check_well_formed_module = ref (fun _ -> assert false) @@ -729,9 +727,12 @@ let check_shadowing env = function | `Label (Some (l1, l2)) when not (!same_constr env l1.lbl_res l2.lbl_res) -> Some "label" - | `Value (Some _) -> Some "value" + | `Value (Some (Val_unbound _, _)) -> None + | `Value (Some (_, _)) -> Some "value" | `Type (Some _) -> Some "type" - | `Module (Some _) | `Component (Some _) -> Some "module" + | `Module (Some (Mod_unbound _, _)) -> None + | `Module (Some _) | `Component (Some _) -> + Some "module" | `Module_type (Some _) -> Some "module type" | `Class (Some _) -> Some "class" | `Class_type (Some _) -> Some "class type" @@ -985,9 +986,9 @@ 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 = +let read_pers_mod cmi = Persistent_env.read !persistent_env - read_sign_of_cmi short_paths_components modname filename + read_sign_of_cmi short_paths_components cmi let find_pers_mod name = Persistent_env.find !persistent_env @@ -1013,7 +1014,6 @@ let reset_declaration_caches () = Types.Uid.Tbl.clear !module_declarations; Types.Uid.Tbl.clear !used_constructors; Types.Uid.Tbl.clear !used_labels; - Types.Uid.Tbl.clear !uid_to_loc; () let reset_cache () = @@ -1080,7 +1080,7 @@ 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) + | Mod_persistent -> find_pers_mod ~allow_hidden:true (Ident.name id) let rec find_module_components path env = match path with @@ -1188,7 +1188,7 @@ let rec find_type_data path env = | decl -> { tda_declaration = decl; - tda_descriptions = Type_abstract; + tda_descriptions = Type_abstract (Btype.type_origin decl); tda_shape = Shape.leaf decl.type_uid; } | exception Not_found -> begin @@ -1213,7 +1213,7 @@ and find_cstr path name env = match tda.tda_descriptions with | Type_variant (cstrs, _) -> List.find (fun cstr -> cstr.cstr_name = name) cstrs - | Type_record _ | Type_abstract | Type_open -> raise Not_found + | Type_record _ | Type_abstract _ | Type_open -> raise Not_found @@ -1320,6 +1320,10 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id = match ns with | Type -> (IdTbl.find_same id env.types).tda_shape + | Constructor -> + Shape.leaf ((TycompTbl.find_same id env.constrs).cda_description.cstr_uid) + | Label -> + Shape.leaf ((TycompTbl.find_same id env.labels).lbl_uid) | Extension_constructor -> (TycompTbl.find_same id env.constrs).cda_shape | Value -> @@ -1440,7 +1444,7 @@ 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 + || not (Btype.type_kind_is_abstract decl) || Btype.has_constr_row body -> (decl.type_params, body, decl.type_expansion_scope) (* The manifest type of Private abstract data types without @@ -1860,7 +1864,7 @@ let rec components_of_module_maker add_to_tbl descr.lbl_name descr c.comp_labels) lbls; Type_record (lbls, repr) - | Type_abstract -> Type_abstract + | Type_abstract r -> Type_abstract r | Type_open -> Type_open in let shape = Shape.proj cm_shape (Shape.Item.type_ id) in @@ -2003,6 +2007,7 @@ and check_value_name name loc = and store_value ?check id addr decl shape env = check_value_name (Ident.name id) decl.val_loc; + Builtin_attributes.mark_alerts_used decl.val_attributes; Option.iter (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations) check; @@ -2041,6 +2046,8 @@ and store_constructor ~check type_decl type_id cstr_id cstr env = (constructor_usage_complaint ~rebind:false priv used)); end; end); + Builtin_attributes.mark_alerts_used cstr.cstr_attributes; + Builtin_attributes.mark_warn_on_literal_pattern_used cstr.cstr_attributes; let cda_shape = Shape.leaf cstr.cstr_uid in { env with constrs = @@ -2073,6 +2080,9 @@ and store_label ~check type_decl type_id lbl_id lbl env = loc (Warnings.Unused_field(name, complaint))) (label_usage_complaint priv mut used)) end); + Builtin_attributes.mark_alerts_used lbl.lbl_attributes; + if lbl.lbl_mut = Mutable then + Builtin_attributes.mark_deprecated_mutable_used lbl.lbl_attributes; { env with labels = TycompTbl.add lbl_id lbl env.labels; } @@ -2102,7 +2112,7 @@ and store_type ~check ~long_path ~predef id info shape env = (fun env (lbl_id, lbl) -> store_label ~check info id lbl_id lbl env) env labels - | Type_abstract -> Type_abstract, env + | Type_abstract r -> Type_abstract r, env | Type_open -> Type_open, env in let tda = @@ -2110,6 +2120,7 @@ and store_type ~check ~long_path ~predef id info shape env = tda_descriptions = descrs; tda_shape = shape } in + Builtin_attributes.mark_alerts_used info.type_attributes; { env with types = IdTbl.add id tda env.types; summary = Env_type(env.summary, id, info); @@ -2125,7 +2136,7 @@ and store_type_infos ~tda_shape id info env = let tda = { tda_declaration = info; - tda_descriptions = Type_abstract; + tda_descriptions = Type_abstract (Btype.type_origin info); tda_shape } in @@ -2145,6 +2156,8 @@ and store_extension ~check ~rebind id addr ext shape env = cda_address = Some addr; cda_shape = shape } in + Builtin_attributes.mark_alerts_used ext.ext_attributes; + Builtin_attributes.mark_warn_on_literal_pattern_used ext.ext_attributes; Builtin_attributes.warning_scope ext.ext_attributes (fun () -> if check && not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_extension ("", false, Unused)) @@ -2178,6 +2191,7 @@ and store_module ?(update_summary=true) ~check let loc = md.mdl_loc in Option.iter (fun f -> check_usage loc id md.mdl_uid f !module_declarations) check; + Builtin_attributes.mark_alerts_used md.mdl_attributes; let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in let comps = components_of_module ~alerts ~uid:md.mdl_uid @@ -2199,6 +2213,7 @@ and store_module ?(update_summary=true) ~check short_paths_module id md comps env.short_paths_additions; } and store_modtype ?(update_summary=true) id info shape env = + Builtin_attributes.mark_alerts_used info.Subst.Lazy.mtdl_attributes; let mtda = { mtda_declaration = info; mtda_shape = shape } in let summary = if not update_summary then env.summary @@ -2210,6 +2225,7 @@ and store_modtype ?(update_summary=true) id info shape env = short_paths_module_type id info env.short_paths_additions; } and store_class id addr desc shape env = + Builtin_attributes.mark_alerts_used desc.cty_attributes; let clda = { clda_declaration = desc; clda_address = addr; @@ -2220,6 +2236,7 @@ and store_class id addr desc shape env = summary = Env_class(env.summary, id, desc) } and store_cltype id desc shape env = + Builtin_attributes.mark_alerts_used desc.clty_attributes; let cltda = { cltda_declaration = desc; cltda_shape = shape } in { env with cltypes = IdTbl.add id cltda env.cltypes; @@ -2340,7 +2357,7 @@ let add_module_lazy ~update_summary id presence mty env = in add_module_declaration_lazy ~update_summary id presence md env -let add_local_type path info env = +let add_local_constraint path info env = { env with local_constraints = Path.Map.add path info env.local_constraints } @@ -2451,8 +2468,6 @@ let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env let add_value = add_value ?shape:None -let add_type = add_type ?shape:None -let add_extension = add_extension ?shape:None let add_class = add_class ?shape:None let add_cltype = add_cltype ?shape:None let add_modtype = add_modtype ?shape:None @@ -2646,29 +2661,19 @@ let open_signature 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 read_signature u = + let mda = read_pers_mod u in let md = Subst.Lazy.force_module_decl 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 + | ".cmi" -> + let modname = Unit_info.modname_from_source fn in + if Unit_info.is_unit_name modname then Some modname + else None | _ -> None let persistent_structures_of_dir dir = @@ -2678,27 +2683,28 @@ let persistent_structures_of_dir dir = |> String.Set.of_seq (* Save a signature to a file *) -let save_signature_with_transform cmi_transform ~alerts sg modname filename = +let save_signature_with_transform cmi_transform ~alerts sg cmi_info = 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 + Persistent_env.make_cmi !persistent_env + (Unit_info.Artifact.modname cmi_info) 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; + let filename = Unit_info.Artifact.filename cmi_info in + let pers_sig = + Persistent_env.Persistent_signature.{ cmi; filename; visibility = Visible } + in + let pm = save_sign_of_cmi pers_sig in + Persistent_env.save_cmi !persistent_env pers_sig pm; cmi -let save_signature ~alerts sg modname filename = - save_signature_with_transform (fun cmi -> cmi) - ~alerts sg modname filename +let save_signature ~alerts sg cmi = + save_signature_with_transform (fun cmi -> cmi) ~alerts sg cmi -let save_signature_with_imports ~alerts sg modname filename imports = +let save_signature_with_imports ~alerts sg cmi imports = let with_imports cmi = { cmi with cmi_crcs = imports } in - save_signature_with_transform with_imports - ~alerts sg modname filename + save_signature_with_transform with_imports ~alerts sg cmi (* Make the initial environment *) let initial = @@ -2707,11 +2713,11 @@ let initial = (add_extension ~check:false ~rebind:false) empty -let add_type_long_path ~check id info env = - add_type ~check ~predef:false ~long_path:true id info env +let add_type_long_path ~check ?shape id info env = + add_type ~check ?shape ~predef:false ~long_path:true id info env -let add_type ~check id info env = - add_type ~check ~predef:false ~long_path:false id info env +let add_type ~check ?shape id info env = + add_type ~check ?shape ~predef:false ~long_path:false id info env (* Tracking usage *) @@ -2916,10 +2922,10 @@ let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env = | Mod_persistent -> begin match load with | Don't_load -> - check_pers_mod ~loc s; + check_pers_mod ~allow_hidden:false ~loc s; path, (() : a) | Load -> begin - match find_pers_mod s with + match find_pers_mod ~allow_hidden:false s with | mda -> use_module ~use ~loc path mda; path, (mda : a) @@ -3258,7 +3264,7 @@ let lookup_label ~errors ~use ~loc usage lid env = 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_variant _ | Type_abstract _ | Type_open -> [] | Type_record (lbls, _) -> List.map (fun lbl -> @@ -3280,7 +3286,7 @@ let lookup_constructor ~errors ~use ~loc usage lid env = 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_record _ | Type_abstract _ | Type_open -> [] | Type_variant (cstrs, _) -> List.map (fun cstr -> @@ -3424,7 +3430,7 @@ let bound_module name env = | exception Not_found -> if Current_unit_name.is name then false else begin - match find_pers_mod name with + match find_pers_mod ~allow_hidden:false name with | _ -> true | exception Not_found -> false end @@ -3697,9 +3703,12 @@ let extract_instance_variables env = | Val_ivar _ -> name :: acc | _ -> acc) None env [] +module Style = Misc.Style + let report_lookup_error _loc env ppf = function | Unbound_value(lid, hint) -> begin - fprintf ppf "Unbound value %a" !print_longident lid; + fprintf ppf "Unbound value %a" + (Style.as_inline_code !print_longident) lid; spellcheck ppf extract_values env lid; match hint with | No_hint -> () @@ -3708,90 +3717,101 @@ let report_lookup_error _loc env ppf = function Location.get_pos_info def_loc.Location.loc_start in fprintf ppf - "@.@[@{Hint@}: If this is a recursive definition,@ %s %i@]" - "you should add the 'rec' keyword on line" + "@.@[@{Hint@}: If this is a recursive definition,@ \ + you should add the %a keyword on line %i@]" + Style.inline_code "rec" line end | Unbound_type lid -> - fprintf ppf "Unbound type constructor %a" !print_longident lid; + fprintf ppf "Unbound type constructor %a" + (Style.as_inline_code !print_longident) lid; spellcheck ppf extract_types env lid; | Unbound_module lid -> begin - fprintf ppf "Unbound module %a" !print_longident lid; + fprintf ppf "Unbound module %a" + (Style.as_inline_code !print_longident) lid; match find_modtype_by_name lid env with | exception Not_found -> spellcheck ppf extract_modules env lid; | _ -> fprintf ppf "@.@[@{Hint@}: There is a module type named %a, %s@]" - !print_longident lid + (Style.as_inline_code !print_longident) lid "but module types are not modules" end | Unbound_constructor lid -> - fprintf ppf "Unbound constructor %a" !print_longident lid; + fprintf ppf "Unbound constructor %a" + (Style.as_inline_code !print_longident) lid; spellcheck ppf extract_constructors env lid; | Unbound_label lid -> - fprintf ppf "Unbound record field %a" !print_longident lid; + fprintf ppf "Unbound record field %a" + (Style.as_inline_code !print_longident) lid; spellcheck ppf extract_labels env lid; | Unbound_class lid -> begin - fprintf ppf "Unbound class %a" !print_longident lid; + fprintf ppf "Unbound class %a" + (Style.as_inline_code !print_longident) lid; match find_cltype_by_name lid env with | exception Not_found -> spellcheck ppf extract_classes env lid; | _ -> fprintf ppf "@.@[@{Hint@}: There is a class type named %a, %s@]" - !print_longident lid + (Style.as_inline_code !print_longident) lid "but classes are not class types" end | Unbound_modtype lid -> begin - fprintf ppf "Unbound module type %a" !print_longident lid; + fprintf ppf "Unbound module type %a" + (Style.as_inline_code !print_longident) lid; match find_module_by_name lid env with | exception Not_found -> spellcheck ppf extract_modtypes env lid; | _ -> fprintf ppf "@.@[@{Hint@}: There is a module named %a, %s@]" - !print_longident lid + (Style.as_inline_code !print_longident) lid "but modules are not module types" end | Unbound_cltype lid -> - fprintf ppf "Unbound class type %a" !print_longident lid; + fprintf ppf "Unbound class type %a" + (Style.as_inline_code !print_longident) lid; spellcheck ppf extract_cltypes env lid; | Unbound_instance_variable s -> - fprintf ppf "Unbound instance variable %s" s; + fprintf ppf "Unbound instance variable %a" Style.inline_code 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; + fprintf ppf "The value %a is not an instance variable" + Style.inline_code 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 + (Style.as_inline_code !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 + (Style.as_inline_code !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 + (Style.as_inline_code !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 + (Style.as_inline_code !print_longident) lid | Abstract_used_as_functor lid -> fprintf ppf "@[The module %a is abstract, it cannot be applied@]" - !print_longident lid + (Style.as_inline_code !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 + it cannot have any components@]" + (Style.as_inline_code !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 + applied@ in@ type@ expressions@]" + (Style.as_inline_code !print_longident) lid | Cannot_scrape_alias(lid, p) -> let cause = if Current_unit_name.is_path p then "is the current compilation unit" @@ -3799,22 +3819,26 @@ let report_lookup_error _loc env ppf = function in fprintf ppf "The module %a is an alias for module %a, which %s" - !print_longident lid !print_path p cause + (Style.as_inline_code !print_longident) lid + (Style.as_inline_code !print_path) p cause let report_error ppf = function | Missing_module(_, path1, path2) -> fprintf ppf "@[@["; if Path.same path1 path2 then - fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1) + fprintf ppf "Internal path@ %a@ is dangling." + Style.inline_code (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)) + fprintf ppf "Internal path@ %a@ expands to@ %a@ which is dangling." + Style.inline_code (Path.name path1) + Style.inline_code (Path.name path2); + fprintf ppf "@]@ @[%s@ %a@ %s.@]@]" + "The compiled interface for module" + Style.inline_code (Ident.name (Path.head path2)) "was not found" | Illegal_value_name(_loc, name) -> - fprintf ppf "'%s' is not a valid value identifier." - name + fprintf ppf "%a is not a valid value identifier." + Style.inline_code name | Lookup_error(loc, t, err) -> report_lookup_error loc t ppf err let () = @@ -3841,7 +3865,7 @@ let () = let check_state_consistency () = let missing modname = - match Load_path.find_uncap (modname ^ ".cmi") with + match Load_path.find_normalized (modname ^ ".cmi") with | _ -> false | exception Not_found -> true and found _modname filename ps_name _md = @@ -3876,7 +3900,7 @@ let short_paths_type_desc decl = if ty.level <> Btype.generic_level then Fresh else begin match decl.type_private, decl.type_kind with - | Private, Type_abstract -> Fresh + | Private, Type_abstract _ -> Fresh | _, _ -> begin let params = List.map get_desc decl.type_params in match ty with diff --git a/src/ocaml/typing/env.mli b/src/ocaml/typing/env.mli index f8c95daae6..0a052fed3b 100644 --- a/src/ocaml/typing/env.mli +++ b/src/ocaml/typing/env.mli @@ -18,10 +18,6 @@ open Types open Misc -val register_uid : Uid.t -> Location.t -> unit - -val get_uid_to_loc_tbl : unit -> Location.t Types.Uid.Tbl.t - type value_unbound_reason = | Val_unbound_instance_variable | Val_unbound_self @@ -60,6 +56,9 @@ val empty: t val initial: t val diff: t -> t -> Ident.t list +(* approximation to the preimage equivalence class of [find_type] *) +val same_type_declarations: t -> t -> bool + type type_descr_kind = (label_description, constructor_description) type_kind @@ -297,10 +296,13 @@ val make_copy_of_types: t -> (t -> t) 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_type_long_path: check:bool -> Ident.t -> type_declaration -> t -> t +val add_type: + check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t +val add_type_long_path: + check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t val add_extension: - check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t + check:bool -> ?shape:Shape.t -> rebind:bool -> Ident.t -> + extension_constructor -> t -> t val add_module: ?arg:bool -> ?shape:Shape.t -> Ident.t -> module_presence -> module_type -> t -> t val add_module_lazy: update_summary:bool -> @@ -314,7 +316,7 @@ val add_modtype_lazy: update_summary:bool -> Ident.t -> Subst.Lazy.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 +val add_local_constraint: Path.t -> type_declaration -> t -> t (* Insertion of persistent signatures *) @@ -326,7 +328,7 @@ val add_local_type: Path.t -> type_declaration -> t -> t contents of the module is accessed. *) val add_persistent_structure : Ident.t -> t -> t -(* Returns the set of persistent structures found in the given + (* Returns the set of persistent structures found in the given directory. *) val persistent_structures_of_dir : Load_path.Dir.t -> Misc.String.Set.t @@ -399,14 +401,14 @@ 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 +val read_signature: Unit_info.Artifact.t -> signature (* Arguments: module name, file name. Results: signature. *) val save_signature: - alerts:alerts -> signature -> modname -> filepath + alerts:alerts -> Types.signature -> Unit_info.Artifact.t -> Cmi_format.cmi_infos (* Arguments: signature, module name, file name. *) val save_signature_with_imports: - alerts:alerts -> signature -> modname -> filepath -> crcs + alerts:alerts -> signature -> Unit_info.Artifact.t -> crcs -> Cmi_format.cmi_infos (* Arguments: signature, module name, file name, imported units with their CRCs. *) diff --git a/src/ocaml/typing/envaux.ml b/src/ocaml/typing/envaux.ml index a0bbbc2684..90e0da92c4 100644 --- a/src/ocaml/typing/envaux.ml +++ b/src/ocaml/typing/envaux.ml @@ -77,7 +77,7 @@ let rec env_from_summary sum subst = | Env_constraints(s, map) -> Path.Map.fold (fun path info -> - Env.add_local_type (Subst.type_path subst path) + Env.add_local_constraint (Subst.type_path subst path) (Subst.type_declaration subst info)) map (env_from_summary s subst) | Env_copy_types s -> @@ -102,10 +102,12 @@ let env_of_only_summary env = (* Error report *) open Format +module Style = Misc.Style let report_error ppf = function | Module_not_found p -> - fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p + fprintf ppf "@[Cannot find module %a@].@." + (Style.as_inline_code Printtyp.path) p let () = Location.register_error_of_exn diff --git a/src/ocaml/typing/includeclass.ml b/src/ocaml/typing/includeclass.ml index 3a2cd57694..39f00f9cf5 100644 --- a/src/ocaml/typing/includeclass.ml +++ b/src/ocaml/typing/includeclass.ml @@ -56,12 +56,13 @@ let include_err mode ppf = | CM_Parameter_arity_mismatch _ -> fprintf ppf "The classes do not have the same number of type parameters" - | CM_Type_parameter_mismatch (env, err) -> + | CM_Type_parameter_mismatch (n, env, err) -> Printtyp.report_equality_error ppf mode env err (function ppf -> - fprintf ppf "A type parameter has type") + fprintf ppf "The %d%s type parameter has type" + n (Misc.ordinal_suffix n)) (function ppf -> - fprintf ppf "but is expected to have type") + 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 @@ -69,10 +70,11 @@ let include_err mode ppf = Printtyp.class_type cty1 "is not matched by the class type" Printtyp.class_type cty2) - | CM_Parameter_mismatch (env, err) -> + | CM_Parameter_mismatch (n, env, err) -> Printtyp.report_moregen_error ppf mode env err (function ppf -> - fprintf ppf "A parameter has type") + fprintf ppf "The %d%s parameter has type" + n (Misc.ordinal_suffix n)) (function ppf -> fprintf ppf "but is expected to have type") | CM_Val_type_mismatch (lab, env, err) -> diff --git a/src/ocaml/typing/includecore.ml b/src/ocaml/typing/includecore.ml index a3cdd189c9..595c07e935 100644 --- a/src/ocaml/typing/includecore.ml +++ b/src/ocaml/typing/includecore.ml @@ -140,7 +140,7 @@ type type_kind = | Kind_open let of_kind = function - | Type_abstract -> Kind_abstract + | Type_abstract _ -> Kind_abstract | Type_record (_, _) -> Kind_record | Type_variant (_, _) -> Kind_variant | Type_open -> Kind_open @@ -202,6 +202,8 @@ type type_mismatch = | Unboxed_representation of position | Immediate of Type_immediacy.Violation.t +module Style = Misc.Style + let report_primitive_mismatch first second ppf err = let pr fmt = Format.fprintf ppf fmt in match (err : primitive_mismatch) with @@ -211,8 +213,9 @@ let report_primitive_mismatch first second ppf err = pr "The syntactic arities of these primitives were not the same.@ \ (They must have the same number of arrows present in the source.)" | No_alloc ord -> - pr "%s primitive is [@@@@noalloc] but %s is not" + pr "%s primitive is %a but %s is not" (String.capitalize_ascii (choose ord first second)) + Style.inline_code "[@@noalloc]" (choose_other ord first second) | Native_name -> pr "The native names of the primitives are not the same" @@ -264,30 +267,34 @@ let report_label_mismatch first second env ppf err = let pp_record_diff first second prefix decl env ppf (x : record_change) = match x with | Delete cd -> - Format.fprintf ppf "%aAn extra field, %s, is provided in %s %s." - prefix x (Ident.name cd.delete.ld_id) first decl + Format.fprintf ppf "%aAn extra field, %a, is provided in %s %s." + prefix x Style.inline_code (Ident.name cd.delete.ld_id) first decl | Insert cd -> - Format.fprintf ppf "%aA field, %s, is missing in %s %s." - prefix x (Ident.name cd.insert.ld_id) first decl + Format.fprintf ppf "%aA field, %a, is missing in %s %s." + prefix x Style.inline_code (Ident.name cd.insert.ld_id) first decl | Change Type {got=lbl1; expected=lbl2; reason} -> Format.fprintf ppf "@[%aFields do not match:@;<1 2>\ %a@ is not the same as:\ @;<1 2>%a@ %a@]" prefix x - Printtyp.label lbl1 - Printtyp.label lbl2 + (Style.as_inline_code Printtyp.label) lbl1 + (Style.as_inline_code Printtyp.label) lbl2 (report_label_mismatch first second env) reason | Change Name n -> - Format.fprintf ppf "%aFields have different names, %s and %s." - prefix x n.got n.expected + Format.fprintf ppf "%aFields have different names, %a and %a." + prefix x + Style.inline_code n.got + Style.inline_code n.expected | Swap sw -> - Format.fprintf ppf "%aFields %s and %s have been swapped." - prefix x sw.first sw.last + Format.fprintf ppf "%aFields %a and %a have been swapped." + prefix x + Style.inline_code sw.first + Style.inline_code sw.last | Move {name; got; expected } -> Format.fprintf ppf - "@[<2>%aField %s has been moved@ from@ position %d@ to %d.@]" - prefix x name expected got + "@[<2>%aField %a has been moved@ from@ position %d@ to %d.@]" + prefix x Style.inline_code name expected got let report_patch pr_diff first second decl env ppf patch = let nl ppf () = Format.fprintf ppf "@," in @@ -330,32 +337,36 @@ let report_constructor_mismatch first second decl env ppf err = let pp_variant_diff first second prefix decl env ppf (x : variant_change) = match x with | Delete cd -> - Format.fprintf ppf "%aAn extra constructor, %s, is provided in %s %s." - prefix x (Ident.name cd.delete.cd_id) first decl + Format.fprintf ppf "%aAn extra constructor, %a, is provided in %s %s." + prefix x Style.inline_code (Ident.name cd.delete.cd_id) first decl | Insert cd -> - Format.fprintf ppf "%aA constructor, %s, is missing in %s %s." - prefix x (Ident.name cd.insert.cd_id) first decl + Format.fprintf ppf "%aA constructor, %a, is missing in %s %s." + prefix x Style.inline_code (Ident.name cd.insert.cd_id) first decl | Change Type {got; expected; reason} -> Format.fprintf ppf "@[%aConstructors do not match:@;<1 2>\ %a@ is not the same as:\ @;<1 2>%a@ %a@]" prefix x - Printtyp.constructor got - Printtyp.constructor expected + (Style.as_inline_code Printtyp.constructor) got + (Style.as_inline_code Printtyp.constructor) expected (report_constructor_mismatch first second decl env) reason | Change Name n -> Format.fprintf ppf - "%aConstructors have different names, %s and %s." - prefix x n.got n.expected + "%aConstructors have different names, %a and %a." + prefix x + Style.inline_code n.got + Style.inline_code n.expected | Swap sw -> Format.fprintf ppf - "%aConstructors %s and %s have been swapped." - prefix x sw.first sw.last + "%aConstructors %a and %a have been swapped." + prefix x + Style.inline_code sw.first + Style.inline_code sw.last | Move {name; got; expected} -> Format.fprintf ppf - "@[<2>%aConstructor %s has been moved@ from@ position %d@ to %d.@]" - prefix x name expected got + "@[<2>%aConstructor %a has been moved@ from@ position %d@ to %d.@]" + prefix x Style.inline_code name expected got let report_extension_constructor_mismatch first second decl env ppf err = let pr fmt = Format.fprintf ppf fmt in @@ -363,25 +374,30 @@ let report_extension_constructor_mismatch first second decl env ppf err = | Constructor_privacy -> pr "Private extension constructor(s) would be revealed." | Constructor_mismatch (id, ext1, ext2, err) -> + let constructor = + Style.as_inline_code (Printtyp.extension_only_constructor id) + in pr "@[Constructors do not match:@;<1 2>%a@ is not the same as:\ @;<1 2>%a@ %a@]" - (Printtyp.extension_only_constructor id) ext1 - (Printtyp.extension_only_constructor id) ext2 + constructor ext1 + constructor ext2 (report_constructor_mismatch first second decl env) err + let report_private_variant_mismatch first second decl env ppf err = let pr fmt = Format.fprintf ppf fmt in + let pp_tag ppf x = Format.fprintf ppf "`%s" x in match (err : private_variant_mismatch) with | Only_outer_closed -> (* It's only dangerous in one direction, so we don't have a position *) pr "%s is private and closed, but %s is not closed" (String.capitalize_ascii second) first | Missing (ord, name) -> - pr "The constructor %s is only present in %s %s." - name (choose ord first second) decl + pr "The constructor %a is only present in %s %s." + Style.inline_code name (choose ord first second) decl | Presence s -> - pr "The tag `%s is present in the %s %s,@ but might not be in the %s" - s second decl first + pr "The tag %a is present in the %s %s,@ but might not be in the %s" + (Style.as_inline_code pp_tag) s second decl first | Incompatible_types_for s -> pr "Types for tag `%s are incompatible" s | Types err -> report_type_inequality env ppf err @@ -389,7 +405,8 @@ let report_private_variant_mismatch first second decl env ppf err = let report_private_object_mismatch env ppf err = let pr fmt = Format.fprintf ppf fmt in match (err : private_object_mismatch) with - | Missing s -> pr "The implementation is missing the method %s" s + | Missing s -> + pr "The implementation is missing the method %a" Style.inline_code s | Types err -> report_type_inequality env ppf err let report_kind_mismatch first second ppf (kind1, kind2) = @@ -715,7 +732,7 @@ let privacy_mismatch env decl1 decl2 = | Type_record _, Type_record _ -> Some Private_record_type | Type_variant _, Type_variant _ -> Some Private_variant_type | Type_open, Type_open -> Some Private_extensible_variant - | Type_abstract, Type_abstract + | Type_abstract _, Type_abstract _ when Option.is_some decl2.type_manifest -> begin match decl1.type_manifest with | Some ty1 -> begin @@ -852,7 +869,7 @@ let type_manifest env ty1 params1 ty2 params2 priv2 kind2 = | _ -> begin let is_private_abbrev_2 = match priv2, kind2 with - | Private, Type_abstract -> begin + | Private, Type_abstract _ -> begin (* Same checks as the [when] guards from above, inverted *) match get_desc ty2' with | Tvariant row -> @@ -911,7 +928,7 @@ let type_declarations ?(equality = false) ~loc env ~mark name in if err <> None then err else let err = match (decl1.type_kind, decl2.type_kind) with - (_, Type_abstract) -> None + (_, Type_abstract _) -> None | (Type_variant (cstrs1, rep1), Type_variant (cstrs2, rep2)) -> if mark then begin let mark usage cstrs = @@ -951,7 +968,7 @@ let type_declarations ?(equality = false) ~loc env ~mark name | (_, _) -> Some (Kind (of_kind decl1.type_kind, of_kind decl2.type_kind)) in if err <> None then err else - let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in + let abstr = Btype.type_kind_is_abstract decl2 && 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 = diff --git a/src/ocaml/typing/includemod.ml b/src/ocaml/typing/includemod.ml index d0fa23a211..b43602c51c 100644 --- a/src/ocaml/typing/includemod.ml +++ b/src/ocaml/typing/includemod.ml @@ -748,6 +748,8 @@ and signature_components ~in_eq ~loc old_env ~mark env subst type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2 in let item = mark_error_as_unrecoverable item in + (* Right now we don't filter hidden constructors / labels from the + shape. *) let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in id1, item, shape_map, false | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> @@ -925,10 +927,14 @@ let can_alias env path = type explanation = Env.t * Error.all exception Error of explanation +type application_name = + | Anonymous_functor + | Full_application_path of Longident.t + | Named_leftmost_functor of Longident.t exception Apply_error of { loc : Location.t ; env : Env.t ; - lid_app : Longident.t option ; + app_name : application_name ; mty_f : module_type ; args : (Error.functor_arg_descr * module_type) list ; } @@ -958,8 +964,8 @@ let check_functor_application_in_path 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}) + let app_name = Full_application_path lid_whole_app in + raise (Apply_error {loc; env; app_name; mty_f; args}) else raise Not_found @@ -1136,7 +1142,7 @@ module Functor_app_diff = struct | Insert(Named(Some param, param_ty)) | Change(_, Named(Some param, param_ty), _ ) -> (* Change is Delete + Insert: we add the Inserted parameter to the - environnement to track equalities with external components that the + environment to track equalities with external components that the parameter might add. *) let mty = Subst.modtype Keep st.subst param_ty in let env = Env.add_module ~arg:true param Mp_present mty st.env in diff --git a/src/ocaml/typing/includemod.mli b/src/ocaml/typing/includemod.mli index d5b2ee9a13..a57d51b67c 100644 --- a/src/ocaml/typing/includemod.mli +++ b/src/ocaml/typing/includemod.mli @@ -215,10 +215,16 @@ type pos = | Body of functor_parameter exception Error of explanation + +type application_name = + | Anonymous_functor (** [(functor (_:sig end) -> struct end)(Int)] *) + | Full_application_path of Longident.t (** [F(G(X).P)(Y)] *) + | Named_leftmost_functor of Longident.t (** [F(struct end)...(...)] *) + exception Apply_error of { loc : Location.t ; env : Env.t ; - lid_app : Longident.t option ; + app_name : application_name ; mty_f : module_type ; args : (Error.functor_arg_descr * Types.module_type) list ; } diff --git a/src/ocaml/typing/includemod_errorprinter.ml b/src/ocaml/typing/includemod_errorprinter.ml index f72795cb6c..db974635ec 100644 --- a/src/ocaml/typing/includemod_errorprinter.ml +++ b/src/ocaml/typing/includemod_errorprinter.ml @@ -13,6 +13,7 @@ (* *) (**************************************************************************) +module Style = Misc.Style module Context = struct type pos = @@ -63,16 +64,20 @@ module Context = struct 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) + Format.fprintf ppf "in module %a," + (Style.as_inline_code Printtyp.path) (path_of_context cxt) else - Format.fprintf ppf "@[at position@ %a,@]" context cxt + Format.fprintf ppf "@[at position@ %a,@]" + (Style.as_inline_code 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) + Format.fprintf ppf "In module %a:@ " + (Style.as_inline_code Printtyp.path) (path_of_context cxt) else - Format.fprintf ppf "@[At position@ %a@]@ " context cxt + Format.fprintf ppf "@[At position@ %a@]@ " + (Style.as_inline_code context) cxt end module Illegal_permutation = struct @@ -163,9 +168,9 @@ module Illegal_permutation = struct let item mt k = Includemod.item_ident_name (runtime_item k mt) let pp_item ppf (id,_,kind) = - Format.fprintf ppf "%s %S" + Format.fprintf ppf "%s %a" (Includemod.kind_of_field_desc kind) - (Ident.name id) + Style.inline_code (Ident.name id) let pp ctx_printer env ppf (mty,c) = try @@ -379,7 +384,7 @@ module Functor_suberror = struct let elt (x,param) = let sty = Diffing.(style @@ classify x) in Format.dprintf "%a%t%a" - Format.pp_open_stag (Misc.Color.Style sty) + Format.pp_open_stag (Style.Style sty) (printer param) Format.pp_close_stag () in @@ -663,8 +668,9 @@ let core env id x = 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 + Format.fprintf ppf "The %s %a is required but not provided%a" + (Includemod.kind_of_field_desc kind) + (Style.as_inline_code Printtyp.ident) id (show_loc "Expected declaration") loc let module_types {Err.got=mty1; expected=mty2} = @@ -690,8 +696,8 @@ let module_type_declarations id {Err.got=d1 ; expected=d2} = let interface_mismatch ppf (diff: _ Err.diff) = Format.fprintf ppf - "The implementation %s@ does not match the interface %s:@ " - diff.got diff.expected + "The implementation %a@ does not match the interface %a:@ " + Style.inline_code diff.got Style.inline_code diff.expected let core_module_type_symptom (x:Err.core_module_type_symptom) = match x with @@ -701,7 +707,9 @@ let core_module_type_symptom (x:Err.core_module_type_symptom) = Some Printtyp.Conflicts.print_explanations else None | Unbound_module_path path -> - Some(Format.dprintf "Unbound module %a" Printtyp.path path) + Some(Format.dprintf "Unbound module %a" + (Style.as_inline_code Printtyp.path) path + ) (* Construct a linearized error message from the error tree *) @@ -741,7 +749,8 @@ and module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx = function 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 + Format.dprintf "Module %a cannot be aliased" + (Style.as_inline_code Printtyp.path) path in dwith_context ctx printer :: before @@ -897,11 +906,7 @@ 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 report_apply_error ~loc env (app_name, mty_f, args) = 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 @@ -916,26 +921,57 @@ let report_apply_error ~loc env (lid_app, mty_f, args) = 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 + let not_functor = + List.for_all (function _, Diffing.Delete _ -> true | _ -> false) d in - Location.errorf ~loc ~sub - "@[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 + if not_functor then + match app_name with + | Includemod.Named_leftmost_functor lid -> + Location.errorf ~loc + "@[The module %a is not a functor, it cannot be applied.@]" + (Style.as_inline_code Printtyp.longident) lid + | Includemod.Anonymous_functor + | Includemod.Full_application_path _ + (* The "non-functor application in term" case is directly handled in + [Env] and it is the only case where we have a full application + path at hand. Thus this case of the or-pattern is currently + unreachable and we don't try to specialize the corresponding error + message. *) -> + Location.errorf ~loc + "@[This module is not a functor, it cannot be applied.@]" + else + let intro ppf = + match app_name with + | Includemod.Anonymous_functor -> + Format.fprintf ppf "This functor application is ill-typed." + | Includemod.Full_application_path lid -> + Format.fprintf ppf "The functor application %a is ill-typed." + (Style.as_inline_code Printtyp.longident) lid + | Includemod.Named_leftmost_functor lid -> + Format.fprintf ppf + "This application of the functor %a is ill-typed." + (Style.as_inline_code Printtyp.longident) lid + in + 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 + "@[%t@ \ + These arguments:@;<1 2>@[%t@]@ \ + do not match these parameters:@;<1 2>@[functor@ %t@ -> ...@]@]" + intro + 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} -> + | Includemod.Apply_error {loc; env; app_name; mty_f; args} -> Some (Printtyp.wrap_printing_env env ~error:true (fun () -> - report_apply_error ~loc env (lid_app, mty_f, args)) + report_apply_error ~loc env (app_name, mty_f, args)) ) | _ -> None ) diff --git a/src/ocaml/typing/lambda.ml b/src/ocaml/typing/lambda.ml new file mode 100644 index 0000000000..7e473d3574 --- /dev/null +++ b/src/ocaml/typing/lambda.ml @@ -0,0 +1,9 @@ +(* The lambda representation is of no interest for Merlin, but some types are + used by [value_rec_check]. *) + +type immediate_or_pointer = + | Immediate + | Pointer + +type array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray diff --git a/src/ocaml/typing/magic_numbers.ml b/src/ocaml/typing/magic_numbers.ml index f052ec9850..f5503f0000 100644 --- a/src/ocaml/typing/magic_numbers.ml +++ b/src/ocaml/typing/magic_numbers.ml @@ -24,16 +24,18 @@ module Cmi = struct | "Caml1999I031" -> Some "4.14" | "Caml1999I032" -> Some "5.0" | "Caml1999I033" -> Some "5.1" + | "Caml1999I034" -> Some "5.2" | _ -> None let () = assert (to_version_opt Config.cmi_magic_number <> None) open Format + module Style = Misc.Style let report_error ppf = function | Not_an_interface filename -> fprintf ppf "%a@ is not a compiled interface" - Location.print_filename filename + (Style.as_inline_code Location.print_filename) filename | Wrong_version_interface (filename, compiler_magic) -> let program_name = Lib_config.program_name () in begin match to_version_opt compiler_magic with @@ -65,7 +67,7 @@ module Cmi = struct end | Corrupted_interface filename -> fprintf ppf "Corrupted compiled interface@ %a" - Location.print_filename filename + (Style.as_inline_code Location.print_filename) filename let () = Location.register_error_of_exn diff --git a/src/ocaml/typing/msupport.ml b/src/ocaml/typing/msupport.ml index 02619389a2..211b9a81c9 100644 --- a/src/ocaml/typing/msupport.ml +++ b/src/ocaml/typing/msupport.ml @@ -82,7 +82,7 @@ let erroneous_type_register te = | None -> () let erroneous_type_check te = - let te = Types.Transient_expr.coerce te in + (* let te = Types.Transient_expr.coerce te in *) match !errors with | Some (_,h) -> Btype.TypeHash.mem h te | _ -> false diff --git a/src/ocaml/typing/mtype.ml b/src/ocaml/typing/mtype.ml index 312fec5fc8..b12dfde8c4 100644 --- a/src/ocaml/typing/mtype.ml +++ b/src/ocaml/typing/mtype.ml @@ -65,7 +65,7 @@ and strengthen_lazy_sig' ~aliasable env sg p = [] -> [] | (SigL_value(_, _, _) as sigelt) :: rem -> sigelt :: strengthen_lazy_sig' ~aliasable env rem p - | SigL_type(id, {type_kind=Type_abstract}, _, _) :: rem + | SigL_type(id, {type_kind=Type_abstract _}, _, _) :: rem when Btype.is_row_name (Ident.name id) -> strengthen_lazy_sig' ~aliasable env rem p | SigL_type(id, decl, rs, vis) :: rem -> @@ -77,7 +77,7 @@ and strengthen_lazy_sig' ~aliasable env sg p = let manif = Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id), decl.type_params, ref Mnil))) in - if decl.type_kind = Type_abstract then + if Btype.type_kind_is_abstract decl then { decl with type_private = Public; type_manifest = manif } else { decl with type_manifest = manif } @@ -392,7 +392,7 @@ 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}),_, _) + {type_kind = Type_abstract _; type_private = Private}),_, _) | Sig_modtype _ | Sig_typext (_, {ext_args = Cstr_record _}, _, _) -> (* We consider that extension constructors with an inlined diff --git a/src/ocaml/typing/oprint.ml b/src/ocaml/typing/oprint.ml index 85124265e4..57897a19fd 100644 --- a/src/ocaml/typing/oprint.ml +++ b/src/ocaml/typing/oprint.ml @@ -24,6 +24,7 @@ let cautious f ppf arg = let print_lident ppf = function | "::" -> pp_print_string ppf "(::)" + | s when Lexer.is_keyword s -> fprintf ppf "\\#%s" s | s -> pp_print_string ppf s let rec print_ident ppf = @@ -62,6 +63,8 @@ let parenthesized_ident name = let value_ident ppf name = if parenthesized_ident name then fprintf ppf "( %s )" name + else if Lexer.is_keyword name then + fprintf ppf "\\#%s" name else pp_print_string ppf name @@ -153,16 +156,26 @@ let print_out_string ppf s = else fprintf ppf "%S" s +let print_constr ppf name = + match name with + | Oide_ident {printed_name = ("true" | "false") as c} -> + (* despite being keywords, these are constructor names + and should not be escaped *) + fprintf ppf "%s" c + | _ -> print_ident ppf name + 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 + fprintf ppf "@[<1>%a@ %a@]" print_constr name print_constr_param param | Oval_constr (name, (_ :: _ as params)) -> - fprintf ppf "@[<1>%a@ (%a)@]" print_ident name + fprintf ppf "@[<1>%a@ (%a)@]" print_constr name (print_tree_list print_tree_1 ",") params | Oval_variant (name, Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param + fprintf ppf "@[<2>`%a@ %a@]" print_lident name print_constr_param param + | Oval_lazy param -> + fprintf ppf "@[<2>lazy@ %a@]" 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) @@ -205,8 +218,8 @@ let print_out_value ppf tree = 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_constr (name, []) -> print_constr ppf name + | Oval_variant (name, None) -> fprintf ppf "`%a" print_lident name | Oval_stuff s -> pp_print_string ppf s | Oval_record fel -> fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel @@ -261,6 +274,12 @@ let ty_var ~non_gen ppf s = let pr_vars = print_list pr_var (fun ppf -> fprintf ppf "@ ") +let print_arg_label ppf (lbl : Asttypes.arg_label) = + match lbl with + | Nolabel -> () + | Labelled s -> fprintf ppf "%a:" print_lident s + | Optional s -> fprintf ppf "?%a:" print_lident s + let rec print_out_type ppf = function | Otyp_alias {non_gen; aliased; alias } -> @@ -278,7 +297,7 @@ 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_arg_label ppf lab; print_out_type_2 ppf ty1; pp_print_string ppf " ->"; pp_print_space ppf (); @@ -351,7 +370,7 @@ and print_fields open_row ppf = [] -> if open_row then fprintf ppf ".."; | [s, t] -> - fprintf ppf "%s : %a" s print_out_type t; + fprintf ppf "%a : %a" print_lident s print_out_type t; if open_row then fprintf ppf ";@ "; print_fields open_row ppf [] | (s, t) :: l -> @@ -362,7 +381,8 @@ and print_row_field ppf (l, opt_amp, tyl) = else if tyl <> [] then fprintf ppf " of@ " else fprintf ppf "" in - fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") + fprintf ppf "@[`%a%t%a@]" print_lident l pr_of + (print_typlist print_out_type " &") tyl and print_typlist print_elem sep ppf = function @@ -385,7 +405,8 @@ and print_typargs 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 + fprintf ppf "@[<2>%s%a :@ %a@];" (if mut then "mutable " else "") + print_lident name print_out_type arg let out_label = ref print_out_label @@ -396,15 +417,15 @@ let out_type_args = ref print_typargs (* Class types *) -let print_type_parameter ppf s = - if s = "_" then fprintf ppf "_" else pr_var ppf s +let print_type_parameter ?(non_gen=false) ppf s = + if s = "_" then fprintf ppf "_" else ty_var ~non_gen ppf s -let type_parameter ppf (ty, (var, inj)) = +let type_parameter ppf {ot_non_gen=non_gen; ot_name=ty; ot_variance=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 + (print_type_parameter ~non_gen) ty let print_out_class_params ppf = function @@ -425,7 +446,7 @@ let rec print_out_class_type ppf = 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 "") + fprintf ppf "@[%a%a ->@ %a@]" print_arg_label lab print_out_type_2 ty print_out_class_type cty | Octy_signature (self_ty, csil) -> let pr_param ppf = @@ -442,14 +463,14 @@ and print_out_class_sig_item ppf = 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@]" + fprintf ppf "@[<2>method %s%s%a :@ %a@]" (if priv then "private " else "") (if virt then "virtual " else "") - name !out_type ty + print_lident name !out_type ty | Ocsg_value (name, mut, vr, ty) -> - fprintf ppf "@[<2>val %s%s%s :@ %a@]" + fprintf ppf "@[<2>val %s%s%a :@ %a@]" (if mut then "mutable " else "") (if vr then "virtual " else "") - name !out_type ty + print_lident name !out_type ty let out_class_type = ref print_out_class_type @@ -590,15 +611,15 @@ and print_out_signature ppf = and print_out_sig_item ppf = function Osig_class (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" + fprintf ppf "@[<2>%s%s@ %a%a@ :@ %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 + print_lident name !out_class_type clt | Osig_class_type (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" + fprintf ppf "@[<2>%s%s@ %a%a@ =@ %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 + print_lident name !out_class_type clt | Osig_typext (ext, Oext_exception) -> fprintf ppf "@[<2>exception %a@]" print_out_constr (constructor_of_extension_constructor ext) @@ -649,13 +670,15 @@ and print_out_type_decl kwd ppf td = 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 + [] -> print_lident ppf td.otype_name + | [param] -> + fprintf ppf "@[%a@ %a@]" type_parameter param + print_lident td.otype_name | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" + fprintf ppf "@[(@[%a)@]@ %a@]" (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) td.otype_params - td.otype_name + print_lident td.otype_name in let print_manifest ppf = function @@ -744,17 +767,17 @@ and print_out_constr ppf constr = 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 + [] -> fprintf ppf "%a" print_lident ext.oext_type_name | [ty_param] -> - fprintf ppf "@[%a@ %s@]" - print_type_parameter + fprintf ppf "@[%a@ %a@]" + (print_type_parameter ~non_gen:false) ty_param - ext.oext_type_name + print_lident ext.oext_type_name | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" + fprintf ppf "@[(@[%a)@]@ %a@]" (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) ext.oext_type_params - ext.oext_type_name + print_lident ext.oext_type_name in fprintf ppf "@[type %t +=%s@;<1 2>%a@]" print_extended_type @@ -765,16 +788,16 @@ and print_out_extension_constructor ppf ext = and print_out_type_extension ppf te = let print_extended_type ppf = match te.otyext_params with - [] -> fprintf ppf "%s" te.otyext_name + [] -> fprintf ppf "%a" print_lident te.otyext_name | [param] -> - fprintf ppf "@[%a@ %s@]" - print_type_parameter param - te.otyext_name + fprintf ppf "@[%a@ %a@]" + (print_type_parameter ~non_gen:false) param + print_lident te.otyext_name | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" + fprintf ppf "@[(@[%a)@]@ %a@]" (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) te.otyext_params - te.otyext_name + print_lident te.otyext_name in fprintf ppf "@[type %t +=%s@;<1 2>%a@]" print_extended_type diff --git a/src/ocaml/typing/outcometree.mli b/src/ocaml/typing/outcometree.mli index 8c32954a30..ed2b61599c 100644 --- a/src/ocaml/typing/outcometree.mli +++ b/src/ocaml/typing/outcometree.mli @@ -55,14 +55,19 @@ type out_value = | Oval_stuff of string | Oval_tuple of out_value list | Oval_variant of string * out_value option + | Oval_lazy of out_value -type out_type_param = string * (Asttypes.variance * Asttypes.injectivity) +type out_type_param = { + ot_non_gen: bool; + ot_name: string; + ot_variance: Asttypes.variance * Asttypes.injectivity +} type out_type = | Otyp_abstract | Otyp_open | Otyp_alias of {non_gen:bool; aliased:out_type; alias:string} - | Otyp_arrow of string * out_type * out_type + | Otyp_arrow of Asttypes.arg_label * out_type * out_type | Otyp_class of out_ident * out_type list | Otyp_constr of out_ident * out_type list | Otyp_manifest of out_type * out_type @@ -89,7 +94,7 @@ and out_variant = type out_class_type = | Octy_constr of out_ident * out_type list - | Octy_arrow of string * out_type * out_class_type + | Octy_arrow of Asttypes.arg_label * 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 diff --git a/src/ocaml/typing/parmatch.ml b/src/ocaml/typing/parmatch.ml index 2a388f1fc8..e10ec777b8 100644 --- a/src/ocaml/typing/parmatch.ml +++ b/src/ocaml/typing/parmatch.ml @@ -20,6 +20,23 @@ open Asttypes open Types open Typedtree +type 'pattern parmatch_case = + { pattern : 'pattern; + has_guard : bool; + needs_refute : bool; + } + +let typed_case { c_lhs; c_guard; c_rhs } = + { pattern = c_lhs; + has_guard = Option.is_some c_guard; + needs_refute = (c_rhs.exp_desc = Texp_unreachable); + } + +let untyped_case { Parsetree.pc_lhs; pc_guard; pc_rhs } = + { pattern = pc_lhs; + has_guard = Option.is_some pc_guard; + needs_refute = (pc_rhs.pexp_desc = Parsetree.Pexp_unreachable); + } (*************************************) (* Utilities for building patterns *) @@ -37,7 +54,8 @@ let omega_list = Patterns.omega_list let extra_pat = make_pat - (Tpat_var (Ident.create_local "+", mknoloc "+")) + (Tpat_var (Ident.create_local "+", mknoloc "+", + Uid.internal_not_actually_unique)) Ctype.none Env.empty @@ -283,8 +301,8 @@ module Compat | ((Tpat_any|Tpat_var _),_) | (_,(Tpat_any|Tpat_var _)) -> true (* Structural induction *) - | Tpat_alias (p,_,_),_ -> compat p q - | _,Tpat_alias (q,_,_) -> compat p q + | 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,_) -> @@ -530,12 +548,14 @@ let do_set_args ~erase_mutable q r = match q with end | {pat_desc = Tpat_array omegas} -> let args,rest = read_args omegas r in + let args = if erase_mutable then omegas else args 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" +| {pat_desc = (Tpat_var _ | Tpat_alias _ | Tpat_or _); _} -> + 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 @@ -846,7 +866,7 @@ let pats_of_type env ty = [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] | _ -> [omega] end - | Typedecl (_, _, {type_kind = Type_abstract | Type_open}) + | Typedecl (_, _, {type_kind = Type_abstract _ | Type_open}) | May_have_typedecl -> [omega] let get_variant_constructors env ty = @@ -919,7 +939,8 @@ let build_other ext env = (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) make_pat (Tpat_var (Ident.create_local "*extension*", - {txt="*extension*"; loc = d.pat_loc})) + {txt="*extension*"; loc = d.pat_loc}, + Uid.internal_not_actually_unique)) Ctype.none Env.empty | Construct _ -> begin match ext with @@ -1049,7 +1070,7 @@ let build_other ext env = 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_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 @@ -1503,7 +1524,7 @@ let is_var_column 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 +| Tpat_alias (p,_,_,_) -> or_args p | _ -> assert false (* Just remove current column *) @@ -1683,8 +1704,8 @@ and every_both pss qs q1 q2 = 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_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 @@ -1715,6 +1736,10 @@ let get_mins le ps = if List.exists (fun p0 -> le p0 p) ps then select_rec r ps else select_rec (p::r) ps in + (* [select_rec] removes the elements that are followed by a smaller element. + An element that is preceded by a smaller element may stay in the list. + We thus do two passes on the list, which is returned reversed + the first time. *) select_rec [] (select_rec [] ps) (* @@ -1723,8 +1748,8 @@ let get_mins le ps = *) 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_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 @@ -1822,8 +1847,8 @@ let pressure_variants_in_computation_pattern tdefs patl = let rec initial_matrix = function [] -> [] - | {c_guard=Some _} :: rem -> initial_matrix rem - | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem + | {has_guard=true} :: rem -> initial_matrix rem + | {has_guard=false; pattern=p} :: rem -> [p] :: initial_matrix rem (* Build up a working pattern matrix by keeping @@ -1831,9 +1856,9 @@ let rec initial_matrix = function *) let rec initial_only_guarded = function | [] -> [] - | { c_guard = None; _} :: rem -> + | { has_guard = false; _} :: rem -> initial_only_guarded rem - | { c_lhs = pat; _ } :: rem -> + | { pattern = pat; _ } :: rem -> [pat] :: initial_only_guarded rem @@ -1845,7 +1870,7 @@ let rec initial_only_guarded = function let contains_extension pat = exists_pattern (function - | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true + | {pat_desc=Tpat_var (_, {txt="*extension*"}, _)} -> true | _ -> false) pat @@ -1877,7 +1902,7 @@ let do_check_partial ~pred loc casel pss = match pss with try let buf = Buffer.create 16 in let fmt = Format.formatter_of_buffer buf in - Printpat.top_pretty fmt v; + Format.fprintf fmt "%a@?" Printpat.pretty_pat v; if do_match (initial_only_guarded casel) [v] then Buffer.add_string buf "\n(However, some guarded clause may match this value.)"; @@ -1930,7 +1955,8 @@ let rec collect_paths_from_pat r p = match p.pat_desc with 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_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 @@ -1948,7 +1974,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with let do_check_fragile loc casel pss = let exts = List.fold_left - (fun r c -> collect_paths_from_pat r c.c_lhs) + (fun r c -> collect_paths_from_pat r c.pattern) [] casel in match exts with | [] -> () @@ -1972,10 +1998,10 @@ let do_check_fragile loc casel pss = 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 + || List.exists (fun vc -> vc.needs_refute) casel then let rec do_rec pref = function | [] -> () - | {c_lhs=q; c_guard; c_rhs} :: rem -> + | {pattern=q; has_guard; needs_refute=refute} :: rem -> let qs = [q] in begin try let pss = @@ -1986,7 +2012,6 @@ let check_unused pred casel = |> 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 = @@ -2032,7 +2057,7 @@ let check_unused pred casel = with Empty | Not_found -> assert false end ; - if c_guard <> None then + if has_guard then do_rec pref rem else do_rec ([q]::pref) rem in @@ -2063,7 +2088,7 @@ let inactive ~partial pat = end | Tpat_tuple ps | Tpat_construct (_, _, ps, _) -> List.for_all (fun p -> loop p) ps - | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) -> + | Tpat_alias (p,_,_,_) | Tpat_variant (_, Some p, _) -> loop p | Tpat_record (ldps,_) -> List.for_all @@ -2182,9 +2207,9 @@ 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,_) -> + | `Alias (p,x,_,_) -> simpl (Ident.Set.add x head_bound_variables) varsets p ps k - | `Var (x, _) -> + | `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 @@ -2335,7 +2360,7 @@ let check_ambiguous_bindings = 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; _} -> + | { 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 diff --git a/src/ocaml/typing/parmatch.mli b/src/ocaml/typing/parmatch.mli index 0fe0d50810..246ca209ea 100644 --- a/src/ocaml/typing/parmatch.mli +++ b/src/ocaml/typing/parmatch.mli @@ -19,6 +19,24 @@ open Asttypes open Typedtree open Types +(** Most checks in this file need not access all information about a case, + and just need a few pieces of information. [parmatch_case] is those + few pieces of information. +*) +type 'pattern parmatch_case = + { pattern : 'pattern; + has_guard : bool; + needs_refute : bool; + (** true if the program text claims the case is unreachable, a la + [function _ -> .] + *) + } + +type 'category typed_case := 'category general_pattern parmatch_case + +val typed_case : 'category case -> 'category typed_case +val untyped_case : Parsetree.case -> Parsetree.pattern parmatch_case + 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 @@ -97,9 +115,11 @@ val pressure_variants_in_computation_pattern: [refute] indicates that [check_unused] was called on a refutation clause. *) val check_partial: - (pattern -> pattern option) -> Location.t -> value case list -> partial + (pattern -> pattern option) -> Location.t -> value typed_case list + -> partial + val check_unused: - (bool -> pattern -> pattern option) -> value case list -> unit + (bool -> pattern -> pattern option) -> value typed_case list -> unit (* Irrefutability tests *) val irrefutable : pattern -> bool @@ -110,7 +130,7 @@ val irrefutable : pattern -> bool active. *) val inactive : partial:partial -> pattern -> bool -(* Ambiguous bindings *) +(* Ambiguous bindings. *) val check_ambiguous_bindings : value case list -> unit (* The tag used for open polymorphic variant types with an abstract row *) diff --git a/src/ocaml/typing/path.ml b/src/ocaml/typing/path.ml index 69b8f34a01..4b44b0b2f0 100644 --- a/src/ocaml/typing/path.ml +++ b/src/ocaml/typing/path.ml @@ -90,9 +90,13 @@ let rec scope = function let kfalse _ = false +let maybe_escape s = + if Lexer.is_keyword s then "\\#" ^ s else s + let rec name ?(paren=kfalse) = function - Pident id -> Ident.name id + Pident id -> maybe_escape (Ident.name id) | Pdot(p, s) | Pextra_ty (p, Pcstr_ty s) -> + let s = maybe_escape s in name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" | Pextra_ty (p, Pext_ty) -> name ~paren p diff --git a/src/ocaml/typing/patterns.ml b/src/ocaml/typing/patterns.ml index 55f9d4ff43..456f8dff33 100644 --- a/src/ocaml/typing/patterns.ml +++ b/src/ocaml/typing/patterns.ml @@ -79,18 +79,18 @@ end module General = struct type view = [ | Half_simple.view - | `Var of Ident.t * string loc - | `Alias of pattern * Ident.t * string loc + | `Var of Ident.t * string loc * Uid.t + | `Alias of pattern * Ident.t * string loc * Uid.t ] 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_var (id, str, uid) -> + `Var (id, str, uid) + | Tpat_alias (p, id, str, uid) -> + `Alias (p, id, str, uid) | Tpat_constant cst -> `Constant cst | Tpat_tuple ps -> @@ -110,8 +110,8 @@ module General = struct let erase_desc = function | `Any -> Tpat_any - | `Var (id, str) -> Tpat_var (id, str) - | `Alias (p, id, str) -> Tpat_alias (p, id, str) + | `Var (id, str, uid) -> Tpat_var (id, str, uid) + | `Alias (p, id, str, uid) -> Tpat_alias (p, id, str, uid) | `Constant cst -> Tpat_constant cst | `Tuple ps -> Tpat_tuple ps | `Construct (cstr, cst_descr, args) -> @@ -129,7 +129,7 @@ module General = struct let rec strip_vars (p : pattern) : Half_simple.pattern = match p.pat_desc with - | `Alias (p, _, _) -> strip_vars (view p) + | `Alias (p, _, _, _) -> strip_vars (view p) | `Var _ -> { p with pat_desc = `Any } | #Half_simple.view as view -> { p with pat_desc = view } end diff --git a/src/ocaml/typing/patterns.mli b/src/ocaml/typing/patterns.mli index 66dd2d05a4..2ad645b0d0 100644 --- a/src/ocaml/typing/patterns.mli +++ b/src/ocaml/typing/patterns.mli @@ -65,8 +65,8 @@ end module General : sig type view = [ | Half_simple.view - | `Var of Ident.t * string loc - | `Alias of pattern * Ident.t * string loc + | `Var of Ident.t * string loc * Uid.t + | `Alias of pattern * Ident.t * string loc * Uid.t ] type pattern = view pattern_data diff --git a/src/ocaml/typing/persistent_env.ml b/src/ocaml/typing/persistent_env.ml index 15bb94165c..a75b4f3e11 100644 --- a/src/ocaml/typing/persistent_env.ml +++ b/src/ocaml/typing/persistent_env.ml @@ -34,14 +34,19 @@ 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) + cmi : Cmi_format.cmi_infos; + visibility : Load_path.visibility } + + let load = ref (fun ~allow_hidden ~unit_name -> + match Load_path.find_normalized_with_visibility (unit_name ^ ".cmi") with + | filename, visibility when allow_hidden -> + let cmi = Cmi_cache.read filename in + Some { filename; cmi; visibility} + | filename, Visible -> + let cmi = Cmi_cache.read filename in + Some { filename; cmi; visibility = Visible} + | _, Hidden + | exception Not_found -> None) end type can_load_cmis = @@ -53,6 +58,7 @@ type pers_struct = { ps_crcs: (string * Digest.t option) list; ps_filename: string; ps_flags: pers_flags list; + ps_visibility: Load_path.visibility; } module String = Misc.String @@ -204,7 +210,7 @@ let save_pers_struct penv crc ps pm = 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 { Persistent_signature.filename; cmi; visibility } = pers_sig in let name = cmi.cmi_name in let crcs = cmi.cmi_crcs in let flags = cmi.cmi_flags in @@ -212,6 +218,7 @@ let acknowledge_pers_struct penv short_path_comps check modname pers_sig pm = ps_crcs = crcs; ps_filename = filename; ps_flags = flags; + ps_visibility = visibility; } in if ps.ps_name <> modname then error (Illegal_renaming(modname, ps.ps_name, filename)); @@ -229,29 +236,33 @@ let acknowledge_pers_struct penv short_path_comps check modname pers_sig 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 = +let read_pers_struct penv val_of_pers_sig short_path_comps check cmi = + let modname = Unit_info.Artifact.modname cmi in + let filename = Unit_info.Artifact.filename cmi in add_import penv modname; let cmi = Cmi_cache.read filename in - let pers_sig = { Persistent_signature.filename; cmi } in + let pers_sig = { Persistent_signature.filename; cmi; visibility = Visible } 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 find_pers_struct ~allow_hidden 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) + | Found (ps, pm) when allow_hidden || ps.ps_visibility = Load_path.Visible -> + (ps, pm) + | Found _ -> raise Not_found | 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 + match !Persistent_signature.load ~allow_hidden ~unit_name:name with | Some psig -> psig | None -> - Hashtbl.add persistent_structures name Missing; + if allow_hidden then Hashtbl.add persistent_structures name Missing; raise Not_found in add_import penv name; @@ -259,10 +270,11 @@ let find_pers_struct penv val_of_pers_sig short_path_comps check name = let ps = acknowledge_pers_struct penv short_path_comps check name psig pm in (ps, pm) +module Style = Misc.Style (* Emits a warning if there is no valid cmi for name *) -let check_pers_struct penv f1 f2 ~loc name = +let check_pers_struct ~allow_hidden penv f1 f2 ~loc name = try - ignore (find_pers_struct penv f1 f2 false name) + ignore (find_pers_struct ~allow_hidden penv f1 f2 false name) with | Not_found -> let warn = Warnings.No_cmi_file(name, None) in @@ -277,24 +289,26 @@ let check_pers_struct penv f1 f2 ~loc name = | 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 + %a when %a was expected" + (Style.as_inline_code Location.print_filename) filename + Style.inline_code ps_name + Style.inline_code name | Inconsistent_import _ -> assert false | Need_recursive_types name -> - Format.sprintf - "%s uses recursive types" - name + Format.asprintf + "%a uses recursive types" + Style.inline_code 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 read penv f1 f2 a = + snd (read_pers_struct penv f1 f2 true a) -let find penv f1 f2 name = - snd (find_pers_struct penv f1 f2 true name) +let find ~allow_hidden penv f1 f2 name = + snd (find_pers_struct ~allow_hidden penv f1 f2 true name) -let check penv f1 f2 ~loc name = +let check ~allow_hidden 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 @@ -303,11 +317,11 @@ let check penv f1 f2 ~loc name = 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) + (fun () -> check_pers_struct ~allow_hidden 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 (ps, _pm) = find_pers_struct ~allow_hidden:true penv f1 f2 true name in let crco = try List.assoc name ps.ps_crcs @@ -347,7 +361,7 @@ let make_cmi penv modname sign alerts = } let save_cmi penv psig pm = - let { Persistent_signature.filename; cmi } = psig in + let { Persistent_signature.filename; cmi; visibility } = psig in Misc.try_finally (fun () -> let { cmi_name = modname; @@ -366,6 +380,7 @@ let save_cmi penv psig pm = ps_crcs = (cmi.cmi_name, Some crc) :: imports; ps_filename = filename; ps_flags = flags; + ps_visibility = visibility } in save_pers_struct penv crc ps pm ) @@ -376,16 +391,22 @@ let report_error ppf = 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 + %a when %a was expected" + (Style.as_inline_code Location.print_filename) filename + Style.inline_code ps_name + Style.inline_code modname | Inconsistent_import(name, source1, source2) -> fprintf ppf "@[The files %a@ and %a@ \ - make inconsistent assumptions@ over interface %s@]" - Location.print_filename source1 Location.print_filename source2 name + make inconsistent assumptions@ over interface %a@]" + (Style.as_inline_code Location.print_filename) source1 + (Style.as_inline_code Location.print_filename) source2 + Style.inline_code name | Need_recursive_types(import) -> fprintf ppf - "@[Invalid import of %s, which uses recursive types.@ %s@]" - import "The compilation flag -rectypes is required" + "@[Invalid import of %a, which uses recursive types.@ \ + The compilation flag %a is required@]" + Style.inline_code import + Style.inline_code "-rectypes" let () = Location.register_error_of_exn diff --git a/src/ocaml/typing/persistent_env.mli b/src/ocaml/typing/persistent_env.mli index afcea8ebc6..1acb5b3d65 100644 --- a/src/ocaml/typing/persistent_env.mli +++ b/src/ocaml/typing/persistent_env.mli @@ -32,12 +32,14 @@ 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 } + cmi : Cmi_format.cmi_infos; + visibility : Load_path.visibility + } (** 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 + val load : (allow_hidden:bool -> unit_name:string -> t option) ref end type can_load_cmis = @@ -57,14 +59,14 @@ 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) + -> Unit_info.Artifact.t -> 'a +val find : allow_hidden:bool -> '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) +val check : allow_hidden:bool -> 'a t -> (Persistent_signature.t -> 'a) -> (string -> 'a -> Short_paths.Desc.Module.components Lazy.t) -> loc:Location.t -> modname -> unit diff --git a/src/ocaml/typing/predef.ml b/src/ocaml/typing/predef.ml index 185825c330..7344be15fc 100644 --- a/src/ocaml/typing/predef.ml +++ b/src/ocaml/typing/predef.ml @@ -134,8 +134,8 @@ 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 mk_add_type add_type type_ident ?manifest + ?(immediate=Type_immediacy.Unknown) ?(kind=Type_abstract Definition) env = let decl = {type_params = []; type_arity = 0; @@ -158,7 +158,7 @@ let mk_add_type add_type type_ident let build_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 = + ~variance ~separability ?(kind=fun _ -> Type_abstract Definition) env = let param = newgenvar () in let decl = {type_params = [param]; diff --git a/src/ocaml/typing/primitive.ml b/src/ocaml/typing/primitive.ml index bf4fe83248..f8e964cce1 100644 --- a/src/ocaml/typing/primitive.ml +++ b/src/ocaml/typing/primitive.ml @@ -24,7 +24,7 @@ type native_repr = | Same_as_ocaml_repr | Unboxed_float | Unboxed_integer of boxed_integer - | Untagged_int + | Untagged_immediate type description = { prim_name: string; (* Name of primitive or C function *) @@ -45,16 +45,16 @@ let is_ocaml_repr = function | Same_as_ocaml_repr -> true | Unboxed_float | Unboxed_integer _ - | Untagged_int -> false + | Untagged_immediate -> false let is_unboxed = function | Same_as_ocaml_repr - | Untagged_int -> false + | Untagged_immediate -> false | Unboxed_float | Unboxed_integer _ -> true let is_untagged = function - | Untagged_int -> true + | Untagged_immediate -> true | Same_as_ocaml_repr | Unboxed_float | Unboxed_integer _ -> false @@ -95,8 +95,7 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res = fatal_error "Primitive.parse_declaration" in let noalloc_attribute = - Attr_helper.has_no_payload_attribute ["noalloc"; "ocaml.noalloc"] - valdecl.pval_attributes + Attr_helper.has_no_payload_attribute "noalloc" valdecl.pval_attributes in if old_style_float && not (List.for_all is_ocaml_repr native_repr_args && @@ -181,7 +180,7 @@ let print p osig_val_decl = | 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 + | Untagged_immediate -> if all_untagged then None else Some oattr_untagged in let type_attrs = List.map attr_of_native_repr p.prim_native_repr_args @ @@ -213,33 +212,40 @@ 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_integer _ | Untagged_immediate) -> false | Unboxed_float, Unboxed_float -> true | Unboxed_float, - (Same_as_ocaml_repr | Unboxed_integer _ | Untagged_int) -> false + (Same_as_ocaml_repr | Unboxed_integer _ | Untagged_immediate) -> 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 | Untagged_immediate) -> false + | Untagged_immediate, Untagged_immediate -> true + | Untagged_immediate, (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] <> '%' +module Style = Misc.Style + 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]." + Format.fprintf ppf "Cannot use %a in conjunction with %a/%a." + Style.inline_code "float" + Style.inline_code "[@unboxed]" + Style.inline_code "[@untagged]" | Old_style_noalloc_with_noalloc_attribute -> - Format.fprintf ppf "Cannot use \"noalloc\" in conjunction with \ - [%@%@noalloc]." + Format.fprintf ppf "Cannot use %a in conjunction with %a." + Style.inline_code "noalloc" + Style.inline_code "[@@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.@]" + "@[The native code version of the primitive is mandatory@ \ + when attributes %a or %a are present.@]" + Style.inline_code "[@untagged]" + Style.inline_code "[@unboxed]" let () = Location.register_error_of_exn diff --git a/src/ocaml/typing/primitive.mli b/src/ocaml/typing/primitive.mli index e8376ad552..3d3ae8854c 100644 --- a/src/ocaml/typing/primitive.mli +++ b/src/ocaml/typing/primitive.mli @@ -23,7 +23,7 @@ type native_repr = | Same_as_ocaml_repr | Unboxed_float | Unboxed_integer of boxed_integer - | Untagged_int + | Untagged_immediate type description = private { prim_name: string; (* Name of primitive or C function *) diff --git a/src/ocaml/typing/printpat.ml b/src/ocaml/typing/printpat.ml index 64094b63ec..bc3578ce41 100644 --- a/src/ocaml/typing/printpat.ml +++ b/src/ocaml/typing/printpat.ml @@ -52,7 +52,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> | [] -> match v.pat_desc with | Tpat_any -> fprintf ppf "_" - | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x) + | 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 @@ -84,7 +84,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) | _ -> true) lvs in begin match filtered_lvs with - | [] -> fprintf ppf "_" + | [] -> fprintf ppf "{ _ }" | (_, lbl, _) :: q -> let elision_mark ppf = (* we assume that there is no label repetitions here *) @@ -98,7 +98,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs | Tpat_lazy v -> fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v - | Tpat_alias (v, x,_) -> + | 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) @@ -144,26 +144,20 @@ and pretty_lvals ppf = function 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 ()) +let pretty_pat ppf p = + fprintf ppf "@[%a@]" pretty_val p type 'k matrix = 'k general_pattern list list -let pretty_line fmt = +let pretty_line ppf line = + Format.fprintf ppf "@["; 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%!" + Format.fprintf ppf "<%a>@ " + pretty_val p + ) line; + Format.fprintf ppf "@]" + +let pretty_matrix ppf (pss : 'k matrix) = + Format.fprintf ppf "@[ %a@]" + (Format.pp_print_list ~pp_sep:Format.pp_print_cut pretty_line) + pss diff --git a/src/ocaml/typing/printpat.mli b/src/ocaml/typing/printpat.mli index 1865a2ab29..1f03508c2d 100644 --- a/src/ocaml/typing/printpat.mli +++ b/src/ocaml/typing/printpat.mli @@ -16,11 +16,11 @@ val pretty_const - : Asttypes.constant -> string -val top_pretty - : Format.formatter -> 'k Typedtree.general_pattern -> unit + : Asttypes.constant -> string +val pretty_val : Format.formatter -> 'k Typedtree.general_pattern -> unit + val pretty_pat - : 'k Typedtree.general_pattern -> unit + : Format.formatter -> 'k Typedtree.general_pattern -> unit val pretty_line : Format.formatter -> 'k Typedtree.general_pattern list -> unit val pretty_matrix diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml index cba0d9c51d..70542c81e4 100644 --- a/src/ocaml/typing/printtyp.ml +++ b/src/ocaml/typing/printtyp.ml @@ -28,12 +28,11 @@ open Types open Btype open Outcometree -(* Print a long identifier *) +module Sig_component_kind = Shape.Sig_component_kind +module Style = Misc.Style -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 +(* Print a long identifier *) +let longident = Pprintast.longident let () = Env.print_longident := longident @@ -58,6 +57,8 @@ let in_printing_env f = Env.without_cmis f !printing_env type namespace = Shape.Sig_component_kind.t = | Value | Type + | Constructor + | Label | Module | Module_type | Extension_constructor @@ -73,7 +74,7 @@ module Namespace = struct | Module_type -> 2 | Class -> 3 | Class_type -> 4 - | Extension_constructor | Value -> 5 + | Extension_constructor | Value | Constructor | Label -> 5 (* we do not handle those component *) let size = 1 + id Value @@ -90,7 +91,8 @@ module Namespace = struct | Some Module_type -> to_lookup Env.find_modtype_by_name | Some Class -> to_lookup Env.find_class_by_name | Some Class_type -> to_lookup Env.find_cltype_by_name - | None | Some(Value|Extension_constructor) -> fun _ -> raise Not_found + | None | Some(Value|Extension_constructor|Constructor|Label) -> + fun _ -> raise Not_found let location namespace id = let path = Path.Pident id in @@ -101,7 +103,8 @@ module Namespace = struct | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc - | Some (Extension_constructor|Value) | None -> Location.none + | Some (Extension_constructor|Value|Constructor|Label) | None -> + Location.none ) with Not_found -> None let best_class_namespace = function @@ -152,9 +155,9 @@ module Conflicts = struct end let pp_explanation ppf r= - Format.fprintf ppf "@[%a:@,Definition of %s %s@]" - Location.print_loc r.location - (Shape.Sig_component_kind.to_string r.kind) r.name + Format.fprintf ppf "@[%a:@,Definition of %s %a@]" + Location.print_loc r.location (Sig_component_kind.to_string r.kind) + Style.inline_code r.name let print_located_explanations ppf l = Format.fprintf ppf "@[%a@]" (Format.pp_print_list pp_explanation) l @@ -181,11 +184,12 @@ module Conflicts = struct | [namespace, a] -> Format.fprintf ppf "@ \ - @[<2>@{Hint@}: The %a %s has been defined multiple times@ \ + @[<2>@{Hint@}: The %a %a 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.pp namespace + Style.inline_code a Namespace.pp namespace | (namespace, _) :: _ :: _ -> Format.fprintf ppf "@ \ @@ -194,7 +198,8 @@ module Conflicts = struct 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) + Format.(pp_print_list ~pp_sep:conj Style.inline_code) + (List.map snd names) pp_namespace_plural namespace in Array.iter (pp_submsg ppf) submsgs @@ -278,7 +283,7 @@ let indexed_name namespace id = | Module_type -> Env.find_modtype_index id env | Class -> Env.find_class_index id env | Class_type-> Env.find_cltype_index id env - | Value | Extension_constructor -> None + | Value | Extension_constructor | Constructor | Label -> None in let index = match M.find_opt (Ident.name id) !bound_in_recursion with @@ -377,7 +382,7 @@ let rec rewrite_double_underscore_paths env p = let better_lid = Ldot (Lident (String.sub name 0 i), - String.capitalize_ascii + Unit_info.modulize (String.sub name (i + 2) (String.length name - i - 2))) in match Env.find_module_by_name better_lid env with @@ -707,6 +712,70 @@ let printer_iter_type_expr f ty = | _ -> Btype.iter_type_expr f ty +module Internal_names : sig + + val reset : unit -> unit + + val add : Path.t -> unit + + val print_explanations : Env.t -> Format.formatter -> unit + +end = struct + + let names = ref Ident.Set.empty + + let reset () = + names := Ident.Set.empty + + let add p = + match p with + | Pident id -> + let name = Ident.name id in + if String.length name > 0 && name.[0] = '$' then begin + names := Ident.Set.add id !names + end + | Pdot _ | Papply _ | Pextra_ty _ -> () + + let print_explanations env ppf = + let constrs = + Ident.Set.fold + (fun id acc -> + let p = Pident id in + match Env.find_type p env with + | exception Not_found -> acc + | decl -> + match type_origin decl with + | Existential constr -> + let prev = String.Map.find_opt constr acc in + let prev = Option.value ~default:[] prev in + String.Map.add constr (tree_of_path None p :: prev) acc + | Definition | Rec_check_regularity -> acc) + !names String.Map.empty + in + String.Map.iter + (fun constr out_idents -> + match out_idents with + | [] -> () + | [out_ident] -> + fprintf ppf + "@ @[<2>@{Hint@}:@ %a@ is an existential type@ \ + bound by the constructor@ %a.@]" + (Style.as_inline_code !Oprint.out_ident) out_ident + Style.inline_code constr + | out_ident :: out_idents -> + fprintf ppf + "@ @[<2>@{Hint@}:@ %a@ and %a@ are existential types@ \ + bound by the constructor@ %a.@]" + (Format.pp_print_list + ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") + (Style.as_inline_code !Oprint.out_ident)) + (List.rev out_idents) + (Style.as_inline_code !Oprint.out_ident) out_ident + Style.inline_code constr) + constrs + +end + module Names : sig val reset_names : unit -> unit @@ -784,11 +853,7 @@ end = struct || 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 + let name = Misc.letter_of_int !name_counter in incr name_counter; if name_is_already_used name then new_name () else name @@ -1013,7 +1078,7 @@ let reset_loop_marks () = visited_objects := []; aliased := []; delayed := []; printed_aliases := [] let reset_except_context () = - Names.reset_names (); reset_loop_marks () + Names.reset_names (); reset_loop_marks (); Internal_names.reset () let reset () = Conflicts.reset (); @@ -1051,7 +1116,7 @@ let rec tree_of_typexp mode ty = Otyp_var (non_gen, Names.name_of_type name_gen tty) | Tarrow(l, ty1, ty2, _) -> let lab = - if !print_labels || is_optional l then string_of_label l else "" + if !print_labels || is_optional l then l else Nolabel in let t1 = if is_optional l then @@ -1067,9 +1132,10 @@ let rec tree_of_typexp mode ty = | Tconstr(p, tyl, _abbrev) -> begin match best_type_path p with | Nth n -> tree_of_typexp mode (apply_nth n tyl) - | Path(nso, p) -> + | Path(nso, p') -> + Internal_names.add p'; let tyl' = apply_subst_opt nso tyl in - Otyp_constr (tree_of_path (Some Type) p, tree_of_typlist mode tyl') + Otyp_constr (tree_of_path (Some Type) p', tree_of_typlist mode tyl') end | Tvariant row -> let Row {fields; name; closed; _} = row_repr row in @@ -1341,7 +1407,7 @@ let prepare_decl id decl = Some ty in begin match decl.type_kind with - | Type_abstract -> () + | Type_abstract _ -> () | Type_variant (cstrs, _rep) -> List.iter (fun c -> @@ -1356,15 +1422,15 @@ let prepare_decl id decl = let tree_of_type_decl id decl = let ty_manifest, params = prepare_decl id decl in - let type_param = + let type_param ot_variance = function - | Otyp_var (_, id) -> id - | _ -> "?" + | Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} in let type_defined decl = let abstr = match decl.type_kind with - Type_abstract -> + Type_abstract _ -> decl.type_manifest = None || decl.type_private = Private | Type_record _ -> decl.type_private = Private @@ -1380,7 +1446,7 @@ let tree_of_type_decl id decl = let is_var = is_Tvar ty in if abstr || not is_var then let inj = - decl.type_kind = Type_abstract && Variance.mem Inj v && + type_kind_is_abstract decl && Variance.mem Inj v && match decl.type_manifest with | None -> true | Some ty -> (* only abstract or private row types *) @@ -1394,7 +1460,7 @@ let tree_of_type_decl id decl = decl.type_params decl.type_variance in (Ident.name id, - List.map2 (fun ty cocn -> type_param (tree_of_typexp Type ty), cocn) + List.map2 (fun ty cocn -> type_param cocn (tree_of_typexp Type ty)) params vari) in let tree_of_manifest ty1 = @@ -1406,7 +1472,7 @@ let tree_of_type_decl id decl = let constraints = tree_of_constraints params in let ty, priv, unboxed = match decl.type_kind with - | Type_abstract -> + | Type_abstract _ -> begin match ty_manifest with | None -> (Otyp_abstract, Public, false) | Some ty -> @@ -1706,7 +1772,7 @@ let rec tree_of_class_type mode params = 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 "" + if !print_labels || is_optional l then l else Nolabel in let tr = if is_optional l then @@ -1723,11 +1789,11 @@ let class_type ppf cty = !Oprint.out_class_type ppf (tree_of_class_type Type [] cty) let tree_of_class_param param variance = - (match tree_of_typexp Type_scheme param with - Otyp_var (_, s) -> s - | _ -> "?"), - if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) - else variance + let ot_variance = + if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) else variance in + match tree_of_typexp Type_scheme param with + Otyp_var (ot_non_gen, ot_name) -> {ot_non_gen; ot_name; ot_variance} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance} let class_variance = let open Variance in let open Asttypes in @@ -1802,7 +1868,7 @@ let dummy = { type_params = []; type_arity = 0; - type_kind = Type_abstract; + type_kind = Type_abstract Definition; type_private = Public; type_manifest = None; type_variance = []; @@ -2053,9 +2119,11 @@ let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = end let type_expansion ppf = function - | Same t -> !Oprint.out_type ppf t + | Same t -> Style.as_inline_code !Oprint.out_type ppf t | Diff(t,t') -> - fprintf ppf "@[<2>%a@ =@ %a@]" !Oprint.out_type t !Oprint.out_type t' + fprintf ppf "@[<2>%a@ =@ %a@]" + (Style.as_inline_code !Oprint.out_type) t + (Style.as_inline_code !Oprint.out_type) t' let trees_of_trace mode = List.map (Errortrace.map_diff (trees_of_type_expansion mode)) @@ -2065,11 +2133,11 @@ let trees_of_type_path_expansion (tp,tp') = Diff(tree_of_path (Some Type) tp, tree_of_path (Some Type) tp') let type_path_expansion ppf = function - | Same p -> !Oprint.out_ident ppf p + | Same p -> Style.as_inline_code !Oprint.out_ident ppf p | Diff(p,p') -> fprintf ppf "@[<2>%a@ =@ %a@]" - !Oprint.out_ident p - !Oprint.out_ident p' + (Style.as_inline_code !Oprint.out_ident) p + (Style.as_inline_code !Oprint.out_ident) p' let rec trace fst txt ppf = function | {Errortrace.got; expected} :: rem -> @@ -2162,7 +2230,7 @@ let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = let print_path p = Format.dprintf "%a" !Oprint.out_ident (tree_of_path (Some Type) p) -let print_tag ppf = fprintf ppf "`%s" +let print_tag ppf s = Style.inline_code ppf ("`" ^ s) let print_tags = let comma ppf () = Format.fprintf ppf ",@ " in @@ -2188,13 +2256,17 @@ let explanation_diff env t3 t4 : (Format.formatter -> unit) option = when is_unit env ty1 && unifiable env ty2 t4 -> Some (fun ppf -> fprintf ppf - "@,@[@{Hint@}: Did you forget to provide `()' as argument?@]") + "@,@[@{Hint@}: Did you forget to provide %a as argument?@]" + Style.inline_code "()" + ) | _, 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 () ->'?@]") + %a?@]" + Style.inline_code "fun () ->" + ) | _ -> None @@ -2202,7 +2274,8 @@ 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 + fprintf ppf "it may not allow the tag(s) %a" + print_tags tags let explain_fixed_row pos expl = match expl with | Fixed_private -> @@ -2210,16 +2283,24 @@ let explain_fixed_row pos expl = match expl with | Univar x -> reserve_names x; dprintf "The %a variant type is bound to the universal type variable %a" - Errortrace.print_pos pos type_expr_with_reserved_names x + Errortrace.print_pos pos + (Style.as_inline_code type_expr_with_reserved_names) x | Reified p -> - dprintf "The %a variant type is bound to %t" - Errortrace.print_pos pos (print_path p) + dprintf "The %a variant type is bound to %a" + Errortrace.print_pos pos + (Style.as_inline_code + (fun ppf p -> + Internal_names.add p; + print_path p ppf)) + 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) + Some(dprintf "@,Types for tag %a are incompatible" + print_tag s + ) (* Unification *) | Errortrace.No_intersection -> Some(dprintf "@,These two variant types have no intersection") @@ -2242,9 +2323,9 @@ let explain_variant (type variety) : variety Errortrace.variant -> _ = function (* Equality & Moregen *) | Errortrace.Presence_not_guaranteed_for (pos, s) -> Some( dprintf - "@,@[The tag `%s is guaranteed to be present in the %a variant type,\ + "@,@[The tag %a is guaranteed to be present in the %a variant type,\ @ but not in the %a@]" - s + print_tag s Errortrace.print_pos (Errortrace.swap_position pos) Errortrace.print_pos pos ) @@ -2258,22 +2339,25 @@ let explain_escape pre = function reserve_names u; Some( dprintf "%t@,The universal variable %a would escape its scope" - pre type_expr_with_reserved_names u) + pre + (Style.as_inline_code type_expr_with_reserved_names) u + ) | Errortrace.Constructor p -> Some( dprintf "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]" - pre path p + pre (Style.as_inline_code path) p ) | Errortrace.Module_type p -> Some( dprintf "%t@,@[The module type@;<1 2>%a@ would escape its scope@]" - pre path p + pre (Style.as_inline_code path) p ) | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> reserve_names t; Some( dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" - pre type_expr_with_reserved_names t + pre + (Style.as_inline_code type_expr_with_reserved_names) t "it would escape the scope of its equation" ) | Errortrace.Self -> @@ -2283,8 +2367,8 @@ let explain_escape pre = function 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 + dprintf "@,@[The %a object type has no method %a@]" + Errortrace.print_pos pos Style.inline_code f ) | Errortrace.Abstract_row pos -> Some( dprintf @@ -2294,6 +2378,15 @@ let explain_object (type variety) : variety Errortrace.obj -> _ = function | Errortrace.Self_cannot_be_closed -> Some (dprintf "@,Self type cannot be unified with a closed object type") +let explain_incompatible_fields name (diff: Types.type_expr Errortrace.diff) = + reserve_names diff.got; + reserve_names diff.expected; + dprintf "@,@[The method %a has type@ %a,@ \ + but the expected method type was@ %a@]" + Style.inline_code name + (Style.as_inline_code type_expr_with_reserved_names) diff.got + (Style.as_inline_code type_expr_with_reserved_names) diff.expected + let explanation (type variety) intro prev env : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function | Errortrace.Diff {got; expected} -> @@ -2303,20 +2396,15 @@ let explanation (type variety) intro prev env match context, kind, prev with | Some ctx, _, _ -> reserve_names ctx; - dprintf "@[%t@;<1 2>%a@]" intro type_expr_with_reserved_names ctx + dprintf "@[%t@;<1 2>%a@]" intro + (Style.as_inline_code type_expr_with_reserved_names) ctx | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> - reserve_names diff.got; - reserve_names diff.expected; - dprintf "@,@[The method %s has type@ %a,@ \ - but the expected method type was@ %a@]" - name - type_expr_with_reserved_names diff.got - type_expr_with_reserved_names diff.expected + explain_incompatible_fields name diff | _ -> ignore in explain_escape pre kind - | Errortrace.Incompatible_fields { name; _ } -> - Some(dprintf "@,Types for method %s are incompatible" name) + | Errortrace.Incompatible_fields { name; diff} -> + Some(explain_incompatible_fields name diff) | Errortrace.Variant v -> explain_variant v | Errortrace.Obj o -> @@ -2331,7 +2419,8 @@ let explanation (type variety) intro prev env mark_loops x; mark_loops y; dprintf "@,@[The type variable %a occurs inside@ %a@]" - prepared_type_expr x prepared_type_expr y + (Style.as_inline_code prepared_type_expr) x + (Style.as_inline_code prepared_type_expr) y ppf) | _ -> (* We had a delayed unification of the type variable with @@ -2354,14 +2443,21 @@ let explain mis ppf = let warn_on_missing_def env ppf t = match get_desc t with | Tconstr (p,_,_) -> - begin - try - ignore(Env.find_type p env : Types.type_declaration) - with Not_found -> + begin match Env.find_type p env with + | exception Not_found -> fprintf ppf - "@,@[%a is abstract because no corresponding cmi file was found \ - in path.@]" path p - end + "@,@[Type %a is abstract because@ no corresponding\ + @ cmi file@ was found@ in path.@]" (Style.as_inline_code path) p + | { type_manifest = Some _; _ } -> () + | { type_manifest = None; _ } as decl -> + match type_origin decl with + | Rec_check_regularity -> + fprintf ppf + "@,@[Type %a was considered abstract@ when checking\ + @ constraints@ in this@ recursive type definition.@]" + (Style.as_inline_code path) p + | Definition | Existential _ -> () + end | _ -> () let prepare_expansion_head empty_tr = function @@ -2416,6 +2512,7 @@ let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = (explain mis); if env <> Env.empty then warn_on_missing_defs env ppf head; + Internal_names.print_explanations env ppf; Conflicts.print_explanations ppf; print_labels := true with exn -> diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml index 67afedcdbf..85a55016ac 100644 --- a/src/ocaml/typing/printtyped.ml +++ b/src/ocaml/typing/printtyped.ml @@ -109,6 +109,11 @@ let fmt_private_flag f x = | Public -> fprintf f "Public" | Private -> fprintf f "Private" +let fmt_partiality f x = + match x with + | Total -> () + | Partial -> fprintf f " (Partial)" + let line i f s (*...*) = fprintf f "%s" (String.make (2*i) ' '); fprintf f s (*...*) @@ -206,7 +211,7 @@ let rec core_type i ppf x = 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; + line i ppf "Ttyp_alias \"%s\"\n" s.txt; core_type i ppf ct; | Ttyp_poly (sl, ct) -> line i ppf "Ttyp_poly%a\n" @@ -215,6 +220,9 @@ let rec core_type i ppf x = | Ttyp_package { pack_path = s; pack_fields = l } -> line i ppf "Ttyp_package %a\n" fmt_path s; list i package_with ppf l; + | Ttyp_open (path, _mod_ident, t) -> + line i ppf "Ttyp_open %a\n" fmt_path path; + core_type i ppf t and package_with i ppf (s, t) = line i ppf "with type %a\n" fmt_longident s; @@ -232,8 +240,8 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> end; 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,_) -> + | 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; @@ -288,7 +296,22 @@ and pattern_extra i ppf (extra_pat, _, attrs) = line i ppf "Tpat_extra_open %a\n" fmt_path id; attributes i ppf attrs; -and expression_extra i ppf (x,_,attrs) = +and function_body i ppf (body : function_body) = + match[@warning "+9"] body with + | Tfunction_body e -> + line i ppf "Tfunction_body\n"; + expression (i+1) ppf e + | Tfunction_cases + { cases; loc; exp_extra; attributes = attrs; param = _; partial } + -> + line i ppf "Tfunction_cases%a %a\n" + fmt_partiality partial + fmt_location loc; + attributes (i+1) ppf attrs; + Option.iter (fun e -> expression_extra (i+1) ppf e []) exp_extra; + list (i+1) case ppf cases + +and expression_extra i ppf x attrs = match x with | Texp_constraint ct -> line i ppf "Texp_constraint\n"; @@ -317,7 +340,7 @@ and expression i ppf x = | [] -> () | extra -> line i ppf "extra\n"; - List.iter (expression_extra (i+1) ppf) extra; + List.iter (fun (x, _, attrs) -> expression_extra (i+1) ppf x attrs) extra; end; match x.exp_desc with | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li; @@ -327,16 +350,17 @@ and expression i ppf x = 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 = _; } -> + | Texp_function (params, body) -> line i ppf "Texp_function\n"; - arg_label i ppf p; - list i case ppf cases; + list i function_param ppf params; + function_body i ppf body; | 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"; + | Texp_match (e, l, partial) -> + line i ppf "Texp_match%a\n" + fmt_partiality partial; expression i ppf e; list i case ppf l; | Texp_try (e, l) -> @@ -427,8 +451,9 @@ and expression i ppf x = | 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"; + | Texp_letop {let_; ands; param = _; body; partial } -> + line i ppf "Texp_letop%a" + fmt_partiality partial; binding_op (i+1) ppf let_; list (i+1) binding_op ppf ands; case i ppf body @@ -457,6 +482,20 @@ and binding_op i ppf x = fmt_location x.bop_loc; expression i ppf x.bop_exp +and function_param i ppf x = + let p = x.fp_arg_label in + arg_label i ppf p; + match x.fp_kind with + | Tparam_pat pat -> + line i ppf "Param_pat%a\n" + fmt_partiality x.fp_partial; + pattern (i+1) ppf pat + | Tparam_optional_default (pat, expr) -> + line i ppf "Param_optional_default%a\n" + fmt_partiality x.fp_partial; + pattern (i+1) ppf pat; + expression (i+1) ppf expr + and type_parameter i ppf (x, _variance) = core_type i ppf x and type_declaration i ppf x = diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml index fb8966077c..2657058229 100644 --- a/src/ocaml/typing/shape.ml +++ b/src/ocaml/typing/shape.ml @@ -67,6 +67,8 @@ module Sig_component_kind = struct type t = | Value | Type + | Constructor + | Label | Module | Module_type | Extension_constructor @@ -76,6 +78,8 @@ module Sig_component_kind = struct let to_string = function | Value -> "value" | Type -> "type" + | Constructor -> "constructor" + | Label -> "label" | Module -> "module" | Module_type -> "module type" | Extension_constructor -> "extension constructor" @@ -87,6 +91,8 @@ module Sig_component_kind = struct | Extension_constructor -> false | Type + | Constructor + | Label | Module | Module_type | Class @@ -99,10 +105,15 @@ module Item = struct type t = string * Sig_component_kind.t let compare = compare + let name (name, _) = name + let kind (_, kind) = kind + let make str ns = str, ns let value id = Ident.name id, Sig_component_kind.Value let type_ id = Ident.name id, Sig_component_kind.Type + let constr id = Ident.name id, Sig_component_kind.Constructor + let label id = Ident.name id, Sig_component_kind.Label let module_ id = Ident.name id, Sig_component_kind.Module let module_type id = Ident.name id, Sig_component_kind.Module_type let extension_constructor id = @@ -124,24 +135,26 @@ module Item = struct end type var = Ident.t -type t = { uid: Uid.t option; desc: desc } +type t = { uid: Uid.t option; desc: desc; approximated: bool } and desc = | Var of var | Abs of var * t | App of t * t | Struct of t Item.Map.t + | Alias of t | Leaf | Proj of t * Item.t | Comp_unit of string + | Error of string -let print fmt = +let print fmt t = let print_uid_opt = Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print) in let rec aux fmt { uid; desc } = match desc with | Var id -> - Format.fprintf fmt "%a%a" Ident.print id print_uid_opt uid + Format.fprintf fmt "%s%a" (Ident.name id) print_uid_opt uid | Abs (id, t) -> let rec collect_idents = function | { uid = None; desc = Abs(id, t) } -> @@ -152,8 +165,9 @@ let print fmt = in let (other_idents, body) = collect_idents t in let pp_idents fmt idents = + let idents_names = List.map Ident.name idents in let pp_sep fmt () = Format.fprintf fmt ",@ " in - Format.pp_print_list ~pp_sep Ident.print fmt idents + Format.pp_print_list ~pp_sep Format.pp_print_string fmt idents_names in Format.fprintf fmt "Abs@[%a@,(@[%a,@ @[%a@]@])@]" print_uid_opt uid pp_idents (id :: other_idents) aux body @@ -183,350 +197,102 @@ let print fmt = aux t ) in - Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + if Item.Map.is_empty map then + Format.fprintf fmt "@[{%a}@]" print_uid_opt uid + else + Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + | Alias t -> + Format.fprintf fmt "Alias@[(@[%a@,%a@])@]" print_uid_opt uid aux t + | Error s -> + Format.fprintf fmt "Error %s" s in - Format.fprintf fmt"@[%a@]@;" aux + if t.approximated then + Format.fprintf fmt "@[(approx)@ %a@]@;" aux t + else + Format.fprintf fmt "@[%a@]@;" aux t + +let rec strip_head_aliases = function + | { desc = Alias t; _ } -> strip_head_aliases t + | t -> t let fresh_var ?(name="shape-var") uid = let var = Ident.create_local name in - var, { uid = Some uid; desc = Var var } + var, { uid = Some uid; desc = Var var; approximated = false } let for_unnamed_functor_param = Ident.create_local "()" let var uid id = - { uid = Some uid; desc = Var id } + { uid = Some uid; desc = Var id; approximated = false } let abs ?uid var body = - { uid; desc = Abs (var, body) } + { uid; desc = Abs (var, body); approximated = false } let str ?uid map = - { uid; desc = Struct map } + { uid; desc = Struct map; approximated = false } + +let alias ?uid t = + { uid; desc = Alias t; approximated = false} let leaf uid = - { uid = Some uid; desc = Leaf } + { uid = Some uid; desc = Leaf; approximated = false } + +let approx t = { t with approximated = true} let proj ?uid t item = match t.desc with | Leaf -> (* When stuck projecting in a leaf we propagate the leaf as a best effort *) - t + approx t | Struct map -> begin try Item.Map.find item map - with Not_found -> t (* ill-typed program *) + with Not_found -> approx t (* ill-typed program *) end | _ -> - { uid; desc = Proj (t, item) } + { uid; desc = Proj (t, item); approximated = false } let app ?uid f ~arg = - { uid; desc = App (f, arg) } + { uid; desc = App (f, arg); approximated = false } let decompose_abs t = match t.desc with | Abs (x, t) -> Some (x, t) | _ -> None - -module Make_reduce(Params : sig - type env - val fuel : int - val read_unit_shape : unit_name:string -> t option - val find_shape : env -> Ident.t -> t -end) = struct - (* We implement a strong call-by-need reduction, following an - evaluator from Nathanaelle Courant. *) - - type nf = { uid: Uid.t option; desc: nf_desc } - and nf_desc = - | NVar of var - | NApp of nf * nf - | NAbs of local_env * var * t * delayed_nf - | NStruct of delayed_nf Item.Map.t - | NProj of nf * Item.t - | NLeaf - | NComp_unit of string - | NoFuelLeft of desc - (* A type of normal forms for strong call-by-need evaluation. - The normal form of an abstraction - Abs(x, t) - is a closure - NAbs(env, x, t, dnf) - when [env] is the local environment, and [dnf] is a delayed - normal form of [t]. - - A "delayed normal form" is morally equivalent to (nf Lazy.t), but - we use a different representation that is compatible with - memoization (lazy values are not hashable/comparable by default - comparison functions): we represent a delayed normal form as - just a not-yet-computed pair [local_env * t] of a term in a - local environment -- we could also see this as a term under - an explicit substitution. This delayed thunked is "forced" - by calling the normalization function as usual, but duplicate - computations are precisely avoided by memoization. - *) - and delayed_nf = Thunk of local_env * t - - and local_env = delayed_nf option Ident.Map.t - (* When reducing in the body of an abstraction [Abs(x, body)], we - bind [x] to [None] in the environment. [Some v] is used for - actual substitutions, for example in [App(Abs(x, body), t)], when - [v] is a thunk that will evaluate to the normal form of [t]. *) - - let improve_uid uid (nf : nf) = - match nf.uid with - | Some _ -> nf - | None -> { nf with uid } - - let in_memo_table memo_table memo_key f arg = - match Hashtbl.find memo_table memo_key with - | res -> res - | exception Not_found -> - let res = f arg in - Hashtbl.replace memo_table memo_key res; - res - - type env = { - fuel: int ref; - global_env: Params.env; - local_env: local_env; - reduce_memo_table: (local_env * t, nf) Hashtbl.t; - read_back_memo_table: (nf, t) Hashtbl.t; - } - - let bind env var shape = - { env with local_env = Ident.Map.add var shape env.local_env } - - let rec reduce_ env t = - let memo_key = (env.local_env, t) in - in_memo_table env.reduce_memo_table memo_key (reduce__ env) t - (* Memoization is absolutely essential for performance on this - problem, because the normal forms we build can in some real-world - cases contain an exponential amount of redundancy. Memoization - can avoid the repeated evaluation of identical subterms, - providing a large speedup, but even more importantly it - implicitly shares the memory of the repeated results, providing - much smaller normal forms (that blow up again if printed back - as trees). A functor-heavy file from Irmin has its shape normal - form decrease from 100Mio to 2.5Mio when memoization is enabled. - - Note: the local environment is part of the memoization key, while - it is defined using a type Ident.Map.t of non-canonical balanced - trees: two maps could have exactly the same items, but be - balanced differently and therefore hash differently, reducing - the effectivenss of memoization. - This could in theory happen, say, with the two programs - (fun x -> fun y -> ...) - and - (fun y -> fun x -> ...) - having "the same" local environments, with additions done in - a different order, giving non-structurally-equal trees. Should we - define our own hash functions to provide robust hashing on - environments? - - We believe that the answer is "no": this problem does not occur - in practice. We can assume that identifiers are unique on valid - typedtree fragments (identifier "stamps" distinguish - binding positions); in particular the two program fragments above - in fact bind *distinct* identifiers x (with different stamps) and - different identifiers y, so the environments are distinct. If two - environments are structurally the same, they must correspond to - the evaluation evnrionments of two sub-terms that are under - exactly the same scope of binders. So the two environments were - obtained by the same term traversal, adding binders in the same - order, giving the same balanced trees: the environments have the - same hash. -*) - - and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) = - let reduce env t = reduce_ env t in - let delay_reduce env t = Thunk (env.local_env, t) in - let force (Thunk (local_env, t)) = - reduce { env with local_env } t in - let return desc : nf = { uid = t.uid; desc } in - if !fuel < 0 then return (NoFuelLeft t.desc) - else - match t.desc with - | Comp_unit unit_name -> - begin match Params.read_unit_shape ~unit_name with - | Some t -> reduce env t - | None -> return (NComp_unit unit_name) - end - | App(f, arg) -> - let f = reduce env f in - begin match f.desc with - | NAbs(clos_env, var, body, _body_nf) -> - let arg = delay_reduce env arg in - let env = bind { env with local_env = clos_env } var (Some arg) in - reduce env body - |> improve_uid t.uid - | _ -> - let arg = reduce env arg in - return (NApp(f, arg)) - end - | Proj(str, item) -> - let str = reduce env str in - let nored () = return (NProj(str, item)) in - begin match str.desc with - | NStruct (items) -> - begin match Item.Map.find item items with - | exception Not_found -> nored () - | nf -> - force nf - |> improve_uid t.uid - end - | _ -> - nored () - end - | Abs(var, body) -> - let body_nf = delay_reduce (bind env var None) body in - return (NAbs(local_env, var, body, body_nf)) - | Var id -> - begin match Ident.Map.find id local_env with - (* Note: instead of binding abstraction-bound variables to - [None], we could unify it with the [Some v] case by - binding the bound variable [x] to [NVar x]. - - One reason to distinguish the situations is that we can - provide a different [Uid.t] location; for bound - variables, we use the [Uid.t] of the bound occurrence - (not the binding site), whereas for bound values we use - their binding-time [Uid.t]. *) - | None -> return (NVar id) - | Some def -> force def - | exception Not_found -> - match Params.find_shape global_env id with - | exception Not_found -> return (NVar id) - | res when res = t -> return (NVar id) - | res -> - decr fuel; - reduce env res - end - | Leaf -> return NLeaf - | Struct m -> - let mnf = Item.Map.map (delay_reduce env) m in - return (NStruct mnf) - - let rec read_back env (nf : nf) : t = - in_memo_table env.read_back_memo_table nf (read_back_ env) nf - (* The [nf] normal form we receive may contain a lot of internal - sharing due to the use of memoization in the evaluator. We have - to memoize here again, otherwise the sharing is lost by mapping - over the term as a tree. *) - - and read_back_ env (nf : nf) : t = - { uid = nf.uid; desc = read_back_desc env nf.desc } - - and read_back_desc env desc = - let read_back nf = read_back env nf in - let read_back_force (Thunk (local_env, t)) = - read_back (reduce_ { env with local_env } t) in - match desc with - | NVar v -> - Var v - | NApp (nft, nfu) -> - App(read_back nft, read_back nfu) - | NAbs (_env, x, _t, nf) -> - Abs(x, read_back_force nf) - | NStruct nstr -> - Struct (Item.Map.map read_back_force nstr) - | NProj (nf, item) -> - Proj (read_back nf, item) - | NLeaf -> Leaf - | NComp_unit s -> Comp_unit s - | NoFuelLeft t -> t - - (* When in Merlin we don't need to perform full shape reduction since we are - only interested by uid's stored at the "top-level" of the shape once the - projections have been done. *) - let weak_read_back env (nf : nf) : t = - let cache = Hashtbl.create 42 in - let rec weak_read_back env nf = - let memo_key = (env.local_env, nf) in - in_memo_table cache memo_key (weak_read_back_ env) nf - and weak_read_back_ env nf : t = - { uid = nf.uid; desc = weak_read_back_desc env nf.desc } - and weak_read_back_desc env desc : desc = - let weak_read_back_no_force (Thunk (_local_env, t)) = t in - match desc with - | NVar v -> - Var v - | NApp (nft, nfu) -> - App(weak_read_back env nft, weak_read_back env nfu) - | NAbs (_env, x, _t, nf) -> - Abs(x, weak_read_back_no_force nf) - | NStruct nstr -> - Struct (Item.Map.map weak_read_back_no_force nstr) - | NProj (nf, item) -> - Proj (read_back env nf, item) - | NLeaf -> Leaf - | NComp_unit s -> Comp_unit s - | NoFuelLeft t -> t - in weak_read_back env nf - - let reduce global_env t = - let fuel = ref Params.fuel in - let reduce_memo_table = Hashtbl.create 42 in - let read_back_memo_table = Hashtbl.create 42 in - let local_env = Ident.Map.empty in - let env = { - fuel; - global_env; - reduce_memo_table; - read_back_memo_table; - local_env; - } in - reduce_ env t |> read_back env - - let weak_reduce global_env t = - let fuel = ref Params.fuel in - let reduce_memo_table = Hashtbl.create 42 in - let read_back_memo_table = Hashtbl.create 42 in - let local_env = Ident.Map.empty in - let env = { - fuel; - global_env; - reduce_memo_table; - read_back_memo_table; - local_env; - } in - reduce_ env t |> weak_read_back env -end - -module Local_reduce = - (* Note: this definition with [type env = unit] is only suitable for - reduction of toplevel shapes -- shapes of compilation units, - where free variables are only Comp_unit names. If we wanted to - reduce shapes inside module signatures, we would need to take - a typing environment as parameter. *) - Make_reduce(struct - type env = unit - let fuel = 10 - let read_unit_shape ~unit_name:_ = None - let find_shape _env _id = raise Not_found - end) - -let local_reduce shape = - Local_reduce.reduce () shape - -let dummy_mod = { uid = None; desc = Struct Item.Map.empty } - -let of_path ~find_shape ~namespace = +let dummy_mod = + { uid = None; desc = Struct Item.Map.empty; approximated = false } + +let of_path ~find_shape ~namespace path = + (* We need to handle the following cases: + Path of constructor: + M.t.C + Path of label: + M.t.lbl + Path of label of inline record: + M.t.C.lbl *) let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function | Pident id -> find_shape ns id - | Pdot (path, name) -> proj (aux Module path) (name, ns) + | Pdot (path, name) -> + let namespace : Sig_component_kind.t = + match (ns : Sig_component_kind.t) with + | Constructor -> Type + | Label -> Type + | _ -> Module + in + proj (aux namespace path) (name, ns) | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) | Pextra_ty (path, extra) -> begin match extra with - Pcstr_ty _ -> aux Type path + Pcstr_ty name -> proj (aux Type path) (name, Constructor) | Pext_ty -> aux Extension_constructor path end in - aux namespace + aux namespace path let for_persistent_unit s = { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s)); - desc = Comp_unit s } + desc = Comp_unit s; approximated = false } -let leaf_for_unpack = { uid = None; desc = Leaf } +let leaf_for_unpack = { uid = None; desc = Leaf; approximated = false } let set_uid_if_none t uid = match t.uid with @@ -546,11 +312,21 @@ module Map = struct let item = Item.value id in Item.Map.add item (proj shape item) t - let add_type t id uid = Item.Map.add (Item.type_ id) (leaf uid) t + let add_type t id shape = Item.Map.add (Item.type_ id) shape t let add_type_proj t id shape = let item = Item.type_ id in Item.Map.add item (proj shape item) t + let add_constr t id shape = Item.Map.add (Item.constr id) shape t + let add_constr_proj t id shape = + let item = Item.constr id in + Item.Map.add item (proj shape item) t + + let add_label t id uid = Item.Map.add (Item.label id) (leaf uid) t + let add_label_proj t id shape = + let item = Item.label id in + Item.Map.add item (proj shape item) t + let add_module t id shape = Item.Map.add (Item.module_ id) shape t let add_module_proj t id shape = let item = Item.module_ id in @@ -562,8 +338,8 @@ module Map = struct let item = Item.module_type id in Item.Map.add item (proj shape item) t - let add_extcons t id uid = - Item.Map.add (Item.extension_constructor id) (leaf uid) t + let add_extcons t id shape = + Item.Map.add (Item.extension_constructor id) shape t let add_extcons_proj t id shape = let item = Item.extension_constructor id in Item.Map.add item (proj shape item) t diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli index 9740a3ad2d..01b31d2575 100644 --- a/src/ocaml/typing/shape.mli +++ b/src/ocaml/typing/shape.mli @@ -13,6 +13,47 @@ (* *) (**************************************************************************) +(** Shapes are an abstract representation of modules' implementations which + allow the tracking of definitions through functor applications and other + module-level operations. + + The Shape of a compilation unit is elaborated during typing, partially + reduced (without loading external shapes) and written to the [cmt] file. + + External tools can retrieve the definition of any value (or type, or module, + etc) by following this procedure: + + - Build the Shape corresponding to the value's path: + [let shape = Env.shape_of_path ~namespace env path] + + - Instantiate the [Shape_reduce.Make] functor with a way to load shapes from + external units and to looks for shapes in the environment (usually using + [Env.shape_of_path]). + + - Completely reduce the shape: + [let shape = My_reduce.(weak_)reduce env shape] + + - The [Uid.t] stored in the reduced shape should be the one of the + definition. However, if the [approximate] field of the reduced shape is + [true] then the [Uid.t] will not correspond to the definition, but to the + closest parent module's uid. This happens when Shape reduction gets stuck, + for example when hitting first-class modules. + + - The location of the definition can be easily found with the + [cmt_format.cmt_uid_to_decl] table of the corresponding compilation unit. + + See: + - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling } + the design document} + - {{: https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf } + a talk about the reduction strategy +*) + +(** A [Uid.t] is associated to every declaration in signatures and + implementations. They uniquely identify bindings in the program. When + associated with these bindings' locations they are useful to external tools + when trying to jump to an identifier's declaration or definition. They are + stored to that effect in the [uid_to_decl] table of cmt files. *) module Uid : sig type t = private | Compilation_unit of string @@ -36,6 +77,8 @@ module Sig_component_kind : sig type t = | Value | Type + | Constructor + | Label | Module | Module_type | Extension_constructor @@ -48,35 +91,49 @@ module Sig_component_kind : sig val can_appear_in_types : t -> bool end +(** Shape's items are elements of a structure or, in the case of constructors + and labels, elements of a record or variants definition seen as a structure. + These structures model module components and nested types' constructors and + labels. *) module Item : sig - type t + type t = string * Sig_component_kind.t + val name : t -> string + val kind : t -> Sig_component_kind.t val make : string -> Sig_component_kind.t -> t val value : Ident.t -> t val type_ : Ident.t -> t + val constr : Ident.t -> t + val label : Ident.t -> t val module_ : Ident.t -> t val module_type : Ident.t -> t val extension_constructor : Ident.t -> t val class_ : Ident.t -> t val class_type : Ident.t -> t + val print : Format.formatter -> t -> unit + module Map : Map.S with type key = t end type var = Ident.t -type t = { uid: Uid.t option; desc: desc } +type t = { uid: Uid.t option; desc: desc; approximated: bool } and desc = | Var of var | Abs of var * t | App of t * t | Struct of t Item.Map.t + | Alias of t | Leaf | Proj of t * Item.t | Comp_unit of string + | Error of string val print : Format.formatter -> t -> unit +val strip_head_aliases : t -> t + (* Smart constructors *) val for_unnamed_functor_param : var @@ -86,6 +143,7 @@ val var : Uid.t -> Ident.t -> t val abs : ?uid:Uid.t -> var -> t -> t val app : ?uid:Uid.t -> t -> arg:t -> t val str : ?uid:Uid.t -> t Item.Map.t -> t +val alias : ?uid:Uid.t -> t -> t val proj : ?uid:Uid.t -> t -> Item.t -> t val leaf : Uid.t -> t @@ -105,16 +163,22 @@ module Map : sig val add_value : t -> Ident.t -> Uid.t -> t val add_value_proj : t -> Ident.t -> shape -> t - val add_type : t -> Ident.t -> Uid.t -> t + val add_type : t -> Ident.t -> shape -> t val add_type_proj : t -> Ident.t -> shape -> t + val add_constr : t -> Ident.t -> shape -> t + val add_constr_proj : t -> Ident.t -> shape -> t + + val add_label : t -> Ident.t -> Uid.t -> t + val add_label_proj : t -> Ident.t -> shape -> t + val add_module : t -> Ident.t -> shape -> t val add_module_proj : t -> Ident.t -> shape -> t val add_module_type : t -> Ident.t -> Uid.t -> t val add_module_type_proj : t -> Ident.t -> shape -> t - val add_extcons : t -> Ident.t -> Uid.t -> t + val add_extcons : t -> Ident.t -> shape -> t val add_extcons_proj : t -> Ident.t -> shape -> t val add_class : t -> Ident.t -> Uid.t -> t @@ -131,28 +195,3 @@ val of_path : namespace:Sig_component_kind.t -> Path.t -> t val set_uid_if_none : t -> Uid.t -> t - -(** The [Make_reduce] functor is used to generate a reduction function for - shapes. - - It is parametrized by: - - an environment and a function to find shapes by path in that environment - - a function to load the shape of an external compilation unit - - some fuel, which is used to bound recursion when dealing with recursive - shapes introduced by recursive modules. (FTR: merlin currently uses a - fuel of 10, which seems to be enough for most practical examples) -*) -module Make_reduce(Context : sig - type env - - val fuel : int - - val read_unit_shape : unit_name:string -> t option - - val find_shape : env -> Ident.t -> t - end) : sig - val reduce : Context.env -> t -> t - val weak_reduce : Context.env -> t -> t -end - -val local_reduce : t -> t diff --git a/src/ocaml/typing/shape_reduce.ml b/src/ocaml/typing/shape_reduce.ml new file mode 100644 index 0000000000..718b212133 --- /dev/null +++ b/src/ocaml/typing/shape_reduce.ml @@ -0,0 +1,347 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* Nathanaëlle Courant, OCamlPro *) +(* Gabriel Scherer, projet Picube, 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. *) +(* *) +(**************************************************************************) + +open Shape + +type result = + | Resolved of Uid.t + | Resolved_alias of Uid.t list + | Unresolved of t + | Approximated of Uid.t option + | Internal_error_missing_uid + +let print_result fmt result = + match result with + | Resolved uid -> + Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid + | Resolved_alias uids -> + Format.fprintf fmt "@[Resolved_alias: %a@]@;" + Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ -> ") + Uid.print) uids + | Unresolved shape -> + Format.fprintf fmt "@[Unresolved: %a@]@;" print shape + | Approximated (Some uid) -> + Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid + | Approximated None -> + Format.fprintf fmt "@[Approximated: No uid@]@;" + | Internal_error_missing_uid -> + Format.fprintf fmt "@[Missing uid@]@;" + + +let find_shape env id = + let namespace = Shape.Sig_component_kind.Module in + Env.shape_of_path ~namespace env (Pident id) + +module Make(Params : sig + val fuel : int + val read_unit_shape : unit_name:string -> t option +end) = struct + (* We implement a strong call-by-need reduction, following an + evaluator from Nathanaelle Courant. *) + + type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool } + and nf_desc = + | NVar of var + | NApp of nf * nf + | NAbs of local_env * var * t * delayed_nf + | NStruct of delayed_nf Item.Map.t + | NAlias of delayed_nf + | NProj of nf * Item.t + | NLeaf + | NComp_unit of string + | NError of string + + (* A type of normal forms for strong call-by-need evaluation. + The normal form of an abstraction + Abs(x, t) + is a closure + NAbs(env, x, t, dnf) + when [env] is the local environment, and [dnf] is a delayed + normal form of [t]. + + A "delayed normal form" is morally equivalent to (nf Lazy.t), but + we use a different representation that is compatible with + memoization (lazy values are not hashable/comparable by default + comparison functions): we represent a delayed normal form as + just a not-yet-computed pair [local_env * t] of a term in a + local environment -- we could also see this as a term under + an explicit substitution. This delayed thunked is "forced" + by calling the normalization function as usual, but duplicate + computations are precisely avoided by memoization. + *) + and delayed_nf = Thunk of local_env * t + + and local_env = delayed_nf option Ident.Map.t + (* When reducing in the body of an abstraction [Abs(x, body)], we + bind [x] to [None] in the environment. [Some v] is used for + actual substitutions, for example in [App(Abs(x, body), t)], when + [v] is a thunk that will evaluate to the normal form of [t]. *) + + let approx_nf nf = { nf with approximated = true } + + let in_memo_table memo_table memo_key f arg = + match Hashtbl.find memo_table memo_key with + | res -> res + | exception Not_found -> + let res = f arg in + Hashtbl.replace memo_table memo_key res; + res + + type env = { + fuel: int ref; + global_env: Env.t; + local_env: local_env; + reduce_memo_table: (local_env * t, nf) Hashtbl.t; + read_back_memo_table: (nf, t) Hashtbl.t; + } + + let bind env var shape = + { env with local_env = Ident.Map.add var shape env.local_env } + + let rec reduce_ env t = + let local_env = env.local_env in + let memo_key = (local_env, t) in + in_memo_table env.reduce_memo_table memo_key (reduce__ env) t + (* Memoization is absolutely essential for performance on this + problem, because the normal forms we build can in some real-world + cases contain an exponential amount of redundancy. Memoization + can avoid the repeated evaluation of identical subterms, + providing a large speedup, but even more importantly it + implicitly shares the memory of the repeated results, providing + much smaller normal forms (that blow up again if printed back + as trees). A functor-heavy file from Irmin has its shape normal + form decrease from 100Mio to 2.5Mio when memoization is enabled. + + Note: the local environment is part of the memoization key, while + it is defined using a type Ident.Map.t of non-canonical balanced + trees: two maps could have exactly the same items, but be + balanced differently and therefore hash differently, reducing + the effectivenss of memoization. + This could in theory happen, say, with the two programs + (fun x -> fun y -> ...) + and + (fun y -> fun x -> ...) + having "the same" local environments, with additions done in + a different order, giving non-structurally-equal trees. Should we + define our own hash functions to provide robust hashing on + environments? + + We believe that the answer is "no": this problem does not occur + in practice. We can assume that identifiers are unique on valid + typedtree fragments (identifier "stamps" distinguish + binding positions); in particular the two program fragments above + in fact bind *distinct* identifiers x (with different stamps) and + different identifiers y, so the environments are distinct. If two + environments are structurally the same, they must correspond to + the evaluation evnrionments of two sub-terms that are under + exactly the same scope of binders. So the two environments were + obtained by the same term traversal, adding binders in the same + order, giving the same balanced trees: the environments have the + same hash. +*) + + and reduce__ + ({fuel; global_env; local_env; _} as env) (t : t) = + let reduce env t = reduce_ env t in + let delay_reduce env t = Thunk (env.local_env, t) in + let force (Thunk (local_env, t)) = reduce { env with local_env } t in + let return desc = { uid = t.uid; desc; approximated = t.approximated } in + let rec force_aliases nf = match nf.desc with + | NAlias delayed_nf -> + let nf = force delayed_nf in + force_aliases nf + | _ -> nf + in + let reset_uid_if_new_binding t' = + match t.uid with + | None -> t' + | Some _ as uid -> { t' with uid } + in + if !fuel < 0 then approx_nf (return (NError "NoFuelLeft")) + else + match t.desc with + | Comp_unit unit_name -> + begin match Params.read_unit_shape ~unit_name with + | Some t -> reduce env t + | None -> return (NComp_unit unit_name) + end + | App(f, arg) -> + let f = reduce env f |> force_aliases in + begin match f.desc with + | NAbs(clos_env, var, body, _body_nf) -> + let arg = delay_reduce env arg in + let env = bind { env with local_env = clos_env } var (Some arg) in + reduce env body |> reset_uid_if_new_binding + | _ -> + let arg = reduce env arg in + return (NApp(f, arg)) + end + | Proj(str, item) -> + let str = reduce env str |> force_aliases in + let nored () = return (NProj(str, item)) in + begin match str.desc with + | NStruct (items) -> + begin match Item.Map.find item items with + | exception Not_found -> nored () + | nf -> force nf |> reset_uid_if_new_binding + end + | _ -> + nored () + end + | Abs(var, body) -> + let body_nf = delay_reduce (bind env var None) body in + return (NAbs(local_env, var, body, body_nf)) + | Var id -> + begin match Ident.Map.find id local_env with + (* Note: instead of binding abstraction-bound variables to + [None], we could unify it with the [Some v] case by + binding the bound variable [x] to [NVar x]. + + One reason to distinguish the situations is that we can + provide a different [Uid.t] location; for bound + variables, we use the [Uid.t] of the bound occurrence + (not the binding site), whereas for bound values we use + their binding-time [Uid.t]. *) + | None -> return (NVar id) + | Some def -> + begin match force def with + | { uid = Some _; _ } as nf -> nf + (* This var already has a binding uid *) + | { uid = None; _ } as nf -> { nf with uid = t.uid } + (* Set the var's binding uid *) + end + | exception Not_found -> + match find_shape global_env id with + | exception Not_found -> return (NVar id) + | res when res = t -> return (NVar id) + | res -> + decr fuel; + reduce env res + end + | Leaf -> return NLeaf + | Struct m -> + let mnf = Item.Map.map (delay_reduce env) m in + return (NStruct mnf) + | Alias t -> return (NAlias (delay_reduce env t)) + | Error s -> approx_nf (return (NError s)) + + and read_back env (nf : nf) : t = + in_memo_table env.read_back_memo_table nf (read_back_ env) nf + (* The [nf] normal form we receive may contain a lot of internal + sharing due to the use of memoization in the evaluator. We have + to memoize here again, otherwise the sharing is lost by mapping + over the term as a tree. *) + + and read_back_ env (nf : nf) : t = + { uid = nf.uid ; + desc = read_back_desc env nf.desc; + approximated = nf.approximated } + + and read_back_desc env desc = + let read_back nf = read_back env nf in + let read_back_force (Thunk (local_env, t)) = + read_back (reduce_ { env with local_env } t) in + match desc with + | NVar v -> + Var v + | NApp (nft, nfu) -> + App(read_back nft, read_back nfu) + | NAbs (_env, x, _t, nf) -> + Abs(x, read_back_force nf) + | NStruct nstr -> + Struct (Item.Map.map read_back_force nstr) + | NAlias nf -> Alias (read_back_force nf) + | NProj (nf, item) -> + Proj (read_back nf, item) + | NLeaf -> Leaf + | NComp_unit s -> Comp_unit s + | NError s -> Error s + + (* Sharing the memo tables is safe at the level of a compilation unit since + idents should be unique *) + let reduce_memo_table = Local_store.s_table Hashtbl.create 42 + let read_back_memo_table = Local_store.s_table Hashtbl.create 42 + + let reduce global_env t = + let fuel = ref Params.fuel in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table = !reduce_memo_table; + read_back_memo_table = !read_back_memo_table; + local_env; + } in + reduce_ env t |> read_back env + + let rec is_stuck_on_comp_unit (nf : nf) = + match nf.desc with + | NVar _ -> + (* This should not happen if we only reduce closed terms *) + false + | NApp (nf, _) | NProj (nf, _) -> is_stuck_on_comp_unit nf + | NStruct _ | NAbs _ -> false + | NAlias _ -> false + | NComp_unit _ -> true + | NError _ -> false + | NLeaf -> false + + let get_aliases_uids (t : t) = + let rec aux acc (t : t) = match t with + | { uid = Some uid; desc = Alias t; _ } -> aux (uid::acc) t + | { uid = Some uid; _ } -> Resolved_alias (List.rev (uid::acc)) + | _ -> Internal_error_missing_uid + in + aux [] t + + let reduce_for_uid global_env t = + let fuel = ref Params.fuel in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table = !reduce_memo_table; + read_back_memo_table = !read_back_memo_table; + local_env; + } in + let nf = reduce_ env t in + if is_stuck_on_comp_unit nf then + Unresolved (read_back env nf) + else match nf with + | { desc = NAlias _; approximated = false; _ } -> + get_aliases_uids (read_back env nf) + | { uid = Some uid; approximated = false; _ } -> + Resolved uid + | { uid; approximated = true; _ } -> + Approximated uid + | { uid = None; approximated = false; _ } -> + (* A missing Uid after a complete reduction means the Uid was first + missing in the shape which is a code error. Having the + [Missing_uid] reported will allow Merlin (or another tool working + with the index) to ask users to report the issue if it does happen. + *) + Internal_error_missing_uid +end + +module Local_reduce = + Make(struct + let fuel = 10 + let read_unit_shape ~unit_name:_ = None + end) + +let local_reduce = Local_reduce.reduce +let local_reduce_for_uid = Local_reduce.reduce_for_uid diff --git a/src/ocaml/typing/shape_reduce.mli b/src/ocaml/typing/shape_reduce.mli new file mode 100644 index 0000000000..5e409c3cd7 --- /dev/null +++ b/src/ocaml/typing/shape_reduce.mli @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* Nathanaëlle Courant, OCamlPro *) +(* Gabriel Scherer, projet Picube, 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. *) +(* *) +(**************************************************************************) + +(** The result of reducing a shape and looking for its uid *) +type result = + | Resolved of Shape.Uid.t (** Shape reduction succeeded and a uid was found *) + | Resolved_alias of Shape.Uid.t list (** Reduction led to an alias chain *) + | Unresolved of Shape.t (** Result still contains [Comp_unit] terms *) + | Approximated of Shape.Uid.t option + (** Reduction failed: it can arrive with first-clsss modules for example *) + | Internal_error_missing_uid + (** Reduction succeeded but no uid was found, this should never happen *) + +val print_result : Format.formatter -> result -> unit + +(** The [Make] functor is used to generate a reduction function for + shapes. + + It is parametrized by: + - a function to load the shape of an external compilation unit + - some fuel, which is used to bound recursion when dealing with recursive + shapes introduced by recursive modules. (FTR: merlin currently uses a + fuel of 10, which seems to be enough for most practical examples) + + Usage warning: To ensure good performances, every reduction made with the + same instance of that functor share the same ident-based memoization tables. + Such an instance should only be used to perform reduction inside a unique + compilation unit to prevent conflicting entries in these memoization tables. +*) +module Make(_ : sig + val fuel : int + + val read_unit_shape : unit_name:string -> Shape.t option + end) : sig + val reduce : Env.t -> Shape.t -> Shape.t + + (** Perform weak reduction and return the head's uid if any. If reduction was + incomplete the partially reduced shape is returned. *) + val reduce_for_uid : Env.t -> Shape.t -> result +end + +(** [local_reduce] will not reduce shapes that require loading external + compilation units. *) +val local_reduce : Env.t -> Shape.t -> Shape.t + +(** [local_reduce_for_uid] will not reduce shapes that require loading external + compilation units. *) +val local_reduce_for_uid : Env.t -> Shape.t -> result diff --git a/src/ocaml/typing/subst.ml b/src/ocaml/typing/subst.ml index deef66768e..de9bf07144 100644 --- a/src/ocaml/typing/subst.ml +++ b/src/ocaml/typing/subst.ml @@ -161,7 +161,68 @@ let norm = function | Tunivar None -> tunivar_none | d -> d -let ctype_apply_env_empty = ref (fun _ -> assert false) +let apply_type_function params args body = + For_copy.with_scope (fun copy_scope -> + List.iter2 + (fun param arg -> + For_copy.redirect_desc copy_scope param (Tsubst (arg, None))) + params args; + let rec copy ty = + assert (get_level ty = generic_level); + match get_desc ty with + | Tsubst (ty, _) -> ty + | Tvariant row -> + let t = newgenstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let more = row_more row in + assert (get_level more = generic_level); + let mored = get_desc more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + let desc' = + match mored with + | Tsubst (_, Some ty2) -> + (* This variant type has been already copied *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); + Tlink ty2 + | _ -> + let more' = + match mored with + Tsubst (ty, None) -> ty + (* TODO: is this case possible? + possibly an interaction with (copy more) below? *) + | Tconstr _ | Tnil -> + copy more + | Tvar _ | Tunivar _ -> + newgenty mored + | _ -> assert false + in + let row = + match get_desc more' with (* PR#6163 *) + Tconstr (x,_,_) when not (is_fixed row) -> + let Row {fields; more; closed; name} = row_repr row in + create_row ~fields ~more ~closed ~name + ~fixed:(Some (Reified x)) + | _ -> row + in + (* Register new type first for recursion *) + For_copy.redirect_desc copy_scope more + (Tsubst(more', Some t)); + (* Return a new copy *) + Tvariant (copy_row copy true row false more') + in + Transient_expr.set_stub_desc t desc'; + t + | desc -> + let t = newgenstub ~scope:(get_scope ty) in + For_copy.redirect_desc copy_scope ty (Tsubst (t, None)); + let desc' = copy_type_desc copy desc in + Transient_expr.set_stub_desc t desc'; + t + in + copy body) + (* Similar to [Ctype.nondep_type_rec]. *) let rec typexp copy_scope s ty = @@ -210,7 +271,7 @@ let rec typexp copy_scope s ty = | 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) + Tlink (apply_type_function params args body) end | Tpackage(p, fl) -> Tpackage(modtype_path s p, @@ -314,7 +375,7 @@ let type_declaration' copy_scope s decl = type_arity = decl.type_arity; type_kind = begin match decl.type_kind with - Type_abstract -> Type_abstract + Type_abstract r -> Type_abstract r | Type_variant (cstrs, rep) -> Type_variant (List.map (constructor_declaration copy_scope s) cstrs, rep) diff --git a/src/ocaml/typing/subst.mli b/src/ocaml/typing/subst.mli index 3a1c85c871..d278d01c24 100644 --- a/src/ocaml/typing/subst.mli +++ b/src/ocaml/typing/subst.mli @@ -85,11 +85,6 @@ val module_declaration: scoping -> t -> module_declaration -> module_declaration 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 - - module Lazy : sig type module_decl = { diff --git a/src/ocaml/typing/tast_iterator.ml b/src/ocaml/typing/tast_iterator.ml index 049dded4ff..6831fc1783 100644 --- a/src/ocaml/typing/tast_iterator.ml +++ b/src/ocaml/typing/tast_iterator.ml @@ -62,6 +62,7 @@ type iterator = value_bindings: iterator -> (rec_flag * value_binding list) -> unit; value_description: iterator -> value_description -> unit; with_constraint: iterator -> with_constraint -> unit; + item_declaration: iterator -> item_declaration -> unit; } let iter_snd f (_, y) = f y @@ -92,18 +93,23 @@ let class_infos sub f x = f x.ci_expr let module_type_declaration sub x = + sub.item_declaration sub (Module_type x); sub.location sub x.mtd_loc; sub.attributes sub x.mtd_attributes; iter_loc sub x.mtd_name; Option.iter (sub.module_type sub) x.mtd_type -let module_declaration sub {md_loc; md_name; md_type; md_attributes; _} = +let module_declaration sub md = + let {md_loc; md_name; md_type; md_attributes; _} = md in + sub.item_declaration sub (Module md); sub.location sub md_loc; sub.attributes sub md_attributes; iter_loc sub md_name; sub.module_type sub md_type -let module_substitution sub {ms_loc; ms_name; ms_txt; ms_attributes; _} = +let module_substitution sub ms = + let {ms_loc; ms_name; ms_txt; ms_attributes; _} = ms in + sub.item_declaration sub (Module_substitution ms); sub.location sub ms_loc; sub.attributes sub ms_attributes; iter_loc sub ms_name; @@ -115,9 +121,11 @@ let include_infos sub f {incl_loc; incl_mod; incl_attributes; _} = f incl_mod let class_type_declaration sub x = + sub.item_declaration sub (Class_type x); class_infos sub (sub.class_type sub) x let class_declaration sub x = + sub.item_declaration sub (Class x); class_infos sub (sub.class_expr sub) x let structure_item sub {str_loc; str_desc; str_env; _} = @@ -143,12 +151,14 @@ let structure_item sub {str_loc; str_desc; str_env; _} = | Tstr_attribute attr -> sub.attribute sub attr let value_description sub x = + sub.item_declaration sub (Value x); sub.location sub x.val_loc; sub.attributes sub x.val_attributes; iter_loc sub x.val_name; sub.typ sub x.val_desc -let label_decl sub {ld_loc; ld_name; ld_type; ld_attributes; _} = +let label_decl sub ({ld_loc; ld_name; ld_type; ld_attributes; _} as ld) = + sub.item_declaration sub (Label ld); sub.location sub ld_loc; sub.attributes sub ld_attributes; iter_loc sub ld_name; @@ -159,6 +169,7 @@ let constructor_args sub = function | Cstr_record l -> List.iter (label_decl sub) l let constructor_decl sub x = + sub.item_declaration sub (Constructor x); sub.location sub x.cd_loc; sub.attributes sub x.cd_attributes; iter_loc sub x.cd_name; @@ -173,6 +184,7 @@ let type_kind sub = function | Ttype_open -> () let type_declaration sub x = + sub.item_declaration sub (Type x); sub.location sub x.typ_loc; sub.attributes sub x.typ_attributes; iter_loc sub x.typ_name; @@ -200,7 +212,9 @@ let type_exception sub {tyexn_loc; tyexn_constructor; tyexn_attributes; _} = sub.attributes sub tyexn_attributes; sub.extension_constructor sub tyexn_constructor -let extension_constructor sub {ext_loc; ext_name; ext_kind; ext_attributes; _} = +let extension_constructor sub ec = + let {ext_loc; ext_name; ext_kind; ext_attributes; _} = ec in + sub.item_declaration sub (Extension_constructor ec); sub.location sub ext_loc; sub.attributes sub ext_attributes; iter_loc sub ext_name; @@ -229,7 +243,7 @@ let pat List.iter (pat_extra sub) extra; match pat_desc with | Tpat_any -> () - | Tpat_var (_, s) -> iter_loc sub s + | Tpat_var (_, s, _) -> iter_loc sub s | Tpat_constant _ -> () | Tpat_tuple l -> List.iter (sub.pat sub) l | Tpat_construct (lid, _, l, vto) -> @@ -241,7 +255,7 @@ let pat | Tpat_record (l, _) -> List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l | Tpat_array l -> List.iter (sub.pat sub) l - | Tpat_alias (p, _, s) -> sub.pat sub p; iter_loc sub s + | Tpat_alias (p, _, s, _) -> sub.pat sub p; iter_loc sub s | Tpat_lazy p -> sub.pat sub p | Tpat_value p -> sub.pat sub (p :> pattern) | Tpat_exception p -> sub.pat sub p @@ -249,16 +263,36 @@ let pat sub.pat sub p1; sub.pat sub p2 +let extra sub = 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 + +let function_param sub fp = + sub.location sub fp.fp_loc; + match fp.fp_kind with + | Tparam_pat pat -> sub.pat sub pat + | Tparam_optional_default (pat, default_arg) -> + sub.pat sub pat; + sub.expr sub default_arg + +let function_body sub body = + match[@warning "+9"] body with + | Tfunction_body body -> + sub.expr sub body + | Tfunction_cases + { cases; loc; exp_extra; attributes; partial = _; param = _ } + -> + List.iter (sub.case sub) cases; + sub.location sub loc; + Option.iter (extra sub) exp_extra; + sub.attributes sub attributes + let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = - 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 + let extra x = extra sub x in sub.location sub exp_loc; sub.attributes sub exp_attributes; List.iter (fun (e, loc, _) -> extra e; sub.location sub loc) exp_extra; @@ -269,8 +303,9 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | 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_function (params, body) -> + List.iter (function_param sub) params; + function_body sub body | Texp_apply (exp, list) -> sub.expr sub exp; List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list @@ -379,6 +414,7 @@ let signature_item sub {sig_loc; sig_desc; sig_env; _} = | Tsig_attribute _ -> () let class_description sub x = + sub.item_declaration sub (Class_type x); class_infos sub (sub.class_type sub) x let functor_parameter sub = function @@ -464,7 +500,8 @@ let module_expr sub {mod_loc; mod_desc; mod_env; mod_attributes; _} = sub.module_coercion sub c | Tmod_unpack (exp, _) -> sub.expr sub exp -let module_binding sub {mb_loc; mb_name; mb_expr; mb_attributes; _} = +let module_binding sub ({mb_loc; mb_name; mb_expr; mb_attributes; _} as mb) = + sub.item_declaration sub (Module_binding mb); sub.location sub mb_loc; sub.attributes sub mb_attributes; iter_loc sub mb_name; @@ -551,6 +588,9 @@ let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = | 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 + | Ttyp_open (_, mod_ident, t) -> + iter_loc sub mod_ident; + sub.typ sub t let class_structure sub {cstr_self; cstr_fields; _} = sub.pat sub cstr_self; @@ -594,7 +634,8 @@ let case sub {c_lhs; c_guard; c_rhs} = Option.iter (sub.expr sub) c_guard; sub.expr sub c_rhs -let value_binding sub {vb_loc; vb_pat; vb_expr; vb_attributes; _} = +let value_binding sub ({vb_loc; vb_pat; vb_expr; vb_attributes; _} as vb) = + sub.item_declaration sub (Value_binding vb); sub.location sub vb_loc; sub.attributes sub vb_attributes; sub.pat sub vb_pat; @@ -602,6 +643,8 @@ let value_binding sub {vb_loc; vb_pat; vb_expr; vb_attributes; _} = let env _sub _ = () +let item_declaration _sub _ = () + let default_iterator = { attribute; @@ -648,4 +691,5 @@ let default_iterator = value_bindings; value_description; with_constraint; + item_declaration; } diff --git a/src/ocaml/typing/tast_iterator.mli b/src/ocaml/typing/tast_iterator.mli index 96352fc351..38cd4eac94 100644 --- a/src/ocaml/typing/tast_iterator.mli +++ b/src/ocaml/typing/tast_iterator.mli @@ -66,6 +66,7 @@ type iterator = value_bindings: iterator -> (rec_flag * value_binding list) -> unit; value_description: iterator -> value_description -> unit; with_constraint: iterator -> with_constraint -> unit; + item_declaration: iterator -> item_declaration -> unit; } val default_iterator: iterator diff --git a/src/ocaml/typing/tast_mapper.ml b/src/ocaml/typing/tast_mapper.ml index 500c07c4ab..bcb0461741 100644 --- a/src/ocaml/typing/tast_mapper.ml +++ b/src/ocaml/typing/tast_mapper.ml @@ -279,7 +279,7 @@ let pat match x.pat_desc with | Tpat_any | Tpat_constant _ -> x.pat_desc - | Tpat_var (id, s) -> Tpat_var (id, map_loc sub s) + | Tpat_var (id, s, uid) -> Tpat_var (id, map_loc sub s, uid) | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) | Tpat_construct (loc, cd, l, vto) -> let vto = Option.map (fun (vl,cty) -> @@ -290,7 +290,8 @@ let pat | Tpat_record (l, closed) -> Tpat_record (List.map (tuple3 (map_loc sub) 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, map_loc sub s) + | Tpat_alias (p, id, s, uid) -> + Tpat_alias (sub.pat sub p, id, map_loc sub s, uid) | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) | Tpat_value p -> (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc @@ -302,16 +303,45 @@ let pat let pat_attributes = sub.attributes sub x.pat_attributes in {x with pat_loc; pat_extra; pat_desc; pat_env; pat_attributes} -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) +let function_param sub fp = + let fp_kind = + match fp.fp_kind with + | Tparam_pat pat -> Tparam_pat (sub.pat sub pat) + | Tparam_optional_default (pat, expr) -> + let pat = sub.pat sub pat in + let expr = sub.expr sub expr in + Tparam_optional_default (pat, expr) in + let fp_loc = sub.location sub fp.fp_loc in + { fp_kind; + fp_param = fp.fp_param; + fp_arg_label = fp.fp_arg_label; + fp_partial = fp.fp_partial; + fp_newtypes = fp.fp_newtypes; + fp_loc; + } + +let extra sub = 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 _ | Texp_newtype' _) as d -> d + | Texp_poly cto -> Texp_poly (Option.map (sub.typ sub) cto) + +let function_body sub body = + match body with + | Tfunction_body body -> + Tfunction_body (sub.expr sub body) + | Tfunction_cases { cases; partial; param; loc; exp_extra; attributes } -> + let loc = sub.location sub loc in + let cases = List.map (sub.case sub) cases in + let exp_extra = Option.map (extra sub) exp_extra in + let attributes = sub.attributes sub attributes in + Tfunction_cases { cases; partial; param; loc; exp_extra; attributes } + +let expr sub x = + let extra x = extra sub x in let exp_loc = sub.location sub x.exp_loc in let exp_extra = List.map (tuple3 extra (sub.location sub) id) x.exp_extra in let exp_env = sub.env sub x.exp_env in @@ -323,9 +353,10 @@ let expr sub x = | 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_function (params, body) -> + let params = List.map (function_param sub) params in + let body = function_body sub body in + Texp_function (params, body) | Texp_apply (exp, list) -> Texp_apply ( sub.expr sub exp, @@ -752,6 +783,8 @@ let typ sub x = Ttyp_poly (sl, sub.typ sub ct) | Ttyp_package pack -> Ttyp_package (sub.package_type sub pack) + | Ttyp_open (path, mod_ident, t) -> + Ttyp_open (path, map_loc sub mod_ident, sub.typ sub t) in let ctyp_attributes = sub.attributes sub x.ctyp_attributes in {x with ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes} @@ -825,7 +858,8 @@ 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 let vb_attributes = sub.attributes sub x.vb_attributes in - {vb_loc; vb_pat; vb_expr; vb_attributes} + let vb_rec_kind = x.vb_rec_kind in + {vb_loc; vb_pat; vb_expr; vb_attributes; vb_rec_kind} let env _sub x = x diff --git a/src/ocaml/typing/typeclass.ml b/src/ocaml/typing/typeclass.ml index 82b8c55251..0c14185f47 100644 --- a/src/ocaml/typing/typeclass.ml +++ b/src/ocaml/typing/typeclass.ml @@ -21,6 +21,7 @@ open Typecore open Typetexp open Format + type 'a class_info = { cls_id : Ident.t; cls_id_loc : string loc; @@ -268,9 +269,15 @@ let type_constraint val_env sty sty' loc = 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 pat = + Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)) + in + Exp.function_ ~loc:expr.pexp_loc + [ { pparam_desc = Pparam_val (Nolabel, None, pat); + pparam_loc = pat.ppat_loc; + } + ] + None (Pfunction_body expr) (*******************************) @@ -772,7 +779,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = 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 _, ty1' = Ctype.instance_poly ~fixed:false tl ty1 in let ty2 = type_approx val_env sbody in Ctype.unify val_env ty2 ty1' | _ -> assert false @@ -1175,7 +1182,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = in let partial = let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in - Typecore.check_partial Modules_rejected val_env pat.pat_type pat.pat_loc + Typecore.check_partial val_env pat.pat_type pat.pat_loc [{c_lhs = pat; c_guard = None; c_rhs = dummy}] in let cl = @@ -1302,7 +1309,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = 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) -> + (fun (id, _id_loc, _typ, _uid) (vals, met_env) -> let path = Pident id in (* do not mark the value as used *) let vd = Env.find_value path val_env in @@ -1335,8 +1342,9 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = ([], met_env) in let cl = class_expr cl_num val_env met_env virt self_scope scl' in - let () = if rec_flag = Recursive then - check_recursive_bindings val_env defs + let defs = match rec_flag with + | Recursive -> annotate_recursive_bindings val_env defs + | Nonrecursive -> defs in rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl); cl_loc = scl.pcl_loc; @@ -1440,7 +1448,7 @@ let temp_abbrev loc arity uid = let ty_td = {type_params = !params; type_arity = arity; - type_kind = Type_abstract; + type_kind = Type_abstract Definition; type_private = Public; type_manifest = Some ty; type_variance = Variance.unknown_signature ~injective:false ~arity; @@ -1664,7 +1672,7 @@ let class_infos define_class kind { type_params = obj_params; type_arity = arity; - type_kind = Type_abstract; + type_kind = Type_abstract Definition; type_private = Public; type_manifest = Some obj_ty; type_variance = Variance.unknown_signature ~injective:false ~arity; @@ -1974,12 +1982,19 @@ let approx_class_declarations env sdecls = open Format -let non_virtual_string_of_kind = function +let non_virtual_string_of_kind : kind -> string = function | Object -> "object" | Class -> "non-virtual class" | Class_type -> "non-virtual class type" -let report_error env ppf = function +module Style=Misc.Style + +let report_error env ppf = + let pp_args ppf args = + let args = List.map (Printtyp.tree_of_typexp Type) args in + Style.as_inline_code !Oprint.out_type_args ppf args + in + function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" | Unconsistent_constraint err -> @@ -1991,50 +2006,58 @@ let report_error env ppf = function | Field_type_mismatch (k, m, err) -> Printtyp.report_unification_error ppf env err (function ppf -> - fprintf ppf "The %s %s@ has type" k m) + fprintf ppf "The %s %a@ has type" k Style.inline_code m) (function ppf -> fprintf ppf "but is expected to have type") | Unexpected_field (ty, lab) -> fprintf ppf "@[@[<2>This object is expected to have type :@ %a@]\ - @ This type does not have a method %s." - Printtyp.type_expr ty lab + @ This type does not have a method %a." + (Style.as_inline_code Printtyp.type_expr) ty + Style.inline_code lab | Structure_expected clty -> fprintf ppf "@[This class expression is not a class structure; it has type@ %a@]" - Printtyp.class_type clty + (Style.as_inline_code 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) + let mark_label ppf = function + | Nolabel -> fprintf ppf "without label" + | l -> fprintf ppf "with label %a" + Style.inline_code (Btype.prefixed_label_name l) + in + fprintf ppf "This argument cannot be applied %a" 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 + (Style.as_inline_code Printtyp.type_expr) ty | Unbound_class_2 cl -> fprintf ppf "@[The class@ %a@ is not yet completely defined@]" - Printtyp.longident cl + (Style.as_inline_code Printtyp.longident) cl | Unbound_class_type_2 cl -> fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" - Printtyp.longident cl + (Style.as_inline_code Printtyp.longident) cl | Abbrev_type_clash (abbrev, actual, expected) -> (* XXX Afficher une trace ? | Print a trace? *) Printtyp.prepare_for_printing [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 Type abbrev) - !Oprint.out_type (Printtyp.tree_of_typexp Type actual) - !Oprint.out_type (Printtyp.tree_of_typexp Type expected) + (Style.as_inline_code !Oprint.out_type) + (Printtyp.tree_of_typexp Type abbrev) + (Style.as_inline_code !Oprint.out_type) + (Printtyp.tree_of_typexp Type actual) + (Style.as_inline_code !Oprint.out_type) + (Printtyp.tree_of_typexp Type expected) | Constructor_type_mismatch (c, err) -> Printtyp.report_unification_error ppf env err (function ppf -> - fprintf ppf "The expression \"new %s\" has type" c) + fprintf ppf "The expression %a has type" + Style.inline_code ("new " ^ c) + ) (function ppf -> fprintf ppf "but is used with type") | Virtual_class (kind, mets, vals) -> @@ -2049,18 +2072,18 @@ let report_error env ppf = function "@[This %s has virtual %s.@ \ @[<2>The following %s are virtual : %a@]@]" kind missings missings - (pp_print_list ~pp_sep:pp_print_space pp_print_string) (mets @ vals) + (pp_print_list ~pp_sep:pp_print_space Style.inline_code) (mets @ vals) | Undeclared_methods(kind, mets) -> let kind = non_virtual_string_of_kind kind in fprintf ppf "@[This %s has undeclared virtual methods.@ \ @[<2>The following methods were not declared : %a@]@]" - kind (pp_print_list ~pp_sep:pp_print_space pp_print_string) mets + kind (pp_print_list ~pp_sep:pp_print_space Style.inline_code) mets | 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 + (Style.as_inline_code Printtyp.longident) lid expected provided | Parameter_mismatch err -> Printtyp.report_unification_error ppf env err (function ppf -> @@ -2072,22 +2095,23 @@ let report_error env ppf = function fprintf ppf "@[The abbreviation %a@ is used with parameter(s)@ %a@ \ which are incompatible with constraint(s)@ %a@]" - Printtyp.ident id - !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) params) - !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) cstrs) + (Style.as_inline_code Printtyp.ident) id + pp_args params + pp_args cstrs | Bad_class_type_parameters (id, params, cstrs) -> + let pp_hash ppf id = fprintf ppf "#%a" Printtyp.ident id in Printtyp.prepare_for_printing (params @ cstrs); fprintf ppf - "@[The class type #%a@ is used with parameter(s)@ %a,@ \ + "@[The class type %a@ is used with parameter(s)@ %a,@ \ whereas the class type definition@ constrains@ \ those parameters to be@ %a@]" - Printtyp.ident id - !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) params) - !Oprint.out_type_args (List.map (Printtyp.tree_of_typexp Type) cstrs) + (Style.as_inline_code pp_hash) id + pp_args params + pp_args cstrs | Class_match_failure error -> Includeclass.report_error Type ppf error | Unbound_val lab -> - fprintf ppf "Unbound instance variable %s" lab + fprintf ppf "Unbound instance variable %a" Style.inline_code lab | Unbound_type_var (printer, reason) -> let print_reason ppf { Ctype.free_variable; meth; meth_ty; } = let (ty0, kind) = free_variable in @@ -2098,11 +2122,12 @@ let report_error env ppf = function in Printtyp.add_type_to_preparation meth_ty; Printtyp.add_type_to_preparation ty1; + let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in fprintf ppf - "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound" - meth - !Oprint.out_type (Printtyp.tree_of_typexp Type meth_ty) - !Oprint.out_type (Printtyp.tree_of_typexp Type ty0) + "The method %a@ has type@;<1 2>%a@ where@ %a@ is unbound" + Style.inline_code meth + pp_type (Printtyp.tree_of_typexp Type meth_ty) + pp_type (Printtyp.tree_of_typexp Type ty0) in fprintf ppf "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ @@ -2114,9 +2139,10 @@ let report_error env ppf = function fprintf ppf "@[The type of this class,@ %a,@ \ contains the non-generalizable type variable(s): %a.@ %a@]" - (Printtyp.class_declaration id) clty + (Style.as_inline_code @@ Printtyp.class_declaration id) clty (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") - Printtyp.prepared_type_scheme) nongen_vars + (Style.as_inline_code Printtyp.prepared_type_scheme) + ) nongen_vars Misc.print_see_manual manual_ref | Cannot_coerce_self ty -> @@ -2124,12 +2150,12 @@ let report_error env ppf = function "@[The type of self cannot be coerced to@ \ the type of the current class:@ %a.@.\ Some occurrences are contravariant@]" - Printtyp.type_scheme ty + (Style.as_inline_code Printtyp.type_scheme) ty | Non_collapsable_conjunction (id, clty, err) -> fprintf ppf "@[The type of this class,@ %a,@ \ contains non-collapsible conjunctive types in constraints.@ %t@]" - (Printtyp.class_declaration id) clty + (Style.as_inline_code @@ Printtyp.class_declaration id) clty (fun ppf -> Printtyp.report_unification_error ppf env err (fun ppf -> fprintf ppf "Type") (fun ppf -> fprintf ppf "is not compatible with type") @@ -2148,19 +2174,23 @@ let report_error env ppf = function "@[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" + fprintf ppf + "@[This inheritance does not override any methods@ \ + or instance variables@ but is explicitly marked as@ \ + overriding with %a.@]" + Style.inline_code "!" | No_overriding (kind, name) -> - fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name + fprintf ppf "@[The %s %a@ has no previous definition@]" kind + Style.inline_code name | Duplicate (kind, name) -> - fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]" - kind name + fprintf ppf "@[The %s %a@ has multiple definitions in this object@]" + kind Style.inline_code name | Closing_self_type sign -> 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 sign.csig_self + (Style.as_inline_code Printtyp.type_scheme) sign.csig_self let report_error env ppf err = Printtyp.wrap_printing_env ~error:true diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index 5240dd01f3..e579f4ee27 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -15,6 +15,9 @@ (* Typechecking for the core language *) +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + open Misc open Asttypes open Parsetree @@ -25,6 +28,8 @@ open Ctype let raise_error = Msupport.raise_error +module Style = Misc.Style + type type_forcing_context = | If_conditional | If_no_else_branch @@ -72,6 +77,10 @@ type wrong_kind_sort = | List | Unit +type contains_gadt = + | Contains_gadt + | No_gadt + let wrong_kind_sort_of_constructor (lid : Longident.t) = match lid with | Lident "true" | Lident "false" | Ldot(_, "true") | Ldot(_, "false") -> @@ -100,6 +109,24 @@ type error = | Expr_type_clash of Errortrace.unification_error * type_forcing_context option * Parsetree.expression_desc option + | Function_arity_type_clash of + { syntactic_arity : int; + type_constraint : type_expr; + trace : Errortrace.unification_error; + } + (* [Function_arity_type_clash { syntactic_arity = n; type_constraint; trace }] + is the type error for the specific case where an n-ary function is + constrained at a type with an arity less than n, e.g.: + {[ + type (_, _) eq = Eq : ('a, 'a) eq + let bad : type a. ?opt:(a, int -> int) eq -> unit -> a = + fun ?opt:(Eq = assert false) () x -> x + 1 + ]} + + [type_constraint] is the user-written polymorphic type (in this example + [?opt:(a, int -> int) eq -> unit -> a]) that causes this type clash, and + [trace] is the unification error that signaled the issue. + *) | Apply_non_function of { funct : Typedtree.expression; func_ty : type_expr; @@ -144,7 +171,7 @@ type error = | Modules_not_allowed | Cannot_infer_signature | Not_a_packed_module of type_expr - | Unexpected_existential of existential_restriction * string * string list + | Unexpected_existential of existential_restriction * string | Invalid_interval | Invalid_for_loop_index | No_value_clauses @@ -327,16 +354,6 @@ type recarg = | Required | Rejected -(* Whether or not patterns of the form (module M) are accepted. (If they are, - the idents will be created at the provided scope.) When module patterns are - allowed, the caller should take care to check that the introduced module - bindings' types don't escape their scope; see the callsites in [type_let] - and [type_cases] for examples. -*) -type module_patterns_restriction = - | Modules_allowed of { scope : int } - | Modules_rejected - let mk_expected ?explanation ty = { ty; explanation; } let case lhs rhs = @@ -464,49 +481,45 @@ let unify_exp_types loc env ty expected_ty = | 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 +(* helper notation for Pattern_env.t *) +let (!!) (penv : Pattern_env.t) = penv.env -let nothing_equated = TypePairs.create 0 +(* Unification inside type_pat *) +let unify_pat_types loc env ty ty' = + try unify env ty ty' with + | Unify err -> + raise(Error(loc, env, Pattern_type_clash(err, None))) + | Tags(l1,l2) -> + raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) -(* unification inside type_pat*) -let unify_pat_types_return_equated_pairs ?(refine = None) loc env ty ty' = +(* GADT unification inside solve_Ppat_construct and check_counter_example_pat *) +let nothing_equated = TypePairs.create 0 +let unify_pat_types_return_equated_pairs ~refine loc penv ty ty' = try - match refine with - | Some allow_recursive_equations -> - unify_gadt ~equations_level:(get_gadt_equations_level ()) - ~allow_recursive_equations env ty ty' - | None -> - unify !env ty ty'; - nothing_equated + if refine then unify_gadt penv ty ty' + else (unify !!penv ty ty'; nothing_equated) with | Unify err -> - raise(error(loc, !env, Pattern_type_clash(err, None))) + raise(error(loc, !!penv, Pattern_type_clash(err, 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') - + raise(Typetexp.Error(loc, !!penv, Typetexp.Variant_tags (l1, l2))) +let unify_pat_types_refine ~refine loc penv ty ty' = + ignore (unify_pat_types_return_equated_pairs ~refine loc penv ty ty') (** [sdesc_for_hint] is used by error messages to report literals in their original formatting *) -let unify_pat ?refine ?sdesc_for_hint env pat expected_ty = - try unify_pat_types ?refine pat.pat_loc env pat.pat_type expected_ty +let unify_pat ?sdesc_for_hint env pat expected_ty = + try unify_pat_types pat.pat_loc env pat.pat_type expected_ty with Error (loc, env, Pattern_type_clash(err, None)) -> raise(error(loc, env, Pattern_type_clash(err, sdesc_for_hint))) (* unification of a type with a Tconstr with freshly created arguments *) -let unify_head_only ~refine loc env ty constr = +let unify_head_only ~refine loc penv ty constr = let path = cstr_type_path constr in - let decl = Env.find_type path !env in + let decl = Env.find_type path !!penv in let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in - unify_pat_types ~refine loc env ty' ty + unify_pat_types_refine ~refine loc penv ty' ty (* Creating new conjunctive types is not allowed when typing patterns *) (* make all Reither present in open variants *) @@ -524,8 +537,7 @@ let finalize_variant pat tag opat r = | Reither (false, ty::tl, _) when not (row_closed row) -> link_row_field_ext ~inside:f (rf_present (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) + | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) end | Reither (c, _l, true) when not (has_fixed_explanation row) -> link_row_field_ext ~inside:f (rf_either [] ~no_arg:c ~matched:false) @@ -549,7 +561,9 @@ let finalize_variants p = finalize_variant p tag opat r | _ -> () } p -(* pattern environment *) +(* [type_pat_state] and related types for pattern environment; + these should not be confused with Pattern_env.t, which is a part of the + interface to unification functions in [Ctype] *) type pattern_variable = { pv_id: Ident.t; @@ -557,6 +571,7 @@ type pattern_variable = pv_loc: Location.t; pv_as_var: bool; pv_attributes: attributes; + pv_uid : Uid.t; } type module_variable = @@ -567,15 +582,73 @@ type module_variable = mv_uid: Uid.t } -let pattern_variables = ref ([] : pattern_variable list) -let pattern_force = ref ([] : (unit -> unit) list) -let allow_modules = ref Modules_rejected -let module_variables = ref ([] : module_variable list) -let reset_pattern allow = - pattern_variables := []; - pattern_force := []; - allow_modules := allow; - module_variables := [] +(* Whether or not patterns of the form (module M) are accepted. (If they are, + the idents will be created at the provided scope.) When module patterns are + allowed, the caller should take care to check that the introduced module + bindings' types don't escape their scope; see the callsites in [type_let] + and [type_cases] for examples. + [Modules_ignored] indicates that the typing of patterns should not accumulate + a list of module patterns to unpack. It's no different than using + [Modules_allowed] and then ignoring the accumulated [module_variables] list, + but signals more clearly that the module patterns aren't used in an + interesting way. +*) +type module_patterns_restriction = + | Modules_allowed of { scope: int } + | Modules_rejected + | Modules_ignored + +(* A parallel type to [module_patterns_restriction], though also + tracking the module variables encountered. +*) +type module_variables = + | Modvars_allowed of + { scope: int; + module_variables: module_variable list; + } + | Modvars_rejected + | Modvars_ignored + +type type_pat_state = + { mutable tps_pattern_variables: pattern_variable list; + mutable tps_pattern_force: (unit -> unit) list; + mutable tps_module_variables: module_variables; + (* Mutation will not change the constructor of [tps_module_variables], just + the contained [module_variables] list. [module_variables] could be made + mutable instead, but we felt this made the code more awkward. + *) + } + +let create_type_pat_state allow_modules = + let tps_module_variables = + match allow_modules with + | Modules_allowed { scope } -> + Modvars_allowed { scope; module_variables = [] } + | Modules_ignored -> Modvars_ignored + | Modules_rejected -> Modvars_rejected + in + { tps_pattern_variables = []; + tps_module_variables; + tps_pattern_force = []; + } + +(* Copy mutable fields. Used in typechecking or-patterns. *) +let copy_type_pat_state + { tps_pattern_variables; + tps_module_variables; + tps_pattern_force; + } + = + { tps_pattern_variables; + tps_module_variables; + tps_pattern_force; + } + +let blit_type_pat_state ~src ~dst = + dst.tps_pattern_variables <- src.tps_pattern_variables; + dst.tps_module_variables <- src.tps_module_variables; + dst.tps_pattern_force <- src.tps_pattern_force; +;; let maybe_add_pattern_variables_ghost loc_let env pv = List.fold_right @@ -588,39 +661,45 @@ let maybe_add_pattern_variables_ghost loc_let env pv = end ) pv env -let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty +let enter_variable ?(is_module=false) ?(is_as_variable=false) tps loc name ty attrs = if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt) - !pattern_variables + tps.tps_pattern_variables then raise(error(loc, Env.empty, Multiply_bound_variable name.txt)); let id = if is_module then begin (* Unpack patterns result in both a module declaration and a value variable of the same name being entered into the environment. (The - module is via [module_variables], and the variable is via - [pattern_variables].) *) - match !allow_modules with - | Modules_rejected -> + module is via [tps_module_variables], and the variable is via + [tps_pattern_variables].) *) + match tps.tps_module_variables with + | Modvars_ignored -> Ident.create_local name.txt + | Modvars_rejected -> raise (error (loc, Env.empty, Modules_not_allowed)); - | Modules_allowed { scope } -> + | Modvars_allowed { scope; module_variables } -> let id = Ident.create_scoped name.txt ~scope in - module_variables := + let module_variables = { mv_id = id; mv_name = name; mv_loc = loc; mv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); - } :: !module_variables; + } :: module_variables + in + tps.tps_module_variables <- + Modvars_allowed { scope; module_variables; }; id end else Ident.create_local name.txt in - pattern_variables := + let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + tps.tps_pattern_variables <- {pv_id = id; pv_type = ty; pv_loc = loc; pv_as_var = is_as_variable; - pv_attributes = attrs} :: !pattern_variables; - id + pv_attributes = attrs; + pv_uid} :: tps.tps_pattern_variables; + id, pv_uid let sort_pattern_variables vs = List.sort @@ -662,31 +741,35 @@ let enter_orpat_variables loc env p1_vs p2_vs = raise (error (loc, env, err)) in unify_vars p1_vs p2_vs -let rec build_as_type ~refine (env : Env.t ref) p = - let as_ty = build_as_type_aux ~refine 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 -> +let rec build_as_type (env : Env.t) p = + build_as_type_extra env p p.pat_extra + +and build_as_type_extra env p = function + | [] -> build_as_type_aux env p + | ((Tpat_type _ | Tpat_open _ | Tpat_unpack), _, _) :: rest -> + build_as_type_extra env p rest + | (Tpat_constraint {ctyp_type = ty; _}, _, _) :: rest -> + (* If the type constraint is ground, then this is the best type + we can return, so just return an instance (cf. #12313) *) + if free_variables ty = [] then instance ty else + (* Otherwise we combine the inferred type for the pattern with + then non-ground constraint in a non-ambivalent way *) + let as_ty = build_as_type_extra env p rest in (* [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]. *) let ty = - with_local_level ~post:generalize_structure - (fun () -> instance cty.ctyp_type) + with_local_level ~post:generalize_structure (fun () -> instance ty) in - (* This call to unify can't fail since the pattern is well typed. *) - unify_pat_types ~refine p.pat_loc env (instance as_ty) (instance ty); + (* This call to unify may only fail due to missing GADT equations *) + unify_pat_types p.pat_loc env (instance as_ty) (instance ty); ty - ) as_ty p.pat_extra -and build_as_type_aux ~refine (env : Env.t ref) p = - let build_as_type = build_as_type ~refine in +and build_as_type_aux (env : Env.t) p = match p.pat_desc with - Tpat_alias(p1,_, _) -> build_as_type env p1 + Tpat_alias(p1,_, _, _) -> build_as_type env p1 | Tpat_tuple pl -> let tyl = List.map (build_as_type env) pl in newty (Ttuple tyl) @@ -699,7 +782,7 @@ and build_as_type_aux ~refine (env : Env.t ref) p = let ty_args, ty_res, _ = instance_constructor Keep_existentials_flexible cstr in - List.iter2 (fun (p,ty) -> unify_pat ~refine env {p with pat_type = ty}) + 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', _) -> @@ -713,19 +796,18 @@ and build_as_type_aux ~refine (env : Env.t ref) p = 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 ~refine env {p with pat_type = ty} ty_res; + let _, ty_arg, ty_res = instance_label ~fixed: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 get_desc lbl.lbl_arg with Tpoly _ -> false | _ -> true in if refinable then begin let arg = List.assoc lbl.lbl_pos ppl in - unify_pat ~refine env - {arg with pat_type = build_as_type env arg} ty_arg + 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_pat_types ~refine p.pat_loc env ty_arg ty_arg'; - unify_pat ~refine env p ty_res' + let _, ty_arg', ty_res' = instance_label ~fixed:false lbl in + unify_pat_types p.pat_loc env ty_arg ty_arg'; + unify_pat env p ty_res' end in Array.iter do_label lbl.lbl_all; ty @@ -733,7 +815,7 @@ and build_as_type_aux ~refine (env : Env.t ref) p = begin match row with None -> let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in - unify_pat ~refine env {p2 with pat_type = ty2} ty1; + unify_pat env {p2 with pat_type = ty2} ty1; ty1 | Some row -> let Row {fields; fixed; name} = row_repr row in @@ -745,56 +827,57 @@ and build_as_type_aux ~refine (env : Env.t ref) p = (* 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; +let solve_Ppat_poly_constraint tps env loc sty expected_ty = + let cty, ty, force = Typetexp.transl_simple_type_delayed env sty in + unify_pat_types loc env ty (instance expected_ty); + tps.tps_pattern_force <- force :: tps.tps_pattern_force; match get_desc ty with | Tpoly (body, tyl) -> let _, ty' = with_level ~level:generic_level - (fun () -> instance_poly ~keep_names:true false tyl body) + (fun () -> instance_poly ~keep_names:true ~fixed:false tyl body) in (cty, ty, ty') | _ -> assert false -let solve_Ppat_alias ~refine env pat = - with_local_level ~post:generalize (fun () -> build_as_type ~refine env pat) +let solve_Ppat_alias env pat = + with_local_level ~post:generalize (fun () -> build_as_type env pat) 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; + unify_pat_types_refine ~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 solve_constructor_annotation + tps (penv : Pattern_env.t) name_list sty ty_args ty_ex = + let expansion_scope = penv.equations_scope in let ids = List.map (fun name -> - let decl = new_local_type ~loc:name.loc () in + let decl = new_local_type ~loc:name.loc Definition in let (id, new_env) = - Env.enter_type ~scope:expansion_scope name.txt decl !env in - env := new_env; + Env.enter_type ~scope:expansion_scope name.txt decl !!penv in + Pattern_env.set_env penv new_env; {name with txt = id}) name_list in let cty, ty, force = with_local_level ~post:(fun (_,ty,_) -> generalize_structure ty) - (fun () -> Typetexp.transl_simple_type_delayed !env sty) + (fun () -> Typetexp.transl_simple_type_delayed !!penv sty) in - pattern_force := force :: !pattern_force; + tps.tps_pattern_force <- force :: tps.tps_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; + unify_pat_types cty.ctyp_loc !!penv ty1 ty_arg; [ty2] | _ -> - unify_pat_types cty.ctyp_loc env ty1 (newty (Ttuple ty_args)); - match get_desc (expand_head !env ty2) with + unify_pat_types cty.ctyp_loc !!penv ty1 (newty (Ttuple ty_args)); + match get_desc (expand_head !!penv ty2) with Ttuple tyl -> tyl | _ -> assert false in @@ -807,50 +890,44 @@ let solve_constructor_annotation env name_list sty ty_args ty_ex = Tconstr(Path.Pident id, [], _) when List.mem id rem -> list_remove id rem | _ -> - raise (Error (cty.ctyp_loc, !env, + raise (Error (cty.ctyp_loc, !!penv, Unbound_existential (ids, ty)))) ids ty_ex in if rem <> [] then - raise (Error (cty.ctyp_loc, !env, + raise (Error (cty.ctyp_loc, !!penv, Unbound_existential (ids, ty))) end; ty_args, Some (ids, cty) -let solve_Ppat_construct ~refine env loc constr no_existentials +let solve_Ppat_construct ~refine tps penv 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; + unify_head_only ~refine loc penv (instance expected_ty) constr; (* PR#7214: do not use gadt unification for toplevel lets *) let unify_res ty_res expected_ty = 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 + refine || constr.cstr_generalized && no_existentials = None in + unify_pat_types_return_equated_pairs ~refine loc penv ty_res expected_ty in let ty_args, equated_types, existential_ctyp = with_local_level_iter ~post: generalize_structure begin fun () -> let expected_ty = instance 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 - (Make_existentials_abstract { env; scope = expansion_scope }) - constr + instance_constructor (Make_existentials_abstract penv) constr in ty_args, ty_res, unify_res ty_res expected_ty, None | Some (name_list, sty) -> let existential_treatment = if name_list = [] then - Make_existentials_abstract { env; scope = expansion_scope } + Make_existentials_abstract penv else (* we will unify them (in solve_constructor_annotation) with the local types provided by the user *) @@ -861,16 +938,17 @@ let solve_Ppat_construct ~refine env loc constr no_existentials in let equated_types = unify_res ty_res expected_ty in let ty_args, existential_ctyp = - solve_constructor_annotation env name_list sty ty_args ty_ex in + solve_constructor_annotation tps penv name_list sty ty_args ty_ex + in ty_args, ty_res, equated_types, existential_ctyp in if constr.cstr_existentials <> [] then - lower_variables_only !env expansion_scope ty_res; + lower_variables_only !!penv penv.Pattern_env.equations_scope ty_res; ((ty_args, equated_types, existential_ctyp), expected_ty :: ty_res :: ty_args) end in - if !Clflags.principal && refine = None then begin + if !Clflags.principal && not refine then begin (* Do not warn for counter-examples *) let exception Warn_only_once in try @@ -894,13 +972,13 @@ let solve_Ppat_construct ~refine env loc constr no_existentials end; (ty_args, existential_ctyp) -let solve_Ppat_record_field ~refine loc env label label_lid record_ty = +let solve_Ppat_record_field ~refine loc penv label label_lid record_ty = with_local_level_iter ~post:generalize_structure begin fun () -> - let (_, ty_arg, ty_res) = instance_label false label in + let (_, ty_arg, ty_res) = instance_label ~fixed:false label in begin try - unify_pat_types ~refine loc env ty_res (instance record_ty) + unify_pat_types_refine ~refine loc penv ty_res (instance record_ty) with Error(_loc, _env, Pattern_type_clash(err, _)) -> - raise(error(label_lid.loc, !env, + raise(error(label_lid.loc, !!penv, Label_mismatch(label_lid.txt, err))) end; (ty_arg, [ty_res; ty_arg]) @@ -909,24 +987,24 @@ let solve_Ppat_record_field ~refine loc env label label_lid record_ty = 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 + unify_pat_types_refine ~refine loc env (Predef.type_array ty_elt) expected_ty; ty_elt -let solve_Ppat_lazy ~refine loc env expected_ty = +let solve_Ppat_lazy ~refine loc env expected_ty = let nv = newgenvar () in - unify_pat_types ~refine loc env (Predef.type_lazy_t nv) + unify_pat_types_refine ~refine loc env (Predef.type_lazy_t nv) (generic_instance expected_ty); nv -let solve_Ppat_constraint ~refine loc env sty expected_ty = +let solve_Ppat_constraint tps loc env sty expected_ty = let cty, ty, force = with_local_level ~post:(fun (_, ty, _) -> generalize_structure ty) - (fun () -> Typetexp.transl_simple_type_delayed !env sty) + (fun () -> Typetexp.transl_simple_type_delayed env sty) in - pattern_force := force :: !pattern_force; + tps.tps_pattern_force <- force :: tps.tps_pattern_force; let ty, expected_ty' = instance ty, ty in - unify_pat_types ~refine loc env ty (instance expected_ty); + unify_pat_types loc env ty (instance expected_ty); (cty, ty, expected_ty') let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = @@ -940,7 +1018,7 @@ let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = (* 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; + unify_pat_types_refine ~refine loc env (newgenty(Tvariant row)) expected_ty; (arg_type, make_row (newvar ()), instance expected_ty) (* Building the or-pattern corresponding to a polymorphic variant type *) @@ -997,19 +1075,6 @@ let build_or_pat env loc lid = 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 = @@ -1463,19 +1528,39 @@ 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 = +(* "untyped" cases are prior to checking the pattern. *) +type untyped_case = Parsetree.pattern Parmatch.parmatch_case + +(* "half typed" cases are produced in [map_half_typed_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, 'case_data) half_typed_case = { typed_pat: 'case_pattern; pat_type_for_unif: type_expr; - untyped_case: Parsetree.case; + untyped_case : untyped_case; + case_data : 'case_data; branch_env: Env.t; pat_vars: pattern_variable list; - module_vars: module_variable list; + module_vars: module_variables; contains_gadt: bool; } +(* Used to split patterns into value cases and exception cases. *) +let split_half_typed_cases env zipped_cases = + let add_case lst htc data = function + | None -> lst + | Some split_pat -> + ({ htc.untyped_case with pattern = split_pat }, data) :: lst + in + List.fold_right (fun (htc, data) (vals, exns) -> + let pat = htc.typed_pat in + match split_pattern pat with + | Some _, Some _ when htc.untyped_case.has_guard -> + raise (Error (pat.pat_loc, env, + Mixed_value_and_exception_patterns_under_guard)) + | vp, ep -> add_case vals htc data vp, add_case exns htc data ep + ) zipped_cases ([], []) + let rec has_literal_pattern p = match p.ppat_desc with | Ppat_constant _ | Ppat_interval _ -> @@ -1566,16 +1651,17 @@ let as_comp_pattern (** [type_pat] propagates the expected type, and unification may update the typing environment. *) let rec type_pat - : type k . k pattern_category -> + : type k . type_pat_state -> k pattern_category -> no_existentials: existential_restriction option -> - env: Env.t ref -> Parsetree.pattern -> type_expr -> k general_pattern - = fun category ~no_existentials ~env sp expected_ty -> + penv: Pattern_env.t -> Parsetree.pattern -> type_expr -> + k general_pattern + = fun tps category ~no_existentials ~penv sp expected_ty -> 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 ~env sp expected_ty + type_pat_aux tps category ~no_existentials ~penv sp expected_ty with Error _ as exn -> (* We only want to catch error, not internal exceptions such as [Need_backtrack], etc. *) @@ -1589,7 +1675,7 @@ let rec type_pat pat_loc = loc; pat_extra = []; pat_type = expected_ty; - pat_env = !env; + pat_env = !!penv; pat_attributes = Msupport.recovery_attributes sp.ppat_attributes; } in @@ -1599,16 +1685,15 @@ let rec type_pat ) and type_pat_aux - : type k . k pattern_category -> no_existentials:_ -> - env:_ -> _ -> _ -> k general_pattern - = fun category ~no_existentials ~env sp expected_ty -> - let type_pat category ?(env=env) = - type_pat category ~no_existentials ~env + : type k . type_pat_state -> k pattern_category -> no_existentials:_ -> + penv:Pattern_env.t -> _ -> _ -> k general_pattern + = fun tps category ~no_existentials ~penv sp expected_ty -> + let type_pat tps category ?(penv=penv) = + type_pat tps category ~no_existentials ~penv in let loc = sp.ppat_loc in - let refine = None in let solve_expected (x : pattern) : pattern = - unify_pat ~refine ~sdesc_for_hint:sp.ppat_desc env x (instance expected_ty); + unify_pat ~sdesc_for_hint:sp.ppat_desc !!penv x (instance expected_ty); x in let crp (x : k general_pattern) : k general_pattern = @@ -1627,16 +1712,16 @@ and type_pat_aux pat_loc = loc; pat_extra=[]; pat_type = instance expected_ty; pat_attributes = sp.ppat_attributes; - pat_env = !env } + pat_env = !!penv } | Ppat_var name -> let ty = instance expected_ty in - let id = enter_variable loc name ty sp.ppat_attributes in + let id, uid = enter_variable tps loc name ty sp.ppat_attributes in rvp { - pat_desc = Tpat_var (id, name); + pat_desc = Tpat_var (id, name, uid); pat_loc = loc; pat_extra=[]; pat_type = ty; pat_attributes = sp.ppat_attributes; - pat_env = !env } + pat_env = !!penv } | Ppat_unpack name -> let t = instance expected_ty in begin match name.txt with @@ -1647,53 +1732,56 @@ and type_pat_aux pat_extra=[Tpat_unpack, name.loc, sp.ppat_attributes]; pat_type = t; pat_attributes = []; - pat_env = !env } + pat_env = !!penv } | Some s -> let v = { name with txt = s } in (* We're able to pass ~is_module:true here without an error because [Ppat_unpack] is a case identified by [may_contain_modules]. See the comment on [may_contain_modules]. *) - let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in + let id, uid = + enter_variable tps loc v t ~is_module:true sp.ppat_attributes + in rvp { - pat_desc = Tpat_var (id, v); + pat_desc = Tpat_var (id, v, uid); pat_loc = sp.ppat_loc; pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; pat_type = t; pat_attributes = []; - pat_env = !env } + pat_env = !!penv } end | Ppat_constraint( {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs}, ({ptyp_desc=Ptyp_poly _} as sty)) -> (* explicitly polymorphic type *) 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 { pat_desc = Tpat_var (id, name); + solve_Ppat_poly_constraint tps !!penv lloc sty expected_ty in + let id, uid = enter_variable tps lloc name ty' attrs in + rvp { pat_desc = Tpat_var (id, name, uid); pat_loc = lloc; pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes]; pat_type = ty; pat_attributes = []; - pat_env = !env } + pat_env = !!penv } | Ppat_alias(sq, name) -> - let q = type_pat Value sq expected_ty in - let ty_var = solve_Ppat_alias ~refine env q in - let id = - enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes + let q = type_pat tps Value sq expected_ty in + let ty_var = solve_Ppat_alias !!penv q in + let id, uid = + enter_variable + ~is_as_variable:true tps name.loc name ty_var sp.ppat_attributes in - rvp { pat_desc = Tpat_alias(q, id, name); + rvp { pat_desc = Tpat_alias(q, id, name, uid); pat_loc = loc; pat_extra=[]; pat_type = q.pat_type; pat_attributes = sp.ppat_attributes; - pat_env = !env } + pat_env = !!penv } | Ppat_constant cst -> - let cst = constant_or_raise !env loc cst in + let cst = constant_or_raise !!penv loc cst in rvp @@ 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 } + pat_env = !!penv } | Ppat_interval (Pconst_char c1, Pconst_char c2) -> let open Ast_helper.Pat in let gloc = {loc with Location.loc_ghost=true} in @@ -1706,45 +1794,45 @@ and type_pat_aux 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 p expected_ty + type_pat tps category p expected_ty (* TODO: record 'extra' to remember about interval *) | Ppat_interval _ -> - raise (error (loc, !env, Invalid_interval)) + raise (error (loc, !!penv, Invalid_interval)) | Ppat_tuple spl -> assert (List.length spl >= 2); - let expected_tys = solve_Ppat_tuple ~refine loc env spl expected_ty in - let pl = List.map2 (type_pat Value) spl expected_tys in + let expected_tys = + solve_Ppat_tuple ~refine:false loc penv spl expected_ty in + let pl = List.map2 (type_pat tps Value) spl expected_tys in rvp { 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 } + pat_env = !!penv } | Ppat_construct(lid, sarg) -> let expected_type = - match extract_concrete_variant !env expected_ty with + match extract_concrete_variant !!penv expected_ty with | Variant_type(p0, p, _) -> Some (p0, p, is_principal expected_ty) | Maybe_a_variant_type -> None | Not_a_variant_type -> let srt = wrong_kind_sort_of_constructor lid.txt in let err = Wrong_expected_kind(srt, Pattern, expected_ty) in - raise (error (loc, !env, err)) + raise (error (loc, !!penv, err)) in let constr = let candidates = - Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !env in + Env.lookup_all_constructors Env.Pattern ~loc:lid.loc lid.txt !!penv in wrap_disambiguate "This variant pattern is expected to have" (mk_expected expected_ty) - (Constructor.disambiguate Env.Pattern lid !env expected_type) + (Constructor.disambiguate Env.Pattern lid !!penv expected_type) candidates in begin match no_existentials, constr.cstr_existentials with | None, _ | _, [] -> () - | Some r, (_ :: _ as exs) -> - let exs = List.map (Ctype.existential_name constr) exs in + | Some r, (_ :: _) -> let name = constr.cstr_name in - raise (error (loc, !env, Unexpected_existential (r, name, exs))) + raise (error (loc, !!penv, Unexpected_existential (r, name))) end; let sarg', existential_styp = match sarg with @@ -1755,7 +1843,7 @@ and type_pat_aux | Some ([], sp) -> Some sp, None | Some (_, sp) -> - raise (error (sp.ppat_loc, !env, Missing_type_constraint)) + raise (error (sp.ppat_loc, !!penv, Missing_type_constraint)) in let sargs = match sarg' with @@ -1780,11 +1868,11 @@ and type_pat_aux | _ -> () end; if List.length sargs <> constr.cstr_arity then - raise(error(loc, !env, Constructor_arity_mismatch(lid.txt, + raise(error(loc, !!penv, 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 + solve_Ppat_construct ~refine:false tps penv loc constr no_existentials existential_styp expected_ty in @@ -1796,7 +1884,7 @@ and type_pat_aux | Ppat_alias (p, _) -> check_non_escaping p | Ppat_constraint _ -> - raise (error (p.ppat_loc, !env, Inlined_record_escape)) + raise (error (p.ppat_loc, !!penv, Inlined_record_escape)) | _ -> () in @@ -1805,21 +1893,21 @@ and type_pat_aux Option.iter (fun (_, sarg) -> check_non_escaping sarg) sarg end; - let args = List.map2 (type_pat Value) sargs ty_args in + let args = List.map2 (type_pat tps Value) sargs ty_args in rvp { 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 } + pat_env = !!penv } | Ppat_variant(tag, sarg) -> assert (tag <> Parmatch.some_private_tag); let constant = (sarg = None) in let arg_type, row, pat_type = - solve_Ppat_variant ~refine loc env tag constant expected_ty in + solve_Ppat_variant ~refine:false loc penv tag constant expected_ty in let arg = (* PR#6235: propagate type information *) match sarg, arg_type with - Some sp, [ty] -> Some (type_pat Value sp ty) + Some sp, [ty] -> Some (type_pat tps Value sp ty) | _ -> None in rvp { @@ -1827,23 +1915,24 @@ and type_pat_aux pat_loc = loc; pat_extra = []; pat_type = pat_type; pat_attributes = sp.ppat_attributes; - pat_env = !env } + pat_env = !!penv } | Ppat_record(lid_sp_list, closed) -> assert (lid_sp_list <> []); let expected_type, record_ty = - match extract_concrete_record !env expected_ty with + match extract_concrete_record !!penv expected_ty with | Record_type(p0, p, _) -> let ty = generic_instance expected_ty in Some (p0, p, is_principal expected_ty), ty | Maybe_a_record_type -> None, newvar () | Not_a_record_type -> let err = Wrong_expected_kind(Record, Pattern, expected_ty) in - raise (error (loc, !env, err)) + raise (error (loc, !!penv, err)) in let type_label_pat (label_lid, label, sarg) = let ty_arg = - solve_Ppat_record_field ~refine loc env label label_lid record_ty in - (label_lid, label, type_pat Value sarg ty_arg) + solve_Ppat_record_field ~refine:false loc penv label label_lid + record_ty in + (label_lid, label, type_pat tps Value sarg ty_arg) in let make_record_pat lbl_pat_list = check_recordpat_labels loc lbl_pat_list closed; @@ -1852,146 +1941,157 @@ and type_pat_aux pat_loc = loc; pat_extra=[]; pat_type = instance record_ty; pat_attributes = sp.ppat_attributes; - pat_env = !env; + pat_env = !!penv; } in let lbl_a_list = wrap_disambiguate "This record pattern is expected to have" (mk_expected expected_ty) - (type_label_a_list loc false !env Env.Projection + (type_label_a_list loc false !!penv Env.Projection type_label_pat expected_type) lid_sp_list in rvp @@ solve_expected (make_record_pat lbl_a_list) | Ppat_array spl -> - let ty_elt = solve_Ppat_array ~refine loc env expected_ty in - let pl = List.map (fun p -> type_pat Value p ty_elt) spl in + let ty_elt = solve_Ppat_array ~refine:false loc penv expected_ty in + let pl = List.map (fun p -> type_pat tps Value p ty_elt) spl in rvp { pat_desc = Tpat_array pl; pat_loc = loc; pat_extra=[]; pat_type = instance expected_ty; pat_attributes = sp.ppat_attributes; - pat_env = !env } + pat_env = !!penv } | Ppat_or(sp1, sp2) -> - 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 + (* Reset pattern forces for just [tps2] because later we append [tps1] and + [tps2]'s pattern forces, and we don't want to duplicate [tps]'s pattern + forces. *) + let tps1 = copy_type_pat_state tps in + let tps2 = {(copy_type_pat_state tps) with tps_pattern_force = []} in (* Introduce a new scope using with_local_level without generalizations *) - let env1, p1, p1_variables, p1_module_variables, env2, p2 = + let env1, p1, env2, p2 = with_local_level begin fun () -> - let lev = get_current_level () in - gadt_equations_level := Some lev; - let type_pat_rec env sp = type_pat category sp expected_ty ~env 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 - (env1, p1, p1_variables, p1_module_variables, env2, p2) + let type_pat_rec tps penv sp = + type_pat tps category sp expected_ty ~penv + in + let penv1 = + Pattern_env.copy ~equations_scope:(get_current_level ()) penv in + let penv2 = Pattern_env.copy penv1 in + let p1 = type_pat_rec tps1 penv1 sp1 in + let p2 = type_pat_rec tps2 penv2 sp2 in + (penv1.env, p1, penv2.env, p2) end in - gadt_equations_level := equation_level; - let p2_variables = !pattern_variables in + let p1_variables = tps1.tps_pattern_variables in + let p2_variables = tps2.tps_pattern_variables in (* Make sure no variable with an ambiguous type gets added to the environment. *) + let outer_lev = get_current_level () in List.iter (fun { pv_type; pv_loc; _ } -> - check_scope_escape pv_loc !env1 outter_lev pv_type + check_scope_escape pv_loc env1 outer_lev pv_type ) p1_variables; List.iter (fun { pv_type; pv_loc; _ } -> - check_scope_escape pv_loc !env2 outter_lev pv_type + check_scope_escape pv_loc env2 outer_lev pv_type ) p2_variables; let alpha_env = - enter_orpat_variables loc !env p1_variables p2_variables in + enter_orpat_variables loc !!penv p1_variables p2_variables in + (* Propagate the outcome of checking the or-pattern back to + the type_pat_state that the caller passed in. + *) + blit_type_pat_state + ~src: + { tps_pattern_variables = tps1.tps_pattern_variables; + (* We want to propagate all pattern forces, regardless of + which branch they were found in. + *) + tps_pattern_force = + tps2.tps_pattern_force @ tps1.tps_pattern_force; + tps_module_variables = tps1.tps_module_variables; + } + ~dst:tps; let p2 = alpha_pat alpha_env p2 in - pattern_variables := p1_variables; - module_variables := p1_module_variables; rp { 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 } + pat_env = !!penv } | Ppat_lazy sp1 -> - let nv = solve_Ppat_lazy ~refine loc env expected_ty in - let p1 = type_pat Value sp1 nv in + let nv = solve_Ppat_lazy ~refine:false loc penv expected_ty in + let p1 = type_pat tps Value sp1 nv in rvp { pat_desc = Tpat_lazy p1; pat_loc = loc; pat_extra=[]; pat_type = instance expected_ty; pat_attributes = sp.ppat_attributes; - pat_env = !env } + pat_env = !!penv } | Ppat_constraint(sp, sty) -> (* Pretend separate = true *) let cty, ty, expected_ty' = - solve_Ppat_constraint ~refine loc env sty expected_ty in - let p = type_pat category sp expected_ty' in + solve_Ppat_constraint tps loc !!penv sty expected_ty in + let p = type_pat tps category sp expected_ty' in let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in begin match category, (p : k general_pattern) with - | Value, {pat_desc = Tpat_var (id,s); _} -> + | Value, {pat_desc = Tpat_var (id,s,uid); _} -> { p with pat_type = ty; pat_desc = Tpat_alias - ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s); + ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s, uid); pat_extra = [extra]; } | _, p -> { p with pat_type = ty; pat_extra = extra::p.pat_extra } end | Ppat_type lid -> - let (path, p) = build_or_pat !env loc lid in + let (path, p) = build_or_pat !!penv loc lid in pure category @@ solve_expected { 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 - env := new_env; - let p = type_pat category ~env p expected_ty in - let new_env = !env in + !type_open Asttypes.Fresh !!penv sp.ppat_loc lid in + Pattern_env.set_env penv new_env; + let p = type_pat tps category ~penv p expected_ty in + let new_env = !!penv in begin match Env.remove_last_open path new_env with | None -> assert false - | Some closed_env -> env := closed_env + | Some closed_env -> Pattern_env.set_env penv closed_env end; { p with pat_extra = (Tpat_open (path,lid,new_env), loc, sp.ppat_attributes) :: p.pat_extra } | Ppat_exception p -> - let p_exn = type_pat Value p Predef.type_exn in + let p_exn = type_pat tps Value p Predef.type_exn in rcp { pat_desc = Tpat_exception p_exn; pat_loc = sp.ppat_loc; pat_extra = []; pat_type = expected_ty; - pat_env = !env; + pat_env = !!penv; pat_attributes = sp.ppat_attributes; } | Ppat_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) -let type_pat category ?no_existentials - ?(lev=get_current_level()) env sp expected_ty = - Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] - (fun () -> type_pat category ~no_existentials ~env sp expected_ty) - 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 -> + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes; pv_uid} 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 ()); + val_uid = pv_uid; } env ) pv env let add_module_variables env module_variables = + let module_variables_as_list = + match module_variables with + | Modvars_allowed mvs -> mvs.module_variables + | Modvars_ignored | Modvars_rejected -> [] + in List.fold_left (fun env { mv_id; mv_loc; mv_name; mv_uid } -> Typetexp.TyVarEnv.with_local_scope begin fun () -> (* This code is parallel to the typing of Pexp_letmodule. However we @@ -2021,43 +2121,56 @@ let add_module_variables env module_variables = in Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md env end - ) env module_variables + ) env module_variables_as_list + +let type_pat tps category ?no_existentials penv = + type_pat tps category ~no_existentials ~penv let type_pattern category ~lev env spat expected_ty allow_modules = - reset_pattern allow_modules; - 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 mvs = get_ref module_variables in - (pat, !new_env, get_ref pattern_force, pvs, mvs) + let tps = create_type_pat_state allow_modules in + let new_penv = Pattern_env.make env + ~equations_scope:lev ~allow_recursive_equations:false in + let pat = type_pat tps category new_penv spat expected_ty in + let { tps_pattern_variables = pvs; + tps_module_variables = mvs; + tps_pattern_force = pattern_forces; + } = tps in + (pat, !!new_penv, pattern_forces, pvs, mvs) let type_pattern_list category no_existentials env spatl expected_tys allow_modules = - reset_pattern allow_modules; - let new_env = ref env in + let tps = create_type_pat_state allow_modules in + let equations_scope = get_current_level () in + let new_penv = Pattern_env.make env + ~equations_scope ~allow_recursive_equations:false in let type_pat (attrs, pat) ty = Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> - type_pat category ~no_existentials new_env pat ty + type_pat tps category ~no_existentials new_penv pat ty ) in let patl = List.map2 type_pat spatl expected_tys in - let pvs = get_ref pattern_variables in - let mvs = get_ref module_variables in - (patl, !new_env, get_ref pattern_force, pvs, mvs) + let { tps_pattern_variables = pvs; + tps_module_variables = mvs; + tps_pattern_force = pattern_forces; + } = tps in + (patl, !!new_penv, pattern_forces, pvs, mvs) let type_class_arg_pattern cl_num val_env met_env l spat = - reset_pattern Modules_rejected; + let tps = create_type_pat_state Modules_rejected in let nv = newvar () in + let equations_scope = get_current_level () in + let new_penv = Pattern_env.make val_env + ~equations_scope ~allow_recursive_equations:false in let pat = - type_pat Value ~no_existentials:In_class_args (ref val_env) spat nv in + type_pat tps Value ~no_existentials:In_class_args new_penv 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 ())); + List.iter (fun f -> f()) tps.tps_pattern_force; + if is_optional l then unify_pat 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} @@ -2088,21 +2201,22 @@ let type_class_arg_pattern cl_num val_env met_env l spat = met_env in ((id', pv_id, pv_type)::pv, val_env, met_env)) - !pattern_variables ([], val_env, met_env) + tps.tps_pattern_variables ([], val_env, met_env) in (pat, pv, val_env, met_env) let type_self_pattern env spat = let open Ast_helper in let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in - reset_pattern Modules_rejected; + let tps = create_type_pat_state Modules_rejected in let nv = newvar() in + let equations_scope = get_current_level () in + let new_penv = Pattern_env.make env + ~equations_scope ~allow_recursive_equations:false in let pat = - type_pat Value ~no_existentials:In_self_pattern (ref env) spat nv in - List.iter (fun f -> f()) (get_ref pattern_force); - let pv = !pattern_variables in - pattern_variables := []; - pat, pv + type_pat tps Value ~no_existentials:In_self_pattern new_penv spat nv in + List.iter (fun f -> f()) tps.tps_pattern_force; + pat, tps.tps_pattern_variables type delayed_check = ((unit -> unit) * Warnings.state) @@ -2233,12 +2347,12 @@ type abort_reason = Adds_constraints | Empty type unification_state = { snapshot: snapshot; env: Env.t; } -let save_state env = +let save_state penv = { snapshot = Btype.snapshot (); - env = !env; } -let set_state s env = + env = !!penv; } +let set_state s penv = Btype.backtrack s.snapshot; - env := s.env + Pattern_env.set_env penv 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 @@ -2262,19 +2376,21 @@ let enter_nonsplit_or info = Refine_or {inside_nonsplit_or = true} in { info with splitting_mode } -let rec check_counter_example_pat ~info ~env tp expected_ty k = - let check_rec ?(info=info) ?(env=env) = - check_counter_example_pat ~info ~env in +let rec check_counter_example_pat + ~info ~(penv : Pattern_env.t) type_pat_state tp expected_ty k = + let check_rec ?(info=info) ?(penv=penv) = + check_counter_example_pat ~info ~penv type_pat_state in let loc = tp.pat_loc in - let refine = Some true in + let refine = true in let solve_expected (x : pattern) : pattern = - unify_pat ~refine env x (instance expected_ty); + unify_pat_types_refine ~refine x.pat_loc penv x.pat_type + (instance expected_ty); x in (* "make pattern" and "make pattern then continue" *) let mp ?(pat_type = expected_ty) desc = { pat_desc = desc; pat_loc = loc; pat_extra=[]; - pat_type = instance pat_type; pat_attributes = []; pat_env = !env } in + pat_type = instance pat_type; pat_attributes = []; pat_env = !!penv } in let mkp k ?pat_type desc = k (mp ?pat_type desc) in let must_backtrack_on_gadt = match info.splitting_mode with @@ -2286,7 +2402,7 @@ let rec check_counter_example_pat ~info ~env tp expected_ty k = let k' () = mkp k tp.pat_desc in if info.explosion_fuel <= 0 then k' () else let decrease n = {info with explosion_fuel = info.explosion_fuel - n} in - begin match Parmatch.pats_of_type !env expected_ty with + begin match Parmatch.pats_of_type !!penv expected_ty with | [] -> raise Empty_branch | [{pat_desc = Tpat_any}] -> k' () | [tp] -> check_rec ~info:(decrease 1) tp expected_ty k @@ -2299,13 +2415,13 @@ let rec check_counter_example_pat ~info ~env tp expected_ty k = in check_rec ~info:(decrease 5) tp expected_ty k end - | Tpat_alias (p, _, _) -> check_rec ~info p expected_ty k + | Tpat_alias (p, _, _, _) -> check_rec ~info p expected_ty k | Tpat_constant cst -> - let cst = constant_or_raise !env loc (Untypeast.constant cst) in + let cst = constant_or_raise !!penv loc (Untypeast.constant cst) in k @@ solve_expected (mp (Tpat_constant cst) ~pat_type:(type_constant cst)) | Tpat_tuple tpl -> assert (List.length tpl >= 2); - let expected_tys = solve_Ppat_tuple ~refine loc env tpl expected_ty in + let expected_tys = solve_Ppat_tuple ~refine loc penv tpl expected_ty in let tpl_ann = List.combine tpl expected_tys in map_fold_cont (fun (p,t) -> check_rec p t) tpl_ann (fun pl -> mkp k (Tpat_tuple pl) @@ -2314,7 +2430,8 @@ let rec check_counter_example_pat ~info ~env tp expected_ty k = if constr.cstr_generalized && must_backtrack_on_gadt then raise Need_backtrack; let (ty_args, existential_ctyp) = - solve_Ppat_construct ~refine env loc constr None None expected_ty + solve_Ppat_construct + ~refine type_pat_state penv loc constr None None expected_ty in map_fold_cont (fun (p,t) -> check_rec p t) @@ -2324,7 +2441,7 @@ let rec check_counter_example_pat ~info ~env tp expected_ty k = | Tpat_variant(tag, targ, _) -> let constant = (targ = None) in let arg_type, row, pat_type = - solve_Ppat_variant ~refine loc env tag constant expected_ty in + solve_Ppat_variant ~refine loc penv tag constant expected_ty in let k arg = mkp k ~pat_type (Tpat_variant(tag, arg, ref row)) in begin @@ -2337,13 +2454,13 @@ let rec check_counter_example_pat ~info ~env tp expected_ty k = let record_ty = generic_instance expected_ty in let type_label_pat (label_lid, label, targ) k = let ty_arg = - solve_Ppat_record_field ~refine loc env label label_lid record_ty in + solve_Ppat_record_field ~refine loc penv label label_lid record_ty in check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) in map_fold_cont type_label_pat fields (fun fields -> mkp k (Tpat_record (fields, closed))) | Tpat_array tpl -> - let ty_elt = solve_Ppat_array ~refine loc env expected_ty in + let ty_elt = solve_Ppat_array ~refine loc penv expected_ty in map_fold_cont (fun p -> check_rec p ty_elt) tpl (fun pl -> mkp k (Tpat_array pl)) | Tpat_or(tp1, tp2, _) -> @@ -2352,22 +2469,22 @@ let rec check_counter_example_pat ~info ~env tp expected_ty k = match info.splitting_mode with | Backtrack_or -> true | Refine_or _ -> false in - let state = save_state env in + let state = save_state penv in let split_or tp = let type_alternative pat = - set_state state env; check_rec pat expected_ty k in + set_state state penv; check_rec pat expected_ty k in find_valid_alternative type_alternative tp in if must_split then split_or tp else - let check_rec_result env tp : (_, abort_reason) result = + let check_rec_result penv tp : (_, abort_reason) result = let info = enter_nonsplit_or info in - match check_rec ~info tp expected_ty ~env (fun x -> x) with + match check_rec ~info tp expected_ty ~penv (fun x -> x) with | res -> Ok res | exception Need_backtrack -> Error Adds_constraints | exception Empty_branch -> Error Empty in - let p1 = check_rec_result (ref !env) tp1 in - let p2 = check_rec_result (ref !env) tp2 in + let p1 = check_rec_result (Pattern_env.copy penv) tp1 in + let p2 = check_rec_result (Pattern_env.copy penv) tp2 in begin match p1, p2 with | Error Empty, Error Empty -> raise Empty_branch @@ -2387,56 +2504,57 @@ let rec check_counter_example_pat ~info ~env tp expected_ty k = mkp k (Tpat_or (p1, p2, None)) end | Tpat_lazy tp1 -> - let nv = solve_Ppat_lazy ~refine loc env expected_ty in + let nv = solve_Ppat_lazy ~refine loc penv expected_ty in (* do not explode under lazy: PR#7421 *) check_rec ~info:(no_explosion info) tp1 nv (fun p1 -> mkp k (Tpat_lazy p1)) -let check_counter_example_pat ~counter_example_args - ?(lev=get_current_level()) env tp expected_ty = - Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () -> - check_counter_example_pat - ~info:counter_example_args ~env tp expected_ty (fun x -> x) - ) +let check_counter_example_pat ~counter_example_args penv tp expected_ty = + (* [check_counter_example_pat] doesn't use [type_pat_state] in an interesting + way -- one of the functions it calls writes an entry into + [tps_pattern_forces] -- so we can just ignore module patterns. *) + let type_pat_state = create_type_pat_state Modules_ignored in + check_counter_example_pat + ~info:counter_example_args ~penv type_pat_state tp expected_ty (fun x -> x) (* this function is passed to Partial.parmatch to type check gadt nonexhaustiveness *) -let partial_pred ~lev ~allow_modules ~splitting_mode ?(explode=0) - env expected_ty p = - let env = ref env in - let state = save_state env in +let partial_pred ~lev ~splitting_mode ?(explode=0) env expected_ty p = + let penv = Pattern_env.make env + ~equations_scope:lev ~allow_recursive_equations:true in + let state = save_state penv in let counter_example_args = { splitting_mode; explosion_fuel = explode; } in try - reset_pattern allow_modules; let typed_p = - check_counter_example_pat ~lev ~counter_example_args env p expected_ty in - set_state state env; + check_counter_example_pat ~counter_example_args penv p expected_ty + in + set_state state penv; (* types are invalidated but we don't need them here *) Some typed_p with Error _ | Empty_branch -> - set_state state env; + set_state state penv; None let check_partial - ?(lev=get_current_level ()) allow_modules env expected_ty loc cases + ?(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 ~allow_modules ~splitting_mode ~explode env expected_ty) + (partial_pred ~lev ~splitting_mode ~explode env expected_ty) loc cases let check_unused - ?(lev=get_current_level ()) allow_modules env expected_ty cases + ?(lev=get_current_level ()) env expected_ty cases = Parmatch.check_unused (fun refute pat -> match - partial_pred ~lev ~allow_modules ~splitting_mode:Backtrack_or ~explode:5 + partial_pred ~lev ~splitting_mode:Backtrack_or ~explode:5 env expected_ty pat with Some pat' when refute -> @@ -2619,19 +2737,21 @@ and is_nonexpansive_opt = function let maybe_expansive e = not (is_nonexpansive e) -let check_recursive_bindings env valbinds = +let annotate_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 + List.map + (fun {vb_pat; vb_expr; vb_rec_kind = _; vb_attributes; vb_loc} -> + match (Value_rec_check.is_valid_recursive_expression ids vb_expr) with + | None -> raise(error(vb_expr.exp_loc, env, Illegal_letrec_expr)) - ) + | Some vb_rec_kind -> + { vb_pat; vb_expr; vb_rec_kind; vb_attributes; vb_loc}) valbinds let check_recursive_class_bindings env ids exprs = List.iter (fun expr -> - if not (Rec_check.is_valid_class_expr ids expr) then + if not (Value_rec_check.is_valid_class_expr ids expr) then raise(error(expr.cl_loc, env, Illegal_class_expr))) exprs @@ -2660,14 +2780,55 @@ let rec approx_type env sty = approx_type env sty | _ -> newvar () +let type_pattern_approx env spat = + match spat.ppat_desc with + | Ppat_constraint (_, sty) -> approx_type env sty + | _ -> newvar () + +let type_approx_fun env label default spat ret_ty = + let ty = type_pattern_approx env spat in + let ty = + match label, default with + | (Nolabel | Labelled _), _ -> ty + | Optional _, None -> + unify_pat_types spat.ppat_loc env ty (type_option (newvar ())); + ty + | Optional _, Some _ -> + type_option ty + in + newty (Tarrow (label, ty, ret_ty, commu_ok)) + +let type_approx_constraint env ty constraint_ ~loc = + match constraint_ with + | Pconstraint constrain -> + let ty_constrain = approx_type env constrain in + begin try unify env ty ty_constrain with Unify err -> + raise (error (loc, env, Expr_type_clash (err, None, None))) + end; + ty_constrain + | Pcoerce (constrain, coerce) -> + let approx_ty_opt = function + | None -> newvar () + | Some sty -> approx_type env sty + in + let ty_constrain = approx_ty_opt constrain + and ty_coerce = approx_type env coerce in + begin try unify env ty ty_constrain with Unify err -> + raise (error (loc, env, Expr_type_clash (err, None, None))) + end; + ty_coerce + +let type_approx_constraint_opt env ty constraint_ ~loc = + match constraint_ with + | None -> ty + | Some constraint_ -> type_approx_constraint env ty constraint_ ~loc + let rec type_approx env sexp = + let loc = sexp.pexp_loc in 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, commu_ok)) - | Pexp_function ({pc_rhs=e}::_) -> - newty (Tarrow(Nolabel, newvar (), type_approx env e, commu_ok)) + | Pexp_function (params, c, body) -> + type_approx_function env params c body ~loc | 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)) @@ -2675,25 +2836,34 @@ let rec type_approx env sexp = | 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 err -> - raise(error(sexp.pexp_loc, env, Expr_type_clash (err, None, None))) - end; - ty1 + type_approx_constraint env ty (Pconstraint sty) ~loc | 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 err -> - raise(error(sexp.pexp_loc, env, Expr_type_clash (err, None, None))) - end; - ty2 + let ty = type_approx env e in + type_approx_constraint env ty (Pcoerce (sty1, sty2)) ~loc | _ -> newvar () +and type_approx_function env params c body ~loc = + (* We can approximate types up to the first newtype parameter, whereupon + we give up. + *) + match params with + | { pparam_desc = Pparam_val (label, default, pat) } :: params -> + type_approx_fun env label default pat + (type_approx_function env params c body ~loc) + | { pparam_desc = Pparam_newtype _ } :: _ -> + newvar () + | [] -> + let body_ty = + match body with + | Pfunction_body body -> + type_approx env body + | Pfunction_cases ({pc_rhs = e} :: _, _, _) -> + newty (Tarrow (Nolabel, newvar (), type_approx env e, commu_ok)) + | Pfunction_cases ([], _, _) -> + newvar () + in + type_approx_constraint_opt env body_ty c ~loc + (* 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 @@ -2719,7 +2889,7 @@ let check_univars env kind exp ty_expected vars = (* Enforce scoping for type_let: since body is not generic, instance_poly only makes copies of nodes that have a Tunivar as descendant *) - let _, ty' = instance_poly true tl body in + let _, ty' = instance_poly ~fixed: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), exp_ty::vars) @@ -2973,8 +3143,8 @@ let check_absent_variant env = create_row ~fields ~more:(newvar ()) ~closed:false ~fixed:None ~name:None in (* Should fail *) - unify_pat (ref env) {pat with pat_type = newty (Tvariant row')} - (correct_levels pat.pat_type) + unify_pat env {pat with pat_type = newty (Tvariant row')} + (correct_levels pat.pat_type) | _ -> () } (* Getting proper location of already typed expressions. @@ -3004,8 +3174,8 @@ 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 + Tpat_var (id, _, _) -> id + | Tpat_alias(_, id, _, _) -> id | _ -> name_pattern default rem let name_cases default lst = @@ -3121,6 +3291,24 @@ let vb_pat_constraint ({pvb_pat=pat; pvb_expr = exp; _ } as vb) = Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat sty | _ -> pat +(** The body of a constraint or coercion. The "body" may be either an expression + or a list of function cases. This type is polymorphic in the data returned + out of typing so that typing an expression body can return an expression + and typing a function cases body can return the cases. +*) +type 'ret constraint_arg = + { type_without_constraint: Env.t -> 'ret * type_expr; + (** [type_without_constraint] types a body (e :> t) where there is no + constraint. + *) + type_with_constraint: Env.t -> type_expr -> 'ret; + (** [type_with_constraint] types a body (e : t) or (e : t :> t') in + the presence of a constraint. + *) + is_self: 'ret -> bool; + (** Whether the thing being constrained is a [Val_self] ident. *) + } + let rec type_exp ?recarg env sexp = (* We now delegate everything to type_expect *) type_expect ?recarg env sexp (mk_expected (newvar ())) @@ -3132,13 +3320,13 @@ let rec type_exp ?recarg env sexp = at [generic_level] (but its variables no higher than [!current_level]). *) -and type_expect ?in_function ?recarg env sexp ty_expected_explained = +and type_expect ?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 + type_expect_ ?recarg env sexp ty_expected_explained with exn -> Msupport.erroneous_type_register ty_expected_explained.ty; raise_error exn; @@ -3163,7 +3351,7 @@ and type_expect ?in_function ?recarg env sexp ty_expected_explained = }) and type_expect_ - ?in_function ?(recarg=Rejected) + ?(recarg=Rejected) env sexp ty_expected_explained = let { ty = ty_expected; explanation } = ty_expected_explained in let loc = sexp.pexp_loc in @@ -3222,7 +3410,7 @@ and type_expect_ 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 + type_expect env format_parsetree ty_expected_explained else rue { exp_desc = Texp_constant cst; @@ -3244,7 +3432,7 @@ and type_expect_ when may_contain_gadts spat -> (* TODO: allow non-empty attributes? *) let sval = vb_exp_constraint vb in - type_expect ?in_function env + type_expect env {sexp with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])} ty_expected_explained @@ -3276,9 +3464,9 @@ and type_expect_ allow_modules in let body = type_expect new_env sbody ty_expected_explained in - let () = - if rec_flag = Recursive then - check_recursive_bindings env pat_exp_list + let pat_exp_list = match rec_flag with + | Recursive -> annotate_recursive_bindings env pat_exp_list + | Nonrecursive -> pat_exp_list in (* The "bound expressions" component of the scope escape check. @@ -3318,49 +3506,60 @@ and type_expect_ 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 default_ghost = {default.pexp_loc with loc_ghost = true} in - let scases = [ - Exp.case - (Pat.construct ~loc:default_ghost - (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) - (Some ([], Pat.var ~loc:default_ghost (mknoloc "*sth*")))) - (Exp.ident ~loc:default_ghost (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 + | Pexp_function (params, body_constraint, body) -> + let in_function = ty_expected_explained, loc in + let exp_type, params, body, newtypes, contains_gadt = + type_function env params body_constraint body ty_expected ~in_function + ~first:true 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 + (* Require that the n-ary function is known to have at least n arrows + in the type. This prevents GADT equations introduced by the parameters + from hiding arrows from the resulting type. + + Performance hack: Only do this check when any of [params] contains a + GADT, as this is the only opportunity for arrows to be hidden from the + resulting type. + *) + begin match contains_gadt with + | No_gadt -> () + | Contains_gadt -> + let ty_function = + List.fold_right + (fun param rest_ty -> + newty + (Tarrow (param.fp_arg_label, newvar (), rest_ty, commu_ok))) + params + (match body with + | Tfunction_body _ -> newvar () + | Tfunction_cases _ -> + newty (Tarrow (Nolabel, newvar (), newvar (), commu_ok))) + in + try unify env ty_function exp_type + with Unify trace -> + let syntactic_arity = + List.length params + + (match body with + | Tfunction_body _ -> 0 + | Tfunction_cases _ -> 1) + in + let err = + Function_arity_type_clash + { syntactic_arity; + type_constraint = exp_type; + trace; + } + in + raise (Error (loc, env, err)) + end; + re + { exp_desc = Texp_function (params, body); + exp_loc = loc; + exp_extra = + List.map (fun { txt; loc } -> Texp_newtype txt, loc, []) newtypes; + exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } | Pexp_apply(sfunct, sargs) -> assert (sargs <> []); let rec lower_args seen ty_fun = @@ -3417,7 +3616,8 @@ and type_expect_ in let cases, partial = type_cases Computation env - arg.exp_type ty_expected_explained true loc caselist in + arg.exp_type ty_expected_explained + ~check_if_total:true loc caselist in if List.for_all (fun c -> pattern_needs_partial_application_check c.c_lhs) cases @@ -3432,7 +3632,8 @@ and type_expect_ 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 + Predef.type_exn ty_expected_explained + ~check_if_total:false loc caselist in re { exp_desc = Texp_try(body, cases); exp_loc = loc; exp_extra = []; @@ -3605,14 +3806,14 @@ and type_expect_ | Some exp -> let ty_exp = instance exp.exp_type in let unify_kept lbl = - let _, ty_arg1, ty_res1 = instance_label false lbl in + let _, ty_arg1, ty_res1 = instance_label ~fixed: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 + let _, ty_arg2, ty_res2 = instance_label ~fixed: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); @@ -3661,7 +3862,7 @@ and type_expect_ let (record, label, _) = type_label_access env srecord Env.Projection lid in - let (_, ty_arg, ty_res) = instance_label false label in + let (_, ty_arg, ty_res) = instance_label ~fixed:false label in unify_exp env record ty_res; rue { exp_desc = Texp_field(record, lid, label); @@ -3736,11 +3937,16 @@ and type_expect_ | Pexp_while(scond, sbody) -> let cond = type_expect env scond (mk_expected ~explanation:While_loop_conditional Predef.type_bool) in + let exp_type = + match cond.exp_desc with + | Texp_construct(_, {cstr_name="true"}, _) -> instance ty_expected + | _ -> instance Predef.type_unit + 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_type; exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_for(param, slow, shigh, dir, sbody) -> @@ -3771,98 +3977,20 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_constraint (sarg, sty) -> - (* Pretend separate = true, 1% slowdown for lablgtk *) - let cty = - with_local_level begin fun () -> - Typetexp.transl_simple_type env ~closed:false sty - end - ~post:(fun cty -> generalize_structure cty.ctyp_type) - in - let ty = cty.ctyp_type in - let (arg, ty') = (type_argument env sarg ty (instance ty), instance ty) in + let (ty, exp_extra) = type_constraint env sty in + let arg = type_argument env sarg ty (instance ty) in rue { exp_desc = arg.exp_desc; exp_loc = arg.exp_loc; - exp_type = ty'; + exp_type = instance ty; exp_attributes = arg.exp_attributes; exp_env = env; - exp_extra = - (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra; + exp_extra = (exp_extra, 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 - let arg, gen = - let lv = get_current_level () in - with_local_level begin fun () -> - let arg = type_exp env sarg in - (arg, generalizable lv arg.exp_type) - end - ~post:(fun (arg,_) -> enforce_current_level env arg.exp_type) - in - begin match arg.exp_desc, !self_coercion, get_desc ty' 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 err -> - (* prerr_endline "coercion failed"; *) - raise(error(loc, env, Not_subtype err)) - end; - | _ -> - let ty, b = enlarge_type env ty' in - force (); - begin try Ctype.unify env arg.exp_type ty with Unify err -> - let expanded = full_expand ~may_forget_scope:true env ty' in - raise(error(sarg.pexp_loc, env, - Coercion_failure({ty = ty'; expanded}, err, b))) - end - end; - (arg, ty', None, cty') - | Some sty -> - let cty, ty, force, cty', ty', force' = - with_local_level_iter ~post:generalize_structure begin fun () -> - let (cty, ty, force) = - Typetexp.transl_simple_type_delayed env sty - and (cty', ty', force') = - Typetexp.transl_simple_type_delayed env sty' - in - ((cty, ty, force, cty', ty', force'), - [ty; ty']) - end - in - begin try - let force'' = subtype env (instance ty) (instance ty') in - force (); force' (); force'' () - with Subtype err -> - raise(error(loc, env, Not_subtype err)) - end; - (type_argument env sarg ty (instance ty), - instance ty', Some cty, cty') + let arg, ty', exp_extra = + type_coerce (expression_constraint sarg) env loc sty sty' + ~loc_arg:sarg.pexp_loc in rue { exp_desc = arg.exp_desc; @@ -3870,8 +3998,7 @@ and type_expect_ exp_type = ty'; exp_attributes = arg.exp_attributes; exp_env = env; - exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) :: - arg.exp_extra; + exp_extra = (exp_extra, loc, sexp.pexp_attributes) :: arg.exp_extra; } | Pexp_send (e, {txt=met}) -> let obj = type_exp env e in @@ -3889,7 +4016,7 @@ and type_expect_ if !Clflags.principal && get_level typ <> generic_level then Location.prerr_warning loc (Warnings.Not_principal "this use of a polymorphic method"); - snd (instance_poly false tl ty) + snd (instance_poly ~fixed:false tl ty) | Tvar _ -> let ty' = newvar () in unify env (instance typ) (newty(Tpoly(ty',[]))); @@ -4019,10 +4146,12 @@ and type_expect_ | _ -> Mp_present in let scope = create_scope () in + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in + let md_shape = Shape.set_uid_if_none md_shape md_uid in let md = { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc; - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } + md_uid; } in let (id, new_env) = match name.txt with @@ -4058,7 +4187,7 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_letexception(cd, sbody) -> - let (cd, newenv) = Typedecl.transl_exception env cd in + let (cd, newenv, _shape) = Typedecl.transl_exception env cd in let body = type_expect newenv sbody ty_expected_explained in re { exp_desc = Texp_letexception(cd, body); @@ -4138,7 +4267,7 @@ and type_expect_ with_local_level begin fun () -> let vars, ty'' = with_local_level_if_principal - (fun () -> instance_poly true tl ty') + (fun () -> instance_poly ~fixed:true tl ty') ~post:(fun (_,ty'') -> generalize_structure ty'') in let exp = type_expect env sbody (mk_expected ty'') in @@ -4159,36 +4288,9 @@ and type_expect_ 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 - (* Use [with_local_level] just for scoping *) - let body, ety, id = with_local_level begin fun () -> - (* 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 (get_id t) then () - else begin - Hashtbl.add seen (get_id t) (); - match get_desc t 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; - (body, ety, id) - end + let body, ety, id = type_newtype loc env name (fun env -> + let expr = type_exp env sbody in + expr, expr.exp_type) in (* non-expansive if the body is non-expansive, so we don't introduce any new extra node in the typed AST. *) @@ -4285,7 +4387,8 @@ and type_expect_ 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] + ty_params (mk_expected ty_func_result) + ~check_if_total:true loc [scase] in let body = match cases with @@ -4354,6 +4457,177 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } +and expression_constraint pexp = + { type_without_constraint = (fun env -> + let expr = type_exp env pexp in + expr, expr.exp_type); + type_with_constraint = + (fun env ty -> type_argument env pexp ty (instance ty)); + is_self = + (fun expr -> + match expr.exp_desc with + | Texp_ident (_, _, { val_kind = Val_self _ }) -> true + | _ -> false); + } + +(** Types a body in the scope of a coercion (with an optional constraint) + and returns the inferred type. See the comment on {!constraint_arg} for + an explanation of how this typechecking is polymorphic in the body. +*) +and type_coerce + : type a. a constraint_arg -> _ -> _ -> _ -> _ -> loc_arg:_ + -> a * type_expr * exp_extra = + fun constraint_arg env loc sty sty' ~loc_arg -> + (* 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 { is_self; type_with_constraint; type_without_constraint } = + constraint_arg + in + match sty with + | None -> + let (cty', ty', force) = + Typetexp.transl_simple_type_delayed env sty' + in + let arg, arg_type, gen = + let lv = get_current_level () in + with_local_level begin fun () -> + let arg, arg_type = type_without_constraint env in + arg, arg_type, generalizable lv arg_type + end + ~post:(fun (_, arg_type, _) -> enforce_current_level env arg_type) + in + begin match !self_coercion, get_desc ty' with + | ((path, r) :: _, Tconstr (path', _, _)) + when is_self arg && Path.same path path' -> + (* prerr_endline "self coercion"; *) + r := loc :: !r; + force () + | _ when free_variables ~env arg_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_type ty; true + with Unify _ -> + backtrack snap; false + then () + else begin try + let force' = subtype env arg_type ty' in + force (); force' (); + if not gen && !Clflags.principal then + Location.prerr_warning loc + (Warnings.Not_principal "this ground coercion"); + with Subtype err -> + (* prerr_endline "coercion failed"; *) + raise (Error (loc, env, Not_subtype err)) + end; + | _ -> + let ty, b = enlarge_type env ty' in + force (); + begin try Ctype.unify env arg_type ty with Unify err -> + let expanded = full_expand ~may_forget_scope:true env ty' in + raise(Error(loc_arg, env, + Coercion_failure ({ ty = ty'; expanded }, err, b))) + end + end; + (arg, ty', Texp_coerce (None, cty')) + | Some sty -> + let cty, ty, force, cty', ty', force' = + with_local_level_iter ~post:generalize_structure begin fun () -> + let (cty, ty, force) = + Typetexp.transl_simple_type_delayed env sty + and (cty', ty', force') = + Typetexp.transl_simple_type_delayed env sty' + in + ((cty, ty, force, cty', ty', force'), + [ ty; ty' ]) + end + in + begin try + let force'' = subtype env (instance ty) (instance ty') in + force (); force' (); force'' () + with Subtype err -> + raise (Error (loc, env, Not_subtype err)) + end; + (type_with_constraint env ty, + instance ty', Texp_coerce (Some cty, cty')) + +and type_constraint env sty = + (* Pretend separate = true, 1% slowdown for lablgtk *) + let cty = + with_local_level begin fun () -> + Typetexp.transl_simple_type env ~closed:false sty + end + ~post:(fun cty -> generalize_structure cty.ctyp_type) + in + cty.ctyp_type, Texp_constraint cty + +(** Types a body in the scope of a coercion (:>) or a constraint (:), and + unifies the inferred type with the expected type. + + @param loc the location of the overall constraint + @param loc_arg the location of the thing being constrained +*) +and type_constraint_expect + : type a. a constraint_arg -> _ -> _ -> loc_arg:_ -> _ -> _ -> a * _ * _ = + fun constraint_arg env loc ~loc_arg constraint_ ty_expected -> + let ret, ty, exp_extra = + match constraint_ with + | Pcoerce (ty_constrain, ty_coerce) -> + type_coerce constraint_arg env loc ty_constrain ty_coerce ~loc_arg + | Pconstraint ty_constrain -> + let ty, exp_extra = type_constraint env ty_constrain in + constraint_arg.type_with_constraint env ty, ty, exp_extra + in + unify_exp_types loc env ty (instance ty_expected); + ret, ty, exp_extra + +(** Typecheck the body of a newtype. The "body" of a newtype may be: + - an expression + - a suffix of function parameters together with a function body + That's why this function is polymorphic over the body. + + @param type_body A function that produces a type for the body given the + environment. When typechecking an expression, this is [type_exp]. + @return The type returned by [type_body] but with the Tconstr + nodes for the newtype properly linked. +*) +and type_newtype + : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr * Ident.t = + fun loc env name type_body -> + let ty = + if Typetexp.valid_tyvar_name name then + newvar ~name () + else + newvar () + in + (* Use [with_local_level] just for scoping *) + with_local_level begin fun () -> + (* Create a fake abstract type declaration for [name]. *) + let decl = new_local_type ~loc Definition in + let scope = create_scope () in + let (id, new_env) = Env.enter_type ~scope name decl env in + + let result, exp_type = type_body new_env 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 (get_id t) then () + else begin + Hashtbl.add seen (get_id t) (); + match get_desc t 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 exp_type in + replace ety; + (result, ety, id) + end + and type_ident env ?(recarg=Rejected) lid = let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in let is_recarg = @@ -4389,66 +4663,276 @@ and type_binding_op_ident env s = 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 +(** Returns the argument type and then the return type. + + @param first Whether the parameter corresponding to the argument of + [ty_expected] is the first parameter to the (n-ary) function. This only + affects error messages. + @param in_function Information about the [Pexp_function] node that's in the + process of being typechecked (its overall type and its location). Again, + this is only used to improve error messages. +*) +and split_function_ty env ty_expected ~arg_label ~first ~in_function = + let { ty = ty_fun; explanation }, loc = in_function in let separate = !Clflags.principal || Env.has_local_constraints env in - let ty_arg, ty_res = - with_local_level_iter_if separate ~post:generalize_structure begin fun () -> - let (ty_arg, ty_res) = - try filter_arrow env (instance ty_expected) arg_label - with Filter_arrow_failed err -> - let err = match err with - | Unification_error unif_err -> - Expr_type_clash(unif_err, explanation, None) - | Label_mismatch { got; expected; expected_type} -> - Abstract_wrong_label { got; expected; expected_type; explanation } - | Not_a_function -> begin - match in_function with - | Some _ -> Too_many_arguments(ty_fun, explanation) - | None -> Not_a_function(ty_fun, explanation) - end + with_local_level_iter_if separate ~post:generalize_structure begin fun () -> + let ty_arg, ty_res = + try filter_arrow env (instance ty_expected) arg_label + with Filter_arrow_failed err -> + let err = match err with + | Unification_error unif_err -> + Expr_type_clash (unif_err, explanation, None) + | Label_mismatch { got; expected; expected_type } -> + Abstract_wrong_label { got; expected; expected_type; explanation } + | Not_a_function -> + if first + then Not_a_function (ty_fun, explanation) + else Too_many_arguments (ty_fun, explanation) + in + raise (Error(loc, env, err)) + 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 + (ty_arg, ty_res), [ ty_arg; ty_res ] + end + +(* Typecheck parameters one at a time followed by the body. Later parameters + are checked in the scope of earlier ones. That's necessary to support + constructs like [fun (type a) (x : a) -> ...] and + [fun (module M : S) (x : M.t) -> ...]. + + Operates like [type_expect] in that it unifies the "type of the remaining + function params + body" with [ty_expected], and returns out the inferred + type. + + See [split_function_ty] for the meaning of [first] and [in_function]. + + Returns (inferred_ty, params, body, newtypes, contains_gadt), where: + - [newtypes] are the newtypes immediately bound by the prefix of function + parameters. These should be added to an [exp_extra] node. + - [contains_gadt] is whether any of [params] contains a GADT. Note + this does not indicate whether [body] contains a GADT (if it's + [Tfunction_cases]). +*) +and type_function + env params_suffix body_constraint body ty_expected ~first ~in_function + = + let ty_fun, (loc_function : Location.t) = in_function in + (* The "rest of the function" extends from the start of the first parameter + to the end of the overall function. The parser does not construct such + a location so we forge one for type errors. + *) + let loc : Location.t = + match params_suffix, body with + | param :: _, _ -> + { loc_start = param.pparam_loc.loc_start; + loc_end = loc_function.loc_end; + loc_ghost = true; + } + | [], Pfunction_body pexp -> pexp.pexp_loc + | [], Pfunction_cases (_, loc_cases, _) -> loc_cases + in + match params_suffix with + | { pparam_desc = Pparam_newtype newtype; pparam_loc = _ } :: rest -> + (* Check everything else in the scope of (type a). *) + let (params, body, newtypes, contains_gadt), exp_type, _ = + type_newtype loc env newtype.txt (fun env -> + let exp_type, params, body, newtypes, contains_gadt = + (* mimic the typing of Pexp_newtype by minting a new type var, + like [type_exp]. + *) + type_function env rest body_constraint body (newvar ()) + ~first:false ~in_function in + (params, body, newtypes, contains_gadt), exp_type) (* Merlin: we recover with an expected type of 'a -> 'b *) - let level = get_level (instance ty_expected) in + (* let level = get_level (instance ty_expected) in raise_error (error(loc_fun, env, err)); - (newvar2 level, newvar2 level) + (newvar2 level, newvar2 level) *) 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 + with_explanation ty_fun.explanation (fun () -> + unify_exp_types loc env exp_type (instance ty_expected)); + exp_type, params, body, newtype :: newtypes, contains_gadt + | { pparam_desc = Pparam_val (arg_label, default_arg, pat); pparam_loc } + :: rest + -> + let ty_arg, ty_res = + split_function_ty env ty_expected ~arg_label ~first ~in_function in - ((ty_arg, ty_res), [ty_arg; ty_res]) - end - in - 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, commu_ok))); - exp_attributes = attrs; - exp_env = env } + (* [ty_arg_internal] is the type of the parameter viewed internally + to the function. This is different than [ty_arg] exactly for + optional arguments with defaults, where the external [ty_arg] + is optional and the internal view is not optional. + *) + let ty_arg_internal, default_arg = + match default_arg with + | None -> ty_arg, None + | Some default -> + assert (is_optional arg_label); + let ty_default = newvar () in + begin + try unify env (type_option ty_default) ty_arg + with Unify _ -> assert false; + end; + (* Issue#12668: Retain type-directed disambiguation of + ?x:(y : Variant.t = Constr) + *) + let default = + match pat.ppat_desc with + | Ppat_constraint (_, sty) -> + let gloc = { default.pexp_loc with loc_ghost = true } in + Ast_helper.Exp.constraint_ default sty ~loc:gloc + | _ -> default + in + let default = type_expect env default (mk_expected ty_default) in + ty_default, Some default + in + let (pat, params, body, newtypes, contains_gadt), partial = + (* Check everything else in the scope of the parameter. *) + map_half_typed_cases Value env ty_arg_internal ty_res pat.ppat_loc + ~check_if_total:true + (* We don't make use of [case_data] here so we pass unit. *) + [ { pattern = pat; has_guard = false; needs_refute = false }, () ] + ~type_body:begin + fun () pat ~ext_env ~ty_expected ~ty_infer:_ + ~contains_gadt:param_contains_gadt -> + let _, params, body, newtypes, suffix_contains_gadt = + type_function ext_env rest body_constraint body + ty_expected ~first:false ~in_function + in + let contains_gadt = + if param_contains_gadt then + Contains_gadt + else + suffix_contains_gadt + in + (pat, params, body, newtypes, contains_gadt) + end + |> function + (* The result must be a singleton because we passed a singleton + list above. *) + | [ result ], partial -> result, partial + | ([] | _ :: _ :: _), _ -> assert false + in + let exp_type = + instance (newgenty (Tarrow (arg_label, ty_arg, ty_res, commu_ok))) + in + (* This is quadratic, as it operates over the entire tail of the + type for each new parameter. Now that functions are n-ary, we + could possibly run this once. + *) + with_explanation ty_fun.explanation (fun () -> + unify_exp_types loc env exp_type (instance ty_expected)); + (* This is quadratic, as it extracts all of the parameters from an arrow + type for each parameter that's added. Now that functions are n-ary, + there might be an opportunity to improve this. + *) + 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 + pat.pat_loc + Warnings.Unerasable_optional_argument; + let fp_kind, fp_param = + match default_arg with + | None -> + let param = name_pattern "param" [ pat ] in + Tparam_pat pat, param + | Some default_arg -> + let param = Ident.create_local "*opt*" in + Tparam_optional_default (pat, default_arg), param + in + let param = + { fp_kind; + fp_arg_label = arg_label; + fp_param; + fp_partial = partial; + fp_newtypes = newtypes; + fp_loc = pparam_loc; + } + in + exp_type, param :: params, body, [], contains_gadt + | [] -> + let exp_type, body = + match body with + | Pfunction_body body -> + let body = + match body_constraint with + | None -> type_expect env body (mk_expected ty_expected) + | Some constraint_ -> + let body_loc = body.pexp_loc in + let body, exp_type, exp_extra = + type_constraint_expect (expression_constraint body) + env body_loc ~loc_arg:body_loc constraint_ ty_expected + in + { body with + exp_extra = (exp_extra, body_loc, []) :: body.exp_extra; + exp_type; + } + in + body.exp_type, Tfunction_body body + | Pfunction_cases (cases, _, attributes) -> + let type_cases_expect env ty_expected = + type_function_cases_expect + env ty_expected loc cases attributes ~first ~in_function + in + let (cases, partial, exp_type), exp_extra = + match body_constraint with + | None -> type_cases_expect env ty_expected, None + | Some constraint_ -> + (* The typing of function case coercions/constraints is + analogous to the typing of expression coercions/constraints. + + - [type_with_constraint]: If there is a constraint, then call + [type_argument] on the cases, and discard the cases' + inferred type in favor of the constrained type. (Function + cases aren't inferred, so [type_argument] would just call + [type_expect] straightaway, so we do the same here.) + - [type_without_constraint]: If there is just a coercion and + no constraint, call [type_exp] on the cases and surface the + cases' inferred type to [type_constraint_expect]. *) + let function_cases_constraint_arg = + { is_self = (fun _ -> false); + type_with_constraint = (fun env ty -> + let cases, partial, _ = type_cases_expect env ty in + cases, partial); + type_without_constraint = (fun env -> + let cases, partial, ty_fun = + (* The analogy to [type_exp] for expressions. *) + type_cases_expect env (newvar ()) + in + (cases, partial), ty_fun); + } + in + let (cases, partial), exp_type, exp_extra = + type_constraint_expect function_cases_constraint_arg + env loc constraint_ ty_expected ~loc_arg:loc + in + (cases, partial, exp_type), Some exp_extra + in + let param = name_cases "param" cases in + let body = + Tfunction_cases + { cases; partial; param; loc; exp_extra; attributes } + in + exp_type, body + in + (* [No_gadt] is fine because this return value is only meant to indicate + whether [params] (here, the empty list) contains any GADT, not whether + the body is a [Tfunction_cases] whose patterns include a GADT. + *) + exp_type, [], body, [], No_gadt and type_label_access env srecord usage lid = @@ -4751,7 +5235,8 @@ and type_label_exp create env loc ty_expected let (vars, ty_arg, ty_res) = with_local_level_iter_if separate ~post:generalize_structure begin fun () -> - let ((_, ty_arg, ty_res) as r) = instance_label true label in + let ((_, ty_arg, ty_res) as r) = + instance_label ~fixed:true label in (r, [ty_arg; ty_res]) end in @@ -4878,7 +5363,10 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = } in let exp_env = Env.add_value id desc env in - {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; + {pat_desc = + Tpat_var (id, mknoloc name, desc.val_uid); + 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; @@ -4894,11 +5382,16 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = (texp, args @ [Nolabel, Some eta_var])} in - let cases = [case eta_pat e] in + let cases = [ case eta_pat e ] in + let cases_loc = { texp.exp_loc with loc_ghost = true } 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; } } + Texp_function ([], + Tfunction_cases + { cases; partial = Total; param; loc = cases_loc; + exp_extra = None; attributes = []; + }) + } in Location.prerr_warning texp.exp_loc (Warnings.Eliminated_optional_arguments @@ -4910,7 +5403,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = 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; + vb_loc=Location.none; vb_rec_kind = Not_recursive; }], func let_var) } end @@ -5233,12 +5726,29 @@ and type_construct env loc lid sarg ty_expected_explained attrs = and type_statement ?explanation env sexp = let has_errors = Msupport.monitor_errors () in + (* OCaml 5.2.0 changed the type of 'while' to give 'while true do e done' + a polymorphic type. The change has the potential to trigger a + nonreturning-statement warning in existing code that follows + 'while true' with some other statement, e.g. + + while true do e done; assert false + + To avoid this issue, we disable the warning in this particular case. + We might consider re-enabling it at a point when most users have + migrated to OCaml 5.2.0 or later. *) + let allow_polymorphic e = match e.exp_desc with + | Texp_while _ -> true + | _ -> false + in (* Raise the current level to detect non-returning functions *) let exp = with_local_level (fun () -> type_exp env sexp) in + let subexp = final_subexpression exp in let ty = expand_head env exp.exp_type in - if is_Tvar ty && get_level ty > get_current_level () && not !has_errors then + if is_Tvar ty && not !has_errors + && get_level ty > get_current_level () + && not (allow_polymorphic subexp) then Location.prerr_warning - (final_subexpression exp).exp_loc + subexp.exp_loc Warnings.Nonreturning_statement; if !Clflags.strict_sequence then let expected_ty = instance Predef.type_unit in @@ -5251,17 +5761,38 @@ and type_statement ?explanation env sexp = exp end -(* 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 -> +(* Most of the arguments are the same as [type_cases]. + + Takes a callback which is responsible for typing the body of the case. + The arguments are documented inline in the type signature. + + It takes a callback rather than returning the half-typed cases directly + because the typing of the body must take place at an increased level. + + The overall function returns: + - The data returned by the callback + - Whether the cases' patterns are partial or total +*) +and map_half_typed_cases + : type k ret case_data. + ?additional_checks_for_split_cases:((_ * ret) list -> unit) + -> k pattern_category -> _ -> _ -> _ -> _ + -> (untyped_case * case_data) list + -> type_body:( + case_data + -> k general_pattern (* the typed pattern *) + -> ext_env:_ (* environment with module variables / pattern variables *) + -> ty_expected:_ (* type to check body in scope of *) + -> ty_infer:_ (* type to infer for body *) + -> contains_gadt:_ (* whether the pattern contains a GADT *) + -> ret) + -> check_if_total:bool (* if false, assume Partial right away *) + -> ret list * partial + = fun ?additional_checks_for_split_cases + category env ty_arg ty_res loc caselist ~type_body ~check_if_total -> 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 patterns = List.map (fun ((x : untyped_case), _) -> x.pattern) 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 @@ -5278,8 +5809,8 @@ and type_cases | _ -> false in let needs_exhaust_check = match caselist with - [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true - | [{pc_lhs}] when is_var pc_lhs -> false + [ ({ needs_refute = true }, _) ] -> true + | [ ({ pattern }, _) ] when is_var pattern -> false | _ -> true in let outer_level = get_current_level () in @@ -5307,7 +5838,7 @@ and type_cases Printtyp.raw_type_expr ty_arg; *) let half_typed_cases = List.map - (fun ({pc_lhs; pc_guard = _; pc_rhs = _} as case) -> + (fun ({ Parmatch.pattern; _ } as untyped_case, case_data) -> let htc = with_local_level_if_principal begin fun () -> let ty_arg = @@ -5316,16 +5847,18 @@ and type_cases (fun () -> instance ?partial:take_partial_instance ty_arg) in let (pat, ext_env, force, pvs, mvs) = - type_pattern category ~lev env pc_lhs ty_arg allow_modules + type_pattern category ~lev env pattern ty_arg allow_modules in pattern_force := force @ !pattern_force; { typed_pat = pat; pat_type_for_unif = ty_arg; - untyped_case = case; + untyped_case; + case_data; branch_env = ext_env; pat_vars = pvs; module_vars = mvs; - contains_gadt = contains_gadt (as_comp_pattern category pat); } + contains_gadt = contains_gadt (as_comp_pattern category pat); + } end ~post: begin fun htc -> iter_pattern_variables_type generalize_structure htc.pat_vars; @@ -5352,7 +5885,7 @@ and type_cases 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 + unify_pat_types pat.pat_loc env pat_ty ty ) half_typed_cases in unify_pats ty_arg'; @@ -5379,20 +5912,23 @@ and type_cases end in (* type bodies *) - let in_function = if List.length caselist = 1 then in_function else None in let ty_res' = instance ty_res in - let cases = with_local_level_if_principal ~post:ignore begin fun () -> + let result = with_local_level_if_principal ~post:ignore begin fun () -> List.map - (fun { typed_pat = pat; branch_env = ext_env; - pat_vars = pvs; module_vars = mvs; - untyped_case = {pc_lhs = _; pc_guard; pc_rhs}; - contains_gadt; _ } -> + (fun { typed_pat = pat; branch_env = ext_env; + pat_vars = pvs; module_vars = mvs; + case_data; contains_gadt; _ } + -> let ext_env = if contains_gadt then do_copy_types ext_env else ext_env in + (* Before handing off the cases to the callback, first set up the the + branch environments by adding the variables (and module variables) + from the patterns. + *) let ext_env = add_pattern_variables ext_env pvs ~check:(fun s -> Warnings.Unused_var_strict s) @@ -5402,28 +5938,12 @@ and type_cases let ty_expected = if contains_gadt && not !Clflags.principal then (* Take a generic copy of [ty_res] again to allow propagation of - type information from preceding branches *) + type information from preceding branches *) correct_levels ty_res else ty_res in - let guard = - match pc_guard with - | None -> None - | Some scond -> - Some - (type_expect ext_env scond - (mk_expected ~explanation:When_guard Predef.type_bool)) - in - let exp = - type_expect ?in_function ext_env - pc_rhs (mk_expected ?explanation ty_expected) - in - { - c_lhs = pat; - c_guard = guard; - c_rhs = {exp with exp_type = ty_res'} - } - ) - half_typed_cases + type_body case_data pat ~ext_env ~ty_expected ~ty_infer:ty_res' + ~contains_gadt) + half_typed_cases end in let do_init = may_contain_gadts || needs_exhaust_check in let ty_arg_check = @@ -5432,15 +5952,37 @@ and type_cases Subst.type_expr (Subst.for_saving Subst.identity) ty_arg' else ty_arg' in - let val_cases, exn_cases = + (* Split the cases into val and exn cases so we can do the appropriate checks + for exhaustivity and unused variables. + + The caller of this function can define custom checks. For some of these + checks, the half-typed case doesn't provide enough info on its own -- for + instance, the check for ambiguous bindings in when guards needs to know the + case body's expression -- so the code pairs each case with its + corresponding element in [result] before handing it off to the caller's + custom checks. + *) + let val_cases_with_result, exn_cases_with_result = match category with - | Value -> (cases : value case list), [] - | Computation -> split_cases env cases in + | Value -> + let val_cases = + List.map2 + (fun htc res -> + { htc.untyped_case with pattern = htc.typed_pat }, res) + half_typed_cases + result + in + (val_cases : (pattern Parmatch.parmatch_case * ret) list), [] + | Computation -> + split_half_typed_cases env (List.combine half_typed_cases result) + in + let val_cases = List.map fst val_cases_with_result in + let exn_cases = List.map fst exn_cases_with_result in if val_cases = [] && exn_cases <> [] then raise (error (loc, env, No_value_clauses)); let partial = - if partial_flag then - check_partial ~lev allow_modules env ty_arg_check loc val_cases + if check_if_total then + check_partial ~lev env ty_arg_check loc val_cases else Partial in @@ -5449,11 +5991,9 @@ and type_cases check_absent_variant branch_env (as_comp_pattern category typed_pat) ) half_typed_cases; with_level_if delayed ~level:lev begin fun () -> - check_unused ~lev allow_modules env ty_arg_check val_cases ; - check_unused ~lev allow_modules env Predef.type_exn exn_cases ; + check_unused ~lev env ty_arg_check val_cases ; + check_unused ~lev env Predef.type_exn exn_cases ; end; - Parmatch.check_ambiguous_bindings val_cases ; - Parmatch.check_ambiguous_bindings exn_cases in if not !has_errors then ( if contains_polyvars then @@ -5462,11 +6002,87 @@ and type_cases (* Check for unused cases, do not delay because of gadts *) unused_check false ); - ((cases, partial), [ty_res']) + begin + match additional_checks_for_split_cases with + | None -> () + | Some check -> + check val_cases_with_result; + check exn_cases_with_result; + end; + (result, partial), [ty_res'] end (* Ensure that existential types do not escape *) ~post:(fun ty_res' -> unify_exp_types loc env ty_res' (newvar ())) +(* Typing of match cases *) +and type_cases + : type k . k pattern_category -> + _ -> _ -> _ -> check_if_total:bool -> _ -> Parsetree.case list -> + k case list * partial + = fun category env + ty_arg ty_res_explained ~check_if_total loc caselist -> + let { ty = ty_res; explanation } = ty_res_explained in + let caselist = + List.map (fun case -> Parmatch.untyped_case case, case) caselist + in + (* Most of the work is done by [map_half_typed_cases]. All that's left + is to typecheck the guards and the cases, and then to check for some + warnings that can fire in the presence of guards. + *) + map_half_typed_cases category env ty_arg ty_res loc caselist ~check_if_total + ~type_body:begin + fun { pc_guard; pc_rhs } pat ~ext_env ~ty_expected ~ty_infer + ~contains_gadt:_ -> + let guard = + match pc_guard with + | None -> None + | Some scond -> + Some + (type_expect ext_env scond + (mk_expected ~explanation:When_guard Predef.type_bool)) + in + let exp = + type_expect ext_env pc_rhs (mk_expected ?explanation ty_expected) + in + { + c_lhs = pat; + c_guard = guard; + c_rhs = {exp with exp_type = ty_infer} + } + end + ~additional_checks_for_split_cases:(fun cases -> + let cases = + List.map + (fun (case_with_pat, case) -> + { case with c_lhs = case_with_pat.Parmatch.pattern }) cases + in + Parmatch.check_ambiguous_bindings cases) + + +(** A version of [type_expect], but that operates over function cases instead + of expressions. The input type is like the [ty_expected] argument to + [type_expect], and the returned type is like the [exp_type] of the + expression returned by [type_expect]. + + See [split_function_ty] for the meaning of [first] and [in_function]. +*) +and type_function_cases_expect + env ty_expected loc cases attrs ~first ~in_function = + Builtin_attributes.warning_scope attrs begin fun () -> + let ty_arg, ty_res = + split_function_ty env ty_expected ~arg_label:Nolabel ~first ~in_function + in + let cases, partial = + type_cases Value env ty_arg (mk_expected ty_res) + ~check_if_total:true loc cases + in + let ty_fun = + instance (newgenty (Tarrow (Nolabel, ty_arg, ty_res, commu_ok))) + in + unify_exp_types loc env ty_fun (instance ty_expected); + cases, partial, ty_fun + end + (* Typing of let bindings *) and type_let ?check ?check_strict @@ -5493,11 +6109,11 @@ and type_let ?check ?check_strict match get_desc pat.pat_type with | Tpoly (ty, tl) -> {pat with pat_type = - snd (instance_poly ~keep_names:true false tl ty)} + snd (instance_poly ~keep_names:true ~fixed:false tl ty)} | _ -> pat in let bound_expr = vb_exp_constraint binding in - unify_pat (ref env) pat (type_approx env bound_expr)) + unify_pat env pat (type_approx env bound_expr)) pat_list spat_sexp_list; (* Polymorphic variant processing *) List.iter @@ -5552,7 +6168,7 @@ and type_let ?check ?check_strict let vars, ty' = with_local_level_if_principal ~post:(fun (_,ty') -> generalize_structure ty') - (fun () -> instance_poly ~keep_names:true true tl ty) + (fun () -> instance_poly ~keep_names:true ~fixed:true tl ty) in let exp = Builtin_attributes.warning_scope pvb_attributes (fun () -> @@ -5570,8 +6186,9 @@ and type_let ?check ?check_strict (fun pat (attrs, exp) -> Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> - ignore(check_partial allow_modules env pat.pat_type pat.pat_loc - [case pat exp] : Typedtree.partial) + let case = Parmatch.typed_case (case pat exp) in + ignore(check_partial env pat.pat_type pat.pat_loc + [case] : Typedtree.partial) ) ) pat_list @@ -5611,8 +6228,9 @@ and type_let ?check ?check_strict let l = List.map2 (fun (p, (e, _)) pvb -> + (* vb_rec_kind will be computed later for recursive bindings *) {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes; - vb_loc=pvb.pvb_loc; + vb_loc=pvb.pvb_loc; vb_rec_kind = Not_recursive; }) l spat_sexp_list in @@ -5620,7 +6238,7 @@ and type_let ?check ?check_strict List.iter (fun {vb_pat=pat} -> match pat.pat_desc with Tpat_var _ -> () - | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> () + | Tpat_alias ({pat_desc=Tpat_any}, _, _, _) -> () | _ -> raise(error(pat.pat_loc, env, Illegal_letrec_pat))) l; List.iter (fun vb -> @@ -5655,7 +6273,7 @@ and type_let_def_wrap_warnings in let sexp_is_fun { pvb_expr = sexp; _ } = match sexp.pexp_desc with - | Pexp_fun _ | Pexp_function _ -> true + | Pexp_function _ -> true | _ -> false in let exp_env = @@ -5958,9 +6576,13 @@ let report_literal_type_constraint expected_type const = Some '.' else None in + let pp_const ppf (c,s) = Format.fprintf ppf "%s%c" c s in match const_str, suffix with - | Some c, Some s -> [ Location.msg "@[@{Hint@}: Did you \ - mean `%s%c'?@]" c s ] + | Some c, Some s -> [ + Location.msg + "@[@{Hint@}: Did you mean %a?@]" + (Style.as_inline_code pp_const) (c,s) + ] | _, _ -> [] let report_literal_type_constraint const = function @@ -6033,7 +6655,8 @@ let report_unification_error ~loc ?sub env err let report_this_function ppf funct = if Typedtree.exp_is_nominal funct then let pexp = Untypeast.untype_expression funct in - Format.fprintf ppf "The function '%a'" Pprintast.expression pexp + Format.fprintf ppf "The function %a" + (Style.as_inline_code Pprintast.expression) pexp else Format.fprintf ppf "This function" let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc @@ -6071,12 +6694,12 @@ let report_error ~loc env = function Location.errorf ~loc "@[The constructor %a@ expects %i argument(s),@ \ but is applied here to %i argument(s)@]" - longident lid expected provided + (Style.as_inline_code longident) lid expected provided | Label_mismatch(lid, err) -> report_unification_error ~loc env err (function ppf -> fprintf ppf "The record field %a@ belongs to the type" - longident lid) + (Style.as_inline_code longident) lid) (function ppf -> fprintf ppf "but is mixed here with fields of type") | Pattern_type_clash (err, pat) -> @@ -6091,19 +6714,21 @@ let report_error ~loc env = function | Or_pattern_type_clash (id, err) -> report_unification_error ~loc env err (function ppf -> - fprintf ppf "The variable %s on the left-hand side of this \ - or-pattern has type" (Ident.name id)) + fprintf ppf "The variable %a on the left-hand side of this \ + or-pattern has type" Style.inline_code (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 + "Variable %a is bound several times in this matching" + Style.inline_code 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); + "Variable %a must occur on both sides of this %a pattern" + Style.inline_code (Ident.name id) + Style.inline_code "|" + ; spellcheck_idents ppf id valid_idents ) () | Expr_type_clash (err, explanation, exp) -> @@ -6116,6 +6741,46 @@ let report_error ~loc env = function fprintf ppf "This expression has type") (function ppf -> fprintf ppf "but an expression was expected of type"); + | Function_arity_type_clash { + syntactic_arity; type_constraint; trace = { trace }; + } -> + (* The last diff's expected type will be the locally-abstract type + that the GADT pattern introduced an equation on. + *) + let type_with_local_equation = + let last_diff = + List.find_map + (function Errortrace.Diff diff -> Some diff | _ -> None) + (List.rev trace) + in + match last_diff with + | None -> None + | Some diff -> Some diff.expected.ty + in + (* [syntactic_arity>1] for this error, so "arguments" is always plural. *) + Location.errorf ~loc + "@[\ + @[\ + The syntactic arity of the function doesn't match the type constraint:@ \ + @[<2>\ + This function has %d syntactic arguments, but its type is constrained \ + to@ %a.\ + @]@ \ + @]@ \ + @[\ + @[<2>@{Hint@}: \ + consider splitting the function definition into@ %a@ \ + where %a is the pattern with the GADT constructor that@ \ + introduces the local type equation%t.\ + @]" + syntactic_arity + (Style.as_inline_code Printtyp.type_expr) type_constraint + Style.inline_code "fun ... gadt_pat -> fun ..." + Style.inline_code "gadt_pat" + (fun ppf -> + Option.iter + (fprintf ppf " on %a" (Style.as_inline_code Printtyp.type_expr)) + type_with_local_equation) | Apply_non_function { funct; func_ty; res_ty; previous_arg_loc; extra_arg_loc } -> @@ -6129,13 +6794,15 @@ let report_error ~loc env = function ~extra_arg_loc ~returns_unit loc | _ -> Location.errorf ~loc "@[@[<2>This expression has type@ %a@]@ %s@]" - Printtyp.type_expr func_ty + (Style.as_inline_code Printtyp.type_expr) func_ty "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) + | l -> + fprintf ppf "with label %a" + Style.inline_code (prefixed_label_name l) in let extra_info = if not extra_info then @@ -6153,30 +6820,32 @@ let report_error ~loc env = function 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 + let print_label ppf lbl = Style.inline_code ppf (Ident.name lbl) in + let print_labels ppf = List.iter (fprintf ppf "@ %a" print_label) in Location.errorf ~loc "@[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 + Location.errorf ~loc "The record field %a is not mutable" + (Style.as_inline_code 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 \ + "@[The field %a is not part of the record \ argument for the %a constructor@]" - name.txt - Printtyp.type_path type_path; + Style.inline_code name.txt + (Style.as_inline_code 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 + There is no %s %a within type %a@]" + eorp (Style.as_inline_code Printtyp.type_expr) ty (report_type_expected_explanation_opt explanation) (Datatype_kind.label_name kind) - name.txt (*kind*) Printtyp.type_path type_path; + Style.inline_code name.txt + (Style.as_inline_code Printtyp.type_path) type_path; end; spellcheck ppf name.txt valid_names )) () @@ -6187,10 +6856,11 @@ let report_error ~loc env = function 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) + name (Style.as_inline_code longident) lid + type_name) (function ppf -> fprintf ppf "The %s %a@ belongs to one of the following %s types:" - name longident lid type_name) + name (Style.as_inline_code longident) lid type_name) (function ppf -> fprintf ppf "but a %s was expected belonging to the %s type" name type_name) @@ -6201,7 +6871,7 @@ let report_error ~loc env = function Location.error_of_printer ~loc (fun ppf () -> fprintf ppf "This expression is not an object;@ \ it has type %a" - Printtyp.type_expr ty; + (Style.as_inline_code Printtyp.type_expr) ty; report_type_expected_explanation_opt explanation ppf ) () | Undefined_method (ty, me, valid_methods) -> @@ -6209,7 +6879,9 @@ let report_error ~loc env = function Printtyp.wrap_printing_env ~error:true env (fun () -> fprintf ppf "@[@[This expression has type@;<1 2>%a@]@,\ - It has no method %s@]" Printtyp.type_expr ty me; + It has no method %a@]" + (Style.as_inline_code Printtyp.type_expr) ty + Style.inline_code me; begin match valid_methods with | None -> () | Some valid_methods -> spellcheck ppf me valid_methods @@ -6217,19 +6889,20 @@ let report_error ~loc env = function )) () | Undefined_self_method (me, valid_methods) -> Location.error_of_printer ~loc (fun ppf () -> - fprintf ppf "This expression has no method %s" me; + fprintf ppf "This expression has no method %a" Style.inline_code me; spellcheck ppf me valid_methods; ) () | Virtual_class cl -> Location.errorf ~loc "Cannot instantiate the virtual class %a" - longident cl + (Style.as_inline_code longident) cl | Unbound_instance_variable (var, valid_vars) -> Location.error_of_printer ~loc (fun ppf () -> - fprintf ppf "Unbound instance variable %s" var; + fprintf ppf "Unbound instance variable %a" Style.inline_code var; spellcheck ppf var valid_vars; ) () | Instance_variable_not_mutable v -> - Location.errorf ~loc "The instance variable %s is not mutable" v + Location.errorf ~loc "The instance variable %a is not mutable" + Style.inline_code v | Not_subtype err -> Location.error_of_printer ~loc (fun ppf () -> Printtyp.Subtype.report_error ppf env err "is not a subtype of" @@ -6239,8 +6912,8 @@ let report_error ~loc env = function "This object duplication occurs outside a method definition" | Value_multiply_overridden v -> Location.errorf ~loc - "The instance variable %s is overridden several times" - v + "The instance variable %a is overridden several times" + Style.inline_code v | Coercion_failure (ty_exp, err, b) -> Location.error_of_printer ~loc (fun ppf () -> Printtyp.report_unification_error ppf env err @@ -6248,31 +6921,36 @@ let report_error ~loc env = function let ty_exp = Printtyp.prepare_expansion ty_exp in fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \ it has type" - (Printtyp.type_expansion Type) ty_exp) + (Style.as_inline_code @@ Printtyp.type_expansion Type) ty_exp) (function ppf -> fprintf ppf "but is here used with type"); if b then - fprintf ppf ".@.@[%s@ @{Hint@}: Consider using a fully \ - explicit coercion@ %s@]" - "This simple coercion was not fully general." - "of the form: `(foo : ty1 :> ty2)'." + fprintf ppf + ".@.@[This simple coercion was not fully general.@ \ + @{Hint@}: Consider using a fully explicit coercion@ \ + of the form: %a@]" + Style.inline_code "(foo : ty1 :> ty2)" ) () | Not_a_function (ty, explanation) -> Location.errorf ~loc "This expression should not be a function,@ \ the expected type is@ %a%t" - Printtyp.type_expr ty + (Style.as_inline_code Printtyp.type_expr) ty (report_type_expected_explanation_opt explanation) | Too_many_arguments (ty, explanation) -> Location.errorf ~loc "This function expects too many arguments,@ \ it should have type@ %a%t" - Printtyp.type_expr ty + (Style.as_inline_code Printtyp.type_expr) ty (report_type_expected_explanation_opt explanation) | Abstract_wrong_label {got; expected; expected_type; explanation} -> - let label ~long = function - | Nolabel -> "unlabeled" - | l -> (if long then "labeled " else "") ^ prefixed_label_name l + let label ~long ppf = function + | Nolabel -> fprintf ppf "unlabeled" + | l -> + if long then + fprintf ppf "labeled %a" Style.inline_code (prefixed_label_name l) + else + Style.inline_code ppf (prefixed_label_name l) in let second_long = match got, expected with | Nolabel, _ | _, Nolabel -> true @@ -6280,29 +6958,34 @@ let report_error ~loc env = function in Location.errorf ~loc "@[@[<2>This function should have type@ %a%t@]@,\ - @[but its first argument is %s@ instead of %s%s@]@]" - Printtyp.type_expr expected_type + @[but its first argument is %a@ instead of %s%a@]@]" + (Style.as_inline_code Printtyp.type_expr) expected_type (report_type_expected_explanation_opt explanation) - (label ~long:true got) + (label ~long:true) got (if second_long then "being " else "") - (label ~long:second_long expected) + (label ~long:second_long) expected | 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 + "This %a expression has type@ %a@ \ + In this type, the locally bound module name %a escapes its scope" + Style.inline_code "let module" + (Style.as_inline_code Printtyp.type_expr) ty + Style.inline_code id | Private_type ty -> Location.errorf ~loc "Cannot create values of the private type %a" - Printtyp.type_expr ty + (Style.as_inline_code 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 + (Style.as_inline_code longident) lid + (Style.as_inline_code 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 + "Cannot use private constructor %a to create values of type %a" + Style.inline_code constr.cstr_name + (Style.as_inline_code Printtyp.type_expr) ty | Not_a_polymorphic_variant_type lid -> - Location.errorf ~loc "The type %a@ is not a variant type" longident lid + Location.errorf ~loc "The type %a@ is not a variant type" + (Style.as_inline_code longident) lid | Incoherent_label_order -> Location.errorf ~loc "This function is applied to arguments@ \ @@ -6320,45 +7003,42 @@ let report_error ~loc env = function | 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) -> + (Style.as_inline_code Printtyp.type_expr) ty + | Unexpected_existential (reason, name) -> let reason_str = - match reason with + match reason with | In_class_args -> - "Existential types are not allowed in class arguments" + dprintf "Existential types are not allowed in class arguments" | In_class_def -> - "Existential types are not allowed in bindings inside \ + dprintf "Existential types are not allowed in bindings inside \ class definition" | In_self_pattern -> - "Existential types are not allowed in self patterns" + dprintf "Existential types are not allowed in self patterns" | At_toplevel -> - "Existential types are not allowed in toplevel bindings" + dprintf "Existential types are not allowed in toplevel bindings" | In_group -> - "Existential types are not allowed in \"let ... and ...\" bindings" + dprintf "Existential types are not allowed in %a bindings" + Style.inline_code "let ... and ..." | In_rec -> - "Existential types are not allowed in recursive bindings" + dprintf "Existential types are not allowed in recursive bindings" | With_attributes -> - "Existential types are not allowed in presence of attributes" + dprintf + "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 + Location.errorf ~loc + "%t,@ but the constructor %a introduces existential types." + reason_str Style.inline_code name | 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.@]" + "@[Invalid for-loop index: only variables and %a are allowed.@]" + Style.inline_code "_" | No_value_clauses -> Location.errorf ~loc - "None of the patterns in this 'match' expression match values." + "None of the patterns in this %a expression match values." + Style.inline_code "match" | Exception_pattern_disallowed -> Location.errorf ~loc "@[Exception patterns are not allowed in this position.@]" @@ -6375,41 +7055,47 @@ let report_error ~loc env = function "@[This constructor expects an inlined record argument.@]" | Unrefuted_pattern pat -> Location.errorf ~loc - "@[%s@ %s@ %a@]" + "@[%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 + (Style.as_inline_code Printpat.pretty_val) pat | Invalid_extension_constructor_payload -> Location.errorf ~loc - "Invalid [%%extension_constructor] payload, a constructor is expected." + "Invalid %a payload, a constructor is expected." + Style.inline_code "[%extension_constructor]" | 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 + "Integer literal exceeds the range of representable integers of type %a" + Style.inline_code ty | Unknown_literal (n, m) -> - Location.errorf ~loc "Unknown modifier '%c' for literal %s%c" m n m + let pp_lit ppf (n,m) = fprintf ppf "%s%c" n m in + Location.errorf ~loc "Unknown modifier %a for literal %a" + (Style.as_inline_code pp_print_char) m + (Style.as_inline_code pp_lit) (n,m) | Illegal_letrec_pat -> Location.errorf ~loc - "Only variables are allowed as left-hand side of `let rec'" + "Only variables are allowed as left-hand side of %a" + Style.inline_code "let rec" | Illegal_letrec_expr -> Location.errorf ~loc - "This kind of expression is not allowed as right-hand side of `let rec'" + "This kind of expression is not allowed as right-hand side of %a" + Style.inline_code "let rec" | Illegal_class_expr -> Location.errorf ~loc "This kind of recursive class expression is not allowed" | Letop_type_clash(name, err) -> report_unification_error ~loc env err (function ppf -> - fprintf ppf "The operator %s has type" name) + fprintf ppf "The operator %a has type" Style.inline_code name) (function ppf -> fprintf ppf "but it was expected to have type") | Andop_type_clash(name, err) -> report_unification_error ~loc env err (function ppf -> - fprintf ppf "The operator %s has type" name) + fprintf ppf "The operator %a has type" Style.inline_code name) (function ppf -> fprintf ppf "but it was expected to have type") | Bindings_type_clash(err) -> @@ -6419,11 +7105,16 @@ let report_error ~loc env = function (function ppf -> fprintf ppf "but bindings were expected of type") | Unbound_existential (ids, ty) -> + let pp_ident ppf id = pp_print_string ppf (Ident.name id) in + let pp_type ppf (ids,ty)= + fprintf ppf "@[type %a.@ %a@]@]" + (pp_print_list ~pp_sep:pp_print_space pp_ident) ids + Printtyp.type_expr ty + in Location.errorf ~loc - "@[<2>%s:@ @[type %s.@ %a@]@]" + "@[<2>%s:@ %a@]" "This type does not bind all existentials in the constructor" - (String.concat " " (List.map Ident.name ids)) - Printtyp.type_expr ty + (Style.as_inline_code pp_type) (ids, ty) | Missing_type_constraint -> Location.errorf ~loc "@[%s@ %s@]" @@ -6446,13 +7137,13 @@ let report_error ~loc env = function Location.errorf ~loc "This %s should not be a %s,@ \ the expected type is@ %a%t" - ctx sort Printtyp.type_expr ty + ctx sort (Style.as_inline_code Printtyp.type_expr) ty (report_type_expected_explanation_opt explanation) | Expr_not_a_record_type ty -> Location.errorf ~loc "This expression has type %a@ \ which is not a record type." - Printtyp.type_expr ty + (Style.as_inline_code Printtyp.type_expr) ty let report_error ~loc env err = Printtyp.wrap_printing_env ~error:true env @@ -6474,12 +7165,16 @@ let () = Env.add_delayed_check_forward := add_delayed_check; () +(* drop the need to call [Parmatch.typed_case] from the external API *) +let check_partial ?lev a b c cases = + check_partial ?lev a b c (List.map Parmatch.typed_case cases) + (* drop ?recarg argument from the external API *) -let type_expect ?in_function env e ty = type_expect ?in_function env e ty +let type_expect env e ty = type_expect 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 ~lev = let splitting_mode = Refine_or {inside_nonsplit_or = false} in - partial_pred ~allow_modules:(Modules_allowed { scope = lev }) ~splitting_mode ~lev + partial_pred ~splitting_mode ~lev diff --git a/src/ocaml/typing/typecore.mli b/src/ocaml/typing/typecore.mli index 1c6374c368..ae47ac4a89 100644 --- a/src/ocaml/typing/typecore.mli +++ b/src/ocaml/typing/typecore.mli @@ -56,6 +56,7 @@ type pattern_variable = pv_loc: Location.t; pv_as_var: bool; pv_attributes: Typedtree.attributes; + pv_uid : Uid.t; } val mk_expected: @@ -98,10 +99,6 @@ type existential_restriction = | In_class_def (** or in [class c = let ... in ...] *) | In_self_pattern (** or in self pattern *) -type module_patterns_restriction = - | Modules_allowed of { scope : int } - | Modules_rejected - val type_binding: Env.t -> rec_flag -> Parsetree.value_binding list -> @@ -121,10 +118,9 @@ val type_self_pattern: Env.t -> Parsetree.pattern -> Typedtree.pattern * pattern_variable list val check_partial: - ?lev:int -> module_patterns_restriction -> Env.t -> type_expr -> + ?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 @@ -161,6 +157,11 @@ type error = | Expr_type_clash of Errortrace.unification_error * type_forcing_context option * Parsetree.expression_desc option + | Function_arity_type_clash of + { syntactic_arity : int; + type_constraint : type_expr; + trace : Errortrace.unification_error; + } | Apply_non_function of { funct : Typedtree.expression; func_ty : type_expr; @@ -205,7 +206,7 @@ type error = | Modules_not_allowed | Cannot_infer_signature | Not_a_packed_module of type_expr - | Unexpected_existential of existential_restriction * string * string list + | Unexpected_existential of existential_restriction * string | Invalid_interval | Invalid_for_loop_index | No_value_clauses @@ -258,7 +259,8 @@ val type_package: val constant: Parsetree.constant -> (Asttypes.constant, error) result -val check_recursive_bindings : Env.t -> Typedtree.value_binding list -> unit +val annotate_recursive_bindings : + Env.t -> Typedtree.value_binding list -> Typedtree.value_binding list val check_recursive_class_bindings : Env.t -> Ident.t list -> Typedtree.class_expr list -> unit diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index c3820f3aec..42f9814efa 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/src/ocaml/typing/typedecl.ml @@ -91,19 +91,19 @@ let get_unboxed_from_attributes sdecl = (* Enter all declared types in the environment as abstract types *) -let add_type ~long_path ~check id decl env = +let add_type ~long_path ~check ?shape id decl env = Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes (fun () -> match long_path with - | true -> Env.add_type_long_path ~check id decl env - | false -> Env.add_type ~check id decl env) + | true -> Env.add_type_long_path ~check ?shape id decl env + | false -> Env.add_type ~check ?shape id decl env) (* Add a dummy type declaration to the environment, with the given arity. The [type_kind] is [Type_abstract], but there is a generic [type_manifest] for abbreviations, to allow polymorphic expansion, except if - [abstract_abbrevs] is [true]. + [abstract_abbrevs] is given along with a reason for not allowing expansion. This function is only used in [transl_type_decl]. *) -let enter_type ~abstract_abbrevs rec_flag env sdecl (id, uid) = +let enter_type ?abstract_abbrevs rec_flag env sdecl (id, uid) = let needed = match rec_flag with | Asttypes.Nonrecursive -> @@ -119,17 +119,19 @@ let enter_type ~abstract_abbrevs rec_flag env sdecl (id, uid) = in let arity = List.length sdecl.ptype_params in if not needed then env else - let type_manifest = match sdecl.ptype_manifest, abstract_abbrevs with - | None, _ | Some _, true -> None - | Some _, false -> Some(Ctype.newvar ()) + let abstract_source, type_manifest = + match sdecl.ptype_manifest, abstract_abbrevs with + | None, _ -> Definition, None + | Some _, None -> Definition, Some (Btype.newgenvar ()) + | Some _, Some reason -> reason, None in let decl = { type_params = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; type_arity = arity; - type_kind = Type_abstract; + type_kind = Type_abstract abstract_source; type_private = sdecl.ptype_private; - type_manifest; + type_manifest = type_manifest; type_variance = Variance.unknown_signature ~injective:false ~arity; type_separability = Types.Separability.default_signature ~arity; type_is_newtype = false; @@ -143,16 +145,6 @@ let enter_type ~abstract_abbrevs rec_flag env sdecl (id, uid) = in add_type ~long_path:true ~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 err -> - raise (Error(loc, Type_clash (env, err))) - (* Determine if a type's values are represented by floats at run-time. *) let is_float env ty = match Typedecl_unboxed.get_unboxed_type_representation env ty with @@ -241,7 +233,9 @@ let transl_labels env univars closed lbls = let arg = Ast_helper.Typ.force_poly arg in let cty = transl_simple_type env ?univars ~closed arg in {ld_id = Ident.create_local name.txt; - ld_name = name; ld_mutable = mut; + ld_name = name; + ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + ld_mutable = mut; ld_type = cty; ld_loc = loc; ld_attributes = attrs} ) in @@ -251,14 +245,12 @@ let transl_labels env univars closed lbls = (fun ld -> let ty = ld.ld_type.ctyp_type in let ty = match get_desc ty with Tpoly(t,[]) -> t | _ -> ty in - let ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in - Env.register_uid ld_uid ld.ld_loc; {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; + ld_uid = ld.ld_uid; } ) lbls in @@ -329,6 +321,27 @@ let make_constructor env loc type_path type_params svars sargs sret_type = targs, Some tret_type, args, Some ret_type end + +let shape_map_labels = + List.fold_left (fun map { ld_id; ld_uid; _} -> + Shape.Map.add_label map ld_id ld_uid) + Shape.Map.empty + +let shape_map_cstrs = + List.fold_left (fun map { cd_id; cd_uid; cd_args; _ } -> + let cstr_shape_map = + let label_decls = + match cd_args with + | Cstr_tuple _ -> [] + | Cstr_record ldecls -> ldecls + in + shape_map_labels label_decls + in + Shape.Map.add_constr map cd_id + @@ Shape.str ~uid:cd_uid cstr_shape_map) + (Shape.Map.empty) + + let transl_declaration env sdecl (id, uid) = (* Bind type parameters *) Ctype.with_local_level begin fun () -> @@ -387,7 +400,7 @@ let transl_declaration env sdecl (id, uid) = in let (tkind, kind) = match sdecl.ptype_kind with - | Ptype_abstract -> Ttype_abstract, Type_abstract + | Ptype_abstract -> Ttype_abstract, Type_abstract Definition | Ptype_variant scstrs -> if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin match cstrs with @@ -415,6 +428,7 @@ let transl_declaration env sdecl (id, uid) = let tcstr = { cd_id = name; cd_name = scstr.pcd_name; + cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); cd_vars = scstr.pcd_vars; cd_args = targs; cd_res = tret_type; @@ -422,14 +436,12 @@ let transl_declaration env sdecl (id, uid) = cd_attributes = scstr.pcd_attributes } in let cstr = - let cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in - Env.register_uid cd_uid scstr.pcd_loc; { Types.cd_id = name; cd_args = args; cd_res = ret_type; cd_loc = scstr.pcd_loc; cd_attributes = scstr.pcd_attributes; - cd_uid; } + cd_uid = tcstr.cd_uid; } in tcstr, cstr in @@ -493,18 +505,28 @@ let transl_declaration env sdecl (id, uid) = 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; - } + let decl = + { + 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; + } + in + let typ_shape = + let uid = decl.typ_type.type_uid in + match decl.typ_kind with + | Ttype_variant cstrs -> Shape.str ~uid (shape_map_cstrs cstrs) + | Ttype_record labels -> Shape.str ~uid (shape_map_labels labels) + | Ttype_abstract | Ttype_open -> Shape.leaf uid + in + decl, typ_shape end (* Generalize a type declaration *) @@ -543,7 +565,7 @@ let rec check_constraints_rec env loc visited ty = end; List.iter (check_constraints_rec env loc visited) args | Tpoly (ty, tl) -> - let _, ty = Ctype.instance_poly false tl ty in + let _, ty = Ctype.instance_poly ~fixed:false tl ty in check_constraints_rec env loc visited ty | _ -> Btype.iter_type_expr (check_constraints_rec env loc visited) ty @@ -567,7 +589,7 @@ let check_constraints env sdecl (_, decl) = (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_abstract _ -> () | Type_variant (l, _rep) -> let find_pl = function Ptype_variant pl -> pl @@ -667,7 +689,7 @@ let check_abbrev env sdecl (id, decl) = We want to guarantee that all cycles within OCaml types are "guarded". - More precisly, we consider a reachability relation + More precisely, we consider a reachability relation "[t] is reachable [guarded|unguarded] from [u]" defined as follows: @@ -880,7 +902,7 @@ let check_well_founded_manifest ~abs_env env loc path decl = (we don't have an example at hand where it is necessary), but we are doing it anyway out of caution. *) -let check_well_founded_decl ~abs_env env loc path decl to_check = +let check_well_founded_decl ~abs_env env loc path decl to_check = let open Btype in (* We iterate on all subexpressions of the declaration to check "in depth" that no ill-founded type exists. *) @@ -899,7 +921,7 @@ let check_well_founded_decl ~abs_env env loc path decl to_check = {type_iterators with it_type_expr = (fun self ty -> if TypeSet.mem ty !checked then () else begin - check_well_founded ~abs_env env loc path to_check visited ty; + check_well_founded ~abs_env env loc path to_check visited ty; checked := TypeSet.add ty !checked; self.it_do_type_expr self ty end)} in @@ -911,10 +933,10 @@ let check_well_founded_decl ~abs_env env loc path decl to_check = Note: in the case of a constrained type definition [type 'a t = ... constraint 'a = ...], we require - that all instances in [...] be equal to the constrainted type. + that all instances in [...] be equal to the constrained type. *) -let check_regularity ~orig_env env loc path decl to_check = +let check_regularity ~abs_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. *) @@ -928,7 +950,7 @@ let check_regularity ~orig_env env loc path decl to_check = match get_desc ty with | Tconstr(path', args', _) -> if Path.same path path' then begin - if not (Ctype.is_equal orig_env false args args') then + if not (Ctype.is_equal abs_env false args args') then raise (Error(loc, Non_regular { definition=path; @@ -950,9 +972,9 @@ let check_regularity ~orig_env env loc path decl to_check = let (params, body) = Ctype.instance_parameterized_type params0 body0 in begin - try List.iter2 (Ctype.unify orig_env) params args' + try List.iter2 (Ctype.unify abs_env) args' params with Ctype.Unify err -> - raise (Error(loc, Constraint_failed (orig_env, err))); + raise (Error(loc, Constraint_failed (abs_env, err))); end; check_regular path' args (path' :: prev_exp) (Expands_to (ty,body) :: trace) @@ -961,7 +983,8 @@ let check_regularity ~orig_env env loc path decl to_check = end; List.iter (check_subtype cpath args prev_exp trace ty) args' | Tpoly (ty, tl) -> - let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in + let (_, ty) = + Ctype.instance_poly ~keep_names:true ~fixed:false tl ty in check_regular cpath args prev_exp trace ty | _ -> Btype.iter_type_expr @@ -981,10 +1004,10 @@ let check_regularity ~orig_env env loc path decl to_check = check_regular path args [] [] body) decl.type_manifest -let check_abbrev_regularity ~orig_env env id_loc_list to_check tdecl = +let check_abbrev_regularity ~abs_env env id_loc_list to_check tdecl = let decl = tdecl.typ_type in let id = tdecl.typ_id in - check_regularity ~orig_env env (List.assoc id id_loc_list) (Path.Pident id) + check_regularity ~abs_env env (List.assoc id id_loc_list) (Path.Pident id) decl to_check let check_duplicates sdecl_list = @@ -1020,7 +1043,7 @@ let check_duplicates 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_kind = Type_abstract _; type_manifest = Some ty; type_private = Private; } when is_fixed_type sdecl -> let ty' = newty2 ~level:(get_level ty) (get_desc ty) in @@ -1049,10 +1072,11 @@ let check_redefined_unit (td: Parsetree.type_declaration) = | _ -> () -let add_types_to_env decls env = - List.fold_right - (fun (id, decl) env -> add_type ~long_path:false ~check:true id decl env) - decls env +let add_types_to_env decls shapes env = + List.fold_right2 + (fun (id, decl) shape env -> + add_type ~long_path:false ~check:true ~shape id decl env) + decls shapes env (* Translate a set of type declarations, mutually recursive or not *) let transl_type_decl env rec_flag sdecl_list = @@ -1083,12 +1107,14 @@ let transl_type_decl env rec_flag sdecl_list = Uid.mk ~current_unit:(Env.get_unit_name ()) ) sdecl_list in - let tdecls, decls, new_env = + (* Translate declarations, using a temporary environment where abbreviations + expand to a generic type variable. After that, we check the coherence of + the translated declarations in the resulting new environment. *) + let tdecls, decls, shapes, new_env = Ctype.with_local_level_iter ~post:generalize_decl begin fun () -> (* Enter types. *) let temp_env = - List.fold_left2 (enter_type ~abstract_abbrevs:false rec_flag) - env sdecl_list ids_list in + 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 = @@ -1121,23 +1147,17 @@ let transl_type_decl env rec_flag sdecl_list = 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 + let decls, shapes = + List.map (fun (tdecl, shape) -> + (tdecl.typ_id, tdecl.typ_type), shape) tdecls + |> List.split + 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; - ((tdecls, decls, new_env), List.map snd decls) + let new_env = add_types_to_env decls shapes env in + ((tdecls, decls, shapes, new_env), List.map snd decls) end in (* Check for ill-formed abbrevs *) @@ -1145,13 +1165,13 @@ let transl_type_decl env rec_flag sdecl_list = List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc)) ids_list sdecl_list in - (* Error messages cannot use the new environment, as this might result in - non-termination. Instead we use a completely abstract version of the - temporary environment, giving a reason for why abbreviations cannot be - expanded (#12645, #12649) *) + (* [check_abbrev_regularity] and error messages cannot use the new + environment, as this might result in non-termination. Instead we use a + completely abstract version of the temporary environment, giving a reason + for why abbreviations cannot be expanded (#12334, #12368) *) let abs_env = List.fold_left2 - (enter_type ~abstract_abbrevs:true rec_flag) + (enter_type ~abstract_abbrevs:Rec_check_regularity rec_flag) env sdecl_list ids_list in List.iter (fun (id, decl) -> check_well_founded_manifest ~abs_env new_env (List.assoc id id_loc_list) @@ -1164,11 +1184,12 @@ let transl_type_decl env rec_flag sdecl_list = (Path.Pident id) decl to_check) decls; - List.iter - (check_abbrev_regularity ~orig_env:env new_env id_loc_list to_check) tdecls; + List.iter (fun (tdecl, _shape) -> + check_abbrev_regularity ~abs_env new_env id_loc_list to_check tdecl) + tdecls; (* Check that all type variables are closed *) List.iter2 - (fun sdecl tdecl -> + (fun sdecl (tdecl, _shape) -> let decl = tdecl.typ_type in match Ctype.closed_type_decl decl with Some ty -> @@ -1195,18 +1216,18 @@ let transl_type_decl env rec_flag sdecl_list = raise (Error (loc, Separability err)) in (* Compute the final environment with variance and immediacy *) - let final_env = add_types_to_env decls env in + let final_env = add_types_to_env decls shapes 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) -> + (fun (tdecl, _shape) (_id2, decl) -> { tdecl with typ_type = decl } ) tdecls decls in (* Done *) - (final_decls, final_env) + (final_decls, final_env, shapes) (* Translating type extensions *) @@ -1317,12 +1338,22 @@ let transl_extension_constructor ~scope env type_path type_params ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } in + let ext_cstrs = { 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; } + in + let shape = + let map = match ext_cstrs.ext_kind with + | Text_decl (_, Cstr_record lbls, _) -> shape_map_labels lbls + | _ -> Shape.Map.empty + in + Shape.str ~uid:ext_cstrs.ext_type.ext_uid map + in + ext_cstrs, shape let transl_extension_constructor ~scope env type_path type_params typext_params priv sext = @@ -1402,7 +1433,7 @@ let transl_type_extension extend env loc styext = (* Generalize types *) List.iter Ctype.generalize type_params; List.iter - (fun ext -> + (fun (ext, _shape) -> Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; Option.iter Ctype.generalize ext.ext_type.ext_ret_type) constructors; @@ -1410,7 +1441,7 @@ let transl_type_extension extend env loc styext = in (* Check that all type variables are closed *) List.iter - (fun ext -> + (fun (ext, _shape) -> match Ctype.closed_extension_constructor ext.ext_type with Some ty -> raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) @@ -1418,7 +1449,7 @@ let transl_type_extension extend env loc styext = constructors; (* Check variances are correct *) List.iter - (fun ext-> + (fun (ext, _shape) -> (* 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 @@ -1431,11 +1462,13 @@ let transl_type_extension extend env loc styext = (* Add extension constructors to the environment *) let newenv = List.fold_left - (fun env ext -> + (fun env (ext, shape) -> let rebind = is_rebind ext in - Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env) + Env.add_extension ~check:true ~shape ~rebind + ext.ext_id ext.ext_type env) env constructors in + let constructors, shapes = List.split constructors in let tyext = { tyext_path = type_path; tyext_txt = styext.ptyext_path; @@ -1445,21 +1478,21 @@ let transl_type_extension extend env loc styext = tyext_loc = styext.ptyext_loc; tyext_attributes = styext.ptyext_attributes; } in - (tyext, newenv) + (tyext, newenv, shapes) 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 ext = + let ext, shape = let scope = Ctype.create_scope () in Ctype.with_local_level (fun () -> TyVarEnv.reset(); transl_extension_constructor ~scope env Predef.path_exn [] [] Asttypes.Public sext) - ~post: begin fun ext -> + ~post: begin fun (ext, _shape) -> Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; Option.iter Ctype.generalize ext.ext_type.ext_ret_type; end @@ -1472,13 +1505,12 @@ let transl_exception env sext = end; let rebind = is_rebind ext in let newenv = - Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env + Env.add_extension ~check:true ~shape ~rebind ext.ext_id ext.ext_type env in - ext, newenv + ext, newenv, shape let transl_type_exception env t = - Builtin_attributes.check_no_alert t.ptyexn_attributes; - let contructor, newenv = + let contructor, newenv, shape = Builtin_attributes.warning_scope t.ptyexn_attributes (fun () -> transl_exception env t.ptyexn_constructor @@ -1486,7 +1518,7 @@ let transl_type_exception env t = in {tyexn_constructor = contructor; tyexn_loc = t.ptyexn_loc; - tyexn_attributes = t.ptyexn_attributes}, newenv + tyexn_attributes = t.ptyexn_attributes}, newenv, shape type native_repr_attribute = @@ -1495,8 +1527,8 @@ type native_repr_attribute = 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, + Attr_helper.get_no_payload_attribute "unboxed" attrs, + Attr_helper.get_no_payload_attribute "untagged" attrs, global_repr with | None, None, None -> Native_repr_attr_absent @@ -1509,8 +1541,9 @@ let get_native_repr_attribute attrs ~global_repr = let native_repr_of_type env kind ty = match kind, get_desc (Ctype.expand_head_opt env ty) with - | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int -> - Some Untagged_int + | Untagged, Tconstr (_, _, _) when + Typeopt.maybe_pointer_type env ty = Lambda.Immediate -> + Some Untagged_immediate | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float -> Some Unboxed_float | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 -> @@ -1721,19 +1754,20 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env with Ctype.Unify err -> raise(Error(loc, Inconsistent_constraint (env, err))) ) constraints; + let sig_decl_abstract = Btype.type_kind_is_abstract sig_decl in let priv = if sdecl.ptype_private = Private then Private else - if arity_ok && sig_decl.type_kind <> Type_abstract + if arity_ok && not sig_decl_abstract then sig_decl.type_private else sdecl.ptype_private in - if arity_ok && sig_decl.type_kind <> Type_abstract + if arity_ok && not sig_decl_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 + Type_abstract Definition, false in let new_sig_decl = { type_params = params; @@ -1816,7 +1850,7 @@ let abstract_type_decl ~injective arity = Ctype.with_local_level ~post:generalize_decl begin fun () -> { type_params = make_params arity; type_arity = arity; - type_kind = Type_abstract; + type_kind = Type_abstract Definition; type_private = Public; type_manifest = None; type_variance = Variance.unknown_signature ~injective ~arity; @@ -1848,8 +1882,8 @@ let check_recmod_typedecl env loc recmod_ids path decl = (path, decl) is the type declaration to be checked. *) let to_check path = Path.exists_free recmod_ids path in check_well_founded_decl ~abs_env:env env loc path decl to_check; - check_regularity ~orig_env:env env loc path decl to_check; - (* additionally check coherece, as one might build an incoherent signature, + check_regularity ~abs_env:env env loc path decl to_check; + (* additional coherence check, as one might build an incoherent signature, and use it to build an incoherent module, cf. #7851 *) check_coherence env loc path decl @@ -1857,6 +1891,7 @@ let check_recmod_typedecl env loc recmod_ids path decl = (**** Error report ****) open Format +module Style = Misc.Style let explain_unbound_gen ppf tv tl typ kwd pr = try @@ -1866,7 +1901,8 @@ let explain_unbound_gen ppf tv tl typ kwd pr = Printtyp.prepare_for_printing [typ ti; ty0]; fprintf ppf ".@ @[In %s@ %a@;<1 -2>the variable %a is unbound@]" - kwd pr ti Printtyp.prepared_type_expr tv + kwd (Style.as_inline_code pr) ti + (Style.as_inline_code Printtyp.prepared_type_expr) tv (* kwd pr ti Printtyp.prepared_type_expr tv *) with Not_found -> () @@ -1931,12 +1967,12 @@ module Reaching_path = struct let pp_step ppf = function | Expands_to (ty, body) -> Format.fprintf ppf "%a = %a" - Printtyp.prepared_type_expr ty - Printtyp.prepared_type_expr body + (Style.as_inline_code Printtyp.prepared_type_expr) ty + (Style.as_inline_code Printtyp.prepared_type_expr) body | Contains (outer, inner) -> Format.fprintf ppf "%a contains %a" - Printtyp.prepared_type_expr outer - Printtyp.prepared_type_expr inner + (Style.as_inline_code Printtyp.prepared_type_expr) outer + (Style.as_inline_code Printtyp.prepared_type_expr) inner in let comma ppf () = Format.fprintf ppf ",@ " in Format.(pp_print_list ~pp_sep:comma pp_step) ppf reaching_path @@ -1950,37 +1986,37 @@ 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 + fprintf ppf "Two constructors are named %a" Style.inline_code 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 + fprintf ppf "Two labels are named %a" Style.inline_code s | Recursive_abbrev (s, env, reaching_path) -> let reaching_path = Reaching_path.simplify reaching_path in Printtyp.wrap_printing_env ~error:true env @@ fun () -> Printtyp.reset (); Reaching_path.add_to_preparation reaching_path; - fprintf ppf "@[The type abbreviation %s is cyclic%a@]" - s + fprintf ppf "@[The type abbreviation %a is cyclic%a@]" + Style.inline_code s Reaching_path.pp_colon reaching_path | Cycle_in_def (s, env, reaching_path) -> let reaching_path = Reaching_path.simplify reaching_path in Printtyp.wrap_printing_env ~error:true env @@ fun () -> Printtyp.reset (); Reaching_path.add_to_preparation reaching_path; - fprintf ppf "@[The definition of %s contains a cycle%a@]" - s + fprintf ppf "@[The definition of %a contains a cycle%a@]" + Style.inline_code s Reaching_path.pp_colon reaching_path | Definition_mismatch (ty, _env, None) -> fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" "This variant or record definition" "does not match that of type" - Printtyp.type_expr ty + (Style.as_inline_code Printtyp.type_expr) ty | Definition_mismatch (ty, env, Some err) -> fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" "This variant or record definition" "does not match that of type" - Printtyp.type_expr ty + (Style.as_inline_code Printtyp.type_expr) ty (Includecore.report_type_mismatch "the original" "this" "definition" env) err @@ -1992,17 +2028,18 @@ let report_error ppf = function fprintf ppf "@]" | Non_regular { definition; used_as; defined_as; reaching_path } -> let reaching_path = Reaching_path.simplify reaching_path in + let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in Printtyp.prepare_for_printing [used_as; defined_as]; Reaching_path.add_to_preparation reaching_path; fprintf ppf "@[This recursive type is not regular.@ \ - The type constructor %s is defined as@;<1 2>type %a@ \ + The type constructor %a is defined as@;<1 2>type %a@ \ but it is used as@;<1 2>%a%t\ All uses need to match the definition for the recursive type \ to be regular.@]" - (Path.name definition) - !Oprint.out_type (Printtyp.tree_of_typexp Type defined_as) - !Oprint.out_type (Printtyp.tree_of_typexp Type used_as) + Style.inline_code (Path.name definition) + pp_type (Printtyp.tree_of_typexp Type defined_as) + pp_type (Printtyp.tree_of_typexp Type used_as) (fun pp -> let is_expansion = function Expands_to _ -> true | _ -> false in if List.exists is_expansion reaching_path then @@ -2042,7 +2079,7 @@ let report_error ppf = function | 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' -> + | Type_abstract _, Some ty' -> explain_unbound_single ppf ty ty' | _ -> () end; @@ -2059,12 +2096,12 @@ let report_error ppf = function | Not_extensible_type path -> fprintf ppf "@[%s@ %a@ %s@]" "Type definition" - Printtyp.path path + (Style.as_inline_code Printtyp.path) path "is not extensible" | Extension_mismatch (path, env, err) -> - fprintf ppf "@[@[%s@ %s@;<1 2>%s@]%a@]" + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" "This extension" "does not match the definition of type" - (Path.name path) + Style.inline_code (Path.name path) (Includecore.report_type_mismatch "the type" "this extension" "definition" env) err @@ -2072,20 +2109,21 @@ let report_error ppf = function Printtyp.report_unification_error ppf env err (function ppf -> fprintf ppf "The constructor %a@ has type" - Printtyp.longident lid) + (Style.as_inline_code 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) + "@[%s@ %a@ %s@ %a@ %s@ %s@ %a@]" + "The constructor" + (Style.as_inline_code Printtyp.longident) lid + "extends type" Style.inline_code (Path.name p) "whose declaration does not match" - "the declaration of type" (Path.name p') + "the declaration of type" Style.inline_code (Path.name p') | Rebind_private lid -> fprintf ppf "@[%s@ %a@ %s@]" "The constructor" - Printtyp.longident lid + (Style.as_inline_code Printtyp.longident) lid "is private" | Variance (Typedecl_variance.Bad_variance (n, v1, v2)) -> let variance (p,n,i) = @@ -2104,13 +2142,13 @@ let report_error ppf = function Printtyp.add_type_declaration_to_preparation id decl; fprintf ppf "@[%s@;<1 2>%a@;" "In the definition" - (Printtyp.prepared_type_declaration id) + (Style.as_inline_code @@ Printtyp.prepared_type_declaration id) decl | Gadt_constructor c -> Printtyp.add_constructor_to_preparation c; fprintf ppf "@[%s@;<1 2>%a@;" "In the GADT constructor" - Printtyp.prepared_constructor + (Style.as_inline_code Printtyp.prepared_constructor) c | Extension_constructor (id, e) -> Printtyp.add_extension_constructor_to_preparation e; @@ -2123,19 +2161,19 @@ let report_error ppf = function | Variance_not_reflected -> fprintf ppf "@[%s@ %a@ %s@ %s@ It" "the type variable" - Printtyp.prepared_type_expr variable + (Style.as_inline_code Printtyp.prepared_type_expr) variable "has a variance that" "is not reflected by its occurrence in type parameters." | No_variable -> fprintf ppf "@[%s@ %a@ %s@ %s@]@]" "the type variable" - Printtyp.prepared_type_expr variable + (Style.as_inline_code Printtyp.prepared_type_expr) variable "cannot be deduced" "from the type parameters." | Variance_not_deducible -> fprintf ppf "@[%s@ %a@ %s@ %s@ It" "the type variable" - Printtyp.prepared_type_expr variable + (Style.as_inline_code Printtyp.prepared_type_expr) variable "has a variance that" "cannot be deduced from the type parameters." end @@ -2150,7 +2188,8 @@ let report_error ppf = function 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 + fprintf ppf "The definition of type %a@ is unavailable" + (Style.as_inline_code Printtyp.path) p | Variance Typedecl_variance.Varying_anonymous -> fprintf ppf "@[%s@ %s@ %s@]" "In this GADT definition," "the variance of some parameter" @@ -2158,28 +2197,42 @@ let report_error ppf = function | Val_in_structure -> fprintf ppf "Value declarations are only allowed in signatures" | Multiple_native_repr_attributes -> - fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes" + fprintf ppf "Too many %a/%a attributes" + Style.inline_code "[@@unboxed]" + Style.inline_code "[@@untagged]" | 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.@]" + Only %a, %a, %a, and %a can be unboxed.@]" + Style.inline_code "float" + Style.inline_code "int32" + Style.inline_code "int64" + Style.inline_code "nativeint" | Cannot_unbox_or_untag_type Untagged -> - fprintf ppf "@[Don't know how to untag this type.@ \ - Only int can be untagged.@]" + fprintf ppf "@[Don't know how to untag this type. Only %a@ \ + and other immediate types can be untagged.@]" + Style.inline_code "int" | Deep_unbox_or_untag_attribute kind -> fprintf ppf - "@[The attribute '%s' should be attached to@ \ + "@[The attribute %a should be attached to@ \ a direct argument or result of the primitive,@ \ it should not occur deeply into its type.@]" + Style.inline_code (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.") + (match violation with + | Type_immediacy.Violation.Not_always_immediate -> + fprintf ppf + "@[Types@ marked@ with@ the@ immediate@ attribute@ must@ be@ \ + non-pointer@ types@ like@ %a@ or@ %a.@]" + Style.inline_code "int" + Style.inline_code "bool" + | Type_immediacy.Violation.Not_always_immediate_on_64bits -> + fprintf ppf + "@[Types@ marked@ with@ the@ %a@ attribute@ must@ be@ \ + produced@ using@ the@ %a@ functor.@]" + Style.inline_code "immediate64" + Style.inline_code "Stdlib.Sys.Immediate64.Make" + ) | Bad_unboxed_attribute msg -> fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg | Separability (Typedecl_separability.Non_separable_evar evar) -> @@ -2188,26 +2241,30 @@ let report_error ppf = function fprintf ppf "an unnamed existential variable" | Some str -> fprintf ppf "the existential variable %a" - Pprintast.tyvar str in + (Style.as_inline_code 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].@]" + You should annotate it with %a.@]" pp_evar evar + Style.inline_code "[@@ocaml.boxed]" | 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.@]" + "@[GADT case syntax cannot be used in a %a block.@]" + Style.inline_code "nonrec" | Invalid_private_row_declaration ty -> + let pp_private ppf ty = fprintf ppf "private %a" Printtyp.type_expr ty in Format.fprintf ppf "@[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.@]@,\ @[@[@{Hint@}: If you intended to define a private \ type abbreviation,@ \ - write explicitly@]@;<1 2>private %a@]" - Printtyp.type_expr ty Printtyp.type_expr ty + write explicitly@]@;<1 2>%a@]" + (Style.as_inline_code Printtyp.type_expr) ty + (Style.as_inline_code pp_private) ty let () = Location.register_error_of_exn diff --git a/src/ocaml/typing/typedecl.mli b/src/ocaml/typing/typedecl.mli index 013fae4300..5598271b0a 100644 --- a/src/ocaml/typing/typedecl.mli +++ b/src/ocaml/typing/typedecl.mli @@ -20,19 +20,19 @@ open Format val transl_type_decl: Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> - Typedtree.type_declaration list * Env.t + Typedtree.type_declaration list * Env.t * Shape.t list val transl_exception: Env.t -> Parsetree.extension_constructor -> - Typedtree.extension_constructor * Env.t + Typedtree.extension_constructor * Env.t * Shape.t val transl_type_exception: Env.t -> - Parsetree.type_exception -> Typedtree.type_exception * Env.t + Parsetree.type_exception -> Typedtree.type_exception * Env.t * Shape.t val transl_type_extension: bool -> Env.t -> Location.t -> Parsetree.type_extension -> - Typedtree.type_extension * Env.t + Typedtree.type_extension * Env.t * Shape.t list val transl_value_decl: Env.t -> Location.t -> diff --git a/src/ocaml/typing/typedecl_immediacy.ml b/src/ocaml/typing/typedecl_immediacy.ml index f1f0594f9a..71e49a10be 100644 --- a/src/ocaml/typing/typedecl_immediacy.ml +++ b/src/ocaml/typing/typedecl_immediacy.ml @@ -35,8 +35,9 @@ let compute_decl env tdecl = 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_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 = diff --git a/src/ocaml/typing/typedecl_separability.ml b/src/ocaml/typing/typedecl_separability.ml index c6ded4cf6a..c8f2f3b171 100644 --- a/src/ocaml/typing/typedecl_separability.ml +++ b/src/ocaml/typing/typedecl_separability.ml @@ -50,7 +50,7 @@ type type_structure = let structure : type_definition -> type_structure = fun def -> match def.type_kind with | Type_open -> Open - | Type_abstract -> + | Type_abstract _ -> begin match def.type_manifest with | None -> Abstract | Some type_expr -> Synonym type_expr diff --git a/src/ocaml/typing/typedecl_variance.ml b/src/ocaml/typing/typedecl_variance.ml index ca0521aec9..c384e8c467 100644 --- a/src/ocaml/typing/typedecl_variance.ml +++ b/src/ocaml/typing/typedecl_variance.ml @@ -113,7 +113,7 @@ let injective = Variance.(set Inj null) let compute_variance_type env ~check (required, loc) decl tyl = (* Requirements *) - let check_injectivity = decl.type_kind = Type_abstract in + let check_injectivity = Btype.type_kind_is_abstract decl in let required = List.map (fun (c,n,i) -> @@ -228,15 +228,15 @@ let compute_variance_type env ~check (required, loc) decl tyl = List.iter (fun (_,ty) -> check ty) tyl; end; List.map2 - (fun ty (p, n, i) -> + (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 concr = not (Btype.type_kind_is_abstract decl) 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 + and i = concr in let v = union v (make p n i) in if not concr || Btype.is_Tvar ty then v else union v @@ -308,11 +308,10 @@ let compute_variance_decl env ~check decl (required, _ as rloc) = let check = Option.map (fun id -> Type_declaration (id, decl)) check in - if (decl.type_kind = Type_abstract || decl.type_kind = Type_open) - && decl.type_manifest = None then + let abstract = Btype.type_kind_is_abstract decl in + if (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)) + (fun (c, n, i) -> make (not n) (not c) (not abstract || i)) required else begin let mn = @@ -322,7 +321,7 @@ let compute_variance_decl env ~check decl (required, _ as rloc) = in let vari = match decl.type_kind with - Type_abstract | Type_open -> + 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 @@ -354,7 +353,7 @@ let compute_variance_decl env ~check decl (required, _ as rloc) = (mn @ List.map (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) ftl) in - if mn = [] || decl.type_kind <> Type_abstract then + if mn = [] || not abstract then List.map Variance.strengthen vari else vari end diff --git a/src/ocaml/typing/typedtree.ml b/src/ocaml/typing/typedtree.ml index f97d52a8d3..1f1954ee82 100644 --- a/src/ocaml/typing/typedtree.ml +++ b/src/ocaml/typing/typedtree.ml @@ -18,6 +18,8 @@ open Asttypes open Types +module Uid = Shape.Uid + (* Value expressions for the core language *) type partial = Partial | Total @@ -53,9 +55,9 @@ and pat_extra = and 'k pattern_desc = (* value patterns *) | Tpat_any : value pattern_desc - | Tpat_var : Ident.t * string loc -> value pattern_desc + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc | Tpat_alias : - value general_pattern * Ident.t * string loc -> value pattern_desc + value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc | Tpat_constant : constant -> value pattern_desc | Tpat_tuple : value general_pattern list -> value pattern_desc | Tpat_construct : @@ -101,8 +103,7 @@ 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_function of function_param list * function_body | Texp_apply of expression * (arg_label * expression option) list | Texp_match of expression * computation case list * partial | Texp_try of expression * value case list @@ -162,6 +163,31 @@ and 'k case = c_rhs: expression; } +and function_param = + { + fp_arg_label: arg_label; + fp_param: Ident.t; + fp_partial: partial; + fp_kind: function_param_kind; + fp_newtypes: string loc list; + fp_loc : Location.t; + } + +and function_param_kind = + | Tparam_pat of pattern + | Tparam_optional_default of pattern * expression + +and function_body = + | Tfunction_body of expression + | Tfunction_cases of + { cases: value case list; + partial: partial; + param: Ident.t; + loc: Location.t; + exp_extra: exp_extra option; + attributes: attributes; + } + and record_label_definition = | Kept of Types.type_expr * mutable_flag | Overridden of Longident.t loc * expression @@ -292,6 +318,7 @@ and module_binding = { mb_id: Ident.t option; mb_name: string option loc; + mb_uid: Uid.t; mb_presence: module_presence; mb_expr: module_expr; mb_attributes: attribute list; @@ -302,6 +329,7 @@ and value_binding = { vb_pat: pattern; vb_expr: expression; + vb_rec_kind: Value_rec_types.recursive_binding_kind; vb_attributes: attributes; vb_loc: Location.t; } @@ -371,6 +399,7 @@ and module_declaration = { md_id: Ident.t option; md_name: string option loc; + md_uid: Uid.t; md_presence: module_presence; md_type: module_type; md_attributes: attribute list; @@ -381,6 +410,7 @@ and module_substitution = { ms_id: Ident.t; ms_name: string loc; + ms_uid: Uid.t; ms_manifest: Path.t; ms_txt: Longident.t loc; ms_attributes: attributes; @@ -391,6 +421,7 @@ and module_type_declaration = { mtd_id: Ident.t; mtd_name: string loc; + mtd_uid: Uid.t; mtd_type: module_type option; mtd_attributes: attribute list; mtd_loc: Location.t; @@ -448,10 +479,11 @@ and core_type_desc = | 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_alias of core_type * string loc | Ttyp_variant of row_field list * closed_flag * label list option | Ttyp_poly of string list * core_type | Ttyp_package of package_type + | Ttyp_open of Path.t * Longident.t loc * core_type and package_type = { pack_path : Path.t; @@ -513,6 +545,7 @@ and label_declaration = { ld_id: Ident.t; ld_name: string loc; + ld_uid: Uid.t; ld_mutable: mutable_flag; ld_type: core_type; ld_loc: Location.t; @@ -523,6 +556,7 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + cd_uid: Uid.t; cd_vars: string loc list; cd_args: constructor_arguments; cd_res: core_type option; @@ -630,6 +664,19 @@ type implementation = { shape: Shape.t; } +type item_declaration = + | Value of value_description + | Value_binding of value_binding + | Type of type_declaration + | Constructor of constructor_declaration + | Extension_constructor of extension_constructor + | Label of label_declaration + | Module of module_declaration + | Module_substitution of module_substitution + | Module_binding of module_binding + | Module_type of module_type_declaration + | Class of class_declaration + | Class_type of class_type_declaration (* Auxiliary functions over the a.s.t. *) @@ -675,7 +722,7 @@ type pattern_action = let shallow_iter_pattern_desc : type k . pattern_action -> k pattern_desc -> unit = fun f -> function - | Tpat_alias(p, _, _) -> f.f p + | 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 @@ -695,8 +742,8 @@ type pattern_transformation = 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_alias (p1, id, s, uid) -> + Tpat_alias (f.f p1, id, s, uid) | Tpat_tuple pats -> Tpat_tuple (List.map f.f pats) | Tpat_record (lpats, closed) -> @@ -757,11 +804,11 @@ 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) -> + | Tpat_var (id, s, uid) -> + f (id,s,pat.pat_type, uid) + | Tpat_alias(p, id, s, uid) -> iter_bound_idents f p; - f (id,s,pat.pat_type) + f (id,s,pat.pat_type, uid) | Tpat_or(p1, _, _) -> (* Invariant : both arguments bind the same variables *) iter_bound_idents f p1 @@ -777,7 +824,7 @@ let rev_pat_bound_idents_full pat = !idents_full let rev_only_idents idents_full = - List.rev_map (fun (id,_,_) -> id) idents_full + List.rev_map (fun (id,_,_,_) -> id) idents_full let pat_bound_idents_full pat = List.rev (rev_pat_bound_idents_full pat) @@ -801,14 +848,14 @@ 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 *) + | Tpat_var (id, s, uid) -> (* note the ``Not_found'' case *) {p with pat_desc = - try Tpat_var (alpha_var env id, s) with + try Tpat_var (alpha_var env id, s, uid) with | Not_found -> Tpat_any} - | Tpat_alias (p1, id, s) -> + | Tpat_alias (p1, id, s, uid) -> 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)} + {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s, uid)} with | Not_found -> new_p end diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli index 4f4ca2b5ae..986a47001e 100644 --- a/src/ocaml/typing/typedtree.mli +++ b/src/ocaml/typing/typedtree.mli @@ -22,6 +22,7 @@ *) open Asttypes +module Uid = Shape.Uid (* Value expressions for the core language *) @@ -77,10 +78,10 @@ and 'k pattern_desc = (* value patterns *) | Tpat_any : value pattern_desc (** _ *) - | Tpat_var : Ident.t * string loc -> value pattern_desc + | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc (** x *) | Tpat_alias : - value general_pattern * Ident.t * string loc -> value pattern_desc + value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc (** P as a *) | Tpat_constant : constant -> value pattern_desc (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) @@ -189,18 +190,17 @@ and expression_desc = (** 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_function of function_param list * function_body + (** fun P0 P1 -> function p1 -> e1 | p2 -> e2 (body = Tfunction_cases _) + fun P0 P1 -> E (body = Tfunction_body _) + + This construct has the same arity as the originating + {{!Parsetree.expression_desc.Pexp_function}[Pexp_function]}. + Arity determines when side-effects for effectful parameters are run + (e.g. optional argument defaults, matching against lazy patterns). + Parameters' effects are run left-to-right when an n-ary function is + saturated with n arguments. + *) | Texp_apply of expression * (arg_label * expression option) list (** E0 ~l1:E1 ... ~ln:En @@ -301,6 +301,54 @@ and 'k case = c_rhs: expression; } +and function_param = + { + fp_arg_label: arg_label; + fp_param: Ident.t; + (** [fp_param] is the identifier that is to be used to name the + parameter of the function. + *) + fp_partial: partial; + (** + [fp_partial] = + [Partial] if the pattern match is partial + [Total] otherwise. + *) + fp_kind: function_param_kind; + fp_newtypes: string loc list; + (** [fp_newtypes] are the new type declarations that come *after* that + parameter. The newtypes that come before the first parameter are + placed as exp_extras on the Texp_function node. This is just used in + {!Untypeast}. *) + fp_loc: Location.t; + (** [fp_loc] is the location of the entire value parameter, not including + the [fp_newtypes]. + *) + } + +and function_param_kind = + | Tparam_pat of pattern + (** [Tparam_pat p] is a non-optional argument with pattern [p]. *) + | Tparam_optional_default of pattern * expression + (** [Tparam_optional_default (p, e)] is an optional argument [p] with default + value [e], i.e. [?x:(p = e)]. If the parameter is of type [a option], the + pattern and expression are of type [a]. *) + +and function_body = + | Tfunction_body of expression + | Tfunction_cases of + { cases: value case list; + partial: partial; + param: Ident.t; + loc: Location.t; + exp_extra: exp_extra option; + attributes: attributes; + (** [attributes] is just used in untypeast. *) + } +(** The function body binds a final argument in [Tfunction_cases], + and this argument is pattern-matched against the cases. +*) + and record_label_definition = | Kept of Types.type_expr * mutable_flag | Overridden of Longident.t loc * expression @@ -438,8 +486,9 @@ and structure_item_desc = and module_binding = { - mb_id: Ident.t option; + mb_id: Ident.t option; (** [None] for [module _ = struct ... end] *) mb_name: string option loc; + mb_uid: Uid.t; mb_presence: Types.module_presence; mb_expr: module_expr; mb_attributes: attributes; @@ -450,6 +499,7 @@ and value_binding = { vb_pat: pattern; vb_expr: expression; + vb_rec_kind: Value_rec_types.recursive_binding_kind; vb_attributes: attributes; vb_loc: Location.t; } @@ -460,7 +510,19 @@ and module_coercion = (Ident.t * int * module_coercion) list | Tcoerce_functor of module_coercion * module_coercion | Tcoerce_primitive of primitive_coercion + (** External declaration coerced to a regular value. + {[ + module M : sig val ext : a -> b end = + struct external ext : a -> b = "my_c_function" end + ]} + Only occurs inside a [Tcoerce_structure] coercion. *) | Tcoerce_alias of Env.t * Path.t * module_coercion + (** Module alias coerced to a regular module. + {[ + module M : sig module Sub : T end = + struct module Sub = Some_alias end + ]} + Only occurs inside a [Tcoerce_structure] coercion. *) and module_type = { mty_desc: module_type_desc; @@ -518,6 +580,7 @@ and module_declaration = { md_id: Ident.t option; md_name: string option loc; + md_uid: Uid.t; md_presence: Types.module_presence; md_type: module_type; md_attributes: attributes; @@ -528,6 +591,7 @@ and module_substitution = { ms_id: Ident.t; ms_name: string loc; + ms_uid: Uid.t; ms_manifest: Path.t; ms_txt: Longident.t loc; ms_attributes: attributes; @@ -538,6 +602,7 @@ and module_type_declaration = { mtd_id: Ident.t; mtd_name: string loc; + mtd_uid: Uid.t; mtd_type: module_type option; mtd_attributes: attributes; mtd_loc: Location.t; @@ -596,10 +661,11 @@ and core_type_desc = | 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_alias of core_type * string loc | Ttyp_variant of row_field list * closed_flag * label list option | Ttyp_poly of string list * core_type | Ttyp_package of package_type + | Ttyp_open of Path.t * Longident.t loc * core_type and package_type = { pack_path : Path.t; @@ -662,6 +728,7 @@ and label_declaration = { ld_id: Ident.t; ld_name: string loc; + ld_uid: Uid.t; ld_mutable: mutable_flag; ld_type: core_type; ld_loc: Location.t; @@ -672,6 +739,7 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + cd_uid: Uid.t; cd_vars: string loc list; cd_args: constructor_arguments; cd_res: core_type option; @@ -788,6 +856,23 @@ type implementation = { structure. *) +type item_declaration = + | Value of value_description + | Value_binding of value_binding + | Type of type_declaration + | Constructor of constructor_declaration + | Extension_constructor of extension_constructor + | Label of label_declaration + | Module of module_declaration + | Module_substitution of module_substitution + | Module_binding of module_binding + | Module_type of module_type_declaration + | Class of class_declaration + | Class_type of class_type_declaration +(** [item_declaration] groups together items that correspond to the syntactic + category of "declarations" which include types, values, modules, etc. + declarations in signatures and their definitions in implementations. *) + (* Auxiliary functions over the a.s.t. *) (** [as_computation_pattern p] is a computation pattern with description @@ -818,7 +903,8 @@ 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 + value_binding list -> + (Ident.t * string loc * Types.type_expr * Types.Uid.t) list (** Alpha conversion of patterns *) val alpha_pat: @@ -829,7 +915,8 @@ 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 + 'k general_pattern -> + (Ident.t * string loc * Types.type_expr * Types.Uid.t) list (** Splits an or pattern into its value (left) and exception (right) parts. *) val split_pattern: diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml index 201b78c0fe..9f9a1b0f63 100644 --- a/src/ocaml/typing/typemod.ml +++ b/src/ocaml/typing/typemod.ml @@ -21,6 +21,8 @@ open Parsetree open Types open Format +module Style = Misc.Style + let () = Includemod_errorprinter.register () module Sig_component_kind = Shape.Sig_component_kind @@ -143,7 +145,7 @@ let initial_env ~loc ~initially_opened_module env in let units = - List.map Env.persistent_structures_of_dir (Load_path.get ()) + List.map Env.persistent_structures_of_dir (Load_path.get_visible ()) in let env, units = match initially_opened_module with @@ -506,7 +508,7 @@ let merge_constraint initial_env loc sg lid constr = type_params = List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; type_arity = arity; - type_kind = Type_abstract; + type_kind = Type_abstract Definition; type_private = Private; type_manifest = None; type_variance = @@ -1046,7 +1048,7 @@ end = struct let open Sig_component_kind in match component with | Value -> names.values - | Type -> names.types + | Type | Label | Constructor -> names.types | Module -> names.modules | Module_type -> names.modtypes | Extension_constructor -> names.typexts @@ -1243,8 +1245,7 @@ end let has_remove_aliases_attribute attr = let remove_aliases = - Attr_helper.get_no_payload_attribute - ["remove_aliases"; "ocaml.remove_aliases"] attr + Attr_helper.get_no_payload_attribute "remove_aliases" attr in match remove_aliases with | None -> false @@ -1369,7 +1370,7 @@ and transl_with ~loc env remove_aliases (rev_tcstrs,sg) constr = -and transl_signature ?(keep_warnings = false) env sg = +and transl_signature ?(keep_warnings = false) ?(toplevel = false) env sg = let names = Signature_names.create () in let rec transl_sig env sg = match sg with @@ -1383,7 +1384,6 @@ and transl_signature ?(keep_warnings = false) env sg = Typedecl.transl_value_decl env item.psig_loc sdesc in Signature_names.check_value names tdesc.val_loc tdesc.val_id; - Env.register_uid tdesc.val_val.val_uid tdesc.val_loc; res with | (tdesc, newenv) -> @@ -1397,17 +1397,15 @@ and transl_signature ?(keep_warnings = false) env sg = end | Psig_type (rec_flag, sdecls) -> begin match - let (decls, _) as res = + 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; - if not (Btype.is_row_name (Ident.name td.typ_id)) then - Env.register_uid td.typ_type.type_uid td.typ_loc ) decls; res with - | (decls, newenv) -> + | (decls, newenv, _) -> let newenv = Env.update_short_paths newenv in let (trem, rem, final_env) = transl_sig newenv srem in let sg = @@ -1432,7 +1430,7 @@ and transl_signature ?(keep_warnings = false) env sg = once we have nice error messages there. *) raise (Error (td.ptype_loc, env, Invalid_type_subst_rhs)) ) sdecls; - let (decls, _) as res = + let (decls, _, _) as res = Typedecl.transl_type_decl env Nonrecursive sdecls in List.iter (fun td -> @@ -1448,12 +1446,11 @@ and transl_signature ?(keep_warnings = false) env sg = in Some (`Substituted_away subst) in - Signature_names.check_type ?info names td.typ_loc td.typ_id; - Env.register_uid td.typ_type.type_uid td.typ_loc + Signature_names.check_type ?info names td.typ_loc td.typ_id ) decls; res with - | (decls, newenv) -> + | (decls, newenv, _) -> let (trem, rem, final_env) = transl_sig newenv srem in let sg = rem in @@ -1466,17 +1463,16 @@ and transl_signature ?(keep_warnings = false) env sg = end | Psig_typext styext -> begin match - let (tyext, _) as res = + 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; - Env.register_uid ext.ext_type.ext_uid ext.ext_loc + Signature_names.check_typext names ext.ext_loc ext.ext_id ) constructors; res, constructors with - | (tyext, newenv), constructors -> + | (tyext, newenv, _shapes), constructors -> let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_typext tyext) env loc :: trem, map_ext (fun es ext -> @@ -1489,16 +1485,13 @@ and transl_signature ?(keep_warnings = false) env sg = end | Psig_exception sext -> begin match - let (ext, _) as res = Typedecl.transl_type_exception env sext in + 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; - Env.register_uid - constructor.ext_type.ext_uid - constructor.ext_loc; res, constructor with - | (ext, newenv), constructor -> + | (ext, newenv, _shape), constructor -> let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_exception ext) env loc :: trem, Sig_typext(constructor.ext_id, @@ -1522,30 +1515,29 @@ and transl_signature ?(keep_warnings = false) env sg = | 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 match pmd.pmd_name.txt with - | None -> None, pres, env, None, tmty + | None -> None, pres, env, None, tmty, md | 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; - Env.register_uid md.md_uid md.md_loc; let sig_item = Sig_module(id, pres, md, Trec_not, Exported) in - Some id, pres, newenv, Some sig_item, tmty + Some id, pres, newenv, Some sig_item, tmty, md with - | (id, pres, newenv, sig_item, tmty) -> + | (id, pres, newenv, sig_item, tmty, md) -> 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_uid=md.md_uid; 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), @@ -1584,10 +1576,9 @@ and transl_signature ?(keep_warnings = false) env sg = `Substituted_away (Subst.add_module id path Subst.identity) in Signature_names.check_module ~info names pms.pms_name.loc id; - Env.register_uid md.md_uid md.md_loc; (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_uid=md.md_uid; ms_manifest=path; + ms_txt=pms.pms_manifest; ms_loc=pms.pms_loc; ms_attributes=pms.pms_attributes}) with | newenv, sig_item -> @@ -1608,9 +1599,8 @@ and transl_signature ?(keep_warnings = false) env sg = | Some id -> Some (id, md, uid) ) tdecls in - List.iter (fun (id, md, uid) -> + List.iter (fun (id, md, _uid) -> Signature_names.check_module names md.md_loc id; - Env.register_uid uid md.md_loc ) decls; (tdecls, decls, newenv) with @@ -1635,7 +1625,6 @@ and transl_signature ?(keep_warnings = false) env sg = begin match transl_modtype_decl env pmtd with | newenv, mtd, decl -> Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; - Env.register_uid decl.mtd_uid mtd.mtd_loc; let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modtype mtd) env loc :: trem, Sig_modtype (mtd.mtd_id, decl, Exported) :: rem, @@ -1646,7 +1635,7 @@ and transl_signature ?(keep_warnings = false) env sg = end | Psig_modtypesubst pmtd -> begin match transl_modtype_decl env pmtd with - | newenv, mtd, decl -> + | newenv, mtd, _decl -> let info = let mty = match mtd.mtd_type with | Some tmty -> tmty.mty_type @@ -1660,7 +1649,6 @@ and transl_signature ?(keep_warnings = false) env sg = | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst) in Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id; - Env.register_uid decl.mtd_uid mtd.mtd_loc; let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modtypesubst mtd) env loc :: trem, rem, @@ -1720,7 +1708,6 @@ and transl_signature ?(keep_warnings = false) env sg = 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; - Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc; ) classes; res with @@ -1755,9 +1742,6 @@ and transl_signature ?(keep_warnings = false) env sg = 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; - Env.register_uid - decl.clsty_ty_decl.clty_uid - decl.clsty_ty_decl.clty_loc; ) classes; res with @@ -1787,6 +1771,8 @@ and transl_signature ?(keep_warnings = false) env sg = end | Psig_attribute x -> Builtin_attributes.warning_attribute x; + if toplevel || not (Warnings.is_active (Misplaced_attribute "")) + then Builtin_attributes.mark_alert_used 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) -> @@ -1825,6 +1811,7 @@ and transl_modtype_decl_aux env { mtd_id=id; mtd_name=pmtd_name; + mtd_uid=decl.mtd_uid; mtd_type=tmty; mtd_attributes=pmtd_attributes; mtd_loc=pmtd_loc; @@ -1907,11 +1894,11 @@ and transl_recmodule_modtypes env sdecls = List.map2 (fun pmd (id_shape, id_loc, md, mty) -> let tmd = {md_id=Option.map fst id_shape; md_name=id_loc; md_type=mty; - md_presence=Mp_present; + md_uid=md.Types.md_uid; md_presence=Mp_present; md_loc=pmd.pmd_loc; md_attributes=pmd.pmd_attributes} in - tmd, md.md_uid, Option.map snd id_shape + tmd, md.Types.md_uid, Option.map snd id_shape ) sdecls dcl2 in (dcl2, env2) @@ -2120,6 +2107,7 @@ let check_recmodule_inclusion env bindings = { mb_id = id; mb_name = name; + mb_uid = uid; mb_presence = Mp_present; mb_expr = modl'; mb_attributes = attrs; @@ -2290,6 +2278,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod = let shape = Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path in + let shape = if alias && aliasable then Shape.alias shape else shape in let md = if alias && aliasable then (Env.add_required_global (Path.head path); md) @@ -2475,10 +2464,11 @@ and type_application loc strengthen funct_body env smod = let strengthen = strengthen && List.for_all has_path args in type_module strengthen funct_body None env sfunct in - List.fold_left (type_one_application ~ctx:(loc, funct, args) funct_body env) + List.fold_left + (type_one_application ~ctx:(loc, sfunct, funct, args) funct_body env) (funct, funct_shape) args -and type_one_application ~ctx:(apply_loc,md_f,args) +and type_one_application ~ctx:(apply_loc,sfunct,md_f,args) funct_body env (funct, funct_shape) app_view = match Env.scrape_alias env funct.mod_type with | Mty_functor (Unit, mty_res) -> @@ -2509,8 +2499,11 @@ and type_one_application ~ctx:(apply_loc,md_f,args) let apply_error () = let args = List.map simplify_app_summary args in let mty_f = md_f.mod_type in - let lid_app = None in - Includemod.Apply_error {loc=apply_loc;env;lid_app;mty_f;args} + let app_name = match sfunct.pmod_desc with + | Pmod_ident l -> Includemod.Named_leftmost_functor l.txt + | _ -> Includemod.Anonymous_functor + in + Includemod.Apply_error {loc=apply_loc;env;app_name;mty_f;args} in begin match app_view with | { arg = None; loc = app_loc; attributes = app_attributes; _ } -> @@ -2586,11 +2579,14 @@ and type_one_application ~ctx:(apply_loc,md_f,args) end | Mty_alias path -> raise(Error(app_view.f_loc, env, Cannot_scrape_alias path)) - | _ -> + | Mty_ident _ | Mty_signature _ | Mty_for_hole -> 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}) + let app_name = match sfunct.pmod_desc with + | Pmod_ident l -> Includemod.Named_leftmost_functor l.txt + | _ -> Includemod.Anonymous_functor + in + raise(Includemod.Apply_error {loc=apply_loc;env;app_name;mty_f;args}) and type_open_decl ?used_slot ?toplevel funct_body names env sod = Builtin_attributes.warning_scope sod.popen_attributes @@ -2670,17 +2666,17 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho | 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 + let defs = match rec_flag with + | Recursive -> Typecore.annotate_recursive_bindings env defs + | Nonrecursive -> 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. *) let items, shape_map = List.fold_left - (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ)-> + (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ, _uid)-> Signature_names.check_value names loc id; let vd = Env.find_value (Pident id) newenv in - Env.register_uid vd.val_uid vd.val_loc; Sig_value(id, vd, Exported) :: acc, Shape.Map.add_value shape_map id vd.val_uid ) @@ -2694,13 +2690,14 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho | 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; - Env.register_uid desc.val_val.val_uid desc.val_val.val_loc; Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val, Exported)], Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid, newenv | Pstr_type (rec_flag, sdecls) -> - let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in + let (decls, newenv, shapes) = + 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) @@ -2709,32 +2706,26 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported)) decls [] in - let shape_map = List.fold_left - (fun shape_map -> function - | Sig_type (id, vd, _, _) -> - if not (Btype.is_row_name (Ident.name id)) then begin - Env.register_uid vd.type_uid vd.type_loc; - Shape.Map.add_type shape_map id vd.type_uid - end else shape_map - | _ -> assert false - ) + let shape_map = List.fold_left2 + (fun map { typ_id; _} shape -> + Shape.Map.add_type map typ_id shape) shape_map - items + decls + shapes in Tstr_type (rec_flag, decls), items, shape_map, enrich_type_decls anchor decls env newenv | Pstr_typext styext -> - let (tyext, newenv) = + let (tyext, newenv, shapes) = Typedecl.transl_type_extension true env loc styext in let constructors = tyext.tyext_constructors in - let shape_map = List.fold_left (fun shape_map ext -> + let shape_map = List.fold_left2 (fun shape_map ext shape -> Signature_names.check_typext names ext.ext_loc ext.ext_id; - Env.register_uid ext.ext_type.ext_uid ext.ext_loc; - Shape.Map.add_extcons shape_map ext.ext_id ext.ext_type.ext_uid - ) shape_map constructors + Shape.Map.add_extcons shape_map ext.ext_id shape + ) shape_map constructors shapes in (Tstr_typext tyext, map_ext @@ -2743,13 +2734,10 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho shape_map, newenv) | Pstr_exception sext -> - let (ext, newenv) = Typedecl.transl_type_exception env sext in + let (ext, newenv, shape) = Typedecl.transl_type_exception env sext in let constructor = ext.tyexn_constructor in Signature_names.check_typext names constructor.ext_loc constructor.ext_id; - Env.register_uid - constructor.ext_type.ext_uid - constructor.ext_loc; Tstr_exception ext, [Sig_typext(constructor.ext_id, constructor.ext_type, @@ -2757,7 +2745,7 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho Exported)], Shape.Map.add_extcons shape_map constructor.ext_id - constructor.ext_type.ext_uid, + shape, newenv | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; pmb_loc; @@ -2785,7 +2773,6 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho } in let md_shape = Shape.set_uid_if_none md_shape md_uid in - Env.register_uid md_uid pmb_loc; (*prerr_endline (Ident.unique_toplevel_name id);*) Mtype.lower_nongen outer_scope md.md_type; let id, newenv, sg = @@ -2809,8 +2796,9 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho | Some id -> Shape.Map.add_module shape_map id md_shape | None -> shape_map in - Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; - mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; }, + Tstr_module {mb_id=id; mb_name=name; mb_uid = md.md_uid; + mb_expr=modl; mb_presence=pres; mb_attributes=attrs; + mb_loc=pmb_loc; }, sg, shape_map, newenv @@ -2885,8 +2873,7 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho ) bindings2 in let shape_map = - List.fold_left (fun map (id, mb, uid, shape) -> - Env.register_uid uid mb.mb_loc; + List.fold_left (fun map (id, _mb, _uid, shape) -> Shape.Map.add_module map id shape ) shape_map mbs in @@ -2906,7 +2893,6 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho let newenv, mtd, decl = 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; - Env.register_uid decl.mtd_uid decl.mtd_loc; let id = mtd.mtd_id in let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv @@ -2925,11 +2911,11 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho 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; - Env.register_uid cls.cls_decl.cty_uid loc; - let map f id acc = f acc id cls.cls_decl.cty_uid in - map Shape.Map.add_class cls.cls_id acc - |> map Shape.Map.add_class_type cls.cls_ty_id - |> map Shape.Map.add_type cls.cls_obj_id + let uid = cls.cls_decl.cty_uid in + let map f id v acc = f acc id v in + map Shape.Map.add_class cls.cls_id uid acc + |> map Shape.Map.add_class_type cls.cls_ty_id uid + |> map Shape.Map.add_type cls.cls_obj_id (Shape.leaf uid) ) shape_map classes in Tstr_class @@ -2955,10 +2941,10 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho 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; - Env.register_uid decl.clsty_ty_decl.clty_uid loc; - let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in - map Shape.Map.add_class_type decl.clsty_ty_id acc - |> map Shape.Map.add_type decl.clsty_obj_id + let uid = decl.clsty_ty_decl.clty_uid in + let map f id v acc = f acc id v in + map Shape.Map.add_class_type decl.clsty_ty_id uid acc + |> map Shape.Map.add_type decl.clsty_obj_id (Shape.leaf uid) ) shape_map classes in Tstr_class_type @@ -3003,6 +2989,8 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pstr_attribute x -> Builtin_attributes.warning_attribute x; + if toplevel || not (Warnings.is_active (Misplaced_attribute "")) then + Builtin_attributes.mark_alert_used x; Tstr_attribute x, [], shape_map, env in let rec type_struct env shape_map sstr = @@ -3050,7 +3038,7 @@ let merlin_type_structure env str = 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 +let transl_signature ~toplevel env sg = transl_signature ~toplevel env sg (* Normalize types in a signature *) @@ -3207,6 +3195,7 @@ let () = Typetexp.transl_modtype_longident := transl_modtype_longident; Typetexp.transl_modtype := transl_modtype; Typecore.type_open := type_open_ ?toplevel:None; + Typetexp.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; @@ -3214,8 +3203,22 @@ let () = (* Typecheck an implementation file *) +(* +let gen_annot target annots = + let annot = Unit_info.annot target in + Cmt2annot.gen_annot (Some (Unit_info.Artifact.filename annot)) + ~sourcefile:(Unit_info.Artifact.source_file annot) + ~use_summaries:false + annots +*) -let type_implementation sourcefile outputprefix modulename initial_env ast = +let type_implementation target initial_env ast = + let sourcefile = Unit_info.source_file target in + let save_cmt target annots initial_env cmi shape = + Cmt_format.save_cmt (Unit_info.cmt target) + annots initial_env cmi shape; + (* gen_annot target annots; *) + in Cmt_format.clear (); Misc.try_finally (fun () -> Typecore.reset_delayed_checks (); @@ -3225,56 +3228,57 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = let (str, sg, names, shape, finalenv) = type_structure initial_env ast in let shape = - Shape.set_uid_if_none shape - (Uid.of_compilation_unit_id (Ident.create_persistent modulename)) + let id = Ident.create_persistent @@ Unit_info.modname target in + Shape.set_uid_if_none shape (Uid.of_compilation_unit_id id) in let simple_sg = Signature_names.simplify finalenv names sg in if !Clflags.print_types then begin Typecore.force_delayed_checks (); - let shape = Shape.local_reduce shape in + let shape = Shape_reduce.local_reduce Env.empty shape in Printtyp.wrap_printing_env ~error:false initial_env (fun () -> fprintf std_formatter "%a@." - (Printtyp.printed_signature sourcefile) simple_sg + (Printtyp.printed_signature @@ Unit_info.source_file target) + simple_sg ); + (* gen_annot target (Cmt_format.Implementation str); *) { structure = str; coercion = Tcoerce_none; shape; signature = simple_sg } (* result is ignored by Compile.implementation *) end else begin - let sourceintf = - Filename.remove_extension sourcefile ^ !Config.interface_suffix in - if !Clflags.cmi_file <> None || Sys.file_exists sourceintf then begin - let intf_file = + let source_intf = Unit_info.mli_from_source target in + if !Clflags.cmi_file <> None + || Sys.file_exists source_intf then begin + let compiled_intf_file = match !Clflags.cmi_file with + | Some cmi_file -> Unit_info.Artifact.from_filename cmi_file | None -> - (try - Load_path.find_uncap (modulename ^ ".cmi") - with Not_found -> - raise(Error(Location.in_file sourcefile, Env.empty, - Interface_not_compiled sourceintf))) - | Some cmi_file -> cmi_file + try Unit_info.find_normalized_cmi target with Not_found -> + raise(Error(Location.in_file sourcefile, Env.empty, + Interface_not_compiled source_intf)) in - let dclsig = Env.read_signature modulename intf_file in + let dclsig = Env.read_signature compiled_intf_file in let coercion, shape = Includemod.compunit initial_env ~mark:Mark_positive - sourcefile sg intf_file dclsig shape + sourcefile sg source_intf + dclsig shape 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 shape = Shape.local_reduce shape in + let shape = Shape_reduce.local_reduce Env.empty shape in let annots = Cmt_format.Implementation str in - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - annots (Some sourcefile) initial_env None (Some shape); + save_cmt target annots initial_env None (Some shape); { structure = str; coercion; shape; signature = dclsig } end else begin - Location.prerr_warning (Location.in_file sourcefile) + Location.prerr_warning + (Location.in_file (Unit_info.source_file target)) Warnings.Missing_mli; let coercion, shape = Includemod.compunit initial_env ~mark:Mark_positive @@ -3287,16 +3291,14 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = the values 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. *) - let shape = Shape.local_reduce shape in + let shape = Shape_reduce.local_reduce Env.empty shape in 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") + Env.save_signature ~alerts simple_sg (Unit_info.cmi target) in let annots = Cmt_format.Implementation str in - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - annots (Some sourcefile) initial_env (Some cmi) (Some shape); + save_cmt target annots initial_env (Some cmi) (Some shape) end; { structure = str; coercion; @@ -3311,16 +3313,18 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = 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 None; + save_cmt target annots initial_env None 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) None +let save_signature target tsg initial_env cmi = + Cmt_format.save_cmt (Unit_info.cmti target) + (Cmt_format.Interface tsg) initial_env (Some cmi) None let type_interface env ast = - transl_signature env ast + transl_signature ~toplevel:true env ast + +let transl_signature env ast = + transl_signature ~toplevel:false env ast (* "Packaging" of several compilation units into one unit having them as sub-modules. *) @@ -3355,25 +3359,24 @@ let package_signatures units = Sig_module(newid, Mp_present, md, Trec_not, Exported)) units_with_ids -let package_units initial_env objfiles cmifile modulename = +let package_units initial_env objfiles target_cmi = (* 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" && + let artifact = Unit_info.Artifact.from_filename f in + let sg = Env.read_signature (Unit_info.companion_cmi artifact) in + if Unit_info.is_cmi artifact && not(Mtype.no_code_needed_sig Env.initial sg) then raise(Error(Location.none, Env.empty, Implementation_is_required f)); - (modname, Env.read_signature modname (pref ^ ".cmi"))) + Unit_info.Artifact.modname artifact, sg) objfiles in (* Compute signature of packaged unit *) Ident.reinit(); let sg = package_signatures units in (* Compute the shape of the package *) - let prefix = Filename.remove_extension cmifile in + let prefix = Unit_info.Artifact.prefix target_cmi in let pack_uid = Uid.of_compilation_unit_id (Ident.create_persistent prefix) in let shape = List.fold_left (fun map (name, _sg) -> @@ -3383,19 +3386,20 @@ let package_units initial_env objfiles cmifile modulename = |> Shape.str ~uid:pack_uid in (* See if explicit interface is provided *) - 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)) + let mli = Unit_info.mli_from_artifact target_cmi in + if Sys.file_exists mli then begin + if not (Sys.file_exists @@ Unit_info.Artifact.filename target_cmi) then + begin + raise(Error(Location.in_file mli, Env.empty, + Interface_not_compiled mli)) end; - let dclsig = Env.read_signature modulename cmifile in + let dclsig = Env.read_signature target_cmi in let cc, _shape = Includemod.compunit initial_env ~mark:Mark_both - "(obtained by packing)" sg mlifile dclsig shape + "(obtained by packing)" sg mli dclsig shape in - Cmt_format.save_cmt (prefix ^ ".cmt") modulename - (Cmt_format.Packed (sg, objfiles)) None initial_env None (Some shape); + Cmt_format.save_cmt (Unit_info.companion_cmt target_cmi) + (Cmt_format.Packed (sg, objfiles)) initial_env None (Some shape); cc end else begin (* Determine imports *) @@ -3408,11 +3412,10 @@ let package_units initial_env objfiles cmifile modulename = 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 + sg target_cmi imports in - Cmt_format.save_cmt (prefix ^ ".cmt") modulename - (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env + Cmt_format.save_cmt (Unit_info.companion_cmt target_cmi) + (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) initial_env (Some cmi) (Some shape); end; Tcoerce_none @@ -3427,7 +3430,8 @@ 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 + "@[This module is not a functor; it has type@ %a@]" + (Style.as_inline_code modtype) mty | Not_included errs -> let main = Includemod_errorprinter.err_msgs errs in Location.errorf ~loc "@[Signature mismatch:@ %t@]" main @@ -3435,53 +3439,72 @@ let report_error ~loc _env = function 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 + Please bind the argument to a module identifier.@]" + (Style.as_inline_code 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 + "@[This module is not a structure; it has type@ %a" + (Style.as_inline_code modtype) mty | With_no_component lid -> Location.errorf ~loc - "@[The signature constrained by `with' has no component named %a@]" - longident lid + "@[The signature constrained by %a has no component named %a@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid | With_mismatch(lid, explanation) -> let main = Includemod_errorprinter.err_msgs explanation in Location.errorf ~loc "@[\ - @[In this `with' constraint, the new definition of %a@ \ + @[In this %a constraint, the new definition of %a@ \ does not match its original definition@ \ in the constrained signature:@]@ \ - %t@]" - longident lid main + %t@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid main | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> let main = Includemod_errorprinter.err_msgs explanation in Location.errorf ~loc "@[\ - @[This `with' constraint on %a makes the applicative functor @ \ - type %s ill-typed in the constrained signature:@]@ \ - %t@]" - longident lid (Path.name path) main + @[This %a constraint on %a makes the applicative functor @ \ + type %a ill-typed in the constrained signature:@]@ \ + %t@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid + Style.inline_code (Path.name path) + main | With_changes_module_alias(lid, id, path) -> Location.errorf ~loc "@[\ - @[This `with' constraint on %a changes %s, which is aliased @ \ - in the constrained signature (as %s)@].@]" - longident lid (Path.name path) (Ident.name id) + @[This %a constraint on %a changes %a, which is aliased @ \ + in the constrained signature (as %a)@].@]" + Style.inline_code "with" + (Style.as_inline_code longident) lid + Style.inline_code (Path.name path) + Style.inline_code (Ident.name id) | With_cannot_remove_constrained_type -> Location.errorf ~loc "@[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) -> + let[@manual.ref "ss:module-type-substitution"] manual_ref = + [ 12; 7; 3 ] + in + let pp_constraint ppf () = + Format.fprintf ppf "%s := %a" + (Path.name p) Printtyp.modtype mty + in Location.errorf ~loc - "This `with' constraint@ %s := %a@ makes a packed module ill-formed." - (Path.name p) Printtyp.modtype mty + "This %a constraint@ %a@ makes a packed module ill-formed.@ %a" + Style.inline_code "with" + (Style.as_inline_code pp_constraint) () + Misc.print_see_manual manual_ref | Repeated_name(kind, name) -> Location.errorf ~loc - "@[Multiple definition of the %s name %s.@ \ + "@[Multiple definition of the %s name %a.@ \ Names must be unique in a given structure or signature.@]" - (Sig_component_kind.to_string kind) name + (Sig_component_kind.to_string kind) Style.inline_code name | Non_generalizable { vars; expression } -> let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in prepare_for_printing vars; @@ -3489,9 +3512,9 @@ let report_error ~loc _env = function Location.errorf ~loc "@[The type of this expression,@ %a,@ \ contains the non-generalizable type variable(s): %a.@ %a@]" - prepared_type_scheme expression + (Style.as_inline_code prepared_type_scheme) expression (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") - prepared_type_scheme) vars + (Style.as_inline_code prepared_type_scheme)) vars Misc.print_see_manual manual_ref | Non_generalizable_module { vars; mty; item } -> let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in @@ -3501,10 +3524,10 @@ let report_error ~loc _env = function [ Location.msg ~loc:item.val_loc "The type of this value,@ %a,@ \ contains the non-generalizable type variable(s) %a." - prepared_type_scheme + (Style.as_inline_code prepared_type_scheme) item.val_type (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ") - prepared_type_scheme) vars + @@ Style.as_inline_code prepared_type_scheme) vars ] in Location.errorf ~loc ~sub @@ -3528,28 +3551,31 @@ let report_error ~loc _env = function | Not_a_packed_module ty -> Location.errorf ~loc "This expression is not a packed module. It has type@ %a" - type_expr ty + (Style.as_inline_code type_expr) ty | Incomplete_packed_module ty -> Location.errorf ~loc "The type of this packed module contains variables:@ %a" - type_expr ty + (Style.as_inline_code 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 + Its type contains local dependencies:@ %a" + (Style.as_inline_code longident) lid + (Style.as_inline_code 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 ()" + "This is a generative functor. It can only be applied to %a" + Style.inline_code "()" | Cannot_scrape_alias p -> Location.errorf ~loc "This is an alias for module %a, which is missing" - path p + (Style.as_inline_code path) p | Cannot_scrape_package_type p -> Location.errorf ~loc "The type of this packed module refers to %a, which is missing" - path p + (Style.as_inline_code path) p | Badly_formed_signature (context, err) -> Location.errorf ~loc "@[In %s:@ %a@]" context Typedecl.report_error err | Cannot_hide_id Illegal_shadowing @@ -3564,39 +3590,50 @@ let report_error ~loc _env = function let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in let shadowed_msg = Location.msg ~loc:shadowed_item_loc - "@[%s %s came from this include.@]" + "@[%s %a came from this include.@]" (String.capitalize_ascii shadowed_item_kind) - shadowed + Style.inline_code shadowed in let user_msg = Location.msg ~loc:user_loc - "@[The %s %s has no valid type@ if %s is shadowed.@]" - (Sig_component_kind.to_string user_kind) (Ident.name user_id) - shadowed + "@[The %s %a has no valid type@ if %a is shadowed.@]" + (Sig_component_kind.to_string user_kind) + Style.inline_code (Ident.name user_id) + Style.inline_code shadowed in Location.errorf ~loc ~sub:[shadowed_msg; user_msg] - "Illegal shadowing of included %s %s@ by %s." - shadowed_item_kind shadowed shadower + "Illegal shadowing of included %s %a@ by %a." + shadowed_item_kind + Style.inline_code shadowed + Style.inline_code shadower | 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 let opened_id = Ident.name opened_item_id in let user_msg = Location.msg ~loc:user_loc - "@[The %s %s has no valid type@ if %s is hidden.@]" - (Sig_component_kind.to_string user_kind) (Ident.name user_id) - opened_id + "@[The %s %a has no valid type@ if %a is hidden.@]" + (Sig_component_kind.to_string user_kind) + Style.inline_code (Ident.name user_id) + Style.inline_code opened_id in Location.errorf ~loc ~sub:[user_msg] - "The %s %s introduced by this open appears in the signature." - opened_item_kind opened_id + "The %s %a introduced by this open appears in the signature." + opened_item_kind + Style.inline_code opened_id | Invalid_type_subst_rhs -> - Location.errorf ~loc "Only type synonyms are allowed on the right of :=" + Location.errorf ~loc "Only type synonyms are allowed on the right of %a" + Style.inline_code ":=" | Unpackable_local_modtype_subst p -> + let[@manual.ref "ss:module-type-substitution"] manual_ref = + [ 12; 7; 3 ] + in 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) + "The module type@ %a@ is not a valid type for a packed module:@ \ + it is defined as a local substitution (temporary name)@ \ + for an anonymous module type.@ %a" + Style.inline_code (Path.name p) + Misc.print_see_manual manual_ref let report_error env ~loc err = Printtyp.wrap_printing_env ~error:true env diff --git a/src/ocaml/typing/typemod.mli b/src/ocaml/typing/typemod.mli index 209f2a55fb..0b85d88513 100644 --- a/src/ocaml/typing/typemod.mli +++ b/src/ocaml/typing/typemod.mli @@ -39,8 +39,8 @@ val type_toplevel_phrase: Typedtree.structure * Types.signature * (* Signature_names.t * *) Shape.t * Env.t val type_implementation: - string -> string -> string -> Env.t -> - Parsetree.structure -> Typedtree.implementation + Unit_info.t -> Env.t -> Parsetree.structure -> + Typedtree.implementation val type_interface: Env.t -> Parsetree.signature -> Typedtree.signature val transl_signature: @@ -60,11 +60,11 @@ val modtype_of_package: 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 + Unit_info.t -> Typedtree.signature -> Env.t -> + Cmi_format.cmi_infos -> unit val package_units: - Env.t -> string list -> string -> string -> Typedtree.module_coercion + Env.t -> string list -> Unit_info.Artifact.t -> Typedtree.module_coercion (* Should be in Envaux, but it breaks the build of the debugger *) val initial_env: @@ -76,6 +76,8 @@ module Sig_component_kind : sig type t = | Value | Type + | Constructor + | Label | Module | Module_type | Extension_constructor diff --git a/src/ocaml/typing/typeopt.ml b/src/ocaml/typing/typeopt.ml index 7462e16a09..f983c499c7 100644 --- a/src/ocaml/typing/typeopt.ml +++ b/src/ocaml/typing/typeopt.ml @@ -18,6 +18,7 @@ open Types open Asttypes open Typedtree +open Lambda let scrape_ty env ty = match get_desc ty with @@ -43,7 +44,7 @@ let scrape_ty env ty = let scrape env ty = get_desc (scrape_ty env ty) -let _scrape_poly env ty = +let scrape_poly env ty = let ty = scrape_ty env ty in match get_desc ty with | Tpoly (ty, _) -> get_desc ty @@ -67,6 +68,13 @@ let is_immediate = function targeting 32 or 64 bits. *) !Clflags.native_code && Sys.word_size = 64 +let maybe_pointer_type env ty = + let ty = scrape_ty env ty in + if is_immediate (Ctype.immediacy env ty) then Immediate + else Pointer + +let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type + type classification = | Int | Float @@ -92,7 +100,7 @@ let classify env ty = else begin try match (Env.find_type p env).type_kind with - | Type_abstract -> + | Type_abstract _ -> Any | Type_record _ | Type_variant _ | Type_open -> Addr @@ -107,7 +115,6 @@ let classify env ty = | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ -> assert false -(* let array_type_kind env ty = match scrape_poly env ty with | Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array -> @@ -125,6 +132,7 @@ let array_type_kind env ty = 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 = @@ -136,7 +144,8 @@ let bigarray_decode_type env ty tbl dfl = dfl let kind_table = - ["float32_elt", Pbigarray_float32; + ["float16_elt", Pbigarray_float16; + "float32_elt", Pbigarray_float32; "float64_elt", Pbigarray_float64; "int8_signed_elt", Pbigarray_sint8; "int8_unsigned_elt", Pbigarray_uint8; @@ -178,11 +187,6 @@ let value_kind env ty = | _ -> Pgenval end - -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. diff --git a/src/ocaml/typing/typeopt.mli b/src/ocaml/typing/typeopt.mli index 6ca678d2fe..1e7c1ecb79 100644 --- a/src/ocaml/typing/typeopt.mli +++ b/src/ocaml/typing/typeopt.mli @@ -19,18 +19,18 @@ 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 -> diff --git a/src/ocaml/typing/types.ml b/src/ocaml/typing/types.ml index 4bba370fbd..bdc2a9e549 100644 --- a/src/ocaml/typing/types.ml +++ b/src/ocaml/typing/types.ml @@ -249,11 +249,16 @@ type type_declaration = and type_decl_kind = (label_declaration, constructor_declaration) type_kind and ('lbl, 'cstr) type_kind = - Type_abstract + Type_abstract of type_origin | Type_record of 'lbl list * record_representation | Type_variant of 'cstr list * variant_representation | Type_open +and type_origin = + Definition + | Rec_check_regularity + | Existential of string + and record_representation = Record_regular (* All fields are boxed / tagged *) | Record_float (* All fields are floats *) diff --git a/src/ocaml/typing/types.mli b/src/ocaml/typing/types.mli index ec8a13774c..d7a782da3e 100644 --- a/src/ocaml/typing/types.mli +++ b/src/ocaml/typing/types.mli @@ -486,11 +486,16 @@ type type_declaration = and type_decl_kind = (label_declaration, constructor_declaration) type_kind and ('lbl, 'cstr) type_kind = - Type_abstract + Type_abstract of type_origin | Type_record of 'lbl list * record_representation | Type_variant of 'cstr list * variant_representation | Type_open +and type_origin = + Definition + | Rec_check_regularity (* See Typedecl.transl_type_decl *) + | Existential of string + and record_representation = Record_regular (* All fields are boxed / tagged *) | Record_float (* All fields are floats *) diff --git a/src/ocaml/typing/typetexp.ml b/src/ocaml/typing/typetexp.ml index a104ba8d57..837ea4e901 100644 --- a/src/ocaml/typing/typetexp.ml +++ b/src/ocaml/typing/typetexp.ml @@ -33,7 +33,6 @@ type error = | 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_error | Alias_type_mismatch of Errortrace.unification_error | Present_has_conjunction of string @@ -187,7 +186,9 @@ end = struct TyVarMap.find name !type_variables let get_in_scope_names () = - let add_name name _ l = if name = "_" then l else ("'" ^ name) :: l in + let add_name name _ l = + if name = "_" then l else Pprintast.tyvar_of_name name :: l + in TyVarMap.fold add_name !type_variables [] (*****) @@ -318,7 +319,7 @@ end = struct with Not_found -> if extensibility = Fixed && Btype.is_Tvar ty then raise(Error(loc, env, - Unbound_type_variable ("'"^name, + Unbound_type_variable (Pprintast.tyvar_of_name name, get_in_scope_names ()))); let v2 = new_global_var () in r := (loc, v, v2) :: !r; @@ -409,6 +410,14 @@ let transl_type_param env styp = Builtin_attributes.warning_scope styp.ptyp_attributes (fun () -> transl_type_param env styp) +(* Forward declaration (set in 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 rec transl_type env ~policy ?(aliased=false) ~row_context styp = Msupport.with_saved_types ~warning_attribute:styp.ptyp_attributes ?save_part:None @@ -531,22 +540,23 @@ and transl_type_aux env ~row_context ~aliased ~policy styp = | Ptyp_alias(st, alias) -> let cty = try - let t = TyVarEnv.lookup_local ~row_context alias in + let t = TyVarEnv.lookup_local ~row_context alias.txt in let ty = transl_type env ~policy ~aliased:true ~row_context st in begin try unify_var env t ty.ctyp_type with Unify err -> let err = Errortrace.swap_unification_error err in - raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) + raise(Error(alias.loc, env, Alias_type_mismatch err)) end; ty with Not_found -> let t, ty = with_local_level_if_principal begin fun () -> let t = newvar () in - TyVarEnv.remember_used alias t styp.ptyp_loc; + (* Use the whole location, which is used by [Type_mismatch]. *) + TyVarEnv.remember_used alias.txt t styp.ptyp_loc; let ty = transl_type env ~policy ~row_context st in begin try unify_var env t ty.ctyp_type with Unify err -> let err = Errortrace.swap_unification_error err in - raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) + raise(Error(alias.loc, env, Alias_type_mismatch err)) end; (t, ty) end @@ -555,8 +565,8 @@ and transl_type_aux env ~row_context ~aliased ~policy styp = let t = instance t in let px = Btype.proxy t in begin match get_desc px with - | Tvar None -> set_type_desc px (Tvar (Some alias)) - | Tunivar None -> set_type_desc px (Tunivar (Some alias)) + | Tvar None -> set_type_desc px (Tvar (Some alias.txt)) + | Tunivar None -> set_type_desc px (Tunivar (Some alias.txt)) | _ -> () end; { ty with ctyp_type = t } @@ -699,6 +709,12 @@ and transl_type_aux env ~row_context ~aliased ~policy styp = pack_fields = ptys; pack_txt = p; }) ty + | Ptyp_open (mod_ident, t) -> + let path, new_env = + !type_open Asttypes.Fresh env loc mod_ident + in + let cty = transl_type new_env ~policy ~row_context t in + ctyp (Ttyp_open (path, mod_ident, cty)) cty.ctyp_type | Ptyp_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) @@ -869,30 +885,31 @@ let transl_type_scheme env styp = open Format open Printtyp +module Style = Misc.Style +let pp_tag ppf t = Format.fprintf ppf "`%s" t + let report_error env ppf = function | Unbound_type_variable (name, in_scope_names) -> - fprintf ppf "The type variable %s is unbound in this type declaration.@ %a" - name + fprintf ppf "The type variable %a is unbound in this type declaration.@ %a" + Style.inline_code name did_you_mean (fun () -> Misc.spellcheck in_scope_names name ) | No_type_wildcards -> - fprintf ppf "A type wildcard \"_\" is not allowed in this type declaration." + fprintf ppf "A type wildcard %a is not allowed in this type declaration." + Style.inline_code "_" | Undefined_type_constructor p -> fprintf ppf "The type constructor@ %a@ is not yet completely defined" - path p + (Style.as_inline_code 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 + (Style.as_inline_code longident) lid expected provided | Bound_type_variable name -> - fprintf ppf "Already bound type parameter %a" Pprintast.tyvar name + fprintf ppf "Already bound type parameter %a" + (Style.as_inline_code 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 -> @@ -906,27 +923,33 @@ let report_error env ppf = function (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 + fprintf ppf "The present constructor %a has a conjunctive type" + Style.inline_code l | Present_has_no_type l -> fprintf ppf - "@[@[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,@ \ + "@[@[The constructor %a is missing from the upper bound@ \ + (between %a@ and %a)@ of this polymorphic variant@ \ + but is present in@ its lower bound (after %a).@]@,\ + @[@{Hint@}: Either add %a in the upper bound,@ \ or remove it@ from the lower bound.@]@]" - l l + (Style.as_inline_code pp_tag) l + Style.inline_code "<" + Style.inline_code ">" + Style.inline_code ">" + (Style.as_inline_code pp_tag) l | Constructor_mismatch (ty, ty') -> + let pp_type ppf ty = Style.as_inline_code !Oprint.out_type ppf ty in wrap_printing_env ~error:true env (fun () -> Printtyp.prepare_for_printing [ty; ty']; fprintf ppf "@[%s %a@ %s@ %a@]" "This variant type contains a constructor" - !Oprint.out_type (tree_of_typexp Type ty) + pp_type (tree_of_typexp Type ty) "which should be" - !Oprint.out_type (tree_of_typexp Type ty')) + pp_type (tree_of_typexp Type ty')) | Not_a_variant ty -> fprintf ppf "@[The type %a@ does not expand to a polymorphic variant type@]" - Printtyp.type_expr ty; + (Style.as_inline_code Printtyp.type_expr) ty; begin match get_desc ty with | Tvar (Some s) -> (* PR#7012: help the user that wrote 'Foo instead of `Foo *) @@ -935,36 +958,43 @@ let report_error env ppf = function end | Variant_tags (lab1, lab2) -> fprintf ppf - "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]" - lab1 lab2 "Change one of them." + "@[Variant tags %a@ and %a have the same hash value.@ %s@]" + (Style.as_inline_code pp_tag) lab1 + (Style.as_inline_code pp_tag) lab2 + "Change one of them." | Invalid_variable_name name -> - fprintf ppf "The type variable name %s is not allowed in programs" name + fprintf ppf "The type variable name %a is not allowed in programs" + Style.inline_code name | Cannot_quantify (name, v) -> fprintf ppf "@[The universal type variable %a cannot be generalized:@ " - Pprintast.tyvar name; + (Style.as_inline_code 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 "it is bound to@ %a" + (Style.as_inline_code Printtyp.type_expr) v; fprintf ppf ".@]"; | Multiple_constraints_on_type s -> - fprintf ppf "Multiple constraints for type %a" longident s + fprintf ppf "Multiple constraints for type %a" + (Style.as_inline_code longident) s | Method_mismatch (l, ty, ty') -> wrap_printing_env ~error:true env (fun () -> - fprintf ppf "@[Method '%s' has type %a,@ which should be %a@]" - l Printtyp.type_expr ty Printtyp.type_expr ty') + fprintf ppf "@[Method %a has type %a,@ which should be %a@]" + Style.inline_code l + (Style.as_inline_code Printtyp.type_expr) ty + (Style.as_inline_code Printtyp.type_expr) ty') | Opened_object nm -> fprintf ppf "Illegal open object type%a" (fun ppf -> function - Some p -> fprintf ppf "@ %a" path p + Some p -> fprintf ppf "@ %a" (Style.as_inline_code path) p | None -> fprintf ppf "") nm | Not_an_object ty -> fprintf ppf "@[The type %a@ is not an object type@]" - Printtyp.type_expr ty + (Style.as_inline_code Printtyp.type_expr) ty let () = Location.register_error_of_exn diff --git a/src/ocaml/typing/typetexp.mli b/src/ocaml/typing/typetexp.mli index ca058a5cf0..56ed31c5fb 100644 --- a/src/ocaml/typing/typetexp.mli +++ b/src/ocaml/typing/typetexp.mli @@ -45,6 +45,12 @@ module TyVarEnv : sig end +(* Forward declaration, to be filled in by Typemod.type_open *) +val type_open: + (?used_slot:bool ref -> Asttypes.override_flag -> Env.t -> Location.t -> + Longident.t Asttypes.loc -> Path.t * Env.t) + ref + val valid_tyvar_name : string -> bool val transl_simple_type: @@ -73,7 +79,6 @@ type error = | 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_error | Alias_type_mismatch of Errortrace.unification_error | Present_has_conjunction of string diff --git a/src/ocaml/typing/untypeast.ml b/src/ocaml/typing/untypeast.ml index 5bf911989a..fc7714b419 100644 --- a/src/ocaml/typing/untypeast.ml +++ b/src/ocaml/typing/untypeast.ml @@ -13,7 +13,9 @@ (* *) (**************************************************************************) -open Longident +[@@@ocaml.warning "-60"] module Str = Ast_helper.Str (* For ocamldep *) +[@@@ocaml.warning "+60"] + open Asttypes open Parsetree open Ast_helper @@ -78,11 +80,6 @@ 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. @@ -105,13 +102,6 @@ let rec lident_of_path = function 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 name i = s ^ Int.to_string i in - let available i = not (Env.bound_value (name i) env) in - let first_i = Misc.find_first_mono available in - name first_i - (** Extract the [n] patterns from the case of a letop *) let rec extract_letop_patterns n pat = if n = 0 then pat, [] @@ -298,7 +288,8 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> 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); _ } -> + | { 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) @@ -308,7 +299,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> | _ -> match pat.pat_desc with Tpat_any -> Ppat_any - | Tpat_var (id, name) -> + | Tpat_var (id, name, _) -> begin match (Ident.name id).[0] with 'A'..'Z' -> @@ -321,11 +312,11 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> 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) + | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name, _) when pat_loc = pat.pat_loc -> Ppat_var name - | Tpat_alias (pat, _id, name) -> + | Tpat_alias (pat, _id, name, _) -> Ppat_alias (sub.pat sub pat, name) | Tpat_constant cst -> Ppat_constant (constant cst) | Tpat_tuple list -> @@ -408,22 +399,52 @@ let expression sub 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_function (params, body) -> + let body, constraint_ = + match body with + | Tfunction_body body -> + (* Unlike function cases, the [exp_extra] is placed on the body + itself. *) + Pfunction_body (sub.expr sub body), None + | Tfunction_cases { cases; loc; exp_extra; attributes; _ } -> + let cases = List.map (sub.case sub) cases in + let constraint_ = + match exp_extra with + | Some (Texp_coerce (ty1, ty2)) -> + Some + (Pcoerce (Option.map (sub.typ sub) ty1, sub.typ sub ty2)) + | Some (Texp_constraint ty) -> + Some (Pconstraint (sub.typ sub ty)) + | Some (Texp_poly _ | Texp_newtype _ | Texp_newtype' _) + | None -> None + in + Pfunction_cases (cases, loc, attributes), constraint_ + in + let params = + List.concat_map + (fun fp -> + let pat, default_arg = + match fp.fp_kind with + | Tparam_pat pat -> pat, None + | Tparam_optional_default (pat, expr) -> pat, Some expr + in + let pat = sub.pat sub pat in + let default_arg = Option.map (sub.expr sub) default_arg in + let newtypes = + List.map + (fun x -> + { pparam_desc = Pparam_newtype x; + pparam_loc = x.loc; + }) + fp.fp_newtypes + in + let pparam_desc = + Pparam_val (fp.fp_arg_label, default_arg, pat) + in + { pparam_desc; pparam_loc = fp.fp_loc } :: newtypes) + params + in + Pexp_function (params, constraint_, body) | Texp_apply (exp, list) -> Pexp_apply (sub.expr sub exp, List.fold_right (fun (label, expo) list -> @@ -787,12 +808,13 @@ let core_type sub 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) + | Ttyp_open (_path, mod_ident, t) -> Ptyp_open (mod_ident, sub.typ sub t) in Typ.mk ~loc ~attrs desc let class_structure sub cs = let rec remove_self = function - | { pat_desc = Tpat_alias (p, id, _s) } + | { pat_desc = Tpat_alias (p, id, _s, _) } when string_is_prefix "selfpat-" (Ident.name id) -> remove_self p | p -> p @@ -822,10 +844,25 @@ let object_field sub {of_loc; of_desc; of_attributes;} = Of.mk ~loc ~attrs desc and is_self_pat = function - | { pat_desc = Tpat_alias(_pat, id, _) } -> + | { pat_desc = Tpat_alias(_pat, id, _, _) } -> string_is_prefix "self-" (Ident.name id) | _ -> false +(* [Typeclass] adds a [self] parameter to initializers and methods that isn't + present in the source program. +*) +let remove_fun_self exp = + match exp with + | { exp_desc = + Texp_function + ({fp_arg_label = Nolabel; fp_kind = Tparam_pat pat} :: params, body) + } + when is_self_pat pat -> + (match params, body with + | [], Tfunction_body body -> body + | _, _ -> { exp with exp_desc = Texp_function (params, body) }) + | e -> e + let class_field sub cf = let loc = sub.location sub cf.cf_loc in let attrs = sub.attributes sub cf.cf_attributes in @@ -842,21 +879,9 @@ let class_field sub cf = | 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 diff --git a/src/ocaml/typing/rec_check.ml b/src/ocaml/typing/value_rec_check.ml similarity index 84% rename from src/ocaml/typing/rec_check.ml rename to src/ocaml/typing/value_rec_check.ml index 6dae3a0a95..91a73ca48b 100644 --- a/src/ocaml/typing/rec_check.ml +++ b/src/ocaml/typing/value_rec_check.ml @@ -16,7 +16,11 @@ (* *) (**************************************************************************) -(** Static checking of recursive declarations +(** Static checking of recursive declarations, as described in + + A practical mode system for recursive definitions + Alban Reynaud, Gabriel Scherer and Jeremy Yallop + POPL 2021 Some recursive definitions are meaningful {[ @@ -102,11 +106,9 @@ open Asttypes open Typedtree open Types -exception Illegal_expr - (** {1 Static or dynamic size} *) -type sd = Static | Dynamic +type sd = Value_rec_types.recursive_binding_kind let is_ref : Types.value_description -> bool = function | { Types.val_kind = @@ -142,7 +144,13 @@ let classify_expression : Typedtree.expression -> sd = 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 + let rec classify_expression env e : sd = + let is_constant expr = + match classify_expression env expr with + | Constant -> true + | _ -> false + in + 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 @@ -159,14 +167,29 @@ let classify_expression : Typedtree.expression -> sd = | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) -> classify_expression env e - | Texp_construct _ -> - Static + | Texp_construct (_, _, exprs) -> + if List.for_all is_constant exprs then Constant else Static + + | Texp_variant (_, Some expr) -> + if is_constant expr then Constant else Static + | Texp_variant (_, None) -> + Constant | Texp_record { representation = Record_unboxed _; fields = [| _, Overridden (_,e) |] } -> classify_expression env e - | Texp_record _ -> - Static + | Texp_record { fields; _ } -> + (* We ignore the [extended_expression] field. + As long as all fields are Overridden rather than Kept, the value + can be constant. *) + let is_constant_field (_label, def) = + match def with + | Kept _ -> false + | Overridden (_loc, expr) -> is_constant expr + in + if Array.for_all is_constant_field fields then Constant else Static + | Texp_tuple exprs -> + if List.for_all is_constant exprs then Constant else Static | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _) when is_ref vd -> @@ -175,27 +198,50 @@ let classify_expression : Typedtree.expression -> sd = when List.exists is_abstracted_arg args -> Static | Texp_apply _ -> - Dynamic + Not_recursive + + | Texp_array _ -> + Static + | Texp_pack mexp -> + classify_module_expression env mexp + | Texp_function _ -> + Static + | Texp_lazy e -> + (* The code below was copied (in part) from translcore.ml *) + begin match Typeopt.classify_lazy_argument e with + | `Constant_or_function -> + (* A constant expr (of type <> float if [Config.flat_float_array] is + true) gets compiled as itself. *) + classify_expression env e + | `Float_that_cannot_be_shortcut + | `Identifier `Forward_value -> + (* Forward blocks *) + Static + | `Identifier `Other -> + classify_expression env e + | `Other -> + (* other cases compile to a lazy block holding a function *) + Static + end + | Texp_extension_constructor _ -> + Static + + | Texp_constant _ -> + Constant | 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_setinstvar _ -> + (* Unit-returning expressions *) + Constant + + | Texp_unreachable -> + Constant + | Texp_new _ + | Texp_instvar _ + | Texp_object _ | Texp_match _ | Texp_ifthenelse _ | Texp_send _ @@ -204,7 +250,9 @@ let classify_expression : Typedtree.expression -> sd = | Texp_try _ | Texp_override _ | Texp_letop _ -> - Dynamic + Not_recursive + + | Texp_hole -> Static and classify_value_bindings rec_flag env bindings = (* We use a non-recursive classification, classifying each binding with respect to the old environment @@ -221,7 +269,7 @@ let classify_expression : Typedtree.expression -> sd = let old_env = env in let add_value_binding env vb = match vb.vb_pat.pat_desc with - | Tpat_var (id, _loc) -> + | Tpat_var (id, _loc, _uid) -> let size = classify_expression old_env vb.vb_expr in Ident.add id size env | _ -> @@ -229,7 +277,7 @@ let classify_expression : Typedtree.expression -> sd = env in List.fold_left add_value_binding env bindings - and classify_path env = function + and classify_path env : _ -> Value_rec_types.recursive_binding_kind = function | Path.Pident x -> begin try Ident.find_same x env @@ -244,17 +292,42 @@ let classify_expression : Typedtree.expression -> sd = 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. + under-approximate with Not_recursive. This could be fixed by a more complete implementation. *) - Dynamic + Not_recursive end | Path.Pdot _ | Path.Papply _ | Path.Pextra_ty _ -> (* local modules could have such paths to local definitions; classify_expression could be extend to compute module shapes more precisely *) - Dynamic + Not_recursive + and classify_module_expression env mexp : sd = + match mexp.mod_desc with + | Tmod_ident _ | Tmod_hole -> + Not_recursive + | Tmod_structure _ -> + Static + | Tmod_functor _ -> + Static + | Tmod_apply _ -> + Not_recursive + | Tmod_apply_unit _ -> + Not_recursive + | Tmod_constraint (mexp, _, _, coe) -> + begin match coe with + | Tcoerce_none -> classify_module_expression env mexp + | Tcoerce_structure _ -> + Static + | Tcoerce_functor _ -> Static + | Tcoerce_primitive _ -> + Misc.fatal_error "letrec: primitive coercion on a module" + | Tcoerce_alias _ -> + Misc.fatal_error "letrec: alias coercion on a module" + end + | Tmod_unpack (e, _) -> + classify_expression env e in classify_expression Ident.empty @@ -574,19 +647,36 @@ let rec expression : Typedtree.expression -> term_judg = *) 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 + (* [args] may contain omitted arguments, corresponding to labels in + the function's type that were not passed in the actual application. + The arguments before the first omitted argument are passed to the + function immediately, so they are dereferenced. The arguments after + the first omitted one are stored in a closure, so guarded. + The function itself is called immediately (dereferenced) if there + is at least one argument before the first omitted one. + On the other hand, if the first argument is omitted then the + function is stored in the closure without being called. *) + let rec split_args ~has_omitted_arg = function + | [] -> [], [] + | (_, None) :: rest -> split_args ~has_omitted_arg:true rest + | (_, Some arg) :: rest -> + let applied, delayed = split_args ~has_omitted_arg rest in + if has_omitted_arg + then applied, arg :: delayed + else arg :: applied, delayed + in + let applied, delayed = split_args ~has_omitted_arg:false args in + let function_mode = + match applied with + | [] -> Guard + | _ :: _ -> Dereference in - join [expression e; list arg args] << app_mode + join [expression e << function_mode; + list expression applied << Dereference; + list expression delayed << Guard] | 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 *) @@ -599,12 +689,6 @@ let rec expression : Typedtree.expression -> term_judg = (* 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 = @@ -782,18 +866,55 @@ let rec expression : Typedtree.expression -> term_judg = path pth << Dereference; list field fields << Dereference; ] - | Texp_function { cases } -> + | Texp_function (params, body) -> (* - (Gi; _ |- pi -> ei : m[Delay])^i - -------------------------------------- - sum(Gi)^i |- function (pi -> ei)^i : m + G |-{body} b : m[Delay] + (Hj |-{def} Pj : m[Delay])^j + H := sum(Hj)^j + ps := sum(pat(Pj))^j + ----------------------------------- + G + H - ps |- fun (Pj)^j -> b : m + *) + let param_pat param = + (* param P ::= + | ?(pat = expr) + | pat + + Define pat(P) as + pat if P = ?(pat = expr) + pat if P = pat + *) + match param.fp_kind with + | Tparam_pat pat -> pat + | Tparam_optional_default (pat, _) -> pat + in + (* Optional argument defaults. - Contrarily to match, the value that is pattern-matched - is bound locally, so the pattern modes do not influence - the final environment. + G |-{def} P : m *) - let case_env c m = fst (case c m) in - list case_env cases << Delay + let param_default param = + match param.fp_kind with + | Tparam_optional_default (_, default) -> + (* + G |- e : m + ------------------ + G |-{def} ?(p=e) : m + *) + expression default + | Tparam_pat _ -> + (* + ------------------ + . |-{def} p : m + *) + empty + in + let patterns = List.map param_pat params in + let defaults = List.map param_default params in + let body = function_body body in + let f = join (body :: defaults) << Delay in + (fun m -> + let env = f m in + remove_patlist patterns env) | Texp_lazy e -> (* G |- e: m[Delay] @@ -815,18 +936,46 @@ let rec expression : Typedtree.expression -> term_judg = list binding_op (let_ :: ands) << Dereference; case_env body << Delay ] - | Texp_unreachable -> + | Texp_unreachable | Texp_hole -> (* ---------- [] |- .: m *) empty - | Texp_hole -> empty | Texp_extension_constructor (_lid, pth) -> path pth << Dereference | Texp_open (od, e) -> open_declaration od >> expression e +(* Function bodies. + + G |-{body} b : m +*) +and function_body body = + match body with + | Tfunction_body body -> + (* + G |- e : m + ------------------ + G |-{body} e : m (**) + + (**) The "e" here stands for [Tfunction_body] as opposed to + [Tfunction_cases]. + *) + expression body + | Tfunction_cases { cases; _ } -> + (* + (Gi; _ |- pi -> ei : m)^i (**) + ------------------ + sum(Gi)^i |-{body} function (pi -> ei)^i : m + + (**) Contrarily to match, the values that are pattern-matched + are bound locally, so the pattern modes do not influence + the final environment. + *) + List.map (fun c mode -> fst (case c mode)) cases + |> join + and binding_op : Typedtree.binding_op -> term_judg = fun bop -> join [path bop.bop_op_path; expression bop.bop_exp] @@ -1201,8 +1350,8 @@ and pattern : type k . k general_pattern -> Env.t -> mode = fun pat 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_var (_, _, _) -> false + | Tpat_alias (pat, _, _, _) -> is_destructuring_pattern pat | Tpat_constant _ -> true | Tpat_tuple _ -> true | Tpat_construct _ -> true @@ -1215,21 +1364,27 @@ and is_destructuring_pattern : type k . k general_pattern -> bool = | Tpat_or (l,r,_) -> is_destructuring_pattern l || is_destructuring_pattern r -let is_valid_recursive_expression idlist expr = +let is_valid_recursive_expression idlist expr : sd option = match expr.exp_desc with | Texp_function _ -> (* Fast path: functions can never have invalid recursive references *) - true + Some Static | _ -> - match classify_expression expr with - | Static -> - (* The expression has known size *) - let ty = expression expr Return in - Env.unguarded ty idlist = [] - | Dynamic -> - (* The expression has unknown size *) - let ty = expression expr Return in - Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] + let rkind = classify_expression expr in + let is_valid = + match rkind with + | Static | Constant -> + (* The expression has known size or is constant *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] + | Not_recursive -> + (* The expression has unknown size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] + | Class -> + assert false (* Not generated by [classify_expression] *) + in + if is_valid then Some rkind else None (* A class declaration may contain let-bindings. If they are recursive, their validity will already be checked by [is_valid_recursive_expression] diff --git a/src/ocaml/typing/rec_check.mli b/src/ocaml/typing/value_rec_check.mli similarity index 89% rename from src/ocaml/typing/rec_check.mli rename to src/ocaml/typing/value_rec_check.mli index aa5c1ca3c1..8010e7c92c 100644 --- a/src/ocaml/typing/rec_check.mli +++ b/src/ocaml/typing/value_rec_check.mli @@ -12,8 +12,9 @@ (* *) (**************************************************************************) -exception Illegal_expr - -val is_valid_recursive_expression : Ident.t list -> Typedtree.expression -> bool +val is_valid_recursive_expression : + Ident.t list -> + Typedtree.expression -> + Value_rec_types.recursive_binding_kind option val is_valid_class_expr : Ident.t list -> Typedtree.class_expr -> bool diff --git a/src/ocaml/typing/value_rec_types.mli b/src/ocaml/typing/value_rec_types.mli new file mode 100644 index 0000000000..93be6ee9ba --- /dev/null +++ b/src/ocaml/typing/value_rec_types.mli @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Vincent Laviron, OCamlPro *) +(* *) +(* Copyright 2023 OCamlPro, SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Types related to the compilation of value let-recs (non-functional + recursive definitions) *) + +(** The kind of recursive bindings, as computed by + [Rec_check.classify_expression] *) +type recursive_binding_kind = +| Static + (** The expression evaluates to a function or block of a + statically known size. + It will be pre-allocated and back-patched later. + The expression can refer to recursive variables as long as it + does not inspect them during its evaluation. *) +| Constant + (** The expression evaluates to a value that does not contain any + occurrence of a recursive variable. + Combined with the invariant that recursive variables must never be + examined during the definitions, this special case allow using the + same rules as Static bindings (i.e. allow guarded occurrences of + recursive variables in the expression) for values that cannot be + back-patched (unit, integers, empty arrays, ...). *) +| Not_recursive + (** Non recursive bindings. Arbitrary expressions, that are not allowed to + refer to any recursive variable. *) +| Class + (** Bindings generated by the compilation of objects and classes. + These bindings are generated in Lambda form directly and never go through + [Rec_check], so to avoid re-implementing the classification pass on Lambda + we simply identify this special case with a dedicated constructor. *) diff --git a/src/ocaml/utils/clflags.ml b/src/ocaml/utils/clflags.ml index 337ac0a3c4..f507f58362 100644 --- a/src/ocaml/utils/clflags.ml +++ b/src/ocaml/utils/clflags.ml @@ -1,8 +1,10 @@ (** {0 OCaml compiler compatible command-line parameters} *) let cmi_file = ref None let include_dirs = ref [] +let hidden_include_dirs = ref [] let fast = ref false let classic = ref false +let all_ppx = ref [] let principal = ref false let real_paths = ref true let recursive_types = ref false @@ -15,6 +17,7 @@ let open_modules = ref [] let annotations = ref false let binary_annotations = ref true +let store_occurrences = ref true let print_types = ref false let native_code = ref false let error_size = ref 500 diff --git a/src/ocaml/utils/clflags.mli b/src/ocaml/utils/clflags.mli index 6294b08de6..4948f58901 100644 --- a/src/ocaml/utils/clflags.mli +++ b/src/ocaml/utils/clflags.mli @@ -8,8 +8,10 @@ Parameters from OCaml compiler which affect Merlin behavior. *) val cmi_file : string option ref val include_dirs : string list ref +val hidden_include_dirs : string list ref val fast : bool ref val classic : bool ref +val all_ppx : string list ref val principal : bool ref val real_paths : bool ref val recursive_types : bool ref @@ -23,6 +25,7 @@ val open_modules : string list ref Ignored by merlin but kept for compatibility with upstream code. *) val annotations : bool ref val binary_annotations : bool ref +val store_occurrences : bool ref val print_types : bool ref val native_code : bool ref val dont_write_files : bool ref diff --git a/src/ocaml/utils/config.ml b/src/ocaml/utils/config.ml index f1f93f2814..6d255944b7 100644 --- a/src/ocaml/utils/config.ml +++ b/src/ocaml/utils/config.ml @@ -28,6 +28,8 @@ let version = Sys.ocaml_version let flambda = false +let ext_obj = ".o_The boot compiler cannot process C objects" + let exec_magic_number = "Caml1999X033" (* exec_magic_number is duplicated in runtime/caml/exec.h *) and cmi_magic_number = "Caml1999I033" diff --git a/src/ocaml/utils/config.mli b/src/ocaml/utils/config.mli index 02713f5086..26323f87fa 100644 --- a/src/ocaml/utils/config.mli +++ b/src/ocaml/utils/config.mli @@ -18,6 +18,8 @@ val version: string (* The current version number of the system *) +val ext_obj : string + val interface_suffix: string ref (* Suffix for interface file names *) diff --git a/src/ocaml/utils/diffing.ml b/src/ocaml/utils/diffing.ml index e5b230e233..94391803ae 100644 --- a/src/ocaml/utils/diffing.ml +++ b/src/ocaml/utils/diffing.ml @@ -36,14 +36,14 @@ type change_kind = | Preservation let style = function - | Preservation -> Misc.Color.[ FG Green ] - | Deletion -> Misc.Color.[ FG Red; Bold] - | Insertion -> Misc.Color.[ FG Red; Bold] - | Modification -> Misc.Color.[ FG Magenta; Bold] + | Preservation -> Misc.Style.[ FG Green ] + | Deletion -> Misc.Style.[ FG Red; Bold] + | Insertion -> Misc.Style.[ FG Red; Bold] + | Modification -> Misc.Style.[ FG Magenta; Bold] let prefix ppf (pos, p) = let sty = style p in - Format.pp_open_stag ppf (Misc.Color.Style sty); + Format.pp_open_stag ppf (Misc.Style.Style sty); Format.fprintf ppf "%i. " pos; Format.pp_close_stag ppf () diff --git a/src/ocaml/utils/diffing.mli b/src/ocaml/utils/diffing.mli index 80cfa5e279..7f4d7ced1b 100644 --- a/src/ocaml/utils/diffing.mli +++ b/src/ocaml/utils/diffing.mli @@ -80,7 +80,7 @@ type change_kind = | Modification | Preservation val prefix: Format.formatter -> (int * change_kind) -> unit -val style: change_kind -> Misc.Color.style list +val style: change_kind -> Misc.Style.style list type ('left,'right,'eq,'diff) change = diff --git a/src/ocaml/utils/diffing_with_keys.ml b/src/ocaml/utils/diffing_with_keys.ml index 8a313143bd..33a03b4da5 100644 --- a/src/ocaml/utils/diffing_with_keys.ml +++ b/src/ocaml/utils/diffing_with_keys.ml @@ -37,7 +37,7 @@ let prefix ppf x = in let style k ppf inner = let sty = Diffing.style k in - Format.pp_open_stag ppf (Misc.Color.Style sty); + Format.pp_open_stag ppf (Misc.Style.Style sty); Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner in match x with diff --git a/src/ocaml/utils/load_path.ml b/src/ocaml/utils/load_path.ml index 70ce575599..1944e32b9b 100644 --- a/src/ocaml/utils/load_path.ml +++ b/src/ocaml/utils/load_path.ml @@ -19,17 +19,22 @@ 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 +let visible_files : registry ref = s_table STbl.create 42 +let visible_files_uncap : registry ref = s_table STbl.create 42 + +let hidden_files : registry ref = s_table STbl.create 42 +let hidden_files_uncap : registry ref = s_table STbl.create 42 module Dir = struct type t = { path : string; files : string list; + hidden : bool; } let path t = t.path let files t = t.files + let hidden t = t.hidden let find t fn = if List.mem fn t.files then @@ -37,18 +42,18 @@ module Dir = struct else None - let find_uncap t fn = - let fn = String.uncapitalize_ascii fn in + let find_normalized t fn = + let fn = Misc.normalized_unit_filename fn in let search base = - if String.uncapitalize_ascii base = fn then + if Misc.normalized_unit_filename base = fn then Some (Filename.concat t.path base) else None in List.find_map search t.files - let create path = - { path; files = Array.to_list (Directory_content_cache.read path) } + let create ~hidden path = + { path; files = Array.to_list (Directory_content_cache.read path); hidden } let check t = Directory_content_cache.check t.path @@ -56,19 +61,37 @@ end type auto_include_callback = (Dir.t -> string -> string option) -> string -> string -let dirs = s_ref [] + +let visible_dirs = s_ref [] +let hidden_dirs = s_ref [] let no_auto_include _ _ = raise Not_found let auto_include_callback = ref no_auto_include let reset () = assert (not Config.merlin || Local_store.is_bound ()); - STbl.clear !files; - STbl.clear !files_uncap; - dirs := []; + STbl.clear !hidden_files; + STbl.clear !hidden_files_uncap; + STbl.clear !visible_files; + STbl.clear !visible_files_uncap; + hidden_dirs := []; + visible_dirs := []; auto_include_callback := no_auto_include -let get () = List.rev !dirs -let get_paths () = List.rev_map Dir.path !dirs +let get_visible () = List.rev !visible_dirs + +let get_path_list () = + Misc.rev_map_end Dir.path !visible_dirs (List.rev_map Dir.path !hidden_dirs) + +type paths = + { visible : string list; + hidden : string list } + +let get_paths () = + { visible = List.rev_map Dir.path !visible_dirs; + hidden = List.rev_map Dir.path !hidden_dirs } + +let get_visible_path_list () = List.rev_map Dir.path !visible_dirs +let get_hidden_path_list () = List.rev_map Dir.path !hidden_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 @@ -77,77 +100,106 @@ let get_paths () = List.rev_map Dir.path !dirs 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 + let filename = Misc.normalized_unit_filename base in + if dir.Dir.hidden then begin + STbl.replace !hidden_files base fn; + STbl.replace !hidden_files_uncap filename fn + end else begin + STbl.replace !visible_files base fn; + STbl.replace !visible_files_uncap filename fn + end ) dir.Dir.files -let init ~auto_include l = +let init ~auto_include ~visible ~hidden = assert (not Config.merlin || Local_store.is_bound ()); - let rec loop_changed acc = function + let rec loop_changed ~hidden acc = function | [] -> Some acc | new_path :: new_rest -> - loop_changed (Dir.create new_path :: acc) new_rest + loop_changed ~hidden (Dir.create ~hidden new_path :: acc) new_rest in - let rec loop_unchanged acc new_paths old_dirs = + let rec loop_unchanged ~hidden 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 + loop_changed ~hidden (Dir.create ~hidden 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 + loop_unchanged ~hidden (old_dir :: acc) new_rest old_rest end else begin - loop_changed (Dir.create new_path :: acc) new_rest + loop_changed ~hidden (Dir.create ~hidden new_path :: acc) new_rest end end else begin - loop_changed (Dir.create new_path :: acc) new_rest + loop_changed ~hidden (Dir.create ~hidden new_path :: acc) new_rest end in - match loop_unchanged [] l (List.rev !dirs) with + let () = + match loop_unchanged ~hidden:false [] visible (List.rev !visible_dirs) with + | None -> () + | Some new_dirs -> + reset (); + visible_dirs := new_dirs; + List.iter prepend_add new_dirs; + auto_include_callback := auto_include + in + match loop_unchanged ~hidden:true [] hidden (List.rev !hidden_dirs) with | None -> () | Some new_dirs -> reset (); - dirs := new_dirs; + hidden_dirs := new_dirs; List.iter prepend_add new_dirs; auto_include_callback := auto_include 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 + let visible = List.filter (fun d -> Dir.path d <> dir) !visible_dirs in + let hidden = List.filter (fun d -> Dir.path d <> dir) !hidden_dirs in + if List.compare_lengths visible !visible_dirs <> 0 + || List.compare_lengths hidden !hidden_dirs <> 0 then begin reset (); - List.iter prepend_add new_dirs; - dirs := new_dirs + visible_dirs := visible; + hidden_dirs := hidden; + List.iter prepend_add hidden; + List.iter prepend_add visible 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 = + add a basename to the cache if it is not already present, in order to enforce + left-to-right precedence. *) +let add (dir : Dir.t) = assert (not Config.merlin || Local_store.is_bound ()); + let update base fn visible_files hidden_files = + if dir.hidden && not (STbl.mem !hidden_files base) then + STbl.replace !hidden_files base fn + else if not (STbl.mem !visible_files base) then + STbl.replace !visible_files base fn + in 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 + update base fn visible_files hidden_files; + let ubase = Misc.normalized_unit_filename base in + update ubase fn visible_files_uncap hidden_files_uncap) + dir.files; + if dir.hidden then + hidden_dirs := dir :: !hidden_dirs + else + visible_dirs := dir :: !visible_dirs let append_dir = add -let add_dir dir = add (Dir.create dir) +let add_dir ~hidden dir = add (Dir.create ~hidden dir) (* Add the directory at the start of load path - so basenames are unconditionally added. *) -let prepend_dir dir = +let prepend_dir (dir : Dir.t) = assert (not Config.merlin || Local_store.is_bound ()); prepend_add dir; - dirs := !dirs @ [dir] + if dir.hidden then + hidden_dirs := !hidden_dirs @ [dir] + else + visible_dirs := !visible_dirs @ [dir] let is_basename fn = Filename.basename fn = fn @@ -169,27 +221,40 @@ let is_basename fn = Filename.basename fn = fn (* Ensure directories are only ever scanned once *) let expand = Misc.expand_directory Config.standard_library in let otherlibs = - let read_lib lib = lazy (Dir.create (expand ("+" ^ lib))) in + let read_lib lib = lazy (Dir.create ~hidden:false (expand ("+" ^ lib))) in List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in auto_include_libs otherlibs *) +type visibility = Visible | Hidden + +let find_file_in_cache fn visible_files hidden_files = + try (STbl.find !visible_files fn, Visible) with + | Not_found -> (STbl.find !hidden_files fn, Hidden) + let find fn = assert (not Config.merlin || Local_store.is_bound ()); try if is_basename fn && not !Sys.interactive then - STbl.find !files fn + fst (find_file_in_cache fn visible_files hidden_files) else - Misc.find_in_path (get_paths ()) fn + Misc.find_in_path (get_path_list ()) fn with Not_found -> !auto_include_callback Dir.find fn -let find_uncap fn = +let find_normalized_with_visibility fn = assert (not Config.merlin || Local_store.is_bound ()); try if is_basename fn && not !Sys.interactive then - STbl.find !files_uncap (String.uncapitalize_ascii fn) + find_file_in_cache (Misc.normalized_unit_filename fn) + visible_files_uncap hidden_files_uncap else - Misc.find_in_path_uncap (get_paths ()) fn + try + (Misc.find_in_path_normalized (get_visible_path_list ()) fn, Visible) + with + | Not_found -> + (Misc.find_in_path_normalized (get_hidden_path_list ()) fn, Hidden) with Not_found -> - let fn_uncap = String.uncapitalize_ascii fn in - !auto_include_callback Dir.find_uncap fn_uncap + let fn_uncap = Misc.normalized_unit_filename fn in + (!auto_include_callback Dir.find_normalized fn_uncap, Visible) + + let find_normalized fn = fst (find_normalized_with_visibility fn) diff --git a/src/ocaml/utils/load_path.mli b/src/ocaml/utils/load_path.mli index 7d9abe0a0b..c467f46522 100644 --- a/src/ocaml/utils/load_path.mli +++ b/src/ocaml/utils/load_path.mli @@ -14,15 +14,15 @@ (** 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 + This module offers a high level interface to locating files in the load + path, which is constructed from [-I] and [-H] 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 +val add_dir : hidden:bool -> string -> unit (** Add a directory to the end of the load path (i.e. at lowest priority.) *) val remove_dir : string -> unit @@ -35,7 +35,7 @@ module Dir : sig type t (** Represent one directory in the load path. *) - val create : string -> t + val create : hidden:bool -> string -> t val path : t -> string @@ -43,10 +43,14 @@ module Dir : sig (** All the files in that directory. This doesn't include files in sub-directories of this directory. *) + val hidden : t -> bool + (** If the modules in this directory should not be bound in the initial + scope *) + val find : t -> string -> string option (** [find dir fn] returns the full path to [fn] in [dir]. *) - val find_uncap : t -> string -> string option + val find_normalized : t -> string -> string option (** As {!find}, but search also for uncapitalized name, i.e. if name is Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) end @@ -59,8 +63,13 @@ val no_auto_include : auto_include_callback (** No automatic directory inclusion: misses in the load path raise [Not_found] as normal. *) -val init : auto_include:auto_include_callback -> string list -> unit -(** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *) +val init : + auto_include:auto_include_callback -> visible:string list -> + hidden:string list -> unit +(** [init ~visible ~hidden] is the same as + [reset (); + List.iter add_dir (List.rev hidden); + List.iter add_dir (List.rev visible)] *) (* val auto_include_otherlibs : config:Mconfig.t -> (string -> unit) -> auto_include_callback *) @@ -68,18 +77,32 @@ val init : auto_include:auto_include_callback -> string list -> unit {!Load_path.init} and automatically adds [-I +lib] to the load path after calling [alert lib]. *) -val get_paths : unit -> string list +val get_path_list : unit -> string list (** Return the list of directories passed to [add_dir] so far. *) +type paths = + { visible : string list; + hidden : string list } + +val get_paths : unit -> paths +(** Return the 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. *) +val find_normalized : string -> string +(** Same as [find], but search also for normalized unit name (see + {!Misc.normalized_unit_filename}), i.e. if name is [Foo.ml], allow + [/path/Foo.ml] and [/path/foo.ml] to match. *) + +type visibility = Visible | Hidden + +val find_normalized_with_visibility : string -> string * visibility +(** Same as [find_normalized], but also reports whether the cmi was found in a + -I directory (Visible) or a -H directory (Hidden) *) val[@deprecated] add : Dir.t -> unit (** Old name for {!append_dir} *) @@ -92,5 +115,6 @@ 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]. *) +val get_visible : unit -> Dir.t list +(** Same as [get_paths ()], except that it returns a [Dir.t list], and doesn't + include the -H paths. *) diff --git a/src/ocaml/utils/warnings.mli b/src/ocaml/utils/warnings.mli index 08f30ac40a..bb42eec6ef 100644 --- a/src/ocaml/utils/warnings.mli +++ b/src/ocaml/utils/warnings.mli @@ -68,7 +68,11 @@ type t = | Unused_var of string (* 26 *) | Unused_var_strict of string (* 27 *) | Wildcard_arg_to_constant_constr (* 28 *) - | Eol_in_string (* 29 *) + | Eol_in_string (* 29 + Note: since OCaml 5.2, the lexer normalizes \r\n sequences in + the source file to a single \n character, so the behavior of + newlines in string literals is portable. This warning is + never emitted anymore. *) | Duplicate_definitions of string * string * string * string (* 30 *) | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) diff --git a/src/utils/misc.ml b/src/utils/misc.ml index fa9bafe3f7..063539e2b7 100644 --- a/src/utils/misc.ml +++ b/src/utils/misc.ml @@ -87,6 +87,13 @@ let protect_refs = let map_end f l1 l2 = List.map_end ~f l1 l2 +let rev_map_end f l1 l2 = + let rec rmap_f accu = function + | [] -> accu + | hd::tl -> rmap_f (f hd :: accu) tl + in + rmap_f l2 l1 + let rec map_left_right f = function [] -> [] | hd::tl -> let res = f hd in res :: map_left_right f tl @@ -262,12 +269,14 @@ let find_in_path_rel path name = else try_dir rem in try_dir path -let find_in_path_uncap ?(fallback="") path name = +let normalized_unit_filename = String.uncapitalize_ascii + +let find_in_path_normalized ?(fallback="") path name = let has_fallback = fallback <> "" in canonicalize_filename begin - let uname = String.uncapitalize name in - let ufallback = String.uncapitalize fallback in + let uname = normalized_unit_filename name in + let ufallback = normalized_unit_filename fallback in List.find_map path ~f:(fun dirname -> if exact_file_exists ~dirname ~basename:uname then Some (Filename.concat dirname uname) @@ -381,6 +390,12 @@ let no_overflow_mul a b = let no_overflow_lsl a k = 0 <= k && k < Sys.word_size - 1 && min_int asr k <= a && a <= max_int asr k +let letter_of_int n = + let letter = String.make 1 (Char.chr (Char.code 'a' + n mod 26)) in + let num = n / 26 in + if num = 0 then letter + else letter ^ Int.to_string num + module Int_literal_converter = struct (* To convert integer literals, allowing max_int + 1 (PR#4210) *) let cvt_int_aux str neg of_string = @@ -511,149 +526,6 @@ 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 "@\n@{Hint@}: 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, @@ -667,8 +539,26 @@ let ordinal_suffix n = | 3 when not teen -> "rd" | _ -> "th" -(* Color handling *) +(* Color support handling *) module Color = struct + 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 enabled = ref true + +end + +(* Terminal styling handling *) +module Style = struct (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) type color = | Black @@ -712,19 +602,30 @@ module Color = struct type Format.stag += Style of style list + + type tag_style ={ + ansi: style list; + text_open:string; + text_close:string + } + type styles = { - error: style list; - warning: style list; - loc: style list; - hint:style list; + error: tag_style; + warning: tag_style; + loc: tag_style; + hint: tag_style; + inline_code: tag_style; } + let no_markup stl = { ansi = stl; text_close = ""; text_open = "" } + let default_styles = { - warning = [Bold; FG Magenta]; - error = [Bold; FG Red]; - loc = [Bold]; - hint = [Bold; FG Blue]; - } + warning = no_markup [Bold; FG Magenta]; + error = no_markup [Bold; FG Red]; + loc = no_markup [Bold]; + hint = no_markup [Bold; FG Blue]; + inline_code= { ansi=[Bold]; text_open = {|"|}; text_close = {|"|} } + } let cur_styles = ref default_styles let get_styles () = !cur_styles @@ -733,30 +634,36 @@ module Color = struct (* 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 "error" -> (!cur_styles).error + | Format.String_tag "warning" ->(!cur_styles).warning | Format.String_tag "loc" -> (!cur_styles).loc | Format.String_tag "hint" -> (!cur_styles).hint - | Style s -> s + | Format.String_tag "inline_code" -> (!cur_styles).inline_code + | Style s -> no_markup s | _ -> raise Not_found - let color_enabled = ref true + let as_inline_code printer ppf x = + Format.pp_open_stag ppf (Format.String_tag "inline_code"); + printer ppf x; + Format.pp_close_stag ppf () + + let inline_code ppf s = as_inline_code Format.pp_print_string ppf s (* 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 "" + if !Color.enabled then ansi_of_style_l style.ansi else style.text_open 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 "" + let style = style_of_tag s in + if !Color.enabled then ansi_of_style_l [Reset] else style.text_close with Not_found -> or_else s - (* add color handling to formatter [ppf] *) - let set_color_tag_handling ppf = + (* add tag handling to formatter [ppf] *) + let set_tag_handling ppf = let open Format in let functions = pp_get_formatter_stag_functions ppf () in let functions' = {functions with @@ -767,41 +674,109 @@ module Color = struct 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 + | Color.Auto -> Color.should_enable_color () + | Color.Always -> true + | Color.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 + List.iter ~f:set_tag_handling formatter_l; + Color.enabled := (match o with | Some s -> enable_color s - | None -> enable_color default_setting) + | None -> enable_color Color.default_setting) ); () 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 ~cmp:(fun s1 s2 -> String.compare s2 s1) env 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 + let comma ppf () = Format.fprintf ppf ", " in + Format.fprintf ppf "@\n@{Hint@}: Did you mean %a%s%a?@?" + (Format.pp_print_list ~pp_sep:comma Style.inline_code) rest + (if rest = [] then "" else " or ") + Style.inline_code last + let print_see_manual ppf manual_section = let open Format in fprintf ppf "(see manual section %a)" diff --git a/src/utils/misc.mli b/src/utils/misc.mli index 432f889fc6..249f8b668b 100644 --- a/src/utils/misc.mli +++ b/src/utils/misc.mli @@ -72,6 +72,9 @@ val reraise_preserving_backtrace : exn -> (unit -> unit) -> 'a 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 rev_map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list + (** [map_end f l t] is [map f (rev 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 *) @@ -111,10 +114,14 @@ val find_in_path: string list -> string -> string 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. *) + (** Normalize file name [Foo.ml] to [foo.ml] *) +val normalized_unit_filename: string -> string + +val find_in_path_normalized: ?fallback:string -> string list -> string -> string +(** Same as {!find_in_path_rel} , but search also for normalized unit filename, + 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 "." *) @@ -186,6 +193,8 @@ val no_overflow_lsl: int -> int -> bool (* [no_overflow_lsl n k] returns [true] if the computation of [n lsl k] does not overflow. *) +val letter_of_int : int -> string + module Int_literal_converter : sig val int : string -> int val int32 : string -> int32 @@ -268,21 +277,6 @@ val for4: 'a * 'b * 'c * 'd -> 'd * - 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 @@ -359,8 +353,18 @@ val ordinal_suffix : int -> string [4] -> ["th"], and so on. Handles larger numbers (e.g., [42] -> ["nd"]) and the numbers 11--13 (which all get ["th"]) correctly. *) -(* Color handling *) -module Color : sig +(** {1 Color support detection }*) +module Color: sig + type setting = Auto | Always | Never + + val default_setting : setting + +end + + +(** {1 Styling handling for terminal output } *) + +module Style : sig type color = | Black | Red @@ -382,27 +386,33 @@ module Color : sig val ansi_of_style_l : style list -> string (* ANSI escape sequence for the given style *) + type tag_style ={ + ansi: style list; + text_open:string; + text_close:string + } + type styles = { - error: style list; - warning: style list; - loc: style list; - hint:style list; + error: tag_style; + warning: tag_style; + loc: tag_style; + hint: tag_style; + inline_code: tag_style; } + val as_inline_code: (Format.formatter -> 'a -> unit as 'printer) -> 'printer + val inline_code: Format.formatter -> string -> unit + 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 + val setup : Color.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 + val set_tag_handling : Format.formatter -> unit (* adds functions to support color tags to the given formatter. *) end diff --git a/src/utils/std.ml b/src/utils/std.ml index 5ba3803b6f..2f02dcb782 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -224,6 +224,14 @@ module List = struct let acc, xs' = fold_n_map ~f ~init:acc xs in acc, (x' :: xs') + let rec iteri2 i ~f l1 l2 = + match (l1, l2) with + ([], []) -> () + | (a1::l1, a2::l2) -> f i a1 a2; iteri2 (i + 1) ~f l1 l2 + | (_, _) -> raise (Invalid_argument "iteri2") + + let iteri2 ~f l1 l2 = iteri2 0 ~f l1 l2 + module Lazy = struct type 'a t = | Nil From 1711442c0be0a5875d7e0e4f2d8fdf07ff09c5bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 5 Feb 2024 18:50:14 +0100 Subject: [PATCH 062/130] upgrade: adapt to small changes in the typer --- src/analysis/completion.ml | 6 +++-- src/analysis/construct.ml | 4 +-- src/analysis/context.ml | 4 +-- src/analysis/destruct.ml | 33 ++++++++++++++---------- src/analysis/locate.ml | 4 +-- src/analysis/outline.ml | 2 +- src/analysis/polarity_search.ml | 4 ++- src/analysis/ptyp_of_type.ml | 2 +- src/analysis/type_utils.ml | 4 +-- src/frontend/query_commands.ml | 4 +-- src/ocaml/merlin_specific/browse_raw.ml | 9 ++++--- src/ocaml/merlin_specific/tast_helper.ml | 6 ++--- 12 files changed, 46 insertions(+), 36 deletions(-) diff --git a/src/analysis/completion.ml b/src/analysis/completion.ml index f8d713250b..5a9451d2bd 100644 --- a/src/analysis/completion.ml +++ b/src/analysis/completion.ml @@ -280,7 +280,7 @@ let fold_sumtype_constructors ~env ~init ~f t = (Path.name path); begin match Env.find_type_descrs path env with | exception Not_found -> init - | Type_record _ | Type_abstract | Type_open -> init + | Type_record _ | Type_abstract _ | Type_open -> init | Type_variant (constrs, _) -> List.fold_right constrs ~init ~f end @@ -650,7 +650,9 @@ let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix = 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 + let _, lbl_arg, lbl_res = + Ctype.instance_label ~fixed:false lbl + in begin try Ctype.unify_var env ty lbl_res; with _ -> () diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml index d5df2d0977..93a29a16d9 100644 --- a/src/analysis/construct.ml +++ b/src/analysis/construct.ml @@ -425,7 +425,7 @@ module Gen = struct (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 + let _, arg, res = Ctype.instance_label ~fixed:true lbl in Ctype.unify env res typ ; let lid = Util.maybe_prefix env @@ -477,7 +477,7 @@ module Gen = struct match def with | Type_variant (constrs, _) -> constructor env rtyp path constrs | Type_record (labels, _) -> record env rtyp path labels - | Type_abstract | Type_open -> [] + | Type_abstract _ | Type_open -> [] end | Tarrow (label, tyleft, tyright, _) -> let argument, name = make_arg env label tyleft in diff --git a/src/analysis/context.ml b/src/analysis/context.ml index 7fba149868..ec8daab26a 100644 --- a/src/analysis/context.ml +++ b/src/analysis/context.ml @@ -87,9 +87,9 @@ let inspect_pattern (type a) ~cursor ~lid (p : a Typedtree.general_pattern) = (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 -> + | Tpat_var (_, str_loc, _) when (Longident.last lid) = str_loc.txt -> None - | Tpat_alias (_, _, str_loc) + | 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. *) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index 895d6c2311..dd4dfb8093 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -105,7 +105,9 @@ let rec gen_patterns ?(recurse=true) env type_expr = 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) + Tast_helper.Pat.var + (Uid.internal_not_actually_unique) + env type_expr (mk_var lbl_descr.lbl_name) ) in [ Tast_helper.Pat.record env type_expr lst Asttypes.Closed ] @@ -121,9 +123,11 @@ let rec gen_patterns ?(recurse=true) env type_expr = let res = try ignore ( - Ctype.unify_gadt ~equations_level:0 - ~allow_recursive_equations:true (* really? *) - (ref env) type_expr typ + let pattern_env = Ctype.Pattern_env.make env + ~equations_scope:0 + ~allow_recursive_equations:true + in + Ctype.unify_gadt pattern_env type_expr typ ); true with Ctype.Unify _trace -> false @@ -199,7 +203,7 @@ let rec needs_parentheses = function | Texp_let _ (* We are after the "in" keyword, we need to look at the parent of the binding. *) - | Texp_function {cases = [ _ ]; _ } + | Texp_function (_, Tfunction_body _) (* The assumption here is that we're not in a [function ... | ...] situation but either in [fun param] or [let name param]. *) -> @@ -301,7 +305,7 @@ let rec destructible patt = let open Typedtree in match patt.pat_desc with | Tpat_any | Tpat_var _ -> true - | Tpat_alias (p, _, _) -> destructible p + | Tpat_alias (p, _, _, _) -> destructible p | _ -> false @@ -335,8 +339,8 @@ let rec subst_patt initial ~by patt = | Tpat_any | Tpat_var _ | Tpat_constant _ -> patt - | Tpat_alias (p,x,y) -> - { patt with pat_desc = Tpat_alias (f p, x, y) } + | Tpat_alias (p,x,y,uid) -> + { patt with pat_desc = Tpat_alias (f p, x, y,uid) } | Tpat_tuple lst -> { patt with pat_desc = Tpat_tuple (List.map lst ~f) } | Tpat_construct (lid, cd, lst, lco) -> @@ -362,8 +366,8 @@ let rec rm_sub patt sub = | Tpat_any | Tpat_var _ | Tpat_constant _ -> patt - | Tpat_alias (p,x,y) -> - { patt with pat_desc = Tpat_alias (f p, x, y) } + | Tpat_alias (p,x,y,uid) -> + { patt with pat_desc = Tpat_alias (f p, x, y,uid) } | Tpat_tuple lst -> { patt with pat_desc = Tpat_tuple (List.map lst ~f) } | Tpat_construct (lid, cd, lst, lco) -> @@ -388,7 +392,8 @@ let rec qualify_constructors ~unmangling_tables f pat = 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_alias (p, id, loc, uid) -> + Tpat_alias (qualify_constructors f p, id, loc, uid) | Tpat_tuple ps -> Tpat_tuple (List.map ps ~f:(qualify_constructors f)) | Tpat_record (labels, closed) -> let labels = @@ -458,7 +463,7 @@ let find_branch patterns sub = | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> false - | Tpat_alias (p,_,_) + | Tpat_alias (p,_,_,_) | Tpat_variant (_, Some p, _) | Tpat_lazy p -> is_sub_patt p ~sub @@ -518,14 +523,14 @@ module Conv = struct match pat.pat_desc with Tpat_or (pa,pb,_) -> mkpat (Ppat_or (loop pa, loop pb)) - | Tpat_var (_, ({txt="*extension*"; _} as nm)) -> (* PR#7330 *) + | 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_alias (p,_,_,_) -> loop p | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map ~f:loop lst)) | Tpat_construct (cstr_lid, cstr, lst, _) -> diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 177bc3c8b5..35dc6be2a2 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -255,7 +255,7 @@ module Utils = struct None in let fname = File.with_ext ~src_suffix_pair file in - try Some (Misc.find_in_path_uncap ?fallback path fname) + try Some (Misc.find_in_path_normalized ?fallback path fname) with Not_found -> None in try @@ -341,7 +341,7 @@ let scrape_alias ~env ~fallback_uid ~namespace path = let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace = let module Shape_reduce = - Shape.Make_reduce (struct + Shape_reduce.Make (struct type env = Env.t let fuel = 10 diff --git a/src/analysis/outline.ml b/src/analysis/outline.ml index ed179236ca..54a64a0e71 100644 --- a/src/analysis/outline.ml +++ b/src/analysis/outline.ml @@ -36,7 +36,7 @@ open Browse_raw open Browse_tree let id_of_patt = function - | { pat_desc = Tpat_var (id, _) ; _ } -> Some id + | { pat_desc = Tpat_var (id, _, _) ; _ } -> Some id | _ -> None let mk ?(children=[]) ~location ~deprecated outline_kind outline_type id = diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index ee224c12d1..43ff256cc8 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -24,7 +24,9 @@ let rec normalize_path env path = | decl -> match decl.Types.type_manifest with | Some body when decl.Types.type_private = Asttypes.Public - || decl.Types.type_kind <> Types.Type_abstract -> + || (match decl.Types.type_kind with + | Types.Type_abstract _ -> false + | _ -> true) -> begin match Types.get_desc body with | Types.Tconstr (path, _, _) -> normalize_path env path | _ -> path diff --git a/src/analysis/ptyp_of_type.ml b/src/analysis/ptyp_of_type.ml index 3163de99a6..8c71b56405 100644 --- a/src/analysis/ptyp_of_type.ml +++ b/src/analysis/ptyp_of_type.ml @@ -161,7 +161,7 @@ and type_declaration id { core_type, (v, i)) in let kind = match type_kind with - | Type_abstract -> Parsetree.Ptype_abstract + | Type_abstract _ -> Parsetree.Ptype_abstract | Type_open -> Ptype_open | Type_variant (constrs, _) -> Ptype_variant (List.map ~f:constructor_declaration constrs) diff --git a/src/analysis/type_utils.ml b/src/analysis/type_utils.ml index e3fb86e759..a2c87b7ed1 100644 --- a/src/analysis/type_utils.ml +++ b/src/analysis/type_utils.ml @@ -31,7 +31,7 @@ open Std module Verbosity = Mconfig.Verbosity let protect expr = - Pprintast.protect_ident (Format.str_formatter) expr; + Pprintast.ident_of_name (Format.str_formatter) expr; Format.flush_str_formatter () let parse_expr ?(keywords=Lexer_raw.keywords []) expr = @@ -216,7 +216,7 @@ let print_type_with_decl ~verbosity env ppf typ = in let is_abstract = match decl.Types.type_kind with - | Types.Type_abstract -> true + | Types.Type_abstract _ -> true | _ -> false in (* Print expression only if it is parameterized or abstract *) diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 350d3e7586..7736197f96 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -755,9 +755,9 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | [] -> raise Not_found | x :: xs -> try - find_in_path_uncap (Mconfig.source_path config) x + find_in_path_normalized (Mconfig.source_path config) x with Not_found -> try - find_in_path_uncap (Mconfig.build_path config) x + find_in_path_normalized (Mconfig.build_path config) x with Not_found -> aux xs in diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml index 057e6c8d8b..c5265b375f 100644 --- a/src/ocaml/merlin_specific/browse_raw.ml +++ b/src/ocaml/merlin_specific/browse_raw.ml @@ -299,7 +299,7 @@ let of_pat_record_field 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_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 -> @@ -368,7 +368,7 @@ let of_expression_desc loc = function | 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 } + ; mb_presence; mb_uid=Shape.Uid.internal_not_actually_unique } in app (Module_binding mb) ** of_expression e | Texp_letexception (ec,e) -> @@ -534,6 +534,7 @@ and of_signature_item_desc = function and of_core_type_desc = function | Ttyp_any | Ttyp_var _ -> id_fold + | Ttyp_open (_,_,ct) -> of_core_type ct | Ttyp_arrow (_,ct1,ct2) -> of_core_type ct1 ** of_core_type ct2 | Ttyp_tuple cts | Ttyp_constr (_,_,cts) | Ttyp_class (_,_,cts) -> @@ -780,9 +781,9 @@ let pattern_paths (type k) { Typedtree. pat_desc; pat_extra; _ } = 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}) -> + | Tpat_var (id, {Location. loc; txt}, _uid) -> [mkloc (Path.Pident id) loc, Some (Longident.Lident txt)] - | Tpat_alias (_,id,loc) -> + | Tpat_alias (_,id,loc, _uid) -> [reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)] | _ -> [] in diff --git a/src/ocaml/merlin_specific/tast_helper.ml b/src/ocaml/merlin_specific/tast_helper.ml index 1664fa1586..d9dead492b 100644 --- a/src/ocaml/merlin_specific/tast_helper.ml +++ b/src/ocaml/merlin_specific/tast_helper.ml @@ -8,13 +8,13 @@ module Pat = struct 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 var ?loc uid 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 + let pat_desc = Tpat_var (Ident.create_local str.Asttypes.txt, str, uid) 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 = @@ -25,7 +25,7 @@ module Pat = struct 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) + 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 } From f1e2ceb7e3ef691889620a29c634e71317942697 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 5 Feb 2024 18:51:54 +0100 Subject: [PATCH 063/130] upgrade: support for hidden dependencies --- src/dot-merlin/dot_merlin_reader.ml | 5 ++++- src/dot-protocol/merlin_dot_protocol.ml | 4 +++- src/dot-protocol/merlin_dot_protocol.mli | 2 +- src/kernel/mconfig.ml | 15 +++++++++++++++ src/kernel/mconfig.mli | 6 +++++- src/kernel/mconfig_dot.ml | 4 ++++ src/kernel/mconfig_dot.mli | 1 + src/kernel/mocaml.ml | 4 +++- src/kernel/mtyper.ml | 4 ++-- 9 files changed, 38 insertions(+), 7 deletions(-) diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index e3a1aaba00..e768d6cacb 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -72,6 +72,8 @@ module Cache = File_cache.Make (struct else if String.is_prefixed ~by:"B " line then tell (`B (String.drop 2 line)) + else if String.is_prefixed ~by:"H " line then + tell (`S (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 @@ -324,7 +326,7 @@ let empty_config = { let prepend_config ~cwd ~cfg = List.fold_left ~init:cfg ~f:(fun cfg (d : Merlin_dot_protocol.Directive.Raw.t) -> match d with - | `B _ | `S _ | `CMI _ | `CMT _ as directive -> + | `B _ | `H _ | `S _ | `CMI _ | `CMT _ as directive -> { cfg with to_canonicalize = (cwd, directive) :: cfg.to_canonicalize } | `EXT _ | `SUFFIX _ | `FLG _ | `READER _ | (`EXCLUDE_QUERY_DIR | `USE_PPX_CACHE | `UNKNOWN_TAG _) as directive -> @@ -452,6 +454,7 @@ let postprocess cfg = let dirs = match directive with | `B path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `B p) + | `H path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `H 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) diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index 97648d9317..ba7ea25d0c 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -31,7 +31,7 @@ open Merlin_utils.Std.Result module Directive = struct type include_path = - [ `B of string | `S of string | `CMI of string | `CMT of string ] + [ `B of string | `H of string | `S of string | `CMI of string | `CMT of string ] type no_processing_required = [ `EXT of string list @@ -82,6 +82,7 @@ module Sexp = struct begin match tag with | "S" -> `S value | "B" -> `B value + | "H" -> `H value | "CMI" -> `CMI value | "CMT" -> `CMT value | "STDLIB" -> `STDLIB value @@ -111,6 +112,7 @@ module Sexp = struct let single s = [ Atom s ] in match t with | `B s -> ("B", single s) + | `H s -> ("H", single s) | `S s -> ("S", single s) | `CMI s -> ("CMI", single s) | `CMT s -> ("CMT", single s) diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index c238b813ae..2acff7bbf3 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -43,7 +43,7 @@ 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 ] + [ `B of string | `H of string| `S of string | `CMI of string | `CMT of string ] type no_processing_required = [ `EXT of string list diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index e79b9c36fb..3728dffcd5 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -6,6 +6,7 @@ let {Logger. log} = Logger.for_section "Mconfig" type ocaml = { include_dirs : string list; + hidden_dirs : string list; no_std_include : bool; unsafe : bool; classic : bool; @@ -31,6 +32,7 @@ let dump_warnings st = let dump_ocaml x = `Assoc [ "include_dirs" , `List (List.map ~f:Json.string x.include_dirs); + "hidden_dirs" , `List (List.map ~f:Json.string x.hidden_dirs); "no_std_include" , `Bool x.no_std_include; "unsafe" , `Bool x.unsafe; "classic" , `Bool x.classic; @@ -69,6 +71,7 @@ let marg_commandline f = type merlin = { build_path : string list; + hidden_path : string list; source_path : string list; cmi_path : string list; cmt_path : string list; @@ -456,6 +459,13 @@ let ocaml_flags = [ {ocaml with include_dirs = dir :: ocaml.include_dirs}), " Add to the list of include directories" ); + ( + "-H", + marg_path (fun dir ocaml -> + {ocaml with hidden_dirs = dir :: ocaml.hidden_dirs}), + " Add to the list of \"hidden\" include directories\n\ + \ (Like -I, but the program can not directly reference these dependencies)" + ); ( "-nostdlib", Marg.unit (fun ocaml -> {ocaml with no_std_include = true}), @@ -588,6 +598,7 @@ let ocaml_flags = [ let initial = { ocaml = { include_dirs = []; + hidden_dirs = []; no_std_include = false; unsafe = false; classic = false; @@ -606,6 +617,7 @@ let initial = { }; merlin = { build_path = []; + hidden_path = []; source_path = []; cmi_path = []; cmt_path = []; @@ -752,6 +764,9 @@ let build_path config = ( result' ) +let hidden_path config = + config.merlin.hidden_path @ config.ocaml.hidden_dirs + let cmt_path config = ( let dirs = match config.ocaml.threads with diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index e018a9418f..2aa395b7a4 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -4,6 +4,7 @@ open Std type ocaml = { include_dirs : string list; + hidden_dirs : string list; no_std_include : bool; unsafe : bool; classic : bool; @@ -28,6 +29,7 @@ val dump_ocaml : ocaml -> json type merlin = { build_path : string list; + hidden_path : string list; source_path : string list; cmi_path : string list; cmt_path : string list; @@ -56,7 +58,7 @@ val dump_merlin : merlin -> json (** {1 Some flags affecting queries} *) -module Verbosity : sig +module Verbosity : sig type t = Smart | Lvl of int (** the default value for verbosity, i.e., [Lvl 0] *) @@ -113,6 +115,8 @@ val source_path : t -> string list val build_path : t -> string list +val hidden_path : t -> string list + val cmt_path : t -> string list val global_modules : ?include_current:bool -> t -> string list diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index 13ad8eba99..a4d7ff1a9c 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -34,6 +34,7 @@ type directive = Merlin_dot_protocol.directive type config = { build_path : string list; + hidden_path : string list; source_path : string list; cmi_path : string list; cmt_path : string list; @@ -48,6 +49,7 @@ type config = { let empty_config = { build_path = []; + hidden_path = []; source_path = []; cmi_path = []; cmt_path = []; @@ -234,6 +236,7 @@ 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 + | `H path -> {config with hidden_path = path :: config.hidden_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 @@ -267,6 +270,7 @@ let postprocess_config config = let clean list = List.rev (List.filter_dup list) in { build_path = clean config.build_path; + hidden_path = clean config.hidden_path; source_path = clean config.source_path; cmi_path = clean config.cmi_path; cmt_path = clean config.cmt_path; diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli index 926fb928a8..8e10e2e648 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -36,6 +36,7 @@ end type config = { build_path : string list; + hidden_path : string list; source_path : string list; cmi_path : string list; cmt_path : string list; diff --git a/src/kernel/mocaml.ml b/src/kernel/mocaml.ml index de572d76f1..833db64fe8 100644 --- a/src/kernel/mocaml.ml +++ b/src/kernel/mocaml.ml @@ -46,7 +46,9 @@ let setup_reader_config config = ( let setup_typer_config config = ( setup_reader_config config; - Load_path.(init ~auto_include:no_auto_include (Mconfig.build_path config)); + let visible = Mconfig.build_path config in + let hidden = Mconfig.hidden_path config in + Load_path.(init ~auto_include:no_auto_include ~visible ~hidden); ) (** Switchable implementation of Oprint *) diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index 703c776b80..bae1e7a257 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -155,11 +155,11 @@ 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 + let { Load_path.visible; hidden } = Load_path.get_paths () in Mocaml.flush_caches (); Local_store.reset (); Load_path.reset (); - Load_path.(init ~auto_include:no_auto_include load_path); + Load_path.(init ~auto_include:no_auto_include ~visible ~hidden); ); let caught = ref [] in Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () -> From 80f29ff907b79ceaeacd31788962fa720066ad85 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 7 Feb 2024 14:01:15 +0100 Subject: [PATCH 064/130] Use new iterator to perform locate and occurrences - enable or disable aliases traversal - mark approximated results as such - improve constr / labels cases + traverse aliases - refactor locate and env_lookup --- src/analysis/ast_iterators.ml | 51 +++ src/analysis/completion.ml | 4 +- src/analysis/completion.mli | 2 +- src/analysis/env_lookup.ml | 158 ++++++++++ src/analysis/env_lookup.mli | 38 +++ src/analysis/index_format.ml | 107 +++++++ src/analysis/locate.ml | 529 +++++++++++++------------------- src/analysis/locate.mli | 48 ++- src/analysis/misc_utils.ml | 28 +- src/analysis/misc_utils.mli | 3 + src/analysis/namespace.ml | 34 -- src/analysis/namespace.mli | 15 - src/analysis/occurrences.ml | 243 +++++++++++++++ src/frontend/query_commands.ml | 104 +++---- src/ocaml/typing/cmt_format.mli | 12 + src/ocaml/typing/typecore.ml | 8 +- src/utils/std.ml | 4 +- 17 files changed, 927 insertions(+), 461 deletions(-) create mode 100644 src/analysis/ast_iterators.ml create mode 100644 src/analysis/env_lookup.ml create mode 100644 src/analysis/env_lookup.mli create mode 100644 src/analysis/index_format.ml delete mode 100644 src/analysis/namespace.ml delete mode 100644 src/analysis/namespace.mli create mode 100644 src/analysis/occurrences.ml diff --git a/src/analysis/ast_iterators.ml b/src/analysis/ast_iterators.ml new file mode 100644 index 0000000000..4ad155c1e8 --- /dev/null +++ b/src/analysis/ast_iterators.ml @@ -0,0 +1,51 @@ +open Std +open Typedtree + +let {Logger. log} = Logger.for_section "iterators" + +(* The compiler contains an iterator that aims to gather definitions but +ignores local values like let-in expressions and local type definition. To +provide occurrences in the active buffer we extend the compiler's iterator with +these cases. *) +let iter_on_defs ~uid_to_locs_tbl = + let log = log ~title:"iter_on_defs" in + let register_uid uid fragment = + let loc = Misc_utils.loc_of_decl ~uid fragment in + Option.iter loc ~f:(fun loc -> + Types.Uid.Tbl.add uid_to_locs_tbl uid loc) + in + let iter_decl = Cmt_format.iter_on_declarations ~f:register_uid in + let register_uid uid loc = + Types.Uid.Tbl.add uid_to_locs_tbl uid loc + in + { iter_decl with + expr = (fun sub ({ exp_extra; exp_env; _ } as expr) -> + List.iter exp_extra ~f:(fun (exp_extra, _loc, _attr) -> + match exp_extra with + | Texp_newtype' (typ_id, typ_name) -> + log "Found definition %s (%a)\n%!" typ_name.txt + Logger.fmt (fun fmt -> Location.print_loc fmt typ_name.loc); + let decl = Env.find_type (Path.Pident typ_id) exp_env in + register_uid decl.type_uid typ_name; + () + | _ -> ()); + iter_decl.expr sub expr); + } + +let build_uid_to_locs_tbl ~(local_defs : Mtyper.typedtree) () = + let uid_to_locs_tbl : string Location.loc Types.Uid.Tbl.t = + Types.Uid.Tbl.create 64 + in + let iter = iter_on_defs ~uid_to_locs_tbl in + begin match local_defs with + | `Interface sign -> + iter.signature iter sign + | `Implementation str -> + iter.structure iter str end; + uid_to_locs_tbl + +let iter_on_usages ~f (local_defs : Mtyper.typedtree) = + let iter = Cmt_format.iter_on_occurrences ~f in + begin match local_defs with + | `Interface signature -> iter.signature iter signature + | `Implementation structure -> iter.structure iter structure end diff --git a/src/analysis/completion.ml b/src/analysis/completion.ml index 5a9451d2bd..f3d66c6831 100644 --- a/src/analysis/completion.ml +++ b/src/analysis/completion.ml @@ -219,8 +219,8 @@ let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty = | Some p, Some loc -> let namespace = (* FIXME: that's just terrible *) match kind with - | `Value -> `Vals - | `Type -> `Type + | `Value -> Shape.Sig_component_kind.Value + | `Type -> Type | _ -> assert false in begin match get_doc (`Completion_entry (namespace, p, loc)) with diff --git a/src/analysis/completion.mli b/src/analysis/completion.mli index 74e68e6971..7d379295d3 100644 --- a/src/analysis/completion.mli +++ b/src/analysis/completion.mli @@ -52,7 +52,7 @@ val map_entry : ('a -> 'b) -> val branch_complete : Mconfig.t - -> ?get_doc:([> `Completion_entry of Namespace.t + -> ?get_doc:([> `Completion_entry of Env_lookup.Namespace.t * Path.t * Location.t ] -> [> `Found of string ]) -> ?target_type:Types.type_expr -> ?kinds:Compl.kind list diff --git a/src/analysis/env_lookup.ml b/src/analysis/env_lookup.ml new file mode 100644 index 0000000000..fa64a807fc --- /dev/null +++ b/src/analysis/env_lookup.ml @@ -0,0 +1,158 @@ +open! Std +let {Logger. log} = Logger.for_section "env-lookup" + +module Namespace = struct + type t = Shape.Sig_component_kind.t + + let to_string = Shape.Sig_component_kind.to_string + + type under_type = [ `Constr | `Labels ] + + type inferred_basic = (* TODO: share with [Namespace.t] *) + [ `Type | `Mod | `Modtype | `Vals | under_type ] + + type inferred = + [ inferred_basic + | `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 + +type item = { + uid: Shape.Uid.t; + loc: Location.t; + namespace: Shape.Sig_component_kind.t +} + +let loc path (namespace : Namespace.t) env = + try + let loc, uid, (namespace : Namespace.t) = + match namespace with + | Value -> + let vd = Env.find_value path env in + vd.val_loc, vd.val_uid, Value + | (Type | Extension_constructor | Constructor | Label) -> + let td = Env.find_type path env in + td.type_loc, td.type_uid, Type + | Module -> + let md = Env.find_module path env in + md.md_loc, md.md_uid, Module + | Module_type -> + let mtd = Env.find_modtype path env in + mtd.mtd_loc, mtd.mtd_uid, Module_type + | Class -> + let cty = Env.find_class path env in + cty.cty_loc, cty.cty_uid, Class + | Class_type -> + let clty = Env.find_cltype path env in + clty.clty_loc, clty.clty_uid, Class + + in + Some { uid; loc; namespace } + with + Not_found -> None + +exception Found of + (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t) + +let path_and_loc_of_cstr desc _ = + let open Types in + match desc.cstr_tag with + | Cstr_extension (path, _) -> path, desc.cstr_loc + | _ -> + match get_desc desc.cstr_res with + | Tconstr (path, _, _) -> path, desc.cstr_loc + | _ -> assert false + +let path_and_loc_from_label desc env = + let open Types in + match get_desc desc.lbl_res with + | Tconstr (path, _, _) -> + let typ_decl = Env.find_type path env in + path, typ_decl.Types.type_loc + | _ -> assert false + +let in_namespaces (nss : Namespace.inferred list) ident env = + let open Shape.Sig_component_kind in + try + List.iter nss ~f:(fun namespace -> + try + match namespace with + | `This_cstr ({ Types.cstr_tag = Cstr_extension _; _ } as cd) -> + log ~title:"lookup" + "got extension constructor"; + let path, loc = path_and_loc_of_cstr cd env in + (* TODO: Use [`Constr] here instead of [`Type] *) + raise (Found (path, Extension_constructor, cd.cstr_uid, loc)) + | `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 + log ~title:"lookup" "found path: %a" + Logger.fmt (fun fmt -> Path.print fmt path); + let path = Path.Pdot (path, cd.cstr_name) + in + raise (Found (path, Constructor, cd.cstr_uid, 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 + let path = Path.Pdot (path, cd.cstr_name) in + (* TODO: Use [`Constr] here instead of [`Type] *) + raise (Found (path, Constructor,cd.cstr_uid, loc)) + | `Mod -> + log ~title:"lookup" "lookup in module namespace" ; + let path, md = Env.find_module_by_name ident env in + raise (Found (path, Module, md.md_uid, md.Types.md_loc)) + | `Modtype -> + let path, mtd = Env.find_modtype_by_name ident env in + raise + (Found (path, Module_type, mtd.mtd_uid, 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, Type, typ_decl.type_uid, 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, Value, val_desc.val_uid, 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 + let path = Path.Pdot (path, lbl.lbl_name) + in + raise (Found (path, Label, lbl.lbl_uid, 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, Type, lbl.lbl_uid, loc)) + with Not_found -> () + ) ; + log ~title:"lookup" " ... not in the environment" ; + None + with Found (path, namespace, decl_uid, loc) -> + log ~title:"env_lookup" "found: '%a' in namespace %s with decl_uid %a\nat loc %a" + Logger.fmt (fun fmt -> Path.print fmt path) + (Shape.Sig_component_kind.to_string namespace) + Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid) + Logger.fmt (fun fmt -> Location.print_loc fmt loc); + Some (path, { uid = decl_uid; loc; namespace }) diff --git a/src/analysis/env_lookup.mli b/src/analysis/env_lookup.mli new file mode 100644 index 0000000000..41e070fa0f --- /dev/null +++ b/src/analysis/env_lookup.mli @@ -0,0 +1,38 @@ +module Namespace : sig + type t = Shape.Sig_component_kind.t + + val to_string : t -> string + + type under_type = [ `Constr | `Labels ] + type inferred_basic = + [ `Constr | `Labels | `Mod | `Modtype | `Type | `Vals ] + type inferred = + [ `Constr + | `Labels + | `Mod + | `Modtype + | `This_cstr of Types.constructor_description + | `This_label of Types.label_description + | `Type + | `Vals ] + + val from_context : Context.t -> inferred list + end + + type item = { + uid: Shape.Uid.t; + loc: Location.t; + namespace: Namespace.t + } + + val loc + : Path.t + -> Namespace.t + -> Env.t + -> item option + + val in_namespaces + : Namespace.inferred list + -> Longident.t + -> Env.t + -> (Path.t * item) option diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml new file mode 100644 index 0000000000..45502fa4ff --- /dev/null +++ b/src/analysis/index_format.ml @@ -0,0 +1,107 @@ +module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct + type t = Longident.t Location.loc + + let compare_pos (p1 : Lexing.position) (p2 : Lexing.position) = + match String.compare p1.pos_fname p2.pos_fname with + | 0 -> Int.compare p1.pos_cnum p2.pos_cnum + | n -> n + + let compare (t1 : t) (t2 : t) = + (* TODO CHECK...*) + match compare_pos t1.loc.loc_start t2.loc.loc_start with + | 0 -> compare_pos t1.loc.loc_end t2.loc.loc_end + | n -> n +end + +module LidSet = Set.Make (Lid) + +(** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this key is + already present the locations are merged. *) +let add tbl uid locs = + try + let locations = Hashtbl.find tbl uid in + Hashtbl.replace tbl uid (LidSet.union locs locations) + with Not_found -> Hashtbl.add tbl uid locs + +type payload = { + defs : (Shape.Uid.t, LidSet.t) Hashtbl.t; + partials : (Shape.t, LidSet.t) Hashtbl.t; + unreduced : (Shape.t * Longident.t Location.loc) list; + load_path : string list; + cu_shape : (string, Shape.t) Hashtbl.t; +} + +type file_format = V1 of payload + +let pp_partials (fmt : Format.formatter) + (partials : (Shape.t, LidSet.t) Hashtbl.t) = + Format.fprintf fmt "{@["; + Hashtbl.iter + (fun shape locs -> + Format.fprintf fmt "@[shape: %a; locs:@ @[%a@]@]@;" Shape.print + shape + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") + (fun fmt { Location.txt; loc } -> + Format.fprintf fmt "%S: %a" + (try Longident.flatten txt |> String.concat "." with _ -> "") + Location.print_loc loc)) + (LidSet.elements locs)) + partials; + Format.fprintf fmt "@]}" + +let pp_unreduced (fmt : Format.formatter) + (unreduced : (Shape.t * Longident.t Location.loc) list) = + Format.fprintf fmt "{@["; + List.iter + (fun (shape, { Location.txt; loc }) -> + Format.fprintf fmt "@[shape: %a; locs:@ @[%s: %a@]@]@;" + Shape.print shape + (try Longident.flatten txt |> String.concat "." with _ -> "") + Location.print_loc loc) + unreduced; + Format.fprintf fmt "@]}" + +let pp_payload (fmt : Format.formatter) pl = + Format.fprintf fmt "%i uids:@ {@[" (Hashtbl.length pl.defs); + Hashtbl.iter + (fun uid locs -> + Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" + Shape.Uid.print uid + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") + (fun fmt { Location.txt; loc } -> + Format.fprintf fmt "%S: %a" + (try Longident.flatten txt |> String.concat "." with _ -> "") + Location.print_loc loc)) + (LidSet.elements locs)) + pl.defs; + Format.fprintf fmt "@]},@ "; + Format.fprintf fmt "%i partial shapes:@ @[%a@],@ " + (Hashtbl.length pl.partials) + pp_partials pl.partials; + Format.fprintf fmt "%i unreduced shapes:@ @[%a@]@ " (List.length pl.unreduced) + pp_unreduced pl.unreduced; + Format.fprintf fmt "and shapes for CUS %s.@ " + (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq)) + +let pp (fmt : Format.formatter) ff = + match ff with V1 tbl -> Format.fprintf fmt "V1@,%a" pp_payload tbl + +let ext = "uideps" + +let write ~file tbl = + let oc = open_out_bin file in + Marshal.to_channel oc (V1 tbl) []; + close_out oc + +let read ~file = + let ic = open_in_bin file in + try + let payload = + match Marshal.from_channel ic with V1 payload -> payload + (* TODO is that "safe" ? We probably want some magic number *) + in + close_in ic; + payload + with e -> raise e (* todo *) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index 35dc6be2a2..e6a5746911 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -31,6 +31,21 @@ open Std let last_location = ref Location.none let {Logger. log} = Logger.for_section "locate" + +type config = { + mconfig: Mconfig.t; + ml_or_mli: [ `ML | `MLI ]; + traverse_aliases: bool; +} + +type result = { + uid: Shape.Uid.t; + decl_uid: Shape.Uid.t; + file: string; + location: Location.t; + approximated: bool; +} + module File : sig type t = private | ML of string @@ -194,10 +209,6 @@ end module Utils = struct - let is_builtin_path = function - | Path.Pident id -> Ident.is_predef id - | _ -> false - (* 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 @@ -297,13 +308,12 @@ let move_to filename cmt_infos = in File_switching.move_to ~digest filename - -let load_cmt ~config comp_unit ml_or_mli = - Preferences.set ml_or_mli; +let load_cmt ~config ?(with_fallback = true) comp_unit = + Preferences.set config.ml_or_mli; let file = Preferences.build comp_unit in - match Utils.find_file ~config ~with_fallback:true file with + match Utils.find_file ~config:config.mconfig ~with_fallback file with | Some path -> let cmt_infos = (Cmt_cache.read path).cmt_infos in let source_file = cmt_infos.cmt_sourcefile in @@ -339,125 +349,6 @@ let scrape_alias ~env ~fallback_uid ~namespace path = in non_alias_declaration_uid ~fallback_uid path -let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace = - let module Shape_reduce = - Shape_reduce.Make (struct - type env = Env.t - - let fuel = 10 - - let read_unit_shape ~unit_name = - log ~title:"read_unit_shape" "inspecting %s" unit_name; - match load_cmt ~config unit_name `ML with - | Ok (filename, cmt_infos) -> - move_to filename cmt_infos; - log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; - cmt_infos.cmt_impl_shape - | Error () -> - log ~title:"read_unit_shape" "failed to find %s" unit_name; - None - - let find_shape env id = Env.shape_of_path - ~namespace:Shape.Sig_component_kind.Module env (Pident id) - end) - in - let unalias fallback_uid = - let uid = scrape_alias ~fallback_uid ~env ~namespace path in - log ~title:"uid_of_path" "Unaliasing uid: %a -> %a" - Logger.fmt (fun fmt -> Shape.Uid.print fmt fallback_uid) - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - uid - in - match ml_or_mli with - | `MLI -> unalias decl_uid - | `ML -> - let shape = Env.shape_of_path ~namespace env path in - log ~title:"shape_of_path" "initial: %a" - Logger.fmt (fun fmt -> Shape.print fmt shape); - let r = Shape_reduce.weak_reduce env shape in - log ~title:"shape_of_path" "reduced: %a" - Logger.fmt (fun fmt -> Shape.print fmt r); - match r.uid with - | Some uid -> uid - | None -> - log ~title:"shape_of_path" "No uid found; fallbacking to declaration uid"; - unalias decl_uid - -let from_uid ~config ~ml_or_mli uid loc path = - let loc_of_comp_unit comp_unit = - match load_cmt ~config comp_unit ml_or_mli with - | Ok (pos_fname, _cmt) -> - let pos = Std.Lexing.make_pos ~pos_fname (1, 0) in - let loc = { Location.loc_start=pos; loc_end=pos; loc_ghost=true } in - Some loc - | _ -> None - in - let title = "from_uid" in - match uid with - | Shape.Uid.Item { comp_unit; _ } -> - let locopt = - let log_and_return msg = log ~title msg; None in - let uid_to_loc_tbl = - if Env.get_unit_name () = comp_unit then begin - log ~title "We look for %a in the current compilation unit." - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - Some (Env.get_uid_to_loc_tbl ()) - end else begin - log ~title "Loading the cmt for unit %S" comp_unit; - match load_cmt ~config comp_unit ml_or_mli with - | Ok (_pos_fname, cmt) -> Some cmt.cmt_uid_to_loc - | Error () -> log_and_return "Failed to load the cmt file." - end - in - Option.bind uid_to_loc_tbl ~f:(fun tbl -> - log ~title "Looking for %a in the uid_to_loc table" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - match Shape.Uid.Tbl.find_opt tbl uid with - | Some loc -> - log ~title "Found location: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - Some (uid, loc) - | None -> log_and_return "Uid not found in the table.") - in - begin match locopt with - | Some (uid, loc) -> `Found (Some uid, loc) - | None -> - log ~title "Fallbacking to lookup location: %a" - Logger.fmt (fun fmt -> Location.print_loc fmt loc); - `Found (Some uid, loc) - end - | Compilation_unit comp_unit -> - begin - log ~title "Got the uid of a compilation unit: %a" - Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); - match loc_of_comp_unit comp_unit with - | Some loc -> `Found (Some uid, loc) - | _ -> log ~title "Failed to load the CU's cmt"; - `Not_found (Path.name path, None) - end - | Predef _ | Internal -> assert false - -let locate ~config ~env ~ml_or_mli decl_uid loc path ns = - let uid = uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns in - from_uid ~config ~ml_or_mli uid loc path - -let path_and_loc_of_cstr desc _ = - let open Types in - match desc.cstr_tag with - | Cstr_extension (path, _) -> path, desc.cstr_loc - | _ -> - match get_desc desc.cstr_res with - | Tconstr (path, _, _) -> path, desc.cstr_loc - | _ -> assert false - -let path_and_loc_from_label desc env = - let open Types in - match get_desc desc.lbl_res 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 @@ -483,7 +374,7 @@ let find_source ~config loc = in let dir = Filename.dirname initial_path in let dir = - match Mconfig.(config.query.directory) with + match config.Mconfig.query.directory with | "" -> dir | cwd -> Misc.canonicalize_filename ~cwd dir in @@ -492,7 +383,9 @@ let find_source ~config loc = 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 + 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; @@ -585,8 +478,8 @@ let find_source ~config loc path = | _ -> failure | exception _ -> failure in - match result with - | Found src -> `Found (Some src, loc.Location.loc_start) + match (result : find_source_result) with + | Found src -> `Found (src, loc) | Not_found f -> File.explain_not_found path f | Multiple_matches lst -> let matches = String.concat lst ~sep:", " in @@ -595,183 +488,182 @@ let find_source ~config loc path = merlin doesn't know which is the right one: %s" matches) -module Namespace = struct - type all = Namespace.t - - type under_type = [ `Constr | `Labels ] - - type t =(* TODO: share with [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 - -> Namespace.all - -> Env.t - -> (Location.t * Shape.Uid.t * Shape.Sig_component_kind.t) option - - val in_namespaces - : Namespace.inferred list - -> Longident.t - -> Env.t - -> (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t) option - -end = struct - - let loc path (namespace : Namespace.all) env = - try - Some ( - match namespace with - | `Unknown - | `Apply - | `Vals -> - let vd = Env.find_value path env in - vd.val_loc, vd.val_uid, Shape.Sig_component_kind.Value - | `Constr - | `Labels - | `Type -> - let td = Env.find_type path env in - td.type_loc, td.type_uid, Shape.Sig_component_kind.Type - | `Functor - | `Mod -> - let md = Env.find_module path env in - md.md_loc, md.md_uid, Shape.Sig_component_kind.Module - | `Modtype -> - let mtd = Env.find_modtype path env in - mtd.mtd_loc, mtd.mtd_uid, Shape.Sig_component_kind.Module_type - ) - with - Not_found -> None - - exception Found of - (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t) +(** [find_loc_of_uid] uid's location are given by tables stored int he cmt files + for external compilation units or computed by Merlin for the current buffer. + This function lookups a uid's location in the appropriate table. *) +let find_loc_of_uid ~config ~local_defs uid comp_unit = + let title = "find_loc_of_uid" in + let loc_of_decl ~uid def = + match Misc_utils.loc_of_decl ~uid def with + | Some loc -> + log ~title "Found location: %a" + Logger.fmt (fun fmt -> Location.print_loc fmt loc.loc); + `Some (uid, loc.loc) + | None -> log ~title "The declaration has no location."; `None + in + if Env.get_unit_name () = comp_unit then begin + log ~title "We look for %a in the current compilation unit." + Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); + log ~title "Looking for %a in the uid_to_loc table" + Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); + let tbl = Ast_iterators.build_uid_to_locs_tbl ~local_defs () in + match Shape.Uid.Tbl.find_opt tbl uid with + | Some { Location.loc; _ } -> `Some (uid, loc) + | None -> log ~title "Uid not found in the local table."; `None + end else begin + log ~title "Loading the cmt file for unit %S" comp_unit; + match load_cmt ~config comp_unit with + | Ok (_pos_fname, cmt) -> + log ~title "Shapes successfully loaded, looking for %a" + Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); + begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with + | Some decl -> loc_of_decl ~uid decl + | None -> log ~title "Uid not found in the cmt's table."; `None + end + | _ -> log ~title "Failed to load the cmt file"; `None + end - let in_namespaces (nss : Namespace.inferred list) ident env = - let open Shape.Sig_component_kind in - try - List.iter nss ~f:(fun namespace -> - try - match namespace with - | `This_cstr ({ Types.cstr_tag = Cstr_extension _; _ } as cd) -> - log ~title:"lookup" - "got extension constructor"; - let path, loc = path_and_loc_of_cstr cd env in - (* TODO: Use [`Constr] here instead of [`Type] *) - raise (Found (path, Extension_constructor, cd.cstr_uid, loc)) - | `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, Type, cd.cstr_uid,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, Type,cd.cstr_uid, loc)) - | `Mod -> - log ~title:"lookup" "lookup in module namespace" ; - let path, md = Env.find_module_by_name ident env in - raise (Found (path, Module, md.md_uid, 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, Module_type, mtd.mtd_uid, 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, Type, typ_decl.type_uid, 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, Value, val_desc.val_uid, 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, Type, lbl.lbl_uid, 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, Type, lbl.lbl_uid, loc)) - with Not_found -> () - ) ; - log ~title:"lookup" " ... not in the environment" ; - None - with Found ((path, namespace, decl_uid, _loc) as x) -> - log ~title:"env_lookup" "found: '%a' in namespace %s with uid %a" - Logger.fmt (fun fmt -> Path.print fmt path) - (Shape.Sig_component_kind.to_string namespace) - Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid); - Some x -end +let find_loc_of_comp_unit ~config uid comp_unit = + let title = "find_loc_of_comp_unit" in + log ~title "Got the uid of a compilation unit: %s" comp_unit; + match load_cmt ~config comp_unit with + | Ok (pos_fname, _cmt) -> + let pos = Std.Lexing.make_pos ~pos_fname (1, 0) in + let loc = { Location.loc_start=pos; loc_end=pos; loc_ghost=true } in + `Some (uid, loc) + | _ -> log ~title "Failed to load the CU's cmt"; `None + +let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path = + let namespace = decl.namespace in + let module Reduce = Shape_reduce.Make (struct + let fuel = 10 -let uid_from_longident ~config ~env nss ml_or_mli ident = + let read_unit_shape ~unit_name = + log ~title:"read_unit_shape" "inspecting %s" unit_name; + match + load_cmt ~config:({config with ml_or_mli = `ML}) + ~with_fallback:false unit_name + with + | Ok (filename, cmt_infos) -> + move_to filename cmt_infos; + log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; + cmt_infos.cmt_impl_shape + | Error () -> + log ~title:"read_unit_shape" "failed to find %s" unit_name; + None + end) + in + let shape = Env.shape_of_path ~namespace env path in + log ~title:"shape_of_path" "initial: %a" + Logger.fmt (Fun.flip Shape.print shape); + let _keep_aliases = + if config.traverse_aliases + then (fun _ -> false) + else (function + | Shape. { uid = Some (Item { comp_unit; _ }); + desc = Alias { desc = Comp_unit alias_cu; _ }; + _ } + when let by = comp_unit ^ "__" in + Merlin_utils.Std.String.is_prefixed ~by alias_cu -> + false + | _ -> true) + in + let reduced = Reduce.reduce_for_uid env shape + in + log ~title:"shape_of_path" "reduced: %a" + Logger.fmt (fun fmt -> Shape_reduce.print_result fmt reduced); + reduced + +let rec uid_of_aliases ~traverse_aliases = function + | [] -> assert false + | [ def ] -> def + | (Shape.Uid.Item { comp_unit; _ }) + :: (((Compilation_unit comp_unit') :: _) as tl) + when let by = comp_unit ^ "__" in String.is_prefixed ~by comp_unit' -> + (* Always traverse dune-wrapper aliases *) + uid_of_aliases ~traverse_aliases tl + | [ alias; def ] -> if traverse_aliases then def else alias + | _alias :: tl when traverse_aliases -> uid_of_aliases ~traverse_aliases tl + | alias :: _tl -> alias + +(** This is the main function here *) +let from_path ~config ~env ~local_defs ~decl path = + let title = "from_path" in + let unalias (decl : Env_lookup.item) = + if not config.traverse_aliases then decl.uid else + let namespace = decl.namespace in + let uid = scrape_alias ~fallback_uid:decl.uid ~env ~namespace path in + if uid <> decl.uid then + log ~title:"uid_of_path" "Unaliased declaration uid: %a -> %a" + Logger.fmt (Fun.flip Shape.Uid.print decl.uid) + Logger.fmt (Fun.flip Shape.Uid.print uid); + uid + in + (* Step 1: Path => Uid *) + let decl : Env_lookup.item = { decl with uid = (unalias decl) } in + let uid, approximated = match config.ml_or_mli with + | `MLI -> decl.uid, false + | `ML -> + let traverse_aliases = config.traverse_aliases in + match find_definition_uid ~config ~env ~decl path with + | Resolved uid -> uid, false + | Resolved_alias aliases -> uid_of_aliases ~traverse_aliases aliases, false + | Unresolved { uid = Some uid; desc = Comp_unit _; approximated } -> + uid, approximated + | Approximated _ | Unresolved _ | Internal_error_missing_uid -> + log ~title "No definition uid, falling back to the declaration uid: %a" + Logger.fmt (Fun.flip Shape.Uid.print decl.uid); + decl.uid, true + in + (* Step 2: Uid => Location *) + let loc = match uid with + | Predef s -> `Builtin (uid, s) + | Internal -> `Builtin (uid, "") + | Item {comp_unit; _} -> find_loc_of_uid ~config ~local_defs uid comp_unit + | Compilation_unit comp_unit -> find_loc_of_comp_unit ~config uid comp_unit + in + let loc = match loc with + | `None -> + log ~title "Falling back to the declaration's location: %a" + Logger.fmt (Fun.flip Location.print_loc decl.loc); + `Some (decl.uid, decl.loc) + | other -> other + in + (* Step 3: Location => Source *) + match loc with + | `None -> assert false + | `Builtin _ as err -> err + | `Some (uid, loc) -> + match find_source ~config:config.mconfig loc (Path.name path) with + | `Found (file, location) -> + log ~title:"find_source" "Found file: %s (%a)" file + Logger.fmt (Fun.flip Location.print_loc location); + `Found { + uid; + decl_uid = decl.uid; + file; location; approximated } + | `File_not_found _ as otherwise -> otherwise + +let from_longident ~config ~env ~local_defs nss ident = let str_ident = try String.concat ~sep:"." (Longident.flatten ident) with _-> "Not a flat longident" in match Env_lookup.in_namespaces nss ident env with | None -> `Not_in_env str_ident - | Some (path, namespace, decl_uid, loc) -> - if Utils.is_builtin_path path then - `Builtin - else - let uid = uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace in - `Uid (uid, loc, path) + | Some (path, decl) -> from_path ~config ~env ~local_defs ~decl path -let from_longident ~config ~env nss ml_or_mli ident = - match uid_from_longident ~config ~env nss ml_or_mli ident with - | `Uid (uid, loc, path) -> from_uid ~config ~ml_or_mli uid loc path - | (`Builtin | `Not_in_env _) as v -> v - -let from_path ~config ~env ~namespace ml_or_mli path = +let from_path ~config ~env ~local_defs ~namespace path = File_switching.reset (); - if Utils.is_builtin_path path then - `Builtin - else - match Env_lookup.loc path namespace env with - | None -> `Not_in_env (Path.name path) - | Some (loc, uid, namespace) -> - match locate ~config ~env ~ml_or_mli uid loc path namespace with - | `Not_found _ - | `File_not_found _ as err -> err - | `Found (uid, loc) -> - match find_source ~config loc (Path.name path) with - | `Found (file, loc) -> `Found (uid, file, loc) - | `File_not_found _ as otherwise -> otherwise + match Env_lookup.loc path namespace env with + | None -> `Not_in_env (Path.name path) + | Some decl -> from_path ~config ~env ~local_defs ~decl path let infer_namespace ?namespaces ~pos lid browse is_label = match namespaces with | Some nss -> if not is_label - then `Ok (nss :> Namespace.inferred list) + then `Ok (nss :> Env_lookup.Namespace.inferred list) else if List.mem `Labels ~set:nss then ( log ~title:"from_string" "restricting namespaces to labels"; `Ok [ `Labels ] @@ -789,13 +681,13 @@ let infer_namespace ?namespaces ~pos lid browse is_label = | Some ctxt, false -> log ~title:"from_string" "inferred context: %s" (Context.to_string ctxt); - `Ok (Namespace.from_context ctxt) + `Ok (Env_lookup.Namespace.from_context ctxt) | _, true -> log ~title:"from_string" "dropping inferred context, it is not precise enough"; `Ok [ `Labels ] -let from_string ~config ~env ~local_defs ~pos ?namespaces switch path = +let from_string ~config ~env ~local_defs ~pos ?namespaces path = File_switching.reset (); let browse = Mbrowse.of_typedtree local_defs in let lid = Type_utils.parse_longident path in @@ -806,14 +698,8 @@ let from_string ~config ~env ~local_defs ~pos ?namespaces switch path = | `Ok nss -> log ~title:"from_string" "looking for the source of '%s' (prioritizing %s files)" - path (match switch with `ML -> ".ml" | `MLI -> ".mli"); - match from_longident ~config ~env nss switch ident with - | `File_not_found _ | `Not_found _ | `Not_in_env _ as err -> err - | `Builtin -> `Builtin path - | `Found (uid, loc) -> - match find_source ~config loc path with - | `Found (file, loc) -> `Found (uid, file, loc) - | `File_not_found _ as otherwise -> otherwise + path (match config.ml_or_mli with `ML -> ".ml" | `MLI -> ".mli"); + from_longident ~config ~env ~local_defs nss ident in Option.value_map ~f:from_lid ~default:(`Not_found (path, None)) lid @@ -866,8 +752,8 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid = let rec aux pat = let open Typedtree in match pat.pat_desc with - | Tpat_var (id, _) -> f id - | Tpat_alias (pat, _, _) + | Tpat_var (id, _, _) -> f id + | Tpat_alias (pat, _, _, _) | Tpat_variant (_, Some pat, _) | Tpat_lazy pat | Tpat_or (pat, _, _) -> @@ -892,7 +778,7 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid = in let typedtree = log ~title:"doc_from_uid" "Loading the cmt for unit %S" comp_unit; - match load_cmt ~config comp_unit `MLI with + match load_cmt ~config:({config with ml_or_mli = `MLI}) comp_unit with | Ok (_, cmt_infos) -> log ~title:"doc_from_uid" "Cmt loaded, itering on the typedtree"; begin match cmt_infos.cmt_annots with @@ -934,8 +820,8 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid = let doc_from_uid ~config ~loc uid = begin match uid with - | Some (Shape.Uid.Item { comp_unit; _ } as uid) - | Some (Shape.Uid.Compilation_unit comp_unit as uid) + | Shape.Uid.Item { comp_unit; _ } + | Shape.Uid.Compilation_unit comp_unit when Env.get_unit_name () <> comp_unit -> log ~title:"get_doc" "the doc (%a) you're looking for is in another compilation unit (%s)" @@ -991,38 +877,35 @@ let doc_from_comment_list ~local_defs ~buffer_comments loc = | None, _ -> `No_documentation | Some doc, _ -> `Found doc -let get_doc ~config ~env ~local_defs ~comments ~pos = +let get_doc ~config:mconfig ~env ~local_defs ~comments ~pos = File_switching.reset (); fun path -> let_ref last_location Location.none @@ fun () -> + let config = { mconfig; ml_or_mli = `MLI; traverse_aliases = true; } in let doc_from_uid_result = match path with | `Completion_entry (namespace, path, _loc) -> log ~title:"get_doc" "completion: looking for the doc of '%a'" Logger.fmt (fun fmt -> Path.print fmt path) ; - let from_path = from_path ~config ~env ~namespace `MLI path in + + let from_path = + from_path ~config ~env ~local_defs ~namespace path + in begin match from_path with - | `Found (uid, _, pos) -> - let loc : Location.t = - { loc_start = pos; loc_end = pos; loc_ghost = true } - in + | `Found { uid; location = loc; _ } -> doc_from_uid ~config ~loc uid - | (`Builtin |`Not_in_env _|`File_not_found _|`Not_found _) + | (`Builtin _ |`Not_in_env _|`File_not_found _|`Not_found _) as otherwise -> otherwise end | `User_input path -> log ~title:"get_doc" "looking for the doc of '%s'" path; - begin match from_string ~config ~env ~local_defs ~pos `MLI path with - | `Found (uid, _, pos) -> - let loc : Location.t = - { loc_start = pos; loc_end = pos; loc_ghost = true } - in + begin match from_string ~config ~env ~local_defs ~pos path with + | `Found { uid; location = loc; _ } -> doc_from_uid ~config ~loc uid | `At_origin -> `Found_loc { Location.loc_start = pos; loc_end = pos; loc_ghost = true } | `Missing_labels_namespace -> `No_documentation - | `Builtin _ -> `Builtin - | (`Not_in_env _ | `Not_found _ |`File_not_found _ ) + | (`Builtin _ | `Not_in_env _ | `Not_found _ |`File_not_found _ ) as otherwise -> otherwise end in @@ -1030,7 +913,7 @@ let get_doc ~config ~env ~local_defs ~comments ~pos = | `Found_doc doc -> `Found doc | `Found_loc loc -> doc_from_comment_list ~local_defs ~buffer_comments:comments loc - | `Builtin -> + | `Builtin _ -> begin match path with | `User_input path -> `Builtin path | `Completion_entry (_, path, _) -> `Builtin (Path.name path) diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli index b4a6145bec..2fb5b8f3ec 100644 --- a/src/analysis/locate.mli +++ b/src/analysis/locate.mli @@ -28,34 +28,51 @@ val log : 'a Logger.printf -module Namespace : sig - type all = Namespace.t - type t = [ `Type | `Mod | `Modtype | `Vals | `Constr | `Labels ] -end +type config = { + mconfig: Mconfig.t; + ml_or_mli: [ `ML | `MLI ]; + traverse_aliases: bool; +} + +type result = { + uid: Shape.Uid.t; + decl_uid: Shape.Uid.t; + file: string; + location: Location.t; + approximated: bool; +} + +val uid_of_aliases : traverse_aliases:bool -> Shape.Uid.t list -> Shape.Uid.t + +val find_source + : config: Mconfig.t + -> Warnings.loc + -> string + -> [> `File_not_found of string + | `Found of string * Location.t ] val from_path - : config:Mconfig.t + : config:config -> env:Env.t - -> namespace:Namespace.all - -> [ `ML | `MLI ] + -> local_defs:Mtyper.typedtree + -> namespace:Env_lookup.Namespace.t -> Path.t -> [> `File_not_found of string - | `Found of Shape.Uid.t option * string option * Lexing.position - | `Builtin + | `Found of result + | `Builtin of Shape.Uid.t * string | `Not_in_env of string | `Not_found of string * string option ] val from_string - : config:Mconfig.t + : config:config -> env:Env.t -> local_defs:Mtyper.typedtree -> pos:Lexing.position - -> ?namespaces:Namespace.t list - -> [ `ML | `MLI ] + -> ?namespaces:Env_lookup.Namespace.inferred_basic list -> string -> [> `File_not_found of string - | `Found of Shape.Uid.t option * string option * Lexing.position - | `Builtin of string + | `Found of result + | `Builtin of Shape.Uid.t * string | `Missing_labels_namespace | `Not_found of string * string option | `Not_in_env of string @@ -68,8 +85,7 @@ val get_doc -> comments:(string * Location.t) list -> pos:Lexing.position -> [ `User_input of string - | `Completion_entry of - Namespace.all * Path.t * Location.t ] + | `Completion_entry of Env_lookup.Namespace.t * Path.t * Location.t ] -> [> `File_not_found of string | `Found of string | `Builtin of string diff --git a/src/analysis/misc_utils.ml b/src/analysis/misc_utils.ml index 5312a2b16d..3e26dd7fd6 100644 --- a/src/analysis/misc_utils.ml +++ b/src/analysis/misc_utils.ml @@ -61,10 +61,34 @@ let parenthesize_name name = module Compat = struct open Typedtree let pat_var_id_and_loc = function - | { pat_desc = Tpat_var (id, loc); _ } -> Some (id, loc) + | { pat_desc = Tpat_var (id, loc, _); _ } -> Some (id, loc) | _ -> None let pat_alias_pat_id_and_loc = function - | { pat_desc = Tpat_alias (pat, id, loc); _ } -> Some (pat, id, loc) + | { pat_desc = Tpat_alias (pat, id, loc, _); _ } -> Some (pat, id, loc) | _ -> None end + +let loc_of_decl ~uid = + let of_option name = + match name.Location.txt with + | Some txt -> Some { name with txt } + | None -> None + in + let of_value_binding vb = + let bound_idents = Typedtree.let_bound_idents_full [vb] in + ListLabels.find_map ~f:(fun (_, loc, _, uid') -> if uid = uid' then Some loc else None) bound_idents + in + function + | Typedtree.Value vd -> Some vd.val_name + | Value_binding vb -> of_value_binding vb + | Type td -> Some td.typ_name + | Constructor cd -> Some cd.cd_name + | Extension_constructor ec -> Some ec.ext_name + | Label ld -> Some ld.ld_name + | Module md -> of_option md.md_name + | Module_binding mb -> of_option mb.mb_name + | Module_type mtd -> Some mtd.mtd_name + | Module_substitution msd -> Some msd.ms_name + | Class cd -> Some cd.ci_id_name + | Class_type ctd -> Some ctd.ci_id_name diff --git a/src/analysis/misc_utils.mli b/src/analysis/misc_utils.mli index 27385cb806..4444d618bf 100644 --- a/src/analysis/misc_utils.mli +++ b/src/analysis/misc_utils.mli @@ -31,3 +31,6 @@ module Compat : sig : Typedtree.pattern -> (Typedtree.pattern * Ident.t * string Location.loc) option end + +(** Extracts the loc from cmt's cmt_uid_to_decl tables *) +val loc_of_decl : uid:Shape.Uid.t -> Typedtree.item_declaration -> string Location.loc option diff --git a/src/analysis/namespace.ml b/src/analysis/namespace.ml deleted file mode 100644 index 6088dfb6da..0000000000 --- a/src/analysis/namespace.ml +++ /dev/null @@ -1,34 +0,0 @@ -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)" - diff --git a/src/analysis/namespace.mli b/src/analysis/namespace.mli deleted file mode 100644 index 28b938c6af..0000000000 --- a/src/analysis/namespace.mli +++ /dev/null @@ -1,15 +0,0 @@ -type t = [ - | `Vals - | `Type - | `Constr - | `Mod - | `Modtype - | `Functor - | `Labels - | `Unknown - | `Apply -] - -val to_tag_string : t -> string - -val to_string : t -> string diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml new file mode 100644 index 0000000000..f622d47999 --- /dev/null +++ b/src/analysis/occurrences.ml @@ -0,0 +1,243 @@ +open Std +module LidSet = Index_format.LidSet + +let {Logger. log} = Logger.for_section "occurrences" + +let set_fname ~file (loc : Location.t) = + let pos_fname = file in + { loc with + loc_start = { loc.loc_start with pos_fname }; + loc_end = { loc.loc_end with pos_fname }} + +let decl_of_path_or_lid env namespace path lid = + match (namespace : Shape.Sig_component_kind.t) with + | Constructor -> + begin match Env.find_constructor_by_name lid env with + | exception Not_found -> None + | {cstr_uid; cstr_loc; _ } -> + Some { Env_lookup.uid = cstr_uid; loc = cstr_loc; namespace } + end + | Label -> + begin match Env.find_label_by_name lid env with + | exception Not_found -> None + | {lbl_uid; lbl_loc; _ } -> + Some { Env_lookup.uid = lbl_uid; loc = lbl_loc; namespace } + end + | _ -> Env_lookup.loc path namespace env + +let index_buffer ~current_buffer_path ~local_defs () = + let {Logger. log} = Logger.for_section "index" in + let defs = Hashtbl.create 64 in + let module Shape_reduce = + Shape_reduce.Make (struct + let fuel = 10 + + let read_unit_shape ~unit_name = + log ~title:"read_unit_shape" "inspecting %s" unit_name; + let cmt = Format.sprintf "%s.cmt" unit_name in + match Cmt_format.read (Load_path.find_normalized cmt) with + | _, Some cmt_infos -> + log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; + cmt_infos.cmt_impl_shape + | exception _ | _ -> + log ~title:"read_unit_shape" "failed to find %s" unit_name; + None + end) + in + let f ~namespace env path (lid : Longident.t Location.loc) = + log ~title:"index_buffer" "Path: %a" Logger.fmt (Fun.flip Path.print path); + let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in + let lid = { lid with loc = set_fname ~file:current_buffer_path lid.loc } in + let index_decl () = + begin match decl_of_path_or_lid env namespace path lid.txt with + | exception _ | None -> log ~title:"index_buffer" "Declaration not found" + | Some decl -> + log ~title:"index_buffer" "Found declaration: %a" + Logger.fmt (Fun.flip Location.print_loc decl.loc); + Index_format.(add defs decl.uid (LidSet.singleton lid)) + end + in + if not_ghost lid then + match Env.shape_of_path ~namespace env path with + | exception Not_found -> () + | path_shape -> + log ~title:"index_buffer" "Shape of path: %a" + Logger.fmt (Fun.flip Shape.print path_shape); + begin match Shape_reduce.reduce_for_uid env path_shape with + | Internal_error_missing_uid -> + log ~title:"index_buffer" "Reduction failed: missing uid"; + index_decl () + | Resolved_alias l -> + let uid = Locate.uid_of_aliases ~traverse_aliases:false l in + Index_format.(add defs uid (LidSet.singleton lid)) + | Resolved uid -> + log ~title:"index_buffer" "Found %s (%a) wiht uid %a" + (Longident.head lid.txt) + Logger.fmt (Fun.flip Location.print_loc lid.loc) + Logger.fmt (Fun.flip Shape.Uid.print uid); + Index_format.(add defs uid (LidSet.singleton lid)) + | Approximated s -> + log ~title:"index_buffer" "Shape is approximative, found uid: %a" + Logger.fmt (Fun.flip (Format.pp_print_option Shape.Uid.print) s); + index_decl () + | Unresolved s -> + log ~title:"index_buffer" "Shape unresolved, stuck on: %a" + Logger.fmt (Fun.flip Shape.print s); + index_decl () + end + in + let f ~namespace env path (lid : Longident.t Location.loc) = + (* The compiler lacks sufficient location information to precisely hihglight + modules in paths. This function hacks around that issue when looking for + occurrences in the current buffer only. *) + let rec iter_on_path ~namespace path ({Location.txt; loc} as lid) = + let () = f ~namespace env path lid in + match path, txt with + | Pdot (path, _), Ldot (lid, s) -> + let length_with_dot = String.length s + 1 in + let lid = + { Location.txt = lid; loc = { loc with loc_end = {loc.loc_end with + pos_cnum = loc.loc_end.pos_cnum - length_with_dot}} } + in + iter_on_path ~namespace:Module path lid + | Papply _, _ -> () + | _, _ -> () + in + iter_on_path ~namespace path lid + in + Ast_iterators.iter_on_usages ~f local_defs; + defs + +let merge_tbl ~into tbl = Hashtbl.iter (Index_format.add into) tbl + +(* A longident can have the form: A.B.x Right now we are only interested in + values, but we will eventually want to index all occurrences of modules in + such longidents. However there is an issue with that: we only have the + location of the complete longident which might span multiple lines. This is + enough to get the last component since it will always be on the last line, + but will prevent us to find the location of previous components. *) +let last_loc (loc : Location.t) lid = + if lid = Longident.Lident "*unknown*" then loc + else + let last_size = Longident.last lid |> String.length in + { loc with + loc_start = { loc.loc_end with + pos_cnum = loc.loc_end.pos_cnum - last_size; + } + } + +let uid_and_loc_of_node env node = + let open Browse_raw in + log ~title:"occurrences" "Looking for uid of node %s" + @@ string_of_node node; + match node with + | Module_binding_name { mb_id = Some ident; mb_name; _ } -> + let md = Env.find_module (Pident ident) env in + Some (md.md_uid, mb_name.loc) + | Pattern { pat_desc = + Tpat_var (_, name, uid) | Tpat_alias (_, _, name, uid); _ } -> + Some (uid, name.loc) + | Type_declaration { typ_type; typ_name; _ } -> + Some (typ_type.type_uid, typ_name.loc) + | Label_declaration { ld_uid; ld_loc ; _ } -> + Some (ld_uid, ld_loc) + | Constructor_declaration { cd_uid; cd_loc ; _ } -> + Some (cd_uid, cd_loc) + | Value_description { val_val; val_name; _ } -> + Some (val_val.val_uid, val_name.loc) + | _ -> None + +let loc_of_local_def ~local_defs uid = + (* WIP *) + (* todo: cache or specialize ? *) + let uid_to_locs_tbl : string Location.loc Types.Uid.Tbl.t = + Types.Uid.Tbl.create 64 + in + match local_defs with + | `Interface _ -> failwith "not implemented" + | `Implementation str -> + let iter = Ast_iterators.iter_on_defs ~uid_to_locs_tbl in + iter.structure iter str; + (* todo: optimize, the iterator could be more flexible *) + (* we could check equality and raise with the result as soon that it arrive *) + Shape.Uid.Tbl.find uid_to_locs_tbl uid + +let comp_unit_of_uid = function + | Shape.Uid.Compilation_unit comp_unit + | Item { comp_unit; _ } -> Some comp_unit + | Internal | Predef _ -> None + +let locs_of ~config ~env ~local_defs ~pos ~node:_ path = + log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" + path + (Lexing.print_position () pos); + let locate_result = + Locate.from_string + ~config:{ mconfig = config; traverse_aliases=false; ml_or_mli = `ML} + ~env ~local_defs ~pos path + in + (* When we fail to find an exact definition we restrict the scope to the local + buffer *) + let def = + match locate_result with + | `At_origin -> + log ~title:"locs_of" "Cursor is on definition / declaration"; + (* We are on a definition / declaration so we look for the node's uid *) + (* todo: refactor *) + let browse = Mbrowse.of_typedtree local_defs in + let node = Mbrowse.enclosing pos [browse] in + let env, node = Mbrowse.leaf_node node in + uid_and_loc_of_node env node + | `Found { uid; location; approximated = false; _ } -> + log ~title:"locs_of" "Found definition uid using locate: %a " + Logger.fmt (fun fmt -> Shape.Uid.print fmt uid); + Some (uid, location) + | `Found { decl_uid; location; approximated = true; _ } -> + log ~title:"locs_of" "Approx: %a " + Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid); + Some (decl_uid, location) + | `Builtin (uid, s) -> + log ~title:"locs_of" "Locate found a builtin: %s" s; + Some (uid, Location.none) + | _ -> + log ~title:"locs_of" "Locate failed to find a definition."; + None + in + let current_buffer_path = + Filename.concat config.query.directory config.query.filename + in + match def with + | Some (def_uid, def_loc) -> + log ~title:"locs_of" "Definition has uid %a (%a)" + Logger.fmt (fun fmt -> Shape.Uid.print fmt def_uid) + Logger.fmt (fun fmt -> Location.print_loc fmt def_loc); + log ~title:"locs_of" "Indexing current buffer"; + let buffer_index = + index_buffer ~current_buffer_path ~local_defs () + in + let buffer_locs = Hashtbl.find_opt buffer_index def_uid in + let locs = Option.value ~default: LidSet.empty buffer_locs in + let locs = + log ~title:"occurrences" "Found %i locs" (LidSet.cardinal locs); + LidSet.elements locs + |> List.filter_map ~f:(fun {Location.txt; loc} -> + log ~title:"occurrences" "Found occ: %s %a" + (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc); + let loc = last_loc loc txt in + let fname = loc.Location.loc_start.Lexing.pos_fname in + if Filename.is_relative fname then begin + match Locate.find_source ~config loc fname with + | `Found (file, _) -> Some (set_fname ~file loc) + | `File_not_found msg -> + log ~title:"occurrences" "%s" msg; + None + end else Some loc) + in + let def_uid_is_in_current_unit = + let uid_comp_unit = comp_unit_of_uid def_uid in + Option.value_map ~default:false uid_comp_unit + ~f:(String.equal @@ Env.get_unit_name ()) + in + if not def_uid_is_in_current_unit then Ok locs + else Ok (set_fname ~file:current_buffer_path def_loc :: locs) + | None -> Error "nouid" diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 7736197f96..92959b6449 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -362,7 +362,8 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | Locate_type pos -> let typer = Mpipeline.typer_result pipeline in - let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in + let local_defs = Mtyper.get_typedtree typer in + let structures = Mbrowse.of_typedtree local_defs in let pos = Mpipeline.get_lexing_pos pipeline pos in let node = match Mbrowse.enclosing pos [structures] with @@ -388,15 +389,22 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | None -> `Invalid_context | Some (env, path) -> Locate.log ~title:"debug" "found type: %s" (Path.name path); + let config = Locate.{ + mconfig = Mpipeline.final_config pipeline; + ml_or_mli = `MLI; + traverse_aliases = true + } + in match Locate.from_path + ~config ~env - ~config:(Mpipeline.final_config pipeline) - ~namespace:`Type `MLI + ~local_defs + ~namespace:Type path with - | `Builtin -> `Builtin (Path.name path) + | `Builtin (_, s) -> `Builtin s | `Not_in_env _ as s -> s | `Not_found _ as s -> s - | `Found (_uid, file, pos) -> `Found (file, pos) + | `Found { file; location; _ } -> `Found (Some file, location.loc_start) | `File_not_found _ as s -> s end @@ -529,19 +537,24 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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) -> + let config = Locate.{ + mconfig = Mpipeline.final_config pipeline; + ml_or_mli; + traverse_aliases = true + } + in + begin match Locate.from_string ~config ~env ~local_defs ~pos path with + | `Found { file; location; _ } -> Locate.log ~title:"result" - "found: %s" (Option.value ~default:"" file); - `Found (file, pos) + "found: %s" file; + `Found (Some file, location.loc_start) | `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 + | `Builtin (_, s) -> + Locate.log ~title:"result" "found builtin %s" s; + `Builtin s + | (`Not_found _|`At_origin |`Not_in_env _|`File_not_found _) as otherwise -> Locate.log ~title:"result" "not found"; otherwise @@ -791,62 +804,27 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let config = Mpipeline.final_config pipeline in Mconfig.(config.merlin.source_path) - | Occurrences (`Ident_at pos, _scope) -> + | Occurrences (`Ident_at pos, _) -> + let config = Mpipeline.final_config pipeline in let typer = Mpipeline.typer_result pipeline in - let str = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in + let local_defs = 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 - + let env, node = Mbrowse.leaf_node (Mtyper.node_at typer pos) in + let path = + 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 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 () + Occurrences.locs_of ~config ~env ~local_defs ~node ~pos path + |> Result.value ~default:[] 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 + (List.sort ~cmp locs) | Version -> Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" diff --git a/src/ocaml/typing/cmt_format.mli b/src/ocaml/typing/cmt_format.mli index d27f56bccb..c316ccc70c 100644 --- a/src/ocaml/typing/cmt_format.mli +++ b/src/ocaml/typing/cmt_format.mli @@ -123,3 +123,15 @@ val record_value_dependency: val read_signature : 'a -> string -> Types.signature * 'b list * 'c list *) + +val iter_on_declarations : + f:(Types.Uid.t -> item_declaration -> unit) + -> Tast_iterator.iterator + +val iter_on_occurrences : + f:(namespace:Shape.Sig_component_kind.t -> + Env.t -> + Path.t -> + Longident.t Location.loc -> + unit) + -> Tast_iterator.iterator diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index e579f4ee27..b9a13c28cd 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -2034,8 +2034,12 @@ and type_pat_aux { p with pat_type = ty; pat_desc = - Tpat_alias - ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s, uid); + Tpat_alias + ({p with + pat_desc = Tpat_any; + pat_attributes = (* Merlin should ignore these nodes *) + [Ast_helper.Attr.mk (mknoloc "merlin.hide") (PStr [])]; + pat_loc = { p.pat_loc with loc_ghost = true }}, id,s,uid); pat_extra = [extra]; } | _, p -> diff --git a/src/utils/std.ml b/src/utils/std.ml index 2f02dcb782..9cc9de0932 100644 --- a/src/utils/std.ml +++ b/src/utils/std.ml @@ -351,9 +351,7 @@ module Option = struct end module Result = struct - type ('a, 'e) t = ('a, 'e) result = - | Ok of 'a - | Error of 'e + include Result let map ~f r = Result.map f r let bind ~f r = Result.bind r f From dc3973023ae8eec836b259f5bc706008ee01e10a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 7 Feb 2024 14:02:08 +0100 Subject: [PATCH 065/130] Build with new Texp_function nodes FIXME Merlin recovery and other feature related to functions are probably broken --- src/analysis/construct.ml | 20 +++++++++++++++----- src/analysis/tail_analysis.ml | 3 ++- src/ocaml/merlin_specific/browse_raw.ml | 17 ++++++++++++++--- 3 files changed, 31 insertions(+), 9 deletions(-) diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml index 93a29a16d9..dd0bde6d29 100644 --- a/src/analysis/construct.ml +++ b/src/analysis/construct.ml @@ -329,15 +329,23 @@ module Gen = struct in fun env label ty -> let open Asttypes in + let make_param arg_label pat = + { + Parsetree.pparam_loc = Location.none; + pparam_desc = Pparam_val (arg_label, None, pat) + + } + in + match label with | Labelled s | Optional s -> (* Pun for labelled arguments *) - Ast_helper.Pat.var ( Location.mknoloc s), s + make_param label (Ast_helper.Pat.var ( Location.mknoloc s)), s | Nolabel -> begin match get_desc ty 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 + make_param label (Ast_helper.Pat.var ( Location.mknoloc name)), name + | _ -> make_param label (Ast_helper.Pat.any ()), "_" end in let constructor env type_expr path constrs = @@ -491,7 +499,9 @@ module Gen = struct 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) + (* TODO UPRGADE: this should be improved for multiple arguments *) + List.map exps ~f:(fun e -> + Ast_helper.Exp.function_ [argument] None (Pfunction_body e)) | Ttuple types -> let choices = List.map types ~f:(exp_or_hole env) |> Util.combinations @@ -548,7 +558,7 @@ module Gen = struct end let needs_parentheses e = match e.Parsetree.pexp_desc with - | Pexp_fun _ + | Pexp_function _ | Pexp_lazy _ | Pexp_apply _ | Pexp_variant (_, Some _) diff --git a/src/analysis/tail_analysis.ml b/src/analysis/tail_analysis.ml index 3e75a758d7..2b9891483c 100644 --- a/src/analysis/tail_analysis.ml +++ b/src/analysis/tail_analysis.ml @@ -74,7 +74,8 @@ let tail_positions = function (* 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) + (* TODO UPGRADE *) + (* | Texp_function (cases, _) -> List.map cases ~f:(fun c -> Case c) *) | _ -> [] let entry_points = function diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml index c5265b375f..6e87f437d2 100644 --- a/src/ocaml/merlin_specific/browse_raw.ml +++ b/src/ocaml/merlin_specific/browse_raw.ml @@ -319,13 +319,13 @@ let of_method_call obj meth loc = 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 +let rec 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_function (params, body) -> + list_fold of_function_param params ** of_function_body body | Texp_apply (e,ls) -> of_expression e ** list_fold (function @@ -398,6 +398,17 @@ let of_expression_desc loc = function | Texp_open (od, e) -> app (Module_expr od.open_expr) ** of_expression e +and of_function_param fp = of_function_param_kind fp.fp_kind + +and of_function_param_kind = function + | Tparam_pat pat -> of_pattern pat + | Tparam_optional_default (pat, exp) -> + of_pattern pat ** of_expression exp + +and of_function_body = function + | Tfunction_body exp -> of_expression exp + | Tfunction_cases fc -> list_fold of_case fc.cases + and of_class_expr_desc = function | Tcl_ident (_,_,cts) -> list_fold of_core_type cts From ee8c43eb5e9b1618aeb7e389729df650e0b67a36 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 7 Feb 2024 14:02:23 +0100 Subject: [PATCH 066/130] config: bump magic number --- src/config/gen_config.ml | 2 +- src/ocaml/utils/config.ml | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/config/gen_config.ml b/src/config/gen_config.ml index 1e42ebf8f3..99fa4ceeef 100644 --- a/src/config/gen_config.ml +++ b/src/config/gen_config.ml @@ -17,5 +17,5 @@ let ocamlversion : | `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 - | `OCaml_4_14_0 | `OCaml_5_0_0 | `OCaml_5_1_0 ] = %s + | `OCaml_4_14_0 | `OCaml_5_0_0 | `OCaml_5_1_0 | `OCaml_5_2_0 ] = %s |} ocaml_version_val diff --git a/src/ocaml/utils/config.ml b/src/ocaml/utils/config.ml index 6d255944b7..4c2a9566f6 100644 --- a/src/ocaml/utils/config.ml +++ b/src/ocaml/utils/config.ml @@ -30,25 +30,25 @@ let flambda = false let ext_obj = ".o_The boot compiler cannot process C objects" -let exec_magic_number = "Caml1999X033" +let exec_magic_number = "Caml1999X034" (* exec_magic_number is duplicated in runtime/caml/exec.h *) -and cmi_magic_number = "Caml1999I033" -and cmo_magic_number = "Caml1999O033" -and cma_magic_number = "Caml1999A033" +and cmi_magic_number = "Caml1999I034" +and cmo_magic_number = "Caml1999O034" +and cma_magic_number = "Caml1999A034" and cmx_magic_number = if flambda then - "Caml1999y033" + "Caml1999y034" else - "Caml1999Y033" + "Caml1999Y034" and cmxa_magic_number = if flambda then - "Caml1999z033" + "Caml1999z034" else - "Caml1999Z033" -and ast_impl_magic_number = "Caml1999M033" -and ast_intf_magic_number = "Caml1999N033" -and cmxs_magic_number = "Caml1999D033" -and cmt_magic_number = "Caml1999T033" + "Caml1999Z034" +and ast_impl_magic_number = "Caml1999M034" +and ast_intf_magic_number = "Caml1999N034" +and cmxs_magic_number = "Caml1999D034" +and cmt_magic_number = "Caml1999T034" let interface_suffix = ref ".mli" From 840a50e8340821aa91ba7183444e29ec9597a597 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 7 Feb 2024 16:20:18 +0100 Subject: [PATCH 067/130] shape_reduce: fix late usage of local_store --- src/ocaml/typing/shape_reduce.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/ocaml/typing/shape_reduce.ml b/src/ocaml/typing/shape_reduce.ml index 718b212133..8706038fa2 100644 --- a/src/ocaml/typing/shape_reduce.ml +++ b/src/ocaml/typing/shape_reduce.ml @@ -273,8 +273,8 @@ end) = struct (* Sharing the memo tables is safe at the level of a compilation unit since idents should be unique *) - let reduce_memo_table = Local_store.s_table Hashtbl.create 42 - let read_back_memo_table = Local_store.s_table Hashtbl.create 42 + let reduce_memo_table = Hashtbl.create 42 + let read_back_memo_table = Hashtbl.create 42 let reduce global_env t = let fuel = ref Params.fuel in @@ -282,8 +282,8 @@ end) = struct let env = { fuel; global_env; - reduce_memo_table = !reduce_memo_table; - read_back_memo_table = !read_back_memo_table; + reduce_memo_table = reduce_memo_table; + read_back_memo_table = read_back_memo_table; local_env; } in reduce_ env t |> read_back env @@ -314,8 +314,8 @@ end) = struct let env = { fuel; global_env; - reduce_memo_table = !reduce_memo_table; - read_back_memo_table = !read_back_memo_table; + reduce_memo_table = reduce_memo_table; + read_back_memo_table = read_back_memo_table; local_env; } in let nf = reduce_ env t in From 6a865ddf8e9e5d04a45753f3fe8d2b8e459a08aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 7 Feb 2024 16:21:13 +0100 Subject: [PATCH 068/130] tests: promote improved tests and expected locations improvements --- tests/test-dirs/document/issue1513.t | 8 +-- tests/test-dirs/environment_on_open.t/run.t | 2 +- tests/test-dirs/issue1322.t/run.t | 2 +- tests/test-dirs/locate-type.t/run.t | 6 +- .../locate/context-detection/cd-field.t/run.t | 6 +- .../cd-from_a_pattern.t/run.t | 2 +- .../locate/context-detection/cd-label.t/run.t | 8 +-- .../locate/context-detection/cd-test.t/run.t | 18 ++--- .../locate/functors/f-all_local.t/run.t | 6 +- .../functors/f-from_application.t/run.t | 6 +- .../locate/functors/f-generative.t/run.t | 2 +- .../functors/f-missed_shadowing.t/run.t | 2 +- .../functors/f-nested_applications.t/run.t | 10 +-- .../test-dirs/locate/functors/f-test-ml-mli.t | 4 +- tests/test-dirs/locate/includes.t/run.t | 4 +- tests/test-dirs/locate/issue1199.t | 2 +- tests/test-dirs/locate/issue1424.t | 2 +- tests/test-dirs/locate/issue1667.t | 6 +- tests/test-dirs/locate/issue802.t/run.t | 6 +- tests/test-dirs/locate/issue845.t/run.t | 6 +- tests/test-dirs/locate/l-413-features.t | 4 +- tests/test-dirs/locate/local-build-scheme.t | 2 +- tests/test-dirs/locate/local-locate.t | 17 +++++ tests/test-dirs/locate/locate-constrs.t | 6 +- tests/test-dirs/locate/module-aliases.t/run.t | 8 +-- tests/test-dirs/locate/module-decl-aliases.t | 8 +-- .../locate/non-local/ignore-kept-locs.t/run.t | 19 ++--- .../locate/non-local/preference.t/run.t | 6 +- .../reconstruct-identifier/off_by_one.t/run.t | 2 +- tests/test-dirs/locate/sig-substs.t/run.t | 4 +- tests/test-dirs/locate/without-implem.t | 4 +- tests/test-dirs/occurrences/ext-variant.t | 1 - tests/test-dirs/occurrences/issue1398.t/run.t | 71 +++++++++++++++++-- tests/test-dirs/occurrences/issue1404.t | 12 ++-- tests/test-dirs/occurrences/issue1410.t | 14 ---- tests/test-dirs/occurrences/issue827.t/run.t | 4 +- .../server-tests/typer-cache/stamps.t/run.t | 20 +++--- tests/test-dirs/with-ppx/dune | 2 +- 38 files changed, 178 insertions(+), 134 deletions(-) create mode 100644 tests/test-dirs/locate/local-locate.t diff --git a/tests/test-dirs/document/issue1513.t b/tests/test-dirs/document/issue1513.t index 245bfed984..50fdeca695 100644 --- a/tests/test-dirs/document/issue1513.t +++ b/tests/test-dirs/document/issue1513.t @@ -16,12 +16,10 @@ Merlin should show comments for a type's constructor from another module: $ $OCAMLC -c -bin-annot naux.ml -FIXME: We should not rely on "fallbacking". This requires a compiler change. +We should not rely on "fallbacking". This requires a compiler change. $ $MERLIN single document -position 1:13 \ - > -log-file - -log-section locate \ - > -filename main.ml &1 | - > grep "Uid not found in the table." - Uid not found in the table. + > -filename main.ml -filename ./record.ml < ./record.ml | jq '.value' { "file": "$TESTCASE_ROOT/record.ml", "pos": { "line": 1, - "col": 0 + "col": 11 } } @@ -60,14 +58,12 @@ We could expect 2:12 or at least 2:4 $ $OCAMLC -c -bin-annot record.ml -FIXME: Merlin looks for the Uid of the label in Record's `uid_to_loc` table but -doesn't find it. We need a compiler fix for this, see #1505. $ $MERLIN single locate -look-for mli -position 2:24 \ > -filename ./other_module.ml < ./other_module.ml | jq '.value' { "file": "$TESTCASE_ROOT/record.ml", "pos": { "line": 1, - "col": 0 + "col": 11 } } 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 index 34e4cce900..1dd96f14a8 100644 --- a/tests/test-dirs/locate/context-detection/cd-test.t/run.t +++ b/tests/test-dirs/locate/context-detection/cd-test.t/run.t @@ -7,7 +7,7 @@ Trying them all: "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 1, - "col": 0 + "col": 9 } }, "notifications": [] @@ -20,7 +20,7 @@ Trying them all: "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 3, - "col": 0 + "col": 12 } }, "notifications": [] @@ -33,7 +33,7 @@ Trying them all: "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 7, - "col": 0 + "col": 12 } }, "notifications": [] @@ -61,7 +61,7 @@ FIXME this should say "Already at definition point" (we're defining the label): "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 1, - "col": 0 + "col": 5 } }, "notifications": [] @@ -96,7 +96,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 1, - "col": 0 + "col": 5 } }, "notifications": [] @@ -109,7 +109,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 1, - "col": 0 + "col": 9 } }, "notifications": [] @@ -122,7 +122,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 11, - "col": 0 + "col": 10 } }, "notifications": [] @@ -151,7 +151,7 @@ FIXME this should jump to line 11: "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 13, - "col": 0 + "col": 11 } }, "notifications": [] @@ -177,7 +177,7 @@ FIXME this should jump to line 11: "file": "$TESTCASE_ROOT/test.ml", "pos": { "line": 13, - "col": 0 + "col": 11 } }, "notifications": [] 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 index 1cb47dc635..835e9981c5 100644 --- a/tests/test-dirs/locate/functors/f-all_local.t/run.t +++ b/tests/test-dirs/locate/functors/f-all_local.t/run.t @@ -7,7 +7,7 @@ Check that we can jump locally inside the functor: "file": "$TESTCASE_ROOT/all_local.ml", "pos": { "line": 12, - "col": 2 + "col": 7 } }, "notifications": [] @@ -38,7 +38,7 @@ Check that we can jump from inside the functor to the (sig of the) parameter: "file": "$TESTCASE_ROOT/all_local.ml", "pos": { "line": 2, - "col": 2 + "col": 7 } }, "notifications": [] @@ -53,7 +53,7 @@ Check the argument is substituted for the parameter "file": "$TESTCASE_ROOT/all_local.ml", "pos": { "line": 6, - "col": 2 + "col": 7 } }, "notifications": [] 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 index 37624dbcb5..c28cb0493e 100644 --- a/tests/test-dirs/locate/functors/f-from_application.t/run.t +++ b/tests/test-dirs/locate/functors/f-from_application.t/run.t @@ -8,7 +8,7 @@ FIXME: we confuse the module for the constructor and jump to the wrong place "file": "$TESTCASE_ROOT/from_application.ml", "pos": { "line": 5, - "col": 0 + "col": 7 } }, "notifications": [] @@ -23,7 +23,7 @@ Jump from inside the functor application to inside the functor application: "file": "$TESTCASE_ROOT/from_application.ml", "pos": { "line": 14, - "col": 4 + "col": 9 } }, "notifications": [] @@ -38,7 +38,7 @@ Jump from inside the functor application to the outer scope: "file": "$TESTCASE_ROOT/from_application.ml", "pos": { "line": 9, - "col": 0 + "col": 5 } }, "notifications": [] diff --git a/tests/test-dirs/locate/functors/f-generative.t/run.t b/tests/test-dirs/locate/functors/f-generative.t/run.t index 28de85ca5d..e8d473b0a4 100644 --- a/tests/test-dirs/locate/functors/f-generative.t/run.t +++ b/tests/test-dirs/locate/functors/f-generative.t/run.t @@ -7,7 +7,7 @@ Check that we handle generative functors properly: "file": "$TESTCASE_ROOT/generative.ml", "pos": { "line": 3, - "col": 2 + "col": 6 } }, "notifications": [] 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 index 99b22601c9..40f8de69df 100644 --- a/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t +++ b/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t @@ -22,7 +22,7 @@ Reproduce bug described (and fixed) in commit e558d203334fd06f7653a6388b46dba895 "file": "$TESTCASE_ROOT/missed_shadowing.ml", "pos": { "line": 7, - "col": 0 + "col": 12 } }, "notifications": [] 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 index 0d933368c3..3977c4d0ca 100644 --- a/tests/test-dirs/locate/functors/f-nested_applications.t/run.t +++ b/tests/test-dirs/locate/functors/f-nested_applications.t/run.t @@ -7,7 +7,7 @@ "file": "$TESTCASE_ROOT/nested_applications.ml", "pos": { "line": 10, - "col": 2 + "col": 7 } }, "notifications": [] @@ -21,7 +21,7 @@ "file": "$TESTCASE_ROOT/nested_applications.ml", "pos": { "line": 10, - "col": 2 + "col": 7 } }, "notifications": [] @@ -35,7 +35,7 @@ "file": "$TESTCASE_ROOT/nested_applications.ml", "pos": { "line": 10, - "col": 2 + "col": 7 } }, "notifications": [] @@ -49,7 +49,7 @@ "file": "$TESTCASE_ROOT/nested_applications.ml", "pos": { "line": 10, - "col": 2 + "col": 7 } }, "notifications": [] @@ -63,7 +63,7 @@ "file": "$TESTCASE_ROOT/nested_applications.ml", "pos": { "line": 10, - "col": 2 + "col": 7 } }, "notifications": [] diff --git a/tests/test-dirs/locate/functors/f-test-ml-mli.t b/tests/test-dirs/locate/functors/f-test-ml-mli.t index 35d27170b3..bffd012ce7 100644 --- a/tests/test-dirs/locate/functors/f-test-ml-mli.t +++ b/tests/test-dirs/locate/functors/f-test-ml-mli.t @@ -34,7 +34,7 @@ Should jump to mySet.ml: "file": "$TESTCASE_ROOT/mySet.ml", "pos": { "line": 2, - "col": 2 + "col": 7 } } @@ -45,6 +45,6 @@ Should jump to mySet.mli: "file": "$TESTCASE_ROOT/mySet.mli", "pos": { "line": 2, - "col": 2 + "col": 7 } } diff --git a/tests/test-dirs/locate/includes.t/run.t b/tests/test-dirs/locate/includes.t/run.t index 6ffd20e5a9..e55c9ea2b8 100644 --- a/tests/test-dirs/locate/includes.t/run.t +++ b/tests/test-dirs/locate/includes.t/run.t @@ -13,7 +13,7 @@ thing. "file": "$TESTCASE_ROOT/foo.ml", "pos": { "line": 1, - "col": 0 + "col": 8 } }, "notifications": [] @@ -29,7 +29,7 @@ the structure, but the stamp will have changed: "file": "$TESTCASE_ROOT/foo.ml", "pos": { "line": 1, - "col": 0 + "col": 8 } }, "notifications": [] diff --git a/tests/test-dirs/locate/issue1199.t b/tests/test-dirs/locate/issue1199.t index 86bc6b1738..2f0f3ccb33 100644 --- a/tests/test-dirs/locate/issue1199.t +++ b/tests/test-dirs/locate/issue1199.t @@ -30,7 +30,7 @@ straight to the functor. "file": "$TESTCASE_ROOT/func.ml", "pos": { "line": 5, - "col": 0 + "col": 7 } }, "notifications": [] diff --git a/tests/test-dirs/locate/issue1424.t b/tests/test-dirs/locate/issue1424.t index 6052465110..fc3df920a6 100644 --- a/tests/test-dirs/locate/issue1424.t +++ b/tests/test-dirs/locate/issue1424.t @@ -28,7 +28,7 @@ Jump to interface: "file": "$TESTCASE_ROOT/test2.mli", "pos": { "line": 1, - "col": 0 + "col": 4 } } diff --git a/tests/test-dirs/locate/issue1667.t b/tests/test-dirs/locate/issue1667.t index 4484427162..1c5a51053e 100644 --- a/tests/test-dirs/locate/issue1667.t +++ b/tests/test-dirs/locate/issue1667.t @@ -14,14 +14,14 @@ > -filename ./main.ml < ./main.ml | jq '.value.pos' { "line": 2, - "col": 2 + "col": 14 } $ $MERLIN single locate -look-for ml -position 7:13 \ > -filename ./main.ml < ./main.ml | jq '.value.pos' { "line": 2, - "col": 2 + "col": 14 } @@ -29,5 +29,5 @@ > -filename ./main.ml < ./main.ml | jq '.value.pos' { "line": 2, - "col": 2 + "col": 14 } diff --git a/tests/test-dirs/locate/issue802.t/run.t b/tests/test-dirs/locate/issue802.t/run.t index 73505e98d8..9f32717e42 100644 --- a/tests/test-dirs/locate/issue802.t/run.t +++ b/tests/test-dirs/locate/issue802.t/run.t @@ -15,7 +15,7 @@ Test jumping from a normal constructor: "file": "$TESTCASE_ROOT/error.ml", "pos": { "line": 1, - "col": 0 + "col": 9 } }, "notifications": [] @@ -30,7 +30,7 @@ From an exception: "file": "$TESTCASE_ROOT/error.ml", "pos": { "line": 3, - "col": 0 + "col": 10 } }, "notifications": [] @@ -60,7 +60,7 @@ And from the extensible type name itself: "file": "$TESTCASE_ROOT/error.ml", "pos": { "line": 5, - "col": 0 + "col": 5 } }, "notifications": [] diff --git a/tests/test-dirs/locate/issue845.t/run.t b/tests/test-dirs/locate/issue845.t/run.t index 3dafe6f83b..08b2577700 100644 --- a/tests/test-dirs/locate/issue845.t/run.t +++ b/tests/test-dirs/locate/issue845.t/run.t @@ -11,8 +11,6 @@ module containing a functor locally: Test jumping to impl: -FIXME: this jumps to the .mli... - $ $MERLIN single locate -look-for ml -position 1:24 -filename test.ml < module SM = Local_map.Make(String) > EOF @@ -22,7 +20,7 @@ FIXME: this jumps to the .mli... "file": "$TESTCASE_ROOT/local_map.ml", "pos": { "line": 1, - "col": 0 + "col": 7 } }, "notifications": [] @@ -39,7 +37,7 @@ Test jumping to intf: "file": "$TESTCASE_ROOT/local_map.mli", "pos": { "line": 1, - "col": 0 + "col": 7 } }, "notifications": [] diff --git a/tests/test-dirs/locate/l-413-features.t b/tests/test-dirs/locate/l-413-features.t index 95682571fc..7de71cff21 100644 --- a/tests/test-dirs/locate/l-413-features.t +++ b/tests/test-dirs/locate/l-413-features.t @@ -58,7 +58,7 @@ Module types substitutions "file": "$TESTCASE_ROOT/mtsubst.ml", "pos": { "line": 5, - "col": 19 + "col": 31 } }, "notifications": [] @@ -86,7 +86,7 @@ Module types substitutions "file": "$TESTCASE_ROOT/mtsubst.ml", "pos": { "line": 5, - "col": 19 + "col": 31 } }, "notifications": [] diff --git a/tests/test-dirs/locate/local-build-scheme.t b/tests/test-dirs/locate/local-build-scheme.t index eae49fc8fe..a444f64b4c 100644 --- a/tests/test-dirs/locate/local-build-scheme.t +++ b/tests/test-dirs/locate/local-build-scheme.t @@ -42,7 +42,7 @@ "file": "experimental", "pos": { "line": 1, - "col": 20 + "col": 24 } } diff --git a/tests/test-dirs/locate/local-locate.t b/tests/test-dirs/locate/local-locate.t new file mode 100644 index 0000000000..eeb3ae8033 --- /dev/null +++ b/tests/test-dirs/locate/local-locate.t @@ -0,0 +1,17 @@ + $ cat >main.ml < let _ = let x = 42 in x + > EOF + + $ $MERLIN single locate -look-for ml -position 1:22 \ + > -filename main.ml -filename main.ml -filename ./constr.ml < ./constr.ml | jq '.value' { "file": "$TESTCASE_ROOT/constr.ml", "pos": { "line": 1, - "col": 0 + "col": 9 } } @@ -42,7 +40,7 @@ With the declaration in another compilation unit: "file": "$TESTCASE_ROOT/constr.ml", "pos": { "line": 1, - "col": 18 + "col": 21 } } diff --git a/tests/test-dirs/locate/module-aliases.t/run.t b/tests/test-dirs/locate/module-aliases.t/run.t index 5eac85a908..8b1d56a598 100644 --- a/tests/test-dirs/locate/module-aliases.t/run.t +++ b/tests/test-dirs/locate/module-aliases.t/run.t @@ -49,7 +49,7 @@ Jump to the declaration of an element of an alisaed module `A.|f`: "file": "$TESTCASE_ROOT/anothermod.mli", "pos": { "line": 3, - "col": 0 + "col": 4 } } @@ -128,7 +128,7 @@ Jump from to another module value decl `Anothermod.|a`: "file": "$TESTCASE_ROOT/anothermod.mli", "pos": { "line": 2, - "col": 0 + "col": 5 } } @@ -139,7 +139,7 @@ Jump from to another module value def `Anothermod.|a`: "file": "$TESTCASE_ROOT/anothermod.ml", "pos": { "line": 2, - "col": 0 + "col": 5 } } @@ -151,7 +151,7 @@ Jump to the declaration of an element of an alisaed module `A.|f`: "file": "$TESTCASE_ROOT/anothermod.mli", "pos": { "line": 3, - "col": 0 + "col": 4 } } diff --git a/tests/test-dirs/locate/module-decl-aliases.t b/tests/test-dirs/locate/module-decl-aliases.t index 0d297716e1..c1b66ff728 100644 --- a/tests/test-dirs/locate/module-decl-aliases.t +++ b/tests/test-dirs/locate/module-decl-aliases.t @@ -25,7 +25,7 @@ "file": "$TESTCASE_ROOT/main.ml", "pos": { "line": 6, - "col": 2 + "col": 9 } } @@ -35,7 +35,7 @@ "file": "$TESTCASE_ROOT/main.ml", "pos": { "line": 2, - "col": 2 + "col": 9 } } $ $MERLIN single locate -look-for ml -position 2:10 \ @@ -44,7 +44,7 @@ "file": "$TESTCASE_ROOT/main.ml", "pos": { "line": 6, - "col": 2 + "col": 9 } } @@ -54,6 +54,6 @@ "file": "$TESTCASE_ROOT/main.ml", "pos": { "line": 2, - "col": 2 + "col": 9 } } 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 index 3a0fc89d37..d27f967c51 100644 --- 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 @@ -19,10 +19,8 @@ available: "notifications": [] } - $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d' - Loading the cmt for unit "A" - Looking for A.0 in the uid_to_loc table - Found location: File "a.ml", line 1, characters 4-9 + $ grep -A0 fall log + [1] $ rm log @@ -40,10 +38,8 @@ available: "notifications": [] } - $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d' - Loading the cmt for unit "A" - Looking for A.0 in the uid_to_loc table - Found location: File "a.ml", line 1, characters 4-9 + $ grep -A0 fall log + [1] $ rm log @@ -65,10 +61,7 @@ In the absence of cmt though, fallbacking to the cmi loc makes sense: "notifications": [] } - $ grep -A1 from_uid log | grep -v from_uid - Loading the cmt for unit "A" - -- - Failed to load the cmt file. - Fallbacking to lookup location: File "a.ml", line 1, characters 4-9 + $ grep -A0 fall log + No definition uid, falling back to the declaration uid: A.0 $ rm log diff --git a/tests/test-dirs/locate/non-local/preference.t/run.t b/tests/test-dirs/locate/non-local/preference.t/run.t index 181bcda82d..404f51bf20 100644 --- a/tests/test-dirs/locate/non-local/preference.t/run.t +++ b/tests/test-dirs/locate/non-local/preference.t/run.t @@ -51,7 +51,7 @@ Test that Locate.locate and Locate.from_path do their job properly: "file": "$TESTCASE_ROOT/a.mli", "pos": { "line": 3, - "col": 0 + "col": 4 } }, "notifications": [] @@ -64,7 +64,7 @@ Test that Locate.locate and Locate.from_path do their job properly: "file": "$TESTCASE_ROOT/a.mli", "pos": { "line": 3, - "col": 0 + "col": 4 } }, "notifications": [] @@ -77,7 +77,7 @@ Test that Locate.locate and Locate.from_path do their job properly: "file": "$TESTCASE_ROOT/a.mli", "pos": { "line": 3, - "col": 0 + "col": 4 } }, "notifications": [] 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 index c73c509066..c1bc158677 100644 --- 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 @@ -7,7 +7,7 @@ Regression test for #624 "file": "$TESTCASE_ROOT/off_by_one.ml", "pos": { "line": 1, - "col": 0 + "col": 7 } }, "notifications": [] diff --git a/tests/test-dirs/locate/sig-substs.t/run.t b/tests/test-dirs/locate/sig-substs.t/run.t index 292826a7f4..bc2e509f6a 100644 --- a/tests/test-dirs/locate/sig-substs.t/run.t +++ b/tests/test-dirs/locate/sig-substs.t/run.t @@ -9,7 +9,7 @@ when both are present in the buffer (the struct will always be preferred). "file": "$TESTCASE_ROOT/basic.ml", "pos": { "line": 8, - "col": 2 + "col": 9 } }, "notifications": [] @@ -23,7 +23,7 @@ TODO SHAPES: it could be more precise by answering 8:21 "file": "$TESTCASE_ROOT/basic.ml", "pos": { "line": 8, - "col": 2 + "col": 25 } }, "notifications": [] diff --git a/tests/test-dirs/locate/without-implem.t b/tests/test-dirs/locate/without-implem.t index 7b5c06db64..2202a21e68 100644 --- a/tests/test-dirs/locate/without-implem.t +++ b/tests/test-dirs/locate/without-implem.t @@ -26,7 +26,7 @@ "file": "$TESTCASE_ROOT/noimpl.mli", "pos": { "line": 1, - "col": 0 + "col": 5 } }, "notifications": [] @@ -40,7 +40,7 @@ "file": "$TESTCASE_ROOT/noimpl.mli", "pos": { "line": 1, - "col": 0 + "col": 5 } }, "notifications": [] diff --git a/tests/test-dirs/occurrences/ext-variant.t b/tests/test-dirs/occurrences/ext-variant.t index 0ca6ff38e6..240f72ce74 100644 --- a/tests/test-dirs/occurrences/ext-variant.t +++ b/tests/test-dirs/occurrences/ext-variant.t @@ -46,7 +46,6 @@ See issue #1185 on vscode-ocaml-platform FIXME: we can do better than that $ $MERLIN single occurrences -identifier-at 5:2 \ - > -log-file - -log-section occurrences \ > -filename main.ml jq '.value' > let x = 3 and y = 4 + 2 in @@ -40,21 +40,21 @@ FIXME occurrences identifier-at 2:1 returns the occurrences of [x] (should be [+ { "start": { "line": 1, - "col": 4 + "col": 20 }, "end": { "line": 1, - "col": 5 + "col": 21 } }, { "start": { "line": 2, - "col": 0 + "col": 1 }, "end": { "line": 2, - "col": 1 + "col": 2 } } ] @@ -84,6 +84,6 @@ locate position 2:1 returns the definition of [(+)] "file": "lib/ocaml/stdlib.mli", "pos": { "line": 335, - "col": 0 + "col": 9 } } diff --git a/tests/test-dirs/occurrences/issue1410.t b/tests/test-dirs/occurrences/issue1410.t index 27922260d4..ff0601e4cf 100644 --- a/tests/test-dirs/occurrences/issue1410.t +++ b/tests/test-dirs/occurrences/issue1410.t @@ -1,7 +1,3 @@ -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 < jq '.value' > (* test case *) @@ -9,16 +5,6 @@ First result is incorrect when in the body of a function with an optional argume > None > EOF [ - { - "start": { - "line": 0, - "col": -1 - }, - "end": { - "line": 0, - "col": -1 - } - }, { "start": { "line": 3, diff --git a/tests/test-dirs/occurrences/issue827.t/run.t b/tests/test-dirs/occurrences/issue827.t/run.t index 922bd797c8..f521cec891 100644 --- a/tests/test-dirs/occurrences/issue827.t/run.t +++ b/tests/test-dirs/occurrences/issue827.t/run.t @@ -17,7 +17,7 @@ Reproduction case: { "start": { "line": 4, - "col": 8 + "col": 10 }, "end": { "line": 4, @@ -76,7 +76,7 @@ work: { "start": { "line": 4, - "col": 8 + "col": 10 }, "end": { "line": 4, 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 index 96f7f744a4..111518a3eb 100644 --- a/tests/test-dirs/server-tests/typer-cache/stamps.t/run.t +++ b/tests/test-dirs/server-tests/typer-cache/stamps.t/run.t @@ -8,31 +8,31 @@ 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/275\" - Tpat_var \"x/277\" + Tpat_var \"f/276\" + Tpat_var \"x/278\" $ 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/278\" - Tpat_var \"x/280\" + Tpat_var \"f/279\" + Tpat_var \"x/281\" $ 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/275\" - Tpat_var \"x/277\" + Tpat_var \"f/276\" + Tpat_var \"x/278\" $ 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/278\" - Tpat_var \"x/280\" + Tpat_var \"f/279\" + Tpat_var \"x/281\" $ echo "let f x = x" | \ > $MERLIN server dump -what browse -filename test.ml | \ > sed 's:\\n:\n:g' | grep Tpat_var - Tpat_var \"f/281\" - Tpat_var \"x/283\" + Tpat_var \"f/282\" + Tpat_var \"x/284\" $ $MERLIN server stop-server diff --git a/tests/test-dirs/with-ppx/dune b/tests/test-dirs/with-ppx/dune index 5a55c21031..3ebf322645 100644 --- a/tests/test-dirs/with-ppx/dune +++ b/tests/test-dirs/with-ppx/dune @@ -3,5 +3,5 @@ (locks ../server-tests/merlin_server)) (cram - (applies_to issue1660-deriving-compare issue1671-string) + (applies_to :whole_subtree) (enabled_if (= %{env:MERLIN_TESTS=default} all))) From f94393b353e808c9faa23b0894cf628530871faa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 7 Feb 2024 16:21:49 +0100 Subject: [PATCH 069/130] opam: bump required ocaml version --- dot-merlin-reader.opam | 2 +- merlin-lib.opam | 2 +- merlin.opam | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/dot-merlin-reader.opam b/dot-merlin-reader.opam index 7f38e94b6b..1346ab3386 100644 --- a/dot-merlin-reader.opam +++ b/dot-merlin-reader.opam @@ -11,7 +11,7 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "ocaml" {>= "5.1" & < "5.2" } + "ocaml" {>= "5.1" } "dune" {>= "2.9.0"} "merlin-lib" {>= "4.9"} "ocamlfind" {>= "1.6.0"} diff --git a/merlin-lib.opam b/merlin-lib.opam index 6fefee90d1..8f4e8c3e26 100644 --- a/merlin-lib.opam +++ b/merlin-lib.opam @@ -10,7 +10,7 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "ocaml" {>= "5.1.1" & < "5.2"} + "ocaml" {>= "5.2" & < "5.3"} "dune" {>= "2.9.0"} "csexp" {>= "1.5.1"} "menhir" {dev & >= "20201216"} diff --git a/merlin.opam b/merlin.opam index d036b83937..f118ce4ef8 100644 --- a/merlin.opam +++ b/merlin.opam @@ -11,7 +11,7 @@ build: [ ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] depends: [ - "ocaml" {>= "5.1" & < "5.2"} + "ocaml" {>= "5.2" & < "5.3"} "dune" {>= "2.9.0"} "merlin-lib" {= version} "dot-merlin-reader" {>= "4.9"} From 92d32b75ca1d2aa7d5251063b7be6395b4b8219e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 8 Feb 2024 11:14:46 +0100 Subject: [PATCH 070/130] construct: handle function arity better --- src/analysis/construct.ml | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml index dd0bde6d29..b99b8cc534 100644 --- a/src/analysis/construct.ml +++ b/src/analysis/construct.ml @@ -487,21 +487,29 @@ module Gen = struct | 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 - (* TODO UPRGADE: this should be improved for multiple arguments *) + | Tarrow _ -> + let rec left_types acc env ty = + match get_desc ty with + | Tarrow (label, tyleft, tyright, _) -> + let arg, 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 + left_types (arg :: acc) env tyright + | _ -> List.rev acc, ty, env + in + let arguments, body_type, env = left_types [] env rtyp in + let exps = arrow_rhs env body_type in List.map exps ~f:(fun e -> - Ast_helper.Exp.function_ [argument] None (Pfunction_body e)) + Ast_helper.Exp.function_ arguments None (Pfunction_body e)) | Ttuple types -> let choices = List.map types ~f:(exp_or_hole env) |> Util.combinations From 86c411e72ee73c3b665b950207cf5723d6314ac4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 8 Feb 2024 11:31:45 +0100 Subject: [PATCH 071/130] tests: new function recovery test with 5.1 output --- tests/test-dirs/function-recovery.t | 56 +++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 tests/test-dirs/function-recovery.t diff --git a/tests/test-dirs/function-recovery.t b/tests/test-dirs/function-recovery.t new file mode 100644 index 0000000000..536ca13699 --- /dev/null +++ b/tests/test-dirs/function-recovery.t @@ -0,0 +1,56 @@ + $ cat >test.ml <<'EOF' + > module ERROR_locate_from_inside_function_literal_used_as_non_function = struct + > let problem = `Problem + > let () = fun () -> problem + > EOF + + $ $MERLIN single dump -what typedtree -filename test.ml < test.ml + { + "class": "return", + "value": "[ + structure_item (test.ml[1,0+0]..test.ml[3,104+28]) + Tstr_module + ERROR_locate_from_inside_function_literal_used_as_non_function/277 + module_expr (test.ml[1,0+72]..test.ml[3,104+28]) + Tmod_structure + [ + structure_item (test.ml[2,79+2]..test.ml[2,79+24]) + Tstr_value Nonrec + [ + + pattern (test.ml[2,79+6]..test.ml[2,79+13]) + Tpat_var \"problem/275\" + expression (test.ml[2,79+16]..test.ml[2,79+24]) + Texp_variant \"Problem\" + None + ] + structure_item (test.ml[3,104+2]..test.ml[3,104+28]) + Tstr_value Nonrec + [ + + pattern (test.ml[3,104+6]..test.ml[3,104+8]) + Tpat_construct \"()\" + [] + None + expression (test.ml[3,104+11]..test.ml[3,104+28]) + Texp_function + Nolabel + [ + + pattern (test.ml[3,104+15]..test.ml[3,104+17]) + Tpat_construct \"()\" + [] + None + expression (test.ml[3,104+21]..test.ml[3,104+28]) + attribute \"merlin.loc\" + [] + Texp_ident \"problem/275\" + ] + ] + ] + ] + + + ", + "notifications": [] + } From 5d37374632810dfe7051be61fbc5bd75f448a53c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 9 Feb 2024 14:10:15 +0100 Subject: [PATCH 072/130] tests: more expected function recovery --- tests/test-dirs/function-recovery.t | 76 ++++++++++++++++++++++++++++- 1 file changed, 74 insertions(+), 2 deletions(-) diff --git a/tests/test-dirs/function-recovery.t b/tests/test-dirs/function-recovery.t index 536ca13699..0d596d0df4 100644 --- a/tests/test-dirs/function-recovery.t +++ b/tests/test-dirs/function-recovery.t @@ -10,7 +10,7 @@ "value": "[ structure_item (test.ml[1,0+0]..test.ml[3,104+28]) Tstr_module - ERROR_locate_from_inside_function_literal_used_as_non_function/277 + ERROR_locate_from_inside_function_literal_used_as_non_function/278 module_expr (test.ml[1,0+72]..test.ml[3,104+28]) Tmod_structure [ @@ -19,7 +19,7 @@ [ pattern (test.ml[2,79+6]..test.ml[2,79+13]) - Tpat_var \"problem/275\" + Tpat_var \"problem/276\" expression (test.ml[2,79+16]..test.ml[2,79+24]) Texp_variant \"Problem\" None @@ -54,3 +54,75 @@ ", "notifications": [] } + + $ $MERLIN single dump -what typedtree -filename type.ml < let f = fun (type t) (foo : t list) -> let (_ : t) = () in () + > EOF + { + "class": "return", + "value": "[ + structure_item (type.ml[1,0+0]..type.ml[1,0+61]) + Tstr_value Nonrec + [ + + pattern (type.ml[1,0+4]..type.ml[1,0+5]) + Tpat_var \"f/275\" + expression (type.ml[1,0+8]..type.ml[1,0+61]) + extra + Texp_newtype' \"t/276\" + Texp_function + Nolabel + [ + + pattern (type.ml[1,0+22]..type.ml[1,0+25]) + extra + Tpat_extra_constraint + core_type (type.ml[1,0+28]..type.ml[1,0+34]) + Ttyp_constr \"list/9!\" + [ + core_type (type.ml[1,0+28]..type.ml[1,0+29]) + Ttyp_constr \"t/276\" + [] + ] + Tpat_alias \"foo/277\" + pattern (type.ml[1,0+22]..type.ml[1,0+25]) + Tpat_any + expression (type.ml[1,0+39]..type.ml[1,0+61]) + attribute \"merlin.loc\" + [] + Texp_let Nonrec + [ + + pattern (type.ml[1,0+44]..type.ml[1,0+45]) + extra + Tpat_extra_constraint + core_type (type.ml[1,0+48]..type.ml[1,0+49]) + Ttyp_constr \"t/276\" + [] + Tpat_any + expression (type.ml[1,0+53]..type.ml[1,0+55]) + 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_ident \"*type-error*/278\" + ] + expression (type.ml[1,0+59]..type.ml[1,0+61]) + attribute \"merlin.loc\" + [] + Texp_construct \"()\" + [] + ] + ] + ] + + + ", + "notifications": [] + } + From 1fcb58a3e5c4b77ce2480becf14386a0c243ad4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 9 Feb 2024 15:26:12 +0100 Subject: [PATCH 073/130] functions: add uid to [Texp_newtype'] nodes --- src/analysis/ast_iterators.ml | 10 +++++----- src/ocaml/merlin_specific/browse_raw.ml | 2 +- src/ocaml/typing/printtyped.ml | 2 +- src/ocaml/typing/typecore.ml | 16 +++++++++------- src/ocaml/typing/typedtree.ml | 2 +- src/ocaml/typing/typedtree.mli | 2 +- src/ocaml/typing/untypeast.ml | 2 +- 7 files changed, 19 insertions(+), 17 deletions(-) diff --git a/src/analysis/ast_iterators.ml b/src/analysis/ast_iterators.ml index 4ad155c1e8..5d95ff1ee4 100644 --- a/src/analysis/ast_iterators.ml +++ b/src/analysis/ast_iterators.ml @@ -19,14 +19,14 @@ let iter_on_defs ~uid_to_locs_tbl = Types.Uid.Tbl.add uid_to_locs_tbl uid loc in { iter_decl with - expr = (fun sub ({ exp_extra; exp_env; _ } as expr) -> + expr = (fun sub ({ exp_extra; _ } as expr) -> List.iter exp_extra ~f:(fun (exp_extra, _loc, _attr) -> match exp_extra with - | Texp_newtype' (typ_id, typ_name) -> - log "Found definition %s (%a)\n%!" typ_name.txt + | Texp_newtype' (typ_id, typ_name, uid) -> + log "Found newtype %s wit id %a (%a)\n%!" typ_name.txt + Logger.fmt (Fun.flip Ident.print_with_scope typ_id) Logger.fmt (fun fmt -> Location.print_loc fmt typ_name.loc); - let decl = Env.find_type (Path.Pident typ_id) exp_env in - register_uid decl.type_uid typ_name; + register_uid uid typ_name; () | _ -> ()); iter_decl.expr sub expr); diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml index 6e87f437d2..4d6fe4ac7c 100644 --- a/src/ocaml/merlin_specific/browse_raw.ml +++ b/src/ocaml/merlin_specific/browse_raw.ml @@ -848,7 +848,7 @@ let expression_paths { Typedtree. exp_desc; exp_extra; _ } = List.fold_left ~init exp_extra ~f:(fun acc (extra, _, _) -> match extra with - | Texp_newtype' (id, label_loc) -> + | 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 diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml index 85a55016ac..83bc701fc3 100644 --- a/src/ocaml/typing/printtyped.ml +++ b/src/ocaml/typing/printtyped.ml @@ -328,7 +328,7 @@ and expression_extra i ppf x attrs = option i core_type ppf cto; | Texp_newtype s -> line i ppf "Texp_newtype \"%s\"\n" s; - | Texp_newtype' (id, _) -> + | Texp_newtype' (id, _, _) -> line i ppf "Texp_newtype' \"%a\"\n" fmt_ident id; attributes i ppf attrs; diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index b9a13c28cd..483e7ce15b 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -3558,8 +3558,8 @@ and type_expect_ re { exp_desc = Texp_function (params, body); exp_loc = loc; - exp_extra = - List.map (fun { txt; loc } -> Texp_newtype txt, loc, []) newtypes; + exp_extra = List.map (fun (id, txt_loc, uid) -> + Texp_newtype' (id, txt_loc, uid), txt_loc.loc, []) newtypes; exp_type; exp_attributes = sexp.pexp_attributes; exp_env = env; @@ -4292,7 +4292,7 @@ and type_expect_ re { exp with exp_extra = (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } | Pexp_newtype({txt=name} as label_loc, sbody) -> - let body, ety, id = type_newtype loc env name (fun env -> + let body, ety, id, uid = type_newtype loc env name (fun env -> let expr = type_exp env sbody in expr, expr.exp_type) in @@ -4300,7 +4300,7 @@ and type_expect_ 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 } + (Texp_newtype' (id, label_loc, uid), loc, sexp.pexp_attributes) :: body.exp_extra } | Pexp_pack m -> let (p, fl) = match get_desc (Ctype.expand_head env (instance ty_expected)) with @@ -4599,7 +4599,7 @@ and type_constraint_expect nodes for the newtype properly linked. *) and type_newtype - : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr * Ident.t = + : type a. _ -> _ -> _ -> (Env.t -> a * type_expr) -> a * type_expr * Ident.t * Uid.t = fun loc env name type_body -> let ty = if Typetexp.valid_tyvar_name name then @@ -4629,7 +4629,8 @@ and type_newtype in let ety = Subst.type_expr Subst.identity exp_type in replace ety; - (result, ety, id) + let uid = decl.type_uid in + (result, ety, id, uid) end and type_ident env ?(recarg=Rejected) lid = @@ -4764,6 +4765,7 @@ and type_function in with_explanation ty_fun.explanation (fun () -> unify_exp_types loc env exp_type (instance ty_expected)); + let newtype = nt_id, newtype, nt_uid in exp_type, params, body, newtype :: newtypes, contains_gadt | { pparam_desc = Pparam_val (arg_label, default_arg, pat); pparam_loc } :: rest @@ -4862,7 +4864,7 @@ and type_function fp_arg_label = arg_label; fp_param; fp_partial = partial; - fp_newtypes = newtypes; + fp_newtypes = List.map (fun (_,v,_) -> v) newtypes; fp_loc = pparam_loc; } in diff --git a/src/ocaml/typing/typedtree.ml b/src/ocaml/typing/typedtree.ml index 1f1954ee82..4080b14606 100644 --- a/src/ocaml/typing/typedtree.ml +++ b/src/ocaml/typing/typedtree.ml @@ -97,7 +97,7 @@ and exp_extra = | 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 + | Texp_newtype' of Ident.t * label loc * Uid.t and expression_desc = Texp_ident of Path.t * Longident.t loc * Types.value_description diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli index 986a47001e..be0732c8ca 100644 --- a/src/ocaml/typing/typedtree.mli +++ b/src/ocaml/typing/typedtree.mli @@ -172,7 +172,7 @@ and exp_extra = (** Used for method bodies. *) | Texp_newtype of string (** fun (type t) -> *) - | Texp_newtype' of Ident.t * label loc + | Texp_newtype' of Ident.t * label loc * Uid.t (** merlin-specific: keep enough information to correctly implement occurrences for local-types. Merlin typechecker uses [Texp_newtype'] constructor, while upstream diff --git a/src/ocaml/typing/untypeast.ml b/src/ocaml/typing/untypeast.ml index fc7714b419..00a8ab1428 100644 --- a/src/ocaml/typing/untypeast.ml +++ b/src/ocaml/typing/untypeast.ml @@ -370,7 +370,7 @@ let exp_extra sub (extra, loc, attrs) sexp = 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) + | Texp_newtype' (_id, label_loc, _) -> Pexp_newtype (label_loc, sexp) in Exp.mk ~loc ~attrs desc From f67393c60b66fc1ec288cf4d4990b1e70f822c70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 12 Feb 2024 13:37:08 +0100 Subject: [PATCH 074/130] env_lookup: log in all cases --- src/analysis/env_lookup.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/analysis/env_lookup.ml b/src/analysis/env_lookup.ml index fa64a807fc..e51a2ad966 100644 --- a/src/analysis/env_lookup.ml +++ b/src/analysis/env_lookup.ml @@ -115,6 +115,7 @@ let in_namespaces (nss : Namespace.inferred list) ident env = let path, md = Env.find_module_by_name ident env in raise (Found (path, Module, md.md_uid, 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, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc)) From 5dd0291a09ffdcac42e78bb1a7a318291653fe9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 12 Feb 2024 14:45:11 +0100 Subject: [PATCH 075/130] destruct: add test for fun. param. case analysis This test include the result from merlin-501 and does not past after the update. --- tests/test-dirs/destruct/destruct-fun.t | 26 +++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 tests/test-dirs/destruct/destruct-fun.t diff --git a/tests/test-dirs/destruct/destruct-fun.t b/tests/test-dirs/destruct/destruct-fun.t new file mode 100644 index 0000000000..773633384f --- /dev/null +++ b/tests/test-dirs/destruct/destruct-fun.t @@ -0,0 +1,26 @@ +Test case-analysis in the middle of a [fun]. + + $ cat >fun.ml < let f x (bb : bool) y = something + > EOF + + $ $MERLIN single case-analysis -start 1:10 -end 1:11 \ + > -log-file - -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 9 + }, + "end": { + "line": 1, + "col": 11 + } + }, + "((false as bb) : bool)|((true as bb) : bool)" + ], + "notifications": [] + } From aedc47d9f20a48e2c6ef2da2de03b80363127940 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 14 Feb 2024 10:31:15 +0100 Subject: [PATCH 076/130] tests: more updates --- tests/test-dirs/recovery.t | 6 +- .../test-dirs/type-enclosing/inside-tydecl.t | 2 +- .../type-enclosing/te-413-features.t | 88 +------------------ 3 files changed, 8 insertions(+), 88 deletions(-) diff --git a/tests/test-dirs/recovery.t b/tests/test-dirs/recovery.t index df25068d88..b7dda72cff 100644 --- a/tests/test-dirs/recovery.t +++ b/tests/test-dirs/recovery.t @@ -37,7 +37,7 @@ The hole is filled with merlin.hole. "type": "parser", "sub": [], "valid": true, - "message": "Syntax error, expecting expr" + "message": "Syntax error, expecting fun_expr" } ], "notifications": [] @@ -67,7 +67,7 @@ The hole is filled with merlin.hole. "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 + The value f is required but not provided File \"module_recovery.ml\", line 1, characters 15-34: Expected declaration" }, { @@ -118,7 +118,7 @@ penalty should prevent it. "type": "parser", "sub": [], "valid": true, - "message": "Syntax error, expecting expr" + "message": "Syntax error, expecting fun_expr" } ], "notifications": [] diff --git a/tests/test-dirs/type-enclosing/inside-tydecl.t b/tests/test-dirs/type-enclosing/inside-tydecl.t index 2fda8883cc..af594fb4a8 100644 --- a/tests/test-dirs/type-enclosing/inside-tydecl.t +++ b/tests/test-dirs/type-enclosing/inside-tydecl.t @@ -29,7 +29,7 @@ test "line": 1, "col": 20 }, - "type": "type t1 = t1", + "type": "type t1 = 'a", "tail": "no" }, { diff --git a/tests/test-dirs/type-enclosing/te-413-features.t b/tests/test-dirs/type-enclosing/te-413-features.t index da5ab50a03..b40c8c775f 100644 --- a/tests/test-dirs/type-enclosing/te-413-features.t +++ b/tests/test-dirs/type-enclosing/te-413-features.t @@ -108,51 +108,11 @@ Module types substitutions } ] +FIXME: this doesn't work anymore with the new occurrences backend $ $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 < module type ENDO = sig @@ -196,48 +156,8 @@ Module types substitutions } ] +FIXME: this doesn't work anymore with the new occurrences backend $ $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 - } - } - ] + [] From dcfa0dd4a18481f03e4591f1c9f31b8af4f4e54b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 14 Feb 2024 15:34:48 +0100 Subject: [PATCH 077/130] tests: test for fun recovery saved parts --- tests/test-dirs/function-recovery.t | 440 +++++++++++++++++++++++++++- 1 file changed, 438 insertions(+), 2 deletions(-) diff --git a/tests/test-dirs/function-recovery.t b/tests/test-dirs/function-recovery.t index 0d596d0df4..d8e16ed3e6 100644 --- a/tests/test-dirs/function-recovery.t +++ b/tests/test-dirs/function-recovery.t @@ -69,7 +69,7 @@ Tpat_var \"f/275\" expression (type.ml[1,0+8]..type.ml[1,0+61]) extra - Texp_newtype' \"t/276\" + Texp_newtype' \"t/278\" Texp_function Nolabel [ @@ -81,7 +81,7 @@ Ttyp_constr \"list/9!\" [ core_type (type.ml[1,0+28]..type.ml[1,0+29]) - Ttyp_constr \"t/276\" + Ttyp_constr \"t/278\" [] ] Tpat_alias \"foo/277\" @@ -126,3 +126,439 @@ "notifications": [] } + $ $MERLIN single dump -what browse -filename test.ml <<'EOF' + > let f (x) : int = function + > | None -> 3 + > | Some 5 -> 4 + > | Some _aa -> 4 + > EOF + { + "class": "return", + "value": [ + { + "filename": "test.ml", + "start": { + "line": 1, + "col": 0 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [], + "kind": "structure", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 1, + "col": 0 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [], + "kind": "structure_item", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 1, + "col": 0 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [], + "kind": "value_binding", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 1, + "col": 4 + }, + "end": { + "line": 1, + "col": 5 + }, + "ghost": false, + "attrs": [], + "kind": "pattern (test.ml[1,0+4]..test.ml[1,0+5]) + Tpat_var \"f/275\" + ", + "children": [] + }, + { + "filename": "test.ml", + "start": { + "line": 1, + "col": 6 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": true, + "attrs": [], + "kind": "expression", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 1, + "col": 6 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [], + "kind": "case", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 1, + "col": 6 + }, + "end": { + "line": 1, + "col": 9 + }, + "ghost": false, + "attrs": [], + "kind": "pattern (test.ml[1,0+6]..test.ml[1,0+9]) + Tpat_var \"x/277\" + ", + "children": [] + }, + { + "filename": "test.ml", + "start": { + "line": 1, + "col": 10 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [ + { + "start": { + "line": 0, + "col": -1 + }, + "end": { + "line": 0, + "col": -1 + }, + "name": "merlin.incorrect" + }, + { + "start": { + "line": 0, + "col": -1 + }, + "end": { + "line": 0, + "col": -1 + }, + "name": "merlin.saved-parts _" + } + ], + "kind": "expression", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 1, + "col": 18 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [], + "kind": "expression", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 2, + "col": 4 + }, + "end": { + "line": 2, + "col": 13 + }, + "ghost": false, + "attrs": [], + "kind": "case", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 2, + "col": 4 + }, + "end": { + "line": 2, + "col": 8 + }, + "ghost": false, + "attrs": [], + "kind": "pattern (test.ml[2,27+4]..test.ml[2,27+8]) + Tpat_construct \"None\" + [] + None + ", + "children": [] + }, + { + "filename": "test.ml", + "start": { + "line": 2, + "col": 12 + }, + "end": { + "line": 2, + "col": 13 + }, + "ghost": false, + "attrs": [ + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 13 + }, + "name": "merlin.loc" + } + ], + "kind": "expression", + "children": [] + } + ] + }, + { + "filename": "test.ml", + "start": { + "line": 3, + "col": 4 + }, + "end": { + "line": 3, + "col": 15 + }, + "ghost": false, + "attrs": [], + "kind": "case", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 3, + "col": 4 + }, + "end": { + "line": 3, + "col": 10 + }, + "ghost": false, + "attrs": [], + "kind": "pattern (test.ml[3,41+4]..test.ml[3,41+10]) + Tpat_construct \"Some\" + [ + pattern (test.ml[3,41+9]..test.ml[3,41+10]) + Tpat_constant Const_int 5 + ] + None + ", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 3, + "col": 9 + }, + "end": { + "line": 3, + "col": 10 + }, + "ghost": false, + "attrs": [], + "kind": "pattern (test.ml[3,41+9]..test.ml[3,41+10]) + Tpat_constant Const_int 5 + ", + "children": [] + } + ] + }, + { + "filename": "test.ml", + "start": { + "line": 3, + "col": 14 + }, + "end": { + "line": 3, + "col": 15 + }, + "ghost": false, + "attrs": [ + { + "start": { + "line": 3, + "col": 13 + }, + "end": { + "line": 3, + "col": 15 + }, + "name": "merlin.loc" + } + ], + "kind": "expression", + "children": [] + } + ] + }, + { + "filename": "test.ml", + "start": { + "line": 4, + "col": 4 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [], + "kind": "case", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 4, + "col": 4 + }, + "end": { + "line": 4, + "col": 12 + }, + "ghost": false, + "attrs": [], + "kind": "pattern (test.ml[4,57+4]..test.ml[4,57+12]) + Tpat_construct \"Some\" + [ + pattern (test.ml[4,57+9]..test.ml[4,57+12]) + Tpat_var \"_aa/278\" + ] + None + ", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 4, + "col": 9 + }, + "end": { + "line": 4, + "col": 12 + }, + "ghost": false, + "attrs": [], + "kind": "pattern (test.ml[4,57+9]..test.ml[4,57+12]) + Tpat_var \"_aa/278\" + ", + "children": [] + } + ] + }, + { + "filename": "test.ml", + "start": { + "line": 4, + "col": 16 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [ + { + "start": { + "line": 4, + "col": 15 + }, + "end": { + "line": 4, + "col": 17 + }, + "name": "merlin.loc" + } + ], + "kind": "expression", + "children": [] + } + ] + } + ] + }, + { + "filename": "test.ml", + "start": { + "line": 4, + "col": 16 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [ + { + "start": { + "line": 4, + "col": 15 + }, + "end": { + "line": 4, + "col": 17 + }, + "name": "merlin.loc" + } + ], + "kind": "expression", + "children": [] + } + ] + } + ] + } + ] + } + ] + } + ] + } + ] + } + ], + "notifications": [] + } From 0903757af240dc0581b016b6bf6c8d0ec87e311a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 14 Feb 2024 15:36:34 +0100 Subject: [PATCH 078/130] squash: commit change to handle newtype' --- src/ocaml/typing/typecore.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index 483e7ce15b..0b90e9c0e1 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -4748,7 +4748,7 @@ and type_function match params_suffix with | { pparam_desc = Pparam_newtype newtype; pparam_loc = _ } :: rest -> (* Check everything else in the scope of (type a). *) - let (params, body, newtypes, contains_gadt), exp_type, _ = + let (params, body, newtypes, contains_gadt), exp_type, nt_id, nt_uid = type_newtype loc env newtype.txt (fun env -> let exp_type, params, body, newtypes, contains_gadt = (* mimic the typing of Pexp_newtype by minting a new type var, From 4beafb69baea5ce73a423566a04e18da35a6e243 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 14 Feb 2024 16:47:45 +0100 Subject: [PATCH 079/130] parser: remove old lwt extension --- src/kernel/extension.ml | 29 +- src/ocaml/preprocess/parser_printer.ml | 30 - src/ocaml/preprocess/parser_raw.ml | 23827 ++++++++++++++-------- src/ocaml/preprocess/parser_raw.mli | 15 - src/ocaml/preprocess/parser_raw.mly | 88 +- src/ocaml/preprocess/parser_recover.ml | 6250 +++--- tests/test-dirs/completion/kind.t/run.t | 2 - 7 files changed, 19100 insertions(+), 11141 deletions(-) diff --git a/src/kernel/extension.ml b/src/kernel/extension.ml index 91a08cdd53..cd9173a191 100644 --- a/src/kernel/extension.ml +++ b/src/kernel/extension.ml @@ -46,33 +46,6 @@ type set = string list 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"; @@ -100,7 +73,7 @@ let ext_meta = { } (* Known extensions *) -let registry = [ext_lwt;ext_meta] +let registry = [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) diff --git a/src/ocaml/preprocess/parser_printer.ml b/src/ocaml/preprocess/parser_printer.ml index 2bfbe32000..6b7830e814 100644 --- a/src/ocaml/preprocess/parser_printer.ml +++ b/src/ocaml/preprocess/parser_printer.ml @@ -20,7 +20,6 @@ open Parser_raw 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" @@ -28,7 +27,6 @@ let print_symbol = function | 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" @@ -67,11 +65,9 @@ let print_symbol = function | 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) -> "<-" @@ -109,10 +105,8 @@ let print_symbol = function | 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" @@ -282,8 +276,6 @@ let print_symbol = function | 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__" @@ -339,7 +331,6 @@ let print_symbol = function | 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_delimited_type_supporting_local_open) -> "delimited_type_supporting_local_open" | MenhirInterpreter.X (MenhirInterpreter.N MenhirInterpreter.N_delimited_type) -> "delimited_type" @@ -376,7 +367,6 @@ let print_symbol = function 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") @@ -384,7 +374,6 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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") @@ -423,11 +412,9 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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 _ -> "<-") @@ -465,10 +452,8 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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") @@ -638,8 +623,6 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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__") @@ -695,7 +678,6 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function | 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_delimited_type_supporting_local_open -> (fun _ -> "delimited_type_supporting_local_open") | MenhirInterpreter.N MenhirInterpreter.N_delimited_type -> (fun _ -> "delimited_type") @@ -731,7 +713,6 @@ let print_value (type a) : a MenhirInterpreter.symbol -> a -> string = function 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) () @@ -739,7 +720,6 @@ let print_token = function | 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) () @@ -778,11 +758,9 @@ let print_token = function | 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) () @@ -820,10 +798,8 @@ let print_token = function | 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) () @@ -867,7 +843,6 @@ let token_of_terminal (type a) (t : a MenhirInterpreter.terminal) (v : a) : toke 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 @@ -875,7 +850,6 @@ let token_of_terminal (type a) (t : a MenhirInterpreter.terminal) (v : a) : toke | 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 @@ -914,11 +888,9 @@ let token_of_terminal (type a) (t : a MenhirInterpreter.terminal) (v : a) : toke | 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 @@ -956,10 +928,8 @@ let token_of_terminal (type a) (t : a MenhirInterpreter.terminal) (v : a) : toke | 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 diff --git a/src/ocaml/preprocess/parser_raw.ml b/src/ocaml/preprocess/parser_raw.ml index f1b2c3e667..190b5b4887 100644 --- a/src/ocaml/preprocess/parser_raw.ml +++ b/src/ocaml/preprocess/parser_raw.ml @@ -10,19 +10,17 @@ module MenhirBasics = struct type token = | WITH - | WHILE_LWT | WHILE | WHEN | VIRTUAL | VAL | UNDERSCORE | UIDENT of ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 23 "src/ocaml/preprocess/parser_raw.ml" +# 22 "src/ocaml/preprocess/parser_raw.ml" ) | TYPE - | TRY_LWT | TRY | TRUE | TO @@ -30,9 +28,9 @@ module MenhirBasics = struct | THEN | STRUCT | STRING of ( -# 903 "src/ocaml/preprocess/parser_raw.mly" +# 876 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 36 "src/ocaml/preprocess/parser_raw.ml" +# 34 "src/ocaml/preprocess/parser_raw.ml" ) | STAR | SIG @@ -43,22 +41,22 @@ module MenhirBasics = struct | RBRACKET | RBRACE | QUOTED_STRING_ITEM of ( -# 908 "src/ocaml/preprocess/parser_raw.mly" +# 881 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 49 "src/ocaml/preprocess/parser_raw.ml" +# 47 "src/ocaml/preprocess/parser_raw.ml" ) | QUOTED_STRING_EXPR of ( -# 905 "src/ocaml/preprocess/parser_raw.mly" +# 878 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 54 "src/ocaml/preprocess/parser_raw.ml" +# 52 "src/ocaml/preprocess/parser_raw.ml" ) | QUOTE | QUESTION | PRIVATE | PREFIXOP of ( -# 889 "src/ocaml/preprocess/parser_raw.mly" +# 862 "src/ocaml/preprocess/parser_raw.mly" (string) -# 62 "src/ocaml/preprocess/parser_raw.ml" +# 60 "src/ocaml/preprocess/parser_raw.ml" ) | PLUSEQ | PLUSDOT @@ -66,9 +64,9 @@ module MenhirBasics = struct | PERCENT | OR | OPTLABEL of ( -# 882 "src/ocaml/preprocess/parser_raw.mly" +# 855 "src/ocaml/preprocess/parser_raw.mly" (string) -# 72 "src/ocaml/preprocess/parser_raw.ml" +# 70 "src/ocaml/preprocess/parser_raw.ml" ) | OPEN | OF @@ -81,19 +79,17 @@ module MenhirBasics = struct | MINUSDOT | MINUS | METHOD - | MATCH_LWT | MATCH | LPAREN | LIDENT of ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 91 "src/ocaml/preprocess/parser_raw.ml" +# 88 "src/ocaml/preprocess/parser_raw.ml" ) - | LET_LWT | LETOP of ( -# 847 "src/ocaml/preprocess/parser_raw.mly" +# 820 "src/ocaml/preprocess/parser_raw.mly" (string) -# 97 "src/ocaml/preprocess/parser_raw.ml" +# 93 "src/ocaml/preprocess/parser_raw.ml" ) | LET | LESSMINUS @@ -111,49 +107,49 @@ module MenhirBasics = struct | LBRACE | LAZY | LABEL of ( -# 852 "src/ocaml/preprocess/parser_raw.mly" +# 825 "src/ocaml/preprocess/parser_raw.mly" (string) -# 117 "src/ocaml/preprocess/parser_raw.ml" +# 113 "src/ocaml/preprocess/parser_raw.ml" ) | INT of ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 824 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 122 "src/ocaml/preprocess/parser_raw.ml" +# 118 "src/ocaml/preprocess/parser_raw.ml" ) | INITIALIZER | INHERIT | INFIXOP4 of ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 818 "src/ocaml/preprocess/parser_raw.mly" (string) -# 129 "src/ocaml/preprocess/parser_raw.ml" +# 125 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP3 of ( -# 844 "src/ocaml/preprocess/parser_raw.mly" +# 817 "src/ocaml/preprocess/parser_raw.mly" (string) -# 134 "src/ocaml/preprocess/parser_raw.ml" +# 130 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP2 of ( -# 843 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) -# 139 "src/ocaml/preprocess/parser_raw.ml" +# 135 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP1 of ( -# 842 "src/ocaml/preprocess/parser_raw.mly" +# 815 "src/ocaml/preprocess/parser_raw.mly" (string) -# 144 "src/ocaml/preprocess/parser_raw.ml" +# 140 "src/ocaml/preprocess/parser_raw.ml" ) | INFIXOP0 of ( -# 841 "src/ocaml/preprocess/parser_raw.mly" +# 814 "src/ocaml/preprocess/parser_raw.mly" (string) -# 149 "src/ocaml/preprocess/parser_raw.ml" +# 145 "src/ocaml/preprocess/parser_raw.ml" ) | INCLUDE | IN | IF | HASHOP of ( -# 900 "src/ocaml/preprocess/parser_raw.mly" +# 873 "src/ocaml/preprocess/parser_raw.mly" (string) -# 157 "src/ocaml/preprocess/parser_raw.ml" +# 153 "src/ocaml/preprocess/parser_raw.ml" ) | HASH | GREATERRBRACKET @@ -163,14 +159,12 @@ module MenhirBasics = struct | FUNCTOR | FUNCTION | FUN - | FOR_LWT | FOR | FLOAT of ( -# 830 "src/ocaml/preprocess/parser_raw.mly" +# 803 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 172 "src/ocaml/preprocess/parser_raw.ml" +# 167 "src/ocaml/preprocess/parser_raw.ml" ) - | FINALLY_LWT | FALSE | EXTERNAL | EXCEPTION @@ -182,25 +176,25 @@ module MenhirBasics = struct | DOWNTO | DOTTILDE | DOTOP of ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 188 "src/ocaml/preprocess/parser_raw.ml" +# 182 "src/ocaml/preprocess/parser_raw.ml" ) | DOTLESS | DOTDOT | DOT | DONE | DOCSTRING of ( -# 925 "src/ocaml/preprocess/parser_raw.mly" +# 898 "src/ocaml/preprocess/parser_raw.mly" (Docstrings.docstring) -# 197 "src/ocaml/preprocess/parser_raw.ml" +# 191 "src/ocaml/preprocess/parser_raw.ml" ) | DO | CONSTRAINT | COMMENT of ( -# 924 "src/ocaml/preprocess/parser_raw.mly" +# 897 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t) -# 204 "src/ocaml/preprocess/parser_raw.ml" +# 198 "src/ocaml/preprocess/parser_raw.ml" ) | COMMA | COLONGREATER @@ -209,9 +203,9 @@ module MenhirBasics = struct | COLON | CLASS | CHAR of ( -# 810 "src/ocaml/preprocess/parser_raw.mly" +# 783 "src/ocaml/preprocess/parser_raw.mly" (char) -# 215 "src/ocaml/preprocess/parser_raw.ml" +# 209 "src/ocaml/preprocess/parser_raw.ml" ) | BEGIN | BARRBRACKET @@ -222,9 +216,9 @@ module MenhirBasics = struct | ASSERT | AS | ANDOP of ( -# 848 "src/ocaml/preprocess/parser_raw.mly" +# 821 "src/ocaml/preprocess/parser_raw.mly" (string) -# 228 "src/ocaml/preprocess/parser_raw.ml" +# 222 "src/ocaml/preprocess/parser_raw.ml" ) | AND | AMPERSAND @@ -938,35 +932,8 @@ let merloc startpos ?endpos x = 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, [])) - - -# 970 "src/ocaml/preprocess/parser_raw.ml" +# 937 "src/ocaml/preprocess/parser_raw.ml" module Tables = struct @@ -976,266 +943,254 @@ module Tables = struct fun _tok -> match _tok with | AMPERAMPER -> - 132 - | AMPERSAND -> - 131 - | AND -> - 130 - | ANDOP _ -> - 129 - | AS -> - 128 - | ASSERT -> - 127 - | BACKQUOTE -> 126 - | BANG -> + | AMPERSAND -> 125 - | BAR -> + | AND -> 124 - | BARBAR -> + | ANDOP _ -> 123 - | BARRBRACKET -> + | AS -> 122 - | BEGIN -> + | ASSERT -> 121 - | CHAR _ -> + | BACKQUOTE -> 120 - | CLASS -> + | BANG -> 119 - | COLON -> + | BAR -> 118 - | COLONCOLON -> + | BARBAR -> 117 - | COLONEQUAL -> + | BARRBRACKET -> 116 - | COLONGREATER -> + | BEGIN -> 115 - | COMMA -> + | CHAR _ -> 114 - | COMMENT _ -> + | CLASS -> 113 - | CONSTRAINT -> + | COLON -> 112 - | DO -> + | COLONCOLON -> 111 - | DOCSTRING _ -> + | COLONEQUAL -> 110 - | DONE -> + | COLONGREATER -> 109 - | DOT -> + | COMMA -> 108 - | DOTDOT -> + | COMMENT _ -> 107 - | DOTLESS -> + | CONSTRAINT -> 106 - | DOTOP _ -> + | DO -> 105 - | DOTTILDE -> + | DOCSTRING _ -> 104 - | DOWNTO -> + | DONE -> 103 - | ELSE -> + | DOT -> 102 - | END -> + | DOTDOT -> 101 - | EOF -> + | DOTLESS -> 100 - | EOL -> + | DOTOP _ -> 99 - | EQUAL -> + | DOTTILDE -> 98 - | EXCEPTION -> + | DOWNTO -> 97 - | EXTERNAL -> + | ELSE -> 96 - | FALSE -> + | END -> 95 - | FINALLY_LWT -> + | EOF -> 94 - | FLOAT _ -> + | EOL -> 93 - | FOR -> + | EQUAL -> 92 - | FOR_LWT -> + | EXCEPTION -> 91 - | FUN -> + | EXTERNAL -> 90 - | FUNCTION -> + | FALSE -> 89 - | FUNCTOR -> + | FLOAT _ -> 88 - | GREATER -> + | FOR -> 87 - | GREATERDOT -> + | FUN -> 86 - | GREATERRBRACE -> + | FUNCTION -> 85 - | GREATERRBRACKET -> + | FUNCTOR -> 84 - | HASH -> + | GREATER -> 83 - | HASHOP _ -> + | GREATERDOT -> 82 - | IF -> + | GREATERRBRACE -> 81 - | IN -> + | GREATERRBRACKET -> 80 - | INCLUDE -> + | HASH -> 79 - | INFIXOP0 _ -> + | HASHOP _ -> 78 - | INFIXOP1 _ -> + | IF -> 77 - | INFIXOP2 _ -> + | IN -> 76 - | INFIXOP3 _ -> + | INCLUDE -> 75 - | INFIXOP4 _ -> + | INFIXOP0 _ -> 74 - | INHERIT -> + | INFIXOP1 _ -> 73 - | INITIALIZER -> + | INFIXOP2 _ -> 72 - | INT _ -> + | INFIXOP3 _ -> 71 - | LABEL _ -> + | INFIXOP4 _ -> 70 - | LAZY -> + | INHERIT -> 69 - | LBRACE -> + | INITIALIZER -> 68 - | LBRACELESS -> + | INT _ -> 67 - | LBRACKET -> + | LABEL _ -> 66 - | LBRACKETAT -> + | LAZY -> 65 - | LBRACKETATAT -> + | LBRACE -> 64 - | LBRACKETATATAT -> + | LBRACELESS -> 63 - | LBRACKETBAR -> + | LBRACKET -> 62 - | LBRACKETGREATER -> + | LBRACKETAT -> 61 - | LBRACKETLESS -> + | LBRACKETATAT -> 60 - | LBRACKETPERCENT -> + | LBRACKETATATAT -> 59 - | LBRACKETPERCENTPERCENT -> + | LBRACKETBAR -> 58 - | LESS -> + | LBRACKETGREATER -> 57 - | LESSMINUS -> + | LBRACKETLESS -> 56 - | LET -> + | LBRACKETPERCENT -> 55 - | LETOP _ -> + | LBRACKETPERCENTPERCENT -> 54 - | LET_LWT -> + | LESS -> 53 - | LIDENT _ -> + | LESSMINUS -> 52 - | LPAREN -> + | LET -> 51 - | MATCH -> + | LETOP _ -> 50 - | MATCH_LWT -> + | LIDENT _ -> 49 - | METHOD -> + | LPAREN -> 48 - | MINUS -> + | MATCH -> 47 - | MINUSDOT -> + | METHOD -> 46 - | MINUSGREATER -> + | MINUS -> 45 - | MODULE -> + | MINUSDOT -> 44 - | MUTABLE -> + | MINUSGREATER -> 43 - | NEW -> + | MODULE -> 42 - | NONREC -> + | MUTABLE -> 41 - | OBJECT -> + | NEW -> 40 - | OF -> + | NONREC -> 39 - | OPEN -> + | OBJECT -> 38 - | OPTLABEL _ -> + | OF -> 37 - | OR -> + | OPEN -> 36 - | PERCENT -> + | OPTLABEL _ -> 35 - | PLUS -> + | OR -> 34 - | PLUSDOT -> + | PERCENT -> 33 - | PLUSEQ -> + | PLUS -> 32 - | PREFIXOP _ -> + | PLUSDOT -> 31 - | PRIVATE -> + | PLUSEQ -> 30 - | QUESTION -> + | PREFIXOP _ -> 29 - | QUOTE -> + | PRIVATE -> 28 - | QUOTED_STRING_EXPR _ -> + | QUESTION -> 27 - | QUOTED_STRING_ITEM _ -> + | QUOTE -> 26 - | RBRACE -> + | QUOTED_STRING_EXPR _ -> 25 - | RBRACKET -> + | QUOTED_STRING_ITEM _ -> 24 - | REC -> + | RBRACE -> 23 - | RPAREN -> + | RBRACKET -> 22 - | SEMI -> + | REC -> 21 - | SEMISEMI -> + | RPAREN -> 20 - | SIG -> + | SEMI -> 19 - | STAR -> + | SEMISEMI -> 18 - | STRING _ -> + | SIG -> 17 - | STRUCT -> + | STAR -> 16 - | THEN -> + | STRING _ -> 15 - | TILDE -> + | STRUCT -> 14 - | TO -> + | THEN -> 13 - | TRUE -> + | TILDE -> 12 - | TRY -> + | TO -> 11 - | TRY_LWT -> + | TRUE -> 10 - | TYPE -> + | TRY -> 9 - | UIDENT _ -> + | TYPE -> 8 - | UNDERSCORE -> + | UIDENT _ -> 7 - | VAL -> + | UNDERSCORE -> 6 - | VIRTUAL -> + | VAL -> 5 - | WHEN -> + | VIRTUAL -> 4 - | WHILE -> + | WHEN -> 3 - | WHILE_LWT -> + | WHILE -> 2 | WITH -> 1 @@ -1322,14 +1277,10 @@ module Tables = struct 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 -> @@ -1404,16 +1355,12 @@ module Tables = struct 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 -> @@ -1490,8 +1437,6 @@ module Tables = struct Obj.repr () | TRY -> Obj.repr () - | TRY_LWT -> - Obj.repr () | TYPE -> Obj.repr () | UIDENT _v -> @@ -1506,28 +1451,26 @@ module Tables = struct Obj.repr () | WHILE -> Obj.repr () - | WHILE_LWT -> - Obj.repr () | WITH -> Obj.repr () and default_reduction = - (16, "\000\000\000\000\000\000\002\233\002\232\002\231\002\230\002\229\002\184\002\228\002\227\002\226\002\225\002\224\002\223\002\222\002\221\002\220\002\219\002\218\002\217\002\216\002\215\002\214\002\213\002\212\002\211\002\210\002\183\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\190\002\189\002\188\002\187\002\186\002\185\000\000\000\000\000\"\000\137\000\000\000\000\000\000\000\000\000\000\000\000\002\153\001b\000\000\000\000\000\000\000\000\000\000\000\000\000_\000Z\000\139\000\000\000\000\000\000\000\000\000\000\002\171\000\000\002r\002s\000\000\002p\002q\000\000\001\188\000]\001\167\001\185\001\184\000\000\001\189\001\193\000\000\000\000\000\000\001x\001w\000\000\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\183\001\187\001\186\001\168\001\191\001\182\001\181\001\180\001\179\001\178\001\176\001\192\001\190\000\000\000\000\000\000\000\233\000\000\000\000\001\171\000\000\000\000\000\000\001\173\000\000\000\000\000\000\001\175\001\197\001\194\001\177\001\169\001\195\001\196\000\000\003*\003+\000\000\000\000\000 \001V\000\000\000\229\000\230\000\000\000\000\000\000\001\221\001\220\000\000\000\000\000\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001v\000\000\000\000\000\000\000\000\000\000\003'\000\000\003\"\000\000\000\000\003$\000\000\003&\000\000\003#\003%\000\000\003\029\000\000\003\028\003\024\002@\000\000\003\027\000\000\002A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001T\000\000\000\000\000\000\000\000\000\000\000\000\000\236\000\017\000\016\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\001c\001a\001h\000:\002\135\000\000\001#\003\002\003\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\026\000\000\000\000\000\000\000\\\000\000\000\244\000\000\002t\000\000\000\000\000\000\001\201\000\000\000\000\000x\000\000\000\000\000\000\000\000\000\000\000\000\001g\000\000\001W\001f\000\000\001U\000W\000\027\000\000\000\000\001\142\000\024\000\000\000\000\000\000\000\000\000o\000\000\000\000\000\000\000\000\000\000\000\000\003\023\000\211\000p\000\142\000q\000\023\000\000\000\000\000\000\000\000\000\028\000\025\000\018\000\000\000r\000n\000\000\000\000\000\000\000\019\000\030\000\000\000\213\002J\002<\000\000\000u\000\000\002=\000\000\000\000\001\198\000\000\000\000\000\000\000\000\003\003\000\000\003\004\000\000\000\000\000t\000\000\000\000\000\000\000v\000\000\000w\000\000\000y\000\000\000\000\000z\0022\0021\000\000\000\000\000\000\000\000\000\000\000\000\000X\000\000\002\176\000[\000^\000Y\002\165\003,\002\166\001\254\002\168\000\000\000\000\002\173\002o\002\175\000\000\000\000\000\000\002\179\000\000\000\000\000\000\001\250\001\241\000\000\000\000\000\000\000\000\000\000\001\240\000\000\001\253\002\182\000\000\000\000\000\000\000\000\001\144\000\000\000\000\001\252\002\174\000f\000\000\000\000\000e\000\000\002\167\000\000\000\000\000\000\000\000\002\181\000\000\000\000\000\000\001\242\001\251\001\245\000\000\000d\000\000\002\180\000\000\002\178\000\000\002u\000\000\000\000\002T\002\177\000\000\000\000\000\000\000\000\001\203\001>\001?\002w\000\000\002v\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\255\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\006\000\000\000\000\000\000\000\000\000\000\000\000\000\253\002\005\000\254\000\000\000\000\000\000\000\203\000\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\214\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002.\000\000\000\000\001\127\000\000\000\000\000\000\000\000\000\000\000\000\003C\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\026\000\000\000\000\000\000\000\000\000\000\001~\000\000\000\000\000\000\001_\001\134\001^\001\131\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-\000\000\000\000\001}\000\000\000\215\000\000\000\000\001p\000\000\000\000\001t\000\000\001\223\000\000\000\000\001\222\001s\001q\000\000\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\000\000\000\000\000\000\000\000\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\002\000\000\000\204\002,\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0027\0025\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\001d\002\144\002\142\000\000\000\000\000\000\002\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\248\000\247\000\000\000\249\000\000\000\000\000\000\002\150\000\000\000\000\000\000\002|\000\000\000\000\000\000\000\000\003-\002\152\002\141\002\140\000\000\000\000\000}\001A\000\000\000\000\000\188\002X\000\000\000\000\000\000\000\000\000\173\000\000\000\000\000\000\000\187\000\000\000\172\000\000\000\171\000\000\000\177\000\000\000\181\000\000\000\175\000\000\000\174\000\000\000\179\000\000\000\170\000\000\000\169\000\000\000\168\000\000\000\167\000\000\000\166\000\000\000\180\000\000\000\178\000\000\000\000\000\000\002G\000\000\000\190\000\000\000\182\000\000\000\183\000\000\000\184\000\202\000\176\000\000\000\000\000\000\000\209\000\000\000\208\000\000\000\000\000\000\000\000\000\000\000\000\001\n\000\000\000\000\001\t\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\002\002\000\002\001\000\000\000\000\000\000\001\003\000\000\000\000\000\000\000\000\000\000\000\000\002\011\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001)\001\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\000\000\000\000\000\000\000\000\000\001\031\000\000\001k\002\251\000\000\000\000\002\250\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\000\000\000\000\000\000\000\0024\000\000\000\000\000\000\000\000\000\000\001\146\000\000\002\017\000\000\000\000\000\000\000\000\000`\000\000\000\000\000a\000\000\000\000\000\000\000\000\001\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\238\000\000\000\000\000j\000\000\000\241\000\239\000\000\000\000\000\000\000\218\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\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\002Z\000b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\157\001\153\000\000\000\000\000\000\000\223\000\000\000\000\002\031\002)\000\000\000\226\002\029\002\030\000\000\000\000\000\000\000\000\000\000\001\160\001\156\001\152\000\000\000\000\000\224\000\000\000\000\001\159\001\155\001\151\001\149\002)\000\000\000\228\000\000\000\000\002\019\000\000\000\000\002c\002(\002&\002'\000\000\000\000\000\000\002)\000\000\000\225\002)\000\000\000\227\000\000\000\000\000\000\000\000\002b\000\000\000\000\000\000\000\000\000\000\000\000\001\166\000\000\000\000\000\000\001\165\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\133\000\000\000\000\000\000\000\000\000\000\001y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001!\002h\000\000\000\000\000\000\002f\000\000\000\000\000\000\002e\000\000\001m\000\000\000\000\000\000\000\000\002l\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0035\000\000\000\000\000\000\000\145\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\000\000\001\140\000\000\000\000\000\000\000\000\000A\000\000\000\000\000\000\002\024\000\000\002\023\000\000\000\000\000\000\000\000\000B\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000G\000\000\000\000\000\000\000H\000F\000\000\000J\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000C\000\000\000I\000\000\000D\000E\000\000\0012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000V\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000S\000\000\000U\000T\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\027\002m\002^\000\000\002d\002_\002k\002j\002i\002g\001,\000\000\002\\\000\000\000\000\000\000\000\000\000\000\002)\000\000\000\000\001%\002`\000\000\000\000\000\000\000\000\000\000\000\000\002)\000\000\000\000\001'\002a\002]\002n\001+\002\b\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\0030\000\000\000\000\0032\000\000\000/\000\000\000\000\0038\000\000\0037\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003/\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\000\000\001S\000\000\000\000\001Q\001O\000\000\001\219\000\000\000\000\000\147\002\237\002+\000\000\0000\000\000\000\000\003;\000\000\003:\000\000\000\000\000\000\001M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\001P\001N\000\000\000\000\000\000\0002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\014\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000O\000\000\000\000\000\000\000\000\000\000\000\000\000,\000\000\000\000\000\000\000\000\000\000\0020\002/\000N\000\000\000*\001\015\000\000\0009\000&\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\r\000\000\000M\000\000\000\000\000P\000\000\000\000\001\205\000\000\000.\000\000\000\000\000\000\000-\000\000\000\000\000\000\0001\000\000\000Q\000\000\0003\0004\000\000\0014\000\000\000\000\000\000\000\000\000\000\000\000\0007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\025\002\254\002\245\000\000\000\000\000\000\000\000\000\000\000\000\001\011\002\249\002\234\002\244\002\253\002\252\000\000\001B\0010\000\000\001\012\000\000\002\242\000\000\002\246\002\243\002\255\002\007\000\000\000\000\002\239\000#\000\000\002\238\000\000\000\000\000\143\000\000\000\235\000\000\002\016\000\020\002F\000\000\000\000\002~\000\000\000\000\002}\000\000\000\000\000\000\000\000\002\128\000\000\000\000\002N\000\000\000\000\002\132\000\000\000\000\002\130\002\147\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\186\000\000\002\127\000\000\000\000\002\131\000\000\000\000\002\129\001\020\000\000\000\000\001\021\000\000\000\000\000\189\000\000\001\023\001\022\000\000\000\000\002\148\000\000\002\160\000\000\002\159\000\000\002\163\000\000\002\162\000\000\000\000\002\149\000\000\000\000\000\000\002\028\000\000\000\000\000\000\000\000\002W\002\027\000\000\002\156\000\000\000\000\000\000\001e\000\000\000{\000|\000\000\000\000\000\000\000\000\000\159\000\000\000\000\000\000\000\133\000\000\000\000\000\000\000\000\000\000\000\000\000\132\000\153\000\000\000\000\001D\000\000\001E\001C\0026\000\000\000\000\000\000\000\000\000\000\000\000\002\134\000\000\002\133\000\000\000\000\002x\000\000\000\000\002\155\000\000\000\000\000\000\002Q\002\146\000\000\002\145\000\000\002\161\000\152\000\000\000\000\000\000\000\000\000\151\000\000\000\000\000\000\000\000\000\000\000\000\000\149\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\150\002\236\001\018\001\217\000\000\000\251\000\252\000\000\000\000\000\000\000\000\000\000\000\000\001\b\000\000\000\000\000\000\000\000\001\007\000\000\000\000\001\006\001\005\000\000\001@\000\000\002\158\000\000\002\157\002\143\000\000\000\000\000\000\000\000\002\136\000\000\000\000\002\137\000\000\002z\000\000\002{\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\224\000\000\000\000\001\227\000\000\000\000\001\225\000\000\000\000\001\226\000\000\001\164\000\000\000\000\000\000\001\163\000\000\000\000\001/\001.\000\000\000\138\000\000\000\000\000\000\000\000\001L\001F\000\000\000\000\001G\001\162\000\000\001\161\000\000\000\000\000\212\000\000\000\000\000\000\000\029\000\026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\158\001\154\000\000\001\150\003\022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\140\000\000\002\248\002$\002%\002 \002\"\002!\002#\000\000\000\000\000\000\000\141\000\000\000\000\000\000\000\000\000\000\000\000\002\247\000\000\001n\000\000\000\000\000s\000\000\0033\000\000\001z\000\000\002\170\000\000\000;\000\000\000\000\000<\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\130\000\000\000\129\000\000\000\000\000\000\000\158\000\000\000$\000\000\000\000\000\000\000\000\000\131\000\000\000\231\000\001\000\000\000\000\000\234\000\002\000\000\000\000\000\000\001Y\001Z\000\003\000\000\000\000\000\000\000\000\001\\\001]\001[\000\021\001X\000\022\000\000\001\228\000\000\000\004\000\000\001\229\000\000\000\005\000\000\001\230\000\000\000\000\001\231\000\006\000\000\000\007\000\000\001\232\000\000\000\b\000\000\001\233\000\000\000\t\000\000\001\234\000\000\000\n\000\000\001\235\000\000\000\011\000\000\001\236\000\000\000\000\001\237\000\012\000\000\000\000\001\238\000\r\000\000\000\000\000\000\000\000\000\000\003\011\003\006\003\007\003\n\003\b\000\000\003\015\000\014\000\000\003\014\000\000\0016\000\000\000\000\003\012\000\000\003\r\000\000\000\000\000\000\000\000\001:\001;\000\000\000\000\0019\0018\000\015\000\000\000\000\000\000\003)\000\000\003(") + (16, "\000\000\000\000\000\000\003\014\003\r\003\012\003\011\003\n\002\221\003\t\003\b\003\007\003\006\003\005\003\004\003\003\003\002\003\001\003\000\002\255\002\254\002\253\002\252\002\251\002\250\002\249\002\248\002\247\002\220\002\246\002\245\002\244\002\243\002\242\002\241\002\240\002\239\002\238\002\237\002\236\002\235\002\234\002\233\002\232\002\231\002\230\002\229\002\228\002\227\002\226\002\225\002\224\002\223\002\222\000\000\000\000\000\"\000~\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\212\001\191\001\209\001\208\001\207\001\213\001\217\001\211\001\210\001\192\001\215\001\206\001\205\001\204\001\203\001\202\001\200\001\216\001\214\000\000\000\000\000\000\001\004\000\000\000\000\001\195\000\000\000\000\000\000\001\197\000\000\000\000\000\000\001\199\001\221\001\218\001\201\001\193\001\219\001\220\000\000\003N\003O\000\000\000\000\000 \001n\000\128\000\000\001\000\001\001\000\000\000\000\000\000\001\246\001\245\000\000\000\000\000\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003K\000\000\003F\000\000\000\000\003H\000\000\003J\000\000\003G\003I\000\000\003A\000\000\003@\003<\002]\000\000\003?\000\000\002^\000\000\000\000\000\000\000\000\000_\000\000\000\000\000]\000\000\000\000\001l\000\000\000\000\000\000\000\000\000\000\002\190\001z\000\000\000\000\000\000\000\000\000\000\000\000\002F\000\000\000\000\000\000\000\000\000\000\000\000\000Z\000\000\000\000\000\000\000\000\000\000\002\208\000\000\002\150\002\151\000\000\002\148\002\149\000\000\000\000\000\000\000\000\000\000\001\144\001\143\000\000\002\206\000\000\000\000\000\000\000\000\000\000\001\142\000\000\000\000\000\000\001\007\000\017\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001x\000\000\000\000\001{\001y\001\128\000:\002\172\000\000\001>\003&\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\001\015\000\000\002\152\000\000\000\000\000\000\001\225\000\000\000\000\000x\000\000\000\000\000\000\000\000\000\000\000\000\001\127\000\000\001o\001~\000\000\001m\000W\000\027\000\000\000\000\001\166\000\024\000\000\000\000\000\000\000\000\000o\000\000\000\000\000\000\000\000\000\000\000\000\003;\000\238\000p\000\131\000q\000\023\000\000\000\000\000\000\000\000\000\028\000\025\000\018\000\000\000r\000n\000\000\000\000\000\000\000\019\000\030\000\000\000\240\002k\002Y\000\000\000u\000\000\002Z\000\000\000\000\001\222\000\000\000\000\000\000\000\000\003'\000\000\003(\000\000\000\000\000t\000\000\000\000\000\000\000v\000\000\000w\000\000\000y\000\000\000\000\000z\002O\002N\000\000\000\000\000\000\000\000\000\000\000\000\000X\000\000\002\213\000[\000^\000Y\002\202\003P\002\203\002\027\002\205\000\000\000\000\002\210\002\147\002\212\000\000\000\000\000\000\002\216\000\000\000\000\000\000\002\023\002\014\000\000\000\000\000\000\000\000\000\000\002\r\000\000\002\026\002\219\000\000\000\000\000\000\000\000\001\168\000\000\000\000\002\025\002\211\000f\000\000\000\000\000e\000\000\002\204\000\000\000\000\000\000\000\000\002\218\000\000\000\000\000\000\002\015\002\024\002\018\000\000\000d\000\000\002\217\000\000\002\215\000\000\002\153\000\000\000\000\002x\002\214\000\000\000\000\000\000\000\000\001\227\001Y\001Z\002\155\000\000\002\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\026\001\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\241\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002K\000\000\000\000\001\151\000\000\000\000\000\000\000\000\000\000\000\000\003g\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\000\000\001\150\000\000\000\000\000\000\001w\001\158\001v\001\155\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002W\000\000\000\000\002X\002J\000\000\000\000\001\149\000\000\000\242\000\000\000\000\001\136\000\000\000\000\001\140\000\000\001\248\000\000\000\000\001\247\001\139\001\137\000\000\001\141\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\001\024\002\"\001\025\000\000\000\000\000\000\000\230\000\000\001\028\001\029\000\000\000\231\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\000\000\002T\002R\000\000\000\000\000\000\000\000\000\000\000\000\002\176\001|\002\181\002\179\000\000\000\000\000\000\002\191\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\201\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\200\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\019\001\018\000\000\001\020\000\000\000\000\000\000\002\187\000\000\000\000\000\000\002\161\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Q\002\189\002\178\002\177\000\000\000\000\000\203\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\229\000\000\000\000\000\000\000\000\000\000\000\000\000\202\000\201\000\000\000\000\000\000\000\236\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\017\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\000\000\002Q\000\000\000\000\000\000\001\"\000\000\000\000\001!\001 \000\000\001\244\000\000\000\000\000\136\003\018\002H\000\000\000\000\000\000\000\000\001%\000\000\000\000\001$\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\031\002\029\002\030\000\000\000\000\000\000\001\030\000\000\000\000\001D\000\020\001'\000\000\000\000\000\000\002\163\000\000\000\000\002\162\000\000\000\000\000\000\000\000\002\165\000\000\000\000\002q\000\000\000\000\002\169\000\000\000\000\002\167\002\184\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002M\002L\000\199\002r\000\000\002\164\000\000\000\000\002\168\000\000\000\000\002\166\001/\000\000\000\000\0010\000\000\000\000\000\204\000\000\0012\0011\000\000\000\000\002\185\000\000\002\197\000\000\002\196\000\000\002\200\000\000\002\199\000\000\000\000\002\186\000\000\000\000\000\000\0029\000\000\000\000\000\000\000\000\002{\0028\000\000\002\193\000\000\000\000\000\000\001}\000\000\000{\000|\000\000\000\000\000\000\000\000\000\152\000\000\000\142\000\000\000\000\001\\\000\000\001]\001[\002S\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\171\000\000\002\170\000\000\000\000\000\000\000\000\000\000\002\157\000\000\002\156\000\000\000\000\002\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002u\002\183\000\000\002\182\000\000\002\198\000\141\000\000\000\000\000\000\000\000\000\140\000\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\000\001\131\000\000\000\000\000\000\000`\000\000\000\000\000a\000\000\000\000\000\000\000\000\001\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\t\000\000\000\000\000j\000\000\001\012\001\n\000\000\000\000\000\000\000\245\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\139\000b\000\000\000\000\0027\000\000\000\000\001&\001\242\000\000\001\022\001\023\001-\000\000\000\000\000\000\000\000\000\000\002\195\000\000\002\194\002\180\000\000\000\000\000\000\000\000\002\173\000\000\000\000\002\174\000\000\002\159\000\000\002\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\250\000\000\000\000\002\000\000\000\000\000\001\252\000\000\000\000\001\254\000\000\001\249\000\000\000\000\001\255\000\000\000\000\001\251\000\000\000\000\001\253\000\000\001\188\000\000\000\000\000\000\001\187\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\156\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001:\003\031\000\000\000\000\003\030\000\000\000\000\000\000\000\000\000\000\002(\000\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\000\000\000\000\000\000\001\170\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\003\016\000\000\000\000\002~\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\190\000\000\000\000\000\000\001\189\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\157\000\000\000\000\000\000\000\000\000\000\001\145\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001<\002\140\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002\137\000\000\001\133\000\000\000\000\000\000\000\000\002\144\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003Y\000\000\000\000\000\000\000\134\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000>\000\000\000\000\000\000\000\000\001\165\000\000\001\164\000\000\000\000\000\000\000\000\000A\000\000\000\000\000\000\0025\000\000\0024\000\000\000\000\000\000\000\000\000B\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000G\000\000\000\000\000\000\000H\000F\000\000\000J\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000C\000\000\000I\000\000\000D\000E\000\000\001M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0018\000V\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000S\000\000\000U\000T\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0016\002\145\002\130\000\000\002\136\002\131\002\143\002\142\002\141\002\139\001G\000\000\002\128\000\000\000\000\000\000\000\000\000\000\002F\000\000\000\000\001@\002\132\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\181\001\177\000\000\000\000\000\000\000\250\000\000\000\000\002<\002F\000\000\000\000\001B\002:\002;\000\000\000\000\000\000\000\000\000\000\001\184\001\180\001\176\000\000\000\000\000\251\000\000\000\000\001\183\001\179\001\175\001\173\002\133\002\129\002\146\001F\002%\002\127\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003T\000\000\000\000\003V\000\000\000/\000\000\000\000\003\\\000\000\003[\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003S\000\000\000\000\003U\000\000\000\000\000\000\0020\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001k\000\000\000\000\001i\001g\000\000\0000\000\000\000\000\003_\000\000\003^\000\000\000\000\000\000\001e\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001j\000\000\000\000\001h\001f\000\000\000\000\000\000\0002\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\000O\000\000\000\000\000\000\000\000\000\000\000\000\000,\000\000\000\000\000N\000\000\000*\001*\000\000\0009\000&\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001(\000\000\000M\000\000\000\000\000P\000\000\000\000\001\229\000\000\000.\000\000\000\000\000\000\000-\000\000\000\000\000\000\0001\000\000\000Q\000\000\0003\0004\000\000\001O\000\000\000\000\000\000\000\000\000\000\000\000\0007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0014\003\"\003\025\000\000\000\000\003\029\003\015\003\024\003!\003 \001K\000\000\000\000\003\022\000\000\003\026\003\023\003#\002$\000\000\000\000\003\020\000#\003\019\000\000\000\000\000\132\000\000\001\006\000\000\000\000\001J\001I\000\000\001\134\000\000\000\000\002\207\000\000\000;\000\000\000\000\000<\000\000\000\000\002\175\000\000\000\000\000\000\000\000\002-\000\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\129\000\000\003\028\002A\002B\002=\002?\002>\002@\000\000\000\000\000\000\000\130\000\000\000\000\002F\000\000\000\254\000\000\000\000\000\000\000\000\003\027\000\000\000\127\000\000\000\000\000\000\000\000\001d\001^\000\000\000\000\001_\001\186\000\000\001\185\000\000\000\000\000\239\000\000\000\000\000\000\000\029\000\026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\182\001\178\000\000\001\174\003:\000\000\002F\000\000\000\253\000\000\000\000\000\000\000\000\002\135\002E\002C\002D\000\000\000\000\000\000\002F\000\000\000\252\000\000\000\000\000\000\000\000\002\134\000\000\001\146\000\000\000s\000\000\003W\000\000\000$\000\000\000\000\000\000\000\000\000\151\000\000\001\002\000\001\000\000\000\000\001\005\000\002\000\000\000\000\000\000\001q\001r\000\003\000\000\000\000\000\000\000\000\001t\001u\001s\000\021\001p\000\022\000\000\002\001\000\000\000\004\000\000\002\002\000\000\000\005\000\000\002\003\000\000\000\000\002\004\000\006\000\000\000\007\000\000\002\005\000\000\000\b\000\000\002\006\000\000\000\t\000\000\002\007\000\000\000\n\000\000\002\b\000\000\000\011\000\000\002\t\000\000\000\000\002\n\000\012\000\000\000\000\002\011\000\r\000\000\000\000\000\000\000\000\000\000\003/\003*\003+\003.\003,\000\000\0033\000\014\000\000\0032\000\000\001Q\000\000\000\000\0030\000\000\0031\000\000\000\000\000\000\000\000\001U\001V\000\000\000\000\001T\001S\000\015\000\000\000\000\000\000\003M\000\000\003L") 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\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\"\001@0$r\000\000\n\001@\001\140\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\128\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\001\128\000\000\016\000\000\000@\000\000\000\000\000\000\000\000\012\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\001\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\016\002\002\000\001\003\002\000\000\000\016\000\000\000\000\000B@\n\160\002\012\021!\192\001\016\000\236\b\025\000 \018\000A\000\016@\001\n\000\b\000\006 \000\b\000\000\144\002\b\000\130\000\b@\000@\0001\000\000@\000\000\000\000\000 \0000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\004\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\128\007\224\012\t\000\000\248\132\000\129\000 Q`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\002\128\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\000\000\000\000\000\000\000\000\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\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\t\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\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\136\000\000\000\000\000\000\000\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\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\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\192\000\014\002\000\012.\016\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\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\005\128Y\208\004\025\026C\129\131\"\001\216\017\"\017@\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\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\001\128\000\028\004\b\024\\ \000\016\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\001\000 \0160 \128\000\001\000\000\000\000\000\000\b\001\001\000\000\129\129\004\000\000\b\000\000\000\000\000\000@\b\b\000\004\012\b\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\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\000\000\000\000\000\000\000\000\000\000\000g\240\144b\197V\254f\250\002\128\251\137@\003\142\003?\132\131\022*\183\2433\208\020\007\220J\000\028p\000\192\000\004\152 \140\000 \004\000\000\000\000\000\002\000\006\000\000$\129\004`\001\000 \000\000\000\000\000\016\0000\000\001$\b#\000\000\001\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\000@\000\000\000\000\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\000\018@\0020\000\000\016\000\000\000\000\000\b\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\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\001\000\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\002\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\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\016\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\002\000\000\018@\002\000\000\000\016\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\004\000\000\000\000\000\000\000\000\000\000\t\000\"\130\b \020\134\000\004@\003\176\002\004\000\1281\000\003\192\128\003\011\133\000\002\000 \002\000\001\000\002@\b\160\003\b\021!\192\001\016\000\204\b\131\b \012@\000\224 \000\194\225@\000\128\b\000\128\000@\000`\000\135\001\002\006\023\b\000\004\000\000\000\001\000\000\133\128]\192\004\025\026C\129\130\"\001\216\001f\017`\024\000\001\128\000\001\133\194\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\006\000\000`\000\000ap\128\000D\000\000@\000\000\000\016\000\128\000\000\001\000\000\000\002 \000\000\000@\000\001\128\000\028\004\000\024\\ \000\016\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\192g\240\145b\197V\254fz\002\128\251\153@\003\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\0000\016\002\002\000\002\002\b\000\000\016\000\000\000\000\128\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\000\000\000\000\000\000` \004\000\000\004\004\000\000\000 \000\000\000\000\000\007\001\000 \000\000 \000\000\001\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\128\002\000\000\000@\000 \001\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\b\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\002\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\191\214\239\2517\223\251\255\254N\143\238e\132\014y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\2241\184@\017p\163\127\018}\000@}\000\160\000\199\001\141\194\000\139\005\027\248\147\232\002\003\232\005\000\0068\012n\016\004X(\223\196\143@\016\031@(\0001\192cp\196#\241V\254\164z|\194\250A\192\025\174\176\024\132!\016\n\001\129#\144\000\000P\n\000\012`\024\220 \b\176Q\191\137\030\128 >\128P\000s\129\015=\187\215\250\190w\207\239\254\220\031\191\182\255\249\2307\b\002,\020o\226G\160\b\015\160\020\000\024\224\001\136A\0160\001\024\018m\000\016\005\000\000\000\130\000\012B\b\129\000\b\192\147h\000\128(\000\000\004\016\000b\016D\b\000F\004\139@\004\001@\000\000 \128\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\000P\000\000\b \000\196 \b\016\000\140\t\022\128\b\002\160\000\000Q\000\006!\002@\128\004`H\180\000@\021\000\000\002\b\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\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\000D\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\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\004\000\000\000\000\000\000\002\000\000\000\001\000\000\000\000\0000\024@\000\000\000\000\000\000\000\000\024\000\001\192@\129\133\194\000\001\000\000\000\000\000\000\000\192\000\012\000\000\012.\016\000\b\000\000\000\000\000\000\000\000\000\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\011\000\187\128\b24\135\003\004D\003\176\002\196\"\1920\000\003\000\000\003\011\132\000\002\000\000\000\000\000\000B\192.\224\002\012\141!\192\193\017\000\236\000\177\b\176\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\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\000B@\014\224\002\012\133!\192\193\017\000\236\000\177\b\160\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\000\000\000\000\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\001\000\000\000\000\000\128\000\002\000\000\000\000\017 \000\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\004H\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\b\000\000 \000\000\000\001\000\000\000\000\128\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\002\000\003\000\0008\b\0000\184@\000 \000\000\000\000\004\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\000\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\001\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\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\000\000\000\000\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\138F\212$\005\024\018k\000\144\005(\0166\170\128\000\002\000\001\000\b\000\000\b\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\004\197#j\018\002\140\t7\128H\002\180\004\027U@\002\000\000\000\000\000@\b\160\000\000\000\000\000\000\000\0001\bB\004\000#\002E\160\002\000\168\000\000\144@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012B\000\129\128\b\192\147h\000\128*\000\000\004\016\000b\016\004\b\000F\004\155@\004\001P\000\000 \128\003\016\128 @\0020$Z\000 \n\128\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\027\000\000\016\000\001\000\002\000\000\160\000\152\162\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\012B\000\129\000\b\192\145h\000\128*\000\000\004\016\002\000\001\176\000\001\000\000\016\000 \000\n\000\t\138 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\152\132m\002\000Q\129&\208\t\000V\128\002j\168\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0011\b\218\004\000\163\002M\160\018\000\173\000\004\213P\001\200b\017\248\011\026R->1\005`@\012\150X\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\002\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\196 \b\016\000\140\t\020\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\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\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\004\000\000\000\000\000\002`\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\000\016\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\003\016\128 @\0020$Z\000 \n\128\000\001\004\000\128\000l\000\000@\000\004\000\b\000\002\128\002b\136\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\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\128\000\000\000\000\000H\017\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\196 H\016\000\140\t\022\128\b\002\160\000\000A\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\002\000\000\000\000\000\001!D\000b\016$\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\000\000\002 \000\000\000\000 \000\000\000\000\000\018\004@\000\000\017\000\000\000\000\000\000\000\000\000\000\000\000\000\0000\000\b\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000yI\022\132\193#\166}`2\000\189\128\006\241T\000\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\000\000\128\000\000\000\000\000\000\000\000\b\000\000\128\000\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000\000\000 \000\000\000\000\004\000\000\000\002\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\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\128\000\000\000\000\000\000\000\000\b\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\024\132\001\002\000\017\129\"\208\001\000P\000\000\b \000\197 \n\018\000\140\t5\128H\002\144\000\019E`\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\001\136@\016 \001\024\018-\000\016\005@\000\000\130\000\000\000\016\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\004\000\000\000\000\000\128\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\196 \b\016\000\140\t\020\128\b\002\128\000\000A\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\001\136A\0162\t\024\018m\000\016\005@\000\000\130\000\012\004\000\128\128\000\128\130\000\000\004\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000 \004\004\000\002\006\004\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@\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 \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\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\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\000\000\000\000\000\000\000 \000\b\000\000\004\000\128\128\000@\192\128\000\000\004\000\000\000\000\000\016\144\002\168\000\131\001Hp\000D\000;\000\004@\b\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\128\000\000\000@\000\000\000\000\004\000\000\000\000\000\000\000\000\000\001\t\000*\128\b0T\135\000\004@\003\176 d\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\001\000 \000\0160 \000\000\001\000\000\000\000\000\004$\000\170\000 \192R\028\000\017\000\014\192\001\016\002\000@\b\b\000\004\012\b\000\000\000@\000\000\000\000\001\t\000*\128\b0\020\135\000\004@\003\176\000D\000\128\000\000\000\000\000\000\000\000\000\000\000\004\001\001\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\018\000U\000\016`\169\014\000\b\128\007`@\136\001\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\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\001\t\000*\128\b0\020\135\000\004@\003\176\000D\000\128\b\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\016\144\002\168\000\131\001Hp\000D\000;\000\004@\b\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 \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\000\000\000\000\000\000\128\000\000\000\000\000\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\016\144\002\168\000\131\005Hp\000d\000;\000\004\192\b\007\001\004 \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\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\000\000\000\000\000\000\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\1290\002\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\002\000\000\000\000\000\000\0067\b\002,\020o\226G\160\b\015\160\020\000\024\2241\184@\145`\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\001\000\000\000\000\000\000\000\001\000\b\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\024\132\001\016\n\001\129#\144\000\000P\n\000\012` \000\002 \000\000\000\000\000\000\024\000\016$\t\000\000\006!\000D\002\128`H\228\000\000\020\002\128\003\024\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\001\136@\017\016\160\024\018y\000\000\005\000\160\000\198\000\012B\000\136\005\000\192\147\200\000\000(\005\000\0060\000b\016\004@(\006\004\142@\000\001@(\0001\128cp\128\"\225F\254$\250\000\128\250\t@\001\142\003\027\132\001\022\n7\241'\208\004\007\208J\000\012p\024\220 \b\176Q\191\137\030\128 >\130P\000c\128\198\225\000E\194\141\252I\244\001\001\244\002\128\003\028\0067\b\002,\020o\226O\160\b\015\160\020\000\024\2241\184@\017`\163\127\018=\000@}\000\160\000\199\000\012B\000\129\128\b\192\147h\000\128*\000\000\004P\000b\016\004\b\000F\004\155@\004\001P\000\000\"\128\003\016\128 @\0020$Z\000 \n\128\000\001\020\000\024\132\001\002\000\017\129\"\208\001\000T\000\000\b \004\000\000\000\000\002\000\000 \000\000\000\000\000\018\004@\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\0001H\002\134\128#\002M`\002\000\160\000\000\016@\001\138@\020$\001\024\018k\000\016\005\000\000\000\130\000\012R\000\161 \b\192\145X\000\128(\000\000\004\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\020\128(H\n0$V\000 \n@\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\016\000\000\000\000\000\000\000\000\b\000\0000\000\003\000\000\003\011\132\000\002\000\000\000\000\000\000\000\128\000\000\000\004\b\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\012n\016\004X(\223\196\143@\016\031@(\0001\192\003\016\128 `\0020$\218\000 \n\128\000\001\020\000\024\132\001\002\000\017\129&\208\001\000T\000\000\b\160\000\196 \b\016\000\140\t\022\128\b\002\160\000\000E\001\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\2241\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\000\000\000\000\000\000\000\000\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\n\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\245|\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\136P\012\t<\128\000\002\128P\000c\000\006!\000D\002\128`I\228\000\000\020\002\128\003\024\0001\b\002 \020\003\002G \000\000\160\020\000\024\192BE.\224\250\015\133a\192\255\183\002\239M\1918x\012B\000\136\005\000\192\145\200\000\000(\005\000\0060\016\243\219\189\127\171\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\000\196 \b\024\000\140\t6\128\b\002\160\000\000E\000\006!\000@\128\004`I\180\000@\021\000\000\002(\0001\b\002\004\000#\002E\160\002\000\168\000\000\017@BE.\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\243\219\189\127\171\231\\\254\255\237\193\251\251o\255\158\000\000\000\000\000\0000\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\t\000\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\200\000\000\000\000\b\000\000\000\004\000\000\000\000\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\000\000\000\0002\000\000\000\000\002\000\000\000\001\000\000\128\000\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\012\128\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\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\012B\000\136\005\000\192\145\200\000\000(\005\000\0060\016\243\219\189\127\171\231\\\254\255\237\193\251\251o\255\190\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\018)w\007\208|+\014\007\252\184\023x-\249\195\204n\016\004X(\223\196\143@\016\031@(\0001\192\135\158\221\235\253_:\231\247\255n\015\223\219\127\252\244$R\238\015\160\248V\028\015\251p.\244\219\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\001\012n\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\000\000\000\000\000\000\000\000\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\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\018)w\007\208|+\014\007\252\184\023x-\249\195\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\000\001\015=\187\215\250\190u\207\239\254\220\031\191\182\255\249\232H\165\220\031A\240\1728\031\246\224]\233\183\231\0151\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\012n\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\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\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\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\012n\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\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\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\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\012n\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\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\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\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\012n\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\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\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\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000b\016\004\b\000F\004\155@\004\001@\000\000 \128\003\016\128 @\0020$Z\000 \n\000\000\001\004\000\000\000\000\000\000\000\000\004\000\000\000\002\000\002`\136\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\002\000\000\000\001\000\001 D\012n\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\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\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\001\136@\016 \001\024\018-\000\016\005@\000\000\130\000\000\000\000\000\000\000\000\002\000\000\000\001\000\001 D\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\000\000\000\000\000\000\000\000\000\000\000\144\002(\000\130\001H`\000d\0003\000\000@\b\189\187\"\004\023\241R\000\t\131\129\211\142\011\002\131C?\132\139V*\183\2433\208\020\007\220\n\000\224P\001\227\129{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\001\128\128\016\016\000\016\016@\000\000\128\000\000\000\000\000\012\004\000\128\000\000\128\130\000\000\004\000\000\000\000\000\000` \004\000\000\004\004\000\000\000 \000\000\000\000\000\004\128\017@\004\016*C\128\002 \001\152\000\002\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\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\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\002\000\000\012\000\000\224 \000\194\225\000\000\128\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\002\000\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\192\000\014\002\000\012.\016\000\b\000\000\000\000\000\000\t\000\"\128\b\"\020\135\003\004@\003\176\002\004\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\018\002E\000\016@)\012\000\b\128\006`\000\b\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 \001\152\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004P\001\004B\144\224`\136\000v\000@\128\000\002 \000\000@\000@\001\128\000\000\004\000\000\000\000\000\017\000\000\000\000\002\000\012\000\000\000 \000\000\000\000\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\128\000\000\000\000\000\000\000\000\000\000\001\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\t\000\"\128\012 \020\135\000\004@\003\176\000\012\000\0000\000\003\000\000\003\011\133\000\002\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\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\000\000\000\004\000\000\000\000\000\000\000\000\000\004\000\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\000\000\000\016\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\016\000\004\002\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\000D\000\000\000\000\004\000\000\016\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\b\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\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 \128\017\000\000\000\000\002\000\004\000\000\000 \000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\004\000\000\018\000E\000\016@)\014\000\b\128\006`@\b@\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\138\000 \128R\028\000\017\000\012\192\000\016\000\001 \004P\001\004\002\144\192\000\136\000f\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0000\000\003\000\000\003\011\133\000\002\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\b\000\000\000\012\000\000\192\000\000\194\225@\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\0000\000\0000\184@\000 \000\000\000\000\000\000,\000\138\000 \128\210\028\000\025\000\012\192\b\016\130\001`\020P\001\006\006\144\224\000\200\000f\000@\132\016\000\000\000\000\000\016\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\002\192\b\160\002\b\r!\192\001\144\000\204\000\129\b \022\001E\000\016`i\014\000\012\128\006`\004\bA\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\000\"\240\024 a\244\128\004@\003\000\000\004\000\0000\000\001&\b#\000\b\001\000\000\000\000\000\000\128\001\128\000\t A\024\000@\b\000\000\000\000\000\004\000\012\000\000I\002\b\192\000\000@\000\000\000\000\000 \000`\000\002H\000F\000\000\002\000\000\000\000\000\001\000\001\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000$\000\138\b \128\002\024\000\016\000\014\192\b\144\002\000\196\000\015\002\000\012.\020\000\b\000\128\b\000\004\000\006\000\002p\016\000ap\128\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\144\017@\004\016*C@\002 \003\152\001\002\000@$\000\138\0000\128R\028\000\017\000\012\192\b0\130\001 \004P\001\004\002\144\224\000\136\000f\000@\132\016\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\004\128\017@\004\016\000C\000\002\000\001\152\001\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\000H\001\020\000A\000\1648\000\"\000\029\128\016 \004\000\136\000\002\000\000\016\000(\000\000\001\000\016\000\b\000\004@\000\000\000\000\128\001@\000\000\b\000\128\000@\000\000\000\000\000\004\002\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\000H\001\020\000a\000\1648\000\"\000\025\128\016a\004\002@\b\160\002\b\005!\192\001\016\000\204\000\129\b \000\000\000\000\000\000\000\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\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\018\000E\000\016@)\012\000\b\128\006`\004\b\001\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\b\128\000 \000\001\000\002\000\000\000\016\000\000\000\128\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 \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\000\000\000\000\000\000\000\000\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\001 \004PA\004\000\016\192\000\128\000v\000D\128\016\006 \000x\016\000ap\160\000@\004\000@\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\b\160\002\b\000!\128\001\000\000\204\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\004\128\017@\004\016\nC\000\002 \001\152\001\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\b\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\002@\b\160\002\b\000!\128\001\000\000\204\000\001\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\000@\000\001\000\000\000 \000\000\000\128\000\000\000\000\000\000\b\000\b\000\000\001\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\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\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\224\000\128\b\000\000\000 \000\000\000\000\000\000\000\000\002\000\000\000@\000 \001\000\000\000\000\000\000\000\000\000\016\000\000\000\000\001\000\b\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\000\016@\001\012\000\b\000\007`\000H\000\000 \004\004\000\002\006\004\000\000\000 \000\000\000\000\000\132\128\017@\004\024\000C\128\002\000\001\152\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\192\000\128\000\000\000\000 \000\000\000\000\000\000\000\000\006\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\004\000\001@\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000E\000\016@\129\012\000\b\000\006`@\b\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\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\t\000\"\128\b0\000\135\000\004\000\0030\000\004\000\128H\001\020\000A\000\004 \000 \000\025\128\000 \004\001\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\001\000 \000\0160 \000\000\001\000\000\000\000\000\004$\000\138\000 \192\002\028\000\016\000\012\192\000\016\002\001 \004P\001\004\000\016\128\000\128\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\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\144\002(\000\130\000\b`\000@\0003\002\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\001\001\000\000\129\129\000\000\000\b\000\000\000\000\000! \004P\001\006\000\016\224\000\128\000f\000\000\128\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\000\000\000\000\000\000\016\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\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! \004P\001\006\000\016\224\000\128\000f\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017\000\000\002\000\002\000\012\000\000\000 \000\000\000\000\000\136\000\000\000\000\016\000`\000\000\001\000\000\000\000\000\004@\000\000\000\000\128\001\000\000\000\b\000\000\000\000\000\144\002(\000\194\000\bp\000@\0003\000\000\192\000\b\128\000\000 \000\016\000\192\000\000\000\000\000\000\000\000@\000\000\001\000\000\128\006\000\000\000\000\000\000\000\000\002\000\000\000\000\000\004\0000\000\000\000\000\000\000\000\000\016\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\b\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\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\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\002\000\000@\002\000$@\128\000\000\000\000\000\000\000\000@\000\004\000\000\018\004(\b\000\000\000\128\016\000\000\002\000\000 \000\000\144!\000@\000\000\004\000\128\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\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\002\000\000\000\000\b\004\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\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\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\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\004\000\000\002\000\000\b\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\128\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\000\000\000\000\000\000\000\000\000\000\000\000 \000\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\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\001\000\000 \001\000\018 \192\000\000\000\000\000\000\000\000\b\000\001\000\b\000\145\002\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\002\000\000\000\000\000\000\001\000\000\000\000\000\000\000\016\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\004\000\000\000@\000\000\000 \000\004\000 \002D\b\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\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\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\000\004\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\170\000 \136R\028\004\017\000\014\192\b\016\002\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\t\016 \000\000\000\000\000\000\000\000\018\000U\000\016D)\014\002\b\128\007`\004\b\001\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\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\000\000\000\000\000\000\000\001\000\000\000\000\128\000\000\000\0000\000\003\128\128\003\011\132\000\002\000\000\000\000\000\000\002\000\000 \000\000\128!\192\192\000\000\004\000\128\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\b\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\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\000\000\000\000\002\000\000 \000\000\128!\000@\000\000\004\000\128\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@\b\004\128\017@\004\016\nB\000\002 \001\152\000\002\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\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\004\000\000\128\004\000H\129\000\000\000\000\000\000\000\000\000\144\002(\000\130\001Hp\000D\0003\000\000@\b\004\128\017@\004\016\nB\000\002 \001\152\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\016\000\000\000\000\000 \001\128\000\000\000\000\000\000\000\000\128\000\000\000\000\001\000\004\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\128\000\003\000\0008\t\0002\184@\000 \000\000\000\000\000\000,\002\170\000 \192\130\028\000\017\000\014\192\0000\002\000\192\000\012\000\000\012.\016\000\b\000\000\000\000\000\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\028\004\000\024\\ \000\016\000\000\000\000\n\000\000\000\004\000\000\000\000\002\000\000\000\000\000\001\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\128\000\001\133\194\000\001\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\006\000\000p\018\000ep\128\000@\000\000\000\000\000\000X\005T\000A\129\0048\000\"\000\029\128\000 \004\002\192*\160\002\012\b!\192\001\016\000\236\000\001\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\144\002\168\000\130\000\bp\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\001 \004P\001\004\000\016\192\000\128\000f\000\000\128\016\t\000\"\128\b \000\132\000\004\000\0030\000\004\000\128\128\000\000\000\000\001\000\012\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@\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\000\000\000\000\000\000\000\000\000\004\000\000\024\000\001\192H\001\149\194\000\001\000\000\000\000\000\000\001 \004P\001\004\000\016\192\000\128\000f\000\000\128\016\t\000\"\128\b \000\132\000\004\000\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\138\000 \128\002\016\000\016\000\012\192\000\016\002\000\128\000\004\144\000\140\000 \004\000\000\000\000\000\002\000\004\000\000$\128\004`\000\000 \000\000\000\000\000\016\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\002@\b\160\002\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\004\128\017@\004\016\nB\000\002 \001\152\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\t\000\"\128\b \000\132\000\004\000\0030\000\004\000\128 \000\001$\000#\000\b\001\000\000\000\000\000\000\128\001\000\000\t \001\024\000\000\b\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\002\000\000\003\016\000<\b\0000\184P\000 \002\000 \000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \004P\001\004\000\016\192\000\128\000f\000@\128\016\t\000\"\128\b \000\132\000\004\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\001\000\000\000\000\000\000\000\000\000\136\000\000\002\000\001\000\012\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@\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( \000@\000\b\000@\012\136\016\000\000\016\000\000\000\000\000\b\000\000\128\000\002@\133\003\000\000\000\016\002\000\000\000@\000\004\000\000\018\004 \024\000\000\000\128\016\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\001\000\000\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\000\000\000\000\000\000\000\000\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\t\000\000\000\000\000\000\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\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\000\000\000\000\000\000 \000\002\000\000\b\002\024\012\000\000\000@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\b\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\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\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\001\138@\020$\001\024\018+\000\016\005 \000\002\130\000\014\000\000\224 \000\194\225\000\000\128\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\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\003\027\132\001\022\n7\241'\208\004\007\208\n\000\012p\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\004\000\004\000\000\128\004\000\200\131\000\000\001\000\000\000\000\000\000 \000\004\000 \006D\b\000\000\b\000\000\000\000\000\001\000\000 \001\0002 @\000\000@\000\000\000\000\000\024\132\017\003 \017\129&\208\001\000P\000\000\b /n\200\129\005\252T\128\002`\224t\227\130\192\160\208\006!\004@\128\004`I\180\000@\020\000\000\002\b\0001\b\"\004\000#\002E\160\002\000\160\000\000\016@\001\136@\016 \001\024\018-\000\016\005\000\000\000\130\000\000\000\000\000\000\000\000\004\000\004\000\000\000\000\000\001\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\128\000\000\000\000\000\000\b\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\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000 \000\000\000\016\000\002\000\016\003\"\004\000\000\004\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\000\000\000\000\000\000\001\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\024\164\001B@\017\129&\176\001\000P\000\000\b \000\197 \n\018\000\140\t\021\128\b\002\128\000\000A\000\006)\000P\144\020`H\172\000@\020\000\000\002\b\000\016\000\002\000\016\003\"\004\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000 \004\000\000\128\004\000\200\129\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\007\148\149j\rQ:g\247\130 \011\153A\007\141@\024\132\001\016\n\001\129#\144\000\000P\n\000\012`!\231\183z\255W\206\185\253\255\219\131\247\246\223\255}\015=\187\215\250\190u\207\239\254\220\031\191\182\255\251\224yIV\160\213\019\166\127x\"\000\185\148\016x\212\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\021@\004\017\nC\129\130 \001\152\001\006\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\t\000*\128\b\"\020\135\003\004@\0030\002\012\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\018\000U\000\016D)\014\006\b\128\006`\004\024\005\000 \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\001\145\002\000\000\002\000\000\000\000\000\001 \005P\001\004B\144\224`\136\000f\000A\128P\006!\004@\128\004`H\180\000@\020\000\000\002\b\0001\b\002\004\000#\002E\160\002\000\160\000\000\016@\000\000\000\000\000\000\000\000\128\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\128\000\000\000\000\016\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\024\000\001\192H\001\149\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\000\000@\000\004\000\000\016\0048\024\000\000\000\128\016\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\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\b\000\001\000\b\001\145\002\000\000\002\000\000\000\000\000\001\000\000\016\000\000@\016\224`\000\000\002\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\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\001\000\000\004\001\b\006\000\000\000 \004\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\128\002 \001\152\000\002\000@\024\000\001\192H\001\149\194\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\002\000\000@\002\000d@\128\000\000\128\000\000\000\000\000H\001\020\000A\000\1648\000\"\000\025\128\000 \004\001\138@\020$\001\024\018+\000\016\005 \000\002\130\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\004\128\017@\004\016\nB\000\002 \001\152\000\002\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\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\000\000\000\000\000\000\000\000\000\000\000\t\000\"\128\b \020\132\000\004\000\0030\000\004\000\0001\b\"\006\000#\002M\160\002\000\160\000\000\016@\001\136A\016 \001\024\018m\000\016\005\000\000\000\130\000\012B\b\129\000\b\192\145h\000\128(\000\000\004\016\000b\016\004\b\000F\004\139@\004\001@\000\000 \128\004\128\017@\004\016\nC\000\003 \001\152\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\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\001 \004P\001\004\002\144\128\000\136\000f\000\000\128\016\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\134\000\004\000\0030\000\004\000\000H\001\020\000A\000\164 \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\000@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\000\138\000 \128R\016\000\025\000\012\192\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\0001\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\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\001\000\002\128\000\000\000\000\000\000\000\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\006\192\000\000\000\000\000\000\000\000\000\000 \001\141\194\022\139\005\027\248\145\232\002\003\232\005\000\0078\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\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\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\004\000\n\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\000\000!\231\183z\255W\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\016\243\219\189\127\171\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\152\220 \b\176Q\191\137\030\128 >\128P\000c\128\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\by\237\222\191\213\243\190\127\127\246\224\253\253\183\255\2071\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\192 \000\000\000\000\006\000\n\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\000\000!\231\183z\255W\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\016\243\219\189\127\171\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\152\220 \b\176Q\191\137\030\128 >\128P\000c\128\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\by\237\222\191\213\243\190\127\127\246\224\253\253\183\255\2071\184@\017`\163\127\018=\000@}\000\160\000\199\002\018)w\007\208|+\014\007\252\184\023x-\249\195\192\000\000\000\000\000\000\000\000\000\000\000\000\018\000\000\000\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\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\001\015=\187\215\250\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 \000\000\000\000\000\000\000\000\000\000\000\000\000\135\158\221\235\253_;\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<\198\225\000E\130\141\252H\244\001\001\244\002\128\003\028\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000C\207n\245\254\175\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\030\135\158\221\235\253_;\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\250\190u\207\239\254\\\031\190\150\255\249\224\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\012n\016\004X(\223\196\143@\016\031@(\0001\192\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\024\220 \b\176Q\191\137\030\128 >\128P\000c\128\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\002\000\000\000\001\000\001 D\012n\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\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\004\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\0001\b\002\004\000#\002E\160\002\000\160\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\000b\016\132@(\006\004\142@\000\001@(\0001\128\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\024\220 \b\176Q\191\137\030\128 >\128P\000s\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\141\194\004\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\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\004\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\001\136@\017\000\160\024\0189\000\000\005\000\160\000\198\002\000\000\000\000\000\000\000\000\000\001\128\000\002@\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\000D\000\000\000\000\000\000\000\000\002\000\001 \000\000\000\002 \000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\017\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\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\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\004\000\000\000\000\000\000\000\000\000\003\000\000\004\128\000\000\000@\000\000\000\000\012\001\028\000\000\000\000\000\000\000\001\000\000\017\000\000\000\000\000\000\000\192\000\129 H\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\000\000\000\000\000\000\000\000\000\000\000\000\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\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\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\003\027\132\001\022\n7\241#\208\004\007\208\n\000\012p\000\002\000\000\000\000\000\000\000\000\000\000\000\128\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\000\000\000\000\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\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\021\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\132\138]\193\244\031\n\195\129\255.\005\222\011~p\240\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\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\000\000\000\000\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\004$R\238\015\160\248V\028\015\251p.\244\219\243\135\128\000\000\000\000\000\000\000\000\000\001\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\by\237\222\191\213\243\174\127\127\246\224\253\253\183\255\223\000\000\000@\000\000\000\000\000\000\000\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\001\000\000\000\b\000\000\000\000\b\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\000\000\000\000\000\000\000\000\000\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\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\024\b\001\000\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\000\000\000\000\000\000\000@\001\000\002\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\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\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\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\136\000\000\016\000\016\000`\000\000\001\000\000\000\000\000\004@\000\000\000\000\128\003\000\000\000\b\000\000\000\000\000\"\000\000\000\000\004\000\b\000\000\000@\000\000\000\000\000\000\000\000\002\000\000\000\128\001\000\000\000\000\004\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\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\000\000\000\000\000\000\000\000\000\000\000\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\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\004\000\000\000\000\000\000\000\000\000\004\000\000\000\006\000\000p\016\000ap\128\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\004\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\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\000\000\000\000\000\t\000\"\128\b \020\134\000\006@\0030\000\004\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000BE.\224\250\015\133a\192\255\151\002\239\005\1918x\000\000\000\000\000\000\000\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\192@\b\b\000\b\b \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\002\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 \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\000\000\001\000\000\000\000\000\000\000\000\000\000\000\t\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\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\000b\016\004\b\000F\004\139@\004\001P\000\000\"\128\132\138]\193\244\031\n\195\129\255.\005\222\011~p\244\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\160\000\000E\001\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\006@\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\b\001\001\000\000\129\129\000\000\000\b\000\000\000\000\000 \000\001\000\000\002\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\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\144\002(\000\130\005Hp\000D\0003\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\024\b\001\000\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\000\t\000\"\128\b T\135\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\000\000\204\000\001\000\000\018\000E\000\016@)\b\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\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\016\000\000\000\000\001\000\000\004\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000 \000\000\000\000\000\001\128\000\024\000\000\024\\`\000\017\000\000\016\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000@\000\000\000\128\000\000\001\016\000\000\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\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\001\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\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\016\000\000\002\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\000\000\000\000\000\000\000\000\000\000\000\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\000\000\004\000\000\000\000\000\128\000\000\000\000\000@\000\000\000\000 \000\000\000\000\004\000\000\000\000\000\002\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\017@\004\016\nC\128\002 \001\152\001\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\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\004@\000\000\000\000\128\001\000\000\000\b\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\012 \020\135\000\004@\003\176\000\012 \000\017\000\000\000\000\002\000\004\000\000\000 \000\000\000\000\002@\b\160\002\b\005!\192\001\016\000\204\000\001\b\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\004\128\017A\004\016\nC\000\002 \001\216\001\002\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\000\000\000\000\000\000\000\000\000\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\128\021@\004\024*C\128\002 \001\216\000\"\000D\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\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\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\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\004\000\000\000\000\000\002`\136\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\000\000p\016\000ap\128\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\016\000\001\000\000\004\001\b\006\000\000\000 \004\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\004\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\160\000\000E\001\t\020\187\131\232>\021\135\003\254\\\011\188\022\252\225\232H\165\220\031A\240\1728\031\242\224]\224\183\231\015\001\136@\016 \001\024\018-\000\016\005@\000\000\138\002\018)w\007\208|+\014\007\252\184\023x-\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\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\004\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\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\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\136\000\000\000\000\024\000 \000\000\001\000\000\000\000\000\000\001\016\015\192\024\018\000\001\241\b\001\002\000`\162\192\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\016\000\000\000\000\003\000\000\000\000\000\000\000\000\000\000\000\000 \001\248\003\002@\000>!\000 @\012\020X\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\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\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\b\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\143@\016\031@(\0001\192\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\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\016\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\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\128\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\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 \004\004\000\002\006\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\000\000\000\000@\000\004\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\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\b\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\000\000\000\000\000\000\128\000\000\000\016\000H\017\000\000\000\000\000\000\000\000\000\000\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\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\001\000\000\000\000\0000\000\000\000\000\000\000\000\000\000\003?\132\131\022*\183\2433\208\021\007\220\138\000\028p\000@\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\011! \128\b t\132\004\004@\007 \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\130\000 \128R\016\000\017\000\012\128\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\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\018\000A\000\016@)\b\000\b\000\006\000\000\b\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\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\0003\248H1b\171\1273=\001P}\200\160\001\199\001\159\194A\139\021[\249\153\232\n\131\238E\000\0148\000\144\002\b\000\130\001H@\000D\0002\000\000@\000\004\128\016@\004\016\nB\000\002 \001\144\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\t\000 \128\b \020\134\000\004@\003 \000\004\000\000H\001\004\000A\000\164 \000\"\000\025\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\nC\000\002 \001\144\000\002\000\000$\000\130\000 \128R\016\000\017\000\012\128\000\016\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\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000") + (127, "'\225 \197\138\173\2433\208\020\007\242(\000q\192F\194\000\139\133\027\226O\160\b\015\128P\000c\129\247\217\016 \191\141@\0010p=\199\005\129A\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\250\217\189f\235\252\205\255%C\252J\136<\240>\251\"\004\023\241\168\000&\014\007\184\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\141\132\001\022\n7\196\159@\016\031\000\160\000\199\003\239\178 A\127\026\128\002`\224{\142\011\002\131B~\018-X\170\2233=\001@\127\002\128\015\028\000\000\000\000\b\000\024\000\128\000\000\000\000\000\000\000\000\000\000\000\000\0000\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\128\007\224\012$\000\003\226\016\b\016\002\005\022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\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\001\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\016\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\144\000\000\000\000\000\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\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\b\128\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\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\b\000\000`\000\014\002\000\024\184@\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000X\011:\000\131%!\192\193\145\003\176\"D\"\128\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\006\000\000\224 A\139\132\000\002\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\000\000\000\000\000\000\000\000\000\000\016\004\004\004\002\012\016@\000\000\128\000\000\000\000\000 \b\b\000\004\024 \128\000\001\000\000\000\000\000\000@\016\016\000\b0@\000\000\002\000\000\000\000\000\"@\021@\004\024I\014\000\b\128\029\129\003 \004\004\128 \128\b \002\020\000\016\0001\000\000@\000\t\000A\000\016@\004 \000 \000b\000\000\128\000\012\000\000\147\004\019\000\016\002\000\000\000\000\000\004\000\024\000\001$\b&\000 \004\000\000\000\000\000\b\0000\000\002H\016L\000\000\b\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\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\003\000\000$\128\004\192\000\000\128\000\000\000\000\001\000\004\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\016\000\001$\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\004\016\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\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\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\002\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\002\000\000$\128\004\000\000\000\128\000\000\000\000\001\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$\001\020\016A\000\016\192\000\128\001\216\001\018\000@2\000\007\129\000\012\\(\000\016\004\000@\000 \000\144\004P\001\132\018C\128\002 \006`D\024A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\144\0008\b\000b\225@\000\128 \002\000\001\000\003\000\bp\016 \197\194\000\001\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\022\002\238\000 \201Hp0D@\236\000\179\b\176\024\000\003\000\000\006.\016\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\012\000\000\024\184@\000\"\000\000\128\000\000\000@\004\000\000\000\016\000\000\000D\000\000\000 \000\001\128\0008\b\000b\225\000\000\128\000\000\000\000\000}\246D\b/\227P\000L\028\015q\193`PhO\194E\171\021[\230g\160(\015\224P\001\227\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\0000\000\002L\016L\000@\b\000\000\000\000\000\016\000`\000\004\144 \152\000\128\016\000\000\000\000\000 \000\192\000\t A0\000\000 \000\000\000\000\000@\001\128\000\018@\002`\000\000@\000\000\000\000\000\128\001\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\t\000E\004\016@$0\000\"\000v\000@\128\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\001\020\000A\000\144\192\000\136\001\152\001\002\000G\223d@\130\2545\000\004\193\192\247\028\022\005\006\132\252$Z\177U\190fz\002\128\254\005\000\0308\b\216@\017p\163|I\244\001\001\240\n\000\012p\017\176\128\"\193F\248\147\232\002\003\224\020\000\024\224#a\000E\130\141\241#\208\004\007\192(\0001\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\132\001\016\n\003\004\142@\000\003\000\160\000\198\000 \000\004\002\000\020\016\160`\000\000\b\001\000\000\000@\000\b\000\000(!@\192\000\000\016\002\000\000\000\128\000\016\000\000PB\001\128\000\000 \004\000\000\000\200@\016 \0010H\180\000@4\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\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\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\000\000\000\200b\017\248\0119H\180\248\1966\004\000\201e\128\000\004\000\000\000\000\000\b\000\000@\000\000\000\000\003\000\000\000@\000\000\004\000\000\000\000\000\000\000\000\006\000\000\000\000\000\000\b\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\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\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128 \000\016`\128\000\000\004\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\b\000\000\000\000\000\000\000\000\000\000\000\012\b\001\000\000\002\004\016\000\000 \000\000\000\000\000\024\016\002\000\000\004\b\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\252$\024\177U\190f\250\002\128\254%\000\0148\t\248H1b\171|\204\244\005\001\252J\000\028p\019\240\145b\197V\249\153\232\n\003\249\148\0008\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\024\016\002\002\000\004\b \000\000@\000\000\000\b\0000 \004\004\000\b\016@\000\000\128\000\000\000\000\000`@\b\000\000\016 \128\000\001\000\000\000\000\000\000\192\128\016\000\000 @\000\000\002\000\000\000\000\000\003\129\000 \000\000@\128\000\000\004\000\000\000\000\000#a\000E\130\141\241'\208\004\007\192(\0001\192F\194\000\139\005\027\226G\160\b\015\128P\000c\128\004\000\000\001\000\001\000\016\000\000\000\000\000\000\000\000\b\000\000\000\000\002\000 \000\000\000\000\000\000\000\000\016\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\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\005\253n\255\179}\254\255\255\147\163\254e\132\014y\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\194\000\139\133\027\226O\160\b\015\128P\000c\128\141\132\001\022\n7\196\159@\016\031\000\160\000\199\001\027\b\002,\020o\137\030\128 >\001@\001\142\0026\024\132~*\223R=>a|\131\1283]`d!\b\128P\024$r\000\000\024\005\000\0060\b\216@\017`\163|H\244\001\001\240\n\000\014p#\222\221\235\253_o\159\223\253\184}\253\183\255\207#a\000E\130\141\241#\208\004\007\192(\0001\192\006B\000\129\000\t\130E\160\002\001\128\000\000A\000\012\132\001\002\000\019\004\139@\004\003@\000\000\162\000\025\b\018\004\000&\t\022\128\b\006\128\000\001\004\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\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\016\000\001\000\000\012\000\001\192@\003\023\b\000\004\000\000\000\000\000\000\024\000\003\128\128\006.\016\000\b\000\000\000\000\020\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000`\000\014\002\000\024\184@\000 \000\000\000\000\016\000\192\000\156\004\0001p\128\000@\000\000\000\000\160\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\000p\016\000\197\194\000\001\000\000\000\000\000\128\006\000\000\224 \001\139\132\000\002\000\000\000\000\005\000\004\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\016\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\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\004\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\192\000\028\004\0001p\128\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\001\018\000\238\000 \200Hp0D@\236\000\177\b\176\024\000\003\128\128\006.\016\000\b\000\000\000\000\000\004H\011\184\000\131!!\192\193\017\003\176\002\196\"\192`\000\012\000\000\024\184@\000 \000\000\000\000\000\000\000\000\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\001\000\000\000\000\000\192\194\000\000\000\000\000\000\000\000\006\000\000\224 A\139\132\000\002\000\000\000\000\000\000\012\000\001\128\000\003\023\b\000\004\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\0000\000\007\001\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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,\005\220\000A\146\144\224`\136\129\216\001b\017`0\000\006\000\000\012\\ \000\016\000\000\000\000\000\b\176\023p\001\006JC\129\130\"\007`\005\136E\128@\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\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\b\144\007p\001\006BC\129\130\"\007`\005\136E\000\000\000\b\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\001\022\002\238\000 \201Hp0D@\236\000\177\b\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\128\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\003\000\000p\016\000\197\194\000\001\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\016\000\000\016\000\000@\000\000\000\b\000\024\000\003\128\128\006.\016\000\b\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000`\000\014\002\000\024\184@\000 \000\000\000\000\000\000\000\000\128\000\000\000\001\000\000\004\000\000\000\000\129\001\128\0008\b\000b\225\000\000\128\000\000\000\000\000\000\000\002\000\000\000\000\004\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\b\000\000\000\000\016\000\000@\000\000\000\b\144\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\001\000\003\000\000p\016\000\197\194\000\001\000\000\000\000\000\128\000\000\004\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\016\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\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\002\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\001\016\000\000\000\000@\000\000\000\128\000\000\000\000\000\002 \000\000\000\000\000\000\000\001\000\000\000\000\000\200@\016 \0010H\180\000@4\000\000\b \001\144\128 `\002`\147H\000\128`\000\000\016@\003!\000@\128\004\193&\144\001\000\192\000\000 \128\006B\000\129\000\t\130E \002\001\128\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002e#j\018\002\152$\214\000 \025@\129\181T\000\000@\000 \001\000\000\004\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\000L\164mB@S\004\155\192\004\003h\b6\170\128\b\000\000\000\000\004\001\020\000\000\000\000\000\000\000\0002\016\132\b\000L\018-\000\016\r\000\000\018\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\200@\0160\0010I\180\000@4\000\000\b \001\144\128 @\002`\147h\000\128h\000\000\016@\003!\000@\128\004\193\"\208\001\000\208\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\128\000\216\000\000\128\000 \000\000\000P\000LQ\0002\016\004\b\000L\018-\000\016\r\000\000\002\b\002\000\003`\000\002\000\000\128\000\000\001@\0011D\000\200@\016 \0010H\180\000@4\000\000\b \b\000\r\128\000\b\000\002\000\000\000\005\000\004\197\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000&B6\129\000)\130M\160\002\001\180\000\019U@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0012\017\180\b\001L\018m\000\016\r\160\000\154\170\000t1\b\252\005\156\164Z|b\027\002\000d\178\192\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\004\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\016\000\000\000\000\000\000\000\000\000\000\000\000\000\012\132\001\002\000\019\004\138@\004\003\000\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\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\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\016\000\000\000\000\b\000\000\000\000\000\019\004@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\025\b\002\004\000&\t\022\128\b\006\128\000\001\004\001\000\001\176\000\001\000\000@\000\000\000\160\000\152\162\000`\000\014\002\000\024\184@\000 \000\000\000\000\000\000\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\003!\000@\128\004\193\"\208\001\000\208\000\000 \128 \0006\000\000 \000\b\000\000\000\020\000\019\020@\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\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\b\000\000\000\000\004\000\000\000\000\000\t\002 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\132\t\002\000\019\004\139@\004\003@\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\000\000\000\001\000\000\000\000\000\002B\136\001\144\129 @\002`\145h\000\128h\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\000\000D\000\000\000\000\016\000\000\000\000\000$\b\128\000\000\136\000\000\000\000\000\000\000\000\000\000\000\000\0000\000\016\000\000\004\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\0002\144\005\t\000L\018k\000\144\012\128\000\154+\000\000\000\000\000\000\024\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\004\000\000\000\000\000\000\000\000\004\000\000@\000\003\000\000p\016\000\197\194\000\001\000\000\000\000\000\000\000\000\016\000\000\000\000\b\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\024\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\004\000\000\000\000\000\000\000\000\004\000\000\000\000#a\000E\130\141\241#\208\004\007\192(\0001\192\006B\b\129\144I\130M\160\002\001\160\000\000A\000\012\b\001\001\000\002\004\016\000\000 \000\000\000\004\000\024\016\002\002\000\004\b \000\000@\000\000\000\000\0000 \004\000\000\b\016@\000\000\128\000\000\000\000\000`@\b\000\000\016 \000\000\001\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\003\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\002\000\000\b\002\002\000\001\006\b\000\000\000@\000\000\000\000\000\016\004\132\000\002\012\016\000\000\000\128\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000@\016\016\000\b0@\000\000\002\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\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\128\000\000\000\000\000\000\000\000\000\000\016\004\004\000\002\012\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\017 \n\160\002\012\004\135\000\004@\014\192\001\016\002\000@\000\000\000\016\000\000\000\000\000\000\000\000\000\000\003\000\000$\128\004\192\000\000\128\000\000\000\000\001\000\002\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\b\000\000\024\000\003\192\128\006.\016\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\014\002\000\024\184@\000 \000\000\000\000\000\017 \n\160\002\012\004\135\000\004@\014\192\001\016\n\001\128\0008\b\000b\225\000\000\128\000\000\000\000\000D\128*\128\b0\018\028\000\017\000;\000$@(\137\000U\000\016`$8\000\"\000v\000H\128\016\012\000\001\192@\003\023\b\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000@\000\000\000\0000\000\007\001\000\012\\ \000\016\000\000\000\000\000\b\144\005P\001\006\002C\128\002 \007`\004\136\001\000\000\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\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\016\000\004\000\000\004\001\001\000\000\131\004\000\000\000 \000\000\000\000\002$\001T\000A\128\144\224\000\136\001\216\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\016\000\000\000\000\000\000\000\000\000\"@\021@\004\024I\014\000\b\128\029\129\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\016\004\004\000\002\012\016\000\000\000\128\000\000\000\000\b\144\005P\001\006\002C\128\002 \007`\000\136\001\000@\016\016\000\b0@\000\000\002\000\000\000\000\000\"@\021@\004\024\t\014\000\b\128\029\128\002 \004\000\000\000\000\000\000\000\000\000\000\000\b\002\002\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\018\000\170\000 \194Hp\000D\000\236\b\017\000 \b\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\b\144\005P\001\006\018C\128\002 \007`@\136\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\"@\021@\004\024\t\014\000\b\128\029\128\002 \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\002$\001T\000A\128\144\224\000\136\001\216\000\"\000D\000\000\128\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\016\000\002\000\000\004\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\006\004\000\128\000\001\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\002$\001T\000A\132\144\224\000\200\001\216\000&\000@p \132\000\000\b\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\000\002\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\001\000@@\000 \193\000\000\000\b\000\000\000\000\000\128\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\000\000\000\000\000\000\b\144\005P\001\006\018C\128\003 \007`@\152\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000@\002\000\004\000\000\000\000\000\000#a\000E\130\141\241#\208\004\007\192(\0001\192F\194\004\139\005\027\226G\160\b\015\128P\000c\128\000\000\000\000\000\001\000\000\000\001\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\002\000@\000\000\000\0026\016\004X(\223\018=\000@|\002\128\003\028\000d \b\128P\024$r\000\000\024\005\000\0060\016\000\004@\000\000\000\000\000\000\192\002\004\129 \000\001\144\128\"\001@`\145\200\000\000`\020\000\024\192#a\000E\130\141\241#\208\004\007\192(\0001\192\006B\000\136\133\001\130O \000\001\128P\000c\000\012\132\001\016\n\003\004\158@\000\003\000\160\000\198\000\025\b\002 \020\006\t\028\128\000\006\001@\001\140\0026\016\004\\(\223\018}\000@|\018\128\003\028\004l \b\176Q\190$\250\000\128\248%\000\0068\b\216@\017`\163|H\244\001\001\240J\000\012p\017\176\128\"\225F\248\147\232\002\003\224\020\000\024\224#a\000E\130\141\241'\208\004\007\192(\0001\192F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\000d \b\016\000\152$Z\000 \026\000\000\004\016\004\000\000\000\000\004\000\001\000\000\000\000\000\002@\136\017\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\003)\000P\208\004\193&\176\001\000\192\000\000 \128\006R\000\161 \t\130M`\002\001\128\000\000A\000\012\164\001B@\019\004\138\192\004\003\000\000\000\130\000\016\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\000d \b\016\000\152$Z\000 \026\000\000\004\016\000\000\002\000\000\000\000\001\000\000\000\002\000\002`\136\001\128\0008\b\000b\225\000\000\128\000\000\000\000\000\000\000\b\000\000\000\000\004\000\000\000\b\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\232b\017\248\0119H\180\248\1966\004\000\201e\128\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\012\132\001\002\000\019\004\138@\004\003\000\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\000e \n\018\002\152$V\000 \025\000\000\148\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\016\000\000\000\000\000\000\000\000\128\000\006\000\000\192\000\001\139\132\000\002\000\000\000\000\000\000\004\000\000\000\000A\000\000\000\004\000\000\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\0026\016\004X(\223\018=\000@|\002\128\003\028\000d \b\024\000\152$\218\000 \026\000\000\004P\000\200@\016 \0010I\180\000@4\000\000\b\160\001\144\128 @\002`\145h\000\128h\000\000\017@D\148\187\131\232>\022\028\015\249p;\193o\206\030F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\192\200@\016 \0010H\180\000@4\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\006B\000\129\128\t\130M\160\002\001\160\000\000A\000\012\132\001\002\000\019\004\155@\004\003@\000\000\130\000\025\b\002\004\000&\t\022\128\b\006\128\000\001\004\000\000\000\000\000\000\000\000@\000\000\000\128\000\144\"\004l \b\176Q\190$z\000\128\248\005\000\0068\000\200@\017\000\1600H\228\000\0000\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\002=\237\222\191\213\246\185\253\255\219\135\223\219\127\253\240\016\000\000\000\000\012\0028\000\000\000\000\000\000\000\004l1\b\252U\190\164z|\194\249\007\000f\186\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017\176\132\"\193F\248\145\232\002\003\224\020\000\024\224#a\bE\130\141\241#\208\004\007\192(\0001\192\006\004\000\128\128\001\002\b\000\000\016\000\000\000\000\000\012\b\001\000\000\002\004\016\000\000 \000\000\000\000\000\024\016\002\000\000\004\b\000\000\000@\000\000\000\000\000\000\000\000\000\000\b\000@\000\000\000\000\000\b\000\000 \b\b\000\004\024 \000\000\001\000\000\000\000\000\016\000\002\000\000\004\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#a\bE\130\141\241#\208\004\007\192(\0001\192F\194\016\139\005\027\226G\160\b\015\128P\000c\128\012\132!\002\000\019\004\139@\004\003\000\000\000\130\000\000\000\000\000\000\000\000 \000\000\000@\000L\017\0000\000\007\001\000\012\\ \000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\001\000\000\000\000\b\216@\017`\163|H\244\001\001\240\n\000\012p\001\144\128\"!@`\147\200\000\000`\020\000\024\192\003!\000D\002\128\193'\144\000\000\192(\0001\128\006B\000\136\005\001\130G \000\001\128P\000c\001\018R\238\015\160\248Xp?\237\192\239M\1918x\025\b\002 \020\006\t\028\128\000\006\001@\001\140\004{\219\189\127\171\237s\251\255\183\015\191\182\255\251\224\000\000\000\000\000\016\000P\000\000\000\000\000\000\000\b\216@\017`\163|H\244\001\001\240\n\000\012p\001\144\128 `\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130E\160\002\001\160\000\000E\000\000\000l\000\000\000\000\000\000\000\000\000\000 (\001\027\bZ,\020o\137\030\128 >\001@\001\206\0026\016\004X(\223\018=\000@|\002\128\003\028\000d \b\024\000\152$\218\000 \026\000\000\004P\000\200@\016 \0010I\180\000@4\000\000\b\160\001\144\128 @\002`\145h\000\128h\000\000\017@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\143{w\175\245}\174\127\127\246\225\247\246\223\255<\000\000\000\000\000\003\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\000H\000\000`\000\014\002\000\024\184@\000 \000\000\000\000\000\000\000\006@\000\000\000\001\000\000\000\002\000\000\000\000\001\128\0008\b\000b\225\000\000\128\000\000\000\000\000\000\000\025\000\000\000\000\004\000\000\000\b\000\004\000\000\006\000\000\224 \001\139\132\000\002\000\000\000\000\000\000\000\000d\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\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\003!\000D\002\128\193#\144\000\000\192(\0001\128\143{w\175\245}\174\127\127\246\225\247\246\223\255|\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\016\000\000\000\000\012\000(\000\000\000\000\000\000\000\004l \b\176Q\190$z\000\128\248\005\000\0068\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\000D\148\187\131\232>\022\028\015\249p;\193o\206\030F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\209\239n\245\254\175\181\207\239\254\220>\254\219\255\231\162J]\193\244\031\011\014\007\253\184\029\233\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\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\132l \b\176Q\190$z\000\128\248\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\000D\148\187\131\232>\022\028\015\249p;\193o\206\030F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\209%.\224\250\015\133\135\003\254\\\014\240[\243\135\145\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\003!\000@\192\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130M\160\002\001\160\000\000E\000\012\132\001\002\000\019\004\139@\004\003@\000\000\138\002$\165\220\031A\240\176\224\127\203\129\222\011~p\244IK\184>\131\225a\192\255\151\003\188\022\252\225\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017\239n\245\254\175\181\207\239\254\220>\254\219\255\231\162J]\193\244\031\011\014\007\253\184\029\233\183\231\015#a\000E\130\141\241#\208\004\007\192(\0001\192\006B\000\129\128\t\130M\160\002\001\160\000\000E\000\012\132\001\002\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t\022\128\b\006\128\000\001\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\025\253n\241\250\175\253\207\247\255]\254\250[\255\247\190\251\"\004\023\241\168\000&\014\007\184\224\176(4#a\000E\130\141\241#\208\004\007\192(\0001\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\001\027\b\002,\020o\137\030\128 >\001@\001\142\0002\016\004\012\000L\018m\000\016\r\000\000\002(\000d \b\016\000\152$\218\000 \026\000\000\004P\000\200@\016 \0010H\180\000@4\000\000\b\160\"J]\193\244\031\011\014\007\252\184\029\224\183\231\015D\148\187\131\232>\022\028\015\249p;\193o\206\030F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\209%.\224\250\015\133\135\003\254\\\014\240[\243\135\145\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\003!\000@\192\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130M\160\002\001\160\000\000E\000\012\132\001\002\000\019\004\139@\004\003@\000\000\138\002$\165\220\031A\240\176\224\127\203\129\222\011~p\244IK\184>\131\225a\192\255\151\003\188\022\252\225\228l \b\176Q\190$z\000\128\248\005\000\0068\000\200@\0160\0010I\180\000@4\000\000\b\160\001\144\128 @\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193\"\208\001\000\208\000\000\"\128\137)w\007\208|,8\031\242\224w\130\223\156=\018R\238\015\160\248Xp?\229\192\239\005\1918y\027\b\002,\020o\137\030\128 >\001@\001\142\0002\016\004\012\000L\018m\000\016\r\000\000\002(\000d \b\016\000\152$\218\000 \026\000\000\004P\000\200@\016 \0010H\180\000@4\000\000\b\160\"J]\193\244\031\011\014\007\252\184\029\224\183\231\015D\148\187\131\232>\022\028\015\249p;\193o\206\030F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\209%.\224\250\015\133\135\003\254\\\014\240[\243\135\145\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\003!\000@\192\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130M\160\002\001\160\000\000E\000\012\132\001\002\000\019\004\139@\004\003@\000\000\138\002$\165\220\031A\240\176\224\127\203\129\222\011~p\244IK\184>\131\225a\192\255\151\003\188\022\252\225\228l \b\176Q\190$z\000\128\248\005\000\0068\000\200@\0160\0010I\180\000@4\000\000\b\160\001\144\128 @\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193\"\208\001\000\208\000\000\"\128\137)w\007\208|,8\031\242\224w\130\223\156=\018R\238\015\160\248Xp?\229\192\239\005\1918y\027\b\002,\020o\137\030\128 >\001@\001\142\0002\016\004\012\000L\018m\000\016\r\000\000\002(\000d \b\016\000\152$\218\000 \026\000\000\004P\000\200@\016 \0010H\180\000@4\000\000\b\160\"J]\193\244\031\011\014\007\252\184\029\224\183\231\015D\148\187\131\232>\022\028\015\249p;\193o\206\030F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\209%.\224\250\015\133\135\003\254\\\014\240[\243\135\145\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\003!\000@\192\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130M\160\002\001\160\000\000E\000\012\132\001\002\000\019\004\139@\004\003@\000\000\138\002$\165\220\031A\240\176\224\127\203\129\222\011~p\244IK\184>\131\225a\192\255\151\003\188\022\252\225\228l \b\176Q\190$z\000\128\248\005\000\0068\000\200@\0160\0010I\180\000@4\000\000\b\160\001\144\128 @\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193\"\208\001\000\208\000\000\"\128\137)w\007\208|,8\031\242\224w\130\223\156=\018R\238\015\160\248Xp?\229\192\239\005\1918y\027\b\002,\020o\137\030\128 >\001@\001\142\0002\016\004\012\000L\018m\000\016\r\000\000\002(\000d \b\016\000\152$\218\000 \026\000\000\004P\000\200@\016 \0010H\180\000@4\000\000\b\160\"J]\193\244\031\011\014\007\252\184\029\224\183\231\015D\148\187\131\232>\022\028\015\249p;\193o\206\030F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\209%.\224\250\015\133\135\003\254\\\014\240[\243\135\145\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\003!\000@\192\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130M\160\002\001\160\000\000E\000\012\132\001\002\000\019\004\139@\004\003@\000\000\138\002$\165\220\031A\240\176\224\127\203\129\222\011~p\244IK\184>\131\225a\192\255\151\003\188\022\252\225\228l \b\176Q\190$z\000\128\248\005\000\0068\000\200@\0160\0010I\180\000@4\000\000\b\160\001\144\128 @\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193\"\208\001\000\208\000\000\"\128\137)w\007\208|,8\031\242\224w\130\223\156=\018R\238\015\160\248Xp?\229\192\239\005\1918y\027\b\002,\020o\137\030\128 >\001@\001\142\0002\016\004\012\000L\018m\000\016\r\000\000\002(\000d \b\016\000\152$\218\000 \026\000\000\004P\000\200@\016 \0010H\180\000@4\000\000\b\160\"J]\193\244\031\011\014\007\252\184\029\224\183\231\015D\148\187\131\232>\022\028\015\249p;\193o\206\030F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\209%.\224\250\015\133\135\003\254\\\014\240[\243\135\145\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\003!\000@\192\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130M\160\002\001\160\000\000E\000\012\132\001\002\000\019\004\139@\004\003@\000\000\138\002$\165\220\031A\240\176\224\127\203\129\222\011~p\244IK\184>\131\225a\192\255\151\003\188\022\252\225\228l \b\176Q\190$z\000\128\248\005\000\0068\000\200@\0160\0010I\180\000@4\000\000\b\160\001\144\128 @\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193\"\208\001\000\208\000\000\"\128\137)w\007\208|,8\031\242\224w\130\223\156=\018R\238\015\160\248Xp?\229\192\239\005\1918x\025\b\002\004\000&\t6\128\b\006\000\000\001\004\0002\016\004\b\000L\018-\000\016\012\000\000\002\b\000\245$Z\019\004\154g\214\003 \031`\001\188U\b\216@\017`\163|H\244\001\001\240\n\000\012p\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\128\000p\016\000\197\194\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\000\000\000\000\b\000\000\000\024\000\003\128\128\006.\016\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\128\000\000\000\004l \b\176Q\190$z\000\128\248\005\000\0068\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\001\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\012\000\001\192@\003\023\b\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000@\000\000\000\0026\016\004X(\223\018=\000@|\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\002\000\000\000\000\017\176\128\"\193F\248\145\232\002\003\224\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\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\128\000\000\000\004l \b\176Q\190$z\000\128\248\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\016\000\019\004@\012\000\001\192@\003\023\b\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000@\000\000\000\0026\016\004X(\223\018=\000@|\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\001\000\000\000\002\000\002@\136\017\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006B\000\129\000\t\130E\160\002\001\160\000\000A\000\000\000\000\000\000\000\000\016\000\000\000 \000$\b\128\025\b\002\004\000&\t\022\128\b\006\128\000\001\004\000\000\000\000\000\000\000\000@\000\000\000\128\000\144\"\000d \b\016\000\152$Z\000 \026\000\000\004\016\000\000\000\000\000\000\000\001\000\000\000\002\000\002@\136\000\000\000\000\000\000`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\017\0002\016\004\b\000L\018-\000\016\r\000\000\002\b\000\000\000\000\000\000\000\000\128\000\000\001\000\001 D\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\017@\004\016\t\012\000\012\128\025\128\000 \004\004\128\"\128\b\"\018\024\012\025\0003\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\004IK\184>\131\225a\192\255\151\003\188\022\252\225\228l \b\176Q\190$z\000\128\248\005\000\0068\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#a\000E\130\141\241#\208\004\007\192(\0001\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\000\000\000\000\000\000\000\000\000\144\000\000\000\000\000\000\000\000\b\000(\000\000\000\000\000\000\000\004l \b\176Q\190$z\000\128\248\005\000\0068\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\155\003\224\012\004\004\003\224\016\b\000\011\012\006F\194\022\139\005\027\226G\160\b\015\128P\000s\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\027\b\002,\020o\137\030\128 >\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\000\000\b\216@\017`\163|H\244\001\001\240\n\000\012p\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\012\132\001\016\n\003\004\142@\000\003\000\160\000\198\002=\237\222\191\213\246\185\253\255\219\135\223\219\127\253\240\000\000\000\000\000\b\000(\000\000\000\000\000\000\000\004l \b\176Q\190$z\000\128\248\005\000\0068\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000#\222\221\235\253_o\159\223\253\184}\253\183\255\207#a\000E\130\141\241#\208\004\007\192(\0001\192\006B\000\129\128\t\130M\160\002\001\160\000\000E\000\012\132\001\002\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t\022\128\b\006\128\000\001\020\004IK\184>\131\225a\192\255\151\003\188\022\252\225\232\146\151p}\007\194\195\129\255.\007x-\249\195\200\216@\017`\163|H\244\001\001\240\n\000\012p\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000G\189\187\215\250\190\223?\191\251p\251\251o\255\158F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\209%.\224\250\015\133\135\003\254\\\014\240[\243\135\145\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\143{w\175\245}\190\127\127\246\225\247\246\223\255<\141\132\001\022\n7\196\143@\016\031\000\160\000\199\000\025\b\002\006\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018m\000\016\r\000\000\002(\000d \b\016\000\152$Z\000 \026\000\000\004P\017%.\224\250\015\133\135\003\254\\\014\240[\243\135\162J]\193\244\031\011\014\007\252\184\029\224\183\231\015\001\000\000\000\000\000\192\002\128\000\000\000\000\000\000\000F\194\000\139\005\027\226G\160\b\015\128P\000c\128\000\000 \000\000\000\000\000\000\000\000\000\000\000\000\002=\237\222\191\213\246\249\253\255\219\135\223\219\127\252\2426\016\004X(\223\018=\000@|\002\128\003\028\000d \b\024\000\152$\218\000 \026\000\000\004P\000\200@\016 \0010I\180\000@4\000\000\b\160\001\144\128 @\002`\145h\000\128h\000\000\017@D\148\187\131\232>\022\028\015\249p;\193o\206\030\137)w\007\208|,8\031\242\224w\130\223\156<\141\132\001\022\n7\196\143@\016\031\000\160\000\199\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\004{\219\189\127\171\237\243\251\255\183\015\191\182\255\249\228l \b\176Q\190$z\000\128\248\005\000\0068\000\200@\0160\0010I\180\000@4\000\000\b\160\001\144\128 @\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193\"\208\001\000\208\000\000\"\128\137)w\007\208|,8\031\242\224w\130\223\156=\018R\238\015\160\248Xp?\229\192\239\005\1918y\027\b\002,\020o\137\030\128 >\001@\001\142\000\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\b\247\183z\255W\219\231\247\255n\031\127m\255\243\200\216@\017`\163|H\244\001\001\240\n\000\012p\001\144\128 `\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130E\160\002\001\160\000\000E\001\018R\238\015\160\248Xp?\229\192\239\005\1918z$\165\220\031A\240\176\224\127\203\129\222\011~p\240\000\000\000\000\000\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\016\000P\000\000\000\000\000\000\000\b\216@\017`\163|H\244\001\001\240\n\000\012p\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000G\189\187\215\250\190\223?\191\251p\251\251o\255\158F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\209%.\224\250\015\133\135\003\254\\\014\240[\243\135\145\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\143{w\175\245}\190\127\127\246\225\247\246\223\255<\141\132\001\022\n7\196\143@\016\031\000\160\000\199\000\025\b\002\006\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018m\000\016\r\000\000\002(\000d \b\016\000\152$Z\000 \026\000\000\004P\017%.\224\250\015\133\135\003\254\\\014\240[\243\135\162J]\193\244\031\011\014\007\252\184\029\224\183\231\015#a\000E\130\141\241#\208\004\007\192(\0001\192\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\001\030\246\239_\234\251|\254\255\237\195\239\237\191\254y\027\b\002,\020o\137\030\128 >\001@\001\142\0002\016\004\012\000L\018m\000\016\r\000\000\002(\000d \b\016\000\152$\218\000 \026\000\000\004P\000\200@\016 \0010H\180\000@4\000\000\b\160\"J]\193\244\031\011\014\007\252\184\029\224\183\231\015D\148\187\131\232>\022\028\015\249p;\193o\206\030\143{w\175\245}\190\127\127\246\225\247\246\223\255<\141\132\001\022\n7\196\143@\016\031\000\160\000\199\000\025\b\002\006\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018m\000\016\r\000\000\002(\000d \b\016\000\152$Z\000 \026\000\000\004P\017%.\224\250\015\133\135\003\254\\\014\240[\243\135\162J]\193\244\031\011\014\007\252\184\029\224\183\231\015G\189\187\215\250\190\215?\191\251p\251\251o\255\190\143{w\175\245}\174\127\127\242\225\247\210\223\255<\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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#a\000E\130\141\241#\208\004\007\192(\0001\192\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\001\027\b\002,\020o\137\030\128 >\001@\001\142\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\002\000\000\000\004\000\004\129\016#a\000E\130\141\241#\208\004\007\192(\0001\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\000A\027\b\002,\020o\137\030\128 >\001@\001\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000d \b\016\000\152$Z\000 \024\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\000\003!\bD\002\128\193#\144\000\000\192(\0001\128\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\001\027\b\002,\020o\137\030\128 >\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\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017\176\129\"\193F\248\145\232\002\003\224\020\000\024\224\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\002\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\200@\017\000\1600H\228\000\0000\n\000\012` \000\000\000\000\000\000\000\000\001\128\000\t\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\000D\000\000\000\000\000\000\000\000 \000\018\000\000\000\000\136\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\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\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\001\000\000\000\000\000\000\000\000\000\012\000\000H\000\000\000\b\000\000\000\000\006\001\028\000\000\000\000\000\000\000\004\000\001\016\000\000\000\000\000\0000\000\129 H\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\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\000F\194\000\139\005\027\226G\160\b\015\128P\000c\128\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\001\027\b\002,\020o\137\030\128 >\001@\001\142\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\017%.\224\250\015\133\135\003\254\\\014\240[\243\135\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\000F\194\000\139\005\027\226G\160\b\015\128P\000c\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\027\b\002,\020o\137\030\128 >\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\"J]\193\244\031\011\014\007\252\184\029\224\183\231\015\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\132\001\003\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t6\128\b\006\128\000\001\020\0002\016\004\b\000L\018-\000\016\r\000\000\002(\b\146\151p}\007\194\195\129\255.\007x-\249\195\200\216@\017`\163|H\244\001\001\240\n\000\012p\001\144\128 `\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130E\160\002\001\160\000\000E\001\018R\238\015\160\248Xp?\229\192\239\005\1918z$\165\220\031A\240\176\224\127\203\129\222\011~p\244IK\184>\131\225a\192\255\151\003\188\022\252\225\228l \b\176Q\190$z\000\128\248\005\000\0068\000\200@\0160\0010I\180\000@4\000\000\b\160\001\144\128 @\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193\"\208\001\000\208\000\000\"\128\137)w\007\208|,8\031\242\224w\130\223\156=\018R\238\015\160\248Xp?\229\192\239\005\1918x\000\000\000\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\017%.\224\250\015\133\135\003\254\220\014\244\219\243\135\129\144\128 `\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130E\160\002\001\160\000\000E\000\000\000\000\000\000\000\000\000\000\000\128\000\000 \b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000>\000\192@@>\003\000\128\000\176@`\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017\239n\245\254\175\181\207\239\254\220>\254\219\255\239\128\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\006B\000\129\128\t\130M\160\002\001\160\000\000E\000\012\132\001\002\000\019\004\155@\004\003@\000\000\138\000\025\b\002\004\000&\t\022\128\b\006\128\000\001\020\000\000\001\016\000\000\000\000\000\000\004\000\000\000\128 \000\000\018 |\001\128\128\128|\n\001\000\001`\128\192\000\004\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\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\001\129\000 \000\000@\130\000\000\004\000\000\000\000\000\003\002\000@\000\000\129\000\000\000\b\000\000\000\000\000\000\000\000\000\000\001\000\b\000\016\000\000\000\000\000\000\141\132\001\022\n7\196\143@\016\031\000\160\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0000\000\000\004\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\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\004\000\000@\000\003\002\000@\000\000\129\000\000\000\b\000\000\000\000\000\t\000E\000\016A$8\0002\000f\000\000\128\016\004\001\001\000\000\131\004\000\000\000 \000\000\000\000\002\000\000\000\000\000\128\000 \000\000\000@\000\000\000\0000 \004\000\000\b\016\000\000\000\128\000\000\000\000\000\144\004P\001\004\018C\128\003 \006`\000\b\001\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\017\176\128\"\193F\248\145\232\002\003\224\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\001\000\000\000\000\000\016\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\000\000\002\000\004\0000\000\000\002\000\000\000\000\000\018\000\000\000\000\b\000`\000\000\004\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\004\000\000\000\000\000\000\000\000\000\000\000\128\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\b\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\0000\000\006\000\000\012\\(\000\016\000\000\000\000\000\000\000\000\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\000\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\006\000\000\224 \001\139\132\000\002\000\000\000\000\000\000\000\000\000\128\000\000\000\000\000\000\000\000\b\000\000\000\024\000\003\128\128\006.\016\000\b\000\000\000\000\000\000\000\001\016\000\000\000\000@\000\001\000\000\000\000\002\000\000\002 \000\000\000\000\128\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\128\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\b\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\016\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\000\000\000\000\000\000\000\000\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\000`\000\000\197\194\000\001\000\000\000\000\000\000\011\001E\000\016`\1648\0002\000f\000@\132\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000,\005\020\000A\002\144\224\000\200\001\152\001\002\016@0\000\006\000\000\012\\(\000\016\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000@\000\000\000\192\000\024\000\0001p\160\000@\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\003\000\000`\000\000\197\194\000\001\000\000\000\000\000\000\011\000E\000\016@\1648\0002\000f\000@\132\016\022\002\138\000 \193Hp\000d\000\204\000\129\b \000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\0000\000\006\000\000\012\\ \000\016\000\000\000\000\000\000\176\004P\001\004\nC\128\003 \006`\004\bA\001`(\160\002\012\020\135\000\006@\012\192\b\016\130\000\000\000\000\000\000\000\002\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000F\194\000\139\005\027\226G\160\b\015\128P\000c\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\0002\016D\b\000L\018m\000\016\012\000\000\002\b\000d \136\016\000\152$Z\000 \024\000\000\004\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\144\128 @\002`\145h\000\128`\000\000\016@\004\128\"\128\b \018\024\000\025\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\001\144\128 `\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130E\160\002\001\160\000\000E\001\018R\238\015\160\248Xp?\229\192\239\005\1918z$\165\220\031A\240\176\224\127\203\129\222\011~p\240\000\000\000\000\000\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\003\002\000@@\000\129\004\000\000\b\000\000\000\000\000\006\004\000\128\000\001\002\b\000\000\016\000\000\000\000\000\012\b\001\000\000\002\004\000\000\000 \000\000\000\000\000\000\000@\000\000\004\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 \b\b\000\004\024 \000\000\001\000\000\000\000\000\016\000\002\000\000\004\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\b\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000d \b\016\000\152$Z\000 \026\000\000\004P\017%.\224\250\015\133\135\003\254\\\014\240[\243\135\129\144\128 `\002`\147h\000\128h\000\000\017@\003!\000@\128\004\193&\208\001\000\208\000\000\"\128\006B\000\129\000\t\130E\160\002\001\160\000\000E\000\000\000 \000\000\000\000\000\000\000\000\000\0002\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\004\004\000\002\012\016\000\000\000\128\000\000\000\000\b\000\001\000\000\002\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\128 \000\016`\128\000\000\004\000\000\000\000\000@\000\b\000\000\016\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\004\001\001\000\000\131\004\000\000\000 \000\000\000\000\002\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\017\000|\001\128\128\128|\002\001\000\001\240\128\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128 \000\016`\128\000\000\004\000\000\000\000\000@\000\b\000\000\016\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\004\001\001\000\000\131\004\000\000\000 \000\000\000\000\002\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\b\000\004\024 \000\000\001\000\000\000\000\000\016\000\002\000\000\004\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\004\128\"\128\b \146\028\000\017\0003\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\b\001\000\000\002\004\016\000\000 \000\000\000\000\000\024\016\002\000\000\004\b\000\000\000@\000\000\000\000\000H\002(\000\130\t!\192\001\016\0030\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\224\001\000\016\000\000\001\000\000\000\000\000\000\000\000\000\128\000\000 \000 \002\000\000\000\000\000\000\000\000\001\000\000\000\000\000@\004\000\000\000\000\000\000\000\000\002\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\018\000\138\000 \128H`\000D\000\236\000\001\000\000\b\002\002\000\001\006\b\000\000\000@\000\000\000\000\004H\002(\000\131\001!\192\001\016\0030\000\004\000\000\144\004P\001\004\002C\000\002 \006`\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\128\002\000\000\000\000\002\000\000\000\000\000\000\000\000\003\000\004\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\000\000\000\000\002\000\000\000\000\000 \000\002\000\000$\001\020\000A\000\144\192\000\136\001\152\000\002\000@H\002(\000\130\001!\000\001\016\0030\000\004\000\128`\000\000\000\000\000\000\128\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\004\000\000@\000\004\128\"\128\b \018\024\000\017\0003\000\000@\b\t\000E\000\016@$ \000\"\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\b\000\000\000\000\000\128\000\b\000\000\144\004P\001\004\002C\000\002 \006`\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000>\251\"\004\023\241\168\000&\014\007\184\224\176(4'\225\"\213\138\173\2433\208\020\007\240(\000\241\192\006B\000\129\000\t\130E\160\002\001\160\000\000A\000@\000\b\000\000\000\000\016\000\000\000\000\000$\b\129\027\b\002,\020o\137\030\128 >\001@\001\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\190\200\129\005\252j\000\t\131\129\2388,\n\r\t\248H\181b\171|\204\244\005\001\252\n\000\001@\001\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\001\000\000\b\000\128\000\000\000\000\000\000 \000\000\000\002\000\000\016\001\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\128\000\000\000\000\000\000\000\000\000\012\164\001B@\019\004\138\192\004\003 \000\002\130\000\028\000\003\128\128\006.\016\000\b\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\192\000\028\004\0001p\128\000@\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\004\000\000\000\000#a\000E\130\141\241#\208\004\007\192(\0001\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\001\027\b\002,\020o\137\030\128 >\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\000\000\000\001\000\000 \000\000\128\134\003\000\000\000@\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\b\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\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\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\001\128\0008\b\000b\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\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\012\164\001B@\019\004\138\192\004\003 \000\002\130\000\028\000\003\128\128\006.\016\000\b\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\192\000\028\004\0001p\128\000@\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\004\000\000\000\000#a\000E\130\141\241#\208\004\007\192(\0001\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\001\027\b\002,\020o\137\030\128 >\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\000\000\000\b\216@\017`\163|I\244\001\001\240\n\000\012p\017\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\004\000\000\128\000\002\002\024\012\000\000\001\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\001\000\b\003D\024\000\000\b\000\000\000\004\000\b\000\002\000\016\006\1360\000\000\016\000\000\000\000\000\016\000\004\000 \r\016 \000\000 \000\000\000\000\000 \000\b\000@\026 @\000\000@\000\000\000\000\000\200A\0162\0010I\180\000@0\000\000\b >\251\"\004\023\241\168\000&\014\007\184\224\176(4\003!\004@\128\004\193&\208\001\000\192\000\000 \128\006B\b\129\000\t\130E\160\002\001\128\000\000A\000\012\132\001\002\000\019\004\139@\004\003\000\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\000\128\000\000\000\000\000\000 \000@\000\000\000\000\000\001\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\b\000\000\002\000\000\000\002\000\000\128\004\001\162\004\000\000\004\000\000\000\000\000\012\000\001\192@\003\023\b\000\004\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\000@\000\000\016\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\202@\020$\0010I\172\000@0\000\000\b \001\148\128(H\002`\145X\000\128`\000\000\016@\003)\000P\144\020\193\"\176\001\000\192\000\000 \128\002\000\000\128\004\001\162\004\000\000\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\000 \b\000\002\000\016\006\136\016\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\245%Z\131TZg\247\130 \030e\004\0305\001\234J\181\006\168\180\207\239\004@<\202\b\022\028\015\249p;\193o\206\030\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\001\000\000\016\000@\000\000\b\000\000\000@\000H\000\000\000\000 \000\128\000\000\016\000\000\000\128\000\144\000\000\000\000@\001\000\000\000 \000\000\000\000\004\128\"\128\012 \018\028\000\017\000;\000\000\194\000\002@\000\000\000\001\000\004\000\000\000\128\000\000\000\000\018\000\138\000 \128Hp\000D\000\204\000\001\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000H\002(\000\130\001!\128\001\016\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\000H\002(\000\194\001!\192\001\016\003\176\000\012 \000$\000\000\000\000\016\000@\000\000\b\000\000\000\000\001 \b\160\002\b\004\135\000\004@\012\192\000\016\128\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\t\000E\004\016@$0\000\"\000v\000@\128\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000$\001\020\000A\000\144\192\000\136\001\152\001\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\000H\000\002\000\000 \000\128\000\000\016\000\000\000\128\000\144\000\000\000\000@\001\000\000\000 \000\000\001\000\004\128\"\128\b \018\024\000\017\0003\000\000B\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\001\000\000\000\000\000@\000\001\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\002\000\000\000\000\000\000\192\000\024\000\0001q\128\000D\000\001\000\000\000\001\128\0000\000\000b\225\000\000\136\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\004\000@\000\000\001\000\000\000\004@\000\000\000\000\000\024\000\003\000\000\006.\016\000\b\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\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\016\000\000\000\000\000\000\000\000\000\000\006\000\000\224 \001\139\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\000@\000\000\000\000\000\000\000\000\000\000@\000\000\016\000\000\000\000\004\000\000\000\016\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\003\000\000p\016\000\197\194\000\001\000\000\000\000\000\000\000\000\016\000\000\000\000\b\000\000\000\000\000\016\000\000\000\000 \000\000\000\000\016\000\000\000\000\000 \000\000\024\000\003\128\128\006.\016\000\b\000\000\000\000\000\000\000\000\128\000\000\000\000@\000\000\000\000\000\128\000\000\000\000\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\000\000\000\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\000E\000\016@$8\000\"\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\0002\000\007\129\000\012\\(\000\016\004\000@\000 \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \b\160\002\b\000\134\000\004\000\012\192\b\016\002\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\002@\000\016\000\001\000\004\000\000\000\128\000\000\004\000\004\128\000\000\000\002\000\b\000\000\001\000\000\000\b\000$\001\020\000A\000\016\192\000\128\001\152\000\002\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\001\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\t\000E\004\016@\0040\000 \000v\000D\128\016\012\128\001\224@\003\023\n\000\004\001\000\016\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000H\002(\000\130\000!\128\001\000\0030\002\004\000\128\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\144\000\004\000\000@\001\000\000\000 \000\000\001\000\001 \000\000\000\000\128\002\000\000\000@\000\000\002\000\t\000E\000\016@\0040\000 \000f\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\000\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\000\001\000\000\002\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\002@\017@\004\016\t\012\000\b\128\025\128\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\001\027\b\002,\020o\137\030\128 >\001@\001\142\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\004l \b\176Q\190$z\000\128\248\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\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$\001\004\000A\000\016\128\000\128\001\144\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\144\000\000\000\000`\001\000\000\000 \000\000\000\000\000\000\136\007\224\012$\000\003\226\016\b\016\003\005\022\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\016\000\000\000\000\000\000@\000\000\000@\000\000\000\0000\000\000\000\000\000\000\000\000\000\000\000@\003\240\006\018\000\001\241\b\004\b\001\130\139\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\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002@\000\000\000\001\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\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000`\000\014\002\000\024\184@\000 \000\000\000\000\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\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\194\000\139\005\027\226G\160\b\015\128P\000c\128\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\001\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000`@\b\000\000\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\000\000\000@\002\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\128\128\000A\130\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\000\128\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\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\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006B\000\129\000\t\130E\160\002\001\160\000\000A\000\000\000\000\000\000\000\000\016\000\000\000\b\000$\b\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\024\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\004\000\000\000\004\000\000\000\000\003\000\000\000\000\000\000\000\000\000\001?\t\006,Uo\153\158\128\168?\145@\003\142\000\016\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000\180$\016\001\004\026B\002\002 \014@\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$\001\004\000A\000\144\128\000\136\001\144\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\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\004\128 \128\b \018\016\000\016\0000\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\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\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\019\240\144b\197V\249\153\232\n\131\249\020\0008\224'\225 \197\138\173\2433\208\021\007\242(\000q\192\t\000A\000\016@$ \000\"\000d\000\000\128\000\018\000\130\000 \128H@\000D\000\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\144\004\016\001\004\002C\000\002 \006@\000\b\000\001 \b \002\b\004\132\000\004@\012\128\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\018\000\130\000 \128H`\000D\000\200\000\001\000\000$\001\004\000A\000\144\128\000\136\001\144\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\128\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000") and start = 15 and action = - ((16, "6\224@~;\198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\018;\198\000\000\000\000\022\022;\1986\224@~\022\022\000\003\000\000\000\000@~\022\022\000\003@~\022\022\000\003\000\000\000\000\000\000\018\022;,\021\218<\194K\216\000\000\000\025\000\000\000\000\001\030\000\000\000\000=\168\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\000\002\248\002\160\000\t\000\000\000\000\002\236\000\000>\206Qx\022\022?\170\022|\003\168\0001X2\000\000\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\234\001\132\000\157\000\000\000\168\004B\000\000\000\242\000\226\004J\000\000\005L\002\000\n\\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\234\000\000\000\000\002\160K\b\000\000\000\000\000h\000\000\000\000K\170\003<\003\168\000\000\000\0009J\000h\000\000=\210\022\022>\206\005.\005\000\003\168\004\176\000\000\022\0226\224@D\022\022M\\\000\000\001<\000\000G\018\004\250\000\000\028x\000\000\000\016\000\000\000\000\001\166\000\000\000h\000\000\000\000\000\000\001\206\000\000\028x\000\000\004\004jjq\130X\200s\164<6G\000I\238\000\000[\140\026\018K\b;\1986\2246\224\000\000\000\000\000\000=L=L\003\168\004\176\004\176\022\022?\170\025\174\000\208\005\182\000\000\004\144\005\186\000\000\000\000\000\000\000\000\000\000\022\022\000\000\000\000\000\000@~\022\022\000\003@~\022\022\000\0034\212c\220AP\000\252?\170@~\022\022o~\000\000K\216g\154j\222\000\000\005\182\000\000\005\130\000\000\023\1648NI4\000\0008NI4\000\0008Nu\240\007\028\006\194\004\004\002\164\000\000\006F\000\000\000\000\b0\000\000\000\000\000\0008N\000h\000\000\000\000M\\8NL\146I\238\000\000\006\196\028\2529JI\238\006r8N\000\000\000\000\000\000\000\000\000\000\000\000H\242I\238I\220\007\028\000\000\000\000\000\000\003~\000\000\000\000ON\007\140\000h\000\000\000\000J\198\000\000\000\000\000\000\003(\000\0008N\000\000\021\024xt\000\0008N\007V8N\030.\000\000\031,\000\000\bT\0040\000\000\007`8N\004|\000\000\004\146\000\000\003\138\000\000\000\003\006b\000\000\000\000\000\000$\152\tXK\216@~\022\022K\216\000\000\007\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000G\250\030\140\000\000\000\000\000\000\001\254\026\002j\222\000\000d^\022\022K\216\000\000\000\000HHK\216u\218K\216vh\000\000N\000\000\000\000\000N\164=\168\004\180\004\180\000\000\b~K\216\000\000\000\000\000\000\bB\b\186\000\000\027\138\000\000K\216v\2068N\b\n\000\000K\216v\232\0001\000\000\000\000\000\000\b\202\000\000\022Z\000\000m\168\000\000\tx\000\0006\136K\216\000\000\000\0006\140\tB\005\182\t\156\000\000\000\000\000\000\000\000\b\220\000\000<\176\006\022\011\b\007\1748N\016\186\011\144\000\000\000\000\007l\011\b\t\018\000\003K\216P(\002\254\000\000K\216\024\1448N\017\138\t\018\011\166\000\000\000\000\000\000>\164\004\180\012B\000\000K\216\000\000\000\003@~=\210=L\003\168\004\176\003~\002\004\000\t\000\000\011\144>\206>\206\012H>\206\003~\002\004\002\004\000\000\012p>\206\000\000]\184\001LG\018\005\182\005\248x\142\000\0008NYn8NR\206Y\2468N\005l8NZ\128\000\000\t\134\n\150\006\140>\206^@\000\000\tZ\011\148Q\188\000\000\000\000\000\000\000\000>\206^\200>\206_P\000\218\004\004SX\005\186\004\004S\226\000\000_\216\001L\000\000\000\000``\023f\000\000\025\228\000\000\012\220\004\176\000\000RFP\200\000\000\000$\000\000>\206\026P\000\000\000\000\000\000P\238\000\000\000$\000\003AP\005\234\t\170?\170\024\0069\222\018\022?\170@~\022\022\018\022@~\022\0227\220@~\022\022\000\003d^\022\022K\216K\2168&\000\003d^\022\022<\176\000\000Z\208\000\000\000\000\003ZI\238\t\240\012\248FFd^\022\022K\216\027\254K\216\000\000\000\000d^\022\022K\216\028N\000\003d^\022\022K\216\027\138\000\003\018\022\000\000\000\000\000\000\000\000\001\250\023r5\218\000\000B$B\248=L\003\168\004\176\006\192>\206\026b\000\000C\204D\160g\154\029L8N\t\174\000\003@~\022\022\018\022\024\006\018\022\003\002\017\254?\170d^\022\022K\216\028\252?\170\018\022\n\200\r8\007\2208N#\1548N\028\n8N#\250\r\162\000\000\000\000\r\204\000\000\018\022\004\n\r\232\000\000$\236\000\003\014b\000\000\029\250?\170\019\020\025\004\000\000\000\000\000\000\000\000\b\224\000\003\000\000\000\000\t\202\000\003\000\000\000\000\030\248?\170\031\246?\170\000\000\020\018\026\002?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170 \244?\170\000\000?\170\000\000?\170\000\000?\170\000\000?\170\000\000\000\000\000\000\000\003;\198\000\003\000\000\r\186\000\000\022\022K\216\029\1348N\n\208\000\003\000\000\031\130\000\003\000\000K\216 FK\216 \128K\216!D\0001\000\000\000\000\000\000!~K\216\"B\000\000d\210;\1986\224K\216;R\000\003\000\000:\250\025\174\000\208\000hq\224>\206n\020d\210d\210\000\000\000\000\004\002\005\n\000\t\006\n\004\176kR>\206\005\198\004\176k\220d\210t\002\002\160\000\t\006\nd\210t\002\000\000\006\n\000\000\000\000\006\nd\210\000\000;\1986\224;\1986\224=L\003\168\004\176d\210\000\000\022|\003\168\0001\r\202K\b\n\n\000h\000\0008Ne6\r\248\014\166rD\000\000d\210\000\000e\1568\236\022\022\005\170\000\000\n\146\014\160\000\000\015\bl@I\238\000=\000\000\014\230\014tK\b\011\0308N$\248\022\022\011\152\021\220\000\000%x\015D\000\000\000\248\000\000\000\000\015\144I\238Tj\000\000[n\006\178\n\168\002\004\011\224\014\216\022\022d\210\000\000Mn\011\246I\238\015jI\238`\232U\018\015lI\238a\134U\186\022\022d\210\000\000\000\000\\D@D\022\022X\\G\018\011\208jjq\130u\240\000=\015\150\000\000\000\000b\bf\000\022\022\000\000nx\005\170\000\000\000\000o\194\000\000\000\000\000\000l\164\025z\026x\000=\015\152\000\000\000\000\000\000f\000\022\022\000\000\000=\015\182\000\000\000\000\000\000\000\000\000\000o\194\000\000\015\174\027\226\000\000\022\232o\194\000\000\000\000\000\000\000\000\012\028p^q\130\000\000o\194\000\000\000\000o\194\000\000\015\208\027\226\022\232o\194\000\000x\240\023\152\002\248\000\208\004\004o\194\000\000\000\208\004\004o\194\000\000;f\025\174\000\208\000hq\224>\206o\194\000\000\004\002\006\194\bn\004\004o\194\000\000\000\t\0158>\206o\194G\164\002\160\000\t\015:>\206o\194G\164\000\000\000\000\007\018\000\003o\230\000\000>\206t6d\210\000\000\007\018\000\000=\210\022\022>\206o\194\000\0008\236\022\022\005\170f\000#\242\030\200\021\220\017\184\000\000\012v\028x\012`\000\000\015\206\015z\0312\021\218I\0028N\012N\000\000Er\003\218\006\242\011\232\000\000\012`\000\000\015\224\015`8NAP\000\000\003\168\017\180\012*\000\000\r^\000\000\015\246\015vK\b>\022\000\000\022\022\0312\016\026\004j\000\208\000\003\002X\03128N\r^\007\028\000\0008N\b\238\n\234\000\000\000\000b\174\000\000\000\003\005\204\0312c8AP\000\000\022\0228N\012\1688N5\218>\022\000\000\015\168\000\000>\022\000\000\000\000Er\000\000d\210t\212\021\220\017\184\012v\016\012\015\184\0312d\210t\212\000\000\000\000\021\220\017\184\012v\016 \015\158v\254F\228I\238\016@v\254u\240\030\198\016Xv\254I\238\016^v\254f\128g\000\000\000O\216\000\000\000\000d\210wr\021\220\017\184\012v\016X\015\214v\254d\210wr\000\000\000\000\000\000x\240\000\000\000\000\000\000\000\000\000\000\000\000\000\000d\210\000\000t\226\022\022:*\016\\jj\000\000o\194t\226\000\000\000\000w\140\022\022:*\016^\015\224q\130\000\000o\194w\140\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\026#\242\021\220\017\184\012v\016ng\1548\006\021\218<\194B\248\022f\002\210\000=\016\132\n\012\000\003\000\000\016.\000\003\000\000>\022\000\000\007\222\012\230\000\000\r\194\000\000\016\166\01668N7D\016\188\012\b\000\003\000\000\016j\000\003\000\000\022\138\003\168\r(\016\204h\028K\b\004\180\016n8N\rv\000\003\000\000\016\134\000\003\000\000\000\000\r\006\000\000\016\152FF\000\000\000\000\000\000>\022\000\000\021\182\014\016\000\000\014\\\000\000\016\248\016xK\b\000\000\017\bh\158L\212\004\180\016\1548N\r\166\000\003\000\000\016\182\000\003\000\000\000\000\022\022\000\003>\022\000\000\022<\022\0228\0068\006i\146;\198\022\022o~K\216\n\200\000\000\021\178\000\208\000\003\r<8\0068N\014\\\005\182\000\000\022\022g\154g\1548\006\r\1948\006\000\0009\204\018\022\005\018\006\026:\198\000\000\000\000\000\000V\030\000\000\000\000V\168\000\000\000\000W2\000\003\014:8\006W\188o~K\216\n\200\000\000\007\012\000\000v\254\017Z\000\0004\212\017 \000\000>\022\000\0008\0064\212>\022\000\000\022\0228N>\022\000\000\016\206\000\000>\022\000\000\000\000B\248\000\000plv\254\016\2368\006q\bg\154\000\000d\210u~\021\220\017\184\012v\017Xg\154d\210u~\000\000\000\000\000\000m\138@~\022\022o~K\216d\210\000\000\000\000\000\000\000\000\000\000\000\000r\168\000\000\000\000s*\000\000d\210\000\000t\226\000\000\000\000\000\000\000\000d\210m\138\000\000\000\000r\168\000\000s*\017\148\000\000\017\150\000\000\017\180\000\000\000\000\000\000\000\003\017\186\000\000\000\003\017\232\000\000\t\"\018\252?\170\017\242\000\000\029\130?\170\000\000?\170\018\006\000\000?\170\018\018\000\000\000\000\019\250?\170\018&\007\"?\170!\242?\170\0188\b ?\170\"\240?\170\018:\t\030?\170#\238&\232\000\003\018L\n\028?\170$\236\000\003\018J\011\026?\170%\234\000\003\018\\\012\024?\170&\232\012\230\020\248?\170\018d\r\022?\170'\230?\170\018p\014\020?\170(\228?\170\018\134\015\018?\170)\226\016\016?\170*\224\021\016\000\000\018\146\000\000?\170\018\150\000\000?\170\018\150\000\000\000\000\"|\000\003\000\000\007\214\000\003\000\000K\216\000\000\000\000i\016\018\158\000\000Er\000\000\017\216\000\000Er\000\000\018\158\000\000\005\234\0182\000\000\024\006\028\250\005\182\000\000\031\192\011T\rP\023|\000\000\000\000\018\186\000\000\001t\027\000>\170\000\000\014\176\000\000\000\000\000\003\018\020\000\003\018\030\000\000\0186\000\003\018N\000\000\000\003\014\176\000\003\018L\000\003\018Z\000\000\000\000\018\224\000\003\000\000\000\003\000\000\000\000\000\000+\222\019$?\170,\220?\170-\218\000\000\018\130\000\000\027\000\014D\000\000\017\014\019\030\000\000#\150\014L\014\190\000\000\000\000\018\188\000\000\019:\000\000\000\000\003\168\004\176\023\160\000\003\000\000\002\248\002\160\000\t\006\n\018\214\000\003\000\0008\236\022\022\005\170\000\230\003~\018\216\000\003\000\000\000\000\000\000\000\000\019`\000\000\000\000y\030\004\180\018\1828N\014\176\000\003\000\000\014\1788N\014\200\000\003\000\000\018\218\000\003\000\000\000\000d\210\000\000.\216\000\000\018\194\000\000\000\000=L\003\168\004\176\024\232\000\000>\206\027N\000\000\nT\000\000\019\144\000\000\019\194K\216/\214\019\196K\2160\212\022\022\000\000>\206\027`\000\000>\206\027\210\000\000>\206\028\246\000\000d\210\000\000\003\168\004\176d\210\000\000d\210m\138\000\000\000\000\019\152\000\000\021\006\011\166\022\022a\006\000\000\000\000!\004b2\000\000\000\000\019\028\000\000\019r8N\000\000\r\156\n,\007\028\000\000\000\0008N\005V\007\1588N\012\148\000=\019\168\000\000\000\000n\220\000\000\000\000\019\170\027\226\029P\005\170f\000\006\178\022\022\000\000d\210\000\000\000\000\000\000\000\000\000\000\000\000\000\000j\006\006\178\022\022\000\000\015\140jj\019\176\027\226\029Pd\210\000\000\019,\000\000\\\162\029\206\000\000d\210\000\000\019H\000\000\030r\000\000\028N\000\0008N\0158\000\000B\248\019\\\000\000\020&K\2161\2102\208K\2163\206\000\003\000\000\000\003\000\000\019T\000\003\019^\000\000\020\016\000\000\000\003\019l\000\003\019t\000\000\019\156\000\000\000\000?\170\019\160\000\000\000\000#\238X2\020H\000\000\000\000\000\000\012T\017\196]\020\020J\000\000\000\000\000\000\000\000\000\000\000\000\019\194\000\000\006\178\000\000\019\196\000\0008N\000\000\t\252\000\000\000\003\019\212\000\000\000\000\004\004\000\000\bl\000\000\000\003\000\000\001\212\000\000\004\176\000\000\005\190\000\000>\206\000\000\026P\000\000\n\150\000\000\019\236\000\000K\216\024\144\000\000\000\000\024\216\019\242\000\000\000\000\019\234\025\1787\220\000hm&\000\000\000\000\000\000\000\000\000\000v\b\000\000\000\000\020\156\000\000yT\000\000\015\176\020\158\000\000\020\160\000\0008\2168\216w\250w\250\000\000\000\000d\210w\250\000\000\000\000\000\000d\210w\250\020\002\000\000\020\016\000\000"), (16, "\0039\000\006\000\246\001\142\001\146\0039\001\002\001\006\0039\001\n\001\022\001\"\0039\rF\0039\012\129\001&\0039\007\130\0039\0039\0039\006\025\0039\0039\0039\001*\001\186\002N\001\254\001.\0039\003V\003Z\011\150\0039\012\129\0039\006\217\0012\b\154\003z\002\230\0039\0039\003\174\003\178\0039\003\182\003\194\003\206\003\218\003\226\007\018\007b\002\234\0039\0039\003F\001J\002f\003\214\0039\0039\0039\b\194\b\198\b\210\b\226\b\142\005\150\0039\0039\0039\0039\0039\0039\0039\0039\0039\b\250\001N\0039\000\238\0039\0039\0039\001J\t\006\t\030\tj\t~\005\162\0039\005\166\0039\0039\0039\b\190\0039\0039\0039\0039\b\218\002j\b\222\002\006\024B\0039\001N\0039\0039\004\133\0039\0039\0039\0039\0039\0039\005\170\b\238\0039\0039\0039\t\146\004j\t\246\012\169\0039\0039\0039\0039\012\169\012\169\012\169\012\169\b\158\002\022\012\169\012\169\012\169\012\169\001\250\012\169\012\169\003\157\012\169\012\169\012\169\003\189\012\169\012\169\012\169\012\169\r>\012\169\004\133\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012y\012\169\rF\012\169\000\238\012\169\012\169\012\169\012\169\012\169\007\190\006\025\012\169\012\169\012\169\003a\012\169\003\222\012\169\012\169\012\169\012y\001\137\012\169\012\169\012\169\012\169\012\169\012\169\012\169\003a\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\bB\012\169\012\169\007\250\012\169\012\169\012\169\001V\001\250\003\157\bJ\002\242\012\169\012\169\012\169\012\169\012\169\012\169\bN\012\169\012\169\012\169\012\169\012\169\012\169\012\169\r\190\012\169\012\169\001Z\012\169\012\169\002\246\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\012\169\003\n\001\137\012\169\012\169\012\169\012\169\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\002&\001\137\002\202\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\023\214\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\003]\001\137\001\137\001\137\001\137\001\137\007~\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\028W\001\137\001\137\001\137\001\137\001\137\001\137\001\137\bJ\004\133\004\133\003\014\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\004F\t\170\001\137\005\218\001\137\001\137\r\170\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\016\170\001\137\001\137\001\137\001\137\001\137\nY\002\029\002\029\004>\007\030\nY\nY\nY\nY\002J\001\154\nY\nY\nY\nY\000\238\nY\nY\004\133\nY\nY\nY\bJ\nY\nY\nY\nY\004\133\nY\000\n\nY\nY\nY\nY\nY\nY\nY\nY\001\246\nY\000\238\nY\005\n\nY\nY\nY\nY\nY\007\"\007>\nY\nY\nY\002\014\nY\002\030\nY\nY\nY\002\029\004J\nY\nY\nY\nY\nY\nY\nY\002V\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\002v\nY\nY\004\218\nY\nY\nY\004\133\0075\004\133\004\133\005f\nY\nY\nY\nY\nY\nY\004\133\nY\nY\nY\nY\nY\n\014\nY\001\158\nv\nY\004\133\nY\nY\004\133\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\nY\000\238\nY\nY\nY\nY\nY\003\229\004\133\004\133\004\133\002^\003\229\003\229\003\229\003\229\004\133\005\014\003\229\003\229\003\229\003\229\000\238\003\229\003\229\004\133\003\229\003\229\003\229\005j\003\229\003\229\003\229\003\229\004\133\003\229\t>\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\004\133\003\229\000\238\003\229\005F\003\229\003\229\003\229\003\229\003\229\003\026\006\165\003\229\003\229\003\229\006\173\003\229\004\133\003\229\003\229\003\229\005\014\000\238\003\229\003\229\003\229\003\229\003\229\003\229\003\229\002z\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\005V\n\006\nn\002\n\003\229\003\229\003\229\002\026\003r\002\170\001\006\005^\003\229\003\229\003\229\003\229\003\229\003\229\002\174\003\229\003\229\003\229\003\229\003\229\n\014\003\229\0069\nv\003\229\001*\003\229\003\229\000\238\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\003\229\012}\003\229\003\229\003\229\003\229\003\229\003\213\003n\001\142\001\146\006*\003\213\003\213\003\213\003\213\003F\t%\003\213\003\213\003\213\003\213\012}\003\213\003\213\012Z\003\213\003\213\003\213\002\158\003\213\003\213\003\213\003\213\b!\003\213\002\162\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\007v\003\213\016\158\003\213\003\142\003\213\003\213\003\213\003\213\003\213\005\014\001\250\003\213\003\213\003\213\003\157\003\213\t\r\003\213\003\213\003\213\005\014\0069\003\213\003\213\003\213\003\213\003\213\003\213\003\213\000\238\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\004\014\n\006\nn\r&\003\213\003\213\003\213\001\"\006\194\001\006\007\186\003\146\003\213\003\213\003\213\003\213\003\213\003\213\000\238\003\213\003\213\003\213\003\213\003\213\n\014\003\213\004\241\nv\003\213\000\238\003\213\003\213\002\214\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\003\213\r*\003\213\003\213\003\213\003\213\003\213\003\209\003\134\b6\003\150\b\142\003\209\003\209\003\209\003\209\r6\007\238\003\209\003\209\003\209\003\209\t\r\003\209\003\209\000\238\003\209\003\209\003\209\000\238\003\209\003\209\003\209\003\209\b\202\003\209\004N\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\005\166\003\209\016\226\003\209\007~\003\209\003\209\003\209\003\209\003\209\006\230\006\254\003\209\003\209\003\209\028g\003\209\012r\003\209\003\209\003\209\005r\024\154\003\209\003\209\003\209\003\209\003\209\003\209\003\209\bJ\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\007\202\n\006\nn\001\006\003\209\003\209\003\209\001\"\004\158\012b\001\142\015^\003\209\003\209\003\209\003\209\003\209\003\209\007\210\003\209\003\209\003\209\003\209\003\209\n\014\003\209\015n\nv\003\209\012j\003\209\003\209\016>\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\003\209\r\162\003\209\003\209\003\209\003\209\003\209\t\249\b\142\004>\004>\002^\t\249\t\249\t\249\t\249\r6\020\174\t\249\t\249\t\249\t\249\000\238\t\249\t\249\016F\t\249\t\249\t\249\b\006\t\249\t\249\t\249\t\249\006!\t\249\004j\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\005\166\t\249\b.\t\249\007~\t\249\t\249\t\249\t\249\t\249\0036\004\133\t\249\t\249\t\249\000\238\t\249\022Z\t\249\t\249\t\249\004V\004\142\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\206\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\004\234\t\249\t\249\004\218\t\249\t\249\t\249\007\006\025\022\015\166\000\238\003\197\t\249\t\249\t\249\t\249\t\249\t\249\018\218\t\249\t\249\t\249\t\249\t\249\t\249\t\249\020\178\t\249\t\249\015\178\t\249\t\249\004\133\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\t\249\000\238\n\t\t\249\t\249\t\249\t\249\n\t\n\t\n\t\n\t\018\226\006j\n\t\n\t\n\t\n\t\004N\n\t\n\t\006\025\n\t\n\t\n\t\004\133\n\t\n\t\n\t\n\t\005N\n\t\005*\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\006\229\n\t\003\197\n\t\023V\n\t\n\t\n\t\n\t\n\t\026v\t)\n\t\n\t\n\t\000\238\n\t\022n\n\t\n\t\n\t\004Z\006\238\n\t\n\t\n\t\n\t\n\t\n\t\n\t\0066\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n:\n\t\n\t\nB\n\t\n\t\n\t\001V\004>\005\217\000\238\023^\n\t\n\t\n\t\n\t\n\t\n\t\006N\n\t\n\t\n\t\n\t\n\t\n\t\n\t\006\138\n\t\n\t\001Z\n\t\n\t\t)\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\b\249\n\001\n\t\n\t\n\t\n\t\n\001\n\001\n\001\n\001\005\217\028G\n\001\n\001\n\001\n\001\007]\n\001\n\001\004J\n\001\n\001\n\001\t)\n\001\n\001\n\001\n\001\015b\n\001\005\217\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\006\190\n\001\000\238\n\001\004\237\n\001\n\001\n\001\n\001\n\001\n\170\007U\n\001\n\001\n\001\007U\n\001\022\130\n\001\n\001\n\001\001\006\007\254\n\001\n\001\n\001\n\001\n\001\n\001\n\001\006\162\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\004>\n\001\n\001\006\198\n\001\n\001\n\001\007%\006\218\b\249\007E\007\014\n\001\n\001\n\001\n\001\n\001\n\001\011\170\n\001\n\001\n\001\n\001\n\001\n\001\n\001\022\018\n\001\n\001\003\142\n\001\n\001\002^\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\n\001\005\134\t\237\n\001\n\001\n\001\n\001\t\237\t\237\t\237\t\237\000\238\b\022\t\237\t\237\t\237\t\237\002^\t\237\t\237\012\238\t\237\t\237\t\237\0079\t\237\t\237\t\237\t\237\007E\t\237\0036\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\n\186\t\237\b\206\t\237\t\242\t\237\t\237\t\237\t\237\t\237\000\238\025\154\t\237\t\237\t\237\006\181\t\237\022\154\t\237\t\237\t\237\0036\004\198\t\237\t\237\t\237\t\237\t\237\t\237\t\237\001\162\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\001f\t\237\t\237\028'\t\237\t\237\t\237\002*\011\170\018\186\026^\001f\t\237\t\237\t\237\t\237\t\237\t\237\012\246\t\237\t\237\t\237\t\237\t\237\t\237\t\237\n:\t\237\t\237\nB\t\237\t\237\002j\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\t\237\b\245\t\245\t\237\t\237\t\237\t\237\t\245\t\245\t\245\t\245\n2\nZ\t\245\t\245\t\245\t\245\n:\t\245\t\245\nB\t\245\t\245\t\245\012\014\t\245\t\245\t\245\t\245\000\238\t\245\012\238\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\004\157\t\245\000\238\t\245\006\234\t\245\t\245\t\245\t\245\t\245\r.\007E\t\245\t\245\t\245\007E\t\245\022\174\t\245\t\245\t\245\006J\011\190\t\245\t\245\t\245\t\245\t\245\t\245\t\245\b\026\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\006\250\t\245\t\245\rj\t\245\t\245\t\245\003\177\004\157\b\245\026\"\007:\t\245\t\245\t\245\t\245\t\245\t\245\002^\t\245\t\245\t\245\t\245\t\245\t\245\t\245\003\146\t\245\t\245\rZ\t\245\t\245\002j\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\t\245\b\206\t\241\t\245\t\245\t\245\t\245\t\241\t\241\t\241\t\241\002^\012\238\t\241\t\241\t\241\t\241\014\018\t\241\t\241\016B\t\241\t\241\t\241\r\174\t\241\t\241\t\241\t\241\006)\t\241\005%\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\016n\t\241\016J\t\241\007R\t\241\t\241\t\241\t\241\t\241\016.\007\138\t\241\t\241\t\241\014\214\t\241\022\194\t\241\t\241\t\241\016\014\bU\t\241\t\241\t\241\t\241\t\241\t\241\t\241\007\150\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\004>\t\241\t\241\t\017\t\241\t\241\t\241\006%\007\174\019\002\r\198\000\238\t\241\t\241\t\241\t\241\t\241\t\241\002=\t\241\t\241\t\241\t\241\t\241\t\241\t\241\n:\t\241\t\241\nB\t\241\t\241\016\006\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\000\238\t\253\t\241\t\241\t\241\t\241\t\253\t\253\t\253\t\253\000\238\027\222\t\253\t\253\t\253\t\253\b\130\t\253\t\253\018\222\t\253\t\253\t\253\003\014\t\253\t\253\t\253\t\253\012\213\t\253\tJ\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\014\182\t\253\016v\t\253\016\254\t\253\t\253\t\253\t\253\t\253\t\017\023\190\t\253\t\253\t\253\tQ\t\253\022\222\t\253\t\253\t\253\016\182\bE\t\253\t\253\t\253\t\253\t\253\t\253\t\253\n6\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\t\253\022\206\t\253\t\253\003\142\t\253\t\253\t\253\bQ\026Z\007e\018\230\nV\t\253\t\253\t\253\t\253\t\253\t\253\020\030\t\253\t\253\t\253\t\253\t\253\t\253\t\253\n:\t\253\t\253\nB\t\253\t\253\000\238\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\bJ\n\r\t\253\t\253\t\253\t\253\n\r\n\r\n\r\n\r\000\238\006\029\n\r\n\r\n\r\n\r\nb\n\r\n\r\019>\n\r\n\r\n\r\016\190\n\r\n\r\n\r\n\r\019\130\n\r\nr\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\020F\n\r\019\138\n\r\019\186\n\r\n\r\n\r\n\r\n\r\024\146\012\225\n\r\n\r\n\r\026j\n\r\022\242\n\r\n\r\n\r\020*\n\130\n\r\n\r\n\r\n\r\n\r\n\r\n\r\011b\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\012\230\n\r\n\r\r\002\n\r\n\r\n\r\bI\011\170\r\006\023\230\r2\n\r\n\r\n\r\n\r\n\r\n\r\020\146\n\r\n\r\n\r\n\r\n\r\n\r\n\r\012\238\n\r\n\r\024z\n\r\n\r\t9\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\bJ\n\005\n\r\n\r\n\r\n\r\n\005\n\005\n\005\n\005\b\202\011b\n\005\n\005\n\005\n\005\000\238\n\005\n\005\003\254\n\005\n\005\n\005\016\190\n\005\n\005\n\005\n\005\000\238\n\005\rN\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\rR\n\005\027B\n\005\t=\n\005\n\005\n\005\n\005\n\005\025.\rz\n\005\n\005\n\005\023\234\n\005\023\006\n\005\n\005\n\005\025:\025B\n\005\n\005\n\005\n\005\n\005\n\005\n\005\002^\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\r\142\n\005\n\005\000\238\n\005\n\005\n\005\006\134\r\206\r\222\014&\014r\n\005\n\005\n\005\n\005\n\005\n\005\004\157\n\005\n\005\n\005\n\005\n\005\n\005\n\005\014\146\n\005\n\005\014\178\n\005\n\005\026\238\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\n\005\014\250\nI\n\005\n\005\n\005\n\005\nI\nI\nI\nI\015v\015\142\nI\nI\nI\nI\012\014\nI\nI\016\022\nI\nI\nI\016\026\nI\nI\nI\nI\016R\nI\016V\nI\nI\nI\nI\nI\nI\nI\nI\016~\nI\016\130\nI\016\154\nI\nI\nI\nI\nI\017\018\017B\nI\nI\nI\017F\nI\023\018\nI\nI\nI\017j\017n\nI\nI\nI\nI\nI\nI\nI\017~\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\017\142\nI\nI\017\154\nI\nI\nI\017\206\017\210\018\"\018J\018N\nI\nI\nI\nI\nI\nI\018\146\nI\nI\nI\nI\nI\nI\nI\003\201\nI\nI\018\182\nI\nI\018\198\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\nI\018\238\t\225\nI\nI\nI\nI\t\225\t\225\t\225\t\225\018\242\018\254\t\225\t\225\t\225\t\225\019\014\t\225\t\225\019&\t\225\t\225\t\225\000\238\t\225\t\225\t\225\t\225\0196\t\225\019J\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\019b\t\225\019\146\t\225\019\150\t\225\t\225\t\225\t\225\t\225\019\162\019\178\t\225\t\225\t\225\019\198\t\225\003\201\t\225\t\225\t\225\020\186\020\198\t\225\t\225\t\225\t\225\t\225\t\225\t\225\020\246\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\021\026\n\006\nn\004A\t\225\t\225\t\225\016j\021B\015\254\021\218\021\226\t\225\t\225\t\225\t\225\t\225\t\225\b\026\t\225\t\225\t\225\t\225\t\225\n\014\t\225\021\234\nv\t\225\021\254\t\225\t\225\016r\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\t\225\000\238\t\225\t\225\t\225\t\225\t\225\002M\022\n\bM\022\030\012\205\002M\001\002\001\006\002M\027\226\002j\001\"\002M\n.\002M\0226\001&\002M\012\205\002M\002M\002M\022B\002M\002M\002M\001*\004A\n^\022V\001.\002M\002M\002M\002M\002M\nf\002M\n\018\0012\022j\003z\022~\002M\002M\002M\002M\002M\022\150\022\170\003\206\002N\002M\023*\002M\0236\002M\002M\003F\022\190\022\218\003\214\002M\002M\002M\b\194\b\198\b\210\022\238\020R\005\150\002M\002M\002M\002M\002M\002M\002M\002M\002M\023\002\n\006\nn\023&\002M\002M\002M\0232\023>\023r\023\130\023\146\005\162\002M\005\166\002M\002M\002M\023\158\002M\002M\002M\002M\b\218\022J\b\222\023\206\022\138\002M\023\246\002M\002M\023\254\002M\002M\002M\002M\002M\002M\005\170\b\238\002M\002M\002M\t\146\004j\024\006\n5\002M\002M\002M\002M\n5\001\002\001\006\n5\024\014\024\"\001\"\n5\n5\n5\024*\001&\n5\0246\n5\n5\n5\024V\n5\n5\n5\001*\024n\n5\024\134\001.\n5\n5\n5\n5\n5\n5\n5\022\022\0012\024\162\003z\024\170\n5\n5\n5\n5\n5\024\218\024\250\003\206\002N\n5\022.\n5\022:\n5\n5\003F\025\018\025&\003\214\n5\n5\n5\b\194\b\198\b\210\025N\n5\005\150\n5\n5\n5\n5\n5\n5\n5\n5\n5\025n\n5\n5\025\162\n5\n5\n5\025\170\025\182\026\022\026F\026N\005\162\n5\005\166\n5\n5\n5\026\134\n5\n5\n5\n5\b\218\n5\b\222\026\158\n5\n5\026\246\n5\n5\027\n\n5\n5\n5\n5\n5\n5\005\170\b\238\n5\n5\n5\t\146\004j\027&\n1\n5\n5\n5\n5\n1\001\002\001\006\n1\027N\027V\001\"\n1\n1\n1\027~\001&\n1\027\134\n1\n1\n1\027\142\n1\n1\n1\001*\027\154\n1\027\162\001.\n1\n1\n1\n1\n1\n1\n1\022N\0012\027\171\003z\027\187\n1\n1\n1\n1\n1\027\206\027\234\003\206\002N\n1\022b\n1\022v\n1\n1\003F\028\007\028\023\003\214\n1\n1\n1\b\194\b\198\b\210\0283\n1\005\150\n1\n1\n1\n1\n1\n1\n1\n1\n1\028\135\n1\n1\028\163\n1\n1\n1\028\174\028\227\028\247\028\255\029;\005\162\n1\005\166\n1\n1\n1\029C\n1\n1\n1\n1\b\218\n1\b\222\000\000\n1\n1\000\000\n1\n1\000\000\n1\n1\n1\n1\n1\n1\005\170\b\238\n1\n1\n1\t\146\004j\000\000\002\133\n1\n1\n1\n1\002\133\001\002\001\006\002\133\000\000\000\000\001\"\002\133\n.\002\133\004\133\001&\002\133\000\000\002\133\002\133\002\133\000\000\002\133\002\133\002\133\001*\004\133\n^\000\000\001.\002\133\002\133\002\133\002\133\002\133\nf\002\133\022\210\0012\000\000\003z\005\026\002\133\002\133\002\133\002\133\002\133\000\000\000\000\003\206\002N\002\133\022\230\002\133\022\250\002\133\002\133\003F\000\238\000\000\003\214\002\133\002\133\002\133\b\194\b\198\b\210\000\238\020R\005\150\002\133\002\133\002\133\002\133\002\133\002\133\002\133\002\133\002\133\000\000\004\133\002\133\000\000\002\133\002\133\002\133\019~\004\133\000\000\004\133\000\000\005\162\002\133\005\166\002\133\002\133\002\133\000\000\002\133\002\133\002\133\002\133\b\218\000\000\b\222\004\133\000\000\002\133\000\000\002\133\002\133\019\134\002\133\002\133\002\133\002\133\002\133\002\133\005\170\b\238\002\133\002\133\002\133\t\146\004j\004\133\004\133\002\133\002\133\002\133\002\133\004\133\004\133\bE\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\000\000\004\133\000\238\004\133\004\133\004\133\004\133\004\133\004\133\025\194\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\000\000\004\133\004\133\000\238\000\238\004\133\004\133\000\000\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\006\146\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\000\238\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\004\133\020\018\004\133\000\000\004\133\004\133\004\133\004\133\004\133\004\133\000\238\004\133\000\n\004\133\004\133\004\133\004\133\004\133\004\133\004\133\000\000\004\133\004\133\004\133\000\000\000\238\004\133\004\133\002\029\002\029\004\133\000\238\004\133\004\133\000\000\004\133\004\133\000\000\004\133\r&\011b\025\198\002\029\001\"\025\210\004\133\004\133\004\133\000\000\000\238\004\133\004\133\004\133\004\133\000\129\000\129\004\133\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\000\000\129\000\000\000\129\000\129\019\230\000\129\000\129\000\000\006Z\000\129\000\129\006\006\000\129\000\129\000\129\000\129\r*\000\129\006n\000\129\000\129\000\000\006v\000\129\000\129\018\170\000\129\000\129\000\129\007\186\000\129\r6\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\003\146\019\026\000\129\000\129\000\000\001\006\000\129\000\129\br\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\005\166\002\029\000\129\000\000\tU\000\129\000\000\000\129\000\000\000\129\000\000\000\000\000\000\b6\000\129\000\129\000\129\000\129\000\129\000\129\007=\000\129\000\129\000\129\007=\t\174\002N\000\129\000\n\014B\000\129\003\134\000\129\000\238\000\222\000\000\023v\000\000\000\129\000\000\023\134\023\150\023\162\000\000\000\129\000\129\000\129\000\129\b\142\002}\000\129\000\129\000\129\000\129\002}\001\002\001\006\002}\002\029\000\000\001\"\002}\000\238\002}\000\000\001&\002}\000\000\002}\002}\002}\000\000\002}\002}\002}\001*\000\000\024\190\000\000\001.\002}\002}\002}\002}\002}\000\000\002}\000\000\0012\000\000\003z\000\000\002}\002}\002}\002}\002}\007=\000\000\003\206\b\214\002}\000\000\002}\000\000\002}\002}\003F\000\000\000\000\003\214\002}\002}\002}\b\194\b\198\b\210\004\022\015\018\005\150\002}\002}\002}\002}\002}\002}\002}\002}\002}\000\000\n\006\nn\000\000\002}\002}\002}\000\000\000\000\000\000\004=\000\000\005\162\002}\005\166\002}\002}\002}\000\000\002}\002}\002}\002}\b\218\n\014\b\222\000\000\nv\002}\000\000\002}\002}\001\006\002}\002}\002}\002}\002}\002}\005\170\b\238\002}\002}\002}\t\146\004j\000\000\002\145\002}\002}\002}\002}\002\145\000\238\025\134\002\145\000\000\000\000\000\000\002\145\000\000\002\145\000\000\000\000\002\145\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\000\000\000\000\001\186\002N\000\000\002\145\002\145\002\145\002\145\002\145\b\142\002\145\000\000\004=\000\000\028\147\000\000\002\145\002\145\002\145\002\145\002\145\000\000\000\000\000\238\000\000\002\145\000\000\002\145\006Z\002\145\002\145\006\006\007*\000\000\000\000\002\145\002\145\002\145\006n\r&\000\000\000\000\006v\001\"\002\145\002\145\002\145\002\145\002\145\002\145\002\145\002\145\002\145\000\000\n\006\nn\000\000\002\145\002\145\002\145\000\000\014f\000\000\000\000\000\000\002\029\002\145\003\146\002\145\002\145\002\145\000\000\002\145\002\145\002\145\002\145\025\138\n\014\000\000\000\000\nv\002\145\r*\002\145\002\145\007\186\002\145\002\145\002\145\002\145\002\145\002\145\000\n\000\000\002\145\002\145\002\145\r6\000\000\014\138\002\141\002\145\002\145\002\145\002\145\002\141\bz\003\146\002\141\002\029\001\186\002N\002\141\000\000\002\141\005M\000\000\002\141\000\000\002\141\002\141\002\141\002\029\002\141\002\141\002\141\005\166\000\000\005M\b6\000\000\002\141\002\141\002\141\002\141\002\141\000\000\002\141\014\150\007\186\000\000\000\000\000\000\002\141\002\141\002\141\002\141\002\141\007\186\000\238\005\222\000\000\002\141\000\000\002\141\014.\002\141\002\141\000\000\005M\b\166\003\246\002\141\002\141\002\141\006\150\r&\004\002\000\000\t\214\001\"\002\141\002\141\002\141\002\141\002\141\002\141\002\141\002\141\002\141\000\000\n\006\nn\b6\002\141\002\141\002\141\000\000\000\000\000\000\005M\000\000\b6\002\141\005M\002\141\002\141\002\141\000\000\002\141\002\141\002\141\002\141\000\238\n\014\000\000\000\000\nv\002\141\r*\002\141\002\141\000\238\002\141\002\141\002\141\002\141\002\141\002\141\000\000\000\000\002\141\002\141\002\141\r6\003B\014j\002\129\002\141\002\141\002\141\002\141\002\129\000\000\003\146\002\129\000\000\000\000\028w\002\129\000\000\002\129\000\000\000\000\002\129\000\000\002\129\002\129\002\129\000\000\002\129\002\129\002\129\005\166\000\000\000\000\000\000\000\000\002\129\002\129\002\129\002\129\002\129\000\000\002\129\014v\007\186\000\000\000\000\000\000\002\129\002\129\002\129\002\129\002\129\007\186\000\000\t\174\023\218\002\129\000\000\002\129\014.\002\129\002\129\000\000\000\000\025\146\023v\002\129\002\129\002\129\023\134\023\150\023\162\000\000\025\206\000\000\002\129\002\129\002\129\002\129\002\129\002\129\002\129\002\129\002\129\000\000\n\006\nn\b6\002\129\002\129\002\129\000\000\000\000\000\000\006V\000\000\b6\002\129\000\000\002\129\002\129\002\129\000\000\002\129\002\129\002\129\002\129\000\238\n\014\007\186\000\000\nv\002\129\000\000\002\129\002\129\000\238\002\129\002\129\002\129\002\129\002\129\002\129\000\000\bE\002\129\002\129\002\129\bE\000\000\025\218\002E\002\129\002\129\002\129\002\129\002E\000\238\000\000\002E\000\000\000\000\000\000\002E\000\000\002E\014\182\000\000\002E\000\000\002E\002E\002E\b6\002E\002E\002E\012E\012E\000\000\000\000\012E\002E\002E\002E\002E\002E\bE\002E\000\000\t\142\000\000\000\000\000\238\002E\002E\002E\002E\002E\000\000\000\000\000\000\bE\002E\000\000\002E\006Z\002E\002E\006\006\006b\000\000\0276\002E\002E\002E\006n\000\000\012u\000\000\006v\000\238\002E\002E\002E\002E\002E\002E\002E\002E\002E\bE\000\000\002E\000\000\002E\002E\002E\000\000\012u\000\000\000\000\002\194\025\222\002E\002\198\002E\002E\002E\000\000\002E\002E\002E\002E\012E\000\238\000\000\000\000\002\210\002E\bE\002E\002E\000\000\002\025\002E\002E\002E\002E\002E\tz\nJ\002E\002E\t^\007\186\000\000\023\170\002\025\002E\002E\002E\002E\002\025\000\000\004N\002\025\002\222\024\018\000\000\002\025\000\000\002\025\000\000\000\000\002\025\025\230\002\025\002\025\002\025\000\000\002\025\002\025\002\025\006Z\000\000\000\000\006\006\027:\002\025\002\025\002\025\002\025\002\025\006n\002\025\000\000\000\000\006v\b6\000\000\002\025\002\025\002\025\002\025\002\025\000\000\r&\004\146\004Z\002\025\001\"\002\025\000\000\002\025\002\025\002\226\004\026\004&\000\238\002\025\002\025\002\025\0042\000\000\000\000\000\000\000\000\000\000\002\025\002\025\002\025\002\025\002\025\002\025\002\025\002\025\002\025\n\006\nn\002\025\000\000\002\025\002\025\002\025\022&\t-\000\000\t-\t-\r*\002\025\000\000\002\025\002\025\002\025\000\000\002\025\002\025\002\025\002\025\n\014\007\229\007\186\nv\r6\002\025\000\000\002\025\002\025\000\000\002\025\002\025\002\025\002\025\002\025\002\025\000\000\000\000\002\025\002\025\t^\000\000\000\000\027\022\002\137\002\025\002\025\002\025\002\025\002\137\n\149\000\000\002\137\005\166\007\229\000\000\002\137\000\000\002\137\000\000\000\000\002\137\000\000\002\137\002\137\002\137\b6\002\137\002\137\002\137\007\229\000\000\000\000\007\229\t\234\002\137\002\137\002\137\002\137\002\137\007\229\002\137\026\166\n\149\007\229\000\000\000\238\002\137\002\137\002\137\002\137\002\137\000\000\b\225\000\000\000\000\002\137\011b\002\137\n\149\002\137\002\137\n\149\011\182\007\186\t-\002\137\002\137\002\137\n\149\000\000\000\000\000\000\n\149\000\000\002\137\002\137\002\137\002\137\002\137\002\137\002\137\002\137\002\137\000\000\027.\002\137\000\000\002\137\002\137\002\137\000\000\000\000\001&\b\225\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\b6\000\000\001F\002\029\002\137\000\000\002\137\002\137\b\225\n\138\002\137\002\137\002\137\002\137\002\137\001R\000\000\002\137\002\137\002\137\000\238\b\245\000\000\0035\002\137\002\137\002\137\002\137\0035\000\000\000\000\0035\000\000\000\n\000\000\0035\000\000\0035\000\000\005\150\n\202\000\000\0035\011\146\0035\b\225\0035\0035\0035\004\230\002\029\000\000\b\225\000\000\n\210\n\234\n\242\n\250\011\002\002^\0035\005\162\000\238\002\029\002\029\000\000\0035\0035\011\n\011\018\0035\000\000\b\221\000\000\000\000\0035\000\000\0035\001*\011\026\0035\000\000\000\000\000\000\000\000\0035\0035\000\238\005\170\000\000\000\000\016\030\000\000\000\000\0035\0035\011\"\011*\0112\011:\011B\0035\0035\0036\000\000\0035\016\150\0035\0035\011J\003F\b\245\000\000\b\221\000\000\000\000\0035\016\174\0035\0035\011R\t)\0035\0035\0035\0035\000\000\000\000\000\000\000\000\000\000\0035\000\000\0035\0035\b\221\0035\0035\011Z\011j\0035\0035\000\000\007e\0035\011r\0035\007e\000\000\000\000\002\021\0035\0035\011z\011\130\002\021\000\238\000\000\002\021\000\000\000\000\000\000\002\021\000\000\002\021\000\000\000\000\n\202\000\000\002\021\002\021\002\021\b\221\002\021\002\021\002\021\004\230\000\000\000\000\b\221\000\000\n\210\n\234\n\242\n\250\011\002\000\000\002\021\000\000\011\202\000\000\000\000\000\000\002\021\002\021\011\n\011\018\002\021\000\000\000\000\000\000\000\000\002\021\000\000\002\021\011\210\011\026\002\021\011\218\000\000\000\000\000\000\002\021\002\021\000\238\011\226\000\000\000\000\000\000\011\234\007e\002\021\002\021\011\"\011*\0112\011:\011B\002\021\002\021\000\000\000\000\002\021\000\000\002\021\002\021\011J\n:\000\000\000\000\nB\000\000\000\000\002\021\000\000\002\021\002\021\011R\000\000\002\021\002\021\002\021\002\021\000\000\000\238\000\000\000\000\000\000\002\021\000\000\002\021\002\021\000\000\002\021\002\021\011Z\011j\002\021\002\021\000\000\000\000\002\021\011r\002\021\000\000\000\000\000\000\002\225\002\021\002\021\011z\011\130\002\225\007\249\000\000\002\225\000\000\007\225\000\000\002\225\000\000\002\225\002^\000\000\002\225\000\000\002\225\002\225\002\225\000\000\002\225\002\225\002\225\007\225\000\000\0266\006\006\000\000\002\225\002\225\002\225\002\225\002\225\007\225\002\225\000\000\007\249\007\225\000\000\000\000\002\225\002\225\002\225\002\225\002\225\000\000\000\000\000\000\000\000\002\225\000\000\002\225\007\249\002\225\002\225\006\006\0036\000\000\000\000\002\225\002\225\002\225\007\249\000\000\000\000\000\000\007\249\000\000\002\225\002\225\002\225\002\225\002\225\002\225\002\225\002\225\002\225\000\000\000\000\002\225\000\000\002\225\002\225\002\225\000\000\000\000\000\000\004\198\000\000\000\000\002\225\005)\002\225\002\225\002\225\000\000\002\225\002\225\002\225\002\225\000\000\000\238\000\000\000\000\000\000\002\225\000\000\002\225\002\225\000\000\011b\002\225\002\225\002\225\002\225\002\225\000\000\000\000\002\225\002\225\002\225\000\000\000\000\000\000\003\r\002\225\002\225\002\225\002\225\003\r\b\t\000\000\003\r\000\000\b\r\000\000\003\r\000\000\003\r\000\000\000\000\003\r\000\000\003\r\003\r\003\r\000\000\003\r\003\r\003\r\006Z\000\000\000\000\006\006\000\000\003\r\003\r\003\r\003\r\003\r\b\r\003\r\000\000\b\t\b\r\000\000\000\000\003\r\003\r\003\r\003\r\003\r\000\000\000\000\000\000\000\000\003\r\000\000\003\r\011\254\003\r\003\r\b\t\000\000\000\000\000\000\003\r\003\r\003\r\b\t\000\000\000\000\000\000\b\t\000\000\003\r\003\r\003\r\003\r\003\r\003\r\003\r\003\r\003\r\000\000\000\000\003\r\000\000\003\r\003\r\003\r\000\000\000\000\000\000\000\000\000\000\000\000\003\r\000\000\003\r\003\r\003\r\000\000\003\r\003\r\003\r\003\r\000\000\000\238\000\000\000\000\000\000\003\r\000\000\003\r\003\r\000\000\011b\003\r\003\r\003\r\003\r\003\r\000\000\000\000\003\r\003\r\003\r\000\000\000\000\000\000\003\029\003\r\003\r\003\r\003\r\003\029\000\238\000\000\003\029\000\000\007\221\000\000\003\029\000\000\003\029\000\000\000\000\003\029\000\000\003\029\003\029\003\029\000\000\003\029\003\029\003\029\007\221\000\000\000\000\006\006\000\000\003\029\003\029\003\029\003\029\003\029\007\221\003\029\000\000\023J\007\221\000\000\000\000\003\029\003\029\003\029\003\029\003\029\000\000\000\000\000\000\000\000\003\029\000\000\003\029\011\210\003\029\003\029\011\218\000\000\000\000\000\000\003\029\003\029\003\029\011\226\000\000\000\000\000\000\011\234\000\000\003\029\003\029\003\029\003\029\003\029\003\029\003\029\003\029\003\029\000\000\000\000\003\029\000\000\003\029\003\029\003\029\000\000\000\000\000\000\000\000\000\000\000\000\003\029\000\000\003\029\003\029\003\029\000\000\003\029\003\029\003\029\003\029\007I\000\000\012M\012M\007I\003\029\012M\003\029\003\029\000\000\011b\003\029\003\029\003\029\003\029\003\029\000\000\000\000\003\029\003\029\003\029\000\000\000\000\000\000\003\021\003\029\003\029\003\029\003\029\003\021\002\029\001\162\003\021\000\000\015\242\001\"\003\021\000\000\003\021\000\000\000\000\003\021\000\000\003\021\003\021\003\021\000\238\003\021\003\021\003\021\012I\012I\000\000\000\000\012I\003\021\003\021\003\021\003\021\003\021\000\n\003\021\000\000\000\000\007I\000\000\000\000\003\021\003\021\003\021\003\021\003\021\000\000\000\000\027\198\002j\003\021\002\029\003\021\012M\003\021\003\021\000\000\000\000\000\000\000\000\003\021\003\021\003\021\r6\002\029\002\029\000\000\011b\000\238\003\021\003\021\003\021\003\021\003\021\003\021\003\021\003\021\003\021\000\000\000\000\003\021\000\000\003\021\003\021\003\021\000\000\000\000\000\000\000\000\000\000\000\000\003\021\005\166\003\021\003\021\003\021\000\000\003\021\003\021\003\021\003\021\012I\000\000\007A\000\000\000\000\003\021\007A\003\021\003\021\000\000\011b\003\021\003\021\003\021\003\021\003\021\000\000\000\000\003\021\003\021\003\021\000\000\000\000\000\000\003\001\003\021\003\021\003\021\003\021\003\001\000\000\001\006\003\001\000\000\000\000\000\000\003\001\000\000\003\001\000\000\000\000\003\001\000\000\003\001\003\001\003\001\000\238\003\001\003\001\003\001\b9\000\000\000\000\000\000\b9\003\001\003\001\003\001\003\001\003\001\000\000\003\001\000\000\000\000\000\000\000\000\000\000\003\001\003\001\003\001\003\001\003\001\000\000\000\000\nz\003\134\003\001\000\000\003\001\007A\003\001\003\001\000\000\000\000\000\000\000\000\003\001\003\001\003\001\021\246\000\000\022\002\000\000\000\000\b9\003\001\003\001\003\001\003\001\003\001\003\001\003\001\003\001\003\001\000\000\000\000\003\001\000\000\003\001\003\001\003\001\000\000\000\000\000\000\b5\000\000\b9\003\001\b5\003\001\003\001\003\001\000\000\003\001\003\001\003\001\003\001\000\000\000\000\000\000\000\000\000\000\003\001\000\000\003\001\003\001\000\000\011b\003\001\003\001\003\001\003\001\003\001\000\000\000\000\003\001\003\001\003\001\000\000\000\000\000\000\003\t\003\001\003\001\003\001\003\001\003\t\004\230\b5\003\t\000\000\000\000\000\000\003\t\000\000\003\t\000\000\000\000\003\t\000\000\003\t\003\t\003\t\000\000\003\t\003\t\003\t\000\000\000\000\000\000\b5\000\000\003\t\003\t\003\t\003\t\003\t\000\000\003\t\000\000\000\000\000\000\000\000\000\000\003\t\003\t\003\t\003\t\003\t\000\000\000\000\000\000\000\000\003\t\000\000\003\t\000\000\003\t\003\t\000\000\000\000\000\000\000\000\003\t\003\t\003\t\000\000\000\000\000\000\000\000\000\000\004\230\003\t\003\t\003\t\003\t\003\t\003\t\003\t\003\t\003\t\000\000\000\000\003\t\000\000\003\t\003\t\003\t\000\000\000\000\000\000\000\000\000\000\000\000\003\t\000\000\003\t\003\t\003\t\000\000\003\t\003\t\003\t\003\t\000\000\000\000\000\000\000\000\000\000\003\t\000\000\003\t\003\t\000\000\011b\003\t\003\t\003\t\003\t\003\t\000\000\000\000\003\t\003\t\003\t\000\000\000\000\000\000\003\005\003\t\003\t\003\t\003\t\003\005\000\000\001\006\003\005\000\000\000\000\000\000\003\005\000\000\003\005\000\000\000\000\003\005\000\000\003\005\003\005\003\005\000\000\003\005\003\005\003\005\000\000\000\000\000\000\000\000\000\000\003\005\003\005\003\005\003\005\003\005\000\000\003\005\000\000\000\000\000\000\000\000\000\000\003\005\003\005\003\005\003\005\003\005\000\000\000\000\022\142\003\134\003\005\000\000\003\005\000\000\003\005\003\005\000\000\000\000\000\000\000\000\003\005\003\005\003\005\022\162\000\000\022\182\000\000\000\000\000\000\003\005\003\005\003\005\003\005\003\005\003\005\003\005\003\005\003\005\000\000\000\000\003\005\000\000\003\005\003\005\003\005\000\000\000\000\000\000\000\000\000\000\000\000\003\005\000\000\003\005\003\005\003\005\000\000\003\005\003\005\003\005\003\005\000\000\000\000\000\000\000\000\000\000\003\005\000\000\003\005\003\005\000\000\011b\003\005\003\005\003\005\003\005\003\005\000\000\000\000\003\005\003\005\003\005\000\000\000\000\000\000\003\017\003\005\003\005\003\005\003\005\003\017\000\000\000\000\003\017\000\000\000\000\000\000\003\017\000\000\003\017\000\000\000\000\003\017\000\000\003\017\003\017\003\017\000\000\003\017\003\017\003\017\000\000\000\000\000\000\000\000\000\000\003\017\003\017\003\017\003\017\003\017\000\000\003\017\000\000\000\000\000\000\000\000\000\000\003\017\003\017\003\017\003\017\003\017\000\000\000\000\000\000\000\000\003\017\000\000\003\017\000\000\003\017\003\017\000\000\000\000\000\000\000\000\003\017\003\017\003\017\000\000\000\000\000\000\000\000\000\000\000\000\003\017\003\017\003\017\003\017\003\017\003\017\003\017\003\017\003\017\000\000\000\000\003\017\000\000\003\017\003\017\003\017\000\000\000\000\000\000\000\000\000\000\000\000\003\017\000\000\003\017\003\017\003\017\000\000\003\017\003\017\003\017\003\017\000\000\000\000\000\000\000\000\000\000\003\017\000\000\003\017\003\017\000\000\011b\003\017\003\017\003\017\003\017\003\017\000\000\000\000\003\017\003\017\003\017\000\000\000\000\000\000\003!\003\017\003\017\003\017\003\017\003!\000\000\000\000\003!\000\000\000\000\000\000\003!\000\000\003!\000\000\000\000\003!\000\000\003!\003!\003!\000\000\003!\003!\003!\000\000\000\000\000\000\000\000\000\000\003!\003!\003!\003!\003!\000\000\003!\000\000\000\000\000\000\000\000\000\000\003!\003!\003!\003!\003!\000\000\000\000\000\000\000\000\003!\000\000\003!\000\000\003!\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!\003!\003!\003!\003!\003!\003!\003!\000\000\000\000\003!\000\000\003!\003!\003!\000\000\000\000\000\000\000\000\000\000\000\000\003!\000\000\003!\003!\003!\000\000\003!\003!\003!\003!\000\000\000\000\000\000\000\000\000\000\003!\000\000\003!\003!\000\000\011b\003!\003!\003!\003!\003!\000\000\000\000\003!\003!\003!\000\000\000\000\000\000\003\025\003!\003!\003!\003!\003\025\000\000\000\000\003\025\000\000\000\000\000\000\003\025\000\000\003\025\000\000\000\000\003\025\000\000\003\025\003\025\003\025\000\000\003\025\003\025\003\025\000\000\000\000\000\000\000\000\000\000\003\025\003\025\003\025\003\025\003\025\000\000\003\025\000\000\000\000\000\000\000\000\000\000\003\025\003\025\003\025\003\025\003\025\000\000\000\000\000\000\000\000\003\025\000\000\003\025\000\000\003\025\003\025\000\000\000\000\000\000\000\000\003\025\003\025\003\025\000\000\000\000\000\000\000\000\000\000\000\000\003\025\003\025\003\025\003\025\003\025\003\025\003\025\003\025\003\025\000\000\000\000\003\025\000\000\003\025\003\025\003\025\000\000\000\000\000\000\000\000\000\000\000\000\003\025\000\000\003\025\003\025\003\025\000\000\003\025\003\025\003\025\003\025\000\000\000\000\000\000\000\000\000\000\003\025\000\000\003\025\003\025\000\000\011b\003\025\003\025\003\025\003\025\003\025\000\000\000\000\003\025\003\025\003\025\000\000\000\000\000\000\002\253\003\025\003\025\003\025\003\025\002\253\000\000\000\000\002\253\000\000\000\000\000\000\002\253\000\000\002\253\000\000\000\000\002\253\000\000\002\253\002\253\002\253\000\000\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\002\253\002\253\002\253\002\253\002\253\000\000\002\253\000\000\000\000\000\000\000\000\000\000\002\253\002\253\002\253\002\253\002\253\000\000\000\000\000\000\000\000\002\253\000\000\002\253\000\000\002\253\002\253\000\000\000\000\000\000\000\000\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\000\000\002\253\002\253\002\253\002\253\002\253\002\253\002\253\002\253\002\253\000\000\000\000\002\253\000\000\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\000\000\002\253\000\000\002\253\002\253\002\253\000\000\002\253\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\002\253\000\000\002\253\002\253\000\000\011b\002\253\002\253\002\253\002\253\002\253\000\000\000\000\002\253\002\253\002\253\000\000\000\000\000\000\ta\002\253\002\253\002\253\002\253\ta\000\000\000\000\ta\000\000\000\000\000\000\ta\000\000\ta\000\000\000\000\ta\000\000\ta\ta\ta\000\000\ta\ta\ta\000\000\000\000\000\000\000\000\000\000\ta\ta\ta\ta\ta\000\000\ta\000\000\000\000\000\000\000\000\000\000\ta\ta\ta\ta\ta\000\000\000\000\000\000\000\000\ta\000\000\ta\000\000\ta\ta\000\000\000\000\000\000\000\000\ta\ta\ta\000\000\000\000\000\000\000\000\000\000\000\000\ta\ta\ta\ta\ta\ta\ta\ta\ta\000\000\000\000\ta\000\000\ta\ta\ta\000\000\000\000\000\000\000\000\000\000\000\000\ta\000\000\ta\ta\ta\000\000\ta\ta\ta\ta\000\000\000\000\000\000\000\000\000\000\ta\000\000\ta\ta\000\000\ta\ta\ta\ta\ta\ta\000\000\000\000\ta\ta\t^\000\000\000\000\000\000\002q\ta\ta\ta\ta\002q\000\000\000\000\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\000\000\000\000\000\000\002q\002q\002q\002q\002q\000\000\002q\000\000\000\000\000\000\000\000\000\000\002q\002q\002q\002q\002q\000\000\000\000\000\000\000\000\002q\000\000\002q\000\000\002q\002q\000\000\000\000\000\000\000\000\002q\002q\002q\000\000\000\000\000\000\000\000\000\000\000\000\002q\002q\002q\002q\002q\002q\002q\002q\002q\000\000\000\000\002q\000\000\002q\002q\002q\000\000\000\000\000\000\000\000\000\000\000\000\002q\000\000\002q\002q\002q\000\000\002q\002q\024^\002q\000\000\000\000\000\000\000\000\000\000\002q\000\000\002q\002q\000\000\011b\002q\002q\002q\002q\002q\000\000\000\000\002q\002q\002q\000\000\000\000\000\000\002m\002q\002q\002q\002q\002m\000\000\000\000\002m\000\000\000\000\000\000\002m\000\000\002m\000\000\000\000\002m\000\000\002m\002m\002m\000\000\002m\002m\002m\000\000\000\000\000\000\000\000\000\000\002m\002m\002m\002m\002m\000\000\002m\000\000\000\000\000\000\000\000\000\000\002m\002m\002m\002m\002m\000\000\000\000\000\000\000\000\002m\000\000\002m\000\000\002m\002m\000\000\000\000\000\000\000\000\002m\002m\002m\000\000\000\000\000\000\000\000\000\000\000\000\002m\002m\002m\002m\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\000\000\000\000\000\000\000\002m\000\000\002m\002m\000\000\011b\002m\002m\002m\002m\002m\000\000\000\000\002m\002m\002m\000\000\000\000\000\000\002\249\002m\002m\002m\002m\002\249\000\000\000\000\002\249\000\000\000\000\000\000\002\249\000\000\002\249\000\000\000\000\002\249\000\000\002\249\002\249\002\249\000\000\002\249\002\249\002\249\000\000\000\000\000\000\000\000\000\000\002\249\002\249\002\249\002\249\002\249\000\000\002\249\000\000\000\000\000\000\000\000\000\000\002\249\002\249\002\249\002\249\002\249\000\000\000\000\000\000\000\000\002\249\000\000\002\249\000\000\002\249\002\249\000\000\000\000\000\000\000\000\002\249\002\249\002\249\000\000\000\000\000\000\000\000\000\000\000\000\002\249\002\249\002\249\002\249\002\249\002\249\002\249\002\249\002\249\000\000\000\000\002\249\000\000\002\249\002\249\002\249\000\000\000\000\000\000\000\000\000\000\000\000\002\249\000\000\002\249\002\249\002\249\000\000\002\249\002\249\002\249\002\249\000\000\000\000\000\000\000\000\000\000\002\249\000\000\002\249\002\249\000\000\011b\002\249\002\249\002\249\002\249\002\249\000\000\000\000\002\249\002\249\002\249\000\000\000\000\000\000\002e\002\249\002\249\002\249\002\249\002e\000\000\000\000\002e\000\000\000\000\000\000\002e\000\000\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\002e\002e\002e\002e\002e\000\000\002e\000\000\000\000\000\000\000\000\000\000\002e\002e\002e\002e\002e\000\000\000\000\000\000\000\000\002e\000\000\002e\000\000\002e\002e\000\000\000\000\000\000\000\000\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\000\000\002e\002e\002e\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\000\000\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\000\000\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\002e\000\000\000\000\000\000\000\000\000\000\002e\000\000\002e\002e\000\000\002e\002e\002e\002e\002e\002e\000\000\000\000\002e\002e\t^\000\000\000\000\000\000\001\245\002e\002e\002e\002e\001\245\000\000\000\000\001\245\000\000\000\000\000\000\001\245\000\000\001\245\000\000\000\000\001\245\000\000\001\245\001\245\001\245\000\000\001\245\001\245\001\245\000\000\000\000\000\000\000\000\000\000\001\245\001\245\001\245\001\245\001\245\000\000\001\245\000\000\000\000\000\000\000\000\000\000\001\245\001\245\001\245\001\245\001\245\000\000\000\000\000\000\000\000\001\245\000\000\001\245\000\000\001\245\001\245\000\000\000\000\000\000\000\000\001\245\001\245\001\245\000\000\000\000\000\000\000\000\000\000\000\000\001\245\001\245\001\245\001\245\001\245\001\245\001\245\001\245\001\245\000\000\000\000\001\245\000\000\001\245\001\245\001\245\000\000\000\000\000\000\000\000\000\000\000\000\001\245\000\000\001\245\001\245\001\245\000\000\001\245\001\245\001\245\001\245\000\000\000\000\000\000\000\000\000\000\001\245\000\000\001\245\001\245\000\000\001\245\001\245\001\245\001\245\001\245\001\245\000\000\000\000\001\245\001\245\t^\000\000\000\000\000\000\002i\001\245\001\245\001\245\001\245\002i\000\000\000\000\002i\000\000\000\000\000\000\002i\000\000\002i\000\000\000\000\002i\000\000\002i\002i\002i\000\000\002i\002i\002i\000\000\000\000\000\000\000\000\000\000\002i\002i\002i\002i\002i\000\000\002i\000\000\000\000\000\000\000\000\000\000\002i\002i\002i\002i\002i\000\000\000\000\000\000\000\000\002i\000\000\002i\000\000\002i\002i\000\000\000\000\000\000\000\000\002i\002i\002i\000\000\000\000\000\000\000\000\000\000\000\000\002i\002i\002i\002i\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\t^\000\000\000\000\000\000\027b\002i\002i\002i\002i\001\249\000\000\000\000\001\249\000\000\000\000\000\000\001\249\000\000\001\249\000\000\000\000\001\249\000\000\001\249\001\249\001\249\000\000\001\249\001\249\001\249\000\000\000\000\000\000\000\000\000\000\001\249\001\249\001\249\001\249\001\249\000\000\001\249\000\000\000\000\000\000\000\000\000\000\001\249\001\249\001\249\001\249\001\249\000\000\000\000\000\000\000\000\001\249\000\000\001\249\000\000\001\249\001\249\000\000\000\000\000\000\000\000\001\249\001\249\001\249\000\000\000\000\000\000\000\000\000\000\000\000\001\249\001\249\001\249\001\249\001\249\001\249\001\249\001\249\001\249\000\000\000\000\001\249\000\000\001\249\001\249\001\249\000\000\000\000\000\000\000\000\000\000\000\000\027r\000\000\001\249\001\249\001\249\000\000\001\249\001\249\001\249\001\249\000\000\000\000\000\000\000\000\000\000\001\249\000\000\001\249\001\249\000\000\001\249\001\249\001\249\001\249\001\249\001\249\000\000\000\000\001\249\001\249\001\249\000\000\000\000\000\000\001\253\001\249\001\249\001\249\001\249\001\253\000\000\000\000\001\253\000\000\000\000\000\000\001\253\000\000\001\253\000\000\000\000\001\253\000\000\001\253\001\253\001\253\000\000\001\253\001\253\001\253\000\000\000\000\000\000\000\000\000\000\001\253\001\253\001\253\001\253\001\253\000\000\001\253\000\000\000\000\000\000\000\000\000\000\001\253\001\253\001\253\001\253\001\253\000\000\000\000\000\000\000\000\001\253\000\000\001\253\000\000\001\253\001\253\000\000\000\000\000\000\000\000\001\253\001\253\001\253\000\000\000\000\000\000\000\000\000\000\000\000\001\253\001\253\001\253\001\253\001\253\001\253\001\253\001\253\001\253\000\000\000\000\001\253\000\000\001\253\001\253\001\253\000\000\000\000\000\000\000\000\000\000\000\000\027j\000\000\001\253\001\253\001\253\000\000\001\253\001\253\001\253\001\253\000\000\000\000\000\000\000\000\000\000\001\253\000\000\001\253\001\253\000\000\001\253\001\253\001\253\001\253\001\253\001\253\000\000\000\000\001\253\001\253\t^\000\000\000\000\000\000\000\000\001\253\001\253\001\253\001\253\000\006\000\246\000\000\000\000\007-\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\001f\000\000\000\000\000\000\007-\001*\000\000\000\000\000\000\003\210\001n\t\182\t\186\001z\001~\000\000\000\000\000\000\0012\000\000\003z\000\000\025v\000\000\t\218\t\222\007-\003\182\003\194\003\206\003\218\003\226\t\226\007b\000\000\001\206\007-\003F\000\000\000\000\003\214\007-\007-\000\238\b\194\b\198\b\210\b\226\000\000\005\150\007-\007-\001\210\001\214\001\218\001\222\001\226\000\000\000\000\b\250\001\230\000\000\000\000\000\000\000\000\001\234\000\000\t\006\t\030\tj\t~\005\162\000\000\005\166\000\000\000\000\001\238\000\000\000\000\007-\000\000\000\000\b\218\001\242\b\222\000\000\000\000\000\000\000\000\000\000\007-\000\000\000\000\000\000\002.\006J\000\000\000\000\005\170\b\238\000\000\0022\000\000\023j\004j\t\246\020\194\002:\000\000\002>\002B\000\006\000\246\000\000\000\000\001\153\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\000\000\000\000\t\178\000\000\000\000\000\000\001\153\001*\000\000\000\000\000\000\003\210\001n\t\182\t\186\001z\001~\000\000\000\000\000\000\0012\000\000\003z\000\000\t\190\000\000\t\218\t\222\001\153\003\182\003\194\003\206\003\218\003\226\t\226\007b\000\000\001\206\001\153\003F\000\000\000\000\003\214\001\153\001\153\000\238\b\194\b\198\b\210\b\226\000\000\005\150\001\153\001\153\001\210\001\214\001\218\001\222\001\226\000\000\000\000\b\250\001\230\000\000\000\000\000\000\000\000\001\234\000\000\t\006\t\030\tj\t~\005\162\000\000\005\166\000\000\000\000\001\238\000\000\000\000\001\153\000\000\000\000\b\218\001\242\b\222\000\000\006\170\000\000\007Y\tE\001\153\000\000\007Y\000\000\002.\006\134\000\000\000\000\005\170\b\238\000\000\0022\000\000\023j\004j\t\246\000\000\002:\000\000\002>\002B\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\000\000\000\000\003N\000\238\000\000\000\238\004\177\000\000\003R\001*\000\000\012\022\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\003^\000\000\0012\000\000\003z\000\000\012&\000\000\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\007\018\007b\012\181\000\000\012\178\003F\000\000\000\000\003\214\012\186\000\000\000\000\b\194\b\198\b\210\b\226\006Z\005\150\006Z\006\006\000\000\006\006\012\181\000\000\tE\012\194\006n\b\250\006n\000\000\006v\000\000\006v\000\000\000\000\t\006\t\030\tj\t~\005\162\000\000\005\166\012\214\r\026\012\181\000\000\004\177\004\177\000\000\000\000\b\218\000\000\b\222\000\000\012\181\000\000\000\000\000\000\000\000\012\181\012\181\000\238\000\000\000\000\r\250\018~\005\170\b\238\012\181\012\181\000\000\t\146\004j\t\246\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\000\000\000\000\004\209\000\000\000\000\000\000\000\000\012\181\003R\001*\000\000\001\006\000\000\001.\000\000\003V\003Z\000\000\012\181\000\000\003^\000\000\0012\t\026\003z\000\000\012&\000\000\003\174\003\178\001*\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\000\000\012\178\003F\000\000\018\154\003\214\012\186\002Z\002^\b\194\b\198\b\210\b\226\000\000\005\150\019\238\003\134\000\000\000\000\019\242\000\000\000\000\012\194\003F\b\250\024>\028\182\001*\002\134\002r\020\"\000\000\t\006\t\030\tj\t~\005\162\002~\005\166\012\214\r\026\000\000\000\000\028\215\024f\000\238\000\000\b\218\000\000\b\222\000\000\002\130\003.\000\000\0202\000\000\000\000\003:\000\000\003F\004\026\004&\018~\005\170\b\238\000\000\0042\000\000\t\146\004j\t\246\000\006\000\246\000\000\000\000\001\174\001\002\001\006\002\182\001\n\001\022\001\"\000\000\0046\000\000\000\000\001&\002\029\000\000\029\006\000\000\002\029\000\000\000\000\006Z\003R\001*\006\006\000\000\000\000\001.\000\000\003V\003Z\006n\000\000\000\000\003^\006v\0012\000\000\003z\000\000\012&\000\n\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\004j\012\178\003F\000\000\002\029\003\214\012\186\002Z\002^\b\194\b\198\b\210\b\226\000\000\005\150\000\000\000\000\000\000\002\029\002\029\000\000\000\000\012\194\000\000\b\250\000\000\028\182\001*\002\134\002r\000\000\000\000\t\006\t\030\tj\t~\005\162\002~\005\166\012\214\r\026\000\000\000\000\004\217\002\142\000\000\000\000\b\218\002\029\b\222\000\000\002\130\003.\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\018~\005\170\b\238\000\000\0042\000\000\t\146\004j\t\246\000\145\001\002\001\006\000\145\012\169\000\000\001\"\000\000\n.\000\000\000\000\001&\0046\000\000\000\145\000\000\000\145\000\000\000\145\000\000\000\145\001*\000\000\n^\005}\001.\000\000\000\000\005}\000\000\000\000\nf\000\145\000\000\0012\000\000\003z\000\000\000\145\000\000\000\000\000\000\000\145\000\000\000\000\003\206\002N\000\145\012u\000\145\000\000\000\000\000\145\003F\000\000\000\000\003\214\000\145\000\145\000\145\b\194\b\198\b\210\000\000\020R\005\150\000\145\000\145\000\000\012u\000\000\000\000\002\194\000\145\000\000\002\198\000\000\000\145\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\169\012\169\005\162\002\210\005\166\000\145\000\145\002\218\012a\000\145\000\145\000\000\000\000\b\218\000\000\b\222\005}\000\000\000\000\000\000\000\000\000\145\000\000\012\169\000\000\000\000\012\169\000\145\000\145\005\170\b\238\000\000\002\222\005}\t\146\004j\005}\000\145\000\000\000\145\000\169\001\002\001\006\000\169\000\000\000\000\001\"\000\000\n.\000\000\000\000\001&\000\000\000\000\000\169\000\000\000\169\000\000\000\169\000\000\000\169\001*\000\000\n^\000\000\001.\000\000\002\029\002\029\012*\000\000\nf\000\169\000\000\0012\000\000\003z\000\000\000\169\000\000\000\000\002\226\000\169\002\029\000\000\003\206\002N\000\169\000\000\000\169\000\000\002\029\000\169\003F\000\000\000\n\003\214\000\169\000\169\000\169\b\194\b\198\b\210\000\000\020R\005\150\000\169\000\169\012\030\000\000\000\000\002\029\000\000\000\169\000\000\000\000\000\000\000\169\000\000\000\000\000\n\002\029\002\029\015:\000\000\002\029\000\000\005\162\b%\005\166\000\169\000\169\000\000\002\029\000\169\000\169\002\029\002\029\b\218\000\000\b\222\000\000\000\000\002\029\000\000\000\000\000\169\000\000\002\029\000\n\002\029\000\000\000\169\000\169\005\170\b\238\000\000\002\029\002\029\t\146\004j\000\000\000\169\000\014\000\169\000\018\000\022\000\026\000\030\000\238\000\"\000&\000\000\000*\000.\0002\000\000\0006\000:\002\029\000\000\000>\000\000\000\000\000\000\000B\002\029\000\000\000\000\000\000\000\000\000\000\000F\000\000\000\000\000\000\000\000\002\029\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\006Z\000\000\000\000\006\006\000\000\000\000\000\000\002Z\002^\000\000\006n\000\000\000\000\000z\006v\000\000\000~\000\130\000\000\000\000\000\000\000\000\001f\000\134\000\138\000\142\000\000\001*\002\134\002r\000\000\000\000\000\146\000\150\000\154\000\000\000\158\002~\000\000\000\162\000\166\000\170\000\000\000\000\002\142\000\174\000\178\000\182\000\000\000\000\000\000\002\130\003.\000\186\000\000\000\190\000\194\003:\000\000\003F\004\026\004&\000\000\000\198\000\000\000\202\0042\004\r\001B\001\006\004\r\000\206\000\210\001\"\000\214\006\226\000\241\000\000\001&\000\000\000\000\004\r\000\000\0046\000\000\004\r\000\000\004\r\001*\000\000\007\002\000\000\000\000\000\000\000\000\001F\000\241\000\000\007\026\004\r\000\000\000\000\000\000\000\000\000\000\004\r\000\000\000\000\001R\000\000\000\000\000\000\007F\002N\004\r\000\000\004\r\r.\000\241\004\r\003F\001>\000\000\003\246\004\r\004\r\n\145\003\250\000\241\004\002\000\000\007V\005\150\000\241\000\000\000\000\000\000\000\000\000\000\000\000\004\r\004\r\000\241\000\241\005\154\000\000\002\029\002\029\000\000\000\000\000\000\000\000\000\000\000\000\005\162\002\029\005\166\004\r\004\r\007^\000\000\004\r\004\r\000\000\000\000\000\000\002\029\000\000\000\000\000\000\000\000\000\241\000\000\000\000\000\n\n\145\n:\000\000\n\145\025\026\004\r\005\170\000\241\000\000\000\000\n\145\000\000\004j\000\000\n\145\002\029\004\r\001B\001\006\006&\000\000\000\000\001\"\002\029\000\000\000\000\000\000\001&\001b\002\029\000\000\000\000\001f\000\000\000\000\000\000\000\000\001*\002\029\002\029\000\000\001j\001n\001r\001v\001z\001~\002\029\000\000\000\000\002\029\000\000\002\029\000\000\001\130\000\000\001\194\006F\002\029\000\000\000\000\001^\002N\000\000\001\202\000\000\000\n\001\206\000\000\003F\000\000\004\157\003\246\000\000\000\000\002\029\003\250\000\000\004\002\005\138\000\000\005\150\002\029\002\029\001\210\001\214\001\218\001\222\001\226\003b\002\029\004\157\001\230\005\154\000\000\000\000\002\029\001\234\000\000\000\000\000\000\000\000\000\000\005\162\000\000\005\166\000\000\005\230\001\238\000\000\000\000\000\000\000\000\004\157\000\000\001\242\000\000\000\000\000\000\002\029\000\000\000\000\000\000\004\157\000\000\000\000\002.\006J\004\157\012\014\005\170\000\000\000\000\0022\000\000\0026\004j\004\157\004\157\002:\012\169\002>\002B\001B\001\006\007J\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\001b\000\000\007j\000\000\001f\000\000\005\129\000\000\000\000\001*\005\129\001\162\004\157\001j\001n\001r\001v\001z\001~\000\000\000\000\000\000\001\166\004\157\000\000\007\146\001\130\000\000\001\194\006F\001*\000\000\000\000\001^\002N\000\000\001\202\000\000\000\000\001\206\000\000\003F\000\000\000\000\003\246\000\000\000\000\002\154\003\250\000\000\004\002\005\138\000\000\005\150\007\142\002j\001\210\001\214\001\218\001\222\001\226\000\000\003F\000\000\001\230\005\154\000\000\012\169\012\169\001\234\000\000\000\000\000\000\000\000\000\000\005\162\000\000\005\166\000\000\005\230\001\238\000\000\000\000\005\129\000\000\000\000\000\000\001\242\000\000\000\000\012\169\007\154\000\000\012\169\000\000\000\000\000\000\000\000\002.\006J\005\129\000\000\005\170\005\129\000\000\0022\000\000\0026\004j\000\000\000\000\002:\000\000\002>\002B\000\006\000\246\000\000\000\000\001\174\001\002\001\006\r\254\001\n\001\022\001\"\000\000\000\000\000\000\000\000\001&\000\000\000\000\015\n\000\000\t1\000\000\t1\t1\003R\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\015\014\000\000\0012\000\000\003z\000\000\0156\000\000\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\000\000\012\178\003F\000\000\000\000\003\214\012\186\000\000\000\000\b\194\b\198\b\210\b\226\000\000\005\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\202\000\000\b\250\000\000\000\000\002\029\002\029\000\000\000\000\000\000\n\022\t\030\tj\t~\005\162\000\000\005\166\012\214\015\222\000\000\000\000\004\165\004\165\000\000\000\000\b\218\002\029\b\222\000\000\002\029\002\029\000\000\002\029\000\n\002\029\002\029\000\000\002\029\002\029\002\029\015\238\005\170\b\238\t1\002\029\002\029\t\146\004j\t\246\002\029\002\029\000\000\000\000\000\000\002\029\000\000\000\000\000\000\002\029\000\000\002\029\002\029\000\n\002\029\000\000\007f\000\000\002\029\000\000\002\029\000\000\024\198\000\000\002\029\002\029\000\000\002\029\002\029\002\029\002\029\002\029\002\029\002\029\000\000\000\000\000\000\002\029\000\000\000\000\002\029\000\000\000\000\002\029\002\029\002\029\002\029\002\029\000\000\002\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\029\000\000\002\029\000\000\000\000\000\000\000\000\000\000\002\029\002\029\002\029\002\029\002\029\000\000\002\029\002\029\024\226\000\000\000\000\000\000\002\029\000\000\000\000\002\029\000\000\002\029\000\006\000\246\000\000\000\000\004\157\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\002\029\002\029\001&\000\000\000\000\002\029\002\029\002\029\000\000\003\254\000\000\004\157\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\003\174\003\178\004\157\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\000\000\004\157\003F\000\000\000\000\003\214\004\157\012\014\000\238\b\194\b\198\b\210\b\226\000\000\005\150\000\000\004\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\250\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\022\t\030\tj\t~\005\162\000\000\005\166\000\000\000\000\000\000\000\000\000\000\004\157\000\000\000\000\b\218\000\000\b\222\000\000\000A\000A\000\000\000\000\004\157\000A\000A\000\000\000A\000A\000A\000\000\005\170\b\238\025f\000A\000\000\t\146\004j\t\246\006\221\000\000\000\000\000\000\000\000\000A\000\000\000\000\000\000\000A\000\000\000A\000A\000\000\000\000\000\000\000\000\000\000\000A\000\000\000A\000\000\000\000\000\000\000A\000A\000\000\000A\000A\000A\000A\000A\000A\000A\000\000\000\000\000\000\000A\000\000\000\000\000A\000\000\000\000\000\000\000A\000A\000A\000A\000\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000A\000A\000A\000A\000\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000A\000\000\000A\000\000\000=\000=\000\000\000\000\018\166\000=\000=\000\000\000=\000=\000=\000\000\000A\000A\000\000\000=\000\000\000A\000A\000A\006\217\000\000\000\000\000\000\003R\000=\000\000\000\000\000\000\000=\000\000\000=\000=\000\000\000\000\000\000\000\000\000\000\000=\000\000\000=\000\000\000\000\000\000\000=\000=\019\022\000=\000=\000=\000=\000=\000=\000=\000\000\000\000\012\178\000=\000\000\000\000\000=\012\186\000\000\000\000\000=\000=\000=\000=\000\000\000=\019\210\019\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\004\201\000\000\000\000\000=\000\000\000=\000\000\012\005\012\005\000\000\000\000\020\226\012\005\012\005\000\000\012\005\012\005\012\005\000\000\000=\000=\000\000\012\005\000\000\000=\000=\000=\006\233\000\000\000\000\000\000\000\000\012\005\000\000\000\000\000\000\012\005\000\000\012\005\012\005\000\000\000\000\000\000\000\000\000\000\012\005\000\000\012\005\000\000\000\000\000\000\012\005\012\005\000\000\012\005\012\005\012\005\012\005\012\005\012\005\012\005\000\000\000\000\000\000\012\005\000\000\000\000\012\005\000\000\000\000\000\000\012\005\012\005\012\005\012\005\000\000\012\005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\005\012\005\012\005\012\005\012\005\000\000\012\005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\005\000\000\012\005\000\000\012\001\012\001\000\000\000\000\000\000\012\001\012\001\000\000\012\001\012\001\012\001\000\000\012\005\012\005\000\000\012\001\000\000\012\005\012\005\012\005\006\229\000\000\000\000\000\000\000\000\012\001\000\000\000\000\000\000\012\001\000\000\012\001\012\001\000\000\000\000\000\000\000\000\000\000\012\001\000\000\012\001\000\000\000\000\000\000\012\001\012\001\000\000\012\001\012\001\012\001\012\001\012\001\012\001\012\001\000\000\000\000\000\000\012\001\000\000\000\000\012\001\000\000\000\000\000\000\012\001\012\001\012\001\012\001\000\000\012\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\001\012\001\012\001\012\001\012\001\000\000\012\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\001\000\000\012\001\000\006\000\246\000\000\000\000\0166\001\002\001\006\000\000\001\n\001\022\001\"\000\000\000\000\012\001\012\001\001&\000\000\000\000\012\001\012\001\012\001\000\000\023\138\000\000\003R\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\003\174\003\178\016b\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\000\000\012\178\003F\000\000\000\000\003\214\012\186\000\000\000\000\b\194\b\198\b\210\b\226\000\000\005\150\000\000\016\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\250\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\022\t\030\tj\t~\005\162\000\000\005\166\000\000\000\000\000\000\000\000\000\000\004\193\000\000\000\000\b\218\000\000\b\222\000\000\000\006\000\246\000\000\000\000\016\242\001\002\001\006\000\000\001\n\001\022\001\"\000\000\005\170\b\238\023z\001&\000\000\t\146\004j\t\246\000\000\000\000\000\000\000\000\000\000\001*\000\000\000\000\000\000\001.\000\000\003V\003Z\000\000\000\000\000\000\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\003\174\003\178\000\000\003\182\003\194\003\206\003\218\003\226\007\018\007b\000\000\000\000\000\000\003F\000\000\000\000\003\214\000\000\000\000\000\000\b\194\b\198\b\210\b\226\000\000\005\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\250\000\000\000\000\000\000\005M\000\000\005M\005M\tN\t\030\tj\t~\005\162\005M\005\166\000\000\005M\000\000\005M\000\000\005M\005M\005M\b\218\005M\b\222\000\000\000\000\012u\012a\005M\000\000\005M\005M\005M\000\000\005M\005M\005M\005\170\b\238\000\000\005M\005M\t\146\004j\t\246\000\000\000\000\012u\005M\000\000\002\194\000\000\000\000\002\198\005M\005M\000\000\000\000\005M\005M\005M\005M\005M\005M\000\000\005M\002\210\000\000\005M\000\000\002\218\012a\000\000\005M\005M\005M\000\000\000\000\000\000\005M\000\000\000\000\005M\005M\000\000\000\000\000\000\000\000\000\000\005M\000\000\000\000\005M\005M\005M\002\222\005M\005M\004}\000\000\000\000\004}\000\000\000\000\000\000\000\000\005M\005M\005M\000\000\005M\005M\004}\000\000\017v\005M\004}\000\000\004}\000\000\000\000\000\000\005M\000\000\005M\005M\005M\000\000\0032\005M\004}\000\000\000\000\000\000\005M\000\000\004}\000\000\005M\n\173\005M\005M\n\173\n\173\002\226\000\000\000\000\n\173\000\000\n\173\004}\000\000\n\173\000\000\000\000\004}\n\173\n\173\000\000\n\173\n\173\000\000\n\173\000\000\n\173\000\000\000\000\000\000\000\000\n\173\000\000\004}\n\173\000\000\000\000\000\000\000\000\000\000\007\201\000\000\n\173\000\000\n\173\000\000\000\000\000\000\n\173\n\173\004}\004}\000\000\000\000\004}\004}\n\173\007\201\007\201\n\173\007\201\007\201\n\173\n\173\000\000\n\173\000\000\n\173\n\173\000\000\000\000\000\000\000\000\004}\000\000\000\000\000\000\n\173\000\000\000\000\n\173\007\201\000\000\000\000\015\130\000\000\000\000\000\000\000\000\000\000\n\173\000\000\n\173\000\000\000\000\n\173\000\000\n\173\000\000\000\000\000\000\007\201\000\000\000\000\005\198\000\000\000\000\000\000\000\000\000\000\000\000\n\173\n\173\000\000\n\173\n\173\007\201\n\173\000\000\n\173\000\000\n\173\012=\n\173\000\000\n\173\000\000\012=\000\000\002^\012=\000\000\000\000\000\000\007\201\000\249\007\201\000\000\000\000\004\190\000\000\012=\012=\012=\000\000\012=\012=\012=\000\000\000\000\005\254\000\000\000\000\007\201\007\201\000\249\000\000\000\000\007\201\012=\007\201\007\029\007\029\000\000\007\201\012=\012=\000\000\000\000\012=\000\000\000\000\000\000\0036\012=\000\000\012=\000\249\004*\012=\016&\007\029\007\029\007\029\012=\012=\012=\000\249\000\000\000\000\000\000\007\029\000\249\012=\012=\000\000\000\000\000\000\000\000\000\000\012=\000\000\000\249\000\000\004\198\007\029\007\029\000\000\012=\000\000\000\000\007\029\000\000\007\029\007\029\007\029\000\000\012=\012=\012=\007\029\012=\012=\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\249\000\000\000\000\012=\000\000\012=\012=\007\029\000\000\t!\012=\000\249\000\000\000\000\t!\012=\002^\t!\000\000\012=\000\000\012=\012=\000\000\002Z\002^\t!\000\000\t!\t!\t!\000\000\t!\t!\t!\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\002\134\t!\000\000\004\030\000\000\007\029\000\000\t!\t!\000\000\000\000\t!\000\000\000\000\000\000\0036\t!\000\000\t!\000\000\000\000\t!\000\000\002\130\0036\000\000\t!\t!\t!\003:\000\000\003F\004\026\004&\000\000\t!\t!\000\000\0042\000\000\rB\000\000\t!\000\000\000\000\000\000\004\198\000\000\000\000\000\000\t!\000\000\000\000\000\000\000\000\0046\000\000\000\000\000\000\t!\t!\t!\000\000\t!\t!\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t!\000\000\t!\t!\000\000\000\000\t\029\t!\000\000\000\000\000\000\t\029\t!\002^\t\029\000\000\t!\000\000\t!\t!\000\000\000\000\000\000\t\029\000\000\t\029\t\029\t\029\000\000\t\029\t\029\t\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\029\000\000\002Z\002^\019.\000\000\t\029\t\029\000\000\000\000\t\029\000\000\000\000\000\000\0036\t\029\000\000\t\029\000\000\000\000\t\029\000\000\001*\002b\002r\t\029\t\029\t\029\000\000\000\000\000\000\000\000\002~\000\000\t\029\t\029\000\000\000\000\000\000\000\000\000\000\t\029\000\000\000\000\000\000\004\198\002\130\003.\000\000\t\029\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\t\029\t\029\t\029\0042\t\029\t\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\029\000\000\t\029\t\029\0046\000\000\000\000\t\029\000y\000\000\000y\000y\t\029\000\000\000\000\000\000\t\029\000\000\t\029\t\029\000y\000\000\000y\000y\000\000\000\000\000y\000y\000y\000\000\b\201\000\000\001B\001\006\000\000\000\000\000\000\001\"\000\000\000\000\000y\000\000\001&\000\000\000\000\000\000\000y\000y\000\000\tI\000y\000\000\001*\000\000\000y\000y\000\000\000y\000\000\001F\000y\000\000\000\000\000\000\000\000\000y\000y\000y\000\000\000\000\000\000\000\000\001R\000\000\000y\000y\001^\002N\000\000\000\000\000\000\000y\000y\000\000\003F\000y\000\000\003\246\000\000\000y\000\000\003\250\000\000\004\002\005\138\000\000\005\150\000\000\000y\000y\000y\000\000\000y\000y\000\000\000\000\000\000\000\000\005\154\000\000\b\201\000\000\000\000\000\000\000y\000\000\000\000\000y\005\162\012A\005\166\000y\005\230\000\000\012A\000\000\000y\012A\000\000\000\000\000y\000\000\000y\000\000\000\000\000\000\004\130\000\000\012A\012A\012A\000\000\012A\012A\012A\005\170\000\000\tI\000\000\t\018\000\000\004j\000\000\000\000\000\000\000\000\012A\000\000\002Z\002^\019\170\000\000\012A\012A\000\000\000\000\012A\000\000\000\000\000\000\000\000\012A\000\000\012A\000\000\000\000\012A\000\000\001*\002b\002r\012A\012A\012A\000\000\000\000\000\000\000\000\002~\000\000\012A\012A\000\000\000\000\000\000\000\000\000\000\012A\000\000\000\000\000\000\012A\002\130\003.\000\000\012A\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\012A\012A\012A\0042\012A\012A\003E\000\000\000\000\000\000\000\000\003E\012u\012a\003E\000\000\012A\000\000\012A\012A\0046\002Z\002^\012A\000\000\003E\003E\003E\012A\003E\003E\003E\012A\012u\012A\012A\002\194\000\000\000\000\002\198\000\000\001*\002b\003E\000\000\000\000\002\206\000\000\000\000\003E\004z\000\000\002\210\003E\000\000\000\000\002\218\012a\003E\000\000\003E\000\000\000\000\003E\000\000\002\130\0036\000\000\003E\003E\003E\003:\000\000\003F\004\026\004&\000\000\003E\003E\000\000\0042\002\222\rB\000\000\003E\000\000\000\000\000\000\003E\000\000\000\000\n\185\003E\000\000\001B\001\006\000\000\0046\000\000\001\"\000\000\003E\003E\003E\001&\003E\003E\000\000\n\185\n\185\000\000\n\185\n\185\000\000\001*\000\000\000\000\003E\000\000\003E\003E\001F\000\000\000\000\003E\000\000\000\000\000\000\000\000\003E\002\226\000\000\n\185\003E\001R\003E\003E\000\000\001^\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\n\185\003\250\000\000\004\002\005\138\000\000\005\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\185\000\000\000\000\005\154\000\000\000\000\n\181\000\000\000\000\001B\001\006\000\000\000\000\005\162\001\"\005\166\000\000\005\230\n\185\001&\n\185\000\000\000\000\n\181\n\181\000\000\n\181\n\181\000\000\001*\000\000\000\000\000\000\000\000\n\185\000\000\001F\n\185\n\185\000\000\005\170\000\000\n\185\000\000\n\185\000\000\004j\n\181\n\185\001R\000\000\000\000\000\000\006\"\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\n\181\003\250\000\000\004\002\005\138\000\000\005\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\181\000\000\000\000\005\154\000\000\000\000\001\177\000\000\000\000\000\000\000\000\001\177\000\000\005\162\001\177\005\166\000\000\005\230\n\181\000\000\n\181\000\000\000\000\000\000\000\000\001\177\001\177\001\177\000\000\001\177\001\177\001\177\000\000\000\000\n\181\000\000\000\000\n\181\n\181\000\000\005\170\000\000\n\181\001\177\n\181\000\000\004j\000\000\n\181\001\177\001\177\000\000\000\000\001\177\000\000\000\000\000\000\000\000\001\177\000\000\001\177\000\000\000\000\001\177\000\000\000\000\000\000\000\000\001\177\001\177\001\177\000\000\000\000\000\000\000\000\000\000\000\000\001\177\001\177\000\000\001E\000\000\000\000\001E\001\177\000\000\000\000\000\000\001\177\000\000\000\000\000\000\001\177\000\000\001E\000\000\001E\000\000\001E\000\000\001E\001\177\001\177\001\177\000\000\001\177\001\177\000\000\000\000\000\000\000\000\000\000\001E\000\000\000\000\000\000\000\000\001\177\001E\001\177\001\177\001B\001\006\000\000\001\177\000\000\001\"\000\000\006\226\001\177\000\000\001&\001E\004\230\000\000\001\177\000\000\001E\001E\000\238\000\000\001*\000\000\007\002\000\000\000\000\000\000\000\000\001F\000\000\000\000\007\026\000\000\001E\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007F\002N\000\000\000\000\000\000\001E\001E\001E\003F\001E\001E\003\246\000\000\000\000\n\145\003\250\000\000\004\002\000\000\007V\005\150\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001E\004I\000\000\000\000\005\154\000\000\000\000\003r\002\170\001\006\000\000\001E\000\000\000\000\005\162\000\000\005\166\002\174\000\000\007^\000\000\005\197\000\000\b\146\000\000\000\000\005\197\000\000\001*\005\197\000\000\000\000\000\000\000\000\000\000\n\145\000\000\000\000\n\145\n\145\005\197\005\170\005\197\000\000\005\197\n\145\005\197\004j\000\000\n\145\004I\000\000\003n\000\000\000\000\000\000\000\000\000\000\005\197\000\000\003F\000\000\000\000\000\000\005\197\005\197\000\000\000\000\000\000\000\000\000\000\005\197\000\000\005\197\000\000\005\197\000\000\000\000\005\197\000\000\000\000\000\000\000\000\005\197\005\197\005\197\000\000\000\000\000\000\007v\003\145\000\000\000\000\000\000\000\000\003\145\000\000\000\000\003\145\005\197\005\197\000\000\000\000\005\197\000\000\000\000\000\000\000\000\000\000\003\145\000\000\003\145\000\000\003\145\000\000\003\145\005\197\005\197\005\197\000\000\005\197\005\197\000\000\000\000\003\145\000\000\000\000\003\145\bJ\003\145\000\000\000\000\003\145\003\145\003\145\005\197\000\000\000\000\005\197\005\197\005U\000\000\003\145\003\145\003\145\003\145\000\000\003\145\000\000\003\145\005\197\000\000\003\145\003\145\003\145\000\000\000\000\000\000\000\000\000\000\000\000\003\145\000\000\000\000\000\000\000\000\000\000\003\145\003\145\000\000\000\000\000\000\003\145\000\000\005Y\000\000\003\145\000\000\003\145\000\000\000\000\003\145\000\000\000\000\000\000\003\145\003\145\003\145\003\145\003\145\003\145\000\000\000\000\005\185\000\000\000\000\000\000\005U\005\185\000\000\000\000\005\185\003\145\000\000\003\145\003\145\003\145\000\000\003\145\000\000\000\000\000\000\005\185\000\000\005\185\000\000\005\185\000\000\005\185\003\145\003\145\003\145\000\000\003\145\003\145\000\000\000\000\000\000\000\000\000\000\005\185\005Y\000\000\000\000\000\000\000\000\005\185\005\185\003\145\003\145\000\000\000\000\003\145\b\142\000\000\005\185\000\000\005\185\000\000\000\000\005\185\000\000\000\000\003\145\000\000\005\185\005\185\000\238\000\000\000\000\000\000\b\161\000\000\000\000\000\000\000\000\b\161\000\000\000\000\b\161\000\000\005\185\005\185\000\000\000\000\005\185\000\000\000\000\000\000\000\000\b\161\000\000\b\161\000\000\b\161\000\000\b\161\000\000\005\185\005\185\005\185\000\000\005\185\005\185\000\000\000\000\000\000\000\000\b\161\000\000\000\000\000\000\000\000\000\000\b\161\b\161\000\000\005\185\000\000\000\000\005\185\005\185\000\000\b\161\000\000\b\161\000\000\000\000\b\161\000\000\000\000\000\000\005\185\b\161\b\161\b\161\000\000\000\000\000\000\000\000\012\245\000\000\000\000\000\000\000\000\012\245\000\000\000\000\012\245\b\161\000\000\000\000\000\000\b\161\000\000\000\000\000\000\000\000\000\000\012\245\000\000\012\245\000\000\012\245\000\000\012\245\b\161\b\161\b\161\000\000\b\161\b\161\000\000\000\000\000\000\000\000\000\000\012\245\000\000\000\000\000\000\000\000\b\161\012\245\012\245\b\161\000\000\000\000\000\000\b\161\004>\000\000\012\245\000\000\012\245\000\000\000\000\012\245\004\230\000\000\b\161\000\000\012\245\012\245\012\245\000\000\000\000\000\000\000\000\012\249\000\000\000\000\000\000\000\000\012\249\000\000\000\000\012\249\012\245\000\000\000\000\000\000\012\245\000\000\000\000\000\000\000\000\000\000\012\249\000\000\012\249\000\000\012\249\000\000\012\249\012\245\012\245\012\245\000\000\012\245\012\245\000\000\000\000\000\000\000\000\000\000\012\249\004J\000\000\000\000\000\000\000\000\012\249\012\249\012\245\000\000\000\000\000\000\012\245\004>\000\000\012\249\000\000\012\249\000\000\000\000\012\249\000\000\000\000\012\245\000\000\012\249\012\249\012\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\161\000\000\002^\001\161\000\000\012\249\000\000\000\000\000\000\012\249\000\000\000\000\t\t\000\000\001\161\000\000\000\000\000\000\001\161\000\000\001\161\000\000\012\249\012\249\012\249\000\000\012\249\012\249\000\000\000\000\000\000\000\000\001\161\000\000\004J\000\000\000\000\000\000\001\161\001\161\000\000\012\249\000\000\000\000\000\000\012\249\0036\001\161\000\000\001\161\000\000\000\000\001\161\000\000\000\000\000\000\012\249\001\161\001\161\001\161\000\000\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\161\001\161\000\000\000\000\004\198\000\000\000\000\000\000\000\000\000\000\000\000\003u\000\000\002^\003u\000\000\000\000\001\161\001\161\000\000\000\000\001\161\001\161\t\005\000\000\003u\000\000\000\000\000\000\003u\000\000\003u\000\000\001\161\000\000\000\000\000\000\000\000\000\000\000\000\001\161\000\000\000\000\003u\000\000\001\161\000\000\000\000\000\000\003u\001\157\001\161\000\000\000\000\000\000\000\000\000\000\0036\003u\000\000\003u\000\000\000\000\003u\000\000\000\000\000\000\000\000\003u\003u\003u\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003u\003u\000\000\000\000\004\198\000\000\000\000\000\000\000\000\000\000\000\000\003q\000\000\002^\003q\000\000\000\000\003u\003u\000\000\000\000\003u\003u\t\005\000\000\003q\000\000\000\000\000\000\003q\000\000\003q\000\000\003u\000\000\000\000\000\000\000\000\000\000\000\000\003u\000\000\000\000\003q\000\000\003u\000\000\000\000\000\000\003q\001\157\003u\000\000\000\000\000\000\000\000\000\000\0036\003q\000\000\003q\000\153\000\000\003q\000\153\000\000\000\000\000\000\003q\003q\003q\000\000\000\000\000\000\000\000\000\153\000\000\000\153\000\000\000\153\000\000\000\153\000\000\000\000\003q\003q\000\000\000\000\004\198\000\000\000\000\000\000\000\000\000\153\000\000\000\000\000\000\000\000\000\000\000\153\000\000\003q\003q\000\153\000\000\003q\003q\000\000\000\153\000\000\000\153\000\000\000\000\000\153\000\000\000\000\000\000\003q\000\153\000\153\000\238\000\000\000\000\000\000\003q\000\000\000\000\000\153\000\153\003q\000\221\000\000\000\000\000\221\000\153\003q\000\000\000\000\000\153\000\000\000\000\000\000\000\000\000\000\000\221\000\000\000\221\000\000\000\221\000\000\000\221\000\153\000\153\000\000\000\000\000\153\000\153\000\000\000\000\000\000\000\000\000\000\000\221\000\000\000\000\000\000\000\000\000\153\000\221\000\000\000\000\000\000\000\221\000\153\000\153\000\000\000\000\000\221\000\000\000\221\000\000\000\000\000\221\000\153\000\000\000\153\000\000\000\221\000\221\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\221\000\221\000\000\000\161\000\000\000\000\000\161\000\221\000\000\000\000\000\000\000\221\000\000\000\000\000\000\000\000\000\000\000\161\000\000\000\161\000\000\000\161\000\000\000\161\000\221\000\221\000\000\000\000\000\221\000\221\000\000\000\000\000\000\000\000\000\000\000\161\000\000\000\000\000\000\000\000\000\221\000\161\000\000\000\000\000\000\000\161\000\221\000\221\000\000\000\000\000\161\000\000\000\161\000\000\000\000\000\161\000\221\000\000\000\221\000\000\000\161\000\161\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\161\000\161\000\000\000\157\000\000\000\000\000\157\000\161\000\000\000\000\000\000\000\161\000\000\000\000\000\000\000\000\000\000\000\157\000\000\000\157\000\000\000\157\000\000\000\157\000\161\000\161\000\000\000\000\000\161\000\161\000\000\000\000\000\000\000\000\000\000\000\157\000\000\000\000\000\000\000\000\000\161\000\157\000\000\000\000\000\000\000\157\000\161\000\161\000\000\000\000\000\157\000\000\000\157\000\000\000\000\000\157\000\161\000\000\000\161\000\000\000\157\000\157\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\157\000\157\000\000\000\000\000\000\001b\000\000\000\157\000\000\001f\000\000\000\157\000\000\000\000\000\000\012u\012a\000\000\001j\001n\001r\001\190\001z\001~\000\157\000\157\000\000\000\000\000\157\000\157\000\000\000\000\000\000\001\194\001\198\000\000\012u\000\000\000\000\002\194\000\157\001\202\002\198\000\000\001\206\000\000\000\157\000\157\000\000\014\n\000\000\000\000\000\000\000\000\000\000\002\210\000\157\000\000\000\157\002\218\012a\001\210\001\214\001\218\001\222\001\226\000\000\000\000\001}\001\230\000\000\001}\000\000\000\000\001\234\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\000\000\002\222\001\238\001}\000\000\001}\000\000\000\000\000\000\001\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\001}\000\000\002.\027\202\000\000\001}\000\000\000\000\000\000\0022\000\000\0026\005U\000\000\001}\002:\001}\002>\002B\001}\000\000\000\000\000\000\000\000\001}\001}\001}\000\000\000\000\000\000\000\000\000\000\002\226\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001}\000\000\000\000\000\000\001}\012\241\000\000\000\000\000\000\000\000\012\241\000\000\000\000\012\241\000\000\000\000\000\000\001}\001}\000\000\000\000\001}\001}\000\000\012\241\000\000\012\241\000\000\012\241\005U\012\241\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\001}\001}\000\000\012\241\000\000\000\000\001}\000\000\000\000\012\241\012\241\000\000\001}\000\000\000\000\000\000\000\000\000\000\012\241\000\000\012\241\000\000\000\000\012\241\000\000\000\000\000\000\000\000\012\241\012\241\012\241\000\000\000\000\000\000\012\237\000\000\000\000\000\000\000\000\012\237\000\000\000\000\012\237\000\000\012\241\000\000\000\000\000\000\012\241\000\000\000\000\000\000\000\000\012\237\000\000\012\237\000\000\012\237\000\000\012\237\000\000\012\241\012\241\012\241\000\000\012\241\012\241\000\000\000\000\000\000\000\000\012\237\000\000\000\000\000\000\000\000\000\000\012\237\012\237\000\000\012\241\000\000\000\000\000\000\012\241\000\000\012\237\000\000\012\237\000\000\000\000\012\237\000\000\004\230\000\000\012\241\012\237\012\237\012\237\000\000\000\000\000\000\000\000\b\165\000\000\000\000\000\000\000\000\b\165\000\000\000\000\b\165\012\237\000\000\000\000\000\000\012\237\000\000\000\000\000\000\000\000\000\000\b\165\000\000\b\165\000\000\b\165\000\000\b\165\012\237\012\237\012\237\000\000\012\237\012\237\000\000\000\000\000\000\000\000\000\000\b\165\000\000\000\000\000\000\000\000\007\230\b\165\b\165\012\237\001B\001\006\000\000\012\237\000\000\001\"\b\165\006\226\b\165\000\000\001&\b\165\000\000\000\000\012\237\000\000\b\165\b\165\000\238\000\000\001*\000\000\007\002\000\000\000\000\000\000\000\000\001F\000\000\000\000\007\026\000\000\b\165\000\000\000\000\000\000\b\165\000\000\0031\000\000\001R\000\000\000\000\000\000\007F\002N\000\000\000\000\000\000\b\165\b\165\b\165\003F\b\165\b\165\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007V\005\150\b\165\000\000\000\000\b\165\000\000\000\000\000\000\b\165\000\000\000\000\000\000\005\154\000\000\001\157\000\000\002^\001\157\000\000\b\165\000\000\000\000\005\162\000\000\005\166\000\000\t\005\0031\001\157\000\000\002Z\002^\001\157\000\000\001\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0031\000\000\001\157\0031\000\000\005\170\001*\002\134\001\157\000\000\000\000\004j\000\000\000\000\000\000\000\000\0036\001\157\000\000\001\157\000\000\000\000\001\157\000\000\000\000\000\000\000\000\001\157\001\157\001\157\002\130\003>\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\001\157\001\157\0042\000\000\004\198\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\157\001\157\0046\000\000\001\157\001\157\026>\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\157\001\174\002Z\002^\r\254\000\000\000\000\001\157\000\000\000\000\026*\000\000\001\157\000\000\000\000\015\n\000\000\000\000\001\157\004\165\000\000\003R\001*\002\134\002r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002~\015\014\000\000\000\000\000\000\000\000\000\000\0156\000\000\000\000\000\000\005\237\000\000\000\000\002\130\003.\005\237\000\000\000\000\005\237\003:\012\178\003F\004\026\004&\000\000\012\186\000\000\000\000\0042\005\237\000\000\005\237\000\000\005\237\000\000\005\237\000\000\000\000\000\000\000\000\000\000\015\202\000\000\000\000\000\000\0046\000\000\005\237\000\000\000\000\000\000\000\000\000\000\005\237\005\237\000\000\000\000\000\000\012\214\015\222\b\142\000\000\005\237\000\000\005\237\000\000\000\000\005\237\000\000\000\000\000\000\000\000\005\237\005\237\000\238\000\000\000\000\000\000\000\000\000\000\000\000\015\238\000\000\000\000\001b\000\000\000\000\000\000\005\237\000\000\000\000\000\000\005\237\000\000\000\000\000\000\000\000\001j\001n\001r\001\190\001z\001~\000\000\000\000\005\237\005\237\005\237\000\000\005\237\005\237\000\000\001\194\001\198\000\000\000\000\000\000\000\000\000\000\000\000\001\202\000\000\000\000\001\206\005\237\000\000\000\000\000\000\005\237\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\237\001\210\001\214\001\218\001\222\001\226\000\000\000\000\000\000\001\230\007\186\000\000\000\000\000\000\001\234\005\233\000\000\000\000\005\233\000\000\000\000\000\000\000\000\000\000\000\000\001\238\000\000\000\000\000\000\005\233\000\000\005\233\001\242\005\233\000\000\005\233\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002.\027\230\000\000\000\000\005\233\000\000\000\000\0022\000\000\0026\005\233\b6\000\000\002:\000\000\002>\002B\000\000\000\000\005\233\000\000\005\233\000\000\000\000\005\233\000\000\000\000\000\000\000\000\005\233\005\233\000\238\000\000\000\000\000\000\012\253\000\000\000\000\000\000\000\000\012\253\000\000\000\000\012\253\000\000\005\233\000\000\000\000\000\000\005\233\000\000\000\000\000\000\000\000\012\253\000\000\012\253\000\000\012\253\000\000\012\253\000\000\005\233\005\233\005\233\000\000\005\233\005\233\000\000\000\000\000\000\000\000\012\253\000\000\000\000\000\000\000\000\000\000\012\253\012\253\000\000\005\233\000\000\000\000\000\000\005\233\000\000\012\253\000\000\012\253\000\000\000\000\012\253\000\000\000\000\000\000\005\233\012\253\012\253\000\238\000\000\000\000\000\000\r\001\000\000\000\000\000\000\000\000\r\001\000\000\000\000\r\001\000\000\012\253\000\000\000\000\000\000\012\253\000\000\000\000\000\000\000\000\r\001\000\000\r\001\000\000\r\001\000\000\r\001\000\000\012\253\012\253\012\253\000\000\012\253\012\253\000\000\000\000\000\000\000\000\r\001\000\000\000\000\000\000\000\000\000\000\r\001\b6\000\000\012\253\000\000\000\000\000\000\012\253\000\000\r\001\000\000\r\001\000\000\000\000\r\001\000\000\000\000\000\000\012\253\r\001\r\001\000\238\000\000\000\000\000\000\007\186\000\000\000\000\000\000\000\000\006\001\000\000\000\000\006\001\000\000\r\001\000\000\000\000\000\000\r\001\000\000\000\000\000\000\000\000\006\001\000\000\006\001\000\000\006\001\000\000\006\001\000\000\r\001\r\001\r\001\000\000\r\001\r\001\000\000\000\000\000\000\000\000\006\001\000\000\000\000\000\000\000\000\000\000\006\001\b6\000\000\r\001\000\000\000\000\000\000\r\001\000\000\006\001\000\000\006\001\000\000\000\000\006\001\000\000\000\000\000\000\r\001\006\001\006\001\000\238\000\000\000\000\000\000\006\005\000\000\000\000\000\000\000\000\006\005\000\000\000\000\006\005\000\000\006\001\000\000\000\000\000\000\006\001\000\000\000\000\000\000\000\000\006\005\000\000\006\005\000\000\006\005\000\000\006\005\000\000\006\001\006\001\006\001\000\000\006\001\006\001\000\000\000\000\000\000\000\000\006\005\000\000\000\000\000\000\000\000\000\000\006\005\006\005\000\000\006\001\000\000\000\000\000\000\006\001\000\000\006\005\000\000\006\005\000\000\000\000\006\005\000\000\000\000\000\000\006\001\006\005\006\005\006\005\000\000\000\000\000\000\005\253\000\000\000\000\000\000\000\000\005\253\000\000\000\000\005\253\000\000\006\005\000\000\000\000\000\000\006\005\000\000\000\000\000\000\000\000\005\253\000\000\005\253\000\000\005\253\000\000\005\253\000\000\006\005\006\005\006\005\000\000\006\005\006\005\000\000\000\000\000\000\000\000\005\253\000\000\000\000\000\000\000\000\000\000\005\253\b6\000\000\006\005\000\000\000\000\000\000\006\005\000\000\005\253\000\000\005\253\000\000\000\000\005\253\000\000\000\000\000\000\b^\005\253\005\253\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003m\000\000\002^\003m\000\000\005\253\000\000\000\000\000\000\005\253\000\000\000\000\000\000\000\000\003m\000\000\002Z\002^\003m\000\000\003m\000\000\005\253\005\253\005\253\000\000\005\253\005\253\000\000\000\000\000\000\000\000\003m\000\000\000\000\000\000\001*\002\134\003m\000\000\000\000\005\253\000\000\000\000\000\000\005\253\0036\003m\000\000\003m\000\000\000\000\003m\000\000\000\000\000\000\005\253\003m\003m\003m\002\130\003>\000\000\000\000\000\000\000\000\003:\000\000\003F\004\026\004&\000\000\000\000\003m\003m\0042\000\000\004\198\000\000\003i\000\000\002^\003i\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003m\003m\0046\003i\003m\003m\005\029\003i\000\000\003i\000\000\000\000\000\000\000\000\000\000\000\000\003m\000\000\000\000\000\000\000\000\003i\000\000\003m\000\000\000\000\026*\003i\003m\000\000\000\000\000\000\000\000\000\000\003m\0036\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\001\169\000\000\r&\001\169\000\000\000\000\001\"\000\000\003i\003i\000\000\000\000\004\198\000\000\001\169\000\000\000\000\000\000\001\169\000\000\001\169\000\000\002Z\002^\000\000\003i\003i\000\000\000\000\003i\003i\000\000\001\169\000\000\000\000\000\000\000\000\000\000\001\169\000\000\000\000\003i\001*\002\134\000\000\r*\000\000\001\169\003i\001\169\000\000\000\000\001\169\003i\000\000\000\000\000\000\001\169\001\169\003i\r6\000\000\000\000\000\000\000\000\000\000\002\130\003>\000\000\000\000\000\000\000\000\003:\001\169\003F\004\026\004&\001\169\000\000\000\000\000\000\0042\000\000\001-\000\000\000\000\001-\000\000\000\000\005\166\001\169\001\169\000\000\000\000\001\169\001\169\000\000\001-\0046\001-\000\000\001-\005!\001-\000\000\000\000\001\169\000\000\000\000\000\000\000\000\000\000\000\000\001\169\000\000\001-\000\000\000\000\000\000\000\000\000\000\001-\026*\000\000\001\169\001-\000\000\000\000\000\000\000\000\001-\000\000\001-\000\000\000\000\001-\000\000\000\000\000\000\000\000\001-\001-\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001-\000\000\001)\000\000\000\000\001)\001-\000\000\000\000\000\000\001-\000\000\000\000\000\000\000\000\000\000\001)\000\000\001)\000\000\001)\000\000\001)\001-\001-\001-\000\000\001-\001-\000\000\000\000\000\000\000\000\000\000\001)\000\000\000\000\000\000\000\000\001-\001)\000\000\000\000\000\000\001)\000\000\001-\000\000\000\000\001)\000\000\001)\000\000\000\000\001)\000\000\000\000\001-\000\000\001)\001)\000\238\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\001)\000\000\000\000\000\000\001)\000\000\000\000\000\000\000\000\000\000\001\002\001\006\000\000\000\000\000\000\001\"\000\000\001)\001)\001)\001&\001)\001)\000\000\000\000\006\153\000\000\000\000\000\000\000\000\001*\000\000\000\000\001)\001.\000\000\000\000\000\000\000\000\000\000\001)\000\000\000\000\0012\000\000\003z\000\000\000\000\000\000\000\000\000\000\001)\000\000\000\000\003\206\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\214\000\000\000\000\000\000\b\194\b\198\b\210\000\000\000\000\005\150\002\029\002\029\000\000\000\000\000\000\002\029\000\000\002\029\000\000\000\000\002\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\029\005\162\002\029\005\166\000\000\000\000\000\000\002\029\000\n\000\000\002\029\000\000\b\218\000\000\b\222\000\000\000\000\000\000\000\000\000\000\002\029\000\000\000\000\000\000\002\029\002\029\000\000\000\000\005\170\b\238\000\000\000\000\002\029\t\146\004j\002\029\000\000\004\157\002\029\002\029\004\157\002\029\002\029\002\029\002\029\000\000\000\000\000\000\000\000\000\000\000\000\004\157\000\000\000\000\000\000\004\157\002\029\004\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\029\000\000\002\029\004\157\002\029\000\000\000\000\000\000\000\000\004\157\000\000\000\000\000\000\004\157\000\000\000\000\b\142\000\000\004\157\000\000\004\157\b1\000\000\004\157\b1\000\000\000\000\002\029\004\157\012\014\000\238\002\029\000\000\002\029\000\000\b1\000\000\004\157\004\157\b1\000\000\b1\000\000\000\000\004\157\004\157\000\000\000\000\004\157\000\000\000\000\000\000\000\000\b1\000\000\000\000\000\000\000\000\000\000\b1\000\000\004\157\004\157\b1\000\000\004\157\004\157\000\000\b1\000\000\b1\000\000\b-\b1\000\000\b-\000\000\004\157\b1\b1\000\238\000\000\000\000\000\000\004\157\000\000\b-\b1\b1\026\166\b-\000\000\b-\000\000\b1\004\157\000\000\000\000\b1\000\000\000\000\000\000\000\000\000\000\b-\000\000\000\000\000\000\000\000\000\000\b-\b1\b1\b1\b-\b1\b1\000\000\000\000\b-\000\000\b-\003a\000\000\b-\003a\000\000\b1\000\000\b-\b-\000\238\000\000\000\000\b1\000\000\003a\000\000\b-\b-\003a\000\000\003a\000\000\000\000\b-\000\000\000\000\000\000\b-\000\000\000\000\000\000\000\000\003a\r>\000\000\000\000\000\000\000\000\003a\000\000\b-\b-\b-\000\000\b-\b-\000\000\003a\000\000\003a\000\000\000\000\003a\000\000\000\000\000\000\b-\003a\003a\003a\000\000\000\000\000\000\b-\001Y\000\000\012Y\001Y\000\000\000\000\000\000\000\000\000\000\003a\000\000\000\000\012Y\003a\001Y\000\000\001Y\000\000\001Y\000\000\001Y\000\000\000\000\000\000\000\000\000\000\003a\003a\026\174\000\000\003a\003a\001Y\000\000\000\000\000\000\000\000\000\000\001Y\012Y\000\000\000\000\003a\000\000\000\000\000\000\012Y\000\000\r\190\003a\000\000\000\000\001Y\000\000\003a\000\000\000\000\001Y\001Y\001Y\003a\000\000\000\000\000\000\001\029\000\000\0025\001\029\000\000\000\000\000\000\000\000\000\000\001Y\000\000\000\000\0025\012Y\001\029\000\000\001\029\000\000\001\029\000\000\001\029\000\000\000\000\000\000\000\000\000\000\001Y\001Y\001Y\000\000\001Y\001Y\001\029\000\000\000\000\000\000\000\000\000\000\001\029\0025\000\000\000\000\000\000\000\000\000\000\000\000\0025\000\000\000\000\001Y\000\000\000\000\001\029\000\000\000\000\000\000\000\000\001\029\001\029\001\029\001Y\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\029\000\000\000\000\000\000\0025\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\226\000\000\000\000\001&\000\000\001\029\001\029\001\029\006\157\001\029\001\029\000\000\000\000\001*\000\000\007\002\000\000\000\000\000\000\000\000\001F\000\000\000\000\007\026\000\000\000\000\000\000\000\000\001\029\000\000\000\000\020>\000\000\001R\000\000\000\000\000\000\001^\002N\001\029\000\000\000\000\000\000\000\000\000\000\003F\000\000\000\000\003\246\000\000\000\000\000\000\003\250\000\000\004\002\005\138\007V\005\150\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\226\000\000\000\000\001&\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\005\162\007\002\005\166\000\000\005\230\018\150\001F\000\000\000\000\007\026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007F\002N\021\018\000\000\005\170\000\000\006\210\000\000\003F\000\000\004j\003\246\000\000\000\000\000\000\003\250\000\000\004\002\000\000\007V\005\150\001B\001\006\000\000\000\000\000\000\001\"\000\000\006\226\000\000\000\000\001&\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001*\005\162\007\002\005\166\000\000\000\000\007^\001F\000\000\000\000\007\026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\007F\002N\019*\000\000\005\170\000\000\000\000\000\000\003F\000\000\004j\003\246\000\000\001\002\001\006\003\250\000\000\004\002\001\"\007V\005\150\000\000\000\000\001&\000\000\000\000\000\000\000\000\006\193\000\000\000\000\000\000\005\154\001*\000\000\000\000\000\000\001.\000\000\000\000\000\000\000\000\005\162\000\000\005\166\000\000\0012\007^\003z\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\206\002N\000\000\000\000\000\000\000\000\000\000\000\000\003F\000\000\019\166\003\214\005\170\000\000\000\000\b\194\b\198\b\210\004j\000\000\005\150\004\133\004\133\000\000\000\000\000\000\004\133\000\000\000\000\000\000\000\000\004\133\000\000\000\000\000\000\000\000\000\000\004\133\000\000\000\000\000\000\004\133\005\162\000\000\005\166\000\000\000\000\000\000\004\133\019\246\000\000\000\000\020\014\b\218\000\000\b\222\000\000\000\000\000\000\000\000\000\000\004\133\000\000\000\000\000\000\004\133\004\133\000\000\000\000\005\170\b\238\000\000\000\000\004\133\t\146\004j\004\133\000\000\003a\000\238\004\133\003a\004\133\004\133\000\000\004\133\000\000\000\000\000\000\000\000\000\000\000\000\003a\000\000\000\000\000\000\003a\004\133\003a\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\133\000\000\004\133\003a\r>\000\000\000\000\000\000\000\000\003a\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003a\000\000\003a\012Q\000\000\003a\012Q\000\000\000\000\004\133\003a\003a\003a\000\000\000\000\004\133\000\000\012Q\000\000\000\000\000\000\012Q\000\000\012Q\000\000\000\000\003a\000\000\000\000\005M\003a\000\000\000\000\000\000\000\000\012Q\000\000\000\000\000\000\000\000\000\000\012Q\000\000\003a\003a\026\222\000\000\003a\003a\000\000\012Q\000\000\012Q\000\000\000\000\012Q\000\000\000\000\000\000\000\000\012Q\012Q\001B\001\006\000\000\r\190\003a\001\"\000\000\000\000\000\000\003a\001&\000\000\000\000\000\000\012Q\005\226\000\000\003\254\012Q\000\000\001*\000\000\000\000\000\000\000\000\000\000\000\000\001F\000\000\000\000\000\000\012Q\012Q\003\030\000\000\012Q\012Q\000\000\000\000\000\000\001R\000\000\000\000\000\000\001^\002N\000\000\012Q\000\000\000\000\000\000\014\022\003F\000\000\012Q\003\246\000\000\005\161\000\000\003\250\005\161\004\002\005\138\000\000\005\150\012Q\000\000\000\000\000\000\000\000\000\000\005\161\000\000\000\000\000\000\005\161\005\154\005\161\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\162\000\000\005\166\005\161\005\230\000\000\000\000\000\000\000\000\005\161\000\000\000\000\000\000\000\000\000\000\000\000\b\142\000\000\005\161\000\000\005\161\000\000\000\000\005\161\006\134\000\000\000\000\005\170\005\161\005\161\000\238\000\000\000\000\004j\000\000\000\000\000\000\000\000\000\000\000\000\005\165\000\000\000\000\005\165\005\161\005\161\000\000\000\000\005\161\000\000\000\000\000\000\000\000\000\000\005\165\000\000\000\000\000\000\005\165\000\000\005\165\005\161\005\161\000\000\000\000\005\161\005\161\000\000\000\000\000\000\000\000\000\000\005\165\000\000\000\000\000\000\000\000\000\000\005\165\000\000\000\000\000\000\000\000\000\000\005\161\b\142\000\000\005\165\000\000\005\165\003a\000\000\005\165\003a\000\000\005\161\000\000\005\165\005\165\000\238\000\000\000\000\000\000\000\000\003a\000\000\000\000\000\000\003a\000\000\003a\000\000\000\000\005\165\005\165\000\000\000\000\005\165\000\000\000\000\000\000\000\000\003a\r>\000\000\000\000\000\000\000\000\003a\000\000\005\165\005\165\000\000\000\000\005\165\005\165\000\000\003a\000\000\003a\006I\000\000\003a\006I\000\000\000\000\000\000\003a\003a\003a\000\000\000\000\000\000\005\165\006I\000\000\000\000\000\000\006I\000\000\006I\000\000\000\000\003a\005\165\000\000\000\000\003a\000\000\000\000\000\000\000\000\006I\000\000\000\000\000\000\000\000\000\000\006I\000\000\003a\003a\r\158\000\000\003a\003a\000\000\006I\000\000\006I\000\000\000\000\006I\000\000\000\000\000\000\000\000\006I\006I\000\238\000\000\000\000\r\190\003a\000\000\012\017\000\000\001\006\012\017\000\000\000\000\028\190\000\000\006I\000\000\000\000\028\194\006I\000\000\012\017\000\000\000\000\000\000\000\000\000\000\012\017\000\000\000\000\000\000\000\000\006I\006I\014b\000\000\006I\006I\000\000\012\017\000\000\000\000\000\000\000\000\000\000\012\017\000\000\000\000\006I\000\000\000\000\000\000\001\186\002N\012\017\006I\012\017\001\174\000\000\012\017\002\182\000\000\000\000\000\000\012\017\000\000\006I\000\000\000\000\000\000\000\000\003N\028\198\001B\001\006\004\177\000\000\003R\001\"\000\000\012\017\000\000\000\000\001&\012\017\000\000\000\000\000\000\000\000\003^\006\154\000\000\000\000\001*\000\000\012&\028\202\012\017\012\017\000\000\001F\012\017\000\000\000\000\003\226\000\000\021^\000\000\000\000\012\178\000\000\000\000\000\000\001R\012\186\000\000\000\000\001^\002N\000\000\012\017\007\186\000\000\000\000\000\000\003F\007Q\000\000\003\246\007Q\012\194\000\000\003\250\000\000\004\002\005\138\000\000\005\150\000\000\000\000\007Q\000\000\000\000\000\000\007Q\000\000\007Q\012\214\r\026\005\154\000\000\004\177\004\177\000\000\000\000\000\000\000\000\000\000\007Q\005\162\000\000\005\166\000\000\005\230\007Q\b6\000\000\000\000\000\000\000\000\018~\000\000\000\000\007Q\000\000\007Q\001\173\000\000\007Q\001\173\000\000\000\000\000\000\007Q\007Q\000\238\005\170\000\000\000\000\000\000\001\173\000\000\004j\000\000\001\173\000\000\001\173\000\000\000\000\007Q\000\000\000\000\000\000\007Q\000\000\000\000\000\000\000\000\001\173\000\000\000\000\000\000\000\000\000\000\001\173\000\000\007Q\007Q\000\000\000\000\007Q\007Q\000\000\001\173\000\000\001\173\006M\000\000\001\173\006M\000\000\000\000\000\000\001\173\001\173\000\000\000\000\000\000\000\000\007Q\006M\000\000\000\000\000\000\006M\000\000\006M\000\000\000\000\001\173\000\000\000\000\000\000\001\173\000\000\000\000\000\000\000\000\006M\000\000\000\000\000\000\000\000\000\000\006M\000\000\001\173\001\173\000\000\000\000\001\173\001\173\000\000\006M\000\000\006M\000\000\000\000\006M\000\000\000\000\000\000\001\173\006M\006M\000\238\000\000\000\000\000\000\001\173\000\000\000\000\000\000\000\000\014B\000\000\000\000\000\000\000\000\006M\001\173\000\000\000\000\006M\000\000\000\000\000\000\000\000\ba\ba\000\000\000\000\000\000\ba\000\000\000\000\006M\006M\ba\000\000\006M\006M\000\000\000\000\003\238\000\000\000\000\000\000\ba\000\000\000\000\000\000\006M\000\000\000\000\ba\007\186\000\000\000\000\006M\000\000\004\157\000\000\000\000\004\157\000\000\000\000\000\000\ba\000\000\006M\000\000\ba\ba\000\000\004\157\000\000\000\000\000\000\004\157\ba\004\157\004\157\ba\000\000\000\000\000\000\ba\000\000\ba\ba\000\000\ba\004\157\000\000\000\000\000\000\004\157\000\000\004\157\b6\000\000\000\000\000\000\ba\000\000\004>\000\000\004\157\000\000\004\157\004\157\000\000\004\157\ba\000\000\ba\004\157\004\157\012\014\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\157\000\000\000\000\004\157\000\000\004\157\012\014\004\157\012Q\000\000\ba\012Q\000\000\000\000\000\000\000\209\ba\000\000\000\209\000\000\004\157\004\157\012Q\000\000\004\157\004\157\012Q\000\000\012Q\000\209\000\000\000\000\004J\000\209\005M\000\209\007\230\000\000\004\157\004\157\012Q\000\000\004\157\004\157\000\000\000\000\012Q\000\209\014B\000\000\bJ\000\000\000\000\000\209\004\157\000\000\000\000\000\000\000\000\000\000\012Q\004\157\000\209\000\000\000\209\012Q\012Q\000\209\000\000\000\000\000\000\000\000\000\209\000\209\000\238\000\000\000\000\000\000\000\000\000\000\000\000\012Q\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\000\000\000\000\000\000\209\000\213\000\000\000\000\000\213\000\000\012Q\012Q\003\030\000\000\012Q\012Q\000\000\000\209\000\209\000\213\000\000\000\209\000\209\000\213\000\000\000\213\012Q\000\000\000\000\000\000\014\218\000\000\000\000\012Q\000\000\000\000\000\000\000\213\000\000\000\000\000\209\000\000\000\000\000\213\012Q\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\213\000\000\000\213\000\000\000\000\000\213\000\000\000\000\000\000\000\000\000\213\000\213\000\238\000\000\000\000\002Z\003\"\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\000\213\000\000\000\000\000\000\000\213\000\000\000\000\000\000\000\000\001*\002\134\002r\003&\000\000\000\000\000\000\000\000\000\213\000\213\002~\000\000\000\213\000\213\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003*\003.\007M\000\000\000\000\007M\003:\000\213\003F\004\026\004&\000\000\000\000\000\000\000\000\014\026\007M\014\030\000\213\000\000\007M\000\000\007M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0046\000\000\007M\000\000\000\000\000\000\000\000\000\000\007M\000\000\000\000\000\000\005\166\000\000\000\000\000\000\000\000\007M\000\000\007M\006A\000\000\007M\006A\014*\000\000\000\000\007M\007M\000\000\000\000\r\006\000\000\000\000\006A\000\000\000\000\000\000\006A\000\000\006A\014.\000\000\007M\000\000\000\000\000\000\007M\000\000\000\000\000\000\000\000\006A\000\000\000\000\000\000\000\000\000\000\006A\000\000\007M\007M\012:\000\000\007M\007M\000\000\006A\000\000\006A\011\189\000\000\006A\011\189\000\000\000\000\000\000\006A\006A\000\000\015J\000\000\000\000\007M\011\189\000\000\000\000\000\000\011\189\000\000\011\189\000\000\000\000\006A\000\000\000\000\000\000\006A\000\000\000\000\000\000\000\000\011\189\000\000\000\000\000\000\000\000\000\000\011\189\000\000\006A\006A\000\000\000\000\006A\006A\000\000\011\189\000\000\011\189\000\000\000\000\011\189\000\000\000\000\000\000\000\000\011\189\000\000\000\000\000\000\000\000\000\000\006A\000\000\011\193\000\000\000\000\011\193\000\000\000\000\000\000\000\000\011\189\n\170\000\000\000\000\011\189\000\000\011\193\000\000\000\000\000\000\011\193\000\000\011\193\000\000\000\000\000\000\000\000\011\189\011\189\000\000\000\000\011\189\011\189\000\000\011\193\000\000\000\000\000\000\000\000\000\000\011\193\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\193\011\189\011\193\000\000\000\000\011\193\000\000\000\000\000\000\000\000\011\193\000\000\011\170\000\000\000\000\002Z\003\"\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\011\193\n\186\000\000\000\000\011\193\000\000\000\000\000\000\000\000\001*\002\134\002r\000\000\000\000\000\000\000\000\000\000\011\193\011\193\002~\000\000\011\193\011\193\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003*\003.\004u\000\000\000\000\004u\003:\011\193\003F\004\026\004&\000\000\000\000\000\000\000\000\014\026\004u\026~\011\170\000\000\004u\000\000\004u\007\186\000\000\000\000\000\000\000\000\005\173\000\000\000\000\005\173\0046\000\000\004u\000\000\000\000\000\000\000\000\000\000\004u\000\000\005\173\000\000\005\166\000\000\005\173\000\000\005\173\004u\000\000\004u\000\000\000\000\004u\000\000\026\138\000\000\000\000\004u\005\173\000\000\000\000\000\000\000\000\000\000\005\173\b6\000\000\000\000\000\000\000\000\000\000\014.\000\000\004u\000\000\000\000\000\000\004u\005\173\000\000\000\000\000\000\000\000\005\173\005\173\000\238\000\000\000\000\000\000\000\000\004u\004u\000\000\000\000\004u\004u\000\000\000\000\000\000\005\173\000\000\000\000\000\000\000\000\000\000\004m\000\000\000\000\004m\000\000\000\000\000\000\004\141\004u\000\000\004\141\005\173\005\173\000\000\004m\005\173\005\173\000\000\004m\012\130\004m\004\141\000\000\000\000\000\000\004\141\000\000\004\141\000\000\000\000\000\000\000\000\004m\000\000\005\173\000\000\000\000\000\000\004m\004\141\000\000\000\000\000\000\000\000\000\000\004\141\000\000\004m\000\000\004m\000\000\000\000\004m\000\000\004\141\000\000\004\141\004m\000\000\004\141\000\000\000\000\000\000\000\000\004\141\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004m\000\000\000\000\000\000\004m\000\000\000\000\004\141\000\000\000\000\000\000\004\141\004]\000\000\000\000\004]\000\000\004m\004m\000\000\000\000\004m\004m\000\000\004\141\004\141\004]\000\000\004\141\004\141\004]\000\000\004]\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004m\000\000\000\000\000\000\004]\000\000\000\000\004\141\000\000\000\000\004]\0172\000\000\000\000\000\000\000\000\007\213\000\000\018\022\004]\000\000\004]\000\000\000\000\004]\000\000\000\000\000\000\000\000\004]\002Z\002^\000\000\007\213\007\213\000\000\007\213\007\213\000\000\000\000\000\000\012!\000\000\000\000\012!\004]\000\000\003\254\000\000\004]\001*\002\134\002r\000\000\000\000\012!\000\000\007\213\000\000\000\000\002~\012!\004]\004]\000\000\000\000\004]\004]\000\000\000\000\000\000\000\000\000\000\012!\002\130\003.\000\000\000\238\000\000\012!\003:\000\000\003F\004\026\004&\004]\000\000\007\185\012!\0042\012!\000\000\007\213\012!\000\000\000\000\0212\000\000\012!\000\000\000\000\000\000\000\000\000\000\007\185\007\185\0046\007\185\007\185\000\000\007\213\000\000\007\213\000\000\012!\000\000\000\000\000\000\012!\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007\213\000\000\007\185\006\006\007\213\012!\012!\000\000\007\213\012!\007\213\000\000\007\217\000\000\007\213\000\000\000\000\028\174\000\000\000\000\000\000\004f\007\185\004j\000\000\007\205\000\000\000\000\012!\007\217\007\217\000\000\007\217\007\217\000\000\000\000\000\000\007\185\000\000\002Z\002^\000\000\007\205\007\205\000\000\007\205\007\205\000\000\000\000\000\000\000\000\000\000\000\000\007\217\000\000\007\185\000\000\007\185\000\000\001*\002\134\002r\000\000\000\000\000\000\000\000\007\205\000\000\000\000\002~\000\000\007\185\016\030\000\238\006\006\007\185\000\000\000\000\000\000\007\185\000\000\007\185\000\000\002\130\017r\007\185\000\238\016\150\007\217\003:\000\000\003F\004\026\004&\000\000\000\000\004e\000\000\017\130\004e\000\000\007\205\000\000\000\000\000\000\000\000\007\217\000\000\007\217\004\149\004e\000\000\004\149\000\000\004e\0046\004e\000\000\000\000\007\205\000\000\007\205\007\217\004\149\000\000\006\006\007\217\004\149\004e\004\149\007\217\000\000\007\217\000\000\004e\006Z\007\217\000\000\006\006\007\205\000\000\004\149\000\000\007\205\000\000\007\205\000\000\004\149\004e\007\205\000\000\000\000\000\000\004e\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\149\000\000\000\000\001\174\000\000\004\149\002\182\000\000\004e\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\029\006\000\000\000\000\000\000\004\149\000\000\003R\000\000\004e\004e\000\000\000\000\004e\004e\000\000\000\000\000\000\000\000\003^\000\000\000\000\004\149\004\149\000\000\012&\004\149\004\149\000\000\000\000\000\000\000\000\004e\000\000\003\226\000\000\021^\000\000\000\000\012\178\000\000\000\000\000\000\017\190\012\186\004\149\000\000\000\000\000\000\007\025\007\025\000\000\000\000\000\000\000\000\000\000\018>\000\000\000\000\000\000\012\194\000\000\r\005\r\005\028\182\000\000\000\000\000\000\000\000\007\025\007\025\007\025\000\000\000\000\000\000\000\000\000\000\012\214\r\026\007\025\000\000\004\217\r\005\r\005\r\005\007\206\000\000\000\000\000\000\000\000\000\000\000\000\r\005\007\025\007\025\000\000\000\000\000\000\000\000\007\025\018~\007\025\007\025\007\025\000\000\000\000\r\005\r\005\007\025\000\000\001\174\000\000\r\005\r\254\r\005\r\005\r\005\000\000\000\000\000\000\000\000\r\005\000\000\000\000\015\n\007\025\000\000\000\000\004\165\000\000\003R\000\000\000\000\000\000\002Z\002^\025\030\000\000\r\005\000\000\000\000\000\000\015\014\000\000\000\000\000\000\000\000\000\000\0156\000\000\000\000\000\000\000\000\000\000\001*\002b\002r\000\000\000\000\000\000\001\174\000\000\012\178\002\182\002~\000\000\000\000\012\186\000\000\000\000\000\000\000\000\000\000\005\030\004\209\000\000\000\000\000\000\002\130\003.\003R\000\000\000\000\015\202\003:\000\000\003F\004\026\004&\000\000\000\000\000\000\003^\0042\000\000\000\000\000\000\000\000\012&\000\000\012\214\015\222\000\000\000\000\004\165\004\165\000\000\003\226\000\000\021^\0046\000\000\012\178\000\000\000\000\000\000\000\000\012\186\000\000\000\000\000\000\000\000\000\000\015\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\194\000\000\000\000\000\000\000\000\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\214\r\026\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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~")) + ((16, "o\248x\028r\202\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\150r\202\000\000\000\000\021\164r\202o\248\024\164\000/\001B\171\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\0009\002x\000\177\000\000\000>\005\208\000\000\004\152\000\214\t\192\000\000\005\014\001\134\n\188\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\002\000\000\000\000\002`\187,\000\000\000\000\000\000\005\244\000\000\000\000\164\026\003:\004\182\000\000\000\000\185R\005\244\000\000v\002\021\164rB\169\228\021\164v\142s\234\021\164z\222\000\000\002\012\000\000q\186\003\b\000\000\027V\000\000\025\192\000\000\000\000\006\248\000\000\005\244\000\000\000\000\000\000\000Z\000\000\027V\000\000\007\142\197\158\203*\179\246\000\000\204\150\185R\000\000x\206\170\132\000\000pdn\138\187,r\202o\248\000\000\000\000s\234\021\164\127`q\186\007\236\197\158\000\000\194\004r\202o\248x\028\021\164\000\003\000\000\017\182w\162\021lnN\166&\000\000\000\023\000\000\000\000\003B\000\000\000\000t\168\001 \025\248\000\242\000\t\000\000\000\000\004n\000\000rB\006\238\007D\021\164\022\242\000\000\021\164o\248o\248\000\000\000\000\000\000t\210t\210\021\164\022\242nH\021\164\128.\030\028\004\140\b\232\000\000\007F\t\190\000\000\000\000\000\000\000\000\000\000\021\164\000\000\000\000\000\000x\028\021\164\000\003l.\184$y\192\000\250\128\240\166&\198,\192\142\000\000\b\232\000\000\bJ\000\000\023B\176\166\206\004\000\000\176\166\206\004\000\000\176\166\176\166\003\000\000X\003\000\005D\000\000\006x\000\000\000\000\006x\000\000\000\000\000\000\176\166\005\244\000\000\000\000\165\138\176\166\164\210\170\132\000\000\006\230\006x\185R\170\132\bB\176\166\000\000\000\000\000\000\000\000\000\000\000\000\129\162\170\132\130\150\003\000\000\000\000\000\000\000\001r\000\000\000\000\167\228\b\172\005\244\000\000\000\000\131\138\000\000\000\000\000\000\002\024\000\000\176\166\000\000\001\002\185\240\000\000\176\166\001\002\176\166o2\000\000p\"\000\000\006\234\004 \000\000\b&\176\166\006\144\000\000\007V\000\000\006f\000\000\000\003\tV\000\000\000\000\000\000\024\002\022\186\166&w\182\021\164\166&\000\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000z\174\028\182\000\000\000\000\000\000\001\244\029p\192\142\000\000w\182\021\164\166&\000\000\000\000\208\172\166&\2092\166&\209L\000\000\166&\000\000\000\000\167\018t\168\005\140\005\140\000\000\tL\166&\000\000\000\000\000\000\004\212\tl\000\000\025\214\000\000\166&\209\140\176\166\nN\000\000\166&\209\204\001B\000\000\000\000\000\000\t\182\000\000\030\194\000\000\198,\000\000\t\198\000\000n\186\196\224\000\000\000\000\024\218\005d\023.\t\210\000\000\000\000\000\000\000\000\tL\000\000\168\180\007*\t\230\000\019\176\166\003j\nH\000\000\000\000\n\"\t\230\001\162\000\003x\028xlt\210\021\164\022\242\000/\006\244\000\t\000\000\t\250rBrB\n\152rB\000/\006\244\n\166\000\000\n\180rB\000\000\184\138\n*q\186\b\232\002@\186\142\000\000\176\166\180\148\176\166\172Z\181L\176\166\b\148\176\166\181\128\000\000\0114\n\146\nxrB\185(\000\000\n\192\tz\170\006\000\000\000\000\000\000\000\000rB\185\198rB\186d\002\152\003\000\173\018\t\190\003\000\173\176\000\000\187\002\n*\000\000\000\000\187\160\000\156\000\000\024x\000\000\011F\022\242\000\000\170\164nH\000\000\000\228\000\000rB\024\206\000\000\000\000\000\000\169F\000\000\000+\000\003y\192\011~\022\180\132\\\023\136|4\017\182\133\030x\028\021\164\017\182x\028\021\164p\232x\028\021\164\000\003w\182\021\164\192\142\166&p\152\000\003x\028\021\164s\186\004\144\000\000\166&\024\218\176\166\004f\001\162\011\128\000\000\000\000\000\000u\154\005\140\011\194\000\000\166&\000\000\000\000\174>\000\000\000\000\004B\170\132\003\000\011\176\133\224w\182\021\164\192\142\027x\134\162w\182\021\164\192\142\028t\166&\000\000\000\000w\182\021\164\166&\025\214\000\003\017\182\000\000\000\000\000\000\000\000\001\246\026|m\"\000\000{\152|Zt\210\021\164\022\242\005\208rB\027\212\000\000}\028}\222\200\148\023\222\176\166\011J\000\003x\028\021\164\017\182\023\136\017\182\002\242\023Rv\142w\182\021\164\192\142\025\006v\142\135dw\182\021\164\192\142\000\000\017\182\011\028\011\202\002\226\176\166&\162\176\166\027\132\176\166'T\012\n\000\000\000\000\012\006\000\000\017\182\003\238\012&\000\000\030l\000\003\012|\000\000\029p\136&w\182\021\164\192\142\030l\018\178\024\132\000\000\000\000\000\000\000\000\n>\000\003\000\000\000\000\031h\136\232w\182\021\164\192\142 d!`\137\170w\182\021\164\192\142\"\\#X\000\000\019\174\025\128\138lw\182\021\164\192\142\000\000\000\000\000\003r\202\000\003\000\000\000\000\139.w\182\021\164\192\142$T%P\139\240w\182\021\164\192\142&L'H\140\178w\182\021\164\192\142(D)@\141tw\182\021\164\192\142*<+8\1426w\182\021\164\192\142,4-0\142\248w\182\021\164\192\142.,/(\143\186w\182\021\164\192\1420$1 \144|w\182\021\164\192\1422\0283\024\145>w\182\021\164\192\1424\0205\016\146\000w\182\021\164\192\1426\0127\b\146\194w\182\021\164\192\1428\0049\000\147\132w\182\021\164\192\1429\252:\248\148Fw\182\021\164\192\142;\244<\240\149\bw\182\021\164\192\142=\236>\232\149\202w\182\021\164\192\142?\228@\224\150\140w\182\021\164\192\142A\220B\216\151Nw\182\021\164\192\142C\212D\208\152\016w\182\021\164\192\142E\204F\200\152\210w\182\021\164\192\142G\196H\192\153\148w\182\021\164\192\142I\188J\184\021\164\166&s\186\000\003\000\000\187,\005\140\012\004\176\166\011\196\000\003\000\000\001\202\005\244\000\000\176\166\012$\000\003\000\000\012\026\000\003\000\000\000\000\002\226\000\000\012.\133\224\000\000\000\000\000\000\027\206\176\166\012\132\000\003\000\000\031\190\000\003\000\000\166& \186\166&!\182\166&\"\178\001B\000\000\000\000\000\000#\174\166&$\170\000\000\194\004\1940\000\000\000\000\000\000K\180\000\003\012\214\000\000\000\003\012\250\000\000\b\228\025\200v\142\r\186\000\000\171(wZ\000\000v\142\r\236\000\000v\142\r\252\000\000\000\000\017\182\004\234\026\196v\142\014>\005\230\154Vw\182\021\164\192\142L\176M\172v\142\014F\006\226\155\024w\182\021\164\192\142N\168O\164v\142\014R\007\222\155\218w\182\021\164\192\142P\160Q\156\030\250\000\003\014\162\b\218\156\156w\182\021\164\192\142R\152S\148\000\003\014\202\t\214\157^w\182\021\164\192\142T\144U\140\000\003\014\230\n\210\158 w\182\021\164\192\142V\136W\132\n\166\027\000v\142\014\248\011\206\158\226w\182\021\164\192\142X\128Y|v\142\014\250\012\202\159\164w\182\021\164\192\142Zx[tv\142\015\006\r\198\160fw\182\021\164\192\142\\p]l\014\194\161(w\182\021\164\192\142^h_d\015\190\020\170\000\000\000\000\000\000\000\000\015B\000\000v\142\015B\000\000v\142\015B\000\000\000\000%\166\000\003\000\000\007 \000\003\000\000\166&\000\000\000\000\188<\015T\000\000~\160\000\000\014\164\000\000\127l\000\000\015f\000\000\011~\015\018\000\000\023\136\026b\b\232\000\000\022N\024\190\011\202\026\130\000\000\000\000\015\148\000\000\001\146\027x|\246\000\000\012*\000\000\000\000\000\003\014\242\000\003\014\248\000\000``\000\000\015z\000\003\000\000\000\003\000\000\000\000\000\000a\\\015\192\161\234w\182\021\164\192\142bX\162\172w\182\021\164\192\142cTdPeL\163nw\182\021\164\192\142fHgD\000\000\015\"\000\000\026|w\182\021\164\192\142\004p\000\000\171(\000\000\016\186\015\186\000\000w\182\021\164\192\142\030\240\182\012\011\246\r\\\000\000\000\000\015P\000\000\015\202\000\000\000\000\021\164\022\242\003\198\000\003\000\000\025\248\000\242\000\t\006\244\022\242\198\146rB\003\158\022\242\198\246\015p\000\003\000\000\006\244\000\000r\226\021f\022V\000\000\012P\015\228\000\000\015\228\002\172\180\018\006.\000\000\015\186\015B\187,\003\220\176\166\023\004\bX\012\238\004\014\000\000\027\152\015\248\000\000\007\218\000\000\000\000\016\014\170\132\174\212\000\000\182d\202\172\005\234\180\018\015\218\170\132\188\210\1758\015\234\170\132\1896\175\216\003\216\015\192\000\003\000\000\000\000\021\164\201,\000\000\166&\194\004\000\000\000\000\0166\000\000\000\000\000\000w\182\021\164\192\142h@i<\000\000\015~\000\000\000\000t\210\021\164\022\242\003\216\000\000rB\028h\000\000\005\180\000\000\016@\000\000\016h\192\142j8w\182\021\164\192\142\024\172\000\000rB\028j\000\000rB\026r\000\000rB\029\204\000\000\182\234\000\000rB\030b\000\000rB\029f\000\000rB\031\\\000\000\1940\000\000\021\164\022\242\1940\000\000\030d\030\028\004\140\005\244\205\014rB\201l\194\004\000\000\000\242\005\222\000\t\006\244\194\004\206\130\000\242\000\t\006\244\194\004\206\130\000\000\000\000\006\244\194\004\000\000r\202o\248\166&\023\186\000\003\000\000r\202o\248t\210\021\164\022\242\1940\000\000\024\164\000/\001B\015\140\187,\t\218\176\166\194\198\015\192\016j\205l\000\000\194\004\000\000\195Hr\226\021f\022V\199T\028\196\012\166\001\250\r\n\015\176\021\164\194\004\000\000\021\164\194\004\000\000\176\166\176\166\020\208\006&\000\240\003\000\206\220\000\000\000\240\003\000\206\220\000\000\030\146\030\028\004\140\005\244\207:rB\1940\000\000\000\242\007\214\026\014\003\000\206\220\000\000\000\t\015\180rB\1940\130\030\000\242\000\t\015\208rB\1940\130\030\000\000\000\000\007\240\000\003\194h\000\000rB\205\198\194\004\000\000\007\240\000\000v\002\021\164rB\1940\000\000r\226\021f\022V\188\018\242\000\000\018\246\000\000q\216q\216\189p\189p\000\000\000\000{L\189p\000\000\000\000\000\000{L\189p\018f\000\000\018h\000\000"), (16, "\003\165\000\006\003.\0032\003\165\002\170\002\174\003\165\002\218\002z\003\165\0041\003\165\001^\002\230\003\165\007&\003\165\003\165\003\165\001V\003\165\003\165\003\165\001\194\004\241\004\241\b2\002\234\003\165\003f\003j\011\030\003\165\001n\003\165\001~\002\238\000\238\003\138\000\238\003\165\003\165\003\190\003\194\003\165\003\198\003\210\003\222\003\230\007\006\001f\003\165\003\165\002\162\bb\003\006\003\218\003\165\003\165\003\165\bf\bj\bv\b\134\002^\005\138\003\165\003\165\003\165\003\165\003\165\003\165\003\165\003\165\003\165\b\158\003\n\003\165\007^\003\165\003\165\003\165\0041\b\170\b\194\tf\005\150\005\154\003\165\003\165\003\165\0042\003\165\003\165\003\165\003\165\b~\b\022\b\130\b\149\016\210\003\165\006\226\003\165\003\165\004\241\003\165\003\165\003\165\003\165\003\165\003\165\005\158\b\146\003\165\003\165\003\165\tz\004^\t\222\007\218\003\165\003\165\003\165\003\165\r9\004\241\004\241\001v\r9\r9\r9\r9\b>\r9\r9\r9\r9\000\238\r9\r9\004\241\r9\r9\r9\004J\r9\r9\r9\r9\004\241\r9\002b\r9\r9\r9\r9\r9\r9\r9\r9\b2\r9\0079\r9\005\014\r9\r9\r9\r9\r9\030\147\r9\r9\000\238\r9\003\226\r9\r9\r9\000\238\000\238\r9\r9\r9\r9\r9\r9\r9\000\238\r9\r9\r9\r9\r9\r9\r9\r9\r9\r9\r9\001\137\r9\r9\004\206\r9\r9\r9\001\002\001\174\003\006\004\241\r9\r9\r9\r9\r9\001\134\r9\r9\r9\r9\r9\r9\r9\bB\r9\r9\007\193\r9\r9\003\n\r9\r9\r9\r9\r9\r9\r9\r9\r9\r9\r9\r9\r9\000\238\004\241\r9\r9\r9\r9\001\137\001\137\005\030\rB\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\r\t\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\r\t\001\137\004\254\001\137\022\014\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\007\002\001\137\016\142\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\rJ\001\137\001\137\001\137\001Z\004\t\006\133\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\005\206\t\146\001\137\020\170\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\001\137\n\237\018\018\007n\002\030\n\237\n\237\n\237\n\237\005\002\n\237\n\237\n\237\n\237\001\190\n\237\n\237\r\r\n\237\n\237\n\237\007v\n\237\n\237\n\237\n\237\003\205\n\237\001\170\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\r\r\n\237\001\182\n\237\003\205\n\237\n\237\n\237\n\237\n\237\007\230\n\237\n\237\007\153\n\237\t\129\n\237\n\237\n\237\002\146\007\238\n\237\n\237\n\237\n\237\n\237\n\237\n\237\007\242\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\018r\n\237\n\237\0045\n\237\n\237\n\237\007\201\001\218\004\186\007^\n\237\n\237\n\237\n\237\n\237\000\238\n\237\n\237\n\237\n\237\n\237\t\246\n\237\n6\nr\n\237\n>\n\237\n\237\003\018\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\n\237\000\238\n\237\n\237\n\237\n\237\n\237\004Q\003\022\007\218\002*\004Q\004Q\004Q\004Q\019\018\004Q\004Q\004Q\004Q\t\129\004Q\004Q\rB\004Q\004Q\004Q\000\238\004Q\004Q\004Q\004Q\0045\004Q\b2\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\b2\004Q\004\241\004Q\000\238\004Q\004Q\004Q\004Q\004Q\005:\004Q\004Q\000\238\004Q\017\210\004Q\004Q\004Q\017\170\004\241\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004\241\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\000\238\t\238\nj\004\173\004Q\004Q\004Q\003:\007\149\004\241\b\210\004Q\004Q\004Q\004Q\004Q\018.\004Q\004Q\004Q\004Q\004Q\t\246\004Q\019\022\nr\004Q\001Z\004Q\004Q\004\t\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\004Q\000\238\004Q\004Q\004Q\004Q\004Q\004A\004\241\b\214\b\242\004A\004A\004A\004A\007E\004A\004A\004A\004A\000\238\004A\004A\t\169\004A\004A\004A\017N\004A\004A\004A\004A\004\173\004A\t&\004A\004A\004A\004A\004A\004A\004A\004A\001Z\004A\b2\004A\004\t\004A\004A\004A\004A\004A\tF\004A\004A\003>\004A\000\238\004A\004A\004A\003\018\tZ\004A\004A\004A\004A\004A\004A\004A\004:\004A\004A\004A\004A\004A\004A\004A\004A\004A\004A\004A\003\022\t\238\nj\006\178\004A\004A\004A\005Y\030\131\001\222\024\250\004A\004A\004A\004A\004A\0042\004A\004A\004A\004A\004A\t\246\004A\006\153\nr\004A\n6\004A\004A\n>\004A\004A\004A\004A\004A\004A\004A\004A\004A\004A\004A\004A\004A\019&\004A\004A\004A\004A\004A\n\141\003.\0032\006\030\n\141\n\141\n\141\n\141\007\005\n\141\n\141\n\141\n\141\001\202\n\141\n\141\019\230\n\141\n\141\n\141\004>\n\141\n\141\n\141\n\141\0222\n\141\rB\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\b2\n\141\001\241\n\141\001j\n\141\n\141\n\141\n\141\n\141\b\201\n\141\n\141\000\238\n\141\014b\n\141\n\141\n\141\001\206\006\153\n\141\n\141\n\141\n\141\n\141\n\141\n\141\000\n\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\018\026\n\141\n\141\004B\n\141\n\141\n\141\n6\006y\005Z\n>\n\141\n\141\n\141\n\141\n\141\001\241\n\141\n\141\n\141\n\141\n\141\n\141\n\141\t\182\n\141\n\141\018z\n\141\n\141\005J\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\n\141\004\134\004N\n\141\n\141\n\141\n\141\n\157\022\002\004\014\004\026\n\157\n\157\n\157\n\157\004&\n\157\n\157\n\157\n\157\003F\n\157\n\157\002F\n\157\n\157\n\157\005^\n\157\n\157\n\157\n\157\t\173\n\157\002\017\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\002J\n\157\022\n\n\157\021\202\n\157\n\157\n\157\n\157\n\157\006\129\n\157\n\157\0042\n\157\014\134\n\157\n\157\n\157\005\002\007\"\n\157\n\157\n\157\n\157\n\157\n\157\n\157\000\238\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\005\002\n\157\n\157\005R\n\157\n\157\n\157\006\218\006\242\003J\t\173\n\157\n\157\n\157\n\157\n\157\001\190\n\157\n\157\n\157\n\157\n\157\n\157\n\157\017\194\n\157\n\157\004\130\n\157\n\157\016\014\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\n\157\017\202\t\173\n\157\n\157\n\157\n\157\n\149\003.\021\"\000\238\n\149\n\149\n\149\n\149\002n\n\149\n\149\n\149\n\149\001\190\n\149\n\149\0212\n\149\n\149\n\149\004)\n\149\n\149\n\149\n\149\003\158\n\149\016\022\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\030C\n\149\018\026\n\149\022.\n\149\n\149\n\149\n\149\n\149\006y\n\149\n\149\005\002\n\149\014\170\n\149\n\149\n\149\002\198\007\"\n\149\n\149\n\149\n\149\n\149\n\149\n\149\0226\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\004\002\n\149\n\149\004\241\n\149\n\149\n\149\004\241\021\194\b\193\025B\n\149\n\149\n\149\n\149\n\149\004\146\n\149\n\149\n\149\n\149\n\149\n\149\n\149\021j\n\149\n\149\n6\n\149\n\149\n>\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\n\149\021v\000\238\n\149\n\149\n\149\n\149\n\129\025\026\004\222\r]\n\129\n\129\n\129\n\129\026\194\n\129\n\129\n\129\n\129\002\174\n\129\n\129\r]\n\129\n\129\n\129\002\210\n\129\n\129\n\129\n\129\000\238\n\129\005B\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\005\t\n\129\025\"\n\129\025\166\n\129\n\129\n\129\n\129\n\129\006y\n\129\n\129\000\238\n\129\014\210\n\129\n\129\n\129\003\150\007\146\n\129\n\129\n\129\n\129\n\129\n\129\n\129\025\174\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\006*\n\129\n\129\001\190\n\129\n\129\n\129\005f\005\t\b\185\007\190\n\129\n\129\n\129\n\129\n\129\006B\n\129\n\129\n\129\n\129\n\129\n\129\n\129\026\198\n\129\n\129\014\018\n\129\n\129\003\158\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\n\129\003\162\002\146\n\129\n\129\n\129\n\129\n\137\029\254\001\206\006~\n\137\n\137\n\137\n\137\007\r\n\137\n\137\n\137\n\137\006\150\n\137\n\137\006\186\n\137\n\137\n\137\007\133\n\137\n\137\n\137\n\137\028\246\n\137\rB\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\003\166\n\137\0042\n\137\001z\n\137\n\137\n\137\n\137\n\137\006\206\n\137\n\137\007b\n\137\014\246\n\137\n\137\n\137\004^\006\222\n\137\n\137\n\137\n\137\n\137\n\137\n\137\004\241\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\006\238\n\137\n\137\006^\n\137\n\137\n\137\007\158\030c\006\250\018\214\n\137\n\137\n\137\n\137\n\137\004>\n\137\n\137\n\137\n\137\n\137\n\137\n\137\001\254\n\137\n\137\020j\n\137\n\137\000\238\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\n\137\000\238\004\206\n\137\n\137\n\137\n\137\n\133\n\182\004\241\007.\n\133\n\133\n\133\n\133\007\021\n\133\n\133\n\133\n\133\007:\n\133\n\133\001\206\n\133\n\133\n\133\003\201\n\133\n\133\n\133\n\133\007\"\n\133\007R\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\000\238\n\133\0042\n\133\001\138\n\133\n\133\n\133\n\133\n\133\007\170\n\133\n\133\r\014\n\133\015\026\n\133\n\133\n\133\002\174\007\162\n\133\n\133\n\133\n\133\n\133\n\133\n\133\007\210\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\0156\n\133\n\133\003\158\n\133\n\133\n\133\029\014\n.\nV\002\174\n\133\n\133\n\133\n\133\n\133\007\186\n\133\n\133\n\133\n\133\n\133\n\133\n\133\b&\n\133\n\133\022n\n\133\n\133\b\238\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\n\133\000\238\t\133\n\133\n\133\n\133\n\133\n\145\001\002\001\174\007\238\n\145\n\145\n\145\n\145\bn\n\145\n\145\n\145\n\145\t\006\n\145\n\145\016v\n\145\n\145\n\145\t\225\n\145\n\145\n\145\n\145\t\218\n\145\t2\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\000\238\n\145\017~\n\145\017\134\n\145\n\145\n\145\n\145\n\145\n2\n\145\n\145\nR\n\145\015F\n\145\n\145\n\145\000\238\016\158\n\145\n\145\n\145\n\145\n\145\n\145\n\145\025b\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n^\n\145\n\145\003\162\n\145\n\145\n\145\t\133\002\134\b\185\r6\n\145\n\145\n\145\n\145\n\145\nn\n\145\n\145\n\145\n\145\n\145\n\145\n\145\t\201\n\145\n\145\000\238\n\145\n\145\n~\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\n\145\001\002\001\174\n\145\n\145\n\145\n\145\n\161\002\134\r.\r^\n\161\n\161\n\161\n\161\rR\n\161\n\161\n\161\n\161\rv\n\161\n\161\016\162\n\161\n\161\n\161\021\210\n\161\n\161\n\161\n\161\000\238\n\161\r\254\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\018>\n\161\003\162\n\161\004\029\n\161\n\161\n\161\n\161\n\161\014\n\n\161\n\161\018\002\n\161\015j\n\161\n\161\n\161\022:\r\146\n\161\n\161\n\161\n\161\n\161\n\161\n\161\025\170\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\022\006\n\161\n\161\020\174\n\161\n\161\n\161\025&\006\137\rq\021\242\n\161\n\161\n\161\n\161\n\161\006>\n\161\n\161\n\161\n\161\n\161\n\161\n\161\b\197\n\161\n\161\022\166\n\161\n\161\002b\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\n\161\000\238\bn\n\161\n\161\n\161\n\161\n\153\000\238\006}\007\238\n\153\n\153\n\153\n\153\025\030\n\153\n\153\n\153\n\153\014\030\n\153\n\153\re\n\153\n\153\n\153\022z\n\153\n\153\n\153\n\153\022\194\n\153\t\205\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\026n\n\153\025\178\n\153\0146\n\153\n\153\n\153\n\153\n\153\0042\n\153\n\153\014B\n\153\015\142\n\153\n\153\n\153\000\238\026R\n\153\n\153\n\153\n\153\n\153\n\153\n\153\028\186\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\028\242\n\153\n\153\014^\n\153\n\153\n\153\b\189\r\014\014\130\025\130\n\153\n\153\n\153\n\153\n\153\014\166\n\153\n\153\n\153\n\153\n\153\n\153\n\153\029\250\n\153\n\153\000\238\n\153\n\153\022\130\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\n\153\026F\028\n\n\153\n\153\n\153\n\153\n\221\026\166\005\133\014\206\n\221\n\221\n\221\n\221\025\226\n\221\n\221\n\221\n\221\001\190\n\221\n\221\022\130\n\221\n\221\n\221\007\238\n\221\n\221\n\221\n\221\014\242\n\221\007\238\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\000\238\n\221\029\002\n\221\015\022\n\221\n\221\n\221\n\221\n\221\015B\n\221\n\221\015f\n\221\015\170\n\221\n\221\n\221\028\134\015\138\n\221\n\221\n\221\n\221\n\221\n\221\n\221\001\190\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\030s\n\221\n\221\005\t\n\221\n\221\n\221\015\222\007\238\015\234\015\246\n\221\n\221\n\221\n\221\n\221\016*\n\221\n\221\n\221\n\221\n\221\n\221\n\221\016:\n\221\n\221\016J\n\221\n\221\029f\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\n\221\016V\002\210\n\221\n\221\n\221\n\221\004=\016\134\016\174\016\182\004=\004=\004=\004=\016\198\004=\004=\004=\004=\016\230\004=\004=\0176\004=\004=\004=\017b\004=\004=\004=\004=\017\142\004=\017\150\004=\004=\004=\004=\004=\004=\004=\004=\017\222\004=\018\006\004=\003\242\004=\004=\004=\004=\004=\018\"\004=\004=\018&\004=\018N\004=\004=\004=\018b\018\130\004=\004=\004=\004=\004=\004=\004=\018\146\004=\004=\004=\004=\004=\004=\004=\004=\004=\004=\004=\018\166\t\238\nj\018\210\004=\004=\004=\018\250\019.\0196\020b\004=\004=\004=\004=\004=\020v\004=\004=\004=\004=\004=\t\246\004=\020z\nr\004=\006z\004=\004=\021:\004=\004=\004=\004=\004=\004=\004=\004=\004=\004=\004=\004=\004=\021R\004=\004=\004=\004=\004=\nu\021\218\021\222\022\022\nu\nu\nu\nu\022\026\nu\nu\nu\nu\022B\nu\nu\022F\nu\nu\nu\022^\nu\nu\nu\nu\022\214\nu\023\006\nu\nu\nu\nu\nu\nu\nu\nu\023\n\nu\023.\nu\0232\nu\nu\nu\nu\nu\023B\nu\nu\023R\nu\023^\nu\nu\nu\023\146\023\150\nu\nu\nu\nu\nu\nu\nu\023\230\nu\nu\nu\nu\nu\nu\nu\nu\nu\nu\nu\024\014\t\238\nj\024\018\nu\nu\nu\024\"\024r\024\146\024\210\nu\nu\nu\nu\nu\024\246\nu\nu\nu\nu\nu\t\246\nu\025\006\nr\nu\025.\nu\nu\0252\nu\nu\nu\nu\nu\nu\nu\nu\nu\nu\nu\nu\nu\025>\nu\nu\nu\nu\nu\002!\025N\025j\025z\002!\002\170\002\174\002!\025\142\002z\002!\n*\002!\025\186\002\230\002!\025\190\002!\002!\002!\025\202\002!\002!\002!\001\194\025\218\nZ\025\238\002\234\002!\002!\002!\002!\002!\nb\002!\026\206\002\238\026\218\003\138\027\n\002!\002!\002!\002!\002!\027.\003\210\001\174\027V\002!\027\202\002!\002!\002\162\027\210\027\234\003\218\002!\002!\002!\bf\bj\bv\028\022\014J\005\138\002!\002!\002!\002!\002!\002!\002!\002!\002!\028\030\t\238\nj\028*\002!\002!\002!\0286\028\154\028\174\028\222\005\150\005\154\002!\002!\002!\028\230\002!\002!\002!\002!\b~\014R\b\130\029\030\014\194\002!\029F\002!\002!\029~\002!\002!\002!\002!\002!\002!\005\158\b\146\002!\002!\002!\tz\004^\029\146\029\170\002!\002!\002!\002!\n\201\029\182\029\190\029\199\n\201\002\170\002\174\n\201\029\215\002z\n\201\n\201\n\201\029\234\002\230\n\201\030\006\n\201\n\201\n\201\030#\n\201\n\201\n\201\001\194\0303\n\201\030O\002\234\n\201\n\201\n\201\n\201\n\201\n\201\n\201\030\163\002\238\030\191\003\138\030\202\n\201\n\201\n\201\n\201\n\201\030\255\003\210\001\174\031\019\n\201\031\027\n\201\n\201\002\162\031W\031_\003\218\n\201\n\201\n\201\bf\bj\bv\000\000\n\201\005\138\n\201\n\201\n\201\n\201\n\201\n\201\n\201\n\201\n\201\000\000\n\201\n\201\000\000\n\201\n\201\n\201\000\000\000\000\000\000\000\000\005\150\005\154\n\201\n\201\n\201\000\000\n\201\n\201\n\201\n\201\b~\n\201\b\130\000\000\n\201\n\201\000\000\n\201\n\201\000\000\n\201\n\201\n\201\n\201\n\201\n\201\005\158\b\146\n\201\n\201\n\201\tz\004^\000\000\000\000\n\201\n\201\n\201\n\201\n\197\000\000\000\000\000\000\n\197\002\170\002\174\n\197\000\000\002z\n\197\n\197\n\197\000\000\002\230\n\197\000\000\n\197\n\197\n\197\000\000\n\197\n\197\n\197\001\194\000\000\n\197\000\000\002\234\n\197\n\197\n\197\n\197\n\197\n\197\n\197\000\000\002\238\000\000\003\138\000\000\n\197\n\197\n\197\n\197\n\197\000\000\003\210\001\174\000\000\n\197\000\000\n\197\n\197\002\162\000\000\000\000\003\218\n\197\n\197\n\197\bf\bj\bv\000\000\n\197\005\138\n\197\n\197\n\197\n\197\n\197\n\197\n\197\n\197\n\197\000\000\n\197\n\197\000\000\n\197\n\197\n\197\000\000\000\000\000\000\000\000\005\150\005\154\n\197\n\197\n\197\000\000\n\197\n\197\n\197\n\197\b~\n\197\b\130\000\000\n\197\n\197\000\000\n\197\n\197\000\000\n\197\n\197\n\197\n\197\n\197\n\197\005\158\b\146\n\197\n\197\n\197\tz\004^\000\000\000\000\n\197\n\197\n\197\n\197\002i\000\000\000\000\000\000\002i\002\170\002\174\002i\000\000\002z\002i\n*\002i\000\000\002\230\002i\000\000\002i\002i\002i\000\000\002i\002i\002i\001\194\001\241\nZ\000\000\002\234\002i\002i\002i\002i\002i\nb\002i\000\000\002\238\000\000\003\138\000\000\002i\002i\002i\002i\002i\000\000\003\210\001\174\000\000\002i\000\n\002i\002i\002\162\000\000\000\000\003\218\002i\002i\002i\bf\bj\bv\000\000\014J\005\138\002i\002i\002i\002i\002i\002i\002i\002i\002i\000\000\000\000\002i\001\241\002i\002i\002i\004\241\000\000\000\000\000\000\005\150\005\154\002i\002i\002i\000\000\002i\002i\002i\002i\b~\000\000\b\130\004\241\004\241\002i\004\241\002i\002i\004\241\002i\002i\002i\002i\002i\002i\005\158\b\146\002i\002i\002i\tz\004^\004\241\004\241\002i\002i\002i\002i\004\241\000\000\004\241\004\241\004\241\004\241\004\241\004\241\004\241\000\000\004\241\020\214\004\241\004\241\000\238\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\000\238\004\241\004\241\000\238\004\241\004\241\004\241\000\238\004\241\004\241\004\241\004\241\004\241\000\000\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\001\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\000\238\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\000\000\004\241\000\000\024\234\004\241\004\241\004\241\004\241\004\241\000\000\000\n\000\238\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\004\241\000\000\000\000\004\241\004\241\017\250\001\241\004\241\002z\004\241\004\241\000\000\000\000\007\201\ti\004\241\004\241\007\201\001\241\001\241\004\241\000\000\004\241\004\241\004\241\000\000\000\000\004\241\004\241\004\241\004\241\000\000\000\129\004\241\000\129\000\129\000\129\000\129\000\129\000\129\000\129\004\241\000\129\000\000\000\129\000\129\017\254\000\129\000\129\026\014\000\000\000\129\000\129\000\238\000\129\000\129\000\129\000\129\000\000\000\129\018\n\000\129\000\129\000\000\007\165\000\129\000\129\007\185\000\129\000\129\000\129\007\185\000\129\000\000\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\003R\002\174\000\129\000\129\007\201\005\154\000\129\000\129\003V\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\ti\001\194\000\129\n6\b\173\000\129\n>\000\129\b\173\000\129\t\173\025Z\006\182\002\174\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\000\000\000\003~\000\129\007\165\000\000\000\129\005]\000\129\002\162\000\222\000\000\000\000\007\157\000\129\br\000\000\007\157\005z\000\000\000\129\000\129\000\129\000\129\b\173\000\000\000\129\000\129\000\129\000\129\002a\000\000\000\000\003\150\002a\002\170\002\174\002a\007\026\002z\002a\000\000\002a\000\000\002\230\002a\b\173\002a\002a\002a\t\250\002a\002a\002a\001\194\000\000\000\000\020.\002\234\002a\002a\002a\002a\002a\015\226\002a\015\238\002\238\000\000\003\138\000\000\002a\002a\002a\002a\002a\b\153\003\210\bz\000\000\002a\000\000\002a\002a\002\162\004\218\007\157\003\218\002a\002a\002a\bf\bj\bv\000\000\000\000\005\138\002a\002a\002a\002a\002a\002a\002a\002a\002a\004\n\t\238\nj\007\161\002a\002a\002a\007\161\000\000\000\238\000\000\005\150\005\154\002a\002a\002a\000\000\002a\002a\002a\002a\b~\t\246\b\130\000\000\nr\002a\bY\002a\002a\000\000\002a\002a\002a\002a\002a\002a\005\158\b\146\002a\002a\002a\tz\004^\007^\000\238\002a\002a\002a\002a\002u\004\241\000\000\000\000\002u\000\000\006N\002u\bY\005\250\002u\000\000\002u\b\030\000\000\002u\006b\002u\002u\002u\006j\002u\002u\002u\bY\000\000\007\161\bY\t\210\002u\002u\002u\002u\002u\bY\002u\007\218\007^\bY\019N\000\000\002u\002u\002u\002u\002u\000\000\007\165\000\n\000\000\002u\007\165\002u\002u\000\238\000\238\bJ\000\000\002u\002u\002u\007\189\004\169\001\241\001\241\007\189\000\000\002u\002u\002u\002u\002u\002u\002u\002u\002u\001\241\t\238\nj\007\218\002u\002u\002u\n\014\t\185\000\000\t\185\t\185\000\000\002u\002u\002u\000\000\002u\002u\002u\002u\000\238\t\246\000\000\000\000\nr\002u\000\238\002u\002u\000\000\002u\002u\002u\002u\002u\002u\022b\000\000\002u\002u\002u\000\000\000\000\br\000\000\002u\002u\002u\002u\002q\tF\019R\000\000\002q\019^\001\254\002q\004\169\002z\002q\tZ\002q\000\000\000\000\002q\000\000\002q\002q\002q\000\000\002q\002q\002q\006N\004\241\000\000\005\250\b\222\002q\002q\002q\002q\002q\006b\002q\000\000\r\017\006j\000\000\000\000\002q\002q\002q\002q\002q\tF\029\226\001\206\000\000\002q\000\000\002q\002q\t\185\000\000\tZ\r\017\002q\002q\002q\018\n\006J\002:\000\000\001\241\001\241\002q\002q\002q\002q\002q\002q\002q\002q\002q\002>\t\238\nj\000\238\002q\002q\002q\014\022\000\000\000\000\000\000\000\000\005\154\002q\002q\002q\000\n\002q\002q\002q\002q\014.\t\246\014:\000\000\nr\002q\000\238\002q\002q\000\000\002q\002q\002q\002q\002q\002q\016b\000\000\002q\002q\002q\0069\000\000\001\241\007^\002q\002q\002q\002q\002e\tm\000\000\000\000\002e\000\000\003\162\002e\tv\002\174\002e\026:\002e\000\000\019f\002e\000\000\002e\002e\002e\000\000\002e\002e\002e\006N\t\229\000\000\005\250\006V\002e\002e\002e\002e\002e\006b\002e\0069\007\218\006j\000\000\000\238\002e\002e\002e\002e\002e\000\000\t\150\001\174\000\000\002e\003\150\002e\002e\021&\000\238\0069\016.\002e\002e\002e\016>\016N\016Z\t\238\nj\000\000\002e\002e\002e\002e\002e\002e\002e\002e\002e\000\000\t\238\nj\000\000\002e\002e\002e\014V\000\000\t\246\000\000\tm\nr\002e\002e\002e\000\000\002e\002e\002e\002e\014z\t\246\014\158\000\000\nr\002e\019j\002e\002e\000\000\002e\002e\002e\002e\002e\002e\015:\r\005\002e\002e\002e\000\000\000\000\000\000\000\000\002e\002e\002e\002e\002\025\015^\000\000\015\130\002\025\000\000\003\162\002\025\r\005\000\000\002\025\002\022\002\025\000\000\002\026\002\025\000\000\002\025\002\025\002\025\000\000\002\025\002\025\002\025\012\213\012\213\000\000\002&\012\213\002\025\002\025\002\025\002\025\002\025\b\169\002\025\000\000\000\000\b\169\000\000\000\000\002\025\002\025\002\025\002\025\002\025\007^\t\150\016\146\000\000\002\025\000\000\002\025\002\025\0022\000\000\000\000\016.\002\025\002\025\002\025\016>\016N\016Z\000\000\t\190\000\238\002\025\002\025\002\025\002\025\002\025\002\025\002\025\002\025\002\025\b\169\000\000\002\025\000\000\002\025\002\025\002\025\000\000\000\000\000\238\000\000\000\000\007\218\002\025\002\025\002\025\000\000\002\025\002\025\002\025\002\025\012\213\b\169\000\000\000\000\0026\002\025\011)\002\025\002\025\000\238\tF\002\025\002\025\002\025\002\025\002\025\000\000\nF\002\025\002\025\tZ\030\175\000\000\007^\007^\002\025\002\025\002\025\002\025\t\157\000\000\000\000\000\000\t\157\000\000\006N\t\157\011)\005\250\t\157\004\218\t\157\019\030\019Z\t\157\006b\t\157\t\157\t\157\006j\t\157\t\157\t\157\011)\000\000\000\000\011)\r\138\t\157\t\157\t\157\t\157\t\157\011)\t\157\007\218\007\218\011)\000\000\000\000\t\157\t\157\t\157\t\157\t\157\002\174\002\230\000\000\002z\t\157\000\000\t\157\t\157\000\238\000\238\000\000\000\000\t\157\t\157\t\157\000\000\027\254\000\000\003\002\000\000\000\000\t\157\t\157\t\157\t\157\t\157\t\157\t\157\t\157\t\157\000\000\003\014\t\157\000\000\t\157\t\157\t\157\000\000\000\000\000\000\000\000\020\162\000\000\t\157\t\157\t\157\000\000\t\157\t\157\t\157\t\157\000\000\000\000\005\138\000\000\018\n\t\157\000\238\t\157\t\157\000\000\tF\t\157\t\157\t\157\t\157\t\157\000\000\000\000\t\157\t\157\tZ\000\000\000\000\005\150\007^\t\157\t\157\t\157\t\157\002m\000\000\005\154\000\000\002m\000\000\003\162\002m\000\000\000\000\002m\000\000\002m\000\000\019\146\002m\000\000\002m\002m\002m\005\158\002m\002m\002m\006N\000\000\000\000\005\250\028\002\002m\002m\002m\002m\002m\006b\002m\000\000\007\218\006j\000\000\000\000\002m\002m\002m\002m\002m\007^\005\210\000\000\000\000\002m\000\000\002m\002m\000\000\000\238\000\000\003\234\002m\002m\002m\006\138\000\000\003\246\000\000\019r\000\000\002m\002m\002m\002m\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\007\218\002m\002m\002m\001\241\002m\002m\002m\002m\000\000\b\185\000\000\000\000\b\185\002m\019\150\002m\002m\000\238\n\134\002m\002m\002m\002m\002m\000\000\000\000\002m\002m\002m\000\n\025b\000\000\007^\002m\002m\002m\002m\t\141\001\241\001\241\019\190\t\141\000\000\002\174\t\141\001\241\000\000\t\141\000\000\t\141\b\185\019\134\t\141\001\241\t\141\t\141\t\141\001\241\t\141\t\141\t\141\001\241\001\241\020\254\b\185\000\n\t\141\t\141\t\141\t\141\t\141\000\000\t\141\000\000\007\218\000\000\001\241\000\000\t\141\t\141\t\141\t\141\t\141\000\000\nv\003\150\000\000\t\141\000\n\t\141\t\141\b\185\000\238\001\241\000\000\t\141\t\141\t\141\r\246\006\134\014\002\000\000\000\000\000\000\t\141\t\141\t\141\t\141\t\141\t\141\t\141\t\141\t\141\000\000\002\174\t\141\001\241\t\141\t\141\t\141\b\185\007\173\000\000\000\000\000\000\007\173\t\141\t\141\t\141\000\000\t\141\t\141\t\141\t\141\000\000\000\000\000\000\000\000\000\000\t\141\000\238\t\141\t\141\000\000\tF\t\141\t\141\t\141\t\141\t\141\000\000\000\000\t\141\t\141\tZ\014\198\003\150\007^\007^\t\141\t\141\t\141\t\141\003\161\000\000\000\000\000\000\003\161\000\000\014\234\003\161\015\014\000\000\003\161\000\000\003\161\019\158\027\246\n\198\000\000\003\161\011\026\003\161\007\173\003\161\003\161\003\161\006N\000\000\000\000\005\250\000\000\011.\011v\011\142\011F\011\166\006b\003\161\007\218\007\218\006j\000\000\000\000\003\161\003\161\011\190\011\214\003\161\007^\tF\000\000\000\000\003\161\000\000\011\238\003\161\000\238\000\238\000\000\tZ\003\161\003\161\000\238\000\000\000\000\000\000\000\000\029\154\000\000\003\161\003\161\n\222\011^\012\006\012\030\012N\003\161\003\161\000\000\000\000\003\161\000\000\003\161\003\161\012f\000\000\000\000\000\000\000\000\000\000\007\218\003\161\003\161\012~\000\000\003\161\003\161\003\161\003\161\000\000\000\000\000\000\000\000\000\000\003\161\000\238\003\161\003\161\000\238\012\222\003\161\012\246\0126\003\161\003\161\000\000\000\000\003\161\012\150\003\161\000\000\000\000\000\000\000\000\003\161\003\161\012\174\012\198\002\205\000\000\000\000\000\000\002\205\000\000\000\000\002\205\r\158\000\000\002\205\000\000\002\205\000\000\000\000\002\205\000\000\002\205\002\205\002\205\000\000\002\205\002\205\002\205\r\166\000\000\000\000\r\174\000\000\002\205\002\205\002\205\002\205\002\205\r\182\002\205\000\000\000\000\r\190\000\000\000\000\002\205\002\205\002\205\002\205\002\205\000\000\000\000\000\000\000\000\002\205\000\000\002\205\002\205\000\000\000\000\000\000\000\000\002\205\002\205\002\205\000\000\000\000\000\000\000\000\000\000\000\000\002\205\002\205\002\205\002\205\002\205\002\205\002\205\002\205\002\205\000\000\000\000\002\205\000\000\002\205\002\205\002\205\000\000\000\000\000\000\000\000\000\000\000\000\002\205\002\205\002\205\000\000\002\205\002\205\002\205\002\205\000\000\000\000\000\000\000\000\000\000\002\205\000\238\002\205\002\205\000\000\tF\002\205\002\205\002\205\002\205\002\205\000\000\000\000\002\205\002\205\tZ\000\000\000\000\000\000\000\000\002\205\002\205\002\205\002\205\002\201\000\000\000\000\000\000\002\201\000\000\000\000\002\201\bU\000\000\002\201\000\000\002\201\000\000\000\000\002\201\000\000\002\201\002\201\002\201\000\000\002\201\002\201\002\201\bU\000\000\000\000\005\250\000\000\002\201\002\201\002\201\002\201\002\201\bU\002\201\000\000\000\000\bU\000\000\000\000\002\201\002\201\002\201\002\201\002\201\000\000\000\000\000\000\000\000\002\201\000\000\002\201\002\201\000\000\000\000\000\000\000\000\002\201\002\201\002\201\000\000\000\000\000\000\000\000\000\000\000\000\002\201\002\201\n\222\002\201\002\201\002\201\002\201\002\201\002\201\000\000\000\000\002\201\000\000\002\201\002\201\002\201\000\000\000\000\000\000\000\000\000\000\000\000\002\201\002\201\002\201\000\000\002\201\002\201\002\201\002\201\000\000\000\000\000\000\000\000\000\000\002\201\bm\002\201\002\201\000\000\002\201\002\201\002\201\002\201\002\201\002\201\000\000\000\000\002\201\002\201\002\201\000\000\000\000\000\000\000\000\002\201\002\201\002\201\002\201\002\157\000\000\000\000\000\000\002\157\000\000\000\000\002\157\bm\000\000\002\157\000\000\002\157\000\000\000\000\002\157\000\000\002\157\002\157\002\157\000\000\002\157\002\157\002\157\bm\000\000\000\000\005\250\000\000\002\157\002\157\002\157\002\157\002\157\bm\002\157\000\000\000\000\bm\000\000\000\000\002\157\002\157\002\157\002\157\002\157\000\000\000\000\000\000\000\000\002\157\000\000\002\157\002\157\000\000\000\000\000\000\000\000\002\157\002\157\002\157\000\000\000\000\000\000\000\000\000\000\000\000\002\157\002\157\002\157\002\157\002\157\002\157\002\157\002\157\002\157\000\000\000\000\002\157\000\000\002\157\002\157\002\157\000\000\000\000\000\000\000\000\000\000\000\000\002\157\002\157\002\157\000\000\002\157\002\157\002\157\002\157\000\000\000\000\000\000\000\000\000\000\002\157\000\238\002\157\002\157\000\000\tF\002\157\002\157\002\157\002\157\002\157\000\000\000\000\002\157\002\157\tZ\000\000\000\000\000\000\000\000\002\157\002\157\002\157\002\157\002\153\000\000\000\000\000\000\002\153\000\000\000\000\002\153\b\129\000\000\002\153\000\000\002\153\000\000\000\000\002\153\000\000\002\153\002\153\002\153\000\000\002\153\002\153\002\153\006N\000\000\000\000\005\250\000\000\002\153\002\153\002\153\002\153\002\153\b\129\002\153\000\000\000\000\b\129\000\000\000\000\002\153\002\153\002\153\002\153\002\153\000\000\000\000\000\000\000\000\002\153\000\000\002\153\002\153\000\000\000\000\000\000\000\000\002\153\002\153\002\153\000\000\000\000\000\000\000\000\000\000\000\000\002\153\002\153\n\222\002\153\002\153\002\153\002\153\002\153\002\153\000\000\000\000\002\153\000\000\002\153\002\153\002\153\000\000\000\000\000\000\000\000\000\000\000\000\002\153\002\153\002\153\000\000\002\153\002\153\002\153\002\153\000\000\000\000\000\000\000\000\000\000\002\153\b}\002\153\002\153\000\000\002\153\002\153\002\153\002\153\002\153\002\153\000\000\000\000\002\153\002\153\002\153\000\000\000\000\000\000\000\000\002\153\002\153\002\153\002\153\002\181\000\000\000\000\000\000\002\181\000\000\000\000\002\181\b}\000\000\002\181\000\000\002\181\000\000\000\000\002\181\000\000\002\181\002\181\002\181\000\000\002\181\002\181\002\181\r\210\000\000\000\000\b}\000\000\002\181\002\181\002\181\002\181\002\181\b}\002\181\000\000\000\000\b}\000\000\000\000\002\181\002\181\002\181\002\181\002\181\000\000\000\000\000\000\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\002\181\002\181\002\181\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\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\238\002\181\002\181\000\000\tF\002\181\002\181\002\181\002\181\002\181\000\000\000\000\002\181\002\181\tZ\000\000\000\000\000\000\000\000\002\181\002\181\002\181\002\181\002\177\000\000\000\000\000\000\002\177\000\000\000\000\002\177\bQ\000\000\002\177\000\000\002\177\000\000\000\000\n\198\000\000\002\177\002\177\002\177\000\000\002\177\002\177\002\177\bQ\000\000\000\000\005\250\000\000\002\177\002\177\002\177\011F\002\177\bQ\002\177\000\000\000\000\bQ\000\000\000\000\002\177\002\177\002\177\002\177\002\177\000\000\000\000\000\000\000\000\002\177\000\000\002\177\002\177\000\000\000\000\000\000\000\000\002\177\002\177\002\177\000\000\000\000\000\000\000\000\000\000\000\000\002\177\002\177\n\222\011^\002\177\002\177\002\177\002\177\002\177\000\000\000\000\002\177\000\000\002\177\002\177\002\177\000\000\000\000\000\000\000\000\000\000\000\000\002\177\002\177\002\177\000\000\002\177\002\177\002\177\002\177\000\000\000\000\000\000\000\000\000\000\002\177\000\238\002\177\002\177\000\000\002\177\002\177\002\177\002\177\002\177\002\177\000\000\000\000\002\177\002\177\002\177\000\000\000\000\000\000\000\000\002\177\002\177\002\177\002\177\002\213\000\000\000\000\000\000\002\213\000\000\000\000\002\213\016\002\000\000\002\213\000\000\002\213\000\000\000\000\002\213\000\000\002\213\002\213\002\213\000\000\002\213\002\213\002\213\r\166\000\000\000\000\r\174\000\000\002\213\002\213\002\213\002\213\002\213\r\182\002\213\000\000\000\000\r\190\000\000\000\000\002\213\002\213\002\213\002\213\002\213\000\000\000\000\000\000\000\000\002\213\000\000\002\213\002\213\000\000\000\000\000\000\000\000\002\213\002\213\002\213\012\221\012\221\000\000\000\000\012\221\000\000\002\213\002\213\002\213\002\213\002\213\002\213\002\213\002\213\002\213\000\000\000\000\002\213\000\000\002\213\002\213\002\213\000\000\000\000\000\000\000\000\000\000\000\000\002\213\002\213\002\213\000\000\002\213\002\213\002\213\002\213\000\000\017\250\000\000\000\000\002z\002\213\000\238\002\213\002\213\000\000\tF\002\213\002\213\002\213\002\213\002\213\000\000\000\000\002\213\002\213\tZ\000\000\000\000\000\000\000\000\002\213\002\213\002\213\002\213\002\209\000\000\000\000\000\000\002\209\000\000\000\000\002\209\012\221\000\000\002\209\000\000\002\209\017\254\000\000\002\209\000\000\002\209\002\209\002\209\000\000\002\209\002\209\002\209\012\217\012\217\000\000\018\n\012\217\002\209\002\209\002\209\002\209\002\209\000\000\002\209\000\000\000\000\000\000\000\000\000\000\002\209\002\209\002\209\002\209\002\209\000\000\000\000\000\000\000\000\002\209\000\000\002\209\002\209\005\154\000\000\000\000\000\000\002\209\002\209\002\209\000\000\000\000\000\000\000\000\000\000\000\238\002\209\002\209\n\222\002\209\002\209\002\209\002\209\002\209\002\209\000\000\000\000\002\209\000\000\002\209\002\209\002\209\028>\000\000\000\000\000\000\000\000\000\000\002\209\002\209\002\209\000\000\002\209\002\209\002\209\002\209\012\217\017\250\000\000\000\000\002z\002\209\000\000\002\209\002\209\000\000\002\209\002\209\002\209\002\209\002\209\002\209\000\000\000\000\002\209\002\209\002\209\000\000\000\000\000\000\000\000\002\209\002\209\002\209\002\209\002\149\000\000\000\000\000\000\002\149\000\000\000\000\002\149\000\000\000\000\002\149\000\000\002\149\017\254\000\000\002\149\000\000\002\149\002\149\002\149\000\000\002\149\002\149\002\149\000\000\000\000\000\000\018\n\000\000\002\149\002\149\002\149\002\149\002\149\000\000\002\149\000\000\000\000\000\000\000\000\000\000\002\149\002\149\002\149\002\149\002\149\000\000\000\000\000\000\000\000\002\149\000\000\002\149\002\149\005\154\000\000\000\000\000\000\002\149\002\149\002\149\000\000\000\000\000\000\000\000\000\000\000\000\002\149\002\149\002\149\002\149\002\149\002\149\002\149\002\149\002\149\000\000\000\000\002\149\000\000\002\149\002\149\002\149\024>\000\000\000\000\000\000\000\000\000\000\002\149\002\149\002\149\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\tF\002\149\002\149\002\149\002\149\002\149\000\000\000\000\002\149\002\149\tZ\000\000\000\000\000\000\000\000\002\149\002\149\002\149\002\149\002\145\000\000\000\000\000\000\002\145\000\000\000\000\002\145\000\000\000\000\002\145\000\000\002\145\000\000\000\000\002\145\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\002\145\002\145\002\145\002\145\002\145\000\000\002\145\000\000\000\000\000\000\000\000\000\000\002\145\002\145\002\145\002\145\002\145\000\000\000\000\000\000\000\000\002\145\000\000\002\145\002\145\000\000\000\000\000\000\000\000\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\145\n\222\002\145\002\145\002\145\002\145\002\145\002\145\000\000\000\000\002\145\000\000\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\000\000\002\145\002\145\002\145\000\000\002\145\002\145\002\145\002\145\000\000\000\000\000\000\000\000\000\000\002\145\000\000\002\145\002\145\000\000\002\145\002\145\002\145\002\145\002\145\002\145\000\000\000\000\002\145\002\145\002\145\000\000\000\000\000\000\000\000\002\145\002\145\002\145\002\145\002\173\000\000\000\000\000\000\002\173\000\000\000\000\002\173\000\000\000\000\002\173\000\000\002\173\000\000\000\000\002\173\000\000\002\173\002\173\002\173\000\000\002\173\002\173\002\173\000\000\000\000\000\000\000\000\000\000\002\173\002\173\002\173\002\173\002\173\000\000\002\173\000\000\000\000\000\000\000\000\000\000\002\173\002\173\002\173\002\173\002\173\000\000\000\000\000\000\000\000\002\173\000\000\002\173\002\173\000\000\000\000\000\000\000\000\002\173\002\173\002\173\000\000\000\000\000\000\000\000\000\000\000\000\002\173\002\173\002\173\002\173\002\173\002\173\002\173\002\173\002\173\000\000\000\000\002\173\000\000\002\173\002\173\002\173\000\000\000\000\000\000\000\000\000\000\000\000\002\173\002\173\002\173\000\000\002\173\002\173\002\173\002\173\000\000\000\000\000\000\000\000\000\000\002\173\000\000\002\173\002\173\000\000\tF\002\173\002\173\002\173\002\173\002\173\000\000\000\000\002\173\002\173\tZ\000\000\000\000\000\000\000\000\002\173\002\173\002\173\002\173\002\169\000\000\000\000\000\000\002\169\000\000\000\000\002\169\000\000\000\000\002\169\000\000\002\169\000\000\000\000\n\198\000\000\002\169\002\169\002\169\000\000\002\169\002\169\002\169\000\000\000\000\000\000\000\000\000\000\002\169\002\169\002\169\011F\002\169\000\000\002\169\000\000\000\000\000\000\000\000\000\000\002\169\002\169\002\169\002\169\002\169\000\000\000\000\000\000\000\000\002\169\000\000\002\169\002\169\000\000\000\000\000\000\000\000\002\169\002\169\002\169\000\000\000\000\000\000\000\000\000\000\000\000\002\169\002\169\n\222\011^\002\169\002\169\002\169\002\169\002\169\000\000\000\000\002\169\000\000\002\169\002\169\002\169\000\000\000\000\000\000\000\000\000\000\000\000\002\169\002\169\002\169\000\000\002\169\002\169\002\169\002\169\000\000\000\000\000\000\000\000\000\000\002\169\000\000\002\169\002\169\000\000\002\169\002\169\002\169\002\169\002\169\002\169\000\000\000\000\002\169\002\169\002\169\000\000\000\000\000\000\000\000\002\169\002\169\002\169\002\169\002\165\000\000\000\000\000\000\002\165\000\000\000\000\002\165\000\000\000\000\002\165\000\000\002\165\000\000\000\000\002\165\000\000\002\165\002\165\002\165\000\000\002\165\002\165\002\165\000\000\000\000\000\000\000\000\000\000\002\165\002\165\002\165\002\165\002\165\000\000\002\165\000\000\000\000\000\000\000\000\000\000\002\165\002\165\002\165\002\165\002\165\000\000\000\000\000\000\000\000\002\165\000\000\002\165\002\165\000\000\000\000\000\000\000\000\002\165\002\165\002\165\000\000\000\000\000\000\000\000\000\000\000\000\002\165\002\165\002\165\002\165\002\165\002\165\002\165\002\165\002\165\000\000\000\000\002\165\000\000\002\165\002\165\002\165\000\000\000\000\000\000\000\000\000\000\000\000\002\165\002\165\002\165\000\000\002\165\002\165\002\165\002\165\000\000\000\000\000\000\000\000\000\000\002\165\000\000\002\165\002\165\000\000\tF\002\165\002\165\002\165\002\165\002\165\000\000\000\000\002\165\002\165\tZ\000\000\000\000\000\000\000\000\002\165\002\165\002\165\002\165\002\161\000\000\000\000\000\000\002\161\000\000\000\000\002\161\000\000\000\000\002\161\000\000\002\161\000\000\000\000\n\198\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\002\161\002\161\002\161\011F\002\161\000\000\002\161\000\000\000\000\000\000\000\000\000\000\002\161\002\161\002\161\002\161\002\161\000\000\000\000\000\000\000\000\002\161\000\000\002\161\002\161\000\000\000\000\000\000\000\000\002\161\002\161\002\161\000\000\000\000\000\000\000\000\000\000\000\000\002\161\002\161\n\222\011^\002\161\002\161\002\161\002\161\002\161\000\000\000\000\002\161\000\000\002\161\002\161\002\161\000\000\000\000\000\000\000\000\000\000\000\000\002\161\002\161\002\161\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\002\161\002\161\002\161\002\161\002\161\002\161\000\000\000\000\002\161\002\161\002\161\000\000\000\000\000\000\000\000\002\161\002\161\002\161\002\161\002\245\000\000\000\000\000\000\002\245\000\000\000\000\002\245\000\000\000\000\002\245\000\000\002\245\000\000\000\000\002\245\000\000\002\245\002\245\002\245\000\000\002\245\002\245\002\245\000\000\000\000\000\000\000\000\000\000\002\245\002\245\002\245\002\245\002\245\000\000\002\245\000\000\000\000\000\000\000\000\000\000\002\245\002\245\002\245\002\245\002\245\000\000\000\000\000\000\000\000\002\245\000\000\002\245\002\245\000\000\000\000\000\000\000\000\002\245\002\245\002\245\000\000\000\000\000\000\000\000\000\000\000\000\002\245\002\245\002\245\002\245\002\245\002\245\002\245\002\245\002\245\000\000\000\000\002\245\000\000\002\245\002\245\002\245\000\000\000\000\000\000\000\000\000\000\000\000\002\245\002\245\002\245\000\000\002\245\002\245\002\245\002\245\000\000\000\000\000\000\000\000\000\000\002\245\000\000\002\245\002\245\000\000\tF\002\245\002\245\002\245\002\245\002\245\000\000\000\000\002\245\002\245\tZ\000\000\000\000\000\000\000\000\002\245\002\245\002\245\002\245\002\241\000\000\000\000\000\000\002\241\000\000\000\000\002\241\000\000\000\000\002\241\000\000\002\241\000\000\000\000\n\198\000\000\002\241\002\241\002\241\000\000\002\241\002\241\002\241\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\002\241\000\000\000\000\000\000\000\000\000\000\002\241\002\241\011\190\011\214\002\241\000\000\000\000\000\000\000\000\002\241\000\000\011\238\002\241\000\000\000\000\000\000\000\000\002\241\002\241\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\241\002\241\n\222\011^\012\006\012\030\012N\002\241\002\241\000\000\000\000\002\241\000\000\002\241\002\241\012f\000\000\000\000\000\000\000\000\000\000\000\000\002\241\002\241\012~\000\000\002\241\002\241\002\241\002\241\000\000\000\000\000\000\000\000\000\000\002\241\000\000\002\241\002\241\000\000\002\241\002\241\002\241\0126\002\241\002\241\000\000\000\000\002\241\012\150\002\241\000\000\000\000\000\000\000\000\002\241\002\241\012\174\012\198\002\197\000\000\000\000\000\000\002\197\000\000\000\000\002\197\000\000\000\000\002\197\000\000\002\197\000\000\000\000\002\197\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\002\197\002\197\002\197\002\197\002\197\000\000\002\197\000\000\000\000\000\000\000\000\000\000\002\197\002\197\002\197\002\197\002\197\000\000\000\000\000\000\000\000\002\197\000\000\002\197\002\197\000\000\000\000\000\000\000\000\002\197\002\197\002\197\000\000\000\000\000\000\000\000\000\000\000\000\002\197\002\197\002\197\002\197\002\197\002\197\002\197\002\197\002\197\000\000\000\000\002\197\000\000\002\197\002\197\002\197\000\000\000\000\000\000\000\000\000\000\000\000\002\197\002\197\002\197\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\tF\002\197\002\197\002\197\002\197\002\197\000\000\000\000\002\197\002\197\tZ\000\000\000\000\000\000\000\000\002\197\002\197\002\197\002\197\002\193\000\000\000\000\000\000\002\193\000\000\000\000\002\193\000\000\000\000\002\193\000\000\002\193\000\000\000\000\n\198\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\002\193\002\193\002\193\011F\002\193\000\000\002\193\000\000\000\000\000\000\000\000\000\000\002\193\002\193\002\193\002\193\002\193\000\000\000\000\000\000\000\000\002\193\000\000\002\193\002\193\000\000\000\000\000\000\000\000\002\193\002\193\002\193\000\000\000\000\000\000\000\000\000\000\000\000\002\193\002\193\n\222\011^\002\193\002\193\002\193\002\193\002\193\000\000\000\000\002\193\000\000\002\193\002\193\002\193\000\000\000\000\000\000\000\000\000\000\000\000\002\193\002\193\002\193\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\002\193\002\193\002\193\002\193\002\193\002\193\000\000\000\000\002\193\002\193\002\193\000\000\000\000\000\000\000\000\002\193\002\193\002\193\002\193\002\189\000\000\000\000\000\000\002\189\000\000\000\000\002\189\000\000\000\000\002\189\000\000\002\189\000\000\000\000\002\189\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\002\189\002\189\002\189\002\189\002\189\000\000\002\189\000\000\000\000\000\000\000\000\000\000\002\189\002\189\002\189\002\189\002\189\000\000\000\000\000\000\000\000\002\189\000\000\002\189\002\189\000\000\000\000\000\000\000\000\002\189\002\189\002\189\000\000\000\000\000\000\000\000\000\000\000\000\002\189\002\189\002\189\002\189\002\189\002\189\002\189\002\189\002\189\000\000\000\000\002\189\000\000\002\189\002\189\002\189\000\000\000\000\000\000\000\000\000\000\000\000\002\189\002\189\002\189\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\tF\002\189\002\189\002\189\002\189\002\189\000\000\000\000\002\189\002\189\tZ\000\000\000\000\000\000\000\000\002\189\002\189\002\189\002\189\002\185\000\000\000\000\000\000\002\185\000\000\000\000\002\185\000\000\000\000\002\185\000\000\002\185\000\000\000\000\n\198\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\002\185\002\185\002\185\011F\002\185\000\000\002\185\000\000\000\000\000\000\000\000\000\000\002\185\002\185\002\185\002\185\002\185\000\000\000\000\000\000\000\000\002\185\000\000\002\185\002\185\000\000\000\000\000\000\000\000\002\185\002\185\002\185\000\000\000\000\000\000\000\000\000\000\000\000\002\185\002\185\n\222\011^\002\185\002\185\002\185\002\185\002\185\000\000\000\000\002\185\000\000\002\185\002\185\002\185\000\000\000\000\000\000\000\000\000\000\000\000\002\185\002\185\002\185\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\002\185\002\185\002\185\002\185\002\185\002\185\000\000\000\000\002\185\002\185\002\185\000\000\000\000\000\000\000\000\002\185\002\185\002\185\002\185\002\229\000\000\000\000\000\000\002\229\000\000\000\000\002\229\000\000\000\000\002\229\000\000\002\229\000\000\000\000\002\229\000\000\002\229\002\229\002\229\000\000\002\229\002\229\002\229\000\000\000\000\000\000\000\000\000\000\002\229\002\229\002\229\002\229\002\229\000\000\002\229\000\000\000\000\000\000\000\000\000\000\002\229\002\229\002\229\002\229\002\229\000\000\000\000\000\000\000\000\002\229\000\000\002\229\002\229\000\000\000\000\000\000\000\000\002\229\002\229\002\229\000\000\000\000\000\000\000\000\000\000\000\000\002\229\002\229\002\229\002\229\002\229\002\229\002\229\002\229\002\229\000\000\000\000\002\229\000\000\002\229\002\229\002\229\000\000\000\000\000\000\000\000\000\000\000\000\002\229\002\229\002\229\000\000\002\229\002\229\002\229\002\229\000\000\000\000\000\000\000\000\000\000\002\229\000\000\002\229\002\229\000\000\tF\002\229\002\229\002\229\002\229\002\229\000\000\000\000\002\229\002\229\tZ\000\000\000\000\000\000\000\000\002\229\002\229\002\229\002\229\002\225\000\000\000\000\000\000\002\225\000\000\000\000\002\225\000\000\000\000\002\225\000\000\002\225\000\000\000\000\n\198\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\011.\011v\011\142\011F\002\225\000\000\002\225\000\000\000\000\000\000\000\000\000\000\002\225\002\225\011\190\011\214\002\225\000\000\000\000\000\000\000\000\002\225\000\000\002\225\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\n\222\011^\012\006\012\030\002\225\002\225\002\225\000\000\000\000\002\225\000\000\002\225\002\225\002\225\000\000\000\000\000\000\000\000\000\000\000\000\002\225\002\225\002\225\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\002\225\002\225\002\225\0126\002\225\002\225\000\000\000\000\002\225\002\225\002\225\000\000\000\000\000\000\000\000\002\225\002\225\002\225\002\225\002\141\000\000\000\000\000\000\002\141\000\000\000\000\002\141\000\000\000\000\002\141\000\000\002\141\000\000\000\000\002\141\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\002\141\002\141\002\141\002\141\002\141\000\000\002\141\000\000\000\000\000\000\000\000\000\000\002\141\002\141\002\141\002\141\002\141\000\000\000\000\000\000\000\000\002\141\000\000\002\141\002\141\000\000\000\000\000\000\000\000\002\141\002\141\002\141\000\000\000\000\000\000\000\000\000\000\000\000\002\141\002\141\002\141\002\141\002\141\002\141\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\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\tF\002\141\002\141\002\141\002\141\002\141\000\000\000\000\002\141\002\141\tZ\000\000\000\000\000\000\000\000\002\141\002\141\002\141\002\141\002\137\000\000\000\000\000\000\002\137\000\000\000\000\002\137\000\000\000\000\002\137\000\000\002\137\000\000\000\000\n\198\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\002\137\002\137\002\137\011F\002\137\000\000\002\137\000\000\000\000\000\000\000\000\000\000\002\137\002\137\002\137\002\137\002\137\000\000\000\000\000\000\000\000\002\137\000\000\002\137\002\137\000\000\000\000\000\000\000\000\002\137\002\137\002\137\000\000\000\000\000\000\000\000\000\000\000\000\002\137\002\137\n\222\011^\002\137\002\137\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\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\002\137\002\137\002\137\000\000\000\000\002\137\002\137\002\137\000\000\000\000\000\000\000\000\002\137\002\137\002\137\002\137\002\133\000\000\000\000\000\000\002\133\000\000\000\000\002\133\000\000\000\000\002\133\000\000\002\133\000\000\000\000\002\133\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\002\133\002\133\002\133\002\133\002\133\000\000\002\133\000\000\000\000\000\000\000\000\000\000\002\133\002\133\002\133\002\133\002\133\000\000\000\000\000\000\000\000\002\133\000\000\002\133\002\133\000\000\000\000\000\000\000\000\002\133\002\133\002\133\000\000\000\000\000\000\000\000\000\000\000\000\002\133\002\133\002\133\002\133\002\133\002\133\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\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\tF\002\133\002\133\002\133\002\133\002\133\000\000\000\000\002\133\002\133\tZ\000\000\000\000\000\000\000\000\002\133\002\133\002\133\002\133\002\129\000\000\000\000\000\000\002\129\000\000\000\000\002\129\000\000\000\000\002\129\000\000\002\129\000\000\000\000\n\198\000\000\002\129\002\129\002\129\000\000\002\129\002\129\002\129\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\002\129\000\000\002\129\000\000\000\000\000\000\000\000\000\000\002\129\002\129\011\190\011\214\002\129\000\000\000\000\000\000\000\000\002\129\000\000\002\129\002\129\000\000\000\000\000\000\000\000\002\129\002\129\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\129\002\129\n\222\011^\012\006\012\030\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\002\129\002\129\000\000\002\129\002\129\002\129\002\129\000\000\000\000\000\000\000\000\000\000\002\129\000\000\002\129\002\129\000\000\002\129\002\129\002\129\0126\002\129\002\129\000\000\000\000\002\129\002\129\002\129\000\000\000\000\000\000\000\000\002\129\002\129\002\129\002\129\0035\000\000\000\000\000\000\0035\000\000\000\000\0035\000\000\000\000\0035\000\000\0035\000\000\000\000\0035\000\000\0035\0035\0035\000\000\0035\0035\0035\000\000\000\000\000\000\000\000\000\000\0035\0035\0035\0035\0035\000\000\0035\000\000\000\000\000\000\000\000\000\000\0035\0035\0035\0035\0035\000\000\000\000\000\000\000\000\0035\000\000\0035\0035\000\000\000\000\000\000\000\000\0035\0035\0035\000\000\000\000\000\000\000\000\000\000\000\000\0035\0035\0035\0035\0035\0035\0035\0035\0035\000\000\000\000\0035\000\000\0035\0035\0035\000\000\000\000\000\000\000\000\000\000\000\000\0035\0035\0035\000\000\0035\0035\0035\0035\000\000\000\000\000\000\000\000\000\000\0035\000\000\0035\0035\000\000\tF\0035\0035\0035\0035\0035\000\000\000\000\0035\0035\tZ\000\000\000\000\000\000\000\000\0035\0035\0035\0035\0031\000\000\000\000\000\000\0031\000\000\000\000\0031\000\000\000\000\0031\000\000\0031\000\000\000\000\n\198\000\000\0031\0031\0031\000\000\0031\0031\0031\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\0031\000\000\0031\000\000\000\000\000\000\000\000\000\000\0031\0031\011\190\011\214\0031\000\000\000\000\000\000\000\000\0031\000\000\0031\0031\000\000\000\000\000\000\000\000\0031\0031\0031\000\000\000\000\000\000\000\000\000\000\000\000\0031\0031\n\222\011^\012\006\0031\0031\0031\0031\000\000\000\000\0031\000\000\0031\0031\0031\000\000\000\000\000\000\000\000\000\000\000\000\0031\0031\0031\000\000\0031\0031\0031\0031\000\000\000\000\000\000\000\000\000\000\0031\000\000\0031\0031\000\000\0031\0031\0031\0126\0031\0031\000\000\000\000\0031\0031\0031\000\000\000\000\000\000\000\000\0031\0031\0031\0031\002}\000\000\000\000\000\000\002}\000\000\000\000\002}\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}\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}\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\tF\002}\002}\002}\002}\002}\000\000\000\000\002}\002}\tZ\000\000\000\000\000\000\000\000\002}\002}\002}\002}\002y\000\000\000\000\000\000\002y\000\000\000\000\002y\000\000\000\000\002y\000\000\002y\000\000\000\000\n\198\000\000\002y\002y\002y\000\000\002y\002y\002y\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\002y\000\000\002y\000\000\000\000\000\000\000\000\000\000\002y\002y\011\190\011\214\002y\000\000\000\000\000\000\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\n\222\011^\012\006\012\030\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\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\0126\002y\002y\000\000\000\000\002y\002y\002y\000\000\000\000\000\000\000\000\002y\002y\002y\002y\002\237\000\000\000\000\000\000\002\237\000\000\000\000\002\237\000\000\000\000\002\237\000\000\002\237\000\000\000\000\002\237\000\000\002\237\002\237\002\237\000\000\002\237\002\237\002\237\000\000\000\000\000\000\000\000\000\000\002\237\002\237\002\237\002\237\002\237\000\000\002\237\000\000\000\000\000\000\000\000\000\000\002\237\002\237\002\237\002\237\002\237\000\000\000\000\000\000\000\000\002\237\000\000\002\237\002\237\000\000\000\000\000\000\000\000\002\237\002\237\002\237\000\000\000\000\000\000\000\000\000\000\000\000\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\002\237\000\000\000\000\002\237\000\000\002\237\002\237\002\237\000\000\000\000\000\000\000\000\000\000\000\000\002\237\002\237\002\237\000\000\002\237\002\237\002\237\002\237\000\000\000\000\000\000\000\000\000\000\002\237\000\000\002\237\002\237\000\000\tF\002\237\002\237\002\237\002\237\002\237\000\000\000\000\002\237\002\237\tZ\000\000\000\000\000\000\000\000\002\237\002\237\002\237\002\237\002\233\000\000\000\000\000\000\002\233\000\000\000\000\002\233\000\000\000\000\002\233\000\000\002\233\000\000\000\000\n\198\000\000\002\233\002\233\002\233\000\000\002\233\002\233\002\233\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\002\233\000\000\002\233\000\000\000\000\000\000\000\000\000\000\002\233\002\233\011\190\011\214\002\233\000\000\000\000\000\000\000\000\002\233\000\000\002\233\002\233\000\000\000\000\000\000\000\000\002\233\002\233\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\233\002\233\n\222\011^\012\006\012\030\002\233\002\233\002\233\000\000\000\000\002\233\000\000\002\233\002\233\002\233\000\000\000\000\000\000\000\000\000\000\000\000\002\233\002\233\002\233\000\000\002\233\002\233\002\233\002\233\000\000\000\000\000\000\000\000\000\000\002\233\000\000\002\233\002\233\000\000\002\233\002\233\002\233\0126\002\233\002\233\000\000\000\000\002\233\002\233\002\233\000\000\000\000\000\000\000\000\002\233\002\233\002\233\002\233\002\221\000\000\000\000\000\000\002\221\000\000\000\000\002\221\000\000\000\000\002\221\000\000\002\221\000\000\000\000\002\221\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\002\221\002\221\002\221\002\221\002\221\000\000\002\221\000\000\000\000\000\000\000\000\000\000\002\221\002\221\002\221\002\221\002\221\000\000\000\000\000\000\000\000\002\221\000\000\002\221\002\221\000\000\000\000\000\000\000\000\002\221\002\221\002\221\000\000\000\000\000\000\000\000\000\000\000\000\002\221\002\221\002\221\002\221\002\221\002\221\002\221\002\221\002\221\000\000\000\000\002\221\000\000\002\221\002\221\002\221\000\000\000\000\000\000\000\000\000\000\000\000\002\221\002\221\002\221\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\tF\002\221\002\221\002\221\002\221\002\221\000\000\000\000\002\221\002\221\tZ\000\000\000\000\000\000\000\000\002\221\002\221\002\221\002\221\002\217\000\000\000\000\000\000\002\217\000\000\000\000\002\217\000\000\000\000\002\217\000\000\002\217\000\000\000\000\n\198\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\011.\011v\011\142\011F\002\217\000\000\002\217\000\000\000\000\000\000\000\000\000\000\002\217\002\217\011\190\011\214\002\217\000\000\000\000\000\000\000\000\002\217\000\000\002\217\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\n\222\011^\012\006\012\030\002\217\002\217\002\217\000\000\000\000\002\217\000\000\002\217\002\217\002\217\000\000\000\000\000\000\000\000\000\000\000\000\002\217\002\217\002\217\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\002\217\002\217\002\217\0126\002\217\002\217\000\000\000\000\002\217\002\217\002\217\000\000\000\000\000\000\000\000\002\217\002\217\002\217\002\217\002\253\000\000\000\000\000\000\002\253\000\000\000\000\002\253\000\000\000\000\002\253\000\000\002\253\000\000\000\000\002\253\000\000\002\253\002\253\002\253\000\000\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\002\253\002\253\002\253\002\253\002\253\000\000\002\253\000\000\000\000\000\000\000\000\000\000\002\253\002\253\002\253\002\253\002\253\000\000\000\000\000\000\000\000\002\253\000\000\002\253\002\253\000\000\000\000\000\000\000\000\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\000\000\002\253\002\253\002\253\002\253\002\253\002\253\002\253\002\253\002\253\000\000\000\000\002\253\000\000\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\000\000\002\253\002\253\002\253\000\000\002\253\002\253\002\253\002\253\000\000\000\000\000\000\000\000\000\000\002\253\000\000\002\253\002\253\000\000\tF\002\253\002\253\002\253\002\253\002\253\000\000\000\000\002\253\002\253\tZ\000\000\000\000\000\000\000\000\002\253\002\253\002\253\002\253\002\249\000\000\000\000\000\000\002\249\000\000\000\000\002\249\000\000\000\000\002\249\000\000\002\249\000\000\000\000\n\198\000\000\002\249\002\249\002\249\000\000\002\249\002\249\002\249\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\002\249\000\000\000\000\000\000\000\000\000\000\002\249\002\249\011\190\011\214\002\249\000\000\000\000\000\000\000\000\002\249\000\000\011\238\002\249\000\000\000\000\000\000\000\000\002\249\002\249\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002\249\002\249\n\222\011^\012\006\012\030\012N\002\249\002\249\000\000\000\000\002\249\000\000\002\249\002\249\012f\000\000\000\000\000\000\000\000\000\000\000\000\002\249\002\249\012~\000\000\002\249\002\249\002\249\002\249\000\000\000\000\000\000\000\000\000\000\002\249\000\000\002\249\002\249\000\000\002\249\002\249\002\249\0126\002\249\002\249\000\000\000\000\002\249\012\150\002\249\000\000\000\000\000\000\000\000\002\249\002\249\012\174\012\198\003\005\000\000\000\000\000\000\003\005\000\000\000\000\003\005\000\000\000\000\003\005\000\000\003\005\000\000\000\000\003\005\000\000\003\005\003\005\003\005\000\000\003\005\003\005\003\005\000\000\000\000\000\000\000\000\000\000\003\005\003\005\003\005\003\005\003\005\000\000\003\005\000\000\000\000\000\000\000\000\000\000\003\005\003\005\003\005\003\005\003\005\000\000\000\000\000\000\000\000\003\005\000\000\003\005\003\005\000\000\000\000\000\000\000\000\003\005\003\005\003\005\000\000\000\000\000\000\000\000\000\000\000\000\003\005\003\005\003\005\003\005\003\005\003\005\003\005\003\005\003\005\000\000\000\000\003\005\000\000\003\005\003\005\003\005\000\000\000\000\000\000\000\000\000\000\000\000\003\005\003\005\003\005\000\000\003\005\003\005\003\005\003\005\000\000\000\000\000\000\000\000\000\000\003\005\000\000\003\005\003\005\000\000\tF\003\005\003\005\003\005\003\005\003\005\000\000\000\000\003\005\003\005\tZ\000\000\000\000\000\000\000\000\003\005\003\005\003\005\003\005\003\001\000\000\000\000\000\000\003\001\000\000\000\000\003\001\000\000\000\000\003\001\000\000\003\001\000\000\000\000\n\198\000\000\003\001\003\001\003\001\000\000\003\001\003\001\003\001\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\003\001\000\000\003\001\000\000\000\000\000\000\000\000\000\000\003\001\003\001\011\190\011\214\003\001\000\000\000\000\000\000\000\000\003\001\000\000\011\238\003\001\000\000\000\000\000\000\000\000\003\001\003\001\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003\001\003\001\n\222\011^\012\006\012\030\012N\003\001\003\001\000\000\000\000\003\001\000\000\003\001\003\001\012f\000\000\000\000\000\000\000\000\000\000\000\000\003\001\003\001\012~\000\000\003\001\003\001\003\001\003\001\000\000\000\000\000\000\000\000\000\000\003\001\000\000\003\001\003\001\000\000\003\001\003\001\003\001\0126\003\001\003\001\000\000\000\000\003\001\003\001\003\001\000\000\000\000\000\000\000\000\003\001\003\001\012\174\012\198\003\r\000\000\000\000\000\000\003\r\000\000\000\000\003\r\000\000\000\000\003\r\000\000\003\r\000\000\000\000\003\r\000\000\003\r\003\r\003\r\000\000\003\r\003\r\003\r\000\000\000\000\000\000\000\000\000\000\003\r\003\r\003\r\003\r\003\r\000\000\003\r\000\000\000\000\000\000\000\000\000\000\003\r\003\r\003\r\003\r\003\r\000\000\000\000\000\000\000\000\003\r\000\000\003\r\003\r\000\000\000\000\000\000\000\000\003\r\003\r\003\r\000\000\000\000\000\000\000\000\000\000\000\000\003\r\003\r\003\r\003\r\003\r\003\r\003\r\003\r\003\r\000\000\000\000\003\r\000\000\003\r\003\r\003\r\000\000\000\000\000\000\000\000\000\000\000\000\003\r\003\r\003\r\000\000\003\r\003\r\003\r\003\r\000\000\000\000\000\000\000\000\000\000\003\r\000\000\003\r\003\r\000\000\tF\003\r\003\r\003\r\003\r\003\r\000\000\000\000\003\r\003\r\tZ\000\000\000\000\000\000\000\000\003\r\003\r\003\r\003\r\003\t\000\000\000\000\000\000\003\t\000\000\000\000\003\t\000\000\000\000\003\t\000\000\003\t\000\000\000\000\n\198\000\000\003\t\003\t\003\t\000\000\003\t\003\t\003\t\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\003\t\000\000\003\t\000\000\000\000\000\000\000\000\000\000\003\t\003\t\011\190\011\214\003\t\000\000\000\000\000\000\000\000\003\t\000\000\011\238\003\t\000\000\000\000\000\000\000\000\003\t\003\t\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003\t\003\t\n\222\011^\012\006\012\030\012N\003\t\003\t\000\000\000\000\003\t\000\000\003\t\003\t\012f\000\000\000\000\000\000\000\000\000\000\000\000\003\t\003\t\012~\000\000\003\t\003\t\003\t\003\t\000\000\000\000\000\000\000\000\000\000\003\t\000\000\003\t\003\t\000\000\003\t\003\t\003\t\0126\003\t\003\t\000\000\000\000\003\t\003\t\003\t\000\000\000\000\000\000\000\000\003\t\003\t\012\174\012\198\t\149\000\000\000\000\000\000\t\149\000\000\000\000\t\149\000\000\000\000\t\149\000\000\t\149\000\000\000\000\t\149\000\000\t\149\t\149\t\149\000\000\t\149\t\149\t\149\000\000\000\000\000\000\000\000\000\000\t\149\t\149\t\149\t\149\t\149\000\000\t\149\000\000\000\000\000\000\000\000\000\000\t\149\t\149\t\149\t\149\t\149\000\000\000\000\000\000\000\000\t\149\000\000\t\149\t\149\000\000\000\000\000\000\000\000\t\149\t\149\t\149\000\000\000\000\000\000\000\000\000\000\000\000\t\149\t\149\t\149\t\149\t\149\t\149\t\149\t\149\t\149\000\000\000\000\t\149\000\000\t\149\t\149\t\149\000\000\000\000\000\000\000\000\000\000\000\000\t\149\t\149\t\149\000\000\t\149\t\149\t\149\t\149\000\000\000\000\000\000\000\000\000\000\t\149\000\000\t\149\t\149\000\000\tF\t\149\t\149\t\149\t\149\t\149\000\000\000\000\t\149\t\149\tZ\000\000\000\000\000\000\000\000\t\149\t\149\t\149\t\149\t\145\000\000\000\000\000\000\t\145\000\000\000\000\t\145\000\000\000\000\t\145\000\000\t\145\000\000\000\000\n\198\000\000\t\145\t\145\t\145\000\000\t\145\t\145\t\145\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\t\145\000\000\000\000\000\000\000\000\000\000\t\145\t\145\011\190\011\214\t\145\000\000\000\000\000\000\000\000\t\145\000\000\011\238\t\145\000\000\000\000\000\000\000\000\t\145\t\145\000\238\000\000\000\000\000\000\000\000\000\000\000\000\t\145\t\145\n\222\011^\012\006\012\030\012N\t\145\t\145\000\000\000\000\t\145\000\000\t\145\t\145\012f\000\000\000\000\000\000\000\000\000\000\000\000\t\145\t\145\012~\000\000\t\145\t\145\t\145\t\145\000\000\000\000\000\000\000\000\000\000\t\145\000\000\t\145\t\145\000\000\t\145\t\145\t\145\0126\t\145\t\145\000\000\000\000\t\145\012\150\t\145\000\000\000\000\000\000\000\000\t\145\t\145\012\174\012\198\003\021\000\000\000\000\000\000\003\021\000\000\000\000\003\021\000\000\000\000\003\021\000\000\003\021\000\000\000\000\003\021\000\000\003\021\003\021\003\021\000\000\003\021\003\021\003\021\000\000\000\000\000\000\000\000\000\000\003\021\003\021\003\021\003\021\003\021\000\000\003\021\000\000\000\000\000\000\000\000\000\000\003\021\003\021\003\021\003\021\003\021\000\000\000\000\000\000\000\000\003\021\000\000\003\021\003\021\000\000\000\000\000\000\000\000\003\021\003\021\003\021\000\000\000\000\000\000\000\000\000\000\000\000\003\021\003\021\003\021\003\021\003\021\003\021\003\021\003\021\003\021\000\000\000\000\003\021\000\000\003\021\003\021\003\021\000\000\000\000\000\000\000\000\000\000\000\000\003\021\003\021\003\021\000\000\003\021\003\021\003\021\003\021\000\000\000\000\000\000\000\000\000\000\003\021\000\000\003\021\003\021\000\000\tF\003\021\003\021\003\021\003\021\003\021\000\000\000\000\003\021\003\021\tZ\000\000\000\000\000\000\000\000\003\021\003\021\003\021\003\021\003\017\000\000\000\000\000\000\003\017\000\000\000\000\003\017\000\000\000\000\003\017\000\000\003\017\000\000\000\000\n\198\000\000\003\017\003\017\003\017\000\000\003\017\003\017\003\017\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003\017\000\000\000\000\000\000\000\000\000\000\003\017\003\017\011\190\011\214\003\017\000\000\000\000\000\000\000\000\003\017\000\000\011\238\003\017\000\000\000\000\000\000\000\000\003\017\003\017\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003\017\003\017\n\222\011^\012\006\012\030\012N\003\017\003\017\000\000\000\000\003\017\000\000\003\017\003\017\012f\000\000\000\000\000\000\000\000\000\000\000\000\003\017\003\017\012~\000\000\003\017\003\017\003\017\003\017\000\000\000\000\000\000\000\000\000\000\003\017\000\000\003\017\003\017\000\000\012\222\003\017\012\246\0126\003\017\003\017\000\000\000\000\003\017\012\150\003\017\000\000\000\000\000\000\000\000\003\017\003\017\012\174\012\198\t\137\000\000\000\000\000\000\t\137\000\000\000\000\t\137\000\000\000\000\t\137\000\000\t\137\000\000\000\000\n\198\000\000\t\137\t\137\t\137\000\000\t\137\t\137\t\137\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\t\137\000\000\000\000\000\000\000\000\000\000\t\137\t\137\011\190\011\214\t\137\000\000\000\000\000\000\000\000\t\137\000\000\011\238\t\137\000\000\000\000\000\000\000\000\t\137\t\137\000\238\000\000\000\000\000\000\000\000\000\000\000\000\t\137\t\137\n\222\011^\012\006\012\030\012N\t\137\t\137\000\000\000\000\t\137\000\000\t\137\t\137\012f\000\000\000\000\000\000\000\000\000\000\000\000\t\137\t\137\012~\000\000\t\137\t\137\t\137\t\137\000\000\000\000\000\000\000\000\000\000\t\137\000\000\t\137\t\137\000\000\t\137\t\137\t\137\0126\t\137\t\137\000\000\000\000\t\137\012\150\t\137\000\000\000\000\000\000\000\000\t\137\t\137\012\174\012\198\003e\000\000\000\000\000\000\003e\000\000\000\000\003e\000\000\000\000\003e\000\000\003e\000\000\000\000\003e\000\000\003e\003e\003e\000\000\003e\003e\003e\000\000\000\000\000\000\000\000\000\000\003e\003e\003e\003e\003e\000\000\003e\000\000\000\000\000\000\000\000\000\000\003e\003e\003e\003e\003e\000\000\000\000\000\000\000\000\003e\000\000\003e\003e\000\000\000\000\000\000\000\000\003e\003e\003e\000\000\000\000\000\000\000\000\000\000\000\000\003e\003e\003e\003e\003e\003e\003e\003e\003e\000\000\000\000\003e\000\000\003e\003e\003e\000\000\000\000\000\000\000\000\000\000\000\000\003e\003e\003e\000\000\003e\003e\003e\003e\000\000\000\000\000\000\000\000\000\000\003e\000\000\003e\003e\000\000\tF\003e\003e\003e\003e\003e\000\000\000\000\003e\003e\tZ\000\000\000\000\000\000\000\000\003e\003e\003e\003e\003a\000\000\000\000\000\000\003a\000\000\000\000\003a\000\000\000\000\003a\000\000\003a\000\000\000\000\n\198\000\000\003a\003a\003a\000\000\003a\003a\003a\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003a\000\000\000\000\000\000\000\000\000\000\003a\003a\011\190\011\214\003a\000\000\000\000\000\000\000\000\003a\000\000\011\238\003a\000\000\000\000\000\000\000\000\003a\003a\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003a\003a\n\222\011^\012\006\012\030\012N\003a\003a\000\000\000\000\003a\000\000\003a\003a\012f\000\000\000\000\000\000\000\000\000\000\000\000\003a\003a\012~\000\000\003a\003a\003a\003a\000\000\000\000\000\000\000\000\000\000\003a\000\000\003a\003a\000\000\012\222\003a\012\246\0126\003a\003a\000\000\000\000\003a\012\150\003a\000\000\000\000\000\000\000\000\003a\003a\012\174\012\198\003\133\000\000\000\000\000\000\003\133\000\000\000\000\003\133\000\000\000\000\003\133\000\000\003\133\000\000\000\000\003\133\000\000\003\133\003\133\003\133\000\000\003\133\003\133\003\133\000\000\000\000\000\000\000\000\000\000\003\133\003\133\003\133\003\133\003\133\000\000\003\133\000\000\000\000\000\000\000\000\000\000\003\133\003\133\003\133\003\133\003\133\000\000\000\000\000\000\000\000\003\133\000\000\003\133\003\133\000\000\000\000\000\000\000\000\003\133\003\133\003\133\000\000\000\000\000\000\000\000\000\000\000\000\003\133\003\133\003\133\003\133\003\133\003\133\003\133\003\133\003\133\000\000\000\000\003\133\000\000\003\133\003\133\003\133\000\000\000\000\000\000\000\000\000\000\000\000\003\133\003\133\003\133\000\000\003\133\003\133\003\133\003\133\000\000\000\000\000\000\000\000\000\000\003\133\000\000\003\133\003\133\000\000\tF\003\133\003\133\003\133\003\133\003\133\000\000\000\000\003\133\003\133\tZ\000\000\000\000\000\000\000\000\003\133\003\133\003\133\003\133\003\129\000\000\000\000\000\000\003\129\000\000\000\000\003\129\000\000\000\000\003\129\000\000\003\129\000\000\000\000\n\198\000\000\003\129\003\129\003\129\000\000\003\129\003\129\003\129\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003\129\000\000\000\000\000\000\000\000\000\000\003\129\003\129\011\190\011\214\003\129\000\000\000\000\000\000\000\000\003\129\000\000\011\238\003\129\000\000\000\000\000\000\000\000\003\129\003\129\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003\129\003\129\n\222\011^\012\006\012\030\012N\003\129\003\129\000\000\000\000\003\129\000\000\003\129\003\129\012f\000\000\000\000\000\000\000\000\000\000\000\000\003\129\003\129\012~\000\000\003\129\003\129\003\129\003\129\000\000\000\000\000\000\000\000\000\000\003\129\000\000\003\129\003\129\000\000\012\222\003\129\012\246\0126\003\129\003\129\000\000\000\000\003\129\012\150\003\129\000\000\000\000\000\000\000\000\003\129\003\129\012\174\012\198\003u\000\000\000\000\000\000\003u\000\000\000\000\003u\000\000\000\000\003u\000\000\003u\000\000\000\000\003u\000\000\003u\003u\003u\000\000\003u\003u\003u\000\000\000\000\000\000\000\000\000\000\003u\003u\003u\003u\003u\000\000\003u\000\000\000\000\000\000\000\000\000\000\003u\003u\003u\003u\003u\000\000\000\000\000\000\000\000\003u\000\000\003u\003u\000\000\000\000\000\000\000\000\003u\003u\003u\000\000\000\000\000\000\000\000\000\000\000\000\003u\003u\003u\003u\003u\003u\003u\003u\003u\000\000\000\000\003u\000\000\003u\003u\003u\000\000\000\000\000\000\000\000\000\000\000\000\003u\003u\003u\000\000\003u\003u\003u\003u\000\000\000\000\000\000\000\000\000\000\003u\000\000\003u\003u\000\000\tF\003u\003u\003u\003u\003u\000\000\000\000\003u\003u\tZ\000\000\000\000\000\000\000\000\003u\003u\003u\003u\003q\000\000\000\000\000\000\003q\000\000\000\000\003q\000\000\000\000\003q\000\000\003q\000\000\000\000\n\198\000\000\003q\003q\003q\000\000\003q\003q\003q\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003q\000\000\000\000\000\000\000\000\000\000\003q\003q\011\190\011\214\003q\000\000\000\000\000\000\000\000\003q\000\000\011\238\003q\000\000\000\000\000\000\000\000\003q\003q\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003q\003q\n\222\011^\012\006\012\030\012N\003q\003q\000\000\000\000\003q\000\000\003q\003q\012f\000\000\000\000\000\000\000\000\000\000\000\000\003q\003q\012~\000\000\003q\003q\003q\003q\000\000\000\000\000\000\000\000\000\000\003q\000\000\003q\003q\000\000\012\222\003q\012\246\0126\003q\003q\000\000\000\000\003q\012\150\003q\000\000\000\000\000\000\000\000\003q\003q\012\174\012\198\003M\000\000\000\000\000\000\003M\000\000\000\000\003M\000\000\000\000\003M\000\000\003M\000\000\000\000\003M\000\000\003M\003M\003M\000\000\003M\003M\003M\000\000\000\000\000\000\000\000\000\000\003M\003M\003M\003M\003M\000\000\003M\000\000\000\000\000\000\000\000\000\000\003M\003M\003M\003M\003M\000\000\000\000\000\000\000\000\003M\000\000\003M\003M\000\000\000\000\000\000\000\000\003M\003M\003M\000\000\000\000\000\000\000\000\000\000\000\000\003M\003M\003M\003M\003M\003M\003M\003M\003M\000\000\000\000\003M\000\000\003M\003M\003M\000\000\000\000\000\000\000\000\000\000\000\000\003M\003M\003M\000\000\003M\003M\003M\003M\000\000\000\000\000\000\000\000\000\000\003M\000\000\003M\003M\000\000\tF\003M\003M\003M\003M\003M\000\000\000\000\003M\003M\tZ\000\000\000\000\000\000\000\000\003M\003M\003M\003M\003I\000\000\000\000\000\000\003I\000\000\000\000\003I\000\000\000\000\003I\000\000\003I\000\000\000\000\n\198\000\000\003I\003I\003I\000\000\003I\003I\003I\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003I\000\000\000\000\000\000\000\000\000\000\003I\003I\011\190\011\214\003I\000\000\000\000\000\000\000\000\003I\000\000\011\238\003I\000\000\000\000\000\000\000\000\003I\003I\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003I\003I\n\222\011^\012\006\012\030\012N\003I\003I\000\000\000\000\003I\000\000\003I\003I\012f\000\000\000\000\000\000\000\000\000\000\000\000\003I\003I\012~\000\000\003I\003I\003I\003I\000\000\000\000\000\000\000\000\000\000\003I\000\000\003I\003I\000\000\012\222\003I\012\246\0126\003I\003I\000\000\000\000\003I\012\150\003I\000\000\000\000\000\000\000\000\003I\003I\012\174\012\198\003]\000\000\000\000\000\000\003]\000\000\000\000\003]\000\000\000\000\003]\000\000\003]\000\000\000\000\003]\000\000\003]\003]\003]\000\000\003]\003]\003]\000\000\000\000\000\000\000\000\000\000\003]\003]\003]\003]\003]\000\000\003]\000\000\000\000\000\000\000\000\000\000\003]\003]\003]\003]\003]\000\000\000\000\000\000\000\000\003]\000\000\003]\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]\003]\003]\003]\003]\003]\003]\003]\000\000\000\000\003]\000\000\003]\003]\003]\000\000\000\000\000\000\000\000\000\000\000\000\003]\003]\003]\000\000\003]\003]\003]\003]\000\000\000\000\000\000\000\000\000\000\003]\000\000\003]\003]\000\000\tF\003]\003]\003]\003]\003]\000\000\000\000\003]\003]\tZ\000\000\000\000\000\000\000\000\003]\003]\003]\003]\003Y\000\000\000\000\000\000\003Y\000\000\000\000\003Y\000\000\000\000\003Y\000\000\003Y\000\000\000\000\n\198\000\000\003Y\003Y\003Y\000\000\003Y\003Y\003Y\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003Y\000\000\000\000\000\000\000\000\000\000\003Y\003Y\011\190\011\214\003Y\000\000\000\000\000\000\000\000\003Y\000\000\011\238\003Y\000\000\000\000\000\000\000\000\003Y\003Y\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003Y\003Y\n\222\011^\012\006\012\030\012N\003Y\003Y\000\000\000\000\003Y\000\000\003Y\003Y\012f\000\000\000\000\000\000\000\000\000\000\000\000\003Y\003Y\012~\000\000\003Y\003Y\003Y\003Y\000\000\000\000\000\000\000\000\000\000\003Y\000\000\003Y\003Y\000\000\012\222\003Y\012\246\0126\003Y\003Y\000\000\000\000\003Y\012\150\003Y\000\000\000\000\000\000\000\000\003Y\003Y\012\174\012\198\003U\000\000\000\000\000\000\003U\000\000\000\000\003U\000\000\000\000\003U\000\000\003U\000\000\000\000\003U\000\000\003U\003U\003U\000\000\003U\003U\003U\000\000\000\000\000\000\000\000\000\000\003U\003U\003U\003U\003U\000\000\003U\000\000\000\000\000\000\000\000\000\000\003U\003U\003U\003U\003U\000\000\000\000\000\000\000\000\003U\000\000\003U\003U\000\000\000\000\000\000\000\000\003U\003U\003U\000\000\000\000\000\000\000\000\000\000\000\000\003U\003U\003U\003U\003U\003U\003U\003U\003U\000\000\000\000\003U\000\000\003U\003U\003U\000\000\000\000\000\000\000\000\000\000\000\000\003U\003U\003U\000\000\003U\003U\003U\003U\000\000\000\000\000\000\000\000\000\000\003U\000\000\003U\003U\000\000\tF\003U\003U\003U\003U\003U\000\000\000\000\003U\003U\tZ\000\000\000\000\000\000\000\000\003U\003U\003U\003U\003Q\000\000\000\000\000\000\003Q\000\000\000\000\003Q\000\000\000\000\003Q\000\000\003Q\000\000\000\000\n\198\000\000\003Q\003Q\003Q\000\000\003Q\003Q\003Q\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003Q\000\000\000\000\000\000\000\000\000\000\003Q\003Q\011\190\011\214\003Q\000\000\000\000\000\000\000\000\003Q\000\000\011\238\003Q\000\000\000\000\000\000\000\000\003Q\003Q\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003Q\003Q\n\222\011^\012\006\012\030\012N\003Q\003Q\000\000\000\000\003Q\000\000\003Q\003Q\012f\000\000\000\000\000\000\000\000\000\000\000\000\003Q\003Q\012~\000\000\003Q\003Q\003Q\003Q\000\000\000\000\000\000\000\000\000\000\003Q\000\000\003Q\003Q\000\000\012\222\003Q\012\246\0126\003Q\003Q\000\000\000\000\003Q\012\150\003Q\000\000\000\000\000\000\000\000\003Q\003Q\012\174\012\198\003m\000\000\000\000\000\000\003m\000\000\000\000\003m\000\000\000\000\003m\000\000\003m\000\000\000\000\003m\000\000\003m\003m\003m\000\000\003m\003m\003m\000\000\000\000\000\000\000\000\000\000\003m\003m\003m\003m\003m\000\000\003m\000\000\000\000\000\000\000\000\000\000\003m\003m\003m\003m\003m\000\000\000\000\000\000\000\000\003m\000\000\003m\003m\000\000\000\000\000\000\000\000\003m\003m\003m\000\000\000\000\000\000\000\000\000\000\000\000\003m\003m\003m\003m\003m\003m\003m\003m\003m\000\000\000\000\003m\000\000\003m\003m\003m\000\000\000\000\000\000\000\000\000\000\000\000\003m\003m\003m\000\000\003m\003m\003m\003m\000\000\000\000\000\000\000\000\000\000\003m\000\000\003m\003m\000\000\tF\003m\003m\003m\003m\003m\000\000\000\000\003m\003m\tZ\000\000\000\000\000\000\000\000\003m\003m\003m\003m\003i\000\000\000\000\000\000\003i\000\000\000\000\003i\000\000\000\000\003i\000\000\003i\000\000\000\000\n\198\000\000\003i\003i\003i\000\000\003i\003i\003i\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003i\000\000\000\000\000\000\000\000\000\000\003i\003i\011\190\011\214\003i\000\000\000\000\000\000\000\000\003i\000\000\011\238\003i\000\000\000\000\000\000\000\000\003i\003i\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003i\003i\n\222\011^\012\006\012\030\012N\003i\003i\000\000\000\000\003i\000\000\003i\003i\012f\000\000\000\000\000\000\000\000\000\000\000\000\003i\003i\012~\000\000\003i\003i\003i\003i\000\000\000\000\000\000\000\000\000\000\003i\000\000\003i\003i\000\000\012\222\003i\012\246\0126\003i\003i\000\000\000\000\003i\012\150\003i\000\000\000\000\000\000\000\000\003i\003i\012\174\012\198\003\141\000\000\000\000\000\000\003\141\000\000\000\000\003\141\000\000\000\000\003\141\000\000\003\141\000\000\000\000\003\141\000\000\003\141\003\141\003\141\000\000\003\141\003\141\003\141\000\000\000\000\000\000\000\000\000\000\003\141\003\141\003\141\003\141\003\141\000\000\003\141\000\000\000\000\000\000\000\000\000\000\003\141\003\141\003\141\003\141\003\141\000\000\000\000\000\000\000\000\003\141\000\000\003\141\003\141\000\000\000\000\000\000\000\000\003\141\003\141\003\141\000\000\000\000\000\000\000\000\000\000\000\000\003\141\003\141\003\141\003\141\003\141\003\141\003\141\003\141\003\141\000\000\000\000\003\141\000\000\003\141\003\141\003\141\000\000\000\000\000\000\000\000\000\000\000\000\003\141\003\141\003\141\000\000\003\141\003\141\003\141\003\141\000\000\000\000\000\000\000\000\000\000\003\141\000\000\003\141\003\141\000\000\tF\003\141\003\141\003\141\003\141\003\141\000\000\000\000\003\141\003\141\tZ\000\000\000\000\000\000\000\000\003\141\003\141\003\141\003\141\003\137\000\000\000\000\000\000\003\137\000\000\000\000\003\137\000\000\000\000\003\137\000\000\003\137\000\000\000\000\n\198\000\000\003\137\003\137\003\137\000\000\003\137\003\137\003\137\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003\137\000\000\000\000\000\000\000\000\000\000\003\137\003\137\011\190\011\214\003\137\000\000\000\000\000\000\000\000\003\137\000\000\011\238\003\137\000\000\000\000\000\000\000\000\003\137\003\137\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003\137\003\137\n\222\011^\012\006\012\030\012N\003\137\003\137\000\000\000\000\003\137\000\000\003\137\003\137\012f\000\000\000\000\000\000\000\000\000\000\000\000\003\137\003\137\012~\000\000\003\137\003\137\003\137\003\137\000\000\000\000\000\000\000\000\000\000\003\137\000\000\003\137\003\137\000\000\012\222\003\137\012\246\0126\003\137\003\137\000\000\000\000\003\137\012\150\003\137\000\000\000\000\000\000\000\000\003\137\003\137\012\174\012\198\003}\000\000\000\000\000\000\003}\000\000\000\000\003}\000\000\000\000\003}\000\000\003}\000\000\000\000\003}\000\000\003}\003}\003}\000\000\003}\003}\003}\000\000\000\000\000\000\000\000\000\000\003}\003}\003}\003}\003}\000\000\003}\000\000\000\000\000\000\000\000\000\000\003}\003}\003}\003}\003}\000\000\000\000\000\000\000\000\003}\000\000\003}\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}\003}\003}\003}\003}\003}\003}\003}\000\000\000\000\003}\000\000\003}\003}\003}\000\000\000\000\000\000\000\000\000\000\000\000\003}\003}\003}\000\000\003}\003}\003}\003}\000\000\000\000\000\000\000\000\000\000\003}\000\000\003}\003}\000\000\tF\003}\003}\003}\003}\003}\000\000\000\000\003}\003}\tZ\000\000\000\000\000\000\000\000\003}\003}\003}\003}\003y\000\000\000\000\000\000\003y\000\000\000\000\003y\000\000\000\000\003y\000\000\003y\000\000\000\000\n\198\000\000\003y\003y\003y\000\000\003y\003y\003y\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003y\000\000\000\000\000\000\000\000\000\000\003y\003y\011\190\011\214\003y\000\000\000\000\000\000\000\000\003y\000\000\011\238\003y\000\000\000\000\000\000\000\000\003y\003y\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003y\003y\n\222\011^\012\006\012\030\012N\003y\003y\000\000\000\000\003y\000\000\003y\003y\012f\000\000\000\000\000\000\000\000\000\000\000\000\003y\003y\012~\000\000\003y\003y\003y\003y\000\000\000\000\000\000\000\000\000\000\003y\000\000\003y\003y\000\000\012\222\003y\012\246\0126\003y\003y\000\000\000\000\003y\012\150\003y\000\000\000\000\000\000\000\000\003y\003y\012\174\012\198\003E\000\000\000\000\000\000\003E\000\000\000\000\003E\000\000\000\000\003E\000\000\003E\000\000\000\000\003E\000\000\003E\003E\003E\000\000\003E\003E\003E\000\000\000\000\000\000\000\000\000\000\003E\003E\003E\003E\003E\000\000\003E\000\000\000\000\000\000\000\000\000\000\003E\003E\003E\003E\003E\000\000\000\000\000\000\000\000\003E\000\000\003E\003E\000\000\000\000\000\000\000\000\003E\003E\003E\000\000\000\000\000\000\000\000\000\000\000\000\003E\003E\003E\003E\003E\003E\003E\003E\003E\000\000\000\000\003E\000\000\003E\003E\003E\000\000\000\000\000\000\000\000\000\000\000\000\003E\003E\003E\000\000\003E\003E\003E\003E\000\000\000\000\000\000\000\000\000\000\003E\000\000\003E\003E\000\000\tF\003E\003E\003E\003E\003E\000\000\000\000\003E\003E\tZ\000\000\000\000\000\000\000\000\003E\003E\003E\003E\003A\000\000\000\000\000\000\003A\000\000\000\000\003A\000\000\000\000\003A\000\000\003A\000\000\000\000\n\198\000\000\003A\003A\003A\000\000\003A\003A\003A\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\003A\000\000\000\000\000\000\000\000\000\000\003A\003A\011\190\011\214\003A\000\000\000\000\000\000\000\000\003A\000\000\011\238\003A\000\000\000\000\000\000\000\000\003A\003A\000\238\000\000\000\000\000\000\000\000\000\000\000\000\003A\003A\n\222\011^\012\006\012\030\012N\003A\003A\000\000\000\000\003A\000\000\003A\003A\012f\000\000\000\000\000\000\000\000\000\000\000\000\003A\003A\012~\000\000\003A\003A\003A\003A\000\000\000\000\000\000\000\000\000\000\003A\000\000\003A\003A\000\000\012\222\003A\012\246\0126\003A\003A\000\000\000\000\003A\012\150\003A\000\000\000\000\000\000\000\000\003A\003A\012\174\012\198\t\153\000\000\000\000\000\000\t\153\000\000\000\000\t\153\000\000\000\000\t\153\000\000\t\153\000\000\000\000\n\198\000\000\t\153\t\153\t\153\000\000\t\153\t\153\t\153\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\t\153\000\000\000\000\000\000\000\000\000\000\t\153\t\153\011\190\011\214\t\153\000\000\000\000\000\000\000\000\t\153\000\000\011\238\t\153\000\000\000\000\000\000\000\000\t\153\t\153\000\238\000\000\000\000\000\000\000\000\000\000\000\000\t\153\t\153\n\222\011^\012\006\012\030\012N\t\153\t\153\000\000\000\000\t\153\000\000\t\153\t\153\012f\000\000\000\000\000\000\000\000\000\000\000\000\t\153\t\153\012~\000\000\t\153\t\153\t\153\t\153\000\000\000\000\000\000\000\000\000\000\t\153\000\000\t\153\t\153\000\000\t\153\t\153\t\153\0126\t\153\t\153\000\000\000\000\t\153\012\150\t\153\000\000\000\000\000\000\000\000\t\153\t\153\012\174\012\198\t\241\000\000\000\000\000\000\t\241\000\000\000\000\t\241\000\000\000\000\t\241\000\000\t\241\000\000\000\000\t\241\000\000\t\241\t\241\t\241\000\000\t\241\t\241\t\241\000\000\000\000\000\000\000\000\000\000\t\241\t\241\t\241\t\241\t\241\000\000\t\241\000\000\000\000\000\000\000\000\000\000\t\241\t\241\t\241\t\241\t\241\000\000\000\000\000\000\000\000\t\241\000\000\t\241\t\241\000\000\000\000\000\000\000\000\t\241\t\241\t\241\000\000\000\000\000\000\000\000\000\000\000\000\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\t\241\000\000\000\000\t\241\000\000\t\241\t\241\t\241\000\000\000\000\000\000\000\000\000\000\000\000\t\241\t\241\t\241\000\000\t\241\t\241\t\241\t\241\000\000\000\000\000\000\000\000\000\000\t\241\000\000\t\241\t\241\000\000\tF\t\241\t\241\t\241\t\241\t\241\000\000\000\000\t\241\t\241\tZ\000\000\000\000\000\000\000\000\t\241\t\241\t\241\t\241\002U\000\000\000\000\000\000\002U\000\000\000\000\002U\000\000\000\000\002U\000\000\002U\000\000\000\000\002U\000\000\002U\002U\002U\000\000\002U\002U\002U\000\000\000\000\000\000\000\000\000\000\002U\002U\002U\002U\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\002U\000\000\000\000\000\000\000\000\002U\002U\002U\000\000\000\000\000\000\000\000\000\000\000\000\002U\002U\002U\002U\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\002U\002U\000\000\002U\002U\016\250\002U\000\000\000\000\000\000\000\000\000\000\002U\000\000\002U\002U\000\000\tF\002U\002U\002U\002U\002U\000\000\000\000\002U\002U\tZ\000\000\000\000\000\000\000\000\002U\002U\002U\002U\002M\000\000\000\000\000\000\002M\000\000\000\000\002M\000\000\000\000\002M\000\000\002M\000\000\000\000\002M\000\000\002M\002M\002M\000\000\002M\002M\002M\000\000\000\000\000\000\000\000\000\000\002M\002M\002M\002M\002M\000\000\002M\000\000\000\000\000\000\000\000\000\000\002M\002M\002M\002M\002M\000\000\000\000\000\000\000\000\002M\000\000\002M\002M\000\000\000\000\000\000\000\000\002M\002M\002M\000\000\000\000\000\000\000\000\000\000\000\000\002M\002M\002M\002M\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\002M\002M\000\000\002M\002M\002M\002M\000\000\000\000\000\000\000\000\000\000\002M\000\000\002M\002M\000\000\tF\002M\002M\002M\002M\002M\000\000\000\000\002M\002M\tZ\000\000\000\000\000\000\000\000\002M\002M\002M\002M\002I\000\000\000\000\000\000\002I\000\000\000\000\002I\000\000\000\000\002I\000\000\002I\000\000\000\000\n\198\000\000\002I\002I\002I\000\000\002I\002I\002I\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\002I\000\000\000\000\000\000\000\000\000\000\002I\002I\011\190\011\214\002I\000\000\000\000\000\000\000\000\002I\000\000\011\238\002I\000\000\000\000\000\000\000\000\002I\002I\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002I\002I\n\222\011^\012\006\012\030\012N\002I\002I\000\000\000\000\002I\000\000\002I\002I\012f\000\000\000\000\000\000\000\000\000\000\000\000\002I\002I\012~\000\000\002I\002I\002I\002I\000\000\000\000\000\000\000\000\000\000\002I\000\000\002I\002I\000\000\012\222\002I\012\246\0126\002I\002I\000\000\000\000\002I\012\150\002I\000\000\000\000\000\000\000\000\002I\002I\012\174\012\198\002Q\000\000\000\000\000\000\002Q\000\000\000\000\002Q\000\000\000\000\002Q\000\000\002Q\000\000\000\000\n\198\000\000\002Q\002Q\002Q\000\000\002Q\002Q\002Q\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\002Q\000\000\000\000\000\000\000\000\000\000\002Q\002Q\011\190\011\214\002Q\000\000\000\000\000\000\000\000\002Q\000\000\011\238\002Q\000\000\000\000\000\000\000\000\002Q\002Q\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002Q\002Q\n\222\011^\012\006\012\030\012N\002Q\002Q\000\000\000\000\002Q\000\000\002Q\002Q\012f\000\000\000\000\000\000\000\000\000\000\000\000\002Q\002Q\012~\000\000\002Q\002Q\017\022\002Q\000\000\000\000\000\000\000\000\000\000\002Q\000\000\002Q\002Q\000\000\012\222\002Q\012\246\0126\002Q\002Q\000\000\000\000\002Q\012\150\002Q\000\000\000\000\000\000\000\000\002Q\002Q\012\174\012\198\002E\000\000\000\000\000\000\002E\000\000\000\000\002E\000\000\000\000\002E\000\000\002E\000\000\000\000\002E\000\000\002E\002E\002E\000\000\002E\002E\002E\000\000\000\000\000\000\000\000\000\000\002E\002E\002E\002E\002E\000\000\002E\000\000\000\000\000\000\000\000\000\000\002E\002E\002E\002E\002E\000\000\000\000\000\000\000\000\002E\000\000\002E\002E\000\000\000\000\000\000\000\000\002E\002E\002E\000\000\000\000\000\000\000\000\000\000\000\000\002E\002E\002E\002E\002E\002E\002E\002E\002E\000\000\000\000\002E\000\000\002E\002E\002E\000\000\000\000\000\000\000\000\000\000\000\000\002E\002E\002E\000\000\002E\002E\002E\002E\000\000\000\000\000\000\000\000\000\000\002E\000\000\002E\002E\000\000\tF\002E\002E\002E\002E\002E\000\000\000\000\002E\002E\tZ\000\000\000\000\000\000\000\000\002E\002E\002E\002E\002A\000\000\000\000\000\000\002A\000\000\000\000\002A\000\000\000\000\002A\000\000\002A\000\000\000\000\n\198\000\000\002A\002A\002A\000\000\002A\002A\002A\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\002A\000\000\000\000\000\000\000\000\000\000\002A\002A\011\190\011\214\002A\000\000\000\000\000\000\000\000\002A\000\000\011\238\002A\000\000\000\000\000\000\000\000\002A\002A\000\238\000\000\000\000\000\000\000\000\000\000\000\000\002A\002A\n\222\011^\012\006\012\030\012N\002A\002A\000\000\000\000\002A\000\000\002A\002A\012f\000\000\000\000\000\000\000\000\000\000\000\000\002A\002A\012~\000\000\002A\002A\002A\002A\000\000\000\000\000\000\000\000\000\000\002A\000\000\002A\002A\000\000\012\222\002A\012\246\0126\002A\002A\000\000\000\000\002A\012\150\002A\000\000\000\000\000\000\000\000\002A\002A\012\174\012\198\003=\000\000\000\000\000\000\003=\000\000\000\000\003=\000\000\000\000\003=\000\000\003=\000\000\000\000\003=\000\000\003=\003=\003=\000\000\003=\003=\003=\000\000\000\000\000\000\000\000\000\000\003=\003=\003=\003=\003=\000\000\003=\000\000\000\000\000\000\000\000\000\000\003=\003=\003=\003=\003=\000\000\000\000\000\000\000\000\003=\000\000\003=\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=\003=\003=\003=\003=\003=\003=\003=\000\000\000\000\003=\000\000\003=\003=\003=\000\000\000\000\000\000\000\000\000\000\000\000\003=\003=\003=\000\000\003=\003=\003=\003=\000\000\000\000\000\000\000\000\000\000\003=\000\000\003=\003=\000\000\tF\003=\003=\003=\003=\003=\000\000\000\000\003=\003=\tZ\000\000\000\000\000\000\000\000\003=\003=\003=\003=\0039\000\000\000\000\000\000\0039\000\000\000\000\0039\000\000\000\000\0039\000\000\0039\000\000\000\000\n\198\000\000\0039\0039\0039\000\000\0039\0039\0039\000\000\000\000\000\000\000\000\000\000\011.\011v\011\142\011F\011\166\000\000\0039\000\000\000\000\000\000\000\000\000\000\0039\0039\011\190\011\214\0039\000\000\000\000\000\000\000\000\0039\000\000\011\238\0039\000\000\000\000\000\000\000\000\0039\0039\000\238\000\000\000\000\000\000\000\000\000\000\000\000\0039\0039\n\222\011^\012\006\012\030\012N\0039\0039\000\000\000\000\0039\000\000\0039\0039\012f\000\000\000\000\000\000\000\000\000\000\000\000\0039\0039\012~\000\000\0039\0039\0039\0039\000\000\000\000\000\000\000\000\000\000\0039\000\000\0039\0039\000\000\012\222\0039\012\246\0126\0039\0039\000\000\000\000\0039\012\150\0039\000\000\000\000\000\000\000\000\0039\0039\012\174\012\198\0029\000\000\000\000\000\000\0029\000\000\000\000\0029\000\000\000\000\0029\000\000\0029\000\000\000\000\0029\000\000\0029\0029\0029\000\000\0029\0029\0029\000\000\000\000\000\000\000\000\000\000\0029\0029\0029\0029\0029\000\000\0029\000\000\000\000\000\000\000\000\000\000\0029\0029\0029\0029\0029\000\000\000\000\000\000\000\000\0029\000\000\0029\0029\000\000\000\000\000\000\000\000\0029\0029\0029\000\000\000\000\000\000\000\000\000\000\000\000\0029\0029\0029\0029\0029\0029\0029\0029\0029\000\000\000\000\0029\000\000\0029\0029\0029\000\000\000\000\000\000\000\000\000\000\000\000\0029\0029\0029\000\000\0029\0029\0029\0029\000\000\000\000\000\000\000\000\000\000\0029\000\000\0029\0029\000\000\0029\0029\0029\0029\0029\0029\000\000\000\000\0029\0029\tZ\000\000\000\000\000\000\000\000\0029\0029\0029\0029\002=\000\000\000\000\000\000\002=\000\000\000\000\002=\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=\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=\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=\tZ\000\000\000\000\000\000\000\000\002=\002=\002=\002=\000\006\000\000\000\000\007\141\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\001\006\000\000\000\000\000\000\002\134\000\000\000\000\000\000\007\141\001\194\000\000\000\000\000\000\003\214\001\014\t\158\t\162\001\026\001\030\000\000\000\000\000\000\002\238\000\000\003\138\000\000\019\002\000\000\t\194\t\198\007\141\003\198\003\210\003\222\t\202\007\006\000\000\001.\007\141\002\162\000\000\000\000\003\218\007\141\007\141\000\238\bf\bj\bv\b\134\000\000\005\138\007\141\007\141\0012\0016\001:\001>\001B\000\000\000\000\b\158\001F\000\000\000\000\000\000\000\000\001J\000\000\b\170\b\194\tf\005\150\005\154\000\000\000\000\001N\000\000\000\000\007\141\000\000\000\000\b~\001R\b\130\000\000\000\000\000\000\000\000\000\000\007\141\000\000\000\000\000\000\001\142\006>\000\000\000\000\005\158\b\146\000\000\001\146\000\000\016\"\004^\t\222\026\214\001\154\000\006\001\158\001\162\001\153\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\001\006\000\000\000\000\000\000\t\154\000\000\000\000\000\000\001\153\001\194\000\000\000\000\000\000\003\214\001\014\t\158\t\162\001\026\001\030\000\000\000\000\000\000\002\238\000\000\003\138\000\000\t\166\000\000\t\194\t\198\001\153\003\198\003\210\003\222\t\202\007\006\000\000\001.\001\153\002\162\000\000\000\000\003\218\001\153\001\153\000\238\bf\bj\bv\b\134\000\000\005\138\001\153\001\153\0012\0016\001:\001>\001B\000\000\000\000\b\158\001F\000\000\000\000\017\250\000\000\001J\002z\b\170\b\194\tf\005\150\005\154\000\000\000\000\001N\001\190\000\000\001\153\000\000\000\000\b~\001R\b\130\000\000\024f\000\000\000\000\028\206\001\153\000\000\000\000\000\000\001\142\006z\000\000\000\000\005\158\b\146\000\000\001\146\000\000\016\"\004^\t\222\017\254\001\154\000\000\001\158\001\162\000\145\002\170\002\174\000\145\000\000\002z\000\000\n*\002\146\018\n\002\230\024\138\000\000\000\145\000\000\000\145\000\000\000\145\000\000\000\145\001\194\000\000\nZ\000\000\002\234\003\130\003R\002\174\000\241\000\000\nb\000\145\000\000\002\238\003V\003\138\005\154\000\145\004\186\000\000\b6\000\145\005\137\003\210\001\174\001\194\000\145\000\241\024\150\000\145\002\162\000\000\000\000\003\218\000\145\000\145\000\145\bf\bj\bv\005\173\014J\005\138\000\145\000\145\024*\000\000\000\000\003~\000\241\000\145\002\250\005\173\000\000\000\145\002\162\000\000\000\241\000\000\000\000\000\000\000\000\000\241\005\150\005\154\000\145\000\145\000\000\000\000\000\145\000\145\000\241\000\241\b~\000\000\b\130\006\158\000\000\000\000\t\213\000\000\000\145\005\173\000\000\007\026\000\000\000\000\000\145\000\145\005\158\b\146\000\000\000\000\000\000\tz\004^\000\000\000\145\000\241\000\145\000\169\002\170\002\174\000\169\000\000\002z\000\000\n*\000\000\000\241\002\230\000\000\005\173\000\169\000\000\000\169\005\173\000\169\000\238\000\169\001\194\000\000\nZ\000\000\002\234\000\000\000\000\000\000\000\000\000\000\nb\000\169\000\000\002\238\000\000\003\138\000\000\000\169\000\000\tU\000\000\000\169\000\000\003\210\001\174\002\158\000\169\001\241\000\000\000\169\002\162\021\182\000\000\003\218\000\169\000\169\000\169\bf\bj\bv\000\000\014J\005\138\000\169\000\169\006N\000\000\000\000\005\250\000\000\000\169\000\000\000\000\t\213\000\169\006b\000\n\000\000\tU\006j\000\000\000\000\000\000\005\150\005\154\000\169\000\169\000\000\000\000\000\169\000\169\000\000\001\241\b~\000\000\b\130\000\000\000\000\000\000\000\000\tU\000\169\001\190\000\000\001\241\001\241\000\000\000\169\000\169\005\158\b\146\000\000\000\000\000\000\tz\004^\000\000\000\169\000\006\000\169\001\194\000\246\002\170\002\174\002\178\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\021\226\003^\tU\000\000\000\000\005\029\004\218\003b\001\194\tU\020&\002\146\002\234\022Z\003f\003j\000\000\002\162\000\000\003n\000\000\002\238\000\000\003\138\022r\019\186\tQ\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\020\030\002\162\000\000\000\000\003\218\0206\001\186\001\190\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\020>\000\000\b\158\000\000\001\194\001\234\000\000\tQ\b\190\000\000\b\170\b\194\tf\005\150\005\154\020R\020\142\000\000\000\000\005\029\005\029\000\000\000\000\b~\000\249\b\130\000\000\001\230\002\154\tQ\000\000\000\000\002\150\000\000\002\162\004\014\004\026\020\202\024\190\005\158\b\146\004&\000\000\000\249\tz\004^\t\222\000\006\016\206\000\000\000\246\002\170\002\174\002\178\002\218\002z\000\000\000\000\004*\000\000\002\230\000\000\028\214\005=\tQ\000\249\000\238\021\234\004\218\003b\001\194\tQ\000\000\000\249\002\234\000\000\003f\003j\000\249\000\000\028\194\003n\000\000\002\238\000\000\003\138\000\000\019\186\000\249\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\020\030\002\162\000\000\000\000\003\218\0206\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\006N\000\249\000\000\005\250\000\000\000\000\000\000\020>\000\000\b\158\006b\030\210\000\249\000\000\006j\000\000\000\000\b\170\b\194\tf\005\150\005\154\020R\020\142\000\000\000\000\030\243\017.\000\000\000\000\b~\000\000\b\130\000\000\000\000\000\000\000\000\000\000\017\250\000\000\000\000\002z\000\000\r\005\012\241\024\190\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\000\006\000\000\000\000\000\246\002\170\002\174\002\178\002\218\002z\r\005\000\000\000\000\002\022\002\230\000\000\002\026\031\"\000\000\000\000\000\000\000\000\000\000\003b\001\194\000\000\017\254\000\000\002\234\002&\003f\003j\002.\012\241\000\000\003n\000\000\002\238\000\000\003\138\018\n\019\186\024j\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\020\030\002\162\000\000\0022\003\218\0206\001\254\000\000\bf\bj\bv\b\134\000\000\005\138\005\154\000\000\002\002\000\000\000\000\0076\000\000\020>\000\000\b\158\001\194\030\210\024v\000\000\000\000\000\000\000\000\b\170\b\194\tf\005\150\005\154\020R\020\142\000\000\000\000\005E\003B\000\000\024*\b~\000\000\b\130\0072\001\206\000\000\0026\000\000\000\000\000\000\002\162\000\000\000\000\000\000\000\000\024\190\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\000\014\000\018\000\022\000\026\000\030\000\000\000\"\000&\000*\000.\0002\000\000\0006\000:\000\000\007>\000>\000\000\001\241\000\000\000B\001\241\000\000\000\000\000\000\000\000\000\000\000F\000\000\000\000\000\000\000\000\000\000\000J\000\000\000N\000R\000V\000Z\000^\000b\000f\000\000\000\000\000\n\000j\000n\000\000\000r\000\000\000v\000\000\rE\000\000\000\000\000\000\000\000\000\000\000\000\001\241\000\000\000\000\000\000\000\000\000z\000\000\000\000\000~\000\130\000\000\000\000\rE\001\241\001\241\000\134\000\138\000\142\000\000\000\000\000\000\000\000\000\000\000\000\000\146\000\150\000\154\000\158\000\000\000\162\000\166\000\170\000\000\000\000\rE\000\174\000\178\000\182\000\000\000\000\000\000\001\241\rE\000\186\000\000\000\190\000\194\rE\rE\000\238\000\000\000\000\000\000\000\198\000\000\000\202\rE\rE\000\000\000\000\000\000\000\206\000\210\000\000\000\214\004y\002\254\002\174\004y\000\000\002z\000\000\006\214\000\000\000\000\002\230\000\000\000\000\004y\000\000\000\000\000\000\004y\rE\004y\001\194\000\000\006\246\000\000\000\000\001\241\001\241\003\002\000\000\rE\b\206\004y\000\000\000\000\000\000\000\000\000\000\004y\000\000\000\000\003\014\000\000\000\000\b\250\001\174\001\241\004y\000\000\001\241\004y\002\162\001\241\000\n\003\234\004y\004y\011%\003\238\001\241\003\246\000\000\t\n\005\138\000\000\001\241\000\000\000\000\001\241\001\241\000\000\004y\004y\000\000\000\000\005\142\000\000\000\000\000\000\000\000\000\000\001\241\000\000\000\000\005\150\005\154\004y\004y\r\026\000\000\004y\004y\001\241\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011%\n6\000\000\011%\r\"\004y\005\158\000\000\000\000\000\000\011%\000\000\004^\000\000\011%\000\000\004y\002\254\002\174\006\026\000\000\002z\000\000\000\000\000\000\000\000\002\230\001\006\000\000\000\000\000\000\002\134\000\000\000\000\000\000\001\241\001\194\000\000\001\241\001\241\001\n\001\014\001\018\003\030\001\026\001\030\001\241\000\000\000\000\000\000\000\000\000\000\000\000\003\"\000\000\001\"\006:\001\241\000\000\003\026\001\174\001*\000\000\000\000\001.\000\n\002\162\000\000\000\000\003\234\000\000\000\000\000\000\003\238\000\000\003\246\005~\000\000\005\138\000\000\001\241\0012\0016\001:\001>\001B\000\000\001\241\000\000\001F\005\142\000\000\000\000\001\241\001J\000\000\000\000\000\000\000\000\005\150\005\154\000\000\005\218\001N\000\000\000\000\000\000\000\000\000\000\000\000\001R\000\000\000\000\000\000\000\000\000\000\001\241\000\000\000\000\000\000\000\000\001\142\006>\000\000\000\000\005\158\000\000\000\000\001\146\000\000\001\150\004^\000\000\000\000\001\154\000\000\001\158\001\162\002\254\002\174\b\254\000\000\002z\000\000\000\000\000\000\000\000\002\230\001\006\000\000\000\000\003r\002\134\000\000\000\000\000\000\000\000\001\194\000\000\000\000\000\000\001\n\001\014\001\018\003\030\001\026\001\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\"\000\000\001\"\006:\000\000\000\000\003\026\001\174\001*\000\000\000\000\001.\000\000\002\162\000\000\000\000\003\234\001\241\000\000\000\000\003\238\000\000\003\246\005~\000\000\005\138\000\000\001\241\0012\0016\001:\001>\001B\000\000\000\000\001\241\001F\005\142\000\000\000\000\000\000\001J\000\000\000\n\000\000\000\000\005\150\005\154\000\000\005\218\001N\000\000\001\241\000\000\000\000\000\000\000\000\001R\001\241\001\241\000\000\000\000\000\000\000\000\000\000\001\241\000\000\000\000\001\142\006>\000\000\001\241\005\158\000\000\000\000\001\146\000\000\001\150\004^\000\000\000\000\001\154\000\006\001\158\001\162\000\246\002\170\002\174\002\n\002\218\002z\000\000\000\000\000\000\001\241\002\230\000\000\000\000\020\206\000\000\t\189\000\000\t\189\t\189\003b\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\020\210\000\000\002\238\000\000\003\138\000\000\020\250\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\020\030\002\162\000\000\000\000\003\218\0206\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\021\142\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\254\b\194\tf\005\150\005\154\020R\021\162\000\000\000\000\005\017\005\017\000\000\000\000\b~\000\000\b\130\000\000\000\000\000\000\000\006\000\000\000\000\000\000\002\170\002\174\000\000\002\218\002z\021\178\005\158\b\146\t\189\002\230\000\000\tz\004^\t\222\t\181\000\000\t\181\t\181\000\000\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\001\241\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\001\241\001\241\000\000\002\162\001\241\000\000\003\218\000\000\001\241\001\241\bf\bj\bv\b\134\000\000\005\138\000\000\000\n\000\000\001\241\000\000\000\000\000\000\000\000\000\000\b\158\001\241\000\n\000\000\000\000\001\241\000\000\001\241\t\254\b\194\tf\005\150\005\154\001\241\001\241\000\000\000\000\001\241\001\241\000\000\001\241\b~\001\241\b\130\001\241\000\000\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\005\158\b\146\t\181\000\000\001\241\tz\004^\t\222\001\241\000\000\001\241\001\241\001\241\000\000\001\241\001\241\000\n\001\241\001\241\007\n\001\241\001\241\000\000\001\241\000\000\017\178\000\000\001\241\001\241\001\241\001\241\001\241\001\241\001\241\001\241\000\000\000\000\001\241\001\241\000\000\000\000\001\241\000\000\000\000\001\241\001\241\001\241\001\241\001\241\001\241\001\241\000\000\001\241\000\000\000\000\000\000\000\n\000\000\000\000\000\000\001\241\000\000\001\241\000\000\000\000\000\000\000\000\000\000\001\241\001\241\001\241\001\241\001\241\005\173\017\238\000\000\000\000\005\173\001\241\005\173\005\173\001\241\000\000\001\241\001\241\000\000\000\000\000\000\005\173\000\000\005\173\005\173\005\173\000\000\005\173\005\173\005\173\001\241\001\241\000\000\000\000\000\000\001\241\001\241\001\241\000\000\000\000\001\241\005\173\000\000\000\000\000\000\000\000\000\000\005\173\005\173\000\000\000\000\005\173\000\000\005\173\005\173\005\173\005\173\000\000\000\000\005\173\000\000\000\000\000\000\000\000\005\173\005\173\005\173\000\000\005\173\000\000\005\173\000\000\005\173\005\173\005\173\007\014\000\000\000\000\000\000\000\000\005\173\000\000\000\000\000\000\005\173\000\000\000\000\000\000\005\173\000\000\005\173\005\173\000\000\000\000\000\000\005\173\005\173\005\173\000\000\005\173\005\173\000\000\005\173\000\000\000\000\024\230\000\000\005\173\005\173\005\173\000\000\005\173\000\000\005\173\005\173\000\000\000\000\002\142\005\173\000\000\000\000\000\000\000\000\005\173\003b\000\000\000\000\005\173\000\006\005\173\005\173\000\000\002\170\002\174\000\000\002\218\002z\000\000\005\173\005\173\005\173\002\230\005\173\005\173\000\000\000\000\025V\000\000\003\242\000\000\000\000\001\194\000\000\000\000\020\030\002\234\000\000\003f\003j\0206\023:\005\173\000\000\000\000\002\238\000\000\003\138\000\000\025\250\026\n\003\190\003\194\005\173\003\198\003\210\003\222\003\230\007\006\000\000\002\174\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\0055\000\000\001\194\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\026\246\000\000\000\000\000\000\024\218\t\254\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\026\022\003\150\000\000\026\026\b~\021\250\b\130\002\162\000\000\000\000\000\000\000\000\000\000\000\000\026J\000\000\000\000\000\000\000\000\000\000\005\158\b\146\018\242\000\000\003b\tz\004^\t\222\011A\000\000\000\246\011A\011A\002\178\000\000\011A\000\000\011A\026Z\000\000\011A\000\000\000\000\005=\011A\011A\022&\011A\011A\003b\011A\000\000\011A\000\000\020\030\r\005\012\241\011A\000\000\0206\011A\003n\000\000\000\000\000\000\000\000\000\000\019\186\011A\022R\011A\000\000\000\000\011A\011A\r\005\027r\000\000\002\022\020\030\011A\002\026\000\000\011A\0206\000\000\011A\011A\002\"\011A\000\000\011A\011A\000\000\002&\005-\000\000\002.\012\241\000\000\020>\000\000\000\000\000\000\011A\000\000\022\182\000\000\000\000\005\t\000\000\000\000\005\t\011A\011A\020R\020\142\011A\000\000\011A\000\000\0022\005\t\000\000\000\000\000\000\005\186\000\000\005\t\000\000\000\000\000\000\000\000\011A\011A\000\000\011A\011A\024\190\011A\005\t\011A\000\000\011A\000A\011A\005\t\011A\000A\000A\000\000\000A\000A\000\000\000\000\005\t\000\000\000A\005\t\000\000\000\000\000\000\007=\005\t\002\210\000\000\000\000\000A\0026\000\000\000\000\000A\000\000\000A\000A\000\000\000\000\000\000\000\000\005\t\000A\000\000\000A\005\t\000\000\000\000\000A\000A\000\000\000A\000A\000A\000A\000A\005\t\005\t\000\000\000A\005\t\000\000\000A\000\000\000\000\000\000\000A\000A\000A\000A\000\000\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\t\000\000\000A\000\000\r9\000\000\000\000\000\000\000\000\000\000\000A\000A\000A\000A\000A\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\221\000A\000=\000A\005\221\000\000\000=\000=\000\000\000=\000=\000\000\000\000\000\000\000\000\000=\000\000\000A\000A\000\000\0079\000\000\000A\000A\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=\000\000\000=\000=\000=\000=\000=\000\000\000\000\000\000\000=\000\000\000\000\000=\r9\r9\000\000\000=\000=\000=\000=\000\000\000=\000\000\000\000\000\000\000\000\000\000\005\221\000\000\000\000\000\000\000=\000\000\r9\r9\000\000\000\000\r9\000\000\000=\000=\000=\000=\000=\005\221\000\000\000\000\005\221\000\000\000\000\000\000\005\225\000=\012\149\000=\005\225\000\000\012\149\012\149\000\000\012\149\012\149\000\000\000\000\000\000\000\000\012\149\000\000\000=\000=\000\000\007I\000\000\000=\000=\000=\012\149\000\000\000\000\000\000\012\149\000\000\012\149\012\149\000\000\000\000\000\000\000\000\000\000\012\149\000\000\012\149\000\000\000\000\000\000\012\149\012\149\000\000\012\149\012\149\012\149\012\149\012\149\000\000\000\000\000\000\012\149\000\000\000\000\012\149\r9\r9\000\000\012\149\012\149\012\149\012\149\000\000\012\149\000\000\000\000\000\000\000\000\000\000\005\225\000\000\000\000\000\000\012\149\000\000\000\000\r9\000\000\000\000\r9\000\000\012\149\012\149\012\149\012\149\012\149\005\225\000\000\000\000\005\225\000\000\000\000\000\000\000\000\012\149\012\145\012\149\000\000\000\000\012\145\012\145\000\000\012\145\012\145\000\000\000\000\000\000\000\000\012\145\000\000\012\149\012\149\000\000\007E\000\000\012\149\012\149\012\149\012\145\000\000\000\000\000\000\012\145\000\000\012\145\012\145\000\000\000\000\000\000\000\000\000\000\012\145\000\000\012\145\000\000\000\000\000\000\012\145\012\145\000\000\012\145\012\145\012\145\012\145\012\145\000\000\000\000\000\000\012\145\000\000\000\000\012\145\000\000\000\000\000\000\012\145\012\145\012\145\012\145\000\000\012\145\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\t\012\145\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\145\012\145\012\145\012\145\012\145\000\000\000\000\000\000\000\000\000\000\005\t\000\000\000\000\012\145\000\006\012\145\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\012\145\012\145\000\000\005\t\000\000\012\145\012\145\012\145\001\194\000\000\000\000\005\t\002\234\000\000\003f\003j\005\t\002\210\000\238\000\000\000\000\002\238\000\000\003\138\000\000\005\t\005\t\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\005\t\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\005\t\000\000\000\000\000\000\000\000\t\254\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\000\b\130\000\000\r\005\012\241\000\006\000\000\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\005\158\b\146\0162\002\230\000\000\tz\004^\t\222\r\005\000\000\016B\002\022\000\000\001\194\002\026\000\000\000\000\002\234\000\000\003f\003j\002\190\000\000\000\000\000\000\000\000\002\238\002&\003\138\000\000\002.\012\241\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\0022\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\254\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\0026\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\019>\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\222\b\194\tf\005\150\005\154\012\205\000\000\000\000\000\000\012\205\000\000\001\190\012\205\b~\000\000\b\130\000\000\000\000\000\000\000\000\004\178\000\000\012\205\012\205\012\205\000\000\012\205\012\205\012\205\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\000\000\000\000\000\000\012\205\000\000\000\000\000\000\000\000\000\000\012\205\012\205\000\000\000\000\012\205\000\000\000\000\002\146\000\000\012\205\000\000\000\000\012\205\000\000\000\000\000\000\000\000\012\205\012\205\012\205\000\000\000\000\000\000\000\000\000\000\004\233\012\205\012\205\004\233\000\000\000\000\000\000\000\000\012\205\000\000\000\000\000\000\004\186\004\233\000\000\000\000\012\205\004\233\000\000\004\233\000\000\000\000\000\000\012\205\012\205\012\205\000\000\012\205\012\205\000\000\000\000\004\233\000\000\000\000\000\000\000\000\000\000\004\233\000\000\012\205\000\000\012\205\012\205\000\000\000\000\000\000\012\205\000\000\000\000\004\233\000\000\012\205\000\000\000\000\004\233\012\205\t\165\012\205\012\205\000\000\t\165\000\000\001\190\t\165\000\000\000\000\000\000\000\000\000\000\000\000\004\233\t\165\000\000\t\165\t\165\t\165\000\000\t\165\t\165\t\165\000\000\000\000\000\000\000\000\000\000\004\233\004\233\000\000\000\000\004\233\004\233\t\165\000\000\000\000\000\000\000\000\000\000\t\165\t\165\000\000\000\000\t\165\000\000\000\000\002\146\000\000\t\165\000\000\004\233\t\165\000\000\000\000\000\000\000\000\t\165\t\165\t\165\000\000\000\000\021F\000\000\000\000\004\209\t\165\t\165\004\209\000\000\000\000\000\000\000\000\t\165\000\000\000\000\000\000\004\186\004\209\000\000\000\000\t\165\004\209\000\000\004\209\000\000\000\000\000\000\t\165\t\165\t\165\000\000\t\165\t\165\000\000\000\000\004\209\000\000\000\000\000\000\000\000\000\000\004\209\000\000\t\165\000\000\t\165\t\165\000\000\000\000\000\000\t\165\000\000\000\000\004\209\000\000\t\165\000\000\000\000\004\209\t\165\t\161\t\165\t\165\000\000\t\161\000\000\001\190\t\161\000\000\000\000\000\000\000\000\000\000\000\000\004\209\t\161\000\000\t\161\t\161\t\161\000\000\t\161\t\161\t\161\000\000\000\000\000\000\000\000\000\000\004\209\004\209\000\000\000\000\004\209\004\209\t\161\000\000\000\000\000\000\000\000\000\000\t\161\t\161\000\000\000\000\t\161\000\000\000\000\002\146\000\000\t\161\000\000\004\209\t\161\000\000\000\000\000\000\000\000\t\161\t\161\t\161\000\000\000\000\023\130\000\000\000\000\000\000\t\161\t\161\000\000\000\000\000\000\000\000\000\000\t\161\000\000\000\000\000\000\004\186\000\000\000\000\000\000\t\161\000\000\000\000\000\000\000\000\000\000\000\000\t\161\t\161\t\161\000\000\t\161\t\161\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\161\000\006\t\161\t\161\000\000\002\170\002\174\t\161\002\218\002z\000\000\000\000\t\161\000\000\002\230\000\000\t\161\000\000\t\161\t\161\000\000\000\000\000\000\000\000\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017f\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017>\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t6\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\tJ\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\022\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\138\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\202\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\226\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\006\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0112\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011J\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011b\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011z\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\146\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\170\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\194\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\218\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\242\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\n\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\"\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012:\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012R\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012j\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\130\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\154\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\178\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\202\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\226\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\250\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014f\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014\138\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014\174\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014\214\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\014\250\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\030\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015J\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015n\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\146\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\174\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\234\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\254\b\194\tf\005\150\005\154\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b~\000\006\b\130\000\000\000\000\002\170\002\174\000\000\002\218\002z\000\000\000\000\000\000\000\000\002\230\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\001\194\000\000\000\000\000\000\002\234\000\000\003f\003j\000\000\000\000\000\000\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\003\190\003\194\000\000\003\198\003\210\003\222\003\230\007\006\000\000\000\000\000\000\002\162\000\000\000\000\003\218\000\000\000\000\000\000\bf\bj\bv\b\134\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\b\158\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017\026\b\194\tf\005\150\005\154\000\000\000y\000\000\000y\000y\000\000\000\000\000\000\b~\000\000\b\130\000\000\000y\000\000\000y\000y\000\000\000\000\000y\000y\000y\000\000\t=\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\t\222\000y\000\000\000\000\000\000\000\000\000\000\000y\000y\000\000\000\000\000y\000\000\000\000\000y\000\000\000y\000\000\000\000\000y\000\000\000\000\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\000y\000y\000\000\000\000\000y\000\000\000\000\000\000\000y\000\000\000\000\000\000\000\000\000\000\000\000\000y\000y\000y\012\209\000y\000y\000\000\012\209\000\000\000\000\012\209\000\000\t=\000\000\000\000\000\000\000y\000\000\004v\000y\012\209\012\209\012\209\000y\012\209\012\209\012\209\000\000\000y\000\000\000\000\000\000\000y\000\000\000y\000\000\000\000\000\000\012\209\000\000\000\000\000\000\000\000\000\000\012\209\012\209\000\000\000\000\012\209\000\000\000\000\000\000\000\000\012\209\000\000\000\000\012\209\000\000\000\000\000\000\000\000\012\209\012\209\012\209\000\000\000\000\000\000\000\000\000\000\000\000\012\209\012\209\000\000\000\000\000\000\000\000\000\000\012\209\000\000\000\000\000\000\012\209\000\000\000\000\000\000\012\209\000\000\000\000\000\000\000\000\000\000\000\000\012\209\012\209\012\209\003\177\012\209\012\209\000\000\003\177\000\000\000\000\003\177\000\000\000\000\000\000\000\000\000\000\012\209\000\000\012\209\012\209\003\177\003\177\003\177\012\209\003\177\003\177\003\177\000\000\012\209\000\000\000\000\000\000\012\209\000\000\012\209\012\209\000\000\000\000\003\177\000\000\000\000\000\000\000\000\000\000\003\177\004n\000\000\000\000\003\177\000\000\000\000\000\000\000\000\003\177\000\000\000\000\003\177\000\000\000\000\000\000\000\000\003\177\003\177\003\177\000\000\000\000\000\000\000\000\000\000\000\000\003\177\003\177\000\000\000\000\000\000\000\000\000\000\003\177\000\000\000\000\000\000\003\177\000\000\011M\000\000\003\177\002\254\002\174\000\000\000\000\002z\000\000\003\177\003\177\003\177\002\230\003\177\003\177\000\000\011M\011M\000\000\011M\011M\000\000\001\194\000\000\000\000\003\177\000\000\003\177\003\177\003\002\000\000\000\000\003\177\000\000\000\000\000\000\000\000\003\177\000\000\000\000\011M\003\177\003\014\003\177\003\177\003\026\001\174\000\000\000\000\000\000\001\186\001\190\002\162\000\000\000\000\003\234\000\000\000\000\011M\003\238\000\000\003\246\005~\000\000\005\138\000\000\000\000\000\000\000\000\001\194\001\234\001\214\000\000\000\000\000\000\000\000\005\142\000\000\000\000\001\226\000\000\000\000\021\226\000\000\000\000\005\150\005\154\000\000\005\218\011M\000\000\011M\001\230\0236\000\000\022Z\000\000\002\150\000\000\002\162\004\014\004\026\000\000\000\000\000\000\011M\023F\000\000\011M\011M\000\000\005\158\000\000\011M\000\000\011M\000\000\004^\011I\011M\000\000\002\254\002\174\004*\000\000\002z\000\000\000\000\000\000\000\000\002\230\000\000\000\000\000\000\011I\011I\000\000\011I\011I\000\000\001\194\000\000\000\000\000\000\000\000\000\000\000\000\003\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011I\000\000\003\014\000\000\012\177\006\022\001\174\012\177\000\000\000\000\000\000\000\000\002\162\000\000\000\000\003\234\000\000\012\177\011I\003\238\000\000\003\246\005~\012\177\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\177\005\142\000\000\000\000\000\000\000\000\012\177\000\000\000\000\000\000\005\150\005\154\000\000\005\218\011I\012\177\011I\000\000\012\177\000\000\000\000\000\000\000\000\012\177\000\000\000\000\000\000\000\000\001\177\000\000\011I\000\000\001\177\011I\011I\001\177\005\158\000\000\011I\012\177\011I\000\000\004^\012\177\011I\001\177\001\177\001\177\000\000\001\177\001\177\001\177\000\000\000\000\012\177\012\177\000\000\000\000\012\177\000\000\000\000\000\000\000\000\001\177\000\000\000\000\030\202\000\000\000\000\001\177\001\177\000\000\000\000\001\177\000\000\000\000\000\000\012\177\001\177\000\000\000\000\001\177\000\000\000\000\000\000\000\000\001\177\001\177\001\177\000\000\000\000\000\000\000\000\000\000\000\000\001\177\001\177\000\000\000\000\000\000\000\000\000\000\001\177\000\000\000\000\000\000\001\177\000\000\000\000\000\000\001\177\000\000\000\000\000\000\000\000\000\000\000\000\001\177\001\177\001\177\000\000\001\177\001\177\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\177\000\000\001\177\001\177\002\254\002\174\000\000\001\177\002z\000\000\006\214\000\000\001\177\002\230\000\000\000\000\004\218\000\000\001\177\000\000\000\000\000\000\000\000\001\194\000\000\006\246\000\000\000\000\000\000\000\000\003\002\000\000\000\000\b\206\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\014\000\000\000\000\b\250\001\174\000\000\000\000\000\000\000\000\000\000\002\162\000\000\000\000\003\234\000\000\000\000\011%\003\238\000\000\003\246\000\000\t\n\005\138\000\000\000\000\000\000\000\000\000\000\000\000\006%\000\000\004\181\000\000\006%\005\142\000\000\006%\000\000\000\000\000\000\000\000\000\000\000\000\005\150\005\154\000\000\006%\r\026\006%\000\000\006%\000\000\006%\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011%\006%\000\000\011%\011%\000\000\005\158\006%\006%\000\000\011%\000\000\004^\006%\011%\004\181\006%\000\000\000\000\006%\000\000\000\000\000\000\000\000\006%\006%\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\006%\006%\000\000\000\000\006%\003\253\000\000\000\000\000\000\003\253\000\000\000\000\003\253\000\000\000\000\006%\006%\006%\000\000\006%\006%\000\000\003\253\000\000\003\253\000\000\003\253\007\238\003\253\003\253\000\000\000\000\000\000\000\000\006%\000\000\000\000\006%\006%\003\253\003\253\003\253\000\000\003\253\000\000\003\253\003\253\003\253\000\000\006%\000\000\000\000\005\181\000\000\000\000\003\253\000\000\003\253\003\253\000\000\000\000\000\000\000\000\003\253\003\253\003\253\000\000\000\000\000\000\005\185\000\000\000\000\003\253\000\000\000\000\003\253\000\000\000\000\000\000\003\253\003\253\003\253\003\253\003\253\000\000\000\000\000\000\000\000\000\000\000\000\001\186\001\190\000\000\000\000\003\253\003\253\003\253\000\000\003\253\003\253\003\253\006\025\000\000\000\000\000\000\006\025\005\181\000\000\006\025\001\194\001\234\003\253\003\253\003\253\003\253\003\253\003\253\003\253\006\025\000\000\006\025\000\000\006\025\005\185\006\025\000\000\000\000\000\000\003\253\000\000\003\253\003\253\001\230\002\146\003\253\000\000\006\025\002\150\000\000\002\162\004\014\004\026\006\025\006\025\000\000\003\253\004&\000\000\b2\000\000\000\000\006\025\000\000\000\000\006\025\000\000\000\000\000\000\000\000\006\025\006\025\000\238\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\006\025\006\025\000\000\000\000\006\025\000\000\000\000\n\198\000\000\000\000\014&\t\177\000\000\t\177\t\177\006\025\006\025\006\025\000\000\006\025\006\025\011.\011v\011\142\011F\011\166\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\025\011\190\011\214\006\025\006\025\000\000\000\000\000\000\000\000\000\000\011\238\000\000\000\000\000\000\000\000\006\025\000\000\000\000\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\222\011^\012\006\012\030\012N\000\000\000\000\000\000\000\000\000\000\000\000\000\000\017V\012f\001\006\000\000\000\000\000\000\002\134\000\000\000\000\000\000\012~\000\000\000\000\000\000\000\000\001\n\001\014\001\018\001\022\001\026\001\030\000\000\000\000\000\000\000\000\000\000\012\222\000\000\012\246\0126\001\"\001&\000\000\000\000\t\177\012\150\001*\000\000\000\000\001.\000\000\000\000\000\000\012\174\012\198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0012\0016\001:\001>\001B\000\000\000\000\000\000\001F\000\000\000\000\004\249\000\000\001J\004\249\000\000\t\021\000\000\000\000\000\000\t\021\000\000\001N\t\021\004\249\000\000\000\000\000\000\004\249\001R\004\249\000\000\000\000\t\021\000\000\t\021\000\000\t\021\000\000\t\021\001\142\029\230\004\249\000\000\000\000\000\000\000\000\001\146\004\249\001\150\000\000\t\021\000\000\001\154\000\000\001\158\001\162\t\021\t\021\000\000\004\249\000\000\000\000\000\000\000\000\004\249\t\021\000\000\000\000\t\021\000\000\000\000\000\000\000\000\t\021\t\021\t\021\000\000\000\000\000\000\000\000\004\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\t\021\000\000\000\000\000\000\t\021\000\000\004\249\004\249\000\000\000\000\004\249\004\249\000\000\000\000\000\000\t\021\t\021\t\021\r\133\t\021\t\021\000\000\r\133\000\000\000\000\r\133\000\000\000\000\000\000\004\249\000\000\t\021\000\000\000\000\t\021\r\133\000\000\r\133\t\021\r\133\023\218\r\133\000\000\000\000\000\000\000\000\000\000\004\218\000\000\t\021\000\000\000\000\000\000\r\133\000\000\000\000\000\000\000\000\000\000\r\133\r\133\000\000\000\000\000\000\000\000\0042\000\000\000\000\r\133\000\000\000\000\r\133\000\000\000\000\000\000\000\000\r\133\r\133\r\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\186\001\190\000\000\000\000\000\000\000\000\r\133\000\000\000\000\000\000\r\133\r\137\000\000\000\000\000\000\r\137\000\000\000\000\r\137\001\194\001\234\r\133\r\133\r\133\000\000\r\133\r\133\000\000\r\137\000\000\r\137\000\000\r\137\004>\r\137\000\000\000\000\000\000\000\000\000\000\r\133\000\000\001\230\002\154\r\133\000\000\r\137\002\150\000\000\002\162\004\014\004\026\r\137\r\137\000\000\r\133\004&\000\000\0042\000\000\000\000\r\137\000\000\000\000\r\137\000\000\000\000\000\000\000\000\r\137\r\137\r\137\000\000\004*\000\000\000\000\000\000\005}\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\137\000\000\002\254\002\174\r\137\000\000\002z\000\000\006\214\000\000\028\194\002\230\000\000\000\000\000\000\r\137\r\137\r\137\000\000\r\137\r\137\001\194\000\000\006\246\000\000\000\000\000\000\004>\003\002\000\000\000\000\b\206\000\000\000\000\r\137\000\000\000\000\000\000\r\137\003\157\000\000\003\014\000\000\000\000\b\250\001\174\000\000\000\000\000\000\r\137\000\000\002\162\000\000\000\000\003\234\000\000\000\000\000\000\003\238\000\000\003\246\000\000\t\n\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\142\001\161\000\000\001\190\001\161\000\000\000\000\000\000\000\000\005\150\005\154\000\000\t}\003\157\001\161\000\000\000\000\000\000\001\161\000\000\001\161\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\157\000\000\001\161\003\157\000\000\005\158\000\000\000\000\001\161\001\161\000\000\004^\000\000\000\000\000\000\002\146\000\000\001\161\000\000\000\000\001\161\003\225\000\000\001\190\003\225\001\161\001\161\001\161\000\000\000\000\000\000\000\000\ty\000\000\003\225\000\000\000\000\000\000\003\225\000\000\003\225\001\161\001\161\000\000\000\000\004\186\000\000\000\000\000\000\000\000\000\000\000\000\003\225\000\000\000\000\000\000\001\161\001\161\003\225\001\157\001\161\001\161\000\000\000\000\000\000\002\146\000\000\003\225\000\000\000\000\003\225\000\000\001\161\000\000\000\000\003\225\003\225\003\225\000\000\001\161\000\000\000\000\000\000\000\000\001\161\000\000\000\000\000\000\000\000\000\000\001\161\003\225\003\225\000\000\000\000\004\186\000\000\000\000\000\000\000\000\000\000\003\221\000\000\001\190\003\221\000\000\003\225\003\225\000\000\000\000\003\225\003\225\ty\000\000\003\221\000\000\000\000\000\000\003\221\000\000\003\221\000\000\003\225\000\000\000\000\000\000\000\000\000\000\000\000\003\225\000\000\000\000\003\221\000\000\003\225\000\000\000\000\000\000\003\221\001\157\003\225\000\000\000\000\000\000\000\000\002\146\000\000\003\221\000\000\000\000\003\221\000\000\000\000\000\000\000\000\003\221\003\221\003\221\000\000\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\221\003\221\000\000\000\000\004\186\000\000\000\000\000\000\005\001\000\000\000\000\005\001\000\000\000\000\000\000\003\221\003\221\000\000\000\000\003\221\003\221\005\001\000\000\000\000\000\000\005\001\000\000\005\001\000\000\000\000\000\000\003\221\000\000\000\246\001\186\001\190\002\n\000\000\003\221\005\001\000\000\000\000\000\000\003\221\000\000\005\001\020\206\000\000\000\000\003\221\005\017\000\000\003b\001\194\001\234\001\214\000\000\005\001\000\000\000\000\000\000\000\000\005\001\001\226\020\210\000\000\000\000\000\000\000\000\000\000\020\250\000\000\000\000\000\000\000\000\000\000\001\230\002\138\005\001\000\000\000\000\002\150\020\030\002\162\004\014\004\026\000\000\0206\000\000\000\153\004&\000\000\000\153\005\001\005\001\000\000\000\000\005\001\005\001\000\000\000\000\000\000\000\153\021\142\000\153\000\000\000\153\004*\000\153\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\001\000\000\020R\021\162\000\153\000\000\005\017\005\017\000\000\000\000\000\153\024\002\000\000\000\000\000\153\000\000\000\000\000\000\000\000\000\153\000\000\000\000\000\153\000\000\000\000\021\178\000\000\000\153\000\153\000\238\004Z\000\000\004^\000\000\000\000\000\000\000\153\000\153\000\000\000\000\000\000\000\000\000\000\000\153\000\000\000\000\000\000\000\153\000\000\000\000\000\000\000\000\000\221\000\000\000\000\000\221\000\000\000\000\000\153\000\153\000\000\000\000\000\153\000\153\000\000\000\221\000\000\000\221\000\000\000\221\000\000\000\221\000\000\000\000\000\153\000\000\000\000\000\000\000\000\000\000\000\153\000\153\000\000\000\221\000\000\000\000\000\000\000\000\000\000\000\221\000\153\000\000\000\153\000\221\000\000\000\000\000\000\000\000\000\221\000\000\000\000\000\221\000\000\000\000\000\000\000\000\000\221\000\221\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\221\000\221\000\000\000\000\000\000\000\000\000\000\000\221\000\000\000\000\000\000\000\221\000\000\000\000\000\000\000\000\000\161\000\000\000\000\000\161\000\000\000\000\000\221\000\221\000\000\000\000\000\221\000\221\000\000\000\161\000\000\000\161\000\000\000\161\000\000\000\161\000\000\000\000\000\221\000\000\000\000\000\000\000\000\000\000\000\221\000\221\000\000\000\161\000\000\000\000\000\000\000\000\000\000\000\161\000\221\000\000\000\221\000\161\000\000\000\000\000\000\000\000\000\161\000\000\000\000\000\161\000\000\000\000\000\000\000\000\000\161\000\161\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\161\000\161\000\000\000\000\000\000\000\000\000\000\000\161\000\000\000\000\000\000\000\161\000\000\000\000\000\000\000\000\000\157\000\000\000\000\000\157\000\000\000\000\000\161\000\161\000\000\000\000\000\161\000\161\000\000\000\157\000\000\000\157\000\000\000\157\000\000\000\157\000\000\000\000\000\161\000\000\000\000\000\000\000\000\000\000\000\161\000\161\000\000\000\157\000\000\000\000\000\000\000\000\000\000\000\157\000\161\000\000\000\161\000\157\000\000\000\000\000\000\000\000\000\157\000\000\000\000\000\157\000\000\000\000\000\000\000\000\000\157\000\157\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\157\000\157\000\000\001\006\000\000\000\000\000\000\000\157\000\000\000\000\000\000\000\157\000\000\000\000\000\000\000\000\001\n\001\014\001\018\001\022\001\026\001\030\000\157\000\157\000\000\000\000\000\157\000\157\000\000\000\000\000\000\001\"\001&\000\000\000\000\000\000\000\000\001*\000\157\000\000\001.\000\000\000\000\000\000\000\157\000\157\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\157\000\000\000\157\0012\0016\001:\001>\001B\000\000\000\000\000\000\001F\000\000\000\000\001}\000\000\001J\001}\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001N\000\000\001}\000\000\001\186\001\190\001}\001R\001}\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\142\030\002\001}\001}\000\000\001\194\001\234\001\146\001}\001\150\000\000\000\000\000\000\001\154\005\181\001\158\001\162\001}\000\000\000\000\001}\000\000\000\000\000\000\000\000\001}\001}\001}\001\230\002\146\000\000\000\000\000\000\002\150\000\000\002\162\004\014\004\026\000\000\000\000\000\000\001}\004&\000\000\018\022\001}\r\129\000\000\000\000\000\000\r\129\000\000\000\000\r\129\000\000\000\000\001}\001}\000\000\004*\001}\001}\000\000\r\129\000\000\r\129\000\000\r\129\005\181\r\129\000\000\000\000\001}\000\000\000\000\000\000\000\000\000\000\001}\001}\000\000\r\129\000\000\000\000\001}\000\000\000\000\r\129\r\129\000\000\001}\000\000\000\000\000\000\000\000\000\000\r\129\000\000\000\000\r\129\000\000\000\000\000\000\000\000\r\129\r\129\r\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\r\129\000\000\000\000\000\000\r\129\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\129\r\129\r\129\r}\r\129\r\129\000\000\r}\000\000\000\000\r}\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\129\r}\000\000\r}\r\129\r}\000\000\r}\000\000\000\000\t\025\000\000\000\000\004\218\t\025\r\129\000\000\t\025\000\000\r}\000\000\000\000\000\000\000\000\000\000\r}\r}\t\025\000\000\t\025\000\000\t\025\000\000\t\025\r}\000\000\000\000\r}\000\000\000\000\000\000\000\000\r}\r}\r}\t\025\000\000\000\000\000\000\000\000\000\000\t\025\t\025\000\000\000\000\000\000\000\000\000\000\r}\000\000\t\025\000\000\r}\t\025\000\000\000\000\000\000\000\000\t\025\t\025\000\238\000\000\000\000\r}\r}\r}\000\000\r}\r}\000\000\000\000\000\000\000\000\000\000\t\025\000\000\000\000\000\000\t\025\007\138\000\000\000\000\r}\000\000\000\000\n\198\r}\000\000\007\169\t\025\t\025\t\025\007\169\t\025\t\025\000\000\000\000\r}\000\000\011.\011v\011\142\011F\011\166\000\000\t\025\000\000\000\000\t\025\000\000\000\000\000\000\t\025\011\190\011\214\000\000\000\000\000\000\001\157\000\000\001\190\001\157\011\238\t\025\000\000\000\000\000\000\000\000\000\000\ty\000\238\001\157\000\000\000\000\000\000\001\157\000\000\001\157\000\000\n\222\011^\012\006\012\030\012N\000\000\000\000\000\000\000\000\000\000\001\157\007\169\000\000\012f\000\000\000\000\001\157\000\000\000\000\000\000\000\000\000\000\012~\002\146\000\000\001\157\000\000\000\000\001\157\000\000\000\000\000\000\000\000\001\157\001\157\001\157\000\000\000\000\012\222\000\000\012\246\0126\000\000\000\000\000\000\000\000\000\000\012\150\000\000\001\157\001\157\000\000\000\000\004\186\000\000\012\174\012\198\n\198\000\000\000\000\000\000\019z\000\000\000\000\001\157\001\157\000\000\000\000\001\157\001\157\000\000\011.\011v\011\142\011F\011\166\000\000\000\000\000\000\000\000\001\157\000\000\000\000\000\000\000\000\011\190\011\214\001\157\000\000\000\000\000\000\000\000\001\157\000\000\011\238\000\000\000\000\000\000\001\157\000\000\000\000\000\000\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\n\222\011^\012\006\012\030\012N\000\000\000\000\000\000\000\000\000\000\006M\000\000\000\000\012f\006M\000\000\000\000\006M\000\000\000\000\000\000\000\000\012~\000\000\000\000\000\000\000\000\006M\000\000\006M\000\000\006M\000\000\006M\000\000\000\000\000\000\000\000\012\222\019~\012\246\0126\019\138\000\000\000\000\006M\000\000\012\150\000\000\000\000\000\000\006M\006M\000\000\000\000\012\174\012\198\b2\000\000\000\000\006M\000\000\000\000\006M\000\000\000\000\000\000\000\000\006M\006M\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\006M\000\000\000\000\000\000\006M\000\000\000\000\000\000\000\000\002\170\002\174\000\000\000\000\002z\000\000\006M\006M\006M\002\230\006M\006M\000\000\000\000\006\249\000\000\000\000\000\000\000\000\001\194\000\000\000\000\000\000\002\234\000\000\006M\000\000\000\000\000\000\006M\000\000\000\000\002\238\000\000\003\138\000\000\000\000\000\000\000\000\000\000\006M\000\000\003\210\001\174\000\000\000\000\007^\000\000\000\000\002\162\006I\000\000\003\218\006I\000\000\000\000\bf\bj\bv\000\000\000\000\005\138\000\000\006I\000\000\006I\000\000\006I\000\000\006I\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006I\005\150\005\154\000\000\000\000\000\000\006I\007\218\000\000\000\000\000\000\b~\000\000\b\130\000\000\006I\000\000\000\000\006I\000\000\000\000\000\000\000\000\006I\006I\000\238\000\000\005\158\b\146\000\000\000\000\000\000\tz\004^\000\000\000\000\000\000\000\000\000\000\006I\000\000\000\000\000\000\006I\r\141\000\000\000\000\000\000\r\141\000\000\000\000\r\141\000\000\000\000\006I\006I\006I\000\000\006I\006I\000\000\r\141\000\000\r\141\000\000\r\141\000\000\r\141\000\000\000\000\001\186\001\190\000\000\006I\000\000\000\000\000\000\006I\000\000\r\141\000\000\000\000\000\000\000\000\002\134\r\141\r\141\000\000\006I\001\194\001\234\001\214\000\000\000\000\r\141\000\000\000\000\r\141\000\000\001\226\000\000\000\000\r\141\r\141\000\238\000\000\001\242\000\000\000\000\000\000\000\000\000\000\001\230\002\138\000\000\000\000\000\000\002\150\r\141\002\162\004\014\004\026\r\141\r\145\000\000\000\000\004&\r\145\000\000\000\000\r\145\000\000\000\000\r\141\r\141\r\141\000\000\r\141\r\141\000\000\r\145\000\000\r\145\004*\r\145\000\000\r\145\000\000\000\000\007y\007y\000\000\r\141\000\000\000\000\000\000\r\141\000\000\r\145\000\000\000\000\000\000\000\000\000\000\r\145\007\218\000\000\r\141\007y\007y\007y\000\000\000\000\r\145\000\000\018\002\r\145\000\000\007y\000\000\000\000\r\145\r\145\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007y\007y\000\000\000\000\000\000\007y\r\145\007y\007y\007y\r\145\007^\000\000\000\000\007y\006a\000\000\000\000\006a\000\000\000\000\r\145\r\145\r\145\000\000\r\145\r\145\000\000\006a\000\000\006a\007y\006a\000\000\006a\000\000\000\000\r\149\r\149\000\000\r\145\000\000\000\000\000\000\r\145\000\000\006a\000\000\000\000\000\000\000\000\000\000\006a\007\218\000\000\r\145\r\149\r\149\r\149\007r\000\000\006a\000\000\000\000\006a\000\000\r\149\000\000\000\000\006a\006a\000\238\000\000\000\000\000\000\000\000\000\000\005\018\000\000\r\149\r\149\000\000\000\000\000\000\r\149\006a\r\149\r\149\r\149\006a\006e\000\000\000\000\r\149\006e\000\000\000\000\006e\000\000\000\000\006a\006a\006a\000\000\006a\006a\000\000\006e\000\000\006e\r\149\006e\000\000\006e\000\000\000\000\001\186\001\190\r&\006a\000\000\000\000\000\000\006a\000\000\006e\000\000\000\000\000\000\000\000\000\000\006e\006e\000\000\006a\001\194\001\198\001\214\000\000\000\000\006e\000\000\000\000\006e\000\000\001\226\000\000\000\000\006e\006e\006e\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\230\002\138\000\000\000\000\000\000\002\150\006e\002\162\004\014\004\026\006e\006]\000\000\000\000\004&\006]\000\000\000\000\006]\000\000\000\000\006e\006e\006e\000\000\006e\006e\000\000\006]\000\000\006]\004*\006]\000\000\006]\000\000\000\000\000\000\000\000\000\000\006e\000\000\000\000\000\000\006e\000\000\006]\000\000\000\000\000\000\000\000\000\000\006]\007\218\000\000\b\002\000\000\000\000\000\000\000\000\000\000\006]\000\000\000\000\006]\000\000\000\000\000\000\000\000\006]\006]\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]\000\000\000\000\000\000\006]\000\000\000\000\000\000\003\205\002\170\002\174\003\205\000\000\002z\000\000\006]\006]\006]\002\230\006]\006]\003\205\000\000\007!\000\000\003\205\000\000\003\205\001\194\000\000\000\000\000\000\002\234\000\000\006]\000\000\000\000\000\000\006]\003\205\018\018\002\238\000\000\003\138\000\000\003\205\000\000\000\000\000\000\006]\000\000\003\210\001\174\000\000\003\205\000\000\000\000\003\205\002\162\000\000\000\000\003\218\003\205\003\205\003\205\bf\bj\bv\000\000\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\205\000\000\000\000\000\000\003\205\003\217\000\000\001\190\003\217\000\000\000\000\000\000\000\000\005\150\005\154\003\205\003\205\028F\003\217\003\205\003\205\000\000\003\217\b~\003\217\b\130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\217\018r\003\205\005\158\b\146\000\000\003\217\003\205\tz\004^\000\000\000\000\000\000\002\146\000\000\003\217\000\000\000\000\003\217\003\213\000\000\001\190\003\213\003\217\003\217\003\217\000\000\000\000\000\000\000\000\000\000\000\000\003\213\000\000\000\000\000\000\003\213\000\000\003\213\003\217\003\217\000\000\000\000\004\186\000\000\000\000\000\000\000\000\000\246\000\000\003\213\002\178\000\000\000\000\003\217\003\217\003\213\000\000\003\217\003\217\000\000\031\"\000\000\002\146\000\000\003\213\000\000\003b\003\213\000\000\003\217\000\000\000\000\003\213\003\213\003\213\000\000\003\217\000\000\003n\000\000\000\000\003\217\000\000\000\000\019\186\000\000\000\000\003\217\003\213\003\213\000\000\000\000\004\186\027r\000\000\000\000\020\030\001-\000\000\000\000\001-\0206\000\000\003\213\003\213\000\000\000\000\003\213\003\213\000\000\001-\000\000\001-\000\000\001-\000\000\001-\020>\000\000\003\213\000\000\030\210\000\000\000\000\000\000\000\000\003\213\000\000\001-\000\000\000\000\003\213\020R\020\142\001-\000\000\005E\003\213\001-\000\000\000\000\000\000\000\000\001-\000\000\000\000\001-\000\000\000\000\000\000\000\000\001-\001-\000\238\000\000\024\190\000\000\000\000\000\000\000\000\000\000\001-\000\000\000\000\000\000\000\000\000\000\001-\000\000\000\000\000\000\001-\000\000\000\000\000\000\000\000\001)\000\000\000\000\001)\000\000\000\000\001-\001-\001-\000\000\001-\001-\000\000\001)\000\000\001)\000\000\001)\000\000\001)\000\000\000\000\001-\000\000\000\000\000\000\000\000\000\000\000\000\001-\000\000\001)\000\000\000\000\000\000\000\000\000\000\001)\000\000\000\000\001-\001)\000\000\000\000\000\000\000\000\001)\000\000\000\000\001)\000\000\000\000\000\000\000\000\001)\001)\000\238\000\000\000\000\000\000\001Y\000\000\012\233\001Y\001)\000\000\000\000\000\000\000\000\000\000\001)\012\233\000\000\001Y\001)\001Y\000\000\001Y\000\000\001Y\000\000\000\000\000\000\000\000\000\000\001)\001)\001)\000\000\001)\001)\001Y\000\000\000\000\000\000\000\000\000\000\001Y\012\233\000\000\000\000\001)\000\000\000\000\012\233\000\000\000\000\000\000\001)\001Y\000\000\000\000\000\000\000\000\001Y\001Y\001Y\000\000\000\000\001)\001\029\000\000\002\t\001\029\000\000\000\000\000\000\000\000\000\000\000\000\001Y\002\t\000\000\001\029\012\233\001\029\000\000\001\029\000\000\001\029\000\000\000\000\000\000\000\000\000\000\001Y\001Y\001Y\000\000\001Y\001Y\001\029\000\000\000\000\000\000\000\000\000\000\001\029\002\t\000\000\000\000\000\000\000\000\000\000\002\t\000\000\000\000\000\000\001Y\001\029\000\000\000\000\000\000\000\000\001\029\001\029\001\029\000\000\000\000\001Y\001\169\000\000\017\250\001\169\000\000\002z\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\169\002\t\000\000\000\000\001\169\000\000\001\169\000\000\000\000\000\000\000\000\000\000\001\029\001\029\001\029\000\000\001\029\001\029\001\169\000\000\000\000\000\000\000\000\000\000\001\169\000\000\000\000\000\000\000\000\000\000\017\254\000\000\000\000\001\169\000\000\001\029\001\169\000\000\000\000\000\000\000\000\001\169\001\169\000\000\018\n\000\000\001\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\169\000\000\000\000\000\000\001\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\154\001\169\001\169\000\000\000\000\001\169\001\169\002\254\002\174\000\000\000\000\002z\000\000\006\214\000\000\000\000\002\230\001\169\000\000\000\000\000\000\005\214\000\000\003\242\001\169\000\000\001\194\000\000\006\246\000\000\000\000\000\000\000\000\003\002\000\000\001\169\b\206\000\000\000\000\000\000\000\000\000\000\000\000\000\000\026f\000\000\003\014\000\000\000\000\003\026\001\174\000\000\000\000\000\000\000\000\000\000\002\162\000\000\000\000\003\234\000\000\000\000\000\000\003\238\000\000\003\246\005~\t\n\005\138\000\000\000\000\000\000\000\000\000\000\000\000\002\254\002\174\000\000\000\000\002z\005\142\006\214\000\000\000\000\002\230\000\000\000\000\000\000\000\000\005\150\005\154\000\000\005\218\024\214\001\194\000\000\006\246\000\000\000\000\000\000\000\000\003\002\000\000\000\000\b\206\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006z\027&\003\014\005\158\000\000\b\250\001\174\b\182\000\000\004^\000\000\000\000\002\162\000\000\000\000\003\234\000\000\000\000\000\000\003\238\000\000\003\246\000\000\t\n\005\138\000\000\000\000\000\000\000\000\000\000\000\000\002\254\002\174\000\000\000\000\002z\005\142\006\214\000\000\000\000\002\230\000\000\000\000\000\000\000\000\005\150\005\154\000\000\000\000\r\026\001\194\000\000\006\246\000\000\000\000\000\000\000\000\003\002\000\000\000\000\b\206\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\025n\003\014\005\158\000\000\b\250\001\174\000\000\000\000\004^\000\000\000\000\002\162\005\t\000\000\003\234\005\t\000\000\000\000\003\238\000\000\003\246\000\000\t\n\005\138\000\000\005\t\000\000\000\000\000\000\005\t\007^\005\t\000\000\000\000\005\t\005\142\000\000\005\t\000\000\000\000\000\000\000\000\000\000\005\t\005\150\005\154\000\000\005\t\r\026\005\t\000\000\005\t\000\000\005\t\000\000\000\000\000\000\000\000\005\t\000\000\000\000\005\t\005\t\000\000\000\000\005\t\005\t\002\210\025\206\000\000\005\158\005\t\007\218\000\000\000\000\005\t\004^\b2\000\000\005\t\005\t\005\t\005\t\005\t\000\000\000\000\005\t\000\000\005\t\002\210\000\238\000\000\000\000\005\t\000\000\000\000\000\000\005\t\005\t\005\t\000\000\005\t\005\t\000\000\005\t\005\t\000\000\000\000\005\t\b\165\000\000\005\t\b\165\007\138\000\000\000\000\005\t\002\210\000\000\005\t\005\t\000\000\b\165\005\t\005\t\028>\b\165\000\000\b\165\000\000\000\000\005\t\005\t\000\000\000\000\005\t\000\000\000\000\000\000\000\000\b\165\000\000\005\t\000\000\000\000\000\000\b\165\005\t\005\t\000\000\b\165\005\t\005\t\005\t\000\000\b\165\000\000\000\000\b\165\007\238\000\000\000\000\000\000\b\165\b\165\000\238\000\000\000\000\000\000\000\000\005\t\000\000\b\165\b\165\b\161\024>\000\000\b\161\000\000\b\165\000\000\000\000\000\000\b\165\000\000\000\000\000\000\b\161\000\000\000\000\000\000\b\161\000\000\b\161\b\165\b\165\b\165\000\000\b\165\b\165\000\000\000\000\000\000\000\000\000\000\b\161\000\000\000\000\000\000\000\000\b\165\b\161\000\000\000\000\000\000\b\161\000\000\b\165\000\000\000\000\b\161\000\000\000\000\b\161\000\000\000\000\000\000\000\000\b\161\b\161\000\238\000\000\000\000\000\000\000\000\000\000\000\000\b\161\b\161\003\205\000\000\000\000\003\205\000\000\b\161\000\000\000\000\000\000\b\161\000\000\000\000\000\000\003\205\000\000\001\186\001\190\003\205\000\000\003\205\b\161\b\161\b\161\000\000\b\161\b\161\000\000\000\000\000\000\000\000\000\000\003\205\018\018\000\000\001\194\001\234\b\161\003\205\000\000\000\000\000\000\000\000\000\000\b\161\000\000\000\000\003\205\000\000\000\000\003\205\000\000\000\000\000\000\000\000\003\205\003\205\003\205\001\230\002\154\000\000\000\000\000\000\002\150\000\000\002\162\004\014\004\026\000\000\000\000\000\000\003\205\004&\004\241\004\241\003\205\000\000\004\241\000\000\000\000\000\000\000\000\004\241\000\000\000\000\000\000\003\205\003\205\004\241\004*\003\205\003\205\004\241\005\129\000\000\000\000\000\000\000\000\000\000\004\241\026\030\000\000\003\205\0266\000\000\000\000\000\000\000\000\018r\003\205\000\000\028\194\004\241\000\000\003\205\004\241\004\241\000\000\000\000\000\000\003\205\000\000\004\241\000\000\000\000\004\241\000\000\000\000\000\238\004\241\000\000\004\241\004\241\000\000\004\241\000\000\000\000\000\000\000\000\000\000\000\000\002\254\002\174\000\000\000\000\002z\004\241\000\000\000\000\000\000\002\230\000\000\000\000\000\000\000\000\004\241\004\241\t\217\000\000\000\000\001\194\000\000\000\000\000\000\000\000\000\000\000\000\003\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\003\014\004\241\000\000\003\026\001\174\000\000\000\000\004\241\003\205\000\000\002\162\003\205\000\000\003\234\000\000\000\000\000\000\003\238\000\000\003\246\005~\003\205\005\138\000\000\000\000\003\205\000\000\003\205\000\000\000\000\000\000\000\000\000\000\000\000\005\142\000\000\000\000\000\000\000\000\003\205\018\018\000\000\000\000\005\150\005\154\003\205\005\218\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\205\012\225\000\000\003\205\012\225\000\000\000\000\000\000\003\205\003\205\003\205\000\000\000\000\000\000\012\225\005\158\000\000\t\217\012\225\000\000\012\225\004^\000\000\000\000\003\205\000\000\005\173\000\000\003\205\000\000\000\000\000\000\012\225\000\000\000\000\000\000\000\000\000\000\012\225\003\205\003\205\028v\000\000\003\205\003\205\000\000\000\000\012\225\000\000\000\000\012\225\000\000\000\000\000\000\000\000\012\225\012\225\000\000\000\000\000\000\000\000\018r\003\205\000\000\000\000\000\000\000\000\003\205\000\000\000\000\000\000\012\225\000\000\002\254\002\174\012\225\000\000\002z\000\000\000\000\000\000\000\000\002\230\000\000\000\000\000\000\012\225\012\225\002r\006\142\012\225\012\225\001\194\000\000\000\000\000\000\000\000\000\000\000\000\003\002\000\000\000\000\012\225\000\000\000\000\000\000\0292\000\000\000\000\012\225\000\000\000\000\003\014\000\000\000\000\003\026\001\174\000\000\000\000\000\000\012\225\000\000\002\162\006\001\000\000\003\234\006\001\000\000\000\000\003\238\000\000\003\246\005~\000\000\005\138\000\000\006\001\000\000\000\000\000\000\006\001\000\000\006\001\000\000\000\000\000\000\005\142\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006\001\005\150\005\154\000\000\005\218\000\000\006\001\000\000\000\000\000\000\000\000\000\000\b2\000\000\000\000\006\001\000\000\000\000\006\001\006\005\000\000\000\000\006\005\006\001\006\001\000\238\000\000\005\158\000\000\006\198\000\000\000\000\006\005\004^\000\000\000\000\006\005\000\000\006\005\006\001\006\001\000\000\000\000\006\001\000\000\000\000\000\000\000\000\000\000\000\000\006\005\000\000\000\000\000\000\006\001\006\001\006\005\000\000\006\001\006\001\000\000\000\000\b2\000\000\000\000\006\005\003\205\000\000\006\005\003\205\000\000\000\000\000\000\006\005\006\005\000\238\000\000\006\001\000\000\003\205\000\000\000\000\000\000\003\205\000\000\003\205\000\000\000\000\006\001\006\005\006\005\000\000\000\000\006\005\000\000\000\000\000\000\003\205\018\018\000\000\000\000\000\000\000\000\003\205\006\005\006\005\000\000\000\000\006\005\006\005\000\000\006\169\003\205\000\000\006\169\003\205\000\000\000\000\000\000\000\000\003\205\003\205\003\205\000\000\006\169\000\000\000\000\006\005\006\169\000\000\006\169\000\000\000\000\000\000\000\000\000\000\003\205\000\000\006\005\000\000\003\205\000\000\006\169\000\000\000\000\000\000\000\000\000\000\006\169\000\000\000\000\003\205\003\205\020\158\000\000\003\205\003\205\006\169\000\000\000\000\006\169\000\000\000\000\000\000\000\000\006\169\006\169\000\238\000\000\000\000\000\000\000\000\000\000\018r\003\205\000\000\000\000\000\000\000\000\000\000\000\000\006\169\000\000\000\000\000\000\006\169\000\000\000\000\000\000\012\161\000\000\002\174\012\161\000\000\030\218\000\000\006\169\006\169\024b\030\222\006\169\006\169\012\161\000\000\000\000\000\000\000\000\000\000\012\161\000\000\000\000\000\000\006\169\000\000\000\000\000\000\000\000\000\000\000\000\006\169\012\161\000\000\000\000\000\000\000\000\000\000\012\161\002\254\002\174\000\000\006\169\002z\001\002\001\174\000\000\012\161\002\230\000\000\012\161\000\000\000\000\006\253\000\000\012\161\000\000\000\000\001\194\000\000\000\000\000\000\000\000\030\226\000\000\003\002\000\000\000\000\000\000\000\000\000\000\012\161\000\000\000\000\000\000\012\161\000\000\000\000\003\014\000\000\000\000\003\026\001\174\000\000\000\000\030\230\012\161\012\161\002\162\000\000\012\161\003\234\000\000\000\000\000\000\003\238\000\000\003\246\005~\000\000\005\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\161\000\000\000\000\005\142\000\000\000\000\b\213\b\213\000\000\000\000\b\213\000\000\005\150\005\154\000\000\b\213\000\000\000\000\000\000\000\000\000\000\018\186\000\000\000\000\000\000\b\213\000\000\000\000\000\000\000\000\000\000\000\000\b\213\007^\000\000\000\000\000\000\007\181\005\158\000\000\007\181\000\000\000\000\000\000\004^\b\213\000\000\000\000\b\213\b\213\007\181\000\000\000\000\000\000\007\181\b\213\007\181\000\000\b\213\000\000\000\000\000\000\b\213\001\173\b\213\b\213\001\173\b\213\007\181\000\000\000\000\000\000\000\000\000\000\007\181\007\218\001\173\000\000\000\000\b\213\001\173\000\000\001\173\007\181\000\000\000\000\007\181\000\000\b\213\b\213\000\000\007\181\007\181\000\238\001\173\000\000\000\000\000\000\000\000\000\000\001\173\000\000\000\000\000\000\000\000\000\000\000\000\007\181\000\000\001\173\000\000\007\181\001\173\000\000\b\213\000\000\000\000\001\173\001\173\000\000\b\213\000\000\007\181\007\181\000\000\000\000\007\181\007\181\000\000\000\000\000\000\000\000\000\000\001\173\000\000\000\000\000\000\001\173\006\173\000\000\000\000\006\173\000\000\000\000\000\000\007\181\000\000\000\000\001\173\001\173\000\000\006\173\001\173\001\173\000\000\006\173\000\000\006\173\000\000\000\000\000\000\000\000\000\000\000\000\001\173\000\000\000\000\000\000\000\000\006\173\000\000\001\173\000\000\000\000\000\000\006\173\024>\000\000\000\000\000\000\000\000\000\000\001\173\000\000\006\173\000\000\000\000\006\173\012\225\000\000\000\000\012\225\006\173\006\173\000\238\000\000\000\000\000\000\001\186\001\190\000\000\012\225\000\000\000\000\000\000\012\225\000\000\012\225\006\173\000\000\000\000\000\000\006\173\005\173\000\000\000\000\000\000\001\194\001\198\012\225\000\000\000\000\000\000\006\173\006\173\012\225\000\000\006\173\006\173\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\225\000\000\006\173\001\230\002\146\012\225\012\225\000\000\002\150\006\173\002\162\004\014\004\026\000\000\000\000\000\000\000\000\004&\000\000\018\022\006\173\012\225\000\000\000\000\001\186\002v\000\000\000\000\002z\000\000\000\000\000\000\000\000\000\000\004*\000\000\012\225\012\225\002r\000\000\012\225\012\225\000\000\001\194\001\234\001\214\002~\000\000\000\000\000\000\000\000\000\000\012\225\001\226\000\000\000\000\029j\000\000\000\000\012\225\000\000\000\000\000\000\000\000\000\000\000\000\002\130\002\138\000\000\000\000\012\225\002\150\000\000\002\162\004\014\004\026\000\000\000\000\000\000\000\000\024\022\000\000\024\026\001E\000\000\000\000\001E\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001E\004*\001E\000\000\001E\000\000\001E\000\000\000\000\000\000\000\000\005\154\000\000\000\209\000\000\000\000\000\209\000\000\001E\000\000\000\000\000\000\000\000\024&\001E\000\000\000\209\000\000\000\000\000\000\000\209\000\000\000\209\000\000\000\000\000\000\001E\000\000\000\000\000\000\024*\001E\001E\000\238\000\209\000\000\000\000\000\000\000\000\000\000\000\209\000\000\000\000\000\000\000\000\000\000\000\000\001E\000\000\000\209\000\000\000\000\000\209\000\000\000\000\000\000\000\000\000\209\000\209\000\238\000\000\000\000\001E\001E\001E\000\000\001E\001E\000\000\000\000\000\000\000\000\000\000\000\209\000\000\000\000\000\000\000\209\000\213\000\000\000\000\000\213\000\000\000\000\000\000\001E\000\000\000\000\000\209\000\209\000\000\000\213\000\209\000\209\000\000\000\213\001E\000\213\000\000\000\000\001\186\002v\000\000\000\000\002z\000\000\000\000\000\000\000\000\000\213\000\000\000\209\000\000\000\000\000\000\000\213\000\000\000\000\000\000\001\194\001\234\001\214\000\209\000\000\000\213\000\000\000\000\000\213\000\000\001\226\000\000\000\000\000\213\000\213\000\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\130\002\138\000\000\000\000\000\000\002\150\000\213\002\162\004\014\004\026\000\213\000\000\000\000\000\000\024\022\000\000\029\022\007\177\000\000\000\000\007\177\000\213\000\213\000\000\000\000\000\213\000\213\000\000\000\000\000\000\007\177\004*\000\000\000\000\007\177\000\000\007\177\000\000\000\000\000\000\000\000\005\154\000\000\000\000\000\213\000\000\000\000\000\000\007\177\000\000\000\000\000\000\000\000\029\"\007\177\000\213\000\000\000\000\000\000\000\000\000\000\000\000\000\000\007\177\006\161\000\000\007\177\006\161\000\000\000\000\024*\007\177\007\177\000\000\020z\000\000\000\000\006\161\000\000\000\000\000\000\006\161\000\000\006\161\000\000\000\000\000\000\007\177\000\000\000\000\000\000\007\177\000\000\000\000\000\000\006\161\000\000\000\000\000\000\000\000\000\000\006\161\007\177\007\177\019\206\007^\007\177\007\177\000\000\006\r\006\161\000\000\006\r\006\161\000\000\000\000\000\000\000\000\006\161\006\161\000\000\000\000\006\r\000\000\000\000\007\177\006\r\000\000\006\r\000\000\000\000\000\000\000\000\000\000\006\161\000\000\000\000\000\000\006\161\000\000\006\r\007}\007}\000\000\000\000\000\000\006\r\007\218\000\000\006\161\006\161\000\000\000\000\006\161\006\161\000\000\012Q\004\030\006\r\012Q\007}\007}\007}\006\r\006\r\000\238\000\000\000\000\000\000\012Q\007}\000\000\006\161\012Q\000\000\012Q\000\000\000\000\000\000\006\r\000\000\000\000\000\000\007}\007}\000\000\000\000\012Q\007}\000\000\007}\007}\007}\012Q\006\r\006\r\000\000\007}\006\r\006\r\000\000\000\000\012Q\004\225\000\000\012Q\004\225\000\000\000\000\000\000\012Q\000\000\000\000\000\000\007}\000\000\004\225\006\r\000\000\000\000\004\225\000\000\004\225\000\000\000\000\000\000\012Q\n\182\000\000\000\000\012Q\000\000\000\000\000\000\004\225\000\000\000\000\000\000\000\000\000\000\004\225\012Q\012Q\000\000\000\000\012Q\012Q\000\000\005\t\004\225\000\000\005\t\004\225\004\018\000\000\007}\000\000\004\225\000\000\000\000\000\000\005\t\000\000\000\000\012Q\005\t\000\000\005\t\000\000\000\000\000\000\000\000\000\000\004\225\000\000\r\014\000\000\004\225\000\000\005\t\000\000\000\000\000\000\000\000\000\000\005\t\000\000\000\000\004\225\004\225\000\000\0042\004\225\004\225\000\000\007\177\000\000\005\t\007\177\000\000\000\000\000\000\005\t\002\210\000\000\000\000\000\000\000\000\007\177\000\000\000\000\004\225\007\177\000\000\007\177\000\000\000\000\000\000\005\t\000\000\000\000\000\000\019\246\000\000\000\000\000\000\007\177\000\000\000\000\000\000\000\000\000\000\007\177\005\t\005\t\000\000\000\000\005\t\005\t\000\000\004\217\000\000\000\000\004\217\007\177\004>\000\000\000\000\000\000\007\177\007\177\000\000\000\000\004\217\000\000\000\000\005\t\004\217\000\000\004\217\000\000\000\000\000\000\000\000\000\000\007\177\000\000\000\000\000\000\000\000\000\000\004\217\000\000\000\000\000\000\000\000\000\000\004\217\000\000\000\000\007\177\007\177\019\206\000\000\007\177\007\177\004\217\000\000\000\000\004\217\000\000\000\000\000\000\000\000\004\217\000\000\004\249\000\000\000\000\004\249\021\014\000\000\000\000\007\177\000\000\000\000\000\000\000\000\000\000\004\249\004\217\000\000\000\000\004\249\004\217\004\249\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\217\004\217\004\249\000\000\004\217\004\217\000\000\000\000\004\249\000\000\000\000\000\000\000\000\004\201\000\000\000\000\004\201\004\249\000\000\000\000\004\249\000\000\000\000\004\217\000\000\004\249\004\201\000\000\000\000\000\000\004\201\000\000\004\201\000\000\022\246\000\000\000\000\000\000\000\000\000\000\000\000\004\249\000\000\000\000\004\201\004\249\000\000\000\000\000\000\000\000\004\201\000\000\000\000\b=\000\000\000\000\004\249\004\249\000\000\004\201\004\249\004\249\004\201\000\000\000\000\000\000\000\000\004\201\000\000\b=\b=\000\000\b=\b=\000\000\001\186\001\190\000\000\000\000\004\249\000\000\000\000\000\000\004\201\000\000\000\000\000\000\004\201\000\000\000\000\023\218\003\242\000\000\b=\001\194\001\234\001\214\000\000\004\201\004\201\000\000\000\000\004\201\004\201\001\226\000\000\000\000\000\000\000\000\000\000\000\246\b=\000\000\002\178\000\000\000\000\000\000\001\230\002\138\000\000\bI\004\201\002\150\003^\002\162\004\014\004\026\005\029\000\000\003b\000\000\004&\027F\b-\000\000\000\000\bI\bI\000\000\bI\bI\003n\b=\000\000\b=\000\000\000\000\019\186\004*\b-\b-\000\000\b-\b-\000\000\000\000\027r\000\000\005\242\020\030\bI\b=\b=\000\000\0206\bM\b=\000\000\b=\000\000\000\000\000\000\b=\b-\000\000\000\000\000\000\000\000\000\238\000\000\020>\bM\bM\000\000\bM\bM\000\000\004Z\000\000\004^\000\000\b-\000\000\000\000\000\000\020R\020\142\bA\000\000\005\029\005\029\000\000\000\000\000\000\000\000\bM\000\000\000\000\000\000\bI\000\000\bI\000\000\bA\bA\000\000\bA\bA\024\190\000\000\000\000\000\000\b-\000\238\b-\bI\000\000\000\000\005\250\bI\000\000\000\000\000\000\bI\000\000\bI\000\000\bA\b-\bI\000\000\005\250\b-\000\000\000\000\000\000\b-\000\000\b-\000\000\000\000\000\000\b-\000\000\bM\000\238\bM\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\bM\000\000\000\000\005\250\bM\001\186\001\190\025r\bM\000\000\bM\000\000\000\000\000\000\bM\000\000\bA\000\000\bA\000\000\000\000\000\000\000\000\000\000\001\194\001\198\001\214\000\000\000\000\000\000\000\000\000\000\006N\000\000\001\226\005\250\bA\000\000\000\000\000\000\bA\000\000\bA\001\186\001\190\025\210\bA\001\230\002\138\000\000\000\000\000\000\002\150\000\000\002\162\004\014\004\026\000\000\000\000\000\000\000\000\004&\001\194\001\198\001\214\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\226\000\000\000\000\000\000\000\000\000\000\004*\000\000\000\000\000\000\000\000\000\000\000\000\001\230\002\138\000\000\000\000\000\000\002\150\000\000\002\162\004\014\004\026\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\004*")) and lhs = - (8, "\014\r\012\011\n\t\b\007\006\005\004\003\002\001\000\235\235\234\234\233\232\232\231\231\231\231\231\231\231\231\231\231\230\230\229\228\227\227\227\227\227\227\227\227\226\226\226\226\226\226\226\226\225\225\225\224\224\223\222\222\222\221\221\220\220\220\220\220\220\219\219\219\219\219\219\219\218\218\218\218\218\217\217\217\217\216\215\214\214\214\214\213\213\213\213\212\212\212\211\211\211\211\210\209\209\209\208\208\207\207\206\206\206\205\205\205\205\205\205\205\205\205\204\204\203\203\203\203\203\203\203\203\203\203\203\202\202\201\201\200\199\198\197\196\196\195\195\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\194\193\193\192\191\191\191\191\190\190\190\190\189\189\188\187\187\187\187\187\187\186\185\184\184\183\183\182\182\181\180\180\179\178\178\177\176\175\175\175\174\174\173\172\172\172\172\172\172\171\171\171\171\171\171\171\171\170\170\169\169\169\169\169\169\168\168\167\167\167\166\166\165\165\165\165\164\164\163\163\162\162\161\161\160\160\159\159\158\158\157\157\156\156\155\155\154\154\154\153\153\153\153\152\152\151\151\150\150\149\149\149\149\149\148\148\148\148\147\146\146\145\145\145\144\144\144\144\144\144\144\143\143\143\143\143\143\143\142\142\141\141\140\140\140\140\140\140\139\139\138\138\137\137\136\136\135\135\134\133\133\133\132\132\131\131\131\131\131\131\131\131\131\130\130\129\128\128\128\128\128\128\128\128\128\128\127~}||{{{{{zyyxxwwwwwwwwwwwwwwvvuuttsssssssssssssssssssssssssssssssrrqqppoonnmmllkkjjiihhggffffffedcba`_^]\\[ZZZZZZZYYXXWWWWWVVVVVVUUTTTTTSSRRQPOONNNNNMMLLKKKJJJJJJIIIHHGGFFEEDDCCBBBAA@@??>>==<<;;::998877766655544433210000000000000000000/////....---------------------------------------------,,++++++++++++++++***************************************************))((''&&&&&&&&&&&&&&&&&%%$$#######\"\"\"\"!! \031\031\030\029\028\028\028\027\027\026\026\026\026\026\026\026\026\026\026\025\025\024\023\023\022\021\021\021\021\021\020\019\019\018\018\018\017\017\017\016\016\016\016\016\016\015\015") + (8, "\014\r\012\011\n\t\b\007\006\005\004\003\002\001\000\232\232\231\231\230\229\229\228\228\228\228\228\228\228\228\228\228\227\227\226\225\224\224\224\224\224\224\224\224\223\223\223\223\223\223\223\223\222\222\222\221\221\220\219\219\219\218\218\217\217\217\217\217\217\216\216\216\216\216\216\216\215\215\215\215\215\214\214\214\214\213\212\211\211\211\211\210\210\210\210\209\209\209\208\208\208\208\207\206\206\206\205\205\204\204\203\203\203\202\202\202\202\202\202\202\202\202\201\201\200\200\199\199\198\197\196\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\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\189\189\189\189\188\188\188\188\187\187\186\185\185\185\185\185\185\184\183\182\182\181\181\180\180\179\178\178\177\176\176\175\174\173\173\173\172\172\171\170\170\170\170\170\170\169\169\169\169\169\169\169\169\168\168\167\167\167\167\167\167\166\166\165\165\165\164\164\163\163\163\163\162\162\161\161\160\160\159\159\158\158\157\157\156\156\155\155\154\154\153\153\152\152\152\151\151\151\151\150\150\149\149\148\148\147\147\147\147\147\146\146\146\146\145\145\145\144\144\144\144\144\144\144\143\143\143\143\143\143\143\142\142\141\141\140\140\140\140\140\140\139\139\138\138\137\137\136\136\135\135\134\133\133\133\132\132\131\131\131\131\131\131\131\131\131\130\130\129\128\128\128\128\128\128\128\128\128\128\127~}||{{{{{zyyxxwwwwwwwwwwwwwwvvuuttsssssssssssssssssssssssssssssssrrqqppoonnmmlllkkjjiihhggffffffffffedcba`_^]\\[ZZZZZZZYYXXWWWWWVVVVVVUUTTTTTSSRRQPOONNNNNMMLLKKKJJJJJJIIIHHGGFFEEDDCCBBBAA@@??>>==<<;;::::::998877777766655544433210000000000000000000/////....----------------------------------------------,,++++++++++++++++***************************************************))((''&&&&&&&&&&&&&&&&%%$$#######\"\"\"\"!! \031\031\030\029\028\028\028\027\027\026\026\026\026\026\026\026\026\026\026\025\025\024\023\023\022\021\021\021\021\021\020\019\019\018\018\018\017\017\017\016\016\016\016\016\016\015\015") and goto = - ((16, "\001\228\001\139\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\000\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\153\001\000\000)\000s\0007\012\006\000\000\000\000\000S\001F\r\002\0004\001\192\r\142\000\000\000\000\000\000)n\000\\\002Z\000RH@\000\000\000\000\000\000\000\000\000\000\000\000\000\000C\014\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\198\002\196\001\190\000\000\000\000\000\000\000\000\000a\000\000\002\222\007\154\001\216\003>\000\130\002\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\002T\000\000\000\000\000\000\000\000\000\000\002\182\000\000\000\000\000\000\002\190\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000<\214\000\000\000\000\002\208\000\000\000\000\000\000\000\000\000\000\000\000\000\000B\220\002\242\000\000\002\212\003\142\002\146\000\000\000\000\003\188\000j\000\000\003\198\006\208\002\222\003\228\000\005\000\000\000\000\000\000\001f\000\000\000\000\000\031\000\000\000\000\000\000\000\000\004N\000\000\003T\000\000\000\000\000\000\000\000\000\000\000\006\000\000\000-\004\234\tR\000\000\r\170B\220\000\000#$\000\000\001N\000\000B\240\001\004\003P\b\140\000\000\000\000\000\000\003\186\0042\004\166\000\196\002&\004\240+\234\004X\005\020\000\216\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\024\000\000\000\000\000\000\004\142\005P\r\242\004\168\005\176\014\\\n.)n%\022\000\000,N\004\214\005\180\005\228\000\000%\212C\224D\158\000\000\000\203\000\000\000\000\000\000\005\216H(\005\246\000\000\0018\006&\000\000\002\244;\236\001\148\000\000\001\r\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\006t\005\170\000\000\000\000\000\000!\216\000\000\004\224\000\000\000\000\005\158Hr1`\000\000W\234\000\000\000\000\000\000\000\000\000\000\000\000\004\020\006\022\004\020\002\202\000\000\000\000\000\000\005x\000\000\000\000\000\000\000\000\006\b\000\000\000\000\004\020\000\000\000\000\000\000\000\000\000\000\006\250\004\230\n\252\000\000\000\000\0050\000\000\003\160\001\132\003 \001\022\012f\000\000\000\000VH\000\000V\134\012\014\000\000K\230\005xLp\005x\000\000\001t\000\007\000\000\006\190\003\160\000\000\000\000\0116\000\000\000\000\000\000\000\000\000\000\007R\003\160\b\254\003\160\000\000\000W\000\000\000\000\002\020\000\000\000\000\000\000\012\144\000\000\000\000\003\160\003\160\000\000\003\160\000\000\000\000\004\212\000\000\000^\002&\000\000\000^\000\000\t\188\003\160\000\000\000\000\000\000\000\000\000\000\000^\015\234%j\012N\011\248-X\004\176\000\0003v-\142\011>\007\026D\022\011@\007\192\0168\011N\007\202\016\158\011P\007\230<\134D\230\007\240\016\242\011\\\b\006,Z\000\000\022L\000\000\000\000\012$\n\194\004\020\000\000\017\166\011p\b8=T\000\000Er\000\000\000\000\011t\b\128L\228\007\240\017\198\011\128\b\132MF\007\240\018tG\236\000\000\000\000\000\000\000\000\000\000\002n\nN\000\000\000\000\000\000\011\196\b\134\005\196\000^\011p\003\160\000\000\000\000\000\000*\176\000\000Mj\005x\018\148\011\242\b\144L\024\000\000X\236\000\000\000\000&\030\012 \b\184=\162\000\000-\230.\138\000\000\000\000\r\132M\142\005xF\190\005xM\242\005x\000\000\000\000\000\000\000\000\000\000Y\166\000\000\000\000\000\000\001\170\019H\000\000\000\000\000\000.HY\184\000\000\000\000\000\000\000\000\000\000\012*\019\156\000\000\000\000\012.\020\002\000\000\000\000\012@.\252\012@/T\000\000Y\238\000\000/x\000\000/\208\000\0000$\000\0000\158\000\0001\020\000\0001\144\000\0001\228\000\0002<\000\0002\158\000\0003\020\000\0003l\000\0003\206\000\0004&\000\0004\136\000\0004\224\000\0005B\000\0005\154\000\0005\252\000\0006T\000\0006\182\000\0007\014\000\000\000\000\000\000\020P\004b\020\182\000\000\000\000\000\000\b\202=\222\000\000NP\005x\021\n\000\000\012n\021\190\000\000M\186\007\240O$\007\240OD\007\240\002\190\000\000\000\000\000\000\000\000OZ\007\240\000\000\000Q\004\216\000(O\208\007\240\021\222\000\000\012\170\012\182\t\020\012\238\r\188\014\188\003\160\000b\003\016\000\000\000\000\t:\r\186\r\208\000a\005\200\000^\014\246\003\160\006\000\000^\003\184\r\156\tR\r\222\000\020\0052\r\164\000\000\004\016\000\000\000\000\006\198\005d\000\000\005\144\003\160\005\240\001\148\rX\tn\t\030\000^\000\000\rd\t\130\007\\\000\000>\n\000\000\r\142\000\000O\164\005x\000\000\014\016\014\022\000\000\0078\000\000\005x\rt\t\132\005\246\000\000\000\000\000\000\000\000\000\000\r\152'z\000\203\000\000\000\000\000\000E\172\000\000V\236\000\000\t\144\000\000\t\158\000\000\000\000\000\000\000\000\002|\000\000\000\000\000\000\015\216\004\020\000\000\004\020\000?\000\000\000\000\000\000\000\000\t\164\b`\000\000\000\218\000\0004v\000\000\019\240\004\020\004\020\000\000\024\b\004\020\004\020\t\166\t>\000\000\000\000\b\184\r|\t\184\004\176\006L\b^\004\234\nv;\236\0038\000\000\000\000\000\000\006\222\r\164\t\186\000\000\r\174\006\222\000\000\014\152\tT\000\000\000\000\000\000\005x\000}\000\240\003Z\000\000\000\000\000\000\000\000\r\180\t\204\000\000\007\218\000\000\000\000\000\000\000\000\000\000\014\156\t\194\000\000\000\000\014\144\000\000\002L\001\022\000\000\000\000\000\000\000\000\b\140\014\244\011L\014\176\t\252\000\000\014\188\n\002\000\000\000\000\014\186\005\186\002\226\000\000X\000\r\206\r\210\t\220\005\136\n&\000\000\t\224\bv\n2\000\000\r\214\r\222\t\226\014\016\r\188\017>\003\160\000\000\t\242\014\136\000\000\b\212\nD\000\000\014\138\000\000\017\248\004\228\014R\nz\014\142\000\000\018\002\006R\014V\000\000\000\000\004T\nD\nl\000\000\018 \003\160\np\000\000\0064\000\000\014\006\n\138\019\014\006\182\000\000\014\014\n\142\b\132\r\152\014\022\014\026\n\180\015\146\000\000\0142\002\230\000\000\000\000\000\000\000\000\000\215\n\196\014\004O\184\005x\000\000\001\\\n\202\014\202\000\000\000\000\000\000\000\000\000\000\000\000P,\007j\000\000\n\210\015&\000\000\000\000\000\000\000\000\000\000\000\000>^\n\250\000\000\n\220\000\252\000\000\n\230\n\234\n\188\000\000\002\184E\208\000\000\002\238\000\000PP\005x\005x\000\000\000\000\007v\000\000\011b\000\000\0068\007v\007v\000\000\011\002@\018\005xP\182\005x\011\022\000\000\000\000\000\000\011L\000\000\000\000\001\248\000\000\bF\014\130\011D\015\160\014D\000\000\000\000\b\026\b\188\014\142\000\000\000\000\011`\015\174\014P\000\000\000\000\004f\000\000WP\000\000QN7|\005x\000\000Q\146Z,\000\000Q\186\000\000\000\000\000\000\007v\000\000\000\000\011j\014\152\011l\015\190\014^\000\000\000\000R\"\012\004\014\164\000\000\000\000\000\000X\168\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\b\000\000\014\178\011p\b\216\000\000\015\182\015j\012\026\014\194\000\000\000\000\014\198\011x\t6\000\000\000\000\011\170\015p\012*\014\210\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005x\014z\011z\015\236\014\148\000\000R\150\001\001\011\146\014b\004\132\000x\011\154\015(\000\000\015\226\022\140\000\000\000\000\022\172\000\000\0128\000\000\002N\000\000\000\000\000\000\000\000\000\000\000\000RJ\005x\000\000\015\234\023`\000\000\000\000\023\180\000\000\000\228\011\164\015\142\000\000>*>\252\015<\000\000Rf\005x\024\026\000\000\000\000\024h\000\000\000\000\002T\000\000\000\000\024\206\000\000\000\000\000\000\012V\000\000\007\214\000\000\000\000\000\000\000\000\000\000\000\000?(\000\000\000\000?\150@8\015>\000\000R\144\005x\025\"\000\000\000\000\025\214\000\000\000\000\011\178\025\246\012\\\000\000\011\192\012D\000\245\000\167\012R\t\030\012f\015\156@\172\012d\000\000\012j\012r\011\130\000\000\004XF4\000\000\003X\000\000\012z\026d\030|\007\156\014f\bT\000\0001\210Y\248\000\000\000\000\rD\000\000\000\000\000\000\007^\000\000\000\000\007^\000\000\000\000\007^\012\180\000\000\012R\007^\015\160@\182\012\200\000\000\007^\000\000SR\000\000\000\000\007^\000\000\000\000\012\244\000\000\012\182\007\196\r*\000\000\012|F\152\r.\000\000\000\000\000\000\r8\000\000\000\000\005z\000\000\007^S\140\000\000\014\148\007^W\024\000\000\r<\014\248\012\150\016 \014\194\000\000W\144\r@\015\006\000\000\000\000\000\000\n\216\n\012\012\154\015\190A \rH\000\000\000\000\000\000\000\000\000\000\000\000\012*\000\000\000\000\012.\000\000\rN\000\000\015\"\000\000\000\000\000\000\000\000\rXF\014\000\000\000\000\012*\000\000\012.\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\026\164\000\000\000\000\026\196\000\000\000\000\000\000\000\000&\130\000\000\000\000\000\000&\218\000\000'(\000\000\000\000'\142\000\000\000\000\000\000\000\000'\220\000\000\000\0007\178\000\000(4\000\000\000\0008(\000\000(\150\000\000\000\0008\128\000\000\006\020\027x\000\000\000\0008\186\000\000\027\204\000\000\000\00094\000\000\0282\000\000\000\0009n\000\000\000\000\000\000)\"\000\000\000\0009\194\000\000)\160\000\000\000\000:<\000\000)\214\000\000\000\000:v\000\000\000\000:\240\000\000\rD\000\000\000\000\000\000*.\000\000\000\000*\144\000\000\000\000\000\000\012n\028\128\000\000\000\000\028\230\000\000\0184\000\000\000\000G\236\000\000\000\000+^\000\000\000\000\000\000+\154\000\000\000\000\000\000\015\244\000\000\000\0000F\000\000\007\128\000\000\004<\015\146\000\000\b\002\000\000\000\000\000\000\000\000\000\000\002n\000\000\000\000\014\212\000\000\000\000\029:\000\000\029\238\000\000\000\000\000\000\030\014\000\000\000\000\030\188\014\214\030\220\000\000\031\144\000\000\000\000\000\000\000\000\031\228\000\000 J\000\000\000\000\000\000\000\000\000\000;D\000\000;~\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\164\t\154\000^ \152\000\000\014\222\012\178\015p\007\202\000\000 \254\000\000\014\226\012\218\t\\\015\004\012\232\000\000!R\000\000\000\000\000\000\000\000\000\000\000\000\000\000F\190\015\138\000\000S\244\005x\"\006\000\000\000\000T\b\005x\"&\000\000\000\000\"\212\000\000\000\000\r\138\000\000\000\000\000\000\000\000\000\000\000\000\014\234\012\244\n\004\000^\000\000\021V\003\160\000\000\016D\000\000\000\000\000\000\000\000A\200\000\000\000\000B:\000\000\000\000\000\000\022\022\003\160\000\000\0228\003\160\000\000\023&\003\160\000\000\007&\000\000\r\018\nd\007<\000\000\r\146W\166\000\000\000\000\000\000\000\000\r \000\000\r,\006\138\000\000\000\000\004\0203\188\000\000\000\000\000\000\000\000\000\000X\178\000\000\000\000\b\188\004b\000\000\000\000T\\\005x\005xT\160\005x\007\244\000\000\000\000\000\000\005x\000\000\000\000\000\000\015\232\000\208\t\158\r\164\004,\r4\000\000\000<\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\180\004\140\r\146\000\000\n~\014\244\000\000\015\236\006\012\002:\000\000\000\000\000\000\000^\003\160\000\000\014\b\000\000\000\000\000\000\003\160\000\000\007\240\000\000T\246\005x\000\000\007\000\000\000\000\000\000\000B\134\000\000\000\000B\162\000\000\"\244\000\000#\168\000\000\000\000#\252\000\000\000\000\000\000\000\000$b\000\000$\176\000\000\000\000\000\000\000\000\000\000.`\000\000\000\000\000\000\0000\002\192\000\000\000\000\000\000\000\000\000\000\007\248\002\192\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000g\000\000\000\000\000\000G\134\000\000\005x\000\000\011\254\000\000\000\000\000\000\002\138\000\000\000\000\000\000\003\"\000\000\000\000\000\000\004\150\000\000\000^\000\000\000\145\000\000\003\160\000\000\000\147\000\000\000\000\000\000G\208\007\240\000\000\000\000\004\228\000\000\000\000\000\000\000\000\002n\005\020\015 \001\238\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r\166\000\000\014\024\000\000\000\000\000\000\000\000\005d\007 JPU\128\000\000\000\000\014>U\142\000\000\000\000\000\000\014PU\252\000\000\000\000\000\000\000\000"), (16, "\005V\001\017\002f\002g\001m\000;\000\227\001\021\006\167\000\231\000\232\000\188\000\227\003\144\000\193\000\231\000\232\002\138\005W\005n\007 \005^\007\028\003S\000\188\002\139\006\187\001\254\001\015\000\188\005_\005o\000\197\000\227\001\021\001\024\000\231\001\002\002\162\005\017\005V\003\018\002f\002g\001m\005\017\000\194\001\003\006\245\007\004\0007\000\227\007!\001\237\000\231\000\232\007\029\002\138\005W\005n\005`\005^\002\005\002\005\005r\002\139\002\t\002\t\001\021\001\021\005_\005o\001\005\005\019\003^\003`\003b\001\237\002\162\005\019\006\203\004\180\006\229\003j\005\017\003\031\000\231\002\005\000\149\001m\005\020\002\t\002\018\001\021\0043\005\027\005\020\005a\001\021\005D\005`\005\027\002\164\003j\005r\0050\000\231\005b\0044\002\n\002\n\003\018\004K\001\015\002j\005|\002\166\000\231\005\019\001\021\001)\001\\\002\001\003\150\003\151\006\246\005s\002\173\003\018\002\011\003\018\000@\002\005\005t\002\n\005\020\002\t\005a\001\021\001\029\005\027\003'\002\164\003$\005+\000?\003\167\005b\005u\002+\003\160\003~\000\234\002\011\002j\002\"\002\166\000\231\005h\006\247\007\005\000D\001\145\005j\006\254\001\021\005s\002\173\0007\003c\0007\002\177\0007\005t\002\178\001_\003q\005l\006\175\002\n\003m\002\167\001\145\002\233\006\196\006\176\001\029\002-\005u\001\030\000\231\002\183\001@\001\145\002\169\003\144\005m\001\029\005h\003'\002\"\000\234\0035\005j\003\020\000\188\006\255\000\198\001\254\006\227\002\022\002\177\001A\001 \002\178\002\185\006\177\005l\004\182\001Y\003\018\002\167\005V\002\233\002f\002g\001m\001\"\000G\006{\006\178\002\183\002-\001\145\002\169\000\231\005m\007\000\000:\002\138\005W\005n\000\227\005^\001#\000\231\000\232\002\139\000N\005z\001\021\001)\005_\005o\002.\002\185\007\001\004\221\002\023\001&\002\162\001\015\005V\006\210\002f\002g\001m\001\021\001\024\0074\002g\001m\004\223\000\227\001\"\002,\000\231\001\002\001F\002\138\005W\006\234\005`\005^\001s\001\"\005r\002\139\000\234\006\179\006\180\001#\005_\005o\003\177\001\159\001m\001\021\001)\002.\002\162\000b\001#\006\181\006\182\003\150\003\151\001+\001\021\001)\001,\006\145\001\242\004\187\001-\001.\006\183\003~\003w\005a\002\016\000E\005`\000\231\002\164\003\178\004D\0043\003\159\005b\004\215\000\233\003\160\003~\005\248\001m\002j\001\015\002\166\000\231\003z\0044\000\234\001\021\001\024\004;\0015\005\132\005s\002\173\000\231\001\002\004F\000f\001+\005t\0009\001,\000=\005a\000\211\001-\001.\001P\002\164\001+\003\018\003\176\001,\005b\005u\004H\001-\001.\002\252\001m\002j\002\"\002\166\000\231\005h\0075\000H\002\166\000\231\005j\005\146\001/\005s\002\173\0019\000\234\002\"\002\177\004I\005t\002\178\000\188\006\141\005l\000\193\002\021\004\216\002\167\004J\002\233\002&\001\021\001\029\002-\005u\001\030\000\231\002\183\001@\001\145\002\169\001\025\005m\004\191\005h\002/\007\016\006\236\002-\005j\000\188\000\231\001\241\001\254\004F\005v\004\003\002\177\001A\001 \002\178\002\185\000m\005l\006\193\001W\003S\002\167\005V\002\233\002f\002g\001m\004H\003\018\001t\000\234\002\183\001\237\001\145\002\169\006\197\005m\000O\007\017\002\138\005W\005n\002\005\005^\001\021\000\146\002\t\002\139\001\021\006\177\004I\003\018\005_\005o\002.\002\185\000\129\003\179\003\180\001&\002\162\001\015\005V\006\178\002f\002g\001m\001\021\001\024\002.\001\015\003a\003`\003b\001\"\007\020\001\021\001\024\001F\002\138\005W\005n\005`\005^\003\160\003~\006\133\002\139\001\015\002\n\000c\001#\005_\005o\001\021\001\024\001\237\001\021\001)\002\030\002\162\001\237\003\194\000k\002\028\000\133\002\005\000\234\002\011\000\137\002\t\002\005\001\021\007\021\003S\002\t\000\231\001\021\001\237\005a\000\156\002\027\005`\003\018\002\164\003\019\005x\0043\002\005\005b\0014\003S\002\t\003\178\001\021\003\018\002j\000\163\002\166\000\231\000\227\0044\000\165\000\231\000\232\0045\0015\000\175\005s\002\173\0013\000n\004\215\002\n\001+\005t\000\192\001,\002\n\005a\000\234\001-\001.\001P\002\164\003\137\003`\003b\004/\005b\005u\001\029\002\011\000\234\004c\002\n\002j\002\011\002\166\000\231\005h\0007\003\156\003`\003b\005j\000\191\001/\005s\002\173\0019\000\166\001\233\002\177\002\011\005t\002\178\003\213\001 \005l\002f\002g\001m\002\167\000\188\002\233\003\181\001\254\000\227\003 \005u\000\231\001\002\002\183\000\170\001\145\002\169\001h\005m\000\173\005h\000\234\001\180\005\234\005\238\005j\007(\002g\001m\005\012\005\242\003(\001\029\002\177\000\176\001\015\002\178\002\185\003\169\005l\0007\001\021\001)\002\167\004e\002\233\003j\001\005\005V\000\231\002f\002g\001m\002\183\006!\001\145\002\169\006}\005m\001\"\007\024\000\234\0077\0078\003\239\002\138\007:\002\"\000\227\005^\002\004\000\231\000\232\002\139\001\015\001\233\001#\002\185\005_\007<\001\021\001\024\001\021\004h\000\234\003\018\002\162\003'\005V\000\234\002f\002g\001m\007K\003j\007*\007\025\000\231\002\"\002-\002i\005\017\000\231\007C\000\234\002\138\007D\005=\005`\005^\002 \002\026\005\245\002\139\002\166\000\231\001\002\000\218\005_\007L\001\"\003\241\001\015\006\173\003\018\001\145\002\162\002#\001\021\001)\002-\000\219\0007\000\231\005?\005\019\000\224\001#\007+\001+\002\166\000\231\004i\001\021\001)\005a\001-\001.\005`\003\018\002\164\005\237\005\020\005A\006\153\005b\0044\005\027\004n\003\224\004k\005\"\002j\000\239\002\166\000\231\002.\001\237\000\222\002\231\001\238\006\185\001/\001\145\005s\002\173\000\242\002\005\007?\002\167\0007\002\t\005B\001\021\003\193\005a\000\225\001\029\000\235\002\168\002\164\001\145\002\169\001\235\002\026\005b\005u\002.\003%\000\250\001+\000\234\002j\001,\002\166\000\231\005h\001-\001.\000\253\000\188\005j\003\132\001\254\005s\002\173\000\240\007P\002\"\002\177\002\"\003\200\002\178\003,\002\n\005l\006\192\001\021\003\005\002\167\005C\002\233\002\004\001>\001\029\001a\005u\001\030\000\234\002\183\001@\001\145\002\169\002\011\005m\001\029\005h\002s\002\"\003\026\002-\005j\002-\000\231\001\t\000\231\000\234\005?\000\234\002\177\001A\001 \002\178\002\185\000\243\005l\000\251\001B\003\018\002\167\005V\002\233\002f\002g\001m\001\"\005A\003\030\001\012\002\183\002-\001\145\002\169\000\231\005m\001\028\000\234\002\138\005W\006\194\005\179\005^\001#\000\231\001\002\002\139\003\179\003\180\001\021\001)\005_\005o\001=\002\185\003\242\005B\0018\001&\002\162\001\015\005V\001O\002f\002g\001m\001\021\001\024\002.\003\018\002.\003.\001M\001\"\003\160\003~\007C\001F\002\138\007D\005\196\005`\005^\001<\001\"\000\234\002\139\000\234\006\179\006\180\001#\005_\007G\003\230\0039\001m\001\021\001)\002.\002\162\001e\001#\006\181\006\182\003O\003~\001+\001\021\001)\001,\006\140\001|\003\241\001-\001.\006\183\003~\001\237\005a\0030\002\003\005`\004z\002\164\001I\003\018\0043\002\005\005b\003+\001\221\002\t\000\234\001\021\003\018\002j\003\018\002\166\000\231\0011\0044\005\236\000\234\003\247\004:\0015\002+\005s\002\173\004\228\004{\006\201\004|\001+\005t\001\223\001,\002+\005a\003\018\001-\001.\001P\002\164\001+\003\018\002\004\001,\005b\005u\000\234\001-\001.\006\252\002\n\002j\006\211\002\166\000\231\005h\001\232\000\234\004}\0053\005j\003'\001/\005s\002\173\0019\007J\001\237\002\177\002\011\002\r\002\178\002;\006\141\005l\006|\000\234\002\005\002\167\005?\002\233\002\t\005\241\001\021\003E\005u\006\128\004\232\002\183\001^\001\145\002\169\002\004\005m\004~\005h\003\141\003~\005A\000\227\005j\000\234\000\231\001\002\004\127\004\128\003\172\004\129\002\177\004\024\0057\002\178\002\185\000\227\005l\004<\000\231\000\232\002\167\005V\002\233\002f\002g\001m\002\n\001\175\000\234\005B\002\183\003\190\001\145\002\169\004\158\005m\003S\0066\002\138\005W\005\237\001d\005^\004z\000\234\002\011\002\139\003\018\005\017\003S\002,\005_\006\129\001\029\002\185\006\154\001\030\002>\004\131\002\162\003\018\002,\002A\004\133\004\143\000\188\000\227\004\136\001\254\000\231\001\002\004{\004\157\004|\001l\001m\002D\004\154\005\029\001\015\001 \005`\005\019\006S\0018\001\021\001\024\003\164\003`\003b\0046\006V\002J\003'\001n\002K\004\155\001p\001q\005\020\006\161\003`\003b\004}\005\027\005\237\003\018\000\227\005\031\006\253\000\231\000\232\000\188\001\015\004\146\001\254\0007\002V\005a\001\021\001)\004L\002L\002\164\001\173\003\204\001&\000\234\005b\005\029\001\029\001\021\000\234\001\030\003o\002j\001\015\002\166\000\231\004~\005\017\001\"\001\021\001)\001{\0043\000\234\005s\002\173\004\127\004\128\001\132\004\129\002]\006\132\002b\002r\001 \001#\0044\001\015\002\128\000\234\004S\001\021\001)\001\021\001)\001\141\005u\001\140\003\018\003\218\001u\005\019\003\144\002\"\004\158\001\021\005h\004T\002\136\003\018\001\237\005j\001v\002\015\000\234\000\231\001\179\002\236\005\020\002\177\002\005\0046\002\178\005\027\002\t\005l\001\021\005\028\004\131\002\167\001&\002\233\0034\004\133\004\143\002-\003\251\003~\000\231\002\183\0015\001\145\002\169\001\190\005m\001\"\006\166\004\154\001+\002M\000\234\001,\000\234\000\234\003\r\001-\001.\004\159\000\234\002f\002g\001m\001#\002\185\003\018\002\"\004\155\002\n\001\021\001)\004\214\004\220\003}\003\022\002\138\002f\002g\001m\000\234\001\135\0046\001/\002\139\003\149\0019\003\"\002\011\000\234\006f\001\144\002\138\001\145\001t\003\018\006/\002\162\003\018\002-\002\139\0033\000\231\001\195\002.\001\029\005\220\001\237\001\030\006\189\002)\0038\003I\002\162\003\150\003\151\003\018\002\005\003Z\0015\002\"\002\t\003\018\001\021\006D\003\\\000\234\001+\003n\003|\001,\003\018\001 \004\255\001-\001.\003\152\003\168\003\130\003\143\003\171\003\160\003~\001\029\005V\000\234\006<\003~\003\162\006a\003\144\003\018\002-\003\018\000\146\000\231\003\199\000\234\003\203\003\209\001/\002\164\005W\0019\002\n\005^\002.\003\215\002\"\003\186\000\146\000\234\003\189\002j\005_\002\166\000\231\002\164\001&\006\171\003~\000\234\000\234\002\011\003\235\002\170\002\173\000\231\000\234\002j\003\201\002\166\000\231\001\"\003\147\000\234\003\205\006\127\000\234\000\234\002-\002\170\002\173\000\231\005`\003\219\001\209\002\174\000\234\000\234\001#\001\206\001\029\001\212\001\015\001\030\001\021\001)\000\234\002.\001\021\001)\003\018\002\174\005Y\003\236\000\234\003\240\000\234\000\234\002\177\001\"\006-\002\178\001\220\003\226\003\018\000\234\001\226\001 \002\167\005a\002\233\003\245\004*\003\250\002\177\000\231\001#\002\178\002\183\005b\001\145\002\169\001\021\001)\002\167\003\144\002\233\001\029\003\150\003\151\001\030\003\018\003\255\0015\002\183\002.\001\145\002\169\005c\002\173\004\t\001+\002\185\004\015\001,\005e\003\018\004\026\001-\001.\003\152\003\168\004%\001&\001 \003\160\003~\0047\002\185\004)\005f\002f\002g\001m\004#\002f\002g\001m\001\"\003\184\005h\004>\003\144\000\234\001/\005j\002\138\0019\004C\001+\002\138\000\234\001,\000\234\002\139\001#\001-\001.\002\139\005l\007\012\001\021\001)\001\237\006\223\0048\002u\002\162\000\231\001\234\001&\002\162\000\234\002\005\004N\004G\001\247\002\t\005m\001\021\000\234\005\007\002Q\000\234\000\231\001\"\004\149\000\234\004X\001\249\004o\002\b\000\234\003\018\004q\003\018\004\135\000\234\002\025\000\234\004\145\004\162\001#\006(\003\018\003\150\003\151\007\014\001\021\001)\0015\000\234\003\018\004\168\006$\002:\002=\004\172\001+\003\018\002\n\001,\004\200\002@\002C\001-\001.\003\152\003\168\004\246\002I\002\164\003\160\003~\003\018\002\164\0055\003\018\002R\002\011\002U\003\018\002\\\002j\000\234\002\166\000\231\002j\002a\002\166\000\231\001/\003\150\003\151\0019\002\170\002\173\0015\000\234\002\170\002\173\002f\002g\001m\000\234\001+\000\234\004w\001,\004\132\000\234\000\234\001-\001.\003\152\003\168\002\138\002\174\004\140\003\160\003~\002\174\002q\000\234\002\139\000\227\004\151\000\234\000\231\000\232\006\216\003\018\000\234\004\181\002f\002g\001m\002\162\001/\000\234\002\177\0019\004\251\002\178\002\177\002\127\000\234\002\178\004\222\005'\002\167\004\248\002\233\003\018\002\167\005\003\002\233\005\023\005\017\005\000\002\183\005#\001\145\002\169\002\183\005\006\001\145\002\169\002\135\005\014\005:\002f\002g\001m\005$\000\227\002\149\000\231\000\231\000\232\003\018\005V\003\018\005N\002\185\005Z\002\138\003\018\002\185\003\018\006.\003\018\005\019\001\029\002\139\003\018\001\030\0064\003\018\007:\006\213\002\164\005^\003\018\005d\005*\005g\002\162\005\017\005\020\002\227\005_\000\234\002j\005\027\002\166\000\231\006;\005&\000\234\001 \002f\002g\001m\006>\002\170\002\173\0054\003\018\000\234\006`\000\234\003\018\002\253\002i\000\234\002\138\003\021\003\144\000\234\000\234\005`\005\019\003\012\002\139\006~\002j\002\174\002\166\000\231\006m\003\014\006\136\000\234\0058\000\234\005<\002\162\006\138\005\020\000\234\005@\006\174\005L\005\027\005S\001&\000\234\0056\005]\002\177\002\164\005i\002\178\002f\002g\001m\005p\005a\003\017\002\167\001\"\002\233\002j\005\025\002\166\000\231\000\234\005b\002\138\002\183\003\018\001\145\002\169\000\234\002\170\002\173\002\139\001#\003\018\000\234\003*\006X\006j\001\021\001)\006\130\005c\002\173\006\186\002\162\007;\003\024\002\167\002\185\000\234\003)\002\174\003\018\003#\003&\002\164\000\234\002\168\0032\001\145\002\169\003\018\000\234\005f\0037\003=\000\234\002j\003D\002\166\000\231\003C\003H\005h\002\177\003{\003\129\002\178\005j\002\170\002\173\003\142\003\150\003\151\002\167\003\146\002\233\0015\003\148\003\161\003\170\003\175\005l\003\187\002\183\001+\001\145\002\169\001,\006\200\003\185\002\174\001-\001.\006\164\006\165\003\188\007=\002\164\003\160\003~\005m\003\192\000\234\002f\002g\001m\003\202\002\185\003\198\002j\003\214\002\166\000\231\002\177\003\208\007H\002\178\001/\002\138\003\210\0019\002\170\002\173\002\167\007M\002\233\002\139\003\233\003\221\003\232\003\227\003\231\006C\002\183\003\244\001\145\002\169\000\227\003\249\002\162\000\231\000\232\004W\002\174\003\254\002f\002g\001m\001\237\004\001\004\005\003\016\004\r\004\020\004\031\004V\004O\002\185\002\005\004P\002\138\004U\002\t\004Y\001\021\004Z\002\177\004y\002\139\002\178\005\017\004r\004s\004x\006A\004\142\002\167\001\237\002\233\004\138\003\028\002\162\004\139\004\141\004\153\004\150\002\183\002\005\001\145\002\169\004\152\002\t\004\161\001\021\004\163\001\029\002f\002g\001m\004\164\004\169\004\173\004\177\002\164\005\019\002\n\004\195\004\201\004\205\004\236\002\185\002\138\005\001\005\030\005(\002j\005U\002\166\000\231\002\139\005O\005\020\005P\005T\002\011\006,\005\027\002\170\002\173\005[\005H\005k\002\162\005\231\002\n\002f\002g\001m\005\239\005\252\006\007\006&\0063\0065\006:\002\164\006=\006I\006_\002\174\002\138\006h\006\169\002\011\006\191\007/\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\006\027\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001\"\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\001#\002\138\000\000\000\000\000\000\000\000\001\021\001)\002j\002\139\002\166\000\231\000\000\000\000\002\177\006\021\002\185\002\178\000\000\000\000\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\006\r\002\185\002\170\002\173\000\000\000\000\001+\002\162\002\177\001,\000\000\002\178\000\000\001-\001.\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003e\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\177\000\000\000\000\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\002\174\002\138\002f\002g\001m\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\000\000\002\185\002\138\000\000\000\000\002\170\002\173\002\162\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\006\001\000\000\002\167\000\000\002\233\000\000\001\237\002\162\000\000\003\212\000\000\002\174\002\183\000\000\001\145\002\169\002\005\000\000\000\000\000\000\002\t\000\000\001\021\000\000\000\000\000\000\000\000\001\198\001m\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\185\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\001n\002z\000\000\001p\001q\000\000\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\002\n\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\164\000\000\002\138\002f\002g\001m\000\000\002\185\002\170\002\173\002\139\002\011\002j\000\000\002\166\000\231\005\249\000\000\002\138\005\210\002\254\002\255\000\000\002\162\002\170\002\173\002\139\000\000\001\237\000\000\002\174\003\223\005\209\001\237\000\000\000\000\003\229\000\000\002\005\002\162\000\000\000\000\002\t\002\005\001\021\000\000\002\174\002\t\001\237\001\021\000\000\003\238\000\000\004\218\000\000\001\133\002\178\006\012\002\005\000\000\000\000\000\000\002\t\002\167\001\021\002\233\000\000\001v\000\000\002\177\000\231\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\n\000\000\002\164\000\000\002\183\002\n\001\145\002\169\002f\002g\001m\000\000\002\185\005\217\002j\000\000\002\166\000\231\002\164\002\011\002\n\000\000\000\000\002\138\002\011\000\000\002\170\002\173\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\002\160\000\000\002\011\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\002\174\001\135\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\002\172\000\000\002\167\001\237\002\233\000\000\003\246\002\162\002\177\000\000\000\000\002\178\002\183\002\005\001\145\002\169\000\000\002\t\002\167\001\021\002\233\001\029\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\185\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\002\176\002\185\002\170\002\173\000\000\000\000\000\000\002\162\000\000\002\n\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\002\174\002\138\000\000\000\000\002\011\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\002\234\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001\"\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\001#\002\138\000\000\000\000\000\000\000\000\001\021\001)\002j\002\139\002\166\000\231\000\000\000\000\002\177\002\232\002\185\002\178\000\000\000\000\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\002\241\002\185\002\170\002\173\000\000\000\000\001+\002\162\002\177\001,\000\000\002\178\000\000\001-\001.\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003u\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\177\000\000\000\000\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\002\174\002\138\002f\002g\001m\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\002\244\002\185\002\138\000\000\000\000\002\170\002\173\002\162\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\003\t\000\000\002\167\000\000\002\233\000\000\001\237\002\162\000\000\006d\000\000\002\174\002\183\000\000\001\145\002\169\002\005\000\000\000\000\000\000\002\t\000\000\001\021\000\000\000\000\000\000\000\000\001l\001m\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\185\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\001n\002K\000\000\001p\001q\000\000\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\002\n\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\164\000\000\002\138\002f\002g\001m\000\000\002\185\002\170\002\173\002\139\002\011\002j\000\000\002\166\000\231\004\176\000\000\002\138\000\000\000\000\000\000\000\000\002\162\002\170\002\173\002\139\000\000\000\000\000\000\002\174\001\237\004\179\000\000\006s\000\000\000\000\000\000\000\000\002\162\000\000\002\005\000\000\000\000\000\000\002\t\002\174\001\021\001\237\000\000\000\000\006v\000\000\002\177\000\000\001u\002\178\000\000\002\005\000\000\000\000\000\000\002\t\002\167\001\021\002\233\000\000\001v\000\000\002\177\000\231\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\000\000\000\000\002\164\002\n\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\002\185\000\000\002j\000\000\002\166\000\231\002\164\002M\002\n\000\000\002\011\002\138\000\000\000\000\002\170\002\173\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\004\194\000\000\002\011\000\000\002N\002\170\002\173\002\162\000\000\000\000\000\000\002\174\001\135\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\001\144\000\000\001\145\001t\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\004\197\000\000\002\167\001\237\002\233\000\000\006y\002\162\002\177\000\000\000\000\002\178\002\183\002\005\001\145\002\169\000\000\002\t\002\167\001\021\002\233\001\029\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\185\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\004\209\002\185\002\170\002\173\000\000\000\000\000\000\002\162\000\000\002\n\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\002\174\002\138\000\000\000\000\002\011\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\004\212\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001\"\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\001#\002\138\000\000\000\000\000\000\000\000\001\021\001)\002j\002\139\002\166\000\231\000\000\000\000\002\177\000\000\002\185\002\178\000\000\000\000\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\004\240\002\185\002\170\002\173\000\000\000\000\001+\002\162\002\177\001,\000\000\002\178\000\000\001-\001.\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003y\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\177\000\000\000\000\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\002\174\002\138\002f\002g\001m\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\004\243\002\185\002\138\000\000\000\000\002\170\002\173\002\162\004\218\000\000\002\139\002\178\004\219\000\000\000\000\000\000\004\247\000\000\002\167\000\000\002\233\000\000\000\000\002\162\000\000\000\000\000\000\002\174\002\183\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001m\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\185\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\001n\002K\000\000\001p\001q\000\000\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\164\000\000\002\138\002f\002g\001m\000\000\002\185\002\170\002\173\002\139\000\000\002j\000\000\002\166\000\231\005\127\000\000\002\138\000\000\000\000\000\000\000\000\002\162\002\170\002\173\002\139\000\000\000\000\000\000\002\174\000\000\005\130\000\000\000\000\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\000\000\000\000\000\000\002\174\000\000\000\000\000\000\000\000\000\000\000\000\002\177\000\000\001u\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\001v\000\000\002\177\000\231\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\000\000\000\000\002\164\000\000\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\002\185\000\000\002j\000\000\002\166\000\231\002\164\005\015\000\000\000\000\000\000\002\138\000\000\000\000\002\170\002\173\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\005\165\000\000\000\000\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\002\174\001\135\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\001\144\000\000\001\145\001t\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\002\177\005!\002\139\002\178\000\000\000\000\000\000\000\000\005\170\000\000\002\167\000\000\002\233\000\000\000\000\002\162\002\177\000\000\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\185\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\005\175\002\185\002\170\002\173\000\000\000\000\000\000\002\162\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\005\212\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\002\177\005\215\002\185\002\178\000\000\000\000\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\005\253\002\185\002\170\002\173\000\000\000\000\000\000\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\177\000\000\000\000\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\002\174\002\138\002f\002g\001m\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\005\255\002\185\002\138\000\000\000\000\002\170\002\173\002\162\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\006\003\000\000\002\167\000\000\002\233\000\000\000\000\002\162\000\000\000\000\000\000\002\174\002\183\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001m\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\185\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\001n\002K\000\000\001p\001q\000\000\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\164\000\000\002\138\002f\002g\001m\000\000\002\185\002\170\002\173\002\139\000\000\002j\000\000\002\166\000\231\006\006\000\000\002\138\000\000\000\000\000\000\000\000\002\162\002\170\002\173\002\139\000\000\000\000\000\000\002\174\000\000\006\b\000\000\000\000\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\000\000\000\000\000\000\002\174\000\000\000\000\000\000\000\000\000\000\000\000\002\177\000\000\001u\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\001v\000\000\002\177\000\231\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\000\000\000\000\002\164\000\000\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\002\185\000\000\002j\000\000\002\166\000\231\002\164\005\015\000\000\000\000\000\000\002\138\000\000\000\000\002\170\002\173\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\006\n\000\000\000\000\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\002\174\001\135\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\001\144\000\000\001\145\001t\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\002\177\005 \002\139\002\178\000\000\000\000\000\000\000\000\006\015\000\000\002\167\000\000\002\233\000\000\000\000\002\162\002\177\000\000\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\185\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\006\018\002\185\002\170\002\173\000\000\000\000\000\000\002\162\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\0061\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\002\177\0068\002\185\002\178\000\000\000\000\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\006@\002\185\002\170\002\173\000\000\000\000\000\000\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\001\029\002\177\000\000\001\030\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\001 \000\000\002\174\002\138\002f\002g\001m\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\006M\002\185\002\138\000\000\000\000\002\170\002\173\002\162\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\006R\000\000\002\167\000\000\002\233\000\000\000\000\002\162\000\000\000\000\000\000\002\174\002\183\001&\001\145\002\169\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\002\177\000\000\002\185\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001#\002\233\000\000\000\000\000\000\000\000\001\021\001)\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\164\000\000\002\138\002f\002g\001m\000\000\002\185\002\170\002\173\002\139\000\000\002j\000\000\002\166\000\231\006U\000\000\002\138\000\000\000\000\000\000\000\000\002\162\002\170\002\173\002\139\000\000\000\000\001?\002\174\000\000\006\220\000\000\000\000\001\029\000\000\001+\006\147\002\162\001,\000\000\000\000\000\000\001-\001.\002\174\000\000\000\000\000\000\000\000\000\000\000\000\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\001 \002\167\000\000\002\233\000\000\000\000\000\000\002\177\001/\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\000\000\000\000\002\164\000\000\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\002\185\000\000\002j\000\000\002\166\000\231\002\164\000\000\000\000\000\000\000\000\002\138\000\000\000\000\002\170\002\173\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\006\222\001\"\000\000\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\002\174\000\000\002f\002g\001m\000\000\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\002\177\000\000\002\139\002\178\000\000\000\000\000\000\000\000\006\225\000\000\002\167\000\000\002\233\000\000\000\000\002\162\002\177\000\000\000\000\002\178\002\183\000\000\001\145\002\169\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\185\002\138\000\000\001+\000\000\002j\001,\002\166\000\231\002\139\001-\001.\000\000\000\000\000\000\006\230\002\185\002\170\002\173\000\000\000\000\000\000\002\162\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\001/\000\000\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\006\232\000\000\000\000\000\000\000\000\002\170\002\173\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\002\177\000\000\002\185\002\178\000\000\006[\002\170\002\173\002\162\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\000\000\002\185\002\170\002\173\006*\000\000\000\000\002\162\002\177\000\000\000\000\002\178\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\233\000\000\000\000\000\000\002\174\001\184\001m\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\237\001}\002\177\001p\001q\002\178\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\002\233\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002\164\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\002\242\002\254\002\255\002\185\000\000\000\000\005\201\002\170\002\173\002\162\000\000\000\000\000\000\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\005\137\002f\002g\001m\000\000\000\000\000\000\002\174\002\183\000\000\001\145\002\169\000\000\000\000\001\133\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\001v\000\000\000\000\000\231\000\000\000\000\002\185\002\180\005\135\000\000\000\000\002\162\000\000\000\000\002\167\000\000\005\137\000\000\000\000\002f\002g\001m\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\002\138\003\002\006W\002j\000\000\002\166\000\231\000\000\002\139\000\000\000\000\000\000\000\000\000\000\002\185\002\170\002\173\000\000\005\139\000\000\000\000\002\162\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\000\000\002\174\000\000\002\138\000\000\002\164\000\000\001\136\000\000\001\145\001t\002\139\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\005\141\000\000\000\000\002\162\000\000\000\000\002\180\000\000\002\170\002\173\000\000\000\000\000\000\002\167\000\000\005\137\001\029\000\000\002f\002g\001m\000\000\000\000\002\183\000\000\001\145\002\169\000\000\002\164\000\000\002\174\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\003c\002\185\000\000\000\000\000\000\005\144\002\170\002\173\002\162\000\000\002\180\002f\002g\001m\000\000\000\000\000\000\002\167\000\000\005\137\000\000\002\164\000\000\000\000\000\000\000\000\002\138\002\183\002\174\001\145\002\169\000\000\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\149\002\170\002\173\002\162\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002f\002g\001m\001\"\000\000\000\000\002\167\000\000\005\137\000\000\000\000\000\000\002\174\000\000\000\000\002\138\002\183\002\164\001\145\002\169\001#\000\000\000\000\002\139\000\000\000\000\001\021\001)\000\000\002j\000\000\002\166\000\231\005\154\000\000\000\000\002\162\000\000\002\180\000\000\002\185\002\170\002\173\000\000\000\000\002\167\000\000\005\137\000\000\002f\002g\001m\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\174\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\000\000\000\000\000\000\002\185\002\170\002\173\005\159\001+\000\000\002\162\001,\000\000\000\000\002\180\001-\001.\000\000\000\000\003f\000\000\002\167\000\000\005\137\000\000\002\164\000\000\002\174\000\000\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\002j\000\000\002\166\000\231\003g\000\000\000\000\002f\002g\001m\000\000\000\000\002\170\002\173\000\000\000\000\002\180\000\000\002\185\000\000\000\000\000\000\002\138\002\167\000\000\005\137\000\000\000\000\000\000\000\000\002\139\000\000\000\000\002\183\002\174\001\145\002\169\002\164\000\000\000\000\005\182\000\000\000\000\002\162\000\000\002f\002g\001m\000\000\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002\170\002\173\000\000\000\000\000\000\000\000\002\167\006]\005\137\002f\002g\001m\000\000\000\000\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\002\174\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\002f\002g\001m\000\000\002\185\000\000\005\187\000\000\000\000\002\162\002\164\000\000\002\180\000\000\000\000\002\138\000\000\000\000\000\000\002\167\000\000\005\137\002j\002\139\002\166\000\231\000\000\000\000\000\000\002\183\000\000\001\145\002\169\005\192\002\170\002\173\002\162\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002f\002g\001m\000\000\002i\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\174\000\000\000\000\002\138\002j\000\000\002\166\000\231\000\000\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\005\204\000\000\000\000\002\162\000\000\002\180\000\000\000\000\002j\000\000\002\166\000\231\002\167\000\000\005\137\000\000\002f\002g\001m\000\000\002\170\002\173\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\000\000\002\138\000\000\001\198\001m\002j\000\000\002\166\000\231\002\139\000\000\000\000\002\174\000\000\000\000\000\000\002\185\002\170\002\173\005\207\002\167\000\000\002\162\001n\002z\000\000\001p\001q\000\000\000\000\002\168\000\000\001\145\002\169\000\000\000\000\000\000\002\164\002\180\002\174\000\000\000\000\000\000\000\000\000\000\002\167\000\000\005\137\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\002\170\002\173\000\000\000\000\002\180\005\210\002\254\002\255\000\000\000\000\000\000\002\167\000\000\005\137\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\183\002\174\001\145\002\169\002\164\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\001\133\000\000\002\138\000\000\002\185\000\000\000\000\002\180\002\170\002\173\002\139\000\000\001v\000\000\002\167\000\231\005\137\002f\002g\001m\005\224\000\000\000\000\002\162\002\183\000\000\001\145\002\169\000\000\000\000\002\174\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\005\213\005\218\000\000\000\000\000\000\000\000\002\185\000\000\005\228\000\000\000\000\002\162\000\000\000\000\002\180\002f\002g\001m\000\000\000\000\000\000\002\167\000\000\005\137\000\000\000\000\000\000\000\000\000\000\000\000\002\138\002\183\000\000\001\145\002\169\000\000\000\000\001\135\002\139\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\001\136\000\000\001\145\001t\002\162\000\000\000\000\000\000\002\185\000\000\002j\000\000\002\166\000\231\001l\001m\000\000\000\000\002f\002g\001m\000\000\002\170\002\173\000\000\001l\001m\000\000\002\164\000\000\000\000\006B\000\000\002\138\001n\002K\000\000\001p\001q\000\000\002j\002\139\002\166\000\231\002\174\001n\002K\000\000\001p\001q\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\001\029\000\000\000\000\001\030\002L\000\000\001@\000\000\000\000\000\000\002\164\000\000\002\180\000\000\000\000\002L\002\174\000\000\000\000\002\167\000\000\005\137\002j\000\000\002\166\000\231\001A\001 \000\000\002\183\000\000\001\145\002\169\001U\002\170\002\173\000\000\000\000\000\000\000\000\000\000\000\000\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\005\137\000\000\002\185\000\000\001u\002\174\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\001u\001v\000\000\000\000\000\231\000\000\002j\001&\002\166\000\231\000\000\000\000\001v\000\000\000\000\000\231\002\180\002\185\002\170\002\173\000\000\000\000\001\"\002\167\000\000\006p\001F\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\000\000\002M\001#\002\174\000\000\002\138\000\000\000\000\001\021\001)\000\000\000\000\002M\002\139\000\000\000\000\000\000\002f\002g\001m\002\185\000\000\004\214\004\220\000\000\000\000\002\162\000\000\000\000\002\180\000\000\001\135\002\138\002O\004\220\000\000\002\167\000\000\006Y\000\000\002\139\001\144\001\135\001\145\001t\000\000\002\183\000\000\001\145\002\169\000\000\000\000\001\144\002\162\001\145\001t\000\000\0015\000\000\000\000\000\000\002f\002g\001m\000\000\001+\000\000\000\000\001,\000\000\002\185\000\000\001-\001.\001P\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\000\000\000\000\000\000\002\162\001/\000\000\000\000\0019\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\002f\002g\001m\000\000\002\170\002\173\000\000\002\164\000\000\000\000\004z\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\002\174\000\000\000\000\000\000\000\000\002\170\002\173\002f\002g\001m\002\162\000\000\004{\006\238\004|\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\002\180\002\174\000\000\000\000\005\023\000\000\000\000\002\167\000\000\006#\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\183\004}\001\145\002\169\000\000\000\000\002\170\002\173\000\000\000\000\002\180\005\199\000\000\000\000\000\000\000\000\000\000\002\167\000\000\006\030\000\000\002f\002g\001m\002\185\000\000\000\000\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\000\000\002\138\004~\000\000\000\000\000\000\000\000\000\000\002j\002\139\002\166\000\231\004\127\004\128\000\000\004\129\002\185\000\000\000\000\002\180\002\170\002\173\002\162\000\000\000\000\000\000\002\167\000\000\005\200\002i\002f\002g\001m\000\000\000\000\000\000\002\183\000\000\001\145\002\169\004\158\002j\002\174\002\166\000\231\002\138\000\000\000\000\002f\002g\001m\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\138\004\131\006\240\002\162\000\000\002\180\004\133\004\143\002\139\000\000\000\000\000\000\002\167\000\000\005}\000\000\005\026\000\000\000\000\000\000\004\154\002\162\002\183\002\164\001\145\002\169\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\002j\000\000\002\166\000\231\004\155\000\000\000\000\000\000\000\000\002\138\002\167\002\185\002\170\002\173\000\000\000\000\000\000\002\139\000\000\000\000\002\168\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\002\162\000\000\002\164\000\000\002\174\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\164\002\138\000\000\002f\002g\001m\002\170\002\173\000\000\002\139\002\180\000\000\002j\000\000\002\166\000\231\000\000\002\167\000\000\002\228\000\000\000\000\002\162\000\000\002\170\002\173\005\234\002\183\002\174\001\145\002\169\000\000\000\000\005\242\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\002\174\002f\002g\001m\000\000\002\185\000\000\000\000\002\180\000\000\002j\005\243\002\166\000\231\000\000\002\167\002\138\002\182\000\000\000\000\000\000\000\000\002\170\002\173\002\139\002\183\002\180\001\145\002\169\000\000\000\000\000\000\000\000\002\167\000\000\002\186\000\000\002\162\000\000\000\000\002\164\000\000\000\000\002\183\002\174\001\145\002\169\000\000\000\000\002\185\000\000\000\000\002j\000\000\002\166\000\231\000\000\002i\000\000\000\000\002f\002g\001m\000\000\002\170\002\173\000\000\002\185\000\000\005\245\002\180\002\166\000\231\001\002\000\000\002\138\000\000\002\167\000\000\002\188\000\000\000\000\000\000\002\139\000\000\000\000\002\174\002\183\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\000\000\001\029\000\000\005\237\001'\000\000\002\185\002\180\002j\000\000\002\166\000\231\000\000\000\000\002\167\000\000\002\190\002f\002g\001m\002\170\002\173\000\000\000\000\002\183\000\000\001\145\002\169\001 \000\000\000\000\002\167\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\002\168\002\174\001\145\002\169\000\000\000\000\000\000\002\185\000\000\002f\002g\001m\002\162\000\000\002\164\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\002j\002\180\002\166\000\231\000\000\000\000\005\023\002\138\002\167\000\000\002\192\000\000\002\170\002\173\000\000\002\139\000\000\000\000\002\183\000\000\001\145\002\169\001\"\000\000\000\000\000\000\000\000\000\000\002\162\000\000\005\024\000\000\000\000\000\000\002\174\000\000\002f\002g\001m\001#\000\000\000\000\002\185\000\000\000\000\001\021\001)\000\000\000\000\000\000\002\164\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\002\180\000\000\002j\000\000\002\166\000\231\000\000\002\167\000\000\002\194\000\000\000\000\002\162\000\000\002\170\002\173\000\000\002\183\000\000\001\145\002\169\000\000\000\000\002i\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\002\164\000\000\000\000\002j\002\174\002\166\000\231\000\000\002\138\002\185\001+\000\000\002j\001,\002\166\000\231\002\139\001-\001.\000\000\000\000\000\000\000\000\000\000\002\170\002\173\000\000\000\000\000\000\002\162\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\196\000\000\005\026\000\000\001/\002\164\000\000\002\174\002\183\000\000\001\145\002\169\000\000\002f\002g\001m\000\000\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\138\002\170\002\173\002\167\002\185\002\180\000\000\000\000\002\139\000\000\000\000\000\000\002\167\002\168\002\198\001\145\002\169\000\000\000\000\000\000\000\000\002\162\002\183\002\174\001\145\002\169\002\164\000\000\000\000\002f\002g\001m\000\000\000\000\002f\002g\001m\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\138\000\000\002\185\000\000\000\000\002\180\002\170\002\173\002\139\000\000\000\000\000\000\002\167\006 \002\200\000\000\000\000\000\000\000\000\000\000\000\000\002\162\002\183\000\000\001\145\002\169\000\000\000\000\002\174\000\000\000\000\000\000\000\000\001\029\002f\002g\001m\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\138\000\000\000\000\000\000\002j\002\180\002\166\000\231\002\139\000\000\000\000\000\000\002\167\000\000\002\202\000\000\002\170\002\173\000\000\000\000\000\000\002\162\002\183\000\000\001\145\002\169\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\002\164\000\000\002\174\000\000\000\000\002i\000\000\000\000\002\138\000\000\002\185\000\000\002j\000\000\002\166\000\231\002\139\002j\000\000\002\166\000\231\000\000\000\000\000\000\002\170\002\173\000\000\000\000\002\180\002\162\000\000\000\000\000\000\000\000\000\000\002\167\001\"\002\204\000\000\000\000\000\000\001\029\002f\002g\001m\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\001#\000\000\000\000\000\000\002\138\000\000\001\021\001)\002j\006\143\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\003c\002\180\002\170\002\173\000\000\000\000\000\000\002\162\002\167\000\000\002\206\000\000\000\000\002\167\000\000\002f\002g\001m\002\183\000\000\001\145\002\169\002\164\002\168\002\174\001\145\002\169\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\001+\002\170\002\173\001,\000\000\002\180\002\162\001-\001.\000\000\000\000\000\000\002\167\001\"\002\208\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\001#\000\000\000\000\006\141\002\138\000\000\001\021\001)\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002\170\002\173\000\000\000\000\000\000\002\162\002\167\000\000\002\210\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\000\000\001\145\002\169\002\164\000\000\002\174\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\001+\002\170\002\173\001,\000\000\002\180\002\162\001-\001.\000\000\000\000\003s\002\167\000\000\002\212\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\000\000\000\000\000\000\003v\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002\170\002\173\000\000\000\000\000\000\002\162\002\167\000\000\002\214\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\000\000\001\145\002\169\002\164\000\000\002\174\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\000\000\002\170\002\173\000\000\000\000\002\180\002\162\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\216\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002\170\002\173\000\000\000\000\000\000\002\162\002\167\000\000\002\218\000\000\000\000\000\000\000\000\002f\002g\001m\002\183\000\000\001\145\002\169\002\164\000\000\002\174\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\002j\000\000\002\166\000\231\002\139\000\000\000\000\000\000\002\185\000\000\000\000\000\000\002\170\002\173\000\000\000\000\002\180\002\162\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\220\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\183\002\174\001\145\002\169\002\164\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\002j\001Q\002\166\000\231\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\180\002\170\002\173\002f\002g\001m\000\000\002\167\000\000\002\222\001S\001 \000\000\000\000\000\000\000\000\004-\002\183\002\138\001\145\002\169\002\164\000\000\002\174\000\000\000\000\002\139\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\162\000\000\002\185\000\000\000\000\000\000\002\170\002\173\000\000\000\000\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001&\002\224\000\000\000\000\000\000\002f\002g\001m\000\000\002\183\002\174\001\145\002\169\000\000\000\000\001\"\000\000\000\000\000\000\001F\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\139\000\000\000\000\000\000\001#\002\185\000\000\000\000\002\180\000\000\001\021\001)\000\000\002\162\000\000\002\167\000\000\002\226\002\164\000\000\000\000\002f\002g\001m\000\000\002\183\000\000\001\145\002\169\000\000\002j\000\000\002\166\000\231\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\002\170\002\173\002\139\000\000\000\000\000\000\000\000\002\185\002f\002g\001m\000\000\000\000\000\000\000\000\002\162\000\000\0015\000\000\000\000\000\000\000\000\002\174\002\138\000\000\001+\000\000\000\000\001,\000\000\000\000\002\139\001-\001.\004b\002\164\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\162\000\000\000\000\002j\002\180\002\166\000\231\000\000\000\000\000\000\000\000\002\167\000\000\005\152\001/\002\170\002\173\0019\000\000\000\000\000\000\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\002\174\000\000\000\000\002\138\000\000\000\000\000\000\000\000\002\185\000\000\002j\002\139\002\166\000\231\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\002\170\002\173\002\162\000\000\002\180\002\164\000\000\000\000\000\000\000\000\002\138\002\167\000\000\005\157\000\000\000\000\000\000\002j\002\139\002\166\000\231\002\183\002\174\001\145\002\169\000\000\000\000\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\002\185\000\000\000\000\002\180\000\000\000\000\002\174\002\138\000\000\000\000\002\167\000\000\005\162\000\000\000\000\002\139\000\000\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\002\180\002j\000\000\002\166\000\231\000\000\000\000\002\167\000\000\005\168\000\000\000\000\002\185\002\170\002\173\000\000\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\002\174\002\138\000\000\000\000\000\000\000\000\002\185\002\170\002\173\002\139\000\000\000\000\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\002\162\000\000\000\000\002\164\002\180\000\000\000\000\002\174\002\138\000\000\000\000\002\167\000\000\005\173\000\000\002j\002\139\002\166\000\231\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\002\170\002\173\002\162\000\000\000\000\000\000\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\005\178\000\000\000\000\002\185\000\000\000\000\000\000\002\174\002\183\000\000\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\164\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\002\185\002\180\002j\002\139\002\166\000\231\000\000\000\000\002\167\000\000\005\185\000\000\000\000\000\000\002\170\002\173\002\162\000\000\002\183\002\164\001\145\002\169\002f\002g\001m\000\000\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\002\174\002\138\000\000\000\000\000\000\000\000\002\185\002\170\002\173\002\139\000\000\000\000\000\000\000\000\000\000\002f\002g\001m\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\002\180\000\000\000\000\002\174\002\138\000\000\000\000\002\167\000\000\005\190\000\000\000\000\002\139\000\000\000\000\000\000\000\000\002\183\002\164\001\145\002\169\000\000\000\000\000\000\000\000\002\162\000\000\000\000\000\000\002\180\002j\000\000\002\166\000\231\000\000\000\000\002\167\000\000\005\195\000\000\000\000\002\185\002\170\002\173\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\001Q\000\000\002\164\000\000\000\000\000\000\002\174\000\000\000\000\000\000\000\000\000\000\002\185\000\000\002j\000\000\002\166\000\231\000\000\000\000\001S\001 \000\000\000\000\000\000\000\000\002\170\002\173\000\000\000\000\000\000\002\164\002\180\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\005\198\000\000\002j\001\029\002\166\000\231\001\030\002\174\002\183\001@\001\145\002\169\000\000\000\000\002\170\002\173\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001m\000\000\001&\000\000\000\000\001E\001 \000\000\002\185\002\180\000\000\000\000\002\174\000\000\000\000\000\000\002\167\001\"\006\023\001n\001}\001F\001p\001q\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\002\180\000\000\001\021\001)\006\020\000\000\000\000\002\167\001\029\006\025\000\000\001\030\002\185\000\000\001&\000\000\000\000\002\183\000\000\001\145\002\169\000\000\000\000\000\000\000\000\001~\000\000\001\127\002F\001\"\000\000\000\000\000\000\001F\000\000\001 \000\000\000\000\000\000\000\000\000\000\002\185\000\000\000\000\000\000\003;\001#\000\000\000\000\000\000\000\000\0015\001\021\001)\000\000\000\000\000\000\000\000\000\000\001+\001\133\006\199\001,\000\000\001l\001m\001-\001.\001P\000\000\000\000\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001&\000\000\002Z\001n\001}\000\000\001p\001q\000\000\000\000\000\000\001/\000\000\000\000\0019\001\"\000\000\000\000\000\000\000\000\0015\000\000\001l\001m\000\000\000\000\002W\000\000\001+\000\000\000\000\001,\001#\000\000\000\000\001-\001.\001P\001\021\001)\000\000\000\000\001n\001}\000\000\001p\001q\001~\000\000\001\127\002F\000\000\001\184\001m\000\000\000\000\000\000\000\000\001\135\000\000\000\000\001/\000\000\000\000\0019\002\137\000\000\000\000\001\136\000\000\001\145\001t\002\237\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\001\029\001\133\000\000\001\030\000\000\001~\0015\001\127\002F\001l\001m\000\000\000\000\001v\001+\000\000\000\231\001,\000\000\000\000\000\000\001-\001.\003F\002Z\000\000\004\213\001 \000\000\001n\002K\000\000\001p\001q\002\242\002\254\002\255\003;\000\000\000\000\001\133\000\000\001\029\000\000\000\000\001\030\000\000\001/\000\000\000\000\0019\000\000\001v\003@\000\000\000\231\000\000\002L\000\000\000\000\000\000\000\000\000\000\002Z\000\000\000\000\000\000\000\000\000\000\001 \001\133\000\000\000\000\001&\000\000\000\000\000\000\000\000\000\000\003;\001\135\000\000\001v\000\000\000\000\000\231\000\000\000\000\001\"\000\000\001\136\000\000\001\145\001t\000\000\004\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\000\000\001u\000\000\000\000\001\021\001)\000\000\000\000\001&\000\000\003\002\003\003\001\135\001v\001\029\000\000\000\231\001\030\000\000\000\000\000\000\000\000\001\136\001\"\001\145\001t\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\001#\001 \001\135\000\000\000\000\000\000\001\021\001)\000\000\000\000\002M\003;\001\136\0015\001\145\001t\000\000\000\000\000\000\000\000\000\000\001+\000\000\001 \001,\000\000\000\000\004\210\001-\001.\003F\004\214\004\220\003;\000\000\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\000\000\001l\001m\000\000\001&\000\000\004\231\001\144\000\000\001\145\001t\001/\0015\000\000\0019\000\000\000\000\000\000\004\244\001\"\001+\001n\002K\001,\001p\001q\001&\001-\001.\003F\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\000\000\001\"\001\021\001)\000\000\000\000\000\000\000\000\000\000\002L\000\000\000\000\000\000\001/\000\000\000\000\0019\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\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\029\000\000\0015\001\030\000\000\000\000\000\000\000\000\001 \000\000\001+\001u\000\000\001,\000\000\000\000\000\000\001-\001.\003F\000\000\000\000\000\000\001v\0015\000\000\000\231\001 \000\000\000\000\000\000\000\000\001+\000\000\000\000\001,\000\000\003;\000\000\001-\001.\003F\000\000\001/\000\000\000\000\0019\000\000\000\000\000\000\000\000\001\184\001m\004\241\001&\000\000\001\184\001m\000\000\000\000\002M\000\000\000\000\000\000\000\000\001/\000\000\000\000\0019\001\"\000\000\002\237\001}\001&\001p\001q\002\237\001}\000\000\001p\001q\004\214\004\220\000\000\000\000\000\000\001#\000\000\001\"\000\000\001\135\000\000\001\021\001)\000\000\000\000\000\000\000\000\000\000\000\000\001\144\000\000\001\145\001t\000\000\001#\000\000\000\000\000\000\001\184\001m\001\021\001)\000\000\002\242\002\254\002\255\000\000\000\000\002\242\002\254\002\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\237\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0015\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001+\001\133\000\000\001,\000\000\000\000\001\133\001-\001.\004?\000\000\0015\004B\001v\000\000\000\000\000\231\000\000\001v\001+\000\000\000\231\001,\002\242\002\254\002\255\001-\001.\003F\000\000\000\000\000\000\000\000\001/\000\000\000\000\0019\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001l\001m\000\000\000\000\003\002\005\002\000\000\000\000\001/\003\002\005)\0019\000\000\000\000\000\000\001\133\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\000\000\000\000\001\135\000\000\006l\000\000\000\000\001\136\000\000\001\145\001t\000\000\001\136\000\000\001\145\001t\000\000\000\000\001l\001m\000\000\000\000\000\000\003\002\005\\\001~\000\000\001\127\002F\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\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\135\001l\001m\000\000\000\000\001\133\006o\000\000\000\000\000\000\001\136\000\000\001\145\001t\000\000\001l\001m\001v\000\000\000\000\000\231\001n\001}\000\000\001p\001q\000\000\001~\002Z\001\127\002F\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\006\215\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\006\218\000\000\000\000\001\029\001\133\000\000\001\030\001~\000\000\001\127\002F\001l\001m\000\000\000\000\000\000\001v\000\000\000\000\000\231\001 \001~\006\150\001\127\002F\000\000\001\135\002Z\000\000\000\000\001 \001n\001}\000\000\001p\001q\001\136\000\000\001\145\001t\003V\000\000\001\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001v\006\135\001\133\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002Z\001&\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\001~\001&\001\127\001\149\002Z\000\000\001\"\000\000\001\135\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\000\000\001\136\000\000\001\145\001t\000\000\001#\000\000\000\000\000\000\000\000\000\146\001\021\001)\000\000\000\000\001#\000\000\001\133\000\000\000\000\000\000\001\021\001)\001l\001m\000\000\000\000\000\000\001\135\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\001\135\001n\001}\000\000\001p\001q\000\000\002f\002g\001m\001\136\001\182\001\145\001t\000\000\000\000\000\000\000\000\0015\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001+\000\000\0015\001,\006\029\000\000\000\000\001-\001.\006\157\001+\000\000\000\000\001,\000\000\000\000\000\000\001-\001.\001~\000\000\001\127\001\170\000\000\001l\001m\000\000\000\000\001\135\000\000\000\000\000\000\000\000\001/\000\000\000\000\0019\000\000\001\136\000\000\001\145\001t\000\000\001/\001n\001}\003]\001p\001q\000\000\001l\001m\000\000\000\000\001\133\001l\001m\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001v\000\000\000\000\000\231\001n\001}\000\000\001p\001q\001n\001}\000\000\001p\001q\001\168\002i\000\000\000\000\000\000\001\172\001l\001m\001~\000\000\001\127\001\202\000\000\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\000\000\001~\000\000\001\127\001\170\000\000\001~\000\000\001\127\001\170\001\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\135\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\000\000\000\000\001\133\001~\000\000\001\127\002F\001\133\000\000\001l\001m\000\000\000\000\002\167\001v\000\000\000\000\000\231\000\000\001v\001\205\000\000\000\231\002\168\000\000\001\145\002\169\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\001\133\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\001v\000\000\000\000\000\231\000\000\001\135\000\000\000\000\000\000\000\000\000\000\006\019\000\000\001\029\000\000\001\136\001\030\001\145\001t\000\000\000\000\000\000\001 \001~\000\000\001\127\002F\000\000\000\000\000\000\000\000\001\135\003V\000\000\005V\000\000\001\135\000\000\000\000\000\000\001 \001\136\000\000\001\145\001t\004-\001\136\003Y\001\145\001t\000\000\000\000\005W\000\000\000\000\005^\000\000\000\000\001\133\000\000\000\000\000\000\000\000\001\029\005_\000\000\001\030\001\135\001&\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\001\136\000\000\001\145\001t\002Y\000\000\001\"\000\000\000\000\001&\000\000\000\000\000\000\001 \000\000\000\000\000\000\005`\005\n\000\000\000\000\000\000\000\000\001#\001\"\000\000\000\000\000\000\000\000\001\021\001)\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\000\000\000\000\000\000\000\000\005a\001\029\000\000\000\000\001\030\001&\001\135\000\000\000\000\001 \005b\000\000\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\001\"\000\000\000\000\000\000\0015\000\000\000\000\000\000\001 \005c\002\173\000\000\001+\000\000\000\000\001,\005q\001#\006N\001-\001.\000\000\0015\001\021\001)\000\000\000\000\000\000\000\000\000\000\001+\005f\000\000\001,\000\000\001&\000\000\001-\001.\0042\000\000\005h\000\000\000\000\000\000\001/\005j\000\000\003]\000\000\001\"\000\000\000\000\000\000\001&\000\000\000\000\000\000\000\000\000\000\005l\000\000\000\000\001/\000\000\000\000\0019\001#\000\000\001\"\000\000\000\000\0015\001\021\001)\000\000\000\000\000\000\000\000\005m\001+\001\029\000\000\001,\001\030\000\000\001#\001-\001.\0042\000\000\000\000\001\021\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\001 \000\000\000\000\001l\001m\001/\000\000\000\000\0019\000\000\000\000\000\000\000\000\000\000\0015\000\000\002f\002g\001m\000\000\000\000\000\000\001+\001n\001}\001,\001p\001q\000\000\001-\001.\004?\000\000\0015\005;\000\000\000\000\000\000\000\000\002h\000\000\001+\007\b\000\000\001,\000\000\001&\000\000\001-\001.\002\146\000\000\000\000\000\000\001\029\001/\000\000\001\030\0019\001l\001m\001\"\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\127\007$\000\000\007&\000\000\001/\000\000\000\000\0019\001#\001n\001}\001 \001p\001q\001\021\001)\000\000\001l\001m\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\133\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\001\029\000\000\001v\001\030\002i\000\231\001 \000\000\000\000\000\000\000\000\001~\000\000\001\127\006\205\001&\002j\000\000\002\166\000\231\000\000\0015\000\000\000\000\000\000\000\000\000\000\001 \000\000\001+\001\"\000\000\001,\000\000\000\000\001J\001-\001.\007\t\001~\000\000\001\127\001\174\000\000\000\000\000\000\001\133\001#\000\000\000\000\000\000\000\000\001&\001\021\001)\000\000\000\000\000\000\001v\000\000\000\000\000\231\001/\000\000\000\000\0019\000\000\001\"\000\000\001\135\000\000\000\000\000\000\001&\001\133\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\002\167\001#\000\000\001v\000\000\001\"\000\231\001\021\001)\000\000\002\168\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\0015\001l\001m\001#\000\000\000\000\000\000\000\000\001+\001\021\001)\001,\000\000\000\000\000\000\001-\001.\001`\000\000\001l\001m\001n\001}\001\135\001p\001q\001l\001m\000\000\000\000\000\000\000\000\000\000\001\136\000\000\001\145\001t\0015\000\000\001n\001}\001/\001p\001q\0019\001+\001n\001}\001,\001p\001q\001\135\001-\001.\0016\000\000\001l\001m\0015\000\000\000\000\001\136\000\000\001\145\001t\001~\001+\001\127\001\164\001,\000\000\000\000\000\000\001-\001.\000\000\001n\001}\001/\001p\001q\0019\000\000\001~\000\000\001\127\001\161\001l\001m\000\000\001~\000\000\001\127\001\129\000\000\000\000\000\000\000\000\000\000\001/\001\133\000\000\001N\000\000\000\000\000\000\005V\001n\001}\000\000\001p\001q\001v\000\000\000\000\000\231\000\000\000\000\001\133\000\000\001~\007C\001\127\001\131\007D\001\133\000\000\005^\000\000\000\000\001v\000\000\000\000\000\231\000\000\000\000\005_\001v\001\029\000\000\000\231\001\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\127\001\134\001\133\000\000\001l\001m\000\000\000\000\000\000\000\000\000\000\000\000\001 \005`\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\000\000\001n\001}\001\135\001p\001q\000\000\000\000\000\000\000\000\001\133\000\000\000\000\001\136\000\000\001\145\001t\000\000\000\000\000\000\000\000\001\135\001v\000\000\000\000\000\231\000\000\005a\001\135\000\000\000\000\001\136\000\000\001\145\001t\001&\000\000\005b\001\136\000\000\001\145\001t\001l\001m\000\000\001~\000\000\001\127\001\160\000\000\001\"\000\000\000\000\000\000\000\000\000\000\005c\002\173\001\135\007F\000\000\000\000\001n\001}\000\000\001p\001q\001#\001\136\001\029\001\145\001t\001\030\001\021\001)\000\000\000\000\000\000\005f\000\000\001\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005h\001\135\000\000\001\029\001v\005j\001\030\000\231\001 \000\000\000\000\001\136\000\000\001\145\001t\000\000\000\000\000\000\001~\005l\001\127\001\152\000\000\001l\001m\000\000\000\000\000\000\000\000\000\000\001 \000\000\000\000\000\000\0015\000\000\000\000\000\000\005m\000\000\000\000\000\000\001+\001n\001}\001,\001p\001q\000\000\001-\001.\001\154\000\000\001\133\001&\001\029\000\000\000\000\001\030\000\000\000\000\000\000\000\000\000\000\000\000\001v\000\000\000\000\000\231\001\"\000\000\001\135\002f\002g\001m\001/\001&\000\000\0019\000\000\000\000\001\136\001 \001\145\001t\000\000\001#\001~\000\000\001\127\001\157\001\"\001\021\001)\000\000\002\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\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\000\000\000\000\000\000\000\000\000\000\001\133\000\000\001\029\000\000\000\000\001\030\001&\000\000\000\000\000\000\001\135\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\0015\001\136\001\"\001\145\001t\000\000\000\000\000\000\001+\000\000\001 \001,\000\000\000\000\000\000\001-\001.\001\189\000\000\001#\000\000\000\000\0015\000\000\000\000\001\021\001)\000\000\000\000\000\000\001+\002i\000\000\001,\001l\001m\000\000\001-\001.\001\204\000\000\001/\000\000\002j\0019\002\166\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001n\001}\001&\001p\001q\000\000\001\135\000\000\000\000\001/\000\000\000\000\0019\000\000\000\000\000\000\001\136\001\"\001\145\001t\0015\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001+\001l\001m\001,\000\000\000\000\001#\001-\001.\001\251\000\000\000\000\001\021\001)\000\000\000\000\001~\000\000\001\127\002^\000\000\001n\001}\000\000\001p\001q\001\029\000\000\002\167\001\030\000\000\000\000\000\000\001/\000\000\000\000\0019\000\000\002\168\000\000\001\145\002\169\000\000\000\000\001\029\000\000\000\000\001\030\000\000\000\000\000\000\001\133\000\000\001 \000\000\000\000\000\000\000\000\000\000\001l\001m\0015\000\000\001v\000\000\001~\000\231\001\127\002c\001+\000\000\001 \001,\000\000\000\000\000\000\001-\001.\001\253\001n\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\000\000\001&\001\133\000\000\001/\000\000\000\000\0019\000\000\000\000\000\000\000\000\000\000\000\000\001v\000\000\001\"\000\231\000\000\001&\000\000\000\000\000\000\001 \000\000\001~\000\000\001\127\002\246\000\000\000\000\000\000\001\135\001#\001\"\000\000\000\000\000\000\000\000\001\021\001)\000\000\001\136\001\029\001\145\001t\001\030\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\001\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001&\001 \000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\001\"\000\000\000\000\000\000\0015\000\000\000\000\001\136\000\000\001\145\001t\000\000\001+\000\000\000\000\001,\000\000\001#\000\000\001-\001.\002|\0015\001\021\001)\000\000\000\000\000\000\000\000\000\000\001+\000\000\001&\001,\000\000\000\000\000\000\001-\001.\002\144\000\000\000\000\000\000\000\000\000\000\001/\000\000\001\"\0019\000\000\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\001l\001m\000\000\000\000\000\000\001/\001#\001\136\0019\001\145\001t\000\000\001\021\001)\0015\000\000\001l\001m\000\000\000\000\001n\001}\001+\001p\001q\001,\000\000\001l\001m\001-\001.\002\148\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\000\000\000\000\000\000\000\000\001n\001}\000\000\001p\001q\000\000\000\000\000\000\001/\000\000\000\000\0019\000\000\000\000\0015\000\000\000\000\001~\000\000\001\127\002\248\000\000\001+\000\000\001\029\001,\000\000\001\030\000\000\001-\001.\002\239\000\000\001~\001\029\001\127\002\250\001\030\000\000\001l\001m\000\000\000\000\000\000\001~\000\000\001\127\003\001\000\000\000\000\000\000\001 \001\133\000\000\000\000\001/\000\000\000\000\0019\001n\001}\001 \001p\001q\001v\000\000\000\000\000\231\001\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\133\001v\000\000\000\000\000\231\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001v\001\029\000\000\000\231\001\030\000\000\001&\000\000\000\000\000\000\000\000\000\000\001~\000\000\001\127\003\007\001&\000\000\000\000\001\029\000\000\001\"\001\030\000\000\000\000\000\000\000\000\000\000\001 \000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\000\000\001#\000\000\001\135\000\000\000\000\000\000\001\021\001)\001 \001\133\001#\000\000\001\136\000\000\001\145\001t\001\021\001)\001\135\000\000\000\000\001v\000\000\000\000\000\231\000\000\000\000\000\000\001\136\001\135\001\145\001t\001\029\000\000\000\000\001\030\001&\000\000\000\000\001\136\000\000\001\145\001t\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\000\000\000\000\001&\0015\000\000\000\000\000\000\001 \000\000\000\000\000\000\001+\000\000\0015\001,\000\000\001#\001\"\001-\001.\003?\001+\001\021\001)\001,\000\000\000\000\000\000\001-\001.\004\011\000\000\000\000\000\000\001#\000\000\001\135\000\000\000\000\000\000\001\021\001)\000\000\000\000\001/\000\000\001\136\0019\001\145\001t\000\000\000\000\000\000\001&\001/\000\000\001\029\0019\000\000\004c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\000\000\000\000\0015\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001+\000\000\000\000\001,\001 \000\000\001#\001-\001.\004\023\0015\001\029\001\021\001)\004c\000\000\000\000\000\000\001+\000\000\000\000\001,\000\000\000\000\000\000\001-\001.\0041\000\000\000\000\000\000\001\029\000\000\001/\004c\000\000\0019\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\004e\001/\000\000\000\000\0019\000\000\000\000\000\000\001 \000\000\000\000\0015\000\000\000\000\000\000\001\"\000\000\000\000\000\000\001+\000\000\000\000\001,\000\000\000\000\000\000\001-\001.\004A\000\000\000\000\000\000\001#\001\029\004e\000\000\004c\000\000\001\021\004h\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\000\000\000\000\001/\001\029\004e\0019\001\030\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\000\000\001#\001\029\000\000\001\"\001\030\000\000\001\021\004h\000\000\000\000\000\000\000\000\000\000\000\000\001 \000\000\000\000\000\000\001l\001m\001#\000\000\001\029\000\000\000\000\001\030\001\021\004h\001 \001+\000\000\000\000\004i\000\000\000\000\000\000\001-\001.\001n\002K\004e\001p\001q\000\000\000\000\000\000\0044\000\000\004m\001 \004k\000\000\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\001&\000\000\001/\001+\000\000\000\000\004i\000\000\000\000\000\000\001-\001.\001#\000\000\001&\001\"\000\000\000\000\001\021\004h\0044\000\000\004l\001+\004k\000\000\004i\000\000\000\000\001\"\001-\001.\001#\000\000\000\000\001&\001/\000\000\001\021\001)\0044\000\000\004j\000\000\004k\000\000\001#\000\000\000\000\000\000\001\"\000\000\001\021\001)\000\000\000\000\001/\001u\000\000\001\029\000\000\000\000\004c\000\000\000\000\000\000\000\000\001#\000\000\001v\000\000\000\000\000\231\001\021\001)\001+\000\000\000\000\004i\000\000\000\000\000\000\001-\001.\000\000\000\000\001 \0015\001\029\000\000\000\000\004c\0044\000\000\004v\001+\004k\000\000\001,\000\000\000\000\0015\001-\001.\004\190\000\000\005I\000\000\001/\001+\000\000\000\000\001,\000\000\000\000\001 \001-\001.\004\207\000\000\000\000\000\000\0015\000\000\000\000\000\000\000\000\000\000\001/\000\000\001+\0019\004e\001,\000\000\000\000\001\135\001-\001.\004\238\001\029\000\000\001/\001\030\000\000\0019\001\144\001\"\001\145\001t\001\029\000\000\000\000\001\030\000\000\000\000\000\000\000\000\000\000\000\000\005K\004e\000\000\001/\001#\000\000\0019\001 \000\000\000\000\001\021\004h\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\001\029\001#\000\000\001\030\000\000\000\000\000\000\001\021\004h\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\001 \000\000\000\000\000\000\001&\000\000\000\000\001\029\001+\001\"\001\030\004i\000\000\000\000\000\000\001-\001.\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\0044\001#\005.\000\000\004k\000\000\000\000\001\021\001)\001 \000\000\001#\001+\000\000\000\000\004i\001/\001\021\001)\001-\001.\001&\000\000\000\000\000\000\001\029\000\000\000\000\001\030\0044\000\000\005F\000\000\004k\000\000\000\000\001\"\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\001 \001#\000\000\001&\0015\000\000\000\000\001\021\001)\000\000\000\000\000\000\001+\000\000\0015\001,\000\000\000\000\001\"\001-\001.\006K\001+\000\000\000\000\001,\000\000\000\000\000\000\001-\001.\006P\005V\000\000\000\000\001#\000\000\000\000\000\000\005V\000\000\001\021\001)\000\000\000\000\001/\001&\007C\0019\000\000\007D\000\000\000\000\005^\007C\001/\0015\007D\0019\000\000\005^\001\"\005_\000\000\001+\000\000\000\000\001,\000\000\005_\000\000\001-\001.\006\156\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\021\001)\000\000\000\000\000\000\000\000\0015\000\000\005`\000\000\005V\000\000\000\000\001/\001+\005`\0019\001,\000\000\000\000\000\000\001-\001.\006\159\000\000\007C\000\000\000\000\007D\000\000\000\000\005^\000\000\000\000\000\000\000\000\001\029\000\000\000\000\001\030\005_\000\000\000\000\000\000\000\000\005a\000\000\001/\000\000\0015\0019\000\000\005a\000\000\000\000\005b\000\000\001+\001\029\000\000\001,\001\030\005b\001 \001-\001.\006\208\000\000\000\000\000\000\005`\000\000\000\000\000\000\005c\002\173\000\000\007E\000\000\000\000\000\000\005c\002\173\000\000\007I\001 \000\000\000\000\000\000\001\029\001/\000\000\001\030\0019\000\000\000\000\005f\000\000\000\000\000\000\000\000\000\000\000\000\005f\000\000\000\000\005h\005a\000\000\001&\000\000\005j\000\000\005h\000\000\000\000\001 \005b\005j\000\000\000\000\000\000\000\000\000\000\001\"\005l\000\000\000\000\000\000\000\000\000\000\001&\005l\000\000\000\000\000\000\005c\002\173\000\000\007N\001\029\001#\000\000\001\030\005m\000\000\001\"\001\021\001)\000\000\000\000\005m\000\000\000\000\000\000\001l\001m\000\000\005f\000\000\000\000\000\000\001&\001#\000\000\000\000\000\000\001 \005h\001\021\001)\000\000\000\000\005j\000\000\001n\002K\001\"\001p\001q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005l\000\000\000\000\001\029\000\000\000\000\004_\001#\000\000\0015\000\000\000\000\000\000\001\021\001)\000\000\000\000\001+\000\000\005m\001,\000\000\000\000\000\000\001-\001.\001&\000\000\001l\001m\001 \0015\000\000\000\000\000\000\000\000\005V\000\000\000\000\001+\000\000\001\"\001,\000\000\000\000\000\000\001-\001.\001n\002K\001/\001p\001q\001L\005W\000\000\000\000\005^\001#\000\000\000\000\000\000\0015\000\000\001\021\001)\005_\001u\000\000\000\000\001+\000\000\001/\001,\000\000\001\246\000\000\001-\001.\001v\001\029\004z\000\231\001\030\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\"\000\000\000\000\000\000\000\000\005`\000\000\000\000\000\000\000\000\000\000\000\000\001/\000\000\000\000\001\248\001 \001#\004{\000\000\004|\000\000\0015\001\021\001)\005I\000\000\000\000\000\000\000\000\001+\000\000\000\000\001,\000\000\000\000\001u\001-\001.\000\000\000\000\000\000\005a\000\000\000\000\000\000\000\000\000\000\001v\000\000\004}\000\231\005b\000\000\000\000\001\135\000\000\000\000\000\000\000\000\000\000\000\000\001&\001/\000\000\001\144\003X\001\145\001t\000\000\000\000\005c\002\173\000\000\004z\000\000\000\000\001\"\006\131\005J\001+\000\000\000\000\001,\000\000\005I\004~\001-\001.\001\029\000\000\000\000\001\030\005f\001#\000\000\004\127\004\128\000\000\004\129\001\021\001)\004{\005h\004|\000\000\000\000\000\000\005j\000\000\002f\002g\001m\001/\000\000\001\135\001 \000\000\000\000\000\000\000\000\000\000\005l\000\000\004\156\001\144\000\000\001\145\001t\000\000\000\000\000\000\000\000\002\131\004}\000\000\000\000\000\000\000\000\005R\000\000\005m\000\000\000\000\000\000\000\000\000\000\000\000\004\131\001*\000\000\000\000\000\000\004\133\004\143\001l\001m\001+\000\000\000\000\001,\000\000\001&\000\000\001-\001.\000\000\004\154\000\000\000\000\004~\000\000\001l\001m\000\000\001n\001o\001\"\001p\001q\004\127\004\128\000\000\004\129\000\000\000\000\004\155\000\000\000\000\000\000\001/\000\000\001n\001\143\001#\001p\001q\001l\001m\000\000\001\021\001)\000\000\002f\002g\001m\000\000\000\000\004\130\000\000\002i\000\000\002f\002g\001m\000\000\000\000\001n\001\215\000\000\001p\001q\002j\000\000\002\166\000\231\002\155\000\000\000\000\000\000\000\000\000\000\004\131\000\000\000\000\002\165\000\000\004\133\004\143\002f\002g\001m\000\000\000\000\002f\002g\001m\000\000\000\000\006\149\000\000\004\154\000\000\000\000\001u\000\000\000\000\001+\000\000\000\000\001,\000\000\002\184\000\000\001-\001.\001v\005\022\000\000\000\231\004\155\001u\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\004f\000\000\001v\000\000\000\000\000\231\000\000\000\000\002\167\001/\000\000\000\000\000\000\000\000\000\000\001u\000\000\000\000\002\168\000\000\001\145\002\169\002i\000\000\001 \000\000\000\000\001v\000\000\000\000\000\231\002i\000\000\000\000\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\000\000\002j\000\000\002\166\000\231\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\000\000\000\000\000\000\002i\000\000\000\000\000\000\001\144\002i\001\145\001t\000\000\000\000\000\000\001\135\002j\000\000\002\166\000\231\000\000\002j\000\000\002\166\000\231\001\144\000\000\001\145\001t\000\000\000\000\001\"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\135\000\000\000\000\000\000\000\000\000\000\000\000\002\167\001#\000\000\001\144\000\000\001\145\001t\001\021\001)\002\167\002\168\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\002\168\000\000\001\145\002\169\000\000\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\167\000\000\000\000\000\000\000\000\002\167\000\000\000\000\000\000\000\000\002\168\000\000\001\145\002\169\000\000\002\168\000\000\001\145\002\169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001+\000\000\000\000\001,\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\000\000\000\000\000\000\000\000\000\001/")) + ((16, "\002\168\001\133\000S\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\001#\001\234\000)\0019\000\179\000\017\000\135\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\155\000\000\000\000\000\000\000\000\000\000\000M\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000 \204\000\000\000\000\000\000\000\006\000\000\000\000\000\000\000\000\000\000\000\000\000\0008\214\000n\000\000\000N\000\029\000\193\000\000\000\196\000\017\000\218\001l\000Z\000\000\000\000\000\000\000b\000\000\000\000\000\016\000\000\000\000\000\000\000\000\002D\000\000\001d\000\000\000\000\000\000\000\000\000\000\000d\000\000\000,\002\234\000\015\000\000\000\000\011\1728\214\000\000\000\000\025\152\000\000\012x\000\0009p\003\134\003\152\000\000\000\000\001\166\001\236\001\182\004h\000v\002\234\002\216\000{\003\148\000\200\001\246\003\208\014\128\000\000\005(\002\n\004\216\002\bBV\000\000\000\000\000\000\000\000\000\000\000\000\000\0009\162\000\000\002<\005\024\003\020\000\000\000\000\000\000\000\000\002t\000\000\000\000\005\"\004~\000\000\005,\007<\t\028\000\000\000\000\000\000\002\186\003\"\005J\005\196\bX\005\1389\188\003*\005\194\001$\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\242\000\000\000\000\000\000\003\156\006\002\014\242\007\180\005(\"\144\000\000:\028\005\152:\164:\192\000\000\000\249\000\000\000\000\000\000\004\140Kx\004\210\000\000\012:\004\236\000\000\012\162\bb\000\254\000\000\004P\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r0\004~\000\000\000\000\000\000\017@\000\000\nP\000\000\000\000\004~K\156\"*\000\000\017\228\000\000\000\000\000\000\000\000\000\000\000\000\002\134\011\210\002\134\004\006\000\000\000\000\000\000\004n\000\000\000\000\000\000\000\000\005\006\000\000\000\000\002\134\000\000\000\000\000\000\000\000\000\000\tR\000\000\006\210\005\162\000\000K\252\006\224X\252\000\000\000\000\000\000\000\000\004n\000\000\000\000\000\000\rH\000\000\000\000\000\000\000\000\000\000\000\000\000G\005\154\000\000\000\000\000\000\004n\005\224L\160\005.\007\014?\226\000\000\0050\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\230\000\000\000\000\000\000\000\000\006jL\236\000\000\005Z\007(M*\000\000\000\000\000\000M^\005\146Mx\005\146\000\000N\002\005\146\000\000NF9\162\006p\006\230\000\000\000\000Al\000\000\000\000\000\000\000\000\000\000\000\000\005\146\000\000N|\005\146N~\004n\000\000O\128\005\146\000\204\000\000\005\146\005\146\000\000\000\000\005\146\000\000:\192\000\000\000\000\000\000\005\146;H\000\000\000\000\005\146\000\000\000\167\007\014\000\000\000\000\000\000\000\000\000\000\000\000\020v\000\000\006\186\000\000N\228\004n\000\000\000\000\000\000\000\000\007\012\007\170\015<\007\006\b\002\b\016\0074\b\150\007H\000\154\b\186\000\000\000\000\003\006\003p\000\000\006\022\007V\001\002\bh\000\000\000\000\007\222\000\000\000\252\001*\005\196\000\221\t\212\000\000\000\000Y\022\000\000Y@\t\162\000\000O\012\004nO|\004n\000\000\002r\002\156\000\000\b\206\000\252\000\000\000\000\b\238\000\000\000\000\000\000\000\000\000\000\t\158\000\252\011.\000\252\000\000\004f\000\000\000\000\004\236\000\000\000\000\000\000\nj\000\000\000\000\000\252\000\252\000\000\000\252\000\000\000\000\tB\000\000\000W\bX\000\000\000W\000\000\r\242\000\252\000\000\000\000\000\000\000\000\000\000\000W\015\174\"\194\n\"\t\218:\246\023\022\000\0005l;\152\t&\007x5\160\t>\007\158\016\n\td\007\176\016\132\tp\007\238\004\174;\192\005\146\016\246\tz\007\254\023\132\n|\000\000<`\005\146O\220\004n\nX\000\000\000\000\000\000\000\0009\162\nB\000\000\000\000F\210\000\000\000\000\000\172\000\000\000\000\nz\026\254\002\134\000\000\017n\t\202\b\b\007b\000\000;\246\t\246\bB\025\194\000\000<\198\000\000\000\000\n\020\bRP*\005\146\017\150D\030\000\000\000\000\000\000\000\000\000\000\001\006\r\170\000\000\000\000\000\000\nF\br\n\012\000W\014,\000\252\000\000\000\000\000\000\005\152\000\000Pr\004n\018\014\nd\bvIr\000\000N\176\000\000\000\000\"\248\nn\b\142\030\178\000\000#b<\208\nv\b\156#\152\000\000.\136\000\000\000\000\011\224P\198\004nED\004nP\218\004n\000\000\000\000\000\000\000\000\000\000S\192\000\000\000\000\000\000\004\"\018\128\000\000\000\000\000\000=\132\n\146\b\160$$\000\000Z(\000\000\000\000\000\000\000\000\000\000\n^\018\250\000\000\000\000\nn=\206\n\176\b\182$`\000\000\nn=\226\n\182\b\230$\150\000\000\nn\000\000ZB\000\000>T\n\188\b\238% \000\000\nn\019V\004|\019\162\000\000\000\000>\138\n\210\t\"%^\000\000\nn>\188\n\228\t.%\196\000\000\nn?^\011\n\t<%\232\000\000\nn?\144\011\012\tB&&\000\000\nn?\194\011\020\tJ&\140\000\000\nn@8\011&\tZ&\238\000\000\nn@L\0114\tl'T\000\000\nn@\150\011<\t\186'\142\000\000\nnAJ\011X\t\192'\198\000\000\nnA\208\011v\t\248(P\000\000\nnB\026\011\128\n\002(\136\000\000\nnBB\011\136\n\006(\148\000\000\nnBx\011\152\n\014(\250\000\000\nnB\140\011\160\n\016)\\\000\000\nnC\128\011\174\n(*\002\000\000\nnC\246\011\218\nP*\030\000\000\nnD\n\011\222\nT*h\000\000\nnDT\011\236\nX+\b\000\000\nnDh\011\242\nd+*\000\000\nnD|\011\252\n\142+\202\000\000\nn\n\162\015\186\019j\020B\000\000ED\012\172\000\000Qj\004n\020\234\000\000\000\000\012B\000\000Q~\004n\0216\000\000\000\000\021\190\000\000\000\000\002j\000\000\000\000\022\"\000\000\000\000\000\000\000\000Q\194\004n\022\194\000\000\012\b\023\"\000\000Rn\005\146R|\005\146R\144\005\146\003$\000\000\000\000\000\000\000\000Sv\005\146\000\000\002\162\0054\000\000\000\000\000\000\nn\023\142\000\000\000\000\023\236\000\000\000\000\000\000\000\000+\164\000\000\000\000\nn,\000\000\000,r\000\000\000\000,\206\000\000\000\000\000\000Z\146\000\000\000\000-.\000\000\000\000Ev\012D\n\208-\152\000\000\nn-\138\000\000\000\000E\212\012L\n\228-\212\000\000\nn.\146\000\000\000\000F*\012z\n\236.\156\000\000\nn\004\138\024^\000\000\000\000FL\012\132\011\018/\018\000\000\nn\024\188\000\000\000\000Ft\012\136\011\026/\\\000\000\nn\025\026\000\000\000\000G\"\012\162\011.0\026\000\000\nn\000\000\000\0000b\000\000\000\000G\220\012\182\01180\144\000\000\nn0j\000\000\000\000H\014\012\228\011:0\220\000\000\nn18\000\000\000\000H\026\012\234\011H1\158\000\000\nn\000\000Hd\012\252\011T2\016\000\000\nn\000\000;\184\000\000\000\000\nn\000\000\000\000\000\0002F\000\000\000\0002\156\000\000\000\000\000\000\012\b\025v\000\000\000\000\026$\000\000H\132\000\000\000\000D\030\000\000\000\0002\230\000\000\000\000\000\0003J\000\000\000\000\000\000\014\"\000\000\000\000S8\000\000\000B\000\000\007\\\r\190\000\000\002f\000\000\000\000\000\000\000\000\000\000\001\006\000\000\000\000\r\020\000\000\000\000\026b\000\000\026\174\000\000\000\000\nn\000\000\000\000\027\016\000\000\027N\000\000\000\000\000\000\000\000\000\000H\200\r\026\011z3l\000\000I\162\r`\011\1363\176\000\000\nn\nnI\236\rj\011\1384R\000\000\nn\000\000\000\000\000\000\000\000\rl\011\1504\132\000\000\000\000\nn\000\000\000\000\000\000\000\000\rr\011\1544\200\000\000\nn\000\000\014\168\000\000\000\000\000\000\000\000\000\000\000\000\000\000\011\188\011\196\000W\028\026\000\000\r\152\011\190\014Z\001<\012\216\000W\015`\000\252\012\218\000W\000\000\028L\000\000\006<\000\000\r\230\011\230\002\216\000\000\000\000\000\000\000\000\000\000\014\n\003\178\000\235\000\000\000\000\000\000J\000\000\000Y\224\000\000\011\234\000\000\011\242\000\000\000\000\000\000\000\000\000\151\000\000\000\000\000\000)\188\002\134\000\000\002\134\0064\000\000\005\230\000\000*\178\002\134\002\134\000\000/\148\002\134\002\134\011\244\000\000\028\214\000\000\000\000\011\254\014\238\000\0005\020\006\252\000\000\000\000\000\000\000\000\000\000\000\000\r\254\012&5\134\000\000\nn\000\000\000\000\000\000\000\000\014\n\012P\rv\000W\000\000\0176\000\252\000\000\015f\000\000\000\000\000\000\000\0005\236\000\000\014\030\012\1406*\000\000\000\000\018\220\000\252\000\000\019\004\000\252\000\000\019\"\000\252\000\000\nn\000\000\020\198\000\252\000\000\021\140\000\252\000\000\022\\\000\252\000\000\000\026\000\000\012\170\r\142\001\168\000\000\014.\014F\012\182\014\192\015V\022\144\000\252\007\128\000\000\012\194\015~\015\134\007H\007\156\015P\012\196\015\150\007\142\007\168\015`\000\000\000\000\b(\b\134\000\000\004\186\004\136S\138\005\146\029\b\000\000\006\198\001\184\015\014\r\012\014x\004\236\000\000\015\016\r\016\004`\000\0006N\000\000S\212\004n\000\000\015\186\015\212\000\000\b\174\000\000\004n\015D\r \004\b\015\128\002\228\000\000\000\000\000\000\000\000\r(\b\186\000\000\rH\b\228\000\000\t\224\028J\015d\015f\r|\005\198\t@\000\000\r\160\007\228\t\242\000\000\015l\015p\r\172\015\208\015V\022\214\000\252\000\000\r\182\016:\000\000\b\138\n0\000\000\016>\000\000\025\244\001\206\016\012\r\214\016j\000\000\026\134\003\002\016:\000\000\000\000\000\195\003\134\n2\000\000\027\214\000\252\n\134\000\000\005\030\000\000\016\016\r\218\0298\004>\000\000\016\020\r\246\006F\015\128\016\022\016$\r\250\017\148\000\000\0168\002\140\000\000\000\000\000\000\000\000\000\182\014\016\016\nT\030\004n\000\000\004R\014\030\016\212\000\000\000\000\000\000\000\000\000\000\000\000T8\004\176\000\000\014,\017<\000\000\000\000\000\000\000\000\000\000\000\0006z\n\216\000\000\014:\001\b\000\000\014J\014h\006\"\000\000\001nI\188\000\000\005N\000\000U\006\004n\004n\000\000\000\000\005\180\000\000\t\006\000\000\001\132\005\180\005\180\000\000\014pJ>\004nUH\004n\011\000\000\000\000\000\000\000\012D\000\000\000\000\004\132\000\000\005\190\016\158\014~\017\190\016h\000\000\000\000\002\180\006h\016\176\000\000\000\000\014\136\017\204\016p\000\000\000\000\nd\000\000*\200\000\000U\028\002\222\004n\000\000UlL`\000\000V\004\000\000\000\000\000\000\005\180\000\000\000\000\012\192\016\184\014\150\017\212\016\136\000\000\000\000V.\012\250\016\208\000\000\000\000\000\000/\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\r*\000\000\016\222\014\156\006\218\000\000\017\218\017\138\r\128\016\230\000\000\000\000\016\234\014\160\b\128\000\000\000\000\n(\bb\002\224\000\000\000\000\000\000\b\018\016\188\014\186\000\000\016\208\b\018\000\000\017\182\r\212\017\022\000\000\000\000\000\000\004n\002\182\006\196\006L\000\000\000\000\000\000\000\000\016\236\014\210\000\000\006\230\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004n\016\208\014\226\018>\016\226\000\000 \014\001\003\014\228\016\180\001r\002T\014\230\017t\000\000\0182\029\176\000\000\000\000\030\018\000\000\014x\000\000\004\242\000\000\000\000\000\000\000\000\000\000\000\000V\236\004n\000\000\0188\030\132\000\000\000\000\030\232\000\000\003b\014\246\017\222\000\000\000\000\021V7f\017\148\000\000W\004\004n\031N\000\000\000\000\031\156\000\000\000\000\014\158\000\000\002\206\000\000\000\000\000\000\000\000\000\000\000\0007x\000\000\000\0007 7\232\017\150\000\000W\022\004n V\000\000\000\000 \178\000\000\000\000\015\014!\004\014\176\000\000\015$\015@\000\145\001P\015L\b\202\015t\017\2428z\014\178\000\000\015\160\015\162\tr\000\000\003\182J\228\000\000\006\244\000\000\015\176\001\156\002\140\006\194\016\194\n\240\000\000Y\164;\184\000\000\b\150\000\000\000\000\b\150\000\000\000\000\b\150\nB\000\000\012\228\b\150\017\2468\142\014\186\000\000\b\150\000\000W0\000\000\000\000\b\150\000\000\000\000\014\190\000\000\r\020\t\220\015\n\000\000\015\180J\144\015\018\000\000\000\000\000\000\015 \000\000\000\000\001\234\000\000\b\150W@\000\000\016\030\b\150\"X\000\000\015$\017R\015\184\018r\017\028\000\000%\128\015T\017b\000\000\000\000\000\000\n$\007\006\000\000\000\000\000\000\000\000\000\000\000\000\n^\015\160\000\000\017t\000\000\000\000\000\000\000\000\015\210\016\232\000\000\000\000\000\000\n^\000\000\000\000\000\000\000\000\015\236\024\200\000\000\000\000\000\000\000\000\000W\000\252\000\000\005\146\000\000X\020\004n\000\000\003\202\000\000\000\000\000\0008\132\000\000\000\000\000\000\000\000\000\000\018\022\006\148\b\152\016\188\005\024\015\244\000\000\006\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\236\006T\016\012\000\000\b\000\018x\018,\015\238\000\000\000\000\018 \n\254\007X\000\000\000\000\000\000\016\018\000\000\0164\015\248\000\000\000\000\002\134\020\004\000\000\000\000\000\000\000\000\000\000\027\252\000\000\000\000\b\230\007\224\000\000\000\000X.\004n\004nX\178\004n\007\182\000\000\000\000\000\000\004n\000\000\000\000\n\198\0180\0164\000\000\000\000\018$\003N\000\144\000\000\000\000\000\000\000\000\b\240\018x\011j\018<\016\182\000\000\000\000\0184\003x\006\242\000\000\000\000\000\000\000\252\000\000\016\206\000\000\000\000\000\000!,\000\000!\212\000\000\000\000\000\000\000\000\000\000\000B\000\000\000\000\000\000\003F\000\135\000\000\000\000\000\000\000\000\000\000\006\016\000\135\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003V\000\000\000\000\000\000K&\000\000\004n\000\000\014$\000\000\000\000\000\000\001\210\000\000\000\000\000\000\001H\000\000\000\000\000\000\005\014\000\000\000W\000\000\001&\000\000\000\252\000\000\005\238\000\000\000\000\000\000Bp\005\146\000\000\000\000\002T\000\000\000\000\000\000\000\000\001\006\005x\017p\000\164\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000=F\000\000\016\240\000\000\000\000\000\000\000\000\006L\b,\022\154\030\160\000\000\000\000\017\000Sd\000\000\000\000\000\000\017\006Z\026\000\000\000\000\000\000\000\000"), (16, "\006\219\0007\002`\002a\001j\000\231\000;\004\136\000\235\000\236\000\231\007l\005\235\000\235\000\255\000m\001j\002\133\006\220\006\235\003y\006\222\001\000\001\026\000\231\002\138\001\027\000\235\000\255\001\214\006\223\006\236\007f\001Y\000\145\005`\006\155\000\150\002\161\001\238\005\236\007d\005\237\001\242\000?\001\018\0007\001\002\000j\004\136\001\029\000\231\007Q\005\235\000\235\000\255\004\147\004\149\004\151\002\020\006\224\001\219\000\231\001\177\006\239\000\235\000\236\000@\006\015\000\151\006\157\000\145\005\238\007Y\001\231\000\145\000\145\000\155\001\231\000\154\000\238\005\236\007u\005\237\001\243\004\026\006\158\001\\\001\002\007\r\005b\006\160\007\012\006\155\003y\006\201\001#\006\225\004\150\004\149\004\151\000Y\002\167\001\244\007\187\002a\001j\006\226\005\239\001i\001j\001\031\007L\005\238\002d\002\020\002\169\000\235\005\240\005\241\006\219\005\242\002`\002a\001j\001\156\001j\006\157\001 \001k\002E\006\240\001m\001n\001\018\001&\000\238\002\133\006\220\006\235\000]\006\222\000\127\006\158\006.\002\138\006\241\001\210\006\160\005\239\006\223\006\236\006\181\003y\004&\001j\006\229\001\012\002\161\005\240\005\241\006\231\005\242\001\018\001&\001\255\004\234\000\231\005\244\002\176\000\235\000\255\002\177\005\246\006\000\006\233\006\022\006\023\000a\002\170\006\224\0012\002\021\000u\006\239\006.\000:\006*\002\191\001(\001\142\002\172\001)\006\234\001\012\001*\001+\006\024\006(\001\210\001\018\001&\006 \004\172\004\027\006+\007j\003y\001r\005\244\007w\000\238\002\193\002\000\005\246\006\000\007\188\006\225\002\169\000\235\001s\001,\002\167\000\235\0016\007U\001\012\006\226\006*\001i\001j\0009\001\018\001\021\002d\000|\002\169\000\235\002\021\000~\006\219\007\163\002`\002a\001j\000\145\006+\007!\001\231\001k\002E\006\240\001m\001n\000\130\002G\007V\002\133\006\220\006\235\007\155\006\222\001\012\002\t\002\003\002\138\006\241\001\012\001\018\001\021\006\223\006\236\001\214\001\018\001\021\007\164\006\229\002H\002\161\005F\000\231\006\231\001\238\000\235\000\236\001\132\001\242\0007\001\018\002\176\005\164\004w\002\177\003y\001\141\006\233\001\142\001q\007\156\002\170\006\224\000\235\000\231\005\165\006\239\000\235\000\236\005\188\002\191\000\132\001\142\002\172\003y\006\234\002\020\001\212\002\003\000\149\001\012\006D\007\175\002a\001j\000\238\001\018\001\021\007\n\001\243\001r\001\012\007\151\005\164\002\193\006\155\006\194\001\018\001\021\006\225\000\133\001\022\001s\003\\\002\167\000\235\005\165\004z\001\244\006\226\005\172\001i\001j\001\237\000\145\0011\002d\000\150\002\169\000\235\000\148\004\031\006\219\006\196\002`\002a\001j\004\238\000\237\006\157\007\152\001k\002E\006\240\001m\001n\001\018\006\153\006n\002\133\006\220\007q\006\198\006\222\005\164\006\158\005Q\002\138\006\241\005t\006\160\007\177\006\223\006\236\006\176\005\164\006\200\005\165\006\229\001\026\002\161\005\166\001\027\006\231\000\175\001N\000\179\001\132\005\165\000\238\006\199\002\176\005\171\000\174\002\177\003]\001\141\006\233\001\142\001q\003y\002\170\006\224\006\196\006\015\001P\001\029\003q\001j\006\166\002\191\005\158\001\142\002\172\007\178\006\234\002\169\000\235\000\180\002\021\006r\001\214\006\198\000\231\006\253\007|\000\235\000\255\006\242\001\249\001r\001\238\000\235\000\184\002\193\001\242\006F\001\018\001\237\006\225\001\012\001\234\001s\000\189\002\167\000\235\001\018\001&\003y\006\226\006\199\001\238\001#\000\238\000=\001\242\002d\001\018\002\169\000\235\004\027\007\004\006\219\001\012\002`\002a\001j\001\031\000\202\001\018\001\021\001C\003{\006\240\004\136\0007\001\243\006\153\007T\002\133\006\220\006\235\0007\006\222\001 \001\026\005*\002\138\006\241\000\235\001\018\001&\006\223\006\236\001\214\001\244\001\243\002\007\006\229\007b\002\161\007s\007}\006\231\001\238\000\238\000\206\001\132\001\242\007\139\001\018\002\176\006\022\006\023\002\177\004\152\001\141\006\233\001\142\001q\005W\002\170\006\224\006\b\004\149\004\151\007+\005\164\001p\006\165\002\191\004\235\001\142\002\172\006'\006\234\007~\0012\006 \004\172\005\165\007\133\001\018\005*\005\196\001(\000\235\001\214\001)\001\243\002\005\001*\001+\005\211\002\193\004\132\004\172\001\238\006g\006\225\005-\001\242\001\142\001\018\002\167\005\024\001j\005\\\001\244\006\226\000\235\006i\000\145\001\031\000\177\001\231\002d\001,\002\169\000\235\0016\007\134\006\219\000\222\002`\002a\001j\000\228\007W\007X\001 \000\231\001\237\006\240\000\235\000\236\001\018\001&\0007\002\133\006\220\006\235\001\243\006\222\001i\001j\003y\002\138\006\241\007W\007X\007\135\006\223\006\236\006 \004\172\007\005\007\140\006\229\001\142\002\161\001\244\006\155\006\231\001k\001z\000\185\001m\001n\0007\007\136\002\176\001\012\006K\002\177\006 \004\172\006\233\001\018\001\021\000\238\002\170\006\224\006\196\000\243\003\132\006\244\0048\000\235\000\255\002\191\001(\001\142\002\172\001)\006\234\006\157\001*\001+\002\011\000\170\004\155\006\198\003y\002`\002a\001j\000\182\001{\001\014\001|\002/\006\158\001^\002\193\001\018\001e\006\160\005h\006\225\001\251\006\167\003\146\004\156\002\167\005\181\001\018\004\192\006\252\006\226\006\199\002\022\001q\003y\000\235\000\238\002d\003\205\002\169\000\235\000\235\000\255\006\219\001\130\002`\002a\001j\005'\004\172\0010\005\187\005\183\001\006\006\240\002\020\001s\007\190\007\191\000\235\002\133\007\193\001\181\001j\006\222\007\159\001\t\002Y\002\138\006\241\003y\005\185\002\011\006\223\007\195\003\234\005\137\005\183\001\025\006\229\006O\002\161\001k\002t\006\231\001m\001n\000\145\001\254\001\218\001\231\001\237\002\176\005\186\001\018\002\177\005\185\002\023\006\233\000\190\001:\007\160\002\170\006\224\002\022\002c\005\020\000\235\001\026\005*\005c\002\191\000\235\001\142\002\172\0015\006\234\002d\005\186\002\169\000\235\001\132\001\012\007\131\002\201\004\000\003s\003t\001\018\001&\001\133\000\203\001\142\001q\003y\002\193\000\212\001\012\004\152\003y\006\225\000\215\003z\001\018\001\021\002\167\0019\001\026\0015\006\219\006\226\002`\002a\001j\007\210\005\t\000\223\002d\001F\002\169\000\235\001\130\001[\002\011\007\202\005b\002\133\007\203\000\238\002\023\006\222\007\198\003y\001s\002\138\007\167\000\235\004\152\002\021\006\223\007\211\001\172\002\170\007\019\004\158\001\142\001a\002\161\000\226\006\241\001\170\002\171\004\233\001\142\002\172\002\022\001\031\0059\000\235\006\229\000\238\004\003\004\b\001\018\006\231\000\238\005\173\007\168\001x\006\224\000\238\005\189\002\176\001 \005\160\002\177\000\229\001\238\006\233\001\018\001&\001\242\002\170\001\018\003y\000\238\000\145\001\214\005\249\001\231\002\004\002\191\0007\001\142\002\172\001\031\006\234\001\238\001\132\007\021\000\239\001\242\005\155\001\018\007\022\000\235\006\225\001\133\000\244\001\142\001q\002\167\001 \004\136\004{\002\193\006\226\000\238\001\018\001&\002\023\001\129\001\243\002d\006\015\002\169\000\235\005*\001\138\006\219\000\235\002`\002a\001j\001(\007\023\007\215\001)\005\167\007\132\001*\001+\001\243\005\167\004\160\000\238\002\133\006\220\006\250\007\024\006\222\001i\001j\003y\002\138\006\241\005\197\003\\\003y\006\223\006\236\001\244\006\028\004\149\004\151\006\229\004\163\002\161\004z\000\238\006\231\001k\001z\001(\001m\001n\001)\000\238\002\176\001*\001+\002\177\000\231\004\164\006\233\000\235\000\236\001\137\002\170\006\224\004\136\002`\002a\001j\002Q\005l\004\172\002\191\001\176\001\142\002\172\007\031\006\234\001\142\003y\004\167\002\133\000\231\007\025\007\026\000\235\000\236\001L\006\155\002\138\001{\001\187\001|\002/\001J\004\201\002\193\007\027\007\028\003y\007c\006\225\002\161\005\167\004\028\004\178\002\167\006\022\006\023\007\029\004\172\006\226\007&\003y\006$\004\149\004\151\001b\002d\003y\002\169\000\235\006\157\004\252\006\219\001\130\002`\002a\001j\006\031\001y\007V\001\192\006 \004\172\006\240\001\198\001s\006\158\007\202\000\235\002\133\007\203\006\160\004\180\006\222\001\200\006\164\002Y\002\138\006\241\007*\005\015\001\209\006\223\007\206\000\238\004\173\005\001\000j\006\229\001\026\002\161\000\238\001\027\006\231\002\167\001N\006\150\004\136\002$\004\247\000\145\002\176\006\003\001\231\002\177\004z\002d\006\233\002\169\000\235\007\023\002\170\006\224\004\253\000\238\001P\001\029\002'\001\214\005\002\002\191\001\215\001\142\002\172\007\024\006\234\002*\000\238\001\238\001\012\001\132\005=\001\242\000\238\001\018\001\018\001\021\001\018\002\173\001\133\004z\001\142\001q\000\238\002\193\001\012\007G\004\149\004\151\006\225\000\238\001\018\001&\0007\002\167\007@\002\011\002-\003y\006\226\007_\002\176\001#\005\006\002\177\0023\002d\000\238\002\169\000\235\002P\002\170\006\219\001\243\002`\002a\001j\001\031\003y\007\209\002\191\001C\001\142\002\172\003y\002\015\000\238\002\011\002\022\002\133\006\220\000\235\001\244\006\222\001 \000\238\006\184\002\138\006\241\002U\001\018\001&\006\223\006\246\002\193\003y\007?\002\\\006\229\001\026\002\161\004h\001\027\006\231\005K\001=\002\024\004z\001\197\002\022\001\018\002\176\000\235\002l\002\177\002z\000\238\006\233\006\012\004\172\005\007\002\170\006\224\001\203\000\238\001B\001\029\002\130\001\214\000\238\002\191\001\236\001\142\002\172\002\136\006\234\002\165\0012\001\238\001\211\005\"\003y\001\242\002\023\001\018\001(\005/\002\181\001)\001\224\001\012\001*\001+\001M\002\193\001\012\001\018\001&\000\238\006\225\005\235\001\018\001&\002\011\002\167\005\169\000\238\0052\000\235\006\226\001\026\002\187\001#\001\027\002\023\002\196\002d\001,\002\169\000\235\0016\001\226\000\238\001\243\000\238\007\017\004\172\001\031\005\236\006-\005\237\001C\002\012\006\249\006\219\002\022\000\238\001\029\000\235\001\241\006\162\002\207\001\244\000\238\001 \000\238\001\026\002\213\006\241\001\027\001\018\001&\006\220\005:\002\219\006\222\000\238\002\225\006\229\006\145\005\238\002\231\000\235\006\231\006\223\002\002\001\026\004c\006\137\002\237\003y\002\176\001\214\001\029\002\177\001\246\001\026\006\233\002\243\005\212\000\238\002\170\001\238\001#\000\238\004_\001\242\002#\001\018\006\188\002\191\006\015\001\142\002\172\006\224\006\234\005\239\0012\001\031\002&\002\023\003y\003y\001\029\002\011\001(\005\240\005\241\001)\005\242\000\238\001*\001+\001M\002\193\001 \000\238\002\249\002)\001#\002\255\001\018\001&\000\238\002,\001\026\000\238\001\243\001\027\0022\000\238\006\225\006.\002m\001\031\006\018\002\022\001,\000\238\000\235\0016\006\226\005>\002>\003y\002;\001\244\000\238\003\005\005\214\002A\001 \001\029\003\011\001\031\003\017\005\244\001\018\001&\003\023\003\029\005\246\006\000\006\169\001\031\006\227\000\235\002L\0012\002O\006\015\001 \003#\005L\005]\006*\001(\001\018\001&\001)\006\228\001 \001*\001+\006/\003y\000\238\001\018\005\217\000\238\006\229\002T\003)\006+\003/\006\231\0035\007)\001#\006\022\006\023\002\023\003;\006\162\0012\003y\002[\001\026\001,\006\233\001\027\0016\001(\001\031\007N\001)\005a\000\238\001*\001+\006\024\006(\000\238\003A\000\238\006 \004\172\006\234\000\238\000\238\001 \002k\001(\003E\001\029\001)\001\018\001&\001*\001+\001\026\000\238\001(\001\027\001,\005\218\002y\0016\001*\001+\000\231\002\129\006\015\000\235\000\236\002\135\003\156\005\148\005\165\001\026\005\223\000\238\005\220\000\238\001;\000\238\003\165\001\029\002\148\002\164\003\174\000\238\001\214\003|\001,\001\248\002\190\005\180\006\022\006\023\001#\006\155\001\238\0012\002\180\006\015\001\242\002\186\001\018\003\184\002\195\001(\000\238\003\193\001)\001\031\007\\\001*\001+\006\024\006(\002\206\000\238\003\202\006 \004\172\007\025\007\026\003\213\003\222\002\212\001\026\001 \001#\001\027\006\157\003\231\001=\001\018\001&\007\027\007\028\003\238\001,\002\011\000\238\0016\001\243\001\031\002\218\002\224\006\158\007\029\004\172\002\230\000\238\006\160\001>\001\029\000\238\006\161\004=\001\026\002\236\001V\001 \001\244\001\031\004B\004I\002\242\001\018\001&\004j\002\248\004R\002\022\004\\\000\238\000\235\006\022\006\023\000\238\001\026\001 \0012\001\027\003y\002\254\001=\001\018\001&\000\238\001(\004i\004o\001)\000\238\000\238\001*\001+\006\024\006(\003\004\001#\000\238\006 \004\172\003\n\001>\001\029\000\238\003\016\006\022\006\023\004~\001T\004\143\0012\001\031\003\022\004\145\004\169\001C\003\028\001,\001(\004\174\0016\001)\000\238\003\"\001*\001+\007J\007K\001 \000\238\000\238\006 \004\172\002\023\001\018\001&\000\238\001(\000\238\004\186\001)\003y\001\031\001*\001+\003(\001\026\003.\001#\001\027\001,\005\184\001=\0016\0034\000\238\000\238\003:\001\026\001 \004\195\001\027\003@\001\031\001=\001\018\001&\001C\0077\001.\003y\003K\001>\001\029\002\011\002\011\000\238\003R\000\238\001?\001 \0012\000\238\000\238\001>\001\029\001\018\001&\000\238\001(\004\210\001R\001)\003r\003y\001*\001+\001M\003\155\002`\002a\001j\003\164\004r\004v\004\236\002\022\002\022\000\238\000\235\000\235\004\242\000\231\005\224\002\133\000\235\000\236\004\249\004\255\001#\001(\001,\002\138\001)\0016\003\173\001*\001+\004\n\000\238\003\183\001#\003\192\0012\001\031\002\161\000\231\003y\001C\000\235\000\236\001(\005\232\006\155\001)\003\201\001\031\001*\001+\001M\001C\001 \0073\002\011\005\018\003\212\005\023\001\018\001&\000\238\002`\002a\001j\001 \005&\002\011\005\245\006\155\005.\001\018\001&\002\023\002\023\001,\000\238\002\133\0016\006\157\003\221\003y\000\238\003\230\004\196\002\138\0051\002\022\000\238\000\238\000\235\007\147\003\237\004\021\000j\006\158\004\237\004\029\002\161\002\022\006\160\002\167\000\235\006\157\006\171\004*\0012\004<\002`\002a\001j\005\253\0058\002d\001(\002\169\000\235\001)\0012\006\158\001*\001+\001M\002\133\006\160\000\238\001(\000\238\006\187\001)\005<\002\138\001*\001+\001M\000\238\005B\007\007\007\149\000\238\001\214\005H\004A\002\018\002\161\002\173\001,\004H\004Q\0016\001\238\004[\002\023\006\020\001\242\000\238\001\018\005S\001,\005f\004a\0016\002\167\003y\002\023\002`\002a\001j\002\176\001\214\004n\002\177\002o\005k\002d\005p\002\169\000\235\002\170\001\238\002\133\000\238\003y\001\242\002\011\001\018\005z\002\191\002\138\001\142\002\172\003y\003y\005\128\004\205\001\243\003y\004p\003y\000\238\005\139\002\161\002`\002a\001j\000\238\002\173\005\150\002\167\004}\000\238\002\193\004\168\005\019\001\244\005\168\002\022\002\133\004\176\000\235\002d\004\185\002\169\000\235\001\243\002\138\000\238\004\194\000\238\002\176\005\154\004\179\002\177\004\203\005\175\006E\003y\004\209\002\161\002\170\003y\005\191\000\238\001\244\000\238\004\248\005\201\003y\002\191\003y\001\142\002\172\002\173\005\226\006h\000\238\005\248\004\241\006\002\002`\002a\001j\000\238\006\130\006\141\002\167\003F\001j\006\175\000\238\006\185\006\014\002\193\003y\002\133\002\176\000\238\002d\002\177\002\169\000\235\002\023\002\138\006\"\000\238\002\170\003b\001z\004g\001m\001n\0062\0068\006<\002\191\002\161\001\142\002\172\004\243\000\238\004\246\006X\002\167\000\238\001\026\002`\002a\001j\006\189\002\173\000\238\003y\006\193\006\128\002d\000\238\002\169\000\235\002\193\006\197\002\133\006\209\000\238\001\214\006\186\000\238\004t\000\238\002\138\003g\003s\003t\002\176\001\238\004M\002\177\003y\001\242\006\133\001\018\000\238\002\161\002\170\005\005\006\172\006\216\002\173\004\251\005\004\003y\003y\002\191\000\238\001\142\002\172\005\000\005\003\005\017\005\022\002\167\000\238\000\238\000\238\005!\006\138\001\130\002`\002a\001j\002\176\000\238\002d\002\177\002\169\000\235\002\193\005 \001s\001\243\002\170\000\235\002\133\000\238\006\230\005%\003y\006\168\006\144\002\191\002\138\001\142\002\172\001\031\000\238\006\152\0049\006\191\001\244\006\211\0050\005;\0057\002\161\002\173\005G\002\167\005A\000\238\006\237\001 \003w\003x\002\193\000\238\006\219\001\018\001&\002d\0072\002\169\000\235\006\247\007%\002`\002a\001j\002\176\000\231\007\020\002\177\000\235\000\236\006\220\000\238\005C\006\222\002\170\005Z\002\133\005N\007 \005Y\001\132\007.\006\223\002\191\002\138\001\142\002\172\002\173\003y\001\133\0041\001\142\001q\000\238\000\238\007P\006\155\002\161\0070\005T\003y\000\238\005X\000\238\002\167\000\238\001\026\002\193\001(\001\027\002\176\001)\006\224\002\177\001*\001+\002d\003y\002\169\000\235\002\170\002`\002a\001j\005e\003y\005j\005\200\003y\002\191\006\157\001\142\002\172\001\029\005o\000\238\002\133\005r\005v\005~\0073\002`\002a\001j\002\138\005\133\006\158\000\238\002\173\006\225\000\238\006\160\005\144\002\193\005\199\006\205\002\133\002\161\005\192\006\226\007^\002\167\005\193\005\198\002\138\005\202\005\203\000\238\005\234\005\227\004'\002\176\007i\002d\002\177\002\169\000\235\002\161\005\228\001#\005\233\002\170\005\255\006\238\005\251\005\252\005\254\006)\001\026\007\196\002\191\001\027\001\142\002\172\001\031\006\r\001\214\007\207\006\228\004\199\007\212\002`\002a\001j\006\017\002\173\001\238\006\019\006\229\006\021\001\242\001 \001\018\006\231\002\193\001\029\002\133\001\018\001&\006!\0061\002\167\0063\0064\002\138\0069\006=\006\233\002\176\006A\003\255\002\177\006S\002d\006Z\002\169\000\235\002\161\002\170\006^\006v\002\167\006\139\006\163\006\173\006\234\006\218\002\191\006\212\001\142\002\172\001\243\006\213\002d\006\217\002\169\000\235\006\232\002`\002a\001j\001#\007\015\007#\001<\002\173\007$\007(\007O\007S\001\244\002\193\001(\002\133\007]\001)\001\031\007a\001*\001+\007\182\002\138\000\000\000\000\000\000\002\173\000\000\002\159\003_\000\000\000\000\002\177\0040\001 \002\161\000\000\000\000\000\000\002\170\001\018\001&\002\167\000\000\000\000\001,\000\000\000\000\002\191\002\176\001\142\002\172\002\177\000\000\002d\000\000\002\169\000\235\000\000\002\170\002`\002a\001j\000\000\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\002\193\000\000\000\000\002\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\002\173\001'\000\000\002\175\000\000\000\000\002\193\000\000\000\000\001(\002\161\000\000\001)\002\167\000\000\001*\001+\000\000\000\000\000\000\002`\002a\001j\002\176\000\000\002d\002\177\002\169\000\235\000\000\000\000\001i\001j\002\170\000\000\002\133\000\000\000\000\000\000\000\000\003W\001,\002\191\002\138\001\142\002\172\000\000\000\000\003Z\002\203\000\000\001k\002E\000\000\001m\001n\002\161\002\173\002`\002a\001j\000\000\001\214\000\000\000\000\004\214\002\193\000\000\000\000\000\000\000\000\000\000\001\238\002\133\002\167\000\000\001\242\000\000\001\018\002F\002\176\002\138\001\214\002\177\000\000\004\217\002d\002\202\002\169\000\235\002\170\000\000\001\238\000\000\002\161\000\000\001\242\001\214\001\018\002\191\004\220\001\142\002\172\000\000\000\000\000\000\000\000\001\238\000\000\000\000\000\000\001\242\000\000\001\018\000\000\001\026\000\000\001\243\002\173\000\000\002\167\000\000\000\000\002\193\000\000\000\000\000\000\000\000\000\000\000\000\001r\000\000\002d\000\000\002\169\000\235\001\244\001\243\002`\002a\001j\002\176\001s\000\000\002\177\000\235\000\000\000\000\000\000\000\000\000\000\002\170\001\243\002\133\000\000\000\000\001\244\000\000\002\167\000\000\002\191\002\138\001\142\002\172\002\173\001i\001j\003H\000\000\000\000\002d\001\244\002\169\000\235\002\161\000\000\000\000\002G\000\000\000\000\000\000\000\000\004\183\000\000\002\193\001k\002E\002\176\001m\001n\002\177\000\000\000\000\000\000\000\000\000\000\000\000\002\170\003[\003a\000\000\000\000\002\173\001\031\000\000\000\000\002\191\001\132\001\142\002\172\000\000\000\000\000\000\002F\000\000\000\000\001\141\000\000\001\142\001q\001 \000\000\002`\002a\001j\002\176\001\018\001&\002\177\0075\002\193\000\000\000\000\000\000\000\000\002\170\000\000\002\133\002\167\000\000\000\000\000\000\000\000\000\000\002\191\002\138\001\142\002\172\000\000\000\000\002d\003O\002\169\000\235\000\000\000\000\000\000\000\000\002\161\000\000\002`\002a\001j\000\000\001r\000\000\000\000\000\000\002\193\000\000\000\000\000\000\000\000\000\000\000\000\002\133\001s\001i\001j\000\235\000\000\001(\002\173\002\138\001)\000\000\000\000\001*\001+\003V\000\000\000\000\000\000\000\000\006f\000\000\002\161\001k\002E\000\000\001m\001n\000\000\000\000\000\000\002\176\000\000\001\214\002\177\000\000\004\225\002G\000\000\0073\000\000\002\170\000\000\001\238\000\000\000\000\000\000\001\242\002\167\001\018\002\191\002F\001\142\002\172\002`\002a\001j\000\000\003[\003a\002d\000\000\002\169\000\235\000\000\000\000\000\000\001\132\000\000\002\133\000\000\000\000\000\000\000\000\002\193\000\000\001\141\002\138\001\142\001q\000\000\000\000\000\000\003Y\000\000\000\000\002\167\000\000\001\243\000\000\002\161\000\000\002\173\000\000\000\000\000\000\000\000\000\000\002d\000\000\002\169\000\235\001r\000\000\002`\002a\001j\001\244\000\000\000\000\000\000\000\000\000\000\000\000\001s\002\176\000\000\000\235\002\177\002\133\000\000\000\000\000\000\000\000\000\000\002\170\000\000\002\138\000\000\000\000\002\173\000\000\001\214\000\000\002\191\004\228\001\142\002\172\000\000\000\000\002\161\000\000\001\238\000\000\000\000\000\000\001\242\000\000\001\018\002G\000\000\000\000\000\000\002\176\002\167\000\000\002\177\000\000\002\193\000\000\000\000\000\000\006\219\002\170\000\000\000\000\002d\000\000\002\169\000\235\003[\003a\002\191\000\000\001\142\002\172\000\000\007\202\000\000\001\132\007\203\000\000\000\000\006\222\002`\002a\001j\001\243\001\141\000\000\001\142\001q\006\223\000\000\000\000\000\000\002\193\000\000\002\173\002\133\000\000\000\000\000\000\000\000\002\167\000\000\001\244\002\138\000\000\000\000\000\000\000\000\000\000\003f\000\000\000\000\002d\000\000\002\169\000\235\002\161\002\176\006\224\000\000\002\177\000\000\002`\002a\001j\000\000\000\000\002\170\002`\002a\001j\000\000\001\214\000\000\000\000\004\231\002\191\000\000\001\142\002\172\000\000\000\000\001\238\002\133\002\173\004\024\001\242\000\000\001\018\000\000\000\000\002\138\004 \000\000\000\000\006\225\000\000\003i\001\214\000\000\002\193\004\245\000\000\000\000\002\161\006\226\000\000\003_\001\238\000\000\002\177\003`\001\242\000\000\001\018\000\000\004X\002\170\001i\001j\002\167\000\000\002`\002a\001j\007\205\002\191\001\243\001\142\002\172\000\000\000\000\002d\001\214\002\169\000\235\005E\002\133\001k\002E\000\000\001m\001n\001\238\006\228\002\138\001\244\001\242\000\000\001\018\002\193\003\127\000\000\001\243\006\229\000\000\000\000\000\000\002\161\006\231\000\000\000\000\002c\000\000\002\173\000\000\002F\000\000\002\167\002`\002a\001j\001\244\006\233\004#\000\000\002\169\000\235\000\255\000\000\002d\000\000\002\169\000\235\002\133\000\000\000\000\002\176\001\243\000\000\002\177\006\234\002\138\000\000\000\000\000\000\000\000\002\170\003\130\000\000\000\000\000\000\000\000\000\000\000\000\002\161\002\191\001\244\001\142\002\172\000\000\004\027\002\173\000\000\000\000\000\000\000\000\001r\000\000\000\000\000\000\000\000\002\167\000\000\000\000\000\000\002`\002a\001j\001s\002\193\000\000\000\235\000\000\002d\002\176\002\169\000\235\002\177\002\170\000\000\002\133\000\000\000\000\000\000\002\170\000\000\000\000\002\171\002\138\001\142\002\172\000\000\000\000\002\191\003\179\001\142\002\172\000\000\000\000\000\000\000\000\002\161\000\000\002G\000\000\002\173\000\000\000\000\002\167\000\000\000\000\000\000\002`\002a\001j\000\000\006\219\002\193\000\000\000\000\002d\000\000\002\169\000\235\002I\003a\000\000\002\133\002\176\000\000\000\000\002\177\000\000\001\132\006\220\002\138\000\000\006\222\002\170\000\000\000\000\003\188\001\141\000\000\001\142\001q\006\223\002\191\002\161\001\142\002\172\000\000\002\173\000\000\000\000\000\000\000\000\000\000\000\000\002`\002a\001j\000\000\000\000\000\000\002\167\000\000\000\000\000\000\000\000\000\000\002\193\000\000\000\000\002\133\002\176\006\224\002d\002\177\002\169\000\235\000\000\002\138\000\000\000\000\002\170\000\000\000\000\003\197\000\000\000\000\000\000\000\000\000\000\002\191\002\161\001\142\002\172\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002`\002a\001j\000\000\002\173\000\000\000\000\002\167\006\225\000\000\000\000\000\000\000\000\002\193\000\000\002\133\000\000\000\000\006\226\002d\000\000\002\169\000\235\002\138\000\000\001\026\000\000\002\176\0079\004\002\002\177\000\000\000\000\000\000\000\000\000\000\002\161\002\170\000\000\001i\001j\000\000\006\248\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\002\173\001\029\000\000\002\167\000\000\000\000\006\228\000\000\001k\001z\000\000\001m\001n\000\000\000\000\002d\006\229\002\169\000\235\002\193\000\000\006\231\000\000\002\176\000\000\000\000\002\177\000\000\000\000\000\000\000\000\002V\000\000\002\170\000\000\006\233\002`\002a\001j\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\002\173\000\000\002\167\000\000\002\133\001{\006\234\001|\002/\000\000\000\000\000\000\002\138\000\000\002d\001\031\002\169\000\235\004\005\002\193\002`\002a\001j\002\176\000\000\002\161\002\177\000\000\000\000\000\000\000\000\000\000\001 \002\170\000\000\002\133\000\000\000\000\001\018\001&\001\130\000\000\002\191\002\138\001\142\002\172\002\173\000\000\000\000\004+\000\000\000\000\001s\000\000\000\000\000\235\002\161\000\000\002`\002a\001j\000\000\000\000\002Y\000\000\000\000\002\193\000\000\001\214\002\176\000\000\005P\002\177\002\133\000\000\000\000\000\000\000\000\001\238\002\170\000\000\002\138\001\242\000\000\001\018\000\000\000\000\004-\002\191\002\167\001\142\002\172\000\000\001(\002\161\000\000\001)\000\000\000\000\001*\001+\002d\000\000\002\169\000\235\000\000\001\026\002`\002a\001j\000\000\000\000\002\193\000\000\000\000\000\000\000\000\001\132\000\000\000\000\002\167\000\000\002\133\001\243\000\000\001,\001\133\000\000\001\142\001q\002\138\000\000\002d\002\173\002\169\000\235\0043\000\000\002`\002a\001j\001\214\001\244\002\161\005V\000\000\000\000\000\000\000\000\000\000\000\000\001\238\000\000\002\133\000\000\001\242\002\176\001\018\002\167\002\177\000\000\002\138\000\000\000\000\002\173\000\000\002\170\0046\000\000\000\000\002d\000\000\002\169\000\235\002\161\002\191\000\000\001\142\002\172\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\176\000\000\000\000\002\177\000\000\000\000\000\000\001\031\000\000\001\243\002\170\000\000\002\193\000\000\000\000\002\173\000\000\000\000\000\000\002\191\002\167\001\142\002\172\000\000\001 \000\000\000\000\000\000\001\244\000\000\001\018\001&\002d\000\000\002\169\000\235\000\000\000\000\002\176\000\000\000\000\002\177\000\000\002\193\000\000\000\000\001\026\000\000\002\170\001\027\000\000\002\167\000\000\002`\002a\001j\000\000\002\191\000\000\001\142\002\172\000\000\000\000\002d\002\173\002\169\000\235\000\000\002\133\000\000\000\000\000\000\000\000\001\029\000\000\005\235\002\138\000\000\002`\002a\001j\002\193\004l\000\000\000\000\001(\000\000\002\176\001)\002\161\002\177\001*\001+\002\133\000\000\002\173\000\000\002\170\000\000\000\000\000\000\002\138\000\000\005\236\000\000\005\237\002\191\004y\001\142\002\172\000\000\000\000\000\000\000\000\002\161\000\000\000\000\002K\002\176\001#\000\000\002\177\001\214\000\000\000\000\005_\000\000\000\000\002\170\000\000\002\193\000\000\001\238\000\000\001\031\005\238\001\242\002\191\001\018\001\142\002\172\000\000\000\000\000\000\000\000\000\000\000\000\002`\002a\001j\000\000\001 \000\000\002\167\000\000\000\000\000\000\001\018\001&\000\000\000\000\002\193\002\133\000\000\000\000\002d\000\000\002\169\000\235\000\000\002\138\005\239\002`\002a\001j\000\000\004\171\001\243\002\167\000\000\000\000\005\240\005\241\002\161\005\242\000\000\000\000\002\133\000\000\000\000\002d\000\000\002\169\000\235\000\000\002\138\001\244\002\173\000\000\000\000\000\000\005\r\000\000\000\000\007;\000\000\000\000\006,\002\161\000\000\000\000\000\000\001(\000\000\000\000\001)\000\000\000\000\001*\001+\002\176\000\000\002\173\002\177\000\000\000\000\000\000\000\000\000\000\000\000\002\170\005\244\000\000\000\000\000\000\000\000\005\246\006\000\000\000\002\191\000\000\001\142\002\172\000\000\001,\002\176\000\000\002\167\002\177\000\000\006*\000\000\000\000\000\000\000\000\002\170\002`\002a\001j\002d\000\000\002\169\000\235\002\193\002\191\000\000\001\142\002\172\006+\000\000\000\000\002\133\002\167\000\000\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\002d\006@\002\169\000\235\002\193\000\000\000\000\002\173\002\161\000\000\000\000\000\000\000\000\000\000\000\000\001\214\000\000\000\000\005g\000\000\000\000\002`\002a\001j\000\000\001\238\000\000\000\000\000\000\001\242\002\176\001\018\002\173\002\177\000\000\000\000\002\133\000\000\000\000\000\000\002\170\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\002\191\006C\001\142\002\172\000\000\000\000\002\176\000\000\002\161\002\177\000\000\000\000\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\000\000\001\243\000\000\002\167\002\193\002\191\000\000\001\142\002\172\002`\002a\001j\000\000\000\000\000\000\002d\000\000\002\169\000\235\000\000\001\244\006\219\000\000\000\000\002\133\000\000\000\000\000\000\000\000\002\193\000\000\000\000\002\138\001i\001j\000\000\007\202\000\000\006R\007\203\000\000\000\000\006\222\000\000\000\000\002\161\000\000\002\173\000\000\000\000\000\000\006\223\002\167\001k\001z\000\000\001m\001n\000\000\002`\002a\001j\000\000\000\000\002d\000\000\002\169\000\235\000\000\000\000\002\176\000\000\000\000\002\177\002\133\000\000\002\131\000\000\000\000\000\000\002\170\006\224\002\138\000\000\000\000\000\000\000\000\000\000\006U\002\191\000\000\001\142\002\172\000\000\000\000\002\161\002\173\001{\000\000\001|\002/\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\167\002`\002a\001j\002\193\000\000\000\000\000\000\000\000\006\225\002\176\000\000\002d\002\177\002\169\000\235\002\133\000\000\000\000\006\226\002\170\000\000\000\000\001\130\002\138\000\000\000\000\000\000\000\000\002\191\006b\001\142\002\172\000\000\000\000\001s\000\000\002\161\000\235\007\204\002`\002a\001j\000\000\002\173\000\000\002Y\000\000\000\000\000\000\002\167\000\000\000\000\002\193\000\000\002\133\000\000\000\000\006\228\000\000\000\000\000\000\002d\002\138\002\169\000\235\000\000\002\176\006\229\006e\002\177\000\000\000\000\006\231\000\000\000\000\002\161\002\170\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\191\006\233\001\142\002\172\000\000\000\000\000\000\000\000\002\173\000\000\000\000\000\000\001i\001j\001\132\002\167\000\000\000\000\000\000\006\234\000\000\000\000\000\000\001\133\002\193\001\142\001q\002d\000\000\002\169\000\235\002\176\001k\002E\002\177\001m\001n\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\000\000\000\000\002`\002a\001j\002\191\000\000\001\142\002\172\002\167\000\000\000\000\000\000\000\000\002\173\000\000\000\000\002\133\000\000\000\000\000\000\002d\000\000\002\169\000\235\002\138\000\000\000\000\000\000\002\193\000\000\006z\000\000\000\000\000\000\000\000\000\000\002\176\002\161\000\000\002\177\000\000\000\000\000\000\000\000\000\000\000\000\002\170\002`\002a\001j\000\000\000\000\002\173\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\000\000\002\133\000\000\000\000\001r\000\000\000\000\001\026\000\000\002\138\001\027\000\000\000\000\000\000\002\176\006}\001s\002\177\002\193\000\235\000\000\000\000\002\161\000\000\002\170\000\000\000\000\002`\002a\001j\000\000\000\000\000\000\002\191\001\029\001\142\002\172\000\000\000\000\000\000\002\167\000\000\002\133\000\000\005\026\000\000\000\000\002`\002a\001j\002\138\006\206\002d\000\000\002\169\000\235\006\129\002\193\000\000\000\000\007h\000\000\002\133\002\161\000\000\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\007m\000\000\000\000\000\000\001#\001\132\000\000\002\161\002\173\000\000\002\167\000\000\000\000\000\000\001\141\000\000\001\142\001q\000\000\001\031\000\000\000\000\002d\000\000\002\169\000\235\000\000\000\000\006\208\000\000\000\000\002\176\000\000\000\000\002\177\000\000\001 \000\000\000\000\000\000\000\000\002\170\001\018\001&\000\000\000\000\000\000\000\000\000\000\000\000\002\191\002\167\001\142\002\172\002\173\002`\002a\001j\000\000\000\000\000\000\000\000\000\000\002d\000\000\002\169\000\235\000\000\000\000\000\000\002\133\002\167\000\000\000\000\002\193\000\000\000\000\002\176\002\138\000\000\002\177\000\000\000\000\002d\007o\002\169\000\235\002\170\000\000\0012\000\000\002\161\000\000\000\000\000\000\002\173\002\191\001(\001\142\002\172\001)\000\000\000\000\001*\001+\005#\001\026\000\000\000\000\001$\000\000\000\000\000\000\000\000\000\000\002\173\000\000\000\000\002\176\000\000\002\193\002\177\001i\001j\000\000\000\000\000\000\000\000\002\170\001,\000\000\000\000\0016\001\029\000\000\000\000\000\000\002\191\002\176\001\142\002\172\002\177\001k\002E\000\000\001m\001n\000\000\002\170\002`\002a\001j\000\000\000\000\000\000\002\167\000\000\002\191\000\000\001\142\002\172\002\193\000\000\000\000\002\133\000\000\000\000\002d\000\000\002\169\000\235\000\000\002\138\000\000\002`\002a\001j\000\000\000\000\000\000\000\000\002\193\004\190\000\000\000\000\002\161\000\000\000\000\000\000\002\133\000\000\000\000\000\000\000\000\001\031\000\000\000\000\002\138\000\000\002\173\000\000\002`\002a\001j\000\000\000\000\000\000\004e\000\000\000\000\002\161\001 \000\000\000\000\000\000\000\000\002\133\001\018\001&\000\000\000\000\001r\002\176\000\000\002\138\002\177\000\000\000\000\000\000\000\000\000\000\000\000\002\170\001s\003\247\000\000\000\235\002\161\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\000\000\000\000\002\167\000\000\000\000\000\000\000\000\002`\002a\001j\000\000\000\000\000\000\000\000\002d\000\000\002\169\000\235\002\193\000\000\000\000\006\206\002\133\000\000\000\000\001(\000\000\002\167\001)\000\000\002\138\001*\001+\000\000\000\000\001i\001j\000\000\000\000\002d\003\246\002\169\000\235\002\161\000\000\000\000\002\173\000\000\000\000\000\000\000\000\001\132\000\000\000\000\002\167\001k\001z\001,\001m\001n\001\141\000\000\001\142\001q\000\000\000\000\002d\000\000\002\169\000\235\000\000\002\173\003\137\000\000\006\207\000\000\000\000\000\000\002\137\002\170\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\000\000\000\000\000\000\003\137\002\173\001{\000\000\001|\002/\000\000\002\170\001i\001j\002\167\000\000\000\000\000\000\000\000\002\193\002\191\000\000\001\142\002\172\000\000\000\000\002d\000\000\002\169\000\235\000\000\003\137\001k\001z\000\000\001m\001n\000\000\002\170\000\000\000\000\001\130\001i\001j\002\193\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\001s\000\000\002\166\000\235\000\000\002\173\000\000\000\000\000\000\001k\001z\002Y\001m\001n\000\000\000\000\001i\001j\002\193\000\000\000\000\000\000\000\000\001{\000\000\001|\002/\000\000\000\000\000\000\000\000\003\137\002\182\000\000\000\000\000\000\001k\001z\002\170\001m\001n\000\000\000\000\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\001{\000\000\001|\002/\000\000\001\130\002\188\000\000\000\000\000\000\000\000\000\000\001\132\000\000\000\000\000\000\000\000\001s\002\193\000\000\000\235\001\133\000\000\001\142\001q\000\000\000\000\001{\002Y\001|\002/\000\000\001i\001j\000\000\001\130\000\000\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\235\000\000\001k\001z\000\000\001m\001n\000\000\002Y\000\000\000\000\000\000\001\130\001i\001j\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001s\002\197\000\000\000\235\000\000\000\000\001i\001j\001\132\001k\001z\002Y\001m\001n\000\000\000\000\000\000\001\133\000\000\001\142\001q\000\000\001{\000\000\001|\002/\001k\002E\000\000\001m\001n\000\000\002\208\000\000\000\000\000\000\000\000\000\000\001\132\000\000\001i\001j\000\000\000\000\000\000\000\000\000\000\001\133\000\000\001\142\001q\000\000\000\000\001{\000\000\001|\002/\001\130\001i\001j\001k\001z\000\000\001m\001n\001\132\000\000\000\000\000\000\001s\000\000\000\000\000\235\000\000\001\133\000\000\001\142\001q\001k\001z\002Y\001m\001n\002\214\000\000\000\000\000\000\000\000\001\130\001i\001j\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001s\002\220\000\000\000\235\001{\001r\001|\002/\000\000\001k\001z\002Y\001m\001n\000\000\000\000\000\000\001s\000\000\000\000\000\235\000\000\001{\000\000\001|\002/\000\000\000\000\000\000\000\000\000\000\000\000\002\226\000\000\001\132\000\000\000\000\000\000\000\000\001\130\001i\001j\000\000\001\133\000\000\001\142\001q\000\000\000\000\000\000\000\000\001s\006\206\001{\000\235\001|\002/\001\130\000\000\000\000\001k\001z\002Y\001m\001n\001\132\000\000\000\000\000\000\001s\000\000\000\000\000\235\000\000\001\133\000\000\001\142\001q\000\000\000\000\002Y\000\000\001\132\002\232\000\000\000\000\000\000\000\000\001\130\001i\001j\001\141\000\000\001\142\001q\000\000\000\000\000\000\000\000\000\000\001s\000\000\000\000\000\235\001{\006\215\001|\002/\000\000\001k\001z\002Y\001m\001n\000\000\000\000\001\132\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\133\000\000\001\142\001q\000\000\000\000\000\000\002\238\000\000\001\132\000\000\000\000\000\000\000\000\001\130\001i\001j\000\000\001\133\000\000\001\142\001q\000\000\000\000\000\000\000\000\001s\000\000\001{\000\235\001|\002/\000\000\000\000\000\000\001k\001z\002Y\001m\001n\001\132\000\000\000\000\000\000\001i\001j\000\000\000\000\000\000\001\133\000\000\001\142\001q\000\000\000\000\000\000\000\000\000\000\002\244\000\000\000\000\000\000\000\000\001\130\001k\001z\000\000\001m\001n\000\000\000\000\000\000\001i\001j\000\000\001s\000\000\000\000\000\235\001{\000\000\001|\002/\000\000\000\000\000\000\002Y\002\250\000\000\000\000\000\000\001\132\001k\001z\000\000\001m\001n\000\000\000\000\000\000\001\133\000\000\001\142\001q\000\000\000\000\000\000\000\000\001{\000\000\001|\002/\000\000\000\000\001\130\003\000\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\235\000\000\000\000\000\000\000\000\000\000\000\000\001{\002Y\001|\002/\001\132\001i\001j\001\130\000\000\000\000\000\000\000\000\000\000\001\133\000\000\001\142\001q\000\000\000\000\001s\000\000\000\000\000\235\000\000\000\000\001k\001z\000\000\001m\001n\002Y\000\000\000\000\001i\001j\001\130\000\000\000\000\000\000\001i\001j\000\000\000\000\000\000\000\000\000\000\000\000\001s\003\006\000\000\000\235\000\000\000\000\001k\001z\001\132\001m\001n\002Y\001k\001z\000\000\001m\001n\001\133\000\000\001\142\001q\000\000\001{\000\000\001|\002/\000\000\000\000\000\000\003\012\000\000\000\000\000\000\000\000\000\000\003\018\000\000\001\132\000\000\000\000\000\000\000\000\000\000\001i\001j\000\000\001\133\000\000\001\142\001q\001{\000\000\001|\002/\000\000\000\000\001{\001\130\001|\002/\000\000\000\000\000\000\001k\001z\001\132\001m\001n\000\000\001s\000\000\000\000\000\235\000\000\001\133\000\000\001\142\001q\000\000\000\000\002Y\000\000\000\000\000\000\000\000\001\130\003\024\000\000\000\000\000\000\000\000\001\130\001i\001j\000\000\000\000\000\000\001s\000\000\000\000\000\235\000\000\000\000\001s\000\000\000\000\000\235\001{\002Y\001|\002/\000\000\001k\001z\002Y\001m\001n\000\000\000\000\000\000\000\000\000\000\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\132\003\030\000\000\000\000\000\000\000\000\000\000\000\000\001\130\001\133\000\000\001\142\001q\001\026\000\000\000\000\000\000\000\000\000\000\000\000\001s\000\000\001{\000\235\001|\002/\000\000\000\000\001\132\000\000\000\000\002Y\000\000\000\000\001\132\000\000\000\000\001\133\000\000\001\142\001q\001i\001j\001\133\000\000\001\142\001q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001i\001j\001\130\000\000\000\000\000\000\001k\001z\000\000\001m\001n\000\000\000\000\000\000\001s\000\000\000\000\000\235\000\000\000\000\001k\001z\000\000\001m\001n\002Y\000\000\000\000\000\000\003$\001\132\000\000\000\000\000\000\000\000\000\000\000\000\001i\001j\001\133\000\000\001\142\001q\003*\000\000\000\000\001\031\000\000\000\000\000\000\001{\000\000\001|\002/\000\000\000\000\000\000\001k\001z\000\000\001m\001n\000\000\001 \001{\000\000\001|\002/\000\000\001\018\001&\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\132\0030\001\026\000\000\000\000\000\000\001\130\000\000\000\000\001\133\000\000\001\142\001q\001\026\000\000\000\000\005\208\000\000\001s\000\000\001\130\000\235\001{\000\000\001|\002/\000\000\000\000\000\000\002Y\000\000\000\000\001s\000\000\000\000\000\235\000\000\000\000\001i\001j\001\029\000\000\000\000\002Y\000\000\001(\000\000\000\000\001)\000\000\000\000\001*\001+\000\000\000\000\001i\001j\001\130\001k\001z\000\000\001m\001n\000\000\000\000\000\000\000\000\000\000\000\000\001s\000\000\000\000\000\235\000\000\000\000\001k\001z\004\154\001m\001n\002Y\0036\000\000\001\132\000\000\000\000\000\000\000\000\000\000\000\000\001\031\000\000\001\133\000\000\001\142\001q\000\000\001\132\003<\000\000\000\000\001\031\001{\000\000\001|\002/\001\133\001 \001\142\001q\000\000\000\000\000\000\001\018\001&\002`\002a\001j\001 \001{\000\000\001|\002/\000\000\001\018\001&\000\000\000\000\000\000\000\000\002\133\000\000\000\000\000\000\001\132\001i\001j\001\130\002\138\000\000\000\000\000\000\000\000\001\133\000\000\001\142\001q\000\000\003\135\001s\000\000\002\161\000\235\000\000\001\130\001k\001z\000\000\001m\001n\002Y\002`\002a\001j\000\000\000\000\001s\000\000\001(\000\235\000\000\001)\000\000\000\000\001*\001+\002\133\002Y\003B\001(\000\000\000\000\001)\000\000\002\138\001*\001+\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\139\000\000\000\000\002\161\000\000\001{\004\162\001|\002/\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\001\132\002\167\000\000\000\000\002`\002a\001j\000\000\000\000\001\133\000\000\001\142\001q\002d\000\000\002\169\000\235\001\132\000\000\002\133\001\130\000\000\000\000\000\000\000\000\000\000\001\133\002\138\001\142\001q\000\000\000\000\001s\000\000\000\000\000\235\000\000\003\141\000\000\000\000\002\161\000\000\000\000\002Y\000\000\002\173\000\000\002\167\000\000\000\000\002`\002a\001j\000\000\000\000\000\000\000\000\000\000\000\000\002d\000\000\002\169\000\235\000\000\000\000\002\133\000\000\000\000\000\000\000\000\000\000\003\137\000\000\002\138\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\000\000\003\144\000\000\000\000\002\161\002\191\000\000\001\142\002\172\002\173\000\000\000\000\000\000\000\000\000\000\001\132\002`\002a\001j\000\000\000\000\000\000\002\167\000\000\001\133\000\000\001\142\001q\000\000\002\193\000\000\002\133\000\000\000\000\002d\003\137\002\169\000\235\000\000\002\138\000\000\000\000\002\170\000\000\000\000\000\000\000\000\000\000\000\000\003\151\000\000\002\191\002\161\001\142\002\172\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002`\002a\001j\000\000\002\173\000\000\002\167\000\000\001i\001j\000\000\000\000\000\000\002\193\000\000\002\133\000\000\000\000\002d\000\000\002\169\000\235\000\000\002\138\000\000\000\000\000\000\000\000\001k\001z\003\137\001m\001n\003\160\000\000\000\000\002\161\002\170\001i\001j\000\000\000\000\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\002\173\003\157\000\000\000\000\002\167\000\000\000\000\000\000\001k\001z\000\000\001m\001n\000\000\000\000\000\000\002d\000\000\002\169\000\235\002\193\000\000\001{\000\000\001|\002/\003\137\000\000\000\000\000\000\000\000\003\166\000\000\002\170\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\002\173\000\000\002\167\000\000\001{\000\000\001|\002/\000\000\001\130\000\000\000\000\000\000\000\000\002d\000\000\002\169\000\235\002\193\000\000\000\000\001s\000\000\000\000\000\235\000\000\003\137\000\000\000\000\002`\002a\001j\002Y\002\170\002`\002a\001j\000\000\000\000\001\130\001i\001j\002\191\000\000\001\142\002\172\002\173\000\000\000\000\002\133\000\000\001s\003\241\000\000\000\235\000\000\000\000\002\138\000\000\000\000\001k\001z\002Y\001m\001n\000\000\002\193\003\169\000\000\000\000\002\161\000\000\003\137\000\000\000\000\000\000\003\242\000\000\000\000\002\170\000\000\000\000\000\000\003\175\000\000\000\000\001\132\005\235\002\191\000\000\001\142\002\172\000\000\000\000\000\000\001\133\000\000\001\142\001q\001i\001j\000\000\000\000\000\000\001{\000\000\001|\002/\000\000\000\000\000\000\000\000\002\193\000\000\000\000\005\236\001\132\005\237\000\000\001k\001z\000\000\001m\001n\000\000\001\133\000\000\001\142\001q\002c\000\000\000\000\000\000\000\000\002\167\000\000\001i\001j\000\000\001\130\000\000\002d\003\185\002\169\000\235\000\000\002d\005\238\002\169\000\235\000\000\001s\000\000\000\000\000\235\000\000\001k\001z\000\000\001m\001n\000\000\002Y\001{\000\000\001|\002/\000\000\000\000\000\000\000\000\001\026\000\000\000\000\000\000\000\000\000\000\003\244\002\173\003\194\000\000\000\000\000\000\005\239\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\240\005\241\000\000\005\242\000\000\001\130\000\000\001{\000\000\001|\002/\003\137\000\000\002\170\000\000\000\000\000\000\001s\002\170\000\000\000\235\000\000\002\171\001\132\001\142\002\172\005\243\002\191\002Y\001\142\002\172\000\000\001\133\000\000\001\142\001q\000\000\000\000\001i\001j\000\000\000\000\001\130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\244\002\193\000\000\000\000\001s\005\246\006\000\000\235\001k\001z\000\000\001m\001n\000\000\000\000\002Y\001\031\000\000\000\000\006*\000\000\000\000\000\000\002`\002a\001j\000\000\002`\002a\001j\000\000\003\203\001\132\001 \000\000\000\000\000\000\006+\002\133\001\018\001&\001\133\002\133\001\142\001q\000\000\002\138\001i\001j\000\000\002\138\000\000\001{\000\000\001|\002/\003\208\000\000\000\000\002\161\003\217\000\000\000\000\002\161\000\000\000\000\000\000\001k\001z\001\132\001m\001n\000\000\000\000\000\000\000\000\000\000\000\000\001\133\000\000\001\142\001q\000\000\000\000\000\000\001i\001j\001\130\000\000\000\000\003\214\000\000\000\000\000\000\001(\000\000\000\000\001)\000\000\001s\001*\001+\000\235\000\000\000\000\001k\001z\000\000\001m\001n\002Y\001{\000\000\001|\002/\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\000\000\004\166\002\167\003\223\000\000\002`\002a\001j\000\000\000\000\002d\000\000\002\169\000\235\002d\000\000\002\169\000\235\000\000\000\000\002\133\001\130\000\000\000\000\001{\000\000\001|\002/\002\138\000\000\000\000\000\000\000\000\001s\000\000\000\000\000\235\000\000\003\226\001\132\000\000\002\161\002\173\000\000\002Y\000\000\002\173\000\000\001\133\000\000\001\142\001q\000\000\000\000\000\000\000\000\000\000\001i\001j\001\130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\137\000\000\000\000\001s\003\137\000\000\000\235\002\170\000\000\001k\001z\002\170\001m\001n\002Y\000\000\002\191\000\000\001\142\002\172\002\191\000\000\001\142\002\172\000\000\000\000\000\000\000\000\000\000\000\000\001\132\000\000\003\232\000\000\000\000\000\000\000\000\002\167\000\000\001\133\002\193\001\142\001q\000\000\002\193\000\000\001i\001j\000\000\002d\000\000\002\169\000\235\001{\000\000\001|\002/\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001k\001z\001\132\001m\001n\000\000\002`\002a\001j\000\000\000\000\001\133\000\000\001\142\001q\002\173\000\000\000\000\000\000\000\000\000\000\002\133\001\130\003\239\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\001s\000\000\000\000\000\235\000\000\003\250\000\000\003\137\002\161\000\000\001{\002Y\001|\002/\002\170\002`\002a\001j\000\000\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\000\000\002\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\001\130\000\000\002\193\003\253\000\000\000\000\002\161\002`\002a\001j\000\000\000\000\001s\000\000\000\000\000\235\000\000\000\000\000\000\000\000\001\132\000\000\002\133\002Y\000\000\000\000\000\000\002\167\000\000\001\133\002\138\001\142\001q\000\000\000\000\000\000\000\000\000\000\000\000\002d\004\014\002\169\000\235\002\161\000\000\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`\002a\001j\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\167\002\173\002\133\000\000\000\000\001i\001j\001\132\000\000\000\000\002\138\000\000\002d\000\000\002\169\000\235\001\133\000\000\001\142\001q\004\018\000\000\000\000\002\161\000\000\001k\001z\003\137\001m\001n\000\000\000\000\000\000\000\000\002\170\000\000\000\000\002\167\000\000\001i\001j\000\000\000\000\002\191\002\173\001\142\002\172\000\000\004>\002d\000\000\002\169\000\235\000\000\000\000\000\000\000\000\000\000\000\000\001k\001z\000\000\001m\001n\000\000\000\000\000\000\002\193\000\000\001{\003\137\001|\002/\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\002\173\004C\000\000\000\000\000\000\002\191\002\167\001\142\002\172\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002d\000\000\002\169\000\235\001{\001\130\001|\002/\003\137\000\000\000\000\002\193\000\000\000\000\000\000\002\170\000\000\001s\000\000\000\000\000\235\001i\001j\000\000\002\191\000\000\001\142\002\172\002Y\000\000\000\000\000\000\002\173\000\000\000\000\000\000\000\000\000\000\000\000\001\130\000\000\001k\001z\000\000\001m\001n\001i\001j\002\193\000\000\000\000\001s\000\000\000\000\000\235\000\000\000\000\000\000\003\137\000\000\000\000\000\000\002Y\000\000\004J\002\170\001k\001z\000\000\001m\001n\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\001i\001j\001\132\000\000\000\000\001{\000\000\001|\002/\004S\000\000\001\133\000\000\001\142\001q\000\000\000\000\000\000\002\193\000\000\001k\001z\000\000\001m\001n\000\000\000\000\000\000\000\000\000\000\001{\000\000\001|\002/\000\000\000\000\001\132\000\000\003F\001j\001\130\000\000\000\000\004]\000\000\001\133\000\000\001\142\001q\000\000\000\000\000\000\001s\000\000\000\000\000\235\000\000\000\000\003b\001z\000\000\001m\001n\002Y\001{\001\130\001|\002/\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001s\000\000\000\000\000\235\002`\002a\001j\000\000\000\000\000\000\000\000\002Y\000\000\000\000\000\000\000\000\000\000\000\000\001i\001j\000\000\000\000\001\130\000\000\003g\003s\003t\004W\000\000\000\000\002`\002a\001j\000\000\001s\000\000\000\000\000\235\001k\001z\001\132\001m\001n\000\000\000\000\002Y\000\000\000\000\000\000\001\133\000\000\001\142\001q\004O\000\000\000\000\000\000\000\000\000\000\000\000\001\130\004\187\000\000\000\000\000\000\001\132\000\000\000\000\000\000\001i\001j\000\000\001s\000\000\001\133\000\235\001\142\001q\000\000\000\000\000\000\000\000\001{\000\000\001|\002/\000\000\000\000\000\000\001k\001z\000\000\001m\001n\000\000\000\000\000\000\000\000\000\000\001\132\001i\001j\000\000\000\000\002c\003w\004\177\000\000\001\133\000\000\001\142\001q\004\207\000\000\000\000\000\000\002d\001\130\002\169\000\235\001k\001z\000\000\001m\001n\001\026\000\000\000\000\001\027\001s\002c\000\000\000\235\001{\000\000\001|\002/\001\132\000\000\000\000\002Y\000\000\002d\004\211\002\169\000\235\001\133\001\026\001\142\001q\001\027\000\000\001\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\005\026\000\000\001{\000\000\001|\002/\001\130\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\000\000\005\029\000\000\001s\002\170\000\000\000\235\005\026\000\000\000\000\000\000\000\000\000\000\002\171\002Y\001\142\002\172\001\132\000\000\000\000\000\000\001#\001\130\005\147\000\000\000\000\001\133\000\000\001\142\001q\002\170\000\000\000\000\000\000\001s\000\000\001\031\000\235\000\000\002\171\000\000\001\142\002\172\001#\000\000\002Y\001i\001j\000\000\000\000\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\001\031\001\018\001&\000\000\000\000\006~\000\000\000\000\001k\002E\001\132\001m\001n\000\000\000\000\000\000\000\000\001 \000\000\001\133\000\000\001\142\001q\001\018\001&\000\000\000\000\000\000\000\000\000\000\001\026\000\000\000\000\001\027\000\000\000\000\002F\000\000\000\000\001\026\000\000\001\132\001\027\000\000\000\000\000\000\000\000\000\000\0012\000\000\001\133\000\000\001\142\001q\000\000\000\000\001(\001\029\000\000\001)\000\000\000\000\001*\001+\005#\000\000\001\029\005\026\000\000\000\000\0012\000\000\000\000\000\000\000\000\000\000\005\026\000\000\001(\000\000\000\000\001)\000\000\006c\001*\001+\005#\001r\001,\000\000\000\000\0016\006q\000\000\000\000\001\026\000\000\000\000\001\027\001s\000\000\000\000\000\235\001#\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\001#\0016\000\000\000\000\000\000\000\000\001\031\000\000\000\000\000\000\001\029\000\000\000\000\000\000\000\000\001\031\000\000\000\000\000\000\000\000\005\026\000\000\002G\001 \000\000\000\000\000\000\000\000\000\000\001\018\001&\000\000\001 \000\000\000\000\000\000\006{\000\000\001\018\001&\000\000\000\000\000\000\003[\003a\000\000\000\000\000\000\000\000\003F\001j\000\000\001\132\000\000\001i\001j\001#\000\000\000\000\003F\001j\001\141\000\000\001\142\001q\000\000\000\000\000\000\000\000\003b\001z\001\031\001m\001n\001k\001z\0012\001m\001n\003b\001z\000\000\001m\001n\001(\0012\000\000\001)\001 \000\000\001*\001+\005#\001(\001\018\001&\001)\007\t\000\000\001*\001+\005#\001\026\000\000\000\000\001\027\000\000\000\000\000\000\000\000\000\000\000\000\003g\003s\003t\000\000\001,\000\000\001{\0016\001|\002/\003g\003s\003t\001,\000\000\000\000\0016\001\029\000\000\007<\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0012\000\000\000\000\000\000\000\000\000\000\000\000\001\130\001(\000\000\000\000\001)\001\130\000\000\001*\001+\005#\001\130\000\000\001s\000\000\000\000\000\235\000\000\001s\000\000\000\000\000\235\000\000\001s\000\000\000\000\000\235\000\000\001#\002Y\000\000\000\000\001\026\000\000\001,\001\027\000\000\0016\000\000\000\000\000\000\000\000\000\000\001\031\000\000\000\000\003w\006\140\000\000\000\000\001i\001j\000\000\000\000\000\000\000\000\003w\006\174\000\000\001\029\001 \000\000\002`\002a\001j\000\000\001\018\001&\000\000\004\139\001k\001z\000\000\001m\001n\000\000\000\000\002\133\001\132\000\000\000\000\000\000\000\000\001\132\007-\002\138\000\000\001\133\001\132\001\142\001q\000\000\001\133\000\000\001\142\001q\000\000\001\133\002\161\001\142\001q\000\000\000\000\000\000\000\000\001#\000\000\000\000\000\000\000\000\002`\002a\001j\0012\001{\000\000\001|\001\146\000\000\000\000\001\031\001(\000\000\000\000\001)\002\133\000\000\001*\001+\007C\000\000\000\000\000\000\002\138\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\000j\001\018\001&\000\000\002\161\000\000\000\000\001\130\000\000\000\000\000\000\001,\000\000\000\000\0016\000\000\000\000\000\000\000\000\001s\002\167\000\000\000\235\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002d\000\000\002\169\000\235\000\000\001i\001j\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0012\000\000\000\000\001i\001j\000\000\000\000\000\000\001(\001k\001z\001)\001m\001n\001*\001+\002\173\000\000\000\000\001\179\002\167\000\000\000\000\001k\001z\000\000\001m\001n\000\000\002`\002a\001j\002d\001\165\002\169\000\235\001\132\000\000\000\000\000\000\001,\000\000\004\222\004\146\002\133\001\133\000\000\001\142\001q\002\170\000\000\000\000\002\138\001{\000\000\001|\001\167\000\000\002\191\000\000\001\142\002\172\000\000\000\000\002\173\002\161\000\000\001{\000\000\001|\001\167\001i\001j\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\193\000\000\000\000\000\000\000\000\000\000\001\130\000\000\004\188\001k\001z\000\000\001m\001n\000\000\002\170\000\000\000\000\001s\001\169\001\130\000\235\000\000\000\000\002\191\000\000\001\142\002\172\002`\002a\001j\000\000\001s\000\000\000\000\000\235\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\133\002`\002a\001j\002\167\002\193\001i\001j\002\138\000\000\001{\000\000\001|\001\167\000\000\000\000\002d\000\000\002\169\000\235\000\000\002\161\000\000\000\000\003\241\000\000\001k\001z\000\000\001m\001n\000\000\002`\002a\001j\000\000\000\000\000\000\000\000\000\000\001\132\000\000\000\000\000\000\000\000\001\130\000\000\002\133\002\173\001\133\000\000\001\142\001q\000\000\001\132\002\138\000\000\001s\000\000\000\000\000\235\000\000\000\000\001\133\000\000\001\142\001q\000\000\002\161\000\000\001{\000\000\001|\002/\004^\000\000\000\000\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\002\167\001i\001j\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\000\000\002d\000\000\002\169\000\235\002c\000\000\000\000\000\000\001\130\001k\001z\000\000\001m\001n\000\000\000\000\002d\002\193\002\169\000\235\001s\000\000\000\000\000\235\000\000\001\132\000\000\000\000\000\000\000\000\000\000\0047\002\173\000\000\001\133\002\167\001\142\001q\000\000\000\000\001i\001j\000\000\000\000\002`\002a\001j\002d\000\000\002\169\000\235\000\000\003\243\001{\000\000\001|\0027\000\000\004U\002\133\001k\001z\000\000\001m\001n\002\170\000\000\002\138\000\000\000\000\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\002\173\002\161\002\170\000\000\000\000\000\000\001\132\000\000\000\000\001\130\000\000\002\171\000\000\001\142\002\172\001\133\000\000\001\142\001q\002\193\000\000\001s\006\219\000\000\000\235\001{\004/\001|\002/\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\000\000\000\000\000\000\007\193\000\000\002\191\006\222\001\142\002\172\000\000\000\000\000\000\000\000\000\000\002:\006\223\000\000\000\000\002`\002a\001j\000\000\000\000\001\130\000\000\000\000\000\000\000\000\002\167\002\193\000\000\000\000\000\000\002\133\000\000\001s\000\000\000\000\000\235\000\000\002d\002\138\002\169\000\235\000\000\006\224\002X\000\000\000\000\001\132\000\000\000\000\000\000\000\000\002\161\002`\002a\001j\001\133\000\000\001\142\001q\000\000\000\000\000\000\002`\002a\001j\000\000\000\000\002\133\000\000\002\173\000\000\000\000\000\000\000\000\000\000\002\138\000\000\002\133\000\000\006\225\000\000\000\000\000\000\000\000\000\000\002\138\000\000\000\000\002\161\006\226\000\000\000\000\000\000\000\000\000\000\003\245\000\000\001\132\002\161\000\000\000\000\000\000\002\170\000\000\000\000\000\000\001\133\000\000\001\142\001q\007\194\002\191\000\000\001\142\002\172\002\167\000\000\000\000\000\000\002`\002a\001j\000\000\000\000\000\000\000\000\000\000\002d\006\228\002\169\000\235\000\000\000\000\000\000\002\133\002\193\000\000\000\000\006\229\000\000\000\000\000\000\002\138\006\231\000\000\000\000\002`\002a\001j\000\000\000\000\000\000\002\167\000\000\000\000\002\161\000\000\006\233\000\000\002\173\000\000\002\133\002\167\000\000\002d\000\000\002\169\000\235\000\000\002\138\000\000\002`\002a\001j\002d\006\234\002\169\000\235\000\000\000\000\000\000\000\000\002\161\000\000\000\000\003}\002\133\000\000\000\000\000\000\000\000\000\000\002\170\000\000\002\138\000\000\002\173\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\002\173\002\161\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\000\000\002\183\000\000\000\000\002\193\000\000\000\000\000\000\002\170\000\000\002d\002\189\002\169\000\235\000\000\000\000\000\000\002\191\002\170\001\142\002\172\000\000\000\000\000\000\000\000\002\167\000\000\002\191\000\000\001\142\002\172\002`\002a\001j\000\000\000\000\000\000\002d\000\000\002\169\000\235\002\193\002\173\000\000\000\000\000\000\002\133\000\000\000\000\000\000\002\167\002\193\000\000\000\000\002\138\000\000\002`\002a\001j\000\000\000\000\000\000\002d\000\000\002\169\000\235\000\000\002\161\002\198\002\173\000\000\002\133\000\000\000\000\000\000\002\170\000\000\000\000\000\000\002\138\000\000\002`\002a\001j\002\191\000\000\001\142\002\172\000\000\000\000\000\000\000\000\002\161\000\000\002\173\002\209\002\133\000\000\001i\001j\000\000\000\000\002\170\000\000\002\138\000\000\000\000\000\000\002\193\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\002\161\001k\001l\002\215\001m\001n\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\002\167\000\000\000\000\000\000\002\193\002\191\000\000\001\142\002\172\002`\002a\001j\002d\000\000\002\169\000\235\000\000\000\000\000\000\002`\002a\001j\000\000\000\000\002\133\002\167\000\000\000\000\000\000\002\193\000\000\000\000\002\138\000\000\002\133\000\000\000\000\002d\000\000\002\169\000\235\000\000\002\138\000\000\002\173\002\161\000\000\000\000\000\000\000\000\002\167\000\000\000\000\000\000\000\000\002\161\002`\002a\001j\000\000\000\000\000\000\002d\000\000\002\169\000\235\001r\000\000\000\000\002\173\002\221\002\133\000\000\000\000\000\000\000\000\000\000\002\170\001s\002\138\000\000\000\235\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\002\161\000\000\002\173\002\227\000\000\000\000\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\000\000\000\000\000\000\002\167\002\193\002\191\000\000\001\142\002\172\000\000\000\000\000\000\000\000\002\167\002\233\002d\000\000\002\169\000\235\000\000\000\000\002\170\000\000\000\000\000\000\002d\000\000\002\169\000\235\002\193\002\191\000\000\001\142\002\172\000\000\000\000\000\000\001\132\000\000\000\000\002`\002a\001j\000\000\000\000\000\000\001\141\002\173\001\142\001q\002\167\000\000\000\000\000\000\002\193\002\133\000\000\002\173\001i\001j\000\000\000\000\002d\002\138\002\169\000\235\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\239\000\000\000\000\002\161\000\000\001k\001\140\002\170\001m\001n\002\245\000\000\000\000\000\000\000\000\000\000\002\191\002\170\001\142\002\172\000\000\002\173\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\000\000\000\000\002`\002a\001j\000\000\000\000\000\000\002\193\000\000\000\000\000\000\000\000\000\000\000\000\002\251\000\000\002\133\002\193\000\000\000\000\000\000\002\170\000\000\000\000\002\138\000\000\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\002\167\000\000\000\000\002\161\002`\002a\001j\000\000\000\000\000\000\000\000\000\000\002d\000\000\002\169\000\235\000\000\001r\000\000\002\133\002\193\000\000\000\000\000\000\002`\002a\001j\002\138\000\000\001s\000\000\000\000\000\235\000\000\000\000\001i\001j\000\000\000\000\002\133\002\161\000\000\000\000\000\000\002\173\000\000\000\000\002\138\001i\001j\000\000\002`\002a\001j\000\000\001k\001z\000\000\001m\001n\002\161\002`\002a\001j\000\000\000\000\002\133\002\167\001k\001z\003\001\001m\001n\000\000\002\138\000\000\002\133\002\170\000\000\002d\000\000\002\169\000\235\000\000\002\138\000\000\002\191\002\161\001\142\002\172\000\000\000\000\000\000\000\000\001\132\000\000\000\000\002\161\000\000\001{\000\000\001|\006\255\001\141\002\167\001\142\001q\000\000\000\000\000\000\002\193\002\173\001{\000\000\001|\007\171\002d\007\173\002\169\000\235\000\000\000\000\000\000\000\000\002\167\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\130\000\000\002d\003\007\002\169\000\235\000\000\000\000\000\000\000\000\002\170\000\000\001s\001\130\002\173\000\235\000\000\002\167\000\000\002\191\000\000\001\142\002\172\000\000\000\000\001s\000\000\002\167\000\235\002d\000\000\002\169\000\235\000\000\002\173\000\000\000\000\000\000\000\000\002d\003\r\002\169\000\235\002\193\000\000\000\000\000\000\002\170\000\000\002`\002a\001j\000\000\000\000\000\000\000\000\002\191\000\000\001\142\002\172\003\019\002\173\000\000\000\000\002\133\000\000\000\000\002\170\000\000\000\000\000\000\002\173\002\138\000\000\000\000\000\000\002\191\001\132\001\142\002\172\002\193\000\000\000\000\000\000\000\000\002\161\001\133\003\025\001\142\001q\001\132\000\000\000\000\000\000\002\170\000\000\000\000\003\031\000\000\001\133\002\193\001\142\001q\002\191\002\170\001\142\002\172\000\000\002`\002a\001j\000\000\000\000\002\191\000\000\001\142\002\172\000\000\002`\002a\001j\000\000\000\000\002\133\000\000\000\000\000\000\002\193\002`\002a\001j\002\138\000\000\002\133\000\000\000\000\000\000\002\193\000\000\000\000\000\000\002\138\000\000\000\000\002\161\000\000\000\000\000\000\000\000\002\167\000\000\002b\000\000\000\000\002\161\002`\002a\001j\000\000\000\000\000\000\002d\000\000\002\169\000\235\002`\002a\001j\000\000\000\000\002\133\000\000\000\000\000\000\000\000\002`\002a\001j\002\138\000\000\002\133\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\138\000\000\002\133\002\161\000\000\002\173\000\000\000\000\000\000\000\000\002\138\000\000\000\000\002\161\000\000\000\000\000\000\000\000\000\000\000\000\002\167\000\000\000\000\002\161\000\000\000\000\000\000\000\000\000\000\000\000\002\167\003%\002d\000\000\002\169\000\235\000\000\000\000\002\170\000\000\002c\000\000\002d\000\000\002\169\000\235\000\000\002\191\000\000\001\142\002\172\000\000\002d\000\000\002\169\000\235\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\173\000\000\000\000\002\167\000\000\000\000\000\000\002\193\000\000\000\000\002\173\000\000\000\000\002\167\000\000\002d\000\000\002\169\000\235\000\000\000\000\000\000\000\000\002\167\000\000\002d\003+\002\169\000\235\000\000\000\000\001\026\000\000\002\170\001\027\002d\0031\002\169\000\235\000\000\000\000\000\000\002\191\002\170\001\142\002\172\000\000\002\173\002`\002a\001j\000\000\002\191\002\170\001\142\002\172\000\000\002\173\001\029\000\000\000\000\000\000\002\171\002\133\001\142\002\172\002\193\002\173\003P\000\000\000\000\002\138\000\000\0037\000\000\000\000\002\193\000\000\000\000\000\000\002\170\000\000\000\000\003=\002\161\000\000\000\000\000\000\000\000\002\191\002\170\001\142\002\172\003C\000\000\002`\002a\001j\000\000\002\191\002\170\001\142\002\172\000\000\001#\000\000\000\000\000\000\000\000\002\191\002\133\001\142\002\172\002\193\000\000\000\000\000\000\000\000\002\138\001\031\000\000\000\000\000\000\002\193\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\161\000\000\002\193\000\000\000\000\001 \000\000\002`\002a\001j\000\000\001\018\001&\000\000\000\000\000\000\000\000\002\167\000\000\000\000\000\000\000\000\002\133\000\000\002`\002a\001j\000\000\000\000\002d\002\138\002\169\000\235\000\000\000\000\000\000\000\000\000\000\000\000\002\133\000\000\000\000\000\000\002\161\002`\002a\001j\002\138\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\0012\002\133\002\161\002\173\000\000\000\000\002\167\000\000\001(\002\138\000\000\001)\000\000\000\000\001*\001+\002\145\000\000\002d\000\000\002\169\000\235\002\161\000\000\000\000\000\000\000\000\000\000\000\000\003\158\000\000\000\000\000\000\000\000\001i\001j\002\170\000\000\000\000\000\000\001,\000\000\000\000\0016\000\000\002\191\000\000\001\142\002\172\002\167\002\173\000\000\000\000\000\000\001k\002D\000\000\001m\001n\000\000\000\000\002d\000\000\002\169\000\235\000\000\002\167\000\000\000\000\002\193\000\000\000\000\000\000\002`\002a\001j\003\167\000\000\002d\000\000\002\169\000\235\000\000\002\170\000\000\000\000\002\167\000\000\002\133\000\000\000\000\000\000\002\191\002\173\001\142\002\172\002\138\000\000\002d\000\000\002\169\000\235\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\161\002\173\000\000\000\000\000\000\000\000\000\000\002\193\000\000\000\000\003\176\000\000\000\000\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\002\173\000\000\000\000\001r\000\000\002\191\003\186\001\142\002\172\000\000\000\000\000\000\000\000\002\170\000\000\001s\000\000\000\000\000\235\000\000\000\000\000\000\002\191\000\000\001\142\002\172\003\195\000\000\000\000\002\193\000\000\000\000\000\000\002\170\000\000\000\000\002`\002a\001j\000\000\000\000\000\000\002\191\002\167\001\142\002\172\002\193\000\000\000\000\000\000\000\000\002\133\000\000\000\000\000\000\002d\000\000\002\169\000\235\002\138\000\000\002`\002a\001j\000\000\000\000\002\193\002`\002a\001j\000\000\000\000\002\161\000\000\000\000\000\000\002\133\000\000\000\000\000\000\001\132\000\000\002\133\000\000\002\138\000\000\000\000\002\173\000\000\001\141\002\138\001\142\001q\000\000\000\000\000\000\000\000\002\161\000\000\000\000\000\000\000\000\000\000\002\161\002`\002a\001j\000\000\000\000\000\000\000\000\000\000\000\000\003\204\000\000\000\000\000\000\000\000\000\000\002\133\002\170\001\181\001j\000\000\000\000\000\000\000\000\002\138\000\000\002\191\000\000\001\142\002\172\000\000\000\000\000\000\002\167\000\000\000\000\000\000\002\161\001k\002t\000\000\001m\001n\000\000\000\000\002d\000\000\002\169\000\235\000\000\002\193\002`\002a\001j\000\000\000\000\000\000\000\000\002\167\000\000\000\000\000\000\000\000\000\000\002\167\000\000\002\133\000\000\000\000\000\000\002d\000\000\002\169\000\235\002\138\000\000\002d\002\173\002\169\000\235\000\000\004\000\003s\003t\000\000\000\000\000\000\002\161\000\000\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\167\002\173\003\215\000\000\000\000\000\000\000\000\002\173\000\000\002\170\000\000\000\000\002d\000\000\002\169\000\235\001\130\000\000\002\191\000\000\001\142\002\172\000\000\000\000\000\000\000\000\000\000\003\224\001s\000\000\000\000\000\235\000\000\003\233\002\170\002`\002a\001j\000\000\000\000\002\170\000\000\002\193\002\191\002\173\001\142\002\172\000\000\000\000\002\191\002\167\001\142\002\172\000\000\000\000\000\000\000\000\004\007\002{\002`\002a\001j\002d\000\000\002\169\000\235\000\000\002\193\000\000\000\000\003\240\000\000\000\000\002\193\002\133\000\000\000\000\002\170\000\000\000\000\001\026\000\000\002\138\001\027\000\000\000\000\002\191\000\000\001\142\002\172\000\000\000\000\000\000\001\132\002\173\002\161\002`\002a\001j\000\000\000\000\000\000\001\133\000\000\001\142\001q\000\000\001\029\000\000\000\000\002\193\002\133\005\158\000\000\001\026\000\000\000\000\001\027\000\000\002\138\004E\000\000\000\000\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\000\000\002\161\000\000\000\000\002c\002\191\000\000\001\142\002\172\000\000\001\029\000\000\000\000\000\000\001\026\000\000\002d\001\027\002\169\000\235\004\139\000\000\001#\000\000\000\000\000\000\000\000\000\000\002\167\002\193\000\000\000\000\000\000\000\000\000\000\004\142\000\000\001\031\000\000\000\000\002d\001\029\002\169\000\235\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \001\026\001#\000\000\001\027\000\000\001\018\001&\000\000\000\000\000\000\002\167\000\000\000\000\000\000\000\000\000\000\001\031\002\173\000\000\000\000\000\000\000\000\002d\000\000\002\169\000\235\002\170\001\029\000\000\000\000\000\000\000\000\001#\001 \000\000\002\171\000\000\001\142\002\172\001\018\001&\000\000\001\026\004D\000\000\001\027\000\000\001\031\000\000\000\000\002\170\000\000\0012\000\000\002\173\000\000\000\000\000\000\000\000\002\191\001(\001\142\002\172\001)\001 \000\000\001*\001+\005\163\001\029\001\018\001&\000\000\001#\006\148\001\026\000\000\000\000\001\027\000\000\004K\000\000\000\000\002\193\000\000\000\000\0012\002\170\001\031\000\000\000\000\000\000\001,\000\000\001(\0016\002\191\001)\001\142\002\172\001*\001+\001\029\000\000\000\000\001 \000\000\000\000\000\000\000\000\000\000\001\018\001&\000\000\000\000\001#\001\026\0012\000\000\001\027\002\193\000\000\000\000\000\000\000\000\001(\001,\000\000\001)\004\146\001\031\001*\001+\005\176\001\026\000\000\005\179\001\027\000\000\000\000\000\000\000\000\000\000\001\029\007\143\000\000\000\000\001 \001#\000\000\000\000\000\000\000\000\001\018\001&\000\000\000\000\001,\0012\000\000\0016\001\029\000\000\001\031\000\000\000\000\001(\000\000\000\000\001)\000\000\000\000\001*\001+\005\176\000\000\000\000\006\192\000\000\000\000\001 \000\000\001\026\000\000\000\000\001\027\001\018\001&\000\000\001#\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\0012\0016\000\000\000\000\001\031\000\000\000\000\001#\001(\001\029\000\000\001)\000\000\000\000\001*\001+\005\163\001G\000\000\000\000\000\000\001 \001\031\000\000\000\000\000\000\000\000\001\018\001&\000\000\000\000\000\000\001\026\0012\000\000\005\215\000\000\000\000\000\000\001 \001,\001(\000\000\0016\001)\001\018\001&\001*\001+\007\144\000\000\000\000\000\000\000\000\000\000\001#\000\000\001i\001j\001\029\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\031\000\000\000\000\001,\0012\000\000\0016\001k\001z\000\000\001m\001n\001(\000\000\000\000\001)\000\000\001 \001*\001+\001]\000\000\0012\001\018\001&\001i\001j\000\000\000\000\000\000\001(\000\000\000\000\001)\000\000\000\000\001*\001+\0013\000\000\000\000\000\000\000\000\000\000\001,\001k\001z\0016\001m\001n\001\031\001{\000\000\001|\001\171\000\000\001i\001j\000\000\000\000\000\000\000\000\001,\000\000\000\000\0016\000\000\001 \000\000\000\000\0012\000\000\000\000\001\018\001&\000\000\001k\001z\001(\001m\001n\001)\001i\001j\001*\001+\001\130\000\000\000\000\001{\000\000\001|\001\161\000\000\000\000\001i\001j\000\000\001s\000\000\000\000\000\235\001k\001z\000\000\001m\001n\000\000\000\000\000\000\001,\000\000\000\000\001K\000\000\001k\001z\000\000\001m\001n\001{\000\000\001|\001\158\001\130\000\000\000\000\000\000\001(\000\000\000\000\001)\000\000\000\000\001*\001+\001s\000\000\000\000\000\235\000\000\000\000\000\000\000\000\000\000\000\000\001{\000\000\001|\001~\000\000\000\000\000\000\000\000\000\000\001\130\000\000\000\000\000\000\001{\001,\001|\001\128\001\132\001i\001j\000\000\001s\000\000\000\000\000\235\000\000\001\133\000\000\001\142\001q\000\000\000\000\000\000\000\000\000\000\001\130\000\000\000\000\001k\001z\000\000\001m\001n\000\000\000\000\000\000\000\000\001s\001\130\000\000\000\235\000\000\001i\001j\000\000\001\132\000\000\000\000\000\000\000\000\001s\000\000\000\000\000\235\001\133\000\000\001\142\001q\000\000\000\000\000\000\000\000\001k\001z\000\000\001m\001n\000\000\000\000\001i\001j\000\000\001{\000\000\001|\001\131\001\132\001\026\000\000\000\000\001\027\000\000\000\000\000\000\000\000\001\133\000\000\001\142\001q\001k\001z\000\000\001m\001n\002`\002a\001j\000\000\000\000\000\000\000\000\000\000\001\132\000\000\001\029\000\000\001{\001\130\001|\001\157\000\000\001\133\000\000\001\142\001q\001\132\000\000\002}\000\000\001s\000\000\000\000\000\235\000\000\001\133\000\000\001\142\001q\001\026\000\000\000\000\001\027\000\000\001{\000\000\001|\001\149\000\000\000\000\000\000\000\000\001\130\000\000\000\000\000\000\000\000\000\000\000\000\001\026\000\000\001#\001\027\000\000\001s\000\000\001\029\000\235\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\031\000\000\000\000\001\130\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\000\000\000\000\001s\000\000\001 \000\235\001\132\000\000\000\000\000\000\001\018\001&\000\000\000\000\000\000\001\133\002c\001\142\001q\000\000\000\000\001i\001j\001#\000\000\000\000\001\026\000\000\002d\001\027\002\169\000\235\000\000\000\000\000\000\000\000\000\000\000\000\001\031\000\000\001\132\001k\001z\001#\001m\001n\000\000\000\000\000\000\001\133\000\000\001\142\001q\001\029\000\000\001 \000\000\0012\001\031\000\000\000\000\001\018\001&\000\000\000\000\001(\000\000\001\132\001)\000\000\000\000\001*\001+\001\151\001\026\001 \001\133\001\027\001\142\001q\000\000\001\018\001&\000\000\000\000\001{\000\000\001|\001\154\000\000\000\000\000\000\000\000\002\170\000\000\000\000\000\000\001,\000\000\001#\0016\001\029\002\171\000\000\001\142\002\172\001i\001j\0012\000\000\000\000\000\000\000\000\000\000\001\031\000\000\001(\000\000\000\000\001)\001\130\000\000\001*\001+\001\186\000\000\001k\001z\0012\001m\001n\001 \001s\000\000\000\000\000\235\001(\001\018\001&\001)\000\000\000\000\001*\001+\001\228\000\000\000\000\001#\001,\001\026\000\000\0016\001\027\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\031\000\000\000\000\000\000\000\000\000\000\001,\000\000\001{\0016\001|\002]\000\000\000\000\001\029\000\000\000\000\001 \000\000\000\000\000\000\000\000\0012\001\018\001&\000\000\000\000\000\000\000\000\001\026\001(\000\000\001\027\001)\000\000\001\132\001*\001+\001\230\001\026\000\000\000\000\001\027\001\130\001\133\000\000\001\142\001q\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001s\001\029\000\000\000\235\000\000\001#\000\000\001,\000\000\000\000\0016\001\029\000\000\000\000\000\000\0012\000\000\000\000\000\000\000\000\001\031\000\000\000\000\001(\000\000\000\000\001)\000\000\000\000\001*\001+\0029\000\000\000\000\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\000\000\001\018\001&\000\000\000\000\001#\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001,\001\026\001#\0016\001\027\000\000\000\000\001\031\000\000\000\000\001\132\001\026\000\000\000\000\001\027\000\000\000\000\001\031\000\000\001\133\000\000\001\142\001q\000\000\001 \000\000\000\000\000\000\001\029\000\000\001\018\001&\000\000\000\000\001 \0012\000\000\000\000\001\029\000\000\001\018\001&\000\000\001(\000\000\001\026\001)\000\000\001\027\001*\001+\002v\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\029\000\000\001#\001,\000\000\0012\0016\000\000\000\000\000\000\000\000\000\000\001#\001(\000\000\0012\001)\001\031\000\000\001*\001+\002\143\000\000\001(\000\000\000\000\001)\001\031\000\000\001*\001+\002\147\000\000\000\000\001 \000\000\000\000\000\000\000\000\000\000\001\018\001&\000\000\000\000\001 \001,\001#\000\000\0016\000\000\001\018\001&\001i\001j\000\000\001,\000\000\000\000\0016\001i\001j\001\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001i\001j\000\000\001k\001z\000\000\001m\001n\000\000\001 \001k\001z\000\000\001m\001n\001\018\001&\000\000\0012\000\000\001k\001z\000\000\001m\001n\000\000\001(\000\000\0012\001)\000\000\000\000\001*\001+\003M\000\000\001(\000\000\000\000\001)\000\000\000\000\001*\001+\003T\000\000\000\000\001{\000\000\001|\003k\000\000\000\000\000\000\001{\000\000\001|\003m\001,\000\000\000\000\0016\0012\000\000\001{\000\000\001|\003o\001,\000\000\001(\0016\000\000\001)\000\000\000\000\001*\001+\003d\000\000\000\000\000\000\001\130\002`\002a\001j\000\000\000\000\000\000\001\130\000\000\000\000\000\000\000\000\001s\000\000\000\000\000\235\000\000\001\130\000\000\001s\001,\006\219\000\235\0016\004\024\000\000\000\000\000\000\000\000\001s\000\000\004 \000\235\001i\001j\000\000\007\202\000\000\000\000\007\203\000\000\000\000\006\222\001i\001j\000\000\000\000\000\000\000\000\000\000\000\000\006\223\000\000\001k\001z\004!\001m\001n\000\000\000\000\000\000\000\000\000\000\001k\001z\000\000\001m\001n\000\000\002`\002a\001j\000\000\000\000\000\000\000\000\000\000\001\132\000\000\000\000\000\000\006\224\000\000\000\000\001\132\000\000\001\133\001\026\001\142\001q\001\027\000\000\002\154\001\133\001\132\001\142\001q\001{\000\000\001|\003v\002c\000\000\001\133\000\000\001\142\001q\001{\000\000\001|\005\011\000\000\000\000\004#\001\029\002\169\000\235\000\255\006\225\000\000\000\000\000\000\000\000\000\000\001\026\000\000\000\000\001\027\006\226\000\000\000\000\000\000\001\130\000\000\000\000\000\000\000\000\001\026\000\000\000\000\001\027\000\000\001\130\000\000\001s\000\000\000\000\000\235\007\208\000\000\004\027\001\029\000\000\000\000\001s\000\000\000\000\000\235\000\000\000\000\001#\000\000\000\000\000\000\001\029\000\000\000\000\006\228\000\000\002c\000\000\000\000\000\000\000\000\000\000\001\031\000\000\006\229\002\170\000\000\000\000\002d\006\231\002\169\000\235\000\000\000\000\002\171\000\000\001\142\002\172\000\000\001 \000\000\000\000\000\000\006\233\001#\001\018\001&\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\132\001#\000\000\001\031\000\000\006\234\000\000\000\000\000\000\001\133\001\132\001\142\001q\000\000\000\000\000\000\001\031\000\000\000\000\001\133\001 \001\142\001q\000\000\000\000\000\000\001\018\001&\000\000\000\000\000\000\001\026\000\000\001 \001\027\000\000\0012\002\170\000\000\001\018\001&\000\000\001\026\000\000\001(\005\212\002\171\001)\001\142\002\172\001*\001+\005\028\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\000\000\000\000\000\000\001\026\000\000\000\000\001\027\000\000\001\029\000\000\000\000\000\000\0012\000\000\000\000\001,\000\000\000\000\0016\000\000\001(\001\026\000\000\001)\005\212\0012\001*\001+\005|\000\000\001\029\000\000\000\000\001(\000\000\000\000\001)\000\000\000\000\001*\001+\005\136\000\000\001#\000\000\000\000\000\000\000\000\001\029\000\000\000\000\000\000\001,\000\000\005\214\0016\000\000\000\000\001\031\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\0016\001\031\000\000\000\000\000\000\000\000\000\000\001 \001#\000\000\000\000\000\000\000\000\001\018\001&\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\001\031\001\018\005\217\005\214\000\000\000\000\001\026\000\000\000\000\005\212\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001 \001\031\000\000\000\000\000\000\000\000\001\018\001&\000\000\000\000\001\026\000\000\000\000\005\212\000\000\000\000\001\029\000\000\001 \000\000\0012\000\000\000\000\000\000\001\018\005\217\000\000\000\000\001(\000\000\000\000\001)\000\000\000\000\001*\001+\005\162\001\029\000\000\001(\000\000\000\000\005\218\000\000\000\000\001*\001+\000\000\000\000\000\000\000\000\000\000\000\000\0012\000\000\005\165\000\000\005\222\000\000\005\220\001,\001(\005\214\0016\001)\000\000\000\000\001*\001+\005\178\000\000\001,\000\000\000\000\000\000\000\000\000\000\001\031\000\000\001(\000\000\000\000\005\218\005\214\000\000\001*\001+\000\000\000\000\000\000\000\000\000\000\000\000\001,\001 \005\165\0016\005\221\001\031\005\220\001\018\005\217\000\000\000\000\000\000\001\026\000\000\000\000\001\027\000\000\000\000\001,\000\000\000\000\000\000\001 \000\000\001\026\000\000\000\000\001\027\001\018\005\217\000\000\000\000\000\000\001\026\000\000\000\000\001\027\000\000\000\000\001\029\000\000\000\000\000\000\000\000\000\000\000\000\001\026\000\000\000\000\005\212\000\000\001\029\000\000\000\000\001\026\000\000\000\000\005\212\000\000\000\000\001\029\000\000\001(\000\000\000\000\005\218\000\000\000\000\001*\001+\000\000\000\000\000\000\001\029\000\000\000\000\000\000\000\000\005\165\000\000\005\219\001\029\005\220\001(\000\000\001#\005\218\000\000\000\000\001*\001+\000\000\000\000\000\000\001,\000\000\000\000\001#\000\000\005\165\001\031\005\231\000\000\005\220\000\000\000\000\001#\000\000\000\000\000\000\000\000\000\000\001\031\000\000\000\000\001,\000\000\001 \000\000\005\214\000\000\001\031\000\000\001\018\001&\000\000\000\000\005\214\000\000\001 \000\000\000\000\000\000\000\000\001\031\001\018\001&\000\000\001 \000\000\000\000\000\000\001\031\000\000\001\018\001&\000\000\000\000\000\000\000\000\000\000\001 \000\000\000\000\000\000\000\000\000\000\001\018\005\217\001 \001\026\000\000\000\000\001\027\000\000\001\018\005\217\000\000\000\000\000\000\0012\000\000\000\000\001\026\000\000\000\000\001\027\000\000\001(\000\000\000\000\001)\0012\000\000\001*\001+\006N\001\029\000\000\000\000\001(\0012\000\000\001)\000\000\000\000\001*\001+\006`\001(\001\029\000\000\001)\000\000\000\000\001*\001+\006x\000\000\000\000\001,\000\000\001(\0016\000\000\005\218\000\000\000\000\001*\001+\001(\000\000\001,\005\218\000\000\0016\001*\001+\005\165\000\000\006\179\001,\005\220\001#\0016\000\000\005\165\000\000\006\203\001\026\005\220\000\000\001\027\000\000\001,\000\000\001#\000\000\001\031\000\000\000\000\000\000\001,\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\031\000\000\000\000\000\000\001 \001\029\000\000\000\000\000\000\000\000\001\018\001&\000\000\000\000\000\000\001\026\000\000\001 \001\027\000\000\000\000\000\000\000\000\001\018\001&\000\000\000\000\000\000\001\026\000\000\000\000\001\027\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\029\000\000\000\000\000\000\000\000\000\000\000\000\001\026\000\000\001#\001\027\000\000\000\000\001\029\000\000\0012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001(\001\031\000\000\001)\000\000\0012\001*\001+\007\002\000\000\000\000\001\029\000\000\001(\000\000\000\000\001)\000\000\001 \001*\001+\007B\000\000\001#\001\018\001&\002`\002a\001j\000\000\000\000\000\000\001,\000\000\000\000\0016\001#\000\000\001\031\000\000\000\000\000\000\000\000\000\000\000\000\001,\000\000\000\000\0016\003\241\000\000\001\031\000\000\000\000\000\000\001 \000\000\001#\000\000\000\000\000\000\001\018\001&\000\000\001\026\000\000\000\000\001\027\001 \000\000\000\000\0012\001\031\006\159\001\018\001&\000\000\000\000\000\000\001(\000\000\000\000\001)\006\219\000\000\001*\001+\007E\000\000\001 \000\000\001\029\002`\002a\001j\001\018\001&\000\000\007\202\000\000\000\000\007\203\000\000\000\000\006\222\002`\002a\001j\0012\000\000\000\000\001,\000\000\006\223\0016\002\168\001(\000\000\000\000\001)\000\000\0012\001*\001+\000\000\000\000\002c\000\000\002\192\001(\000\000\000\000\001)\000\000\000\000\001*\001+\001#\002d\000\000\002\169\000\235\0012\006\224\000\000\002`\002a\001j\001,\000\000\001(\001I\001\031\001)\000\000\000\000\001*\001+\000\000\000\000\000\000\001,\000\000\000\000\001\223\000\000\000\000\000\000\003\148\001 \000\000\000\000\000\000\000\000\003\244\001\018\001&\000\000\000\000\000\000\006\225\000\000\001,\000\000\000\000\001\225\000\000\000\000\000\000\000\000\006\226\000\000\002c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\170\002d\002c\002\169\000\235\000\000\000\000\007\213\000\000\002\171\000\000\001\142\002\172\000\000\002d\000\000\002\169\000\235\000\000\0012\000\000\000\000\000\000\000\000\000\000\000\000\006\228\001(\000\000\000\000\001)\000\000\000\000\001*\001+\000\000\006\229\000\000\000\000\000\000\000\000\006\231\002c\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002d\006\233\002\169\000\235\000\000\001,\000\000\000\000\004\141\000\000\000\000\000\000\002\170\000\000\000\000\000\000\000\000\000\000\000\000\006\234\000\000\002\171\000\000\001\142\002\172\002\170\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\171\000\000\001\142\002\172\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\170\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\171\000\000\001\142\002\172")) and semantic_action = [| @@ -1545,9 +1488,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4172 "src/ocaml/preprocess/parser_raw.mly" +# 4137 "src/ocaml/preprocess/parser_raw.mly" ( "+" ) -# 1551 "src/ocaml/preprocess/parser_raw.ml" +# 1494 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1570,9 +1513,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4173 "src/ocaml/preprocess/parser_raw.mly" +# 4138 "src/ocaml/preprocess/parser_raw.mly" ( "+." ) -# 1576 "src/ocaml/preprocess/parser_raw.ml" +# 1519 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1595,9 +1538,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3665 "src/ocaml/preprocess/parser_raw.mly" +# 3630 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1601 "src/ocaml/preprocess/parser_raw.ml" +# 1544 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1648,15 +1591,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3613 "src/ocaml/preprocess/parser_raw.mly" +# 3578 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _2 _sloc ) -# 1654 "src/ocaml/preprocess/parser_raw.ml" +# 1597 "src/ocaml/preprocess/parser_raw.ml" in -# 3668 "src/ocaml/preprocess/parser_raw.mly" +# 3633 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_alias(ty, tyvar) ) -# 1660 "src/ocaml/preprocess/parser_raw.ml" +# 1603 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__2_inlined1_, _startpos_ty_) in @@ -1664,15 +1607,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1670 "src/ocaml/preprocess/parser_raw.ml" +# 1613 "src/ocaml/preprocess/parser_raw.ml" in -# 3670 "src/ocaml/preprocess/parser_raw.mly" +# 3635 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1676 "src/ocaml/preprocess/parser_raw.ml" +# 1619 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1719,30 +1662,30 @@ module Tables = struct let _v : (Ast_helper.let_binding) = let attrs2 = let _1 = _1_inlined2 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1725 "src/ocaml/preprocess/parser_raw.ml" +# 1668 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1734 "src/ocaml/preprocess/parser_raw.ml" +# 1677 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2877 "src/ocaml/preprocess/parser_raw.mly" +# 2842 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklb ~loc:_sloc false body attrs ) -# 1746 "src/ocaml/preprocess/parser_raw.ml" +# 1689 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1765,9 +1708,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4056 "src/ocaml/preprocess/parser_raw.mly" +# 4021 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1771 "src/ocaml/preprocess/parser_raw.ml" +# 1714 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1790,9 +1733,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4057 "src/ocaml/preprocess/parser_raw.mly" +# 4022 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 1796 "src/ocaml/preprocess/parser_raw.ml" +# 1739 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1815,9 +1758,9 @@ module Tables = struct let _startpos = _startpos_type__ in let _endpos = _endpos_type__ in let _v : (Parsetree.core_type) = -# 3801 "src/ocaml/preprocess/parser_raw.mly" +# 3766 "src/ocaml/preprocess/parser_raw.mly" ( type_ ) -# 1821 "src/ocaml/preprocess/parser_raw.ml" +# 1764 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1846,35 +1789,35 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 1852 "src/ocaml/preprocess/parser_raw.ml" +# 1795 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3834 "src/ocaml/preprocess/parser_raw.mly" +# 3799 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 1858 "src/ocaml/preprocess/parser_raw.ml" +# 1801 "src/ocaml/preprocess/parser_raw.ml" in -# 3805 "src/ocaml/preprocess/parser_raw.mly" +# 3770 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr (tid, tys) ) -# 1863 "src/ocaml/preprocess/parser_raw.ml" +# 1806 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1872 "src/ocaml/preprocess/parser_raw.ml" +# 1815 "src/ocaml/preprocess/parser_raw.ml" in -# 3819 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1878 "src/ocaml/preprocess/parser_raw.ml" +# 1821 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1910,20 +1853,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 1916 "src/ocaml/preprocess/parser_raw.ml" +# 1859 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3836 "src/ocaml/preprocess/parser_raw.mly" +# 3801 "src/ocaml/preprocess/parser_raw.mly" ( [ ty ] ) -# 1922 "src/ocaml/preprocess/parser_raw.ml" +# 1865 "src/ocaml/preprocess/parser_raw.ml" in -# 3805 "src/ocaml/preprocess/parser_raw.mly" +# 3770 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr (tid, tys) ) -# 1927 "src/ocaml/preprocess/parser_raw.ml" +# 1870 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_ty_ in @@ -1931,15 +1874,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 1937 "src/ocaml/preprocess/parser_raw.ml" +# 1880 "src/ocaml/preprocess/parser_raw.ml" in -# 3819 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 1943 "src/ocaml/preprocess/parser_raw.ml" +# 1886 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -1990,9 +1933,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 1996 "src/ocaml/preprocess/parser_raw.ml" +# 1939 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -2000,24 +1943,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2004 "src/ocaml/preprocess/parser_raw.ml" +# 1947 "src/ocaml/preprocess/parser_raw.ml" in -# 1245 "src/ocaml/preprocess/parser_raw.mly" +# 1210 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2009 "src/ocaml/preprocess/parser_raw.ml" +# 1952 "src/ocaml/preprocess/parser_raw.ml" in -# 3838 "src/ocaml/preprocess/parser_raw.mly" +# 3803 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 2015 "src/ocaml/preprocess/parser_raw.ml" +# 1958 "src/ocaml/preprocess/parser_raw.ml" in -# 3805 "src/ocaml/preprocess/parser_raw.mly" +# 3770 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_constr (tid, tys) ) -# 2021 "src/ocaml/preprocess/parser_raw.ml" +# 1964 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -2025,15 +1968,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2031 "src/ocaml/preprocess/parser_raw.ml" +# 1974 "src/ocaml/preprocess/parser_raw.ml" in -# 3819 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2037 "src/ocaml/preprocess/parser_raw.ml" +# 1980 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2069,20 +2012,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2075 "src/ocaml/preprocess/parser_raw.ml" +# 2018 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3834 "src/ocaml/preprocess/parser_raw.mly" +# 3799 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 2081 "src/ocaml/preprocess/parser_raw.ml" +# 2024 "src/ocaml/preprocess/parser_raw.ml" in -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 3774 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_class (cid, tys) ) -# 2086 "src/ocaml/preprocess/parser_raw.ml" +# 2029 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos__2_ in @@ -2090,15 +2033,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2096 "src/ocaml/preprocess/parser_raw.ml" +# 2039 "src/ocaml/preprocess/parser_raw.ml" in -# 3819 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2102 "src/ocaml/preprocess/parser_raw.ml" +# 2045 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2141,20 +2084,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2147 "src/ocaml/preprocess/parser_raw.ml" +# 2090 "src/ocaml/preprocess/parser_raw.ml" in let tys = -# 3836 "src/ocaml/preprocess/parser_raw.mly" +# 3801 "src/ocaml/preprocess/parser_raw.mly" ( [ ty ] ) -# 2153 "src/ocaml/preprocess/parser_raw.ml" +# 2096 "src/ocaml/preprocess/parser_raw.ml" in -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 3774 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_class (cid, tys) ) -# 2158 "src/ocaml/preprocess/parser_raw.ml" +# 2101 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_ty_ in @@ -2162,15 +2105,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2168 "src/ocaml/preprocess/parser_raw.ml" +# 2111 "src/ocaml/preprocess/parser_raw.ml" in -# 3819 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2174 "src/ocaml/preprocess/parser_raw.ml" +# 2117 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2228,9 +2171,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2234 "src/ocaml/preprocess/parser_raw.ml" +# 2177 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -2238,24 +2181,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2242 "src/ocaml/preprocess/parser_raw.ml" +# 2185 "src/ocaml/preprocess/parser_raw.ml" in -# 1245 "src/ocaml/preprocess/parser_raw.mly" +# 1210 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2247 "src/ocaml/preprocess/parser_raw.ml" +# 2190 "src/ocaml/preprocess/parser_raw.ml" in -# 3838 "src/ocaml/preprocess/parser_raw.mly" +# 3803 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 2253 "src/ocaml/preprocess/parser_raw.ml" +# 2196 "src/ocaml/preprocess/parser_raw.ml" in -# 3809 "src/ocaml/preprocess/parser_raw.mly" +# 3774 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_class (cid, tys) ) -# 2259 "src/ocaml/preprocess/parser_raw.ml" +# 2202 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -2263,15 +2206,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2269 "src/ocaml/preprocess/parser_raw.ml" +# 2212 "src/ocaml/preprocess/parser_raw.ml" in -# 3819 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2275 "src/ocaml/preprocess/parser_raw.ml" +# 2218 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2314,15 +2257,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2320 "src/ocaml/preprocess/parser_raw.ml" +# 2263 "src/ocaml/preprocess/parser_raw.ml" in -# 3813 "src/ocaml/preprocess/parser_raw.mly" +# 3778 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_open (mod_ident, type_) ) -# 2326 "src/ocaml/preprocess/parser_raw.ml" +# 2269 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_type__ in @@ -2330,15 +2273,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2336 "src/ocaml/preprocess/parser_raw.ml" +# 2279 "src/ocaml/preprocess/parser_raw.ml" in -# 3819 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2342 "src/ocaml/preprocess/parser_raw.ml" +# 2285 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2369,24 +2312,24 @@ module Tables = struct let _endpos = _endpos_ident_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3815 "src/ocaml/preprocess/parser_raw.mly" +# 3780 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_var ident ) -# 2375 "src/ocaml/preprocess/parser_raw.ml" +# 2318 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_ident_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2384 "src/ocaml/preprocess/parser_raw.ml" +# 2327 "src/ocaml/preprocess/parser_raw.ml" in -# 3819 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2390 "src/ocaml/preprocess/parser_raw.ml" +# 2333 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2410,23 +2353,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3817 "src/ocaml/preprocess/parser_raw.mly" +# 3782 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 2416 "src/ocaml/preprocess/parser_raw.ml" +# 2359 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 2424 "src/ocaml/preprocess/parser_raw.ml" +# 2367 "src/ocaml/preprocess/parser_raw.ml" in -# 3819 "src/ocaml/preprocess/parser_raw.mly" +# 3784 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2430 "src/ocaml/preprocess/parser_raw.ml" +# 2373 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2450,23 +2393,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (string Location.loc) = let _1 = let _1 = -# 4239 "src/ocaml/preprocess/parser_raw.mly" +# 4204 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2456 "src/ocaml/preprocess/parser_raw.ml" +# 2399 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1092 "src/ocaml/preprocess/parser_raw.mly" +# 1057 "src/ocaml/preprocess/parser_raw.mly" ( mkloc _1 (make_loc _sloc) ) -# 2464 "src/ocaml/preprocess/parser_raw.ml" +# 2407 "src/ocaml/preprocess/parser_raw.ml" in -# 4241 "src/ocaml/preprocess/parser_raw.mly" +# 4206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2470 "src/ocaml/preprocess/parser_raw.ml" +# 2413 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2504,24 +2447,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (string Location.loc) = let _1 = let _1 = -# 4240 "src/ocaml/preprocess/parser_raw.mly" +# 4205 "src/ocaml/preprocess/parser_raw.mly" ( _1 ^ "." ^ _3.txt ) -# 2510 "src/ocaml/preprocess/parser_raw.ml" +# 2453 "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 -# 1092 "src/ocaml/preprocess/parser_raw.mly" +# 1057 "src/ocaml/preprocess/parser_raw.mly" ( mkloc _1 (make_loc _sloc) ) -# 2519 "src/ocaml/preprocess/parser_raw.ml" +# 2462 "src/ocaml/preprocess/parser_raw.ml" in -# 4241 "src/ocaml/preprocess/parser_raw.mly" +# 4206 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2525 "src/ocaml/preprocess/parser_raw.ml" +# 2468 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2544,11 +2487,11 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.payload) = -# 4296 "src/ocaml/preprocess/parser_raw.mly" +# 4261 "src/ocaml/preprocess/parser_raw.mly" ( Builtin_attributes.mark_payload_attrs_used _1; _1 ) -# 2552 "src/ocaml/preprocess/parser_raw.ml" +# 2495 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2595,9 +2538,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4245 "src/ocaml/preprocess/parser_raw.mly" +# 4210 "src/ocaml/preprocess/parser_raw.mly" ( mk_attr ~loc:(make_loc _sloc) _2 _3 ) -# 2601 "src/ocaml/preprocess/parser_raw.ml" +# 2544 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2620,9 +2563,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.class_expr) = -# 2104 "src/ocaml/preprocess/parser_raw.mly" +# 2069 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2626 "src/ocaml/preprocess/parser_raw.ml" +# 2569 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2661,18 +2604,18 @@ module Tables = struct let _v : (Parsetree.class_expr) = let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2667 "src/ocaml/preprocess/parser_raw.ml" +# 2610 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2106 "src/ocaml/preprocess/parser_raw.mly" +# 2071 "src/ocaml/preprocess/parser_raw.mly" ( wrap_class_attrs ~loc:_sloc _3 _2 ) -# 2676 "src/ocaml/preprocess/parser_raw.ml" +# 2619 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2712,9 +2655,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2108 "src/ocaml/preprocess/parser_raw.mly" +# 2073 "src/ocaml/preprocess/parser_raw.mly" ( class_of_let_bindings ~loc:_sloc _1 _3 ) -# 2718 "src/ocaml/preprocess/parser_raw.ml" +# 2661 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2777,34 +2720,34 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2783 "src/ocaml/preprocess/parser_raw.ml" +# 2726 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in let _4 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2792 "src/ocaml/preprocess/parser_raw.ml" +# 2735 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 4164 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 2798 "src/ocaml/preprocess/parser_raw.ml" +# 2741 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2110 "src/ocaml/preprocess/parser_raw.mly" +# 2075 "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)) ) -# 2808 "src/ocaml/preprocess/parser_raw.ml" +# 2751 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2874,37 +2817,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 2880 "src/ocaml/preprocess/parser_raw.ml" +# 2823 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 2889 "src/ocaml/preprocess/parser_raw.ml" +# 2832 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 4165 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 2897 "src/ocaml/preprocess/parser_raw.ml" +# 2840 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2110 "src/ocaml/preprocess/parser_raw.mly" +# 2075 "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)) ) -# 2908 "src/ocaml/preprocess/parser_raw.ml" +# 2851 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2934,9 +2877,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = -# 2114 "src/ocaml/preprocess/parser_raw.mly" +# 2079 "src/ocaml/preprocess/parser_raw.mly" ( Cl.attr _1 _2 ) -# 2940 "src/ocaml/preprocess/parser_raw.ml" +# 2883 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -2971,18 +2914,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 2975 "src/ocaml/preprocess/parser_raw.ml" +# 2918 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1129 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 2980 "src/ocaml/preprocess/parser_raw.ml" +# 2923 "src/ocaml/preprocess/parser_raw.ml" in -# 2117 "src/ocaml/preprocess/parser_raw.mly" +# 2082 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_apply(_1, _2) ) -# 2986 "src/ocaml/preprocess/parser_raw.ml" +# 2929 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -2990,15 +2933,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1115 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 2996 "src/ocaml/preprocess/parser_raw.ml" +# 2939 "src/ocaml/preprocess/parser_raw.ml" in -# 2120 "src/ocaml/preprocess/parser_raw.mly" +# 2085 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3002 "src/ocaml/preprocess/parser_raw.ml" +# 2945 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3022,23 +2965,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2119 "src/ocaml/preprocess/parser_raw.mly" +# 2084 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_extension _1 ) -# 3028 "src/ocaml/preprocess/parser_raw.ml" +# 2971 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1115 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3036 "src/ocaml/preprocess/parser_raw.ml" +# 2979 "src/ocaml/preprocess/parser_raw.ml" in -# 2120 "src/ocaml/preprocess/parser_raw.mly" +# 2085 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3042 "src/ocaml/preprocess/parser_raw.ml" +# 2985 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3091,33 +3034,33 @@ module Tables = struct let _v : (Parsetree.class_field) = let _6 = let _1 = _1_inlined2 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3097 "src/ocaml/preprocess/parser_raw.ml" +# 3040 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3106 "src/ocaml/preprocess/parser_raw.ml" +# 3049 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4164 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 3112 "src/ocaml/preprocess/parser_raw.ml" +# 3055 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2175 "src/ocaml/preprocess/parser_raw.mly" +# 2140 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3121 "src/ocaml/preprocess/parser_raw.ml" +# 3064 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3177,36 +3120,36 @@ module Tables = struct let _v : (Parsetree.class_field) = let _6 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3183 "src/ocaml/preprocess/parser_raw.ml" +# 3126 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _3 = let _1 = _1_inlined2 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3192 "src/ocaml/preprocess/parser_raw.ml" +# 3135 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4165 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 3200 "src/ocaml/preprocess/parser_raw.ml" +# 3143 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2175 "src/ocaml/preprocess/parser_raw.mly" +# 2140 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_inherit (_2, _4, self)) ~attrs:(_3@_6) ~docs ) -# 3210 "src/ocaml/preprocess/parser_raw.ml" +# 3153 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3246,9 +3189,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _3 = let _1 = _1_inlined1 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3252 "src/ocaml/preprocess/parser_raw.ml" +# 3195 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3256,11 +3199,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2178 "src/ocaml/preprocess/parser_raw.mly" +# 2143 "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 ) -# 3264 "src/ocaml/preprocess/parser_raw.ml" +# 3207 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3300,9 +3243,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _3 = let _1 = _1_inlined1 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3306 "src/ocaml/preprocess/parser_raw.ml" +# 3249 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__1_inlined1_ in @@ -3310,11 +3253,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2182 "src/ocaml/preprocess/parser_raw.mly" +# 2147 "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 ) -# 3318 "src/ocaml/preprocess/parser_raw.ml" +# 3261 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3360,28 +3303,28 @@ module Tables = struct let _v : (Parsetree.class_field) = let _4 = let _1 = _1_inlined2 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3366 "src/ocaml/preprocess/parser_raw.ml" +# 3309 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3375 "src/ocaml/preprocess/parser_raw.ml" +# 3318 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2186 "src/ocaml/preprocess/parser_raw.mly" +# 2151 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 3385 "src/ocaml/preprocess/parser_raw.ml" +# 3328 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3427,28 +3370,28 @@ module Tables = struct let _v : (Parsetree.class_field) = let _4 = let _1 = _1_inlined2 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3433 "src/ocaml/preprocess/parser_raw.ml" +# 3376 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3442 "src/ocaml/preprocess/parser_raw.ml" +# 3385 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2189 "src/ocaml/preprocess/parser_raw.mly" +# 2154 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_initializer _3) ~attrs:(_2@_4) ~docs ) -# 3452 "src/ocaml/preprocess/parser_raw.ml" +# 3395 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3480,9 +3423,9 @@ module Tables = struct let _v : (Parsetree.class_field) = let _2 = let _1 = _1_inlined1 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3486 "src/ocaml/preprocess/parser_raw.ml" +# 3429 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -3490,10 +3433,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2192 "src/ocaml/preprocess/parser_raw.mly" +# 2157 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkcf ~loc:_sloc (Pcf_extension _1) ~attrs:_2 ~docs ) -# 3497 "src/ocaml/preprocess/parser_raw.ml" +# 3440 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3517,23 +3460,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_field) = let _1 = let _1 = -# 2195 "src/ocaml/preprocess/parser_raw.mly" +# 2160 "src/ocaml/preprocess/parser_raw.mly" ( Pcf_attribute _1 ) -# 3523 "src/ocaml/preprocess/parser_raw.ml" +# 3466 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1113 "src/ocaml/preprocess/parser_raw.mly" +# 1078 "src/ocaml/preprocess/parser_raw.mly" ( mkcf ~loc:_sloc _1 ) -# 3531 "src/ocaml/preprocess/parser_raw.ml" +# 3474 "src/ocaml/preprocess/parser_raw.ml" in -# 2196 "src/ocaml/preprocess/parser_raw.mly" +# 2161 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3537 "src/ocaml/preprocess/parser_raw.ml" +# 3480 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3563,9 +3506,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = -# 2084 "src/ocaml/preprocess/parser_raw.mly" +# 2049 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 3569 "src/ocaml/preprocess/parser_raw.ml" +# 3512 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3610,24 +3553,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2087 "src/ocaml/preprocess/parser_raw.mly" +# 2052 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constraint(_4, _2) ) -# 3616 "src/ocaml/preprocess/parser_raw.ml" +# 3559 "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 -# 1115 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3625 "src/ocaml/preprocess/parser_raw.ml" +# 3568 "src/ocaml/preprocess/parser_raw.ml" in -# 2090 "src/ocaml/preprocess/parser_raw.mly" +# 2055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3631 "src/ocaml/preprocess/parser_raw.ml" +# 3574 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3658,24 +3601,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2089 "src/ocaml/preprocess/parser_raw.mly" +# 2054 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, _2) ) -# 3664 "src/ocaml/preprocess/parser_raw.ml" +# 3607 "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 -# 1115 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3673 "src/ocaml/preprocess/parser_raw.ml" +# 3616 "src/ocaml/preprocess/parser_raw.ml" in -# 2090 "src/ocaml/preprocess/parser_raw.mly" +# 2055 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3679 "src/ocaml/preprocess/parser_raw.ml" +# 3622 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3713,24 +3656,24 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2151 "src/ocaml/preprocess/parser_raw.mly" +# 2116 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 3719 "src/ocaml/preprocess/parser_raw.ml" +# 3662 "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 -# 1115 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3728 "src/ocaml/preprocess/parser_raw.ml" +# 3671 "src/ocaml/preprocess/parser_raw.ml" in -# 2152 "src/ocaml/preprocess/parser_raw.mly" +# 2117 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3734 "src/ocaml/preprocess/parser_raw.ml" +# 3677 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3761,24 +3704,24 @@ module Tables = struct let _endpos = _endpos_e_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2151 "src/ocaml/preprocess/parser_raw.mly" +# 2116 "src/ocaml/preprocess/parser_raw.mly" ( let (l,o,p) = _1 in Pcl_fun(l, o, p, e) ) -# 3767 "src/ocaml/preprocess/parser_raw.ml" +# 3710 "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 -# 1115 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 3776 "src/ocaml/preprocess/parser_raw.ml" +# 3719 "src/ocaml/preprocess/parser_raw.ml" in -# 2152 "src/ocaml/preprocess/parser_raw.mly" +# 2117 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3782 "src/ocaml/preprocess/parser_raw.ml" +# 3725 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3801,9 +3744,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4046 "src/ocaml/preprocess/parser_raw.mly" +# 4011 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3807 "src/ocaml/preprocess/parser_raw.ml" +# 3750 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3843,9 +3786,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2160 "src/ocaml/preprocess/parser_raw.mly" +# 2125 "src/ocaml/preprocess/parser_raw.mly" ( reloc_pat ~loc:_sloc _2 ) -# 3849 "src/ocaml/preprocess/parser_raw.ml" +# 3792 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3897,24 +3840,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2162 "src/ocaml/preprocess/parser_raw.mly" +# 2127 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_2, _4) ) -# 3903 "src/ocaml/preprocess/parser_raw.ml" +# 3846 "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 -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 3912 "src/ocaml/preprocess/parser_raw.ml" +# 3855 "src/ocaml/preprocess/parser_raw.ml" in -# 2163 "src/ocaml/preprocess/parser_raw.mly" +# 2128 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 3918 "src/ocaml/preprocess/parser_raw.ml" +# 3861 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3933,9 +3876,9 @@ module Tables = struct let _symbolstartpos = _endpos in let _sloc = (_symbolstartpos, _endpos) in -# 2165 "src/ocaml/preprocess/parser_raw.mly" +# 2130 "src/ocaml/preprocess/parser_raw.mly" ( ghpat ~loc:_sloc Ppat_any ) -# 3939 "src/ocaml/preprocess/parser_raw.ml" +# 3882 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3972,9 +3915,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = -# 2292 "src/ocaml/preprocess/parser_raw.mly" +# 2257 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 3978 "src/ocaml/preprocess/parser_raw.ml" +# 3921 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -3991,326 +3934,326 @@ module Tables = struct let _endpos = _startpos in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 2293 "src/ocaml/preprocess/parser_raw.mly" +# 2258 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 3997 "src/ocaml/preprocess/parser_raw.ml" +# 3940 "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 -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 4006 "src/ocaml/preprocess/parser_raw.ml" +# 3949 "src/ocaml/preprocess/parser_raw.ml" in -# 2294 "src/ocaml/preprocess/parser_raw.mly" +# 2259 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) +# 3955 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 + +# 4223 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 4003 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__4_ = _endpos__1_inlined2_ in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) # 4012 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 4258 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 4060 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos__4_ = _endpos__1_inlined2_ in - let _2 = - let _1 = _1_inlined1 in - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 4069 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos = _endpos__4_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 2302 "src/ocaml/preprocess/parser_raw.mly" - ( let docs = symbol_docs _sloc in - mkctf ~loc:_sloc (Pctf_inherit _3) ~attrs:(_2@_4) ~docs ) -# 4079 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" - (string) -# 4139 "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 - -# 4258 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 4152 "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 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 4162 "src/ocaml/preprocess/parser_raw.ml" - in - let _endpos = _endpos__1_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 4170 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2327 "src/ocaml/preprocess/parser_raw.mly" - ( - let mut, virt = flags in - label, mut, virt, ty - ) -# 4179 "src/ocaml/preprocess/parser_raw.ml" - - in - let _2 = - let _1 = _1_inlined1 in - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 4187 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos = _endpos__4_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 2305 "src/ocaml/preprocess/parser_raw.mly" - ( let docs = symbol_docs _sloc in - mkctf ~loc:_sloc (Pctf_val _3) ~attrs:(_2@_4) ~docs ) -# 4197 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" - (string) -# 4257 "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 - -# 4258 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 4270 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos__7_ = _endpos__1_inlined4_ in - let _6 = - let _1 = _1_inlined3 in - -# 3631 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 4279 "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 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 4287 "src/ocaml/preprocess/parser_raw.ml" - in - let _endpos = _endpos__1_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 4295 "src/ocaml/preprocess/parser_raw.ml" - - in - let _2 = - let _1 = _1_inlined1 in - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 4303 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos = _endpos__7_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 2309 "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 ) -# 4314 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__4_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2267 "src/ocaml/preprocess/parser_raw.mly" + ( let docs = symbol_docs _sloc in + mkctf ~loc:_sloc (Pctf_inherit _3) ~attrs:(_2@_4) ~docs ) +# 4022 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 : ( +# 838 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 4082 "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 + +# 4223 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 4095 "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 = +# 3881 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 4105 "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" + ( mkrhs _1 _sloc ) +# 4113 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2292 "src/ocaml/preprocess/parser_raw.mly" + ( + let mut, virt = flags in + label, mut, virt, ty + ) +# 4122 "src/ocaml/preprocess/parser_raw.ml" + + in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 4130 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__4_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2270 "src/ocaml/preprocess/parser_raw.mly" + ( let docs = symbol_docs _sloc in + mkctf ~loc:_sloc (Pctf_val _3) ~attrs:(_2@_4) ~docs ) +# 4140 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 : ( +# 838 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 4200 "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 + +# 4223 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 4213 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__7_ = _endpos__1_inlined4_ in + let _6 = + let _1 = _1_inlined3 in + +# 3596 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 4222 "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 = +# 3881 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 4230 "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" + ( mkrhs _1 _sloc ) +# 4238 "src/ocaml/preprocess/parser_raw.ml" + + in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 4246 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__7_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2274 "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 ) +# 4257 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4356,28 +4299,28 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _4 = let _1 = _1_inlined2 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4362 "src/ocaml/preprocess/parser_raw.ml" +# 4305 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4371 "src/ocaml/preprocess/parser_raw.ml" +# 4314 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2313 "src/ocaml/preprocess/parser_raw.mly" +# 2278 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_constraint _3) ~attrs:(_2@_4) ~docs ) -# 4381 "src/ocaml/preprocess/parser_raw.ml" +# 4324 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4409,9 +4352,9 @@ module Tables = struct let _v : (Parsetree.class_type_field) = let _2 = let _1 = _1_inlined1 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4415 "src/ocaml/preprocess/parser_raw.ml" +# 4358 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -4419,10 +4362,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2316 "src/ocaml/preprocess/parser_raw.mly" +# 2281 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mkctf ~loc:_sloc (Pctf_extension _1) ~attrs:_2 ~docs ) -# 4426 "src/ocaml/preprocess/parser_raw.ml" +# 4369 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4446,23 +4389,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_type_field) = let _1 = let _1 = -# 2319 "src/ocaml/preprocess/parser_raw.mly" +# 2284 "src/ocaml/preprocess/parser_raw.mly" ( Pctf_attribute _1 ) -# 4452 "src/ocaml/preprocess/parser_raw.ml" +# 4395 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1111 "src/ocaml/preprocess/parser_raw.mly" +# 1076 "src/ocaml/preprocess/parser_raw.mly" ( mkctf ~loc:_sloc _1 ) -# 4460 "src/ocaml/preprocess/parser_raw.ml" +# 4403 "src/ocaml/preprocess/parser_raw.ml" in -# 2320 "src/ocaml/preprocess/parser_raw.mly" +# 2285 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4466 "src/ocaml/preprocess/parser_raw.ml" +# 4409 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4491,42 +4434,42 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4497 "src/ocaml/preprocess/parser_raw.ml" +# 4440 "src/ocaml/preprocess/parser_raw.ml" in let tys = let tys = -# 2278 "src/ocaml/preprocess/parser_raw.mly" +# 2243 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 4504 "src/ocaml/preprocess/parser_raw.ml" +# 4447 "src/ocaml/preprocess/parser_raw.ml" in -# 2284 "src/ocaml/preprocess/parser_raw.mly" +# 2249 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 4509 "src/ocaml/preprocess/parser_raw.ml" +# 4452 "src/ocaml/preprocess/parser_raw.ml" in -# 2259 "src/ocaml/preprocess/parser_raw.mly" +# 2224 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_constr (cid, tys) ) -# 4515 "src/ocaml/preprocess/parser_raw.ml" +# 4458 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1109 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 4524 "src/ocaml/preprocess/parser_raw.ml" +# 4467 "src/ocaml/preprocess/parser_raw.ml" in -# 2262 "src/ocaml/preprocess/parser_raw.mly" +# 2227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4530 "src/ocaml/preprocess/parser_raw.ml" +# 4473 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4577,9 +4520,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4583 "src/ocaml/preprocess/parser_raw.ml" +# 4526 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -4588,30 +4531,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 4592 "src/ocaml/preprocess/parser_raw.ml" +# 4535 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 4597 "src/ocaml/preprocess/parser_raw.ml" +# 4540 "src/ocaml/preprocess/parser_raw.ml" in -# 2280 "src/ocaml/preprocess/parser_raw.mly" +# 2245 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 4603 "src/ocaml/preprocess/parser_raw.ml" +# 4546 "src/ocaml/preprocess/parser_raw.ml" in -# 2284 "src/ocaml/preprocess/parser_raw.mly" +# 2249 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 4609 "src/ocaml/preprocess/parser_raw.ml" +# 4552 "src/ocaml/preprocess/parser_raw.ml" in -# 2259 "src/ocaml/preprocess/parser_raw.mly" +# 2224 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_constr (cid, tys) ) -# 4615 "src/ocaml/preprocess/parser_raw.ml" +# 4558 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -4619,15 +4562,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1109 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 4625 "src/ocaml/preprocess/parser_raw.ml" +# 4568 "src/ocaml/preprocess/parser_raw.ml" in -# 2262 "src/ocaml/preprocess/parser_raw.mly" +# 2227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4631 "src/ocaml/preprocess/parser_raw.ml" +# 4574 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4651,23 +4594,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.class_type) = let _1 = let _1 = -# 2261 "src/ocaml/preprocess/parser_raw.mly" +# 2226 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_extension _1 ) -# 4657 "src/ocaml/preprocess/parser_raw.ml" +# 4600 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1109 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 4665 "src/ocaml/preprocess/parser_raw.ml" +# 4608 "src/ocaml/preprocess/parser_raw.ml" in -# 2262 "src/ocaml/preprocess/parser_raw.mly" +# 2227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4671 "src/ocaml/preprocess/parser_raw.ml" +# 4614 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4724,44 +4667,44 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 4728 "src/ocaml/preprocess/parser_raw.ml" +# 4671 "src/ocaml/preprocess/parser_raw.ml" in -# 2298 "src/ocaml/preprocess/parser_raw.mly" +# 2263 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4733 "src/ocaml/preprocess/parser_raw.ml" +# 4676 "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 -# 1057 "src/ocaml/preprocess/parser_raw.mly" +# 1022 "src/ocaml/preprocess/parser_raw.mly" ( extra_csig _startpos _endpos _1 ) -# 4742 "src/ocaml/preprocess/parser_raw.ml" +# 4685 "src/ocaml/preprocess/parser_raw.ml" in -# 2288 "src/ocaml/preprocess/parser_raw.mly" +# 2253 "src/ocaml/preprocess/parser_raw.mly" ( Csig.mk _1 _2 ) -# 4748 "src/ocaml/preprocess/parser_raw.ml" +# 4691 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4756 "src/ocaml/preprocess/parser_raw.ml" +# 4699 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2264 "src/ocaml/preprocess/parser_raw.mly" +# 2229 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc ~attrs:_2 (Pcty_signature _3) ) -# 4765 "src/ocaml/preprocess/parser_raw.ml" +# 4708 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4791,9 +4734,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.class_type) = -# 2270 "src/ocaml/preprocess/parser_raw.mly" +# 2235 "src/ocaml/preprocess/parser_raw.mly" ( Cty.attr _1 _2 ) -# 4797 "src/ocaml/preprocess/parser_raw.ml" +# 4740 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4856,34 +4799,34 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4862 "src/ocaml/preprocess/parser_raw.ml" +# 4805 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in let _4 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4871 "src/ocaml/preprocess/parser_raw.ml" +# 4814 "src/ocaml/preprocess/parser_raw.ml" in let _3 = -# 4164 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 4877 "src/ocaml/preprocess/parser_raw.ml" +# 4820 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2272 "src/ocaml/preprocess/parser_raw.mly" +# 2237 "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)) ) -# 4887 "src/ocaml/preprocess/parser_raw.ml" +# 4830 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -4953,37 +4896,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 4959 "src/ocaml/preprocess/parser_raw.ml" +# 4902 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 4968 "src/ocaml/preprocess/parser_raw.ml" +# 4911 "src/ocaml/preprocess/parser_raw.ml" in let _3 = let _1 = _1_inlined1 in -# 4165 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 4976 "src/ocaml/preprocess/parser_raw.ml" +# 4919 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2272 "src/ocaml/preprocess/parser_raw.mly" +# 2237 "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)) ) -# 4987 "src/ocaml/preprocess/parser_raw.ml" +# 4930 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5020,9 +4963,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.class_expr) = -# 2124 "src/ocaml/preprocess/parser_raw.mly" +# 2089 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 5026 "src/ocaml/preprocess/parser_raw.ml" +# 4969 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5051,42 +4994,42 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5057 "src/ocaml/preprocess/parser_raw.ml" +# 5000 "src/ocaml/preprocess/parser_raw.ml" in let tys = let tys = -# 2278 "src/ocaml/preprocess/parser_raw.mly" +# 2243 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 5064 "src/ocaml/preprocess/parser_raw.ml" +# 5007 "src/ocaml/preprocess/parser_raw.ml" in -# 2284 "src/ocaml/preprocess/parser_raw.mly" +# 2249 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5069 "src/ocaml/preprocess/parser_raw.ml" +# 5012 "src/ocaml/preprocess/parser_raw.ml" in -# 2131 "src/ocaml/preprocess/parser_raw.mly" +# 2096 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constr(cid, tys) ) -# 5075 "src/ocaml/preprocess/parser_raw.ml" +# 5018 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1115 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5084 "src/ocaml/preprocess/parser_raw.ml" +# 5027 "src/ocaml/preprocess/parser_raw.ml" in -# 2142 "src/ocaml/preprocess/parser_raw.mly" +# 2107 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5090 "src/ocaml/preprocess/parser_raw.ml" +# 5033 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5137,9 +5080,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5143 "src/ocaml/preprocess/parser_raw.ml" +# 5086 "src/ocaml/preprocess/parser_raw.ml" in let tys = @@ -5148,30 +5091,30 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 5152 "src/ocaml/preprocess/parser_raw.ml" +# 5095 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 5157 "src/ocaml/preprocess/parser_raw.ml" +# 5100 "src/ocaml/preprocess/parser_raw.ml" in -# 2280 "src/ocaml/preprocess/parser_raw.mly" +# 2245 "src/ocaml/preprocess/parser_raw.mly" ( params ) -# 5163 "src/ocaml/preprocess/parser_raw.ml" +# 5106 "src/ocaml/preprocess/parser_raw.ml" in -# 2284 "src/ocaml/preprocess/parser_raw.mly" +# 2249 "src/ocaml/preprocess/parser_raw.mly" ( tys ) -# 5169 "src/ocaml/preprocess/parser_raw.ml" +# 5112 "src/ocaml/preprocess/parser_raw.ml" in -# 2131 "src/ocaml/preprocess/parser_raw.mly" +# 2096 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constr(cid, tys) ) -# 5175 "src/ocaml/preprocess/parser_raw.ml" +# 5118 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -5179,15 +5122,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1115 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5185 "src/ocaml/preprocess/parser_raw.ml" +# 5128 "src/ocaml/preprocess/parser_raw.ml" in -# 2142 "src/ocaml/preprocess/parser_raw.mly" +# 2107 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5191 "src/ocaml/preprocess/parser_raw.ml" +# 5134 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5239,24 +5182,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.class_expr) = let _1 = let _1 = -# 2137 "src/ocaml/preprocess/parser_raw.mly" +# 2102 "src/ocaml/preprocess/parser_raw.mly" ( Pcl_constraint(_2, _4) ) -# 5245 "src/ocaml/preprocess/parser_raw.ml" +# 5188 "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 -# 1115 "src/ocaml/preprocess/parser_raw.mly" +# 1080 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc _1 ) -# 5254 "src/ocaml/preprocess/parser_raw.ml" +# 5197 "src/ocaml/preprocess/parser_raw.ml" in -# 2142 "src/ocaml/preprocess/parser_raw.mly" +# 2107 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5260 "src/ocaml/preprocess/parser_raw.ml" +# 5203 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5313,44 +5256,44 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 5317 "src/ocaml/preprocess/parser_raw.ml" +# 5260 "src/ocaml/preprocess/parser_raw.ml" in -# 2169 "src/ocaml/preprocess/parser_raw.mly" +# 2134 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5322 "src/ocaml/preprocess/parser_raw.ml" +# 5265 "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 -# 1056 "src/ocaml/preprocess/parser_raw.mly" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( extra_cstr _startpos _endpos _1 ) -# 5331 "src/ocaml/preprocess/parser_raw.ml" +# 5274 "src/ocaml/preprocess/parser_raw.ml" in -# 2156 "src/ocaml/preprocess/parser_raw.mly" +# 2121 "src/ocaml/preprocess/parser_raw.mly" ( Cstr.mk _1 _2 ) -# 5337 "src/ocaml/preprocess/parser_raw.ml" +# 5280 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5345 "src/ocaml/preprocess/parser_raw.ml" +# 5288 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2144 "src/ocaml/preprocess/parser_raw.mly" +# 2109 "src/ocaml/preprocess/parser_raw.mly" ( mkclass ~loc:_sloc ~attrs:_2 (Pcl_structure _3) ) -# 5354 "src/ocaml/preprocess/parser_raw.ml" +# 5297 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5373,9 +5316,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.class_type) = -# 2247 "src/ocaml/preprocess/parser_raw.mly" +# 2212 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5379 "src/ocaml/preprocess/parser_raw.ml" +# 5322 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5421,14 +5364,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3694 "src/ocaml/preprocess/parser_raw.mly" +# 3659 "src/ocaml/preprocess/parser_raw.mly" ( Optional label ) -# 5427 "src/ocaml/preprocess/parser_raw.ml" +# 5370 "src/ocaml/preprocess/parser_raw.ml" in -# 2253 "src/ocaml/preprocess/parser_raw.mly" +# 2218 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 5432 "src/ocaml/preprocess/parser_raw.ml" +# 5375 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -5436,15 +5379,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1109 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5442 "src/ocaml/preprocess/parser_raw.ml" +# 5385 "src/ocaml/preprocess/parser_raw.ml" in -# 2254 "src/ocaml/preprocess/parser_raw.mly" +# 2219 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5448 "src/ocaml/preprocess/parser_raw.ml" +# 5391 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5491,9 +5434,9 @@ module Tables = struct let domain : (Parsetree.core_type) = Obj.magic domain in let _2 : unit = Obj.magic _2 in let label : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 5497 "src/ocaml/preprocess/parser_raw.ml" +# 5440 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -5501,14 +5444,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3696 "src/ocaml/preprocess/parser_raw.mly" +# 3661 "src/ocaml/preprocess/parser_raw.mly" ( Labelled label ) -# 5507 "src/ocaml/preprocess/parser_raw.ml" +# 5450 "src/ocaml/preprocess/parser_raw.ml" in -# 2253 "src/ocaml/preprocess/parser_raw.mly" +# 2218 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 5512 "src/ocaml/preprocess/parser_raw.ml" +# 5455 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -5516,15 +5459,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1109 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5522 "src/ocaml/preprocess/parser_raw.ml" +# 5465 "src/ocaml/preprocess/parser_raw.ml" in -# 2254 "src/ocaml/preprocess/parser_raw.mly" +# 2219 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5528 "src/ocaml/preprocess/parser_raw.ml" +# 5471 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5563,14 +5506,14 @@ module Tables = struct let _v : (Parsetree.class_type) = let _1 = let _1 = let label = -# 3698 "src/ocaml/preprocess/parser_raw.mly" +# 3663 "src/ocaml/preprocess/parser_raw.mly" ( Nolabel ) -# 5569 "src/ocaml/preprocess/parser_raw.ml" +# 5512 "src/ocaml/preprocess/parser_raw.ml" in -# 2253 "src/ocaml/preprocess/parser_raw.mly" +# 2218 "src/ocaml/preprocess/parser_raw.mly" ( Pcty_arrow(label, domain, codomain) ) -# 5574 "src/ocaml/preprocess/parser_raw.ml" +# 5517 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_domain_) in @@ -5578,15 +5521,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1109 "src/ocaml/preprocess/parser_raw.mly" +# 1074 "src/ocaml/preprocess/parser_raw.mly" ( mkcty ~loc:_sloc _1 ) -# 5584 "src/ocaml/preprocess/parser_raw.ml" +# 5527 "src/ocaml/preprocess/parser_raw.ml" in -# 2254 "src/ocaml/preprocess/parser_raw.mly" +# 2219 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5590 "src/ocaml/preprocess/parser_raw.ml" +# 5533 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5669,9 +5612,9 @@ module Tables = struct let csig : (Parsetree.class_type) = Obj.magic csig in let _8 : unit = Obj.magic _8 in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 5675 "src/ocaml/preprocess/parser_raw.ml" +# 5618 "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 @@ -5687,9 +5630,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5693 "src/ocaml/preprocess/parser_raw.ml" +# 5636 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -5699,24 +5642,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 5705 "src/ocaml/preprocess/parser_raw.ml" +# 5648 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5713 "src/ocaml/preprocess/parser_raw.ml" +# 5656 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2394 "src/ocaml/preprocess/parser_raw.mly" +# 2359 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -5724,19 +5667,19 @@ module Tables = struct ext, Ci.mk id csig ~virt ~params ~attrs ~loc ~docs ) -# 5728 "src/ocaml/preprocess/parser_raw.ml" +# 5671 "src/ocaml/preprocess/parser_raw.ml" in -# 1314 "src/ocaml/preprocess/parser_raw.mly" +# 1279 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 5734 "src/ocaml/preprocess/parser_raw.ml" +# 5677 "src/ocaml/preprocess/parser_raw.ml" in -# 2382 "src/ocaml/preprocess/parser_raw.mly" +# 2347 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5740 "src/ocaml/preprocess/parser_raw.ml" +# 5683 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5759,9 +5702,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4043 "src/ocaml/preprocess/parser_raw.mly" +# 4008 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 5765 "src/ocaml/preprocess/parser_raw.ml" +# 5708 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5780,17 +5723,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 824 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 5786 "src/ocaml/preprocess/parser_raw.ml" +# 5729 "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) = -# 3922 "src/ocaml/preprocess/parser_raw.mly" +# 3887 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _1 in Pconst_integer (n, m) ) -# 5794 "src/ocaml/preprocess/parser_raw.ml" +# 5737 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5809,17 +5752,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 810 "src/ocaml/preprocess/parser_raw.mly" +# 783 "src/ocaml/preprocess/parser_raw.mly" (char) -# 5815 "src/ocaml/preprocess/parser_raw.ml" +# 5758 "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) = -# 3923 "src/ocaml/preprocess/parser_raw.mly" +# 3888 "src/ocaml/preprocess/parser_raw.mly" ( Pconst_char _1 ) -# 5823 "src/ocaml/preprocess/parser_raw.ml" +# 5766 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5838,17 +5781,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 903 "src/ocaml/preprocess/parser_raw.mly" +# 876 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 5844 "src/ocaml/preprocess/parser_raw.ml" +# 5787 "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) = -# 3924 "src/ocaml/preprocess/parser_raw.mly" +# 3889 "src/ocaml/preprocess/parser_raw.mly" ( let (s, strloc, d) = _1 in Pconst_string (s, strloc, d) ) -# 5852 "src/ocaml/preprocess/parser_raw.ml" +# 5795 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5867,17 +5810,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 830 "src/ocaml/preprocess/parser_raw.mly" +# 803 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 5873 "src/ocaml/preprocess/parser_raw.ml" +# 5816 "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) = -# 3925 "src/ocaml/preprocess/parser_raw.mly" +# 3890 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _1 in Pconst_float (f, m) ) -# 5881 "src/ocaml/preprocess/parser_raw.ml" +# 5824 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5907,9 +5850,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3998 "src/ocaml/preprocess/parser_raw.mly" +# 3963 "src/ocaml/preprocess/parser_raw.mly" ( "[]" ) -# 5913 "src/ocaml/preprocess/parser_raw.ml" +# 5856 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5939,9 +5882,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3999 "src/ocaml/preprocess/parser_raw.mly" +# 3964 "src/ocaml/preprocess/parser_raw.mly" ( "()" ) -# 5945 "src/ocaml/preprocess/parser_raw.ml" +# 5888 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5964,9 +5907,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4000 "src/ocaml/preprocess/parser_raw.mly" +# 3965 "src/ocaml/preprocess/parser_raw.mly" ( "false" ) -# 5970 "src/ocaml/preprocess/parser_raw.ml" +# 5913 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -5989,9 +5932,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4001 "src/ocaml/preprocess/parser_raw.mly" +# 3966 "src/ocaml/preprocess/parser_raw.mly" ( "true" ) -# 5995 "src/ocaml/preprocess/parser_raw.ml" +# 5938 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6010,17 +5953,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 6016 "src/ocaml/preprocess/parser_raw.ml" +# 5959 "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) = -# 4004 "src/ocaml/preprocess/parser_raw.mly" +# 3969 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6024 "src/ocaml/preprocess/parser_raw.ml" +# 5967 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6057,14 +6000,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = let _1 = -# 3995 "src/ocaml/preprocess/parser_raw.mly" +# 3960 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6063 "src/ocaml/preprocess/parser_raw.ml" +# 6006 "src/ocaml/preprocess/parser_raw.ml" in -# 4005 "src/ocaml/preprocess/parser_raw.mly" +# 3970 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6068 "src/ocaml/preprocess/parser_raw.ml" +# 6011 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6087,9 +6030,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4006 "src/ocaml/preprocess/parser_raw.mly" +# 3971 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6093 "src/ocaml/preprocess/parser_raw.ml" +# 6036 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6112,9 +6055,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4009 "src/ocaml/preprocess/parser_raw.mly" +# 3974 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6118 "src/ocaml/preprocess/parser_raw.ml" +# 6061 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6167,15 +6110,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let (_2, _1) = (_2_inlined1, _1_inlined1) in -# 3995 "src/ocaml/preprocess/parser_raw.mly" +# 3960 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6173 "src/ocaml/preprocess/parser_raw.ml" +# 6116 "src/ocaml/preprocess/parser_raw.ml" in -# 4010 "src/ocaml/preprocess/parser_raw.mly" +# 3975 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 6179 "src/ocaml/preprocess/parser_raw.ml" +# 6122 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6212,14 +6155,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = let _1 = -# 3995 "src/ocaml/preprocess/parser_raw.mly" +# 3960 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 6218 "src/ocaml/preprocess/parser_raw.ml" +# 6161 "src/ocaml/preprocess/parser_raw.ml" in -# 4011 "src/ocaml/preprocess/parser_raw.mly" +# 3976 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 6223 "src/ocaml/preprocess/parser_raw.ml" +# 6166 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6242,9 +6185,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4012 "src/ocaml/preprocess/parser_raw.mly" +# 3977 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 6248 "src/ocaml/preprocess/parser_raw.ml" +# 6191 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6281,9 +6224,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type * Parsetree.core_type) = -# 2338 "src/ocaml/preprocess/parser_raw.mly" +# 2303 "src/ocaml/preprocess/parser_raw.mly" ( _1, _3 ) -# 6287 "src/ocaml/preprocess/parser_raw.ml" +# 6230 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6308,26 +6251,26 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = let tys = let xs = let xs = -# 1201 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 6314 "src/ocaml/preprocess/parser_raw.ml" +# 6257 "src/ocaml/preprocess/parser_raw.ml" in # 253 "" ( List.rev xs ) -# 6319 "src/ocaml/preprocess/parser_raw.ml" +# 6262 "src/ocaml/preprocess/parser_raw.ml" in -# 1221 "src/ocaml/preprocess/parser_raw.mly" +# 1186 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 6325 "src/ocaml/preprocess/parser_raw.ml" +# 6268 "src/ocaml/preprocess/parser_raw.ml" in -# 3497 "src/ocaml/preprocess/parser_raw.mly" +# 3462 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_tuple tys ) -# 6331 "src/ocaml/preprocess/parser_raw.ml" +# 6274 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6366,26 +6309,26 @@ module Tables = struct let _v : (Parsetree.constructor_arguments) = let tys = let xs = let xs = -# 1205 "src/ocaml/preprocess/parser_raw.mly" +# 1170 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 6372 "src/ocaml/preprocess/parser_raw.ml" +# 6315 "src/ocaml/preprocess/parser_raw.ml" in # 253 "" ( List.rev xs ) -# 6377 "src/ocaml/preprocess/parser_raw.ml" +# 6320 "src/ocaml/preprocess/parser_raw.ml" in -# 1221 "src/ocaml/preprocess/parser_raw.mly" +# 1186 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 6383 "src/ocaml/preprocess/parser_raw.ml" +# 6326 "src/ocaml/preprocess/parser_raw.ml" in -# 3497 "src/ocaml/preprocess/parser_raw.mly" +# 3462 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_tuple tys ) -# 6389 "src/ocaml/preprocess/parser_raw.ml" +# 6332 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6422,9 +6365,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.constructor_arguments) = -# 3499 "src/ocaml/preprocess/parser_raw.mly" +# 3464 "src/ocaml/preprocess/parser_raw.mly" ( Pcstr_record _2 ) -# 6428 "src/ocaml/preprocess/parser_raw.ml" +# 6371 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6447,9 +6390,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constructor_declaration list) = -# 3413 "src/ocaml/preprocess/parser_raw.mly" +# 3378 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 6453 "src/ocaml/preprocess/parser_raw.ml" +# 6396 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6472,14 +6415,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.constructor_declaration list) = let cs = -# 1306 "src/ocaml/preprocess/parser_raw.mly" +# 1271 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 6478 "src/ocaml/preprocess/parser_raw.ml" +# 6421 "src/ocaml/preprocess/parser_raw.ml" in -# 3415 "src/ocaml/preprocess/parser_raw.mly" +# 3380 "src/ocaml/preprocess/parser_raw.mly" ( cs ) -# 6483 "src/ocaml/preprocess/parser_raw.ml" +# 6426 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6502,14 +6445,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = -# 3656 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6508 "src/ocaml/preprocess/parser_raw.ml" +# 6451 "src/ocaml/preprocess/parser_raw.ml" in -# 3646 "src/ocaml/preprocess/parser_raw.mly" +# 3611 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6513 "src/ocaml/preprocess/parser_raw.ml" +# 6456 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6539,9 +6482,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = -# 3648 "src/ocaml/preprocess/parser_raw.mly" +# 3613 "src/ocaml/preprocess/parser_raw.mly" ( Typ.attr _1 _2 ) -# 6545 "src/ocaml/preprocess/parser_raw.ml" +# 6488 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6564,9 +6507,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3796 "src/ocaml/preprocess/parser_raw.mly" +# 3761 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6570 "src/ocaml/preprocess/parser_raw.ml" +# 6513 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6589,9 +6532,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3796 "src/ocaml/preprocess/parser_raw.mly" +# 3761 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6595 "src/ocaml/preprocess/parser_raw.ml" +# 6538 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6614,9 +6557,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3796 "src/ocaml/preprocess/parser_raw.mly" +# 3761 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6620 "src/ocaml/preprocess/parser_raw.ml" +# 6563 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6653,9 +6596,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = -# 3749 "src/ocaml/preprocess/parser_raw.mly" +# 3714 "src/ocaml/preprocess/parser_raw.mly" ( type_ ) -# 6659 "src/ocaml/preprocess/parser_raw.ml" +# 6602 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6718,11 +6661,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3842 "src/ocaml/preprocess/parser_raw.mly" +# 3807 "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 ) -# 6726 "src/ocaml/preprocess/parser_raw.ml" +# 6669 "src/ocaml/preprocess/parser_raw.ml" in let attrs = @@ -6730,24 +6673,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6736 "src/ocaml/preprocess/parser_raw.ml" +# 6679 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 6742 "src/ocaml/preprocess/parser_raw.ml" +# 6685 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3751 "src/ocaml/preprocess/parser_raw.mly" +# 3716 "src/ocaml/preprocess/parser_raw.mly" ( wrap_typ_attrs ~loc:_sloc (reloc_typ ~loc:_sloc package_type) attrs ) -# 6751 "src/ocaml/preprocess/parser_raw.ml" +# 6694 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6785,24 +6728,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3754 "src/ocaml/preprocess/parser_raw.mly" +# 3719 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant([ field ], Closed, None) ) -# 6791 "src/ocaml/preprocess/parser_raw.ml" +# 6734 "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 -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 6800 "src/ocaml/preprocess/parser_raw.ml" +# 6743 "src/ocaml/preprocess/parser_raw.ml" in -# 3771 "src/ocaml/preprocess/parser_raw.mly" +# 3736 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6806 "src/ocaml/preprocess/parser_raw.ml" +# 6749 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6852,24 +6795,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 6856 "src/ocaml/preprocess/parser_raw.ml" +# 6799 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 6861 "src/ocaml/preprocess/parser_raw.ml" +# 6804 "src/ocaml/preprocess/parser_raw.ml" in -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 3813 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6867 "src/ocaml/preprocess/parser_raw.ml" +# 6810 "src/ocaml/preprocess/parser_raw.ml" in -# 3756 "src/ocaml/preprocess/parser_raw.mly" +# 3721 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(fields, Closed, None) ) -# 6873 "src/ocaml/preprocess/parser_raw.ml" +# 6816 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -6877,15 +6820,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 6883 "src/ocaml/preprocess/parser_raw.ml" +# 6826 "src/ocaml/preprocess/parser_raw.ml" in -# 3771 "src/ocaml/preprocess/parser_raw.mly" +# 3736 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6889 "src/ocaml/preprocess/parser_raw.ml" +# 6832 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -6942,24 +6885,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 6946 "src/ocaml/preprocess/parser_raw.ml" +# 6889 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 6951 "src/ocaml/preprocess/parser_raw.ml" +# 6894 "src/ocaml/preprocess/parser_raw.ml" in -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 3813 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6957 "src/ocaml/preprocess/parser_raw.ml" +# 6900 "src/ocaml/preprocess/parser_raw.ml" in -# 3758 "src/ocaml/preprocess/parser_raw.mly" +# 3723 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(field :: fields, Closed, None) ) -# 6963 "src/ocaml/preprocess/parser_raw.ml" +# 6906 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -6967,15 +6910,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 6973 "src/ocaml/preprocess/parser_raw.ml" +# 6916 "src/ocaml/preprocess/parser_raw.ml" in -# 3771 "src/ocaml/preprocess/parser_raw.mly" +# 3736 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 6979 "src/ocaml/preprocess/parser_raw.ml" +# 6922 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7025,24 +6968,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7029 "src/ocaml/preprocess/parser_raw.ml" +# 6972 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7034 "src/ocaml/preprocess/parser_raw.ml" +# 6977 "src/ocaml/preprocess/parser_raw.ml" in -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 3813 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7040 "src/ocaml/preprocess/parser_raw.ml" +# 6983 "src/ocaml/preprocess/parser_raw.ml" in -# 3760 "src/ocaml/preprocess/parser_raw.mly" +# 3725 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(fields, Open, None) ) -# 7046 "src/ocaml/preprocess/parser_raw.ml" +# 6989 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -7050,15 +6993,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 7056 "src/ocaml/preprocess/parser_raw.ml" +# 6999 "src/ocaml/preprocess/parser_raw.ml" in -# 3771 "src/ocaml/preprocess/parser_raw.mly" +# 3736 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7062 "src/ocaml/preprocess/parser_raw.ml" +# 7005 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7089,24 +7032,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3762 "src/ocaml/preprocess/parser_raw.mly" +# 3727 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant([], Open, None) ) -# 7095 "src/ocaml/preprocess/parser_raw.ml" +# 7038 "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 -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 7104 "src/ocaml/preprocess/parser_raw.ml" +# 7047 "src/ocaml/preprocess/parser_raw.ml" in -# 3771 "src/ocaml/preprocess/parser_raw.mly" +# 3736 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7110 "src/ocaml/preprocess/parser_raw.ml" +# 7053 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7156,24 +7099,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7160 "src/ocaml/preprocess/parser_raw.ml" +# 7103 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7165 "src/ocaml/preprocess/parser_raw.ml" +# 7108 "src/ocaml/preprocess/parser_raw.ml" in -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 3813 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7171 "src/ocaml/preprocess/parser_raw.ml" +# 7114 "src/ocaml/preprocess/parser_raw.ml" in -# 3764 "src/ocaml/preprocess/parser_raw.mly" +# 3729 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(fields, Closed, Some []) ) -# 7177 "src/ocaml/preprocess/parser_raw.ml" +# 7120 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -7181,15 +7124,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 7187 "src/ocaml/preprocess/parser_raw.ml" +# 7130 "src/ocaml/preprocess/parser_raw.ml" in -# 3771 "src/ocaml/preprocess/parser_raw.mly" +# 3736 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7193 "src/ocaml/preprocess/parser_raw.ml" +# 7136 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7254,18 +7197,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7258 "src/ocaml/preprocess/parser_raw.ml" +# 7201 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1129 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7263 "src/ocaml/preprocess/parser_raw.ml" +# 7206 "src/ocaml/preprocess/parser_raw.ml" in -# 3876 "src/ocaml/preprocess/parser_raw.mly" +# 3841 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7269 "src/ocaml/preprocess/parser_raw.ml" +# 7212 "src/ocaml/preprocess/parser_raw.ml" in let fields = @@ -7273,24 +7216,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 7277 "src/ocaml/preprocess/parser_raw.ml" +# 7220 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7282 "src/ocaml/preprocess/parser_raw.ml" +# 7225 "src/ocaml/preprocess/parser_raw.ml" in -# 3848 "src/ocaml/preprocess/parser_raw.mly" +# 3813 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7288 "src/ocaml/preprocess/parser_raw.ml" +# 7231 "src/ocaml/preprocess/parser_raw.ml" in -# 3769 "src/ocaml/preprocess/parser_raw.mly" +# 3734 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_variant(fields, Closed, Some tags) ) -# 7294 "src/ocaml/preprocess/parser_raw.ml" +# 7237 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -7298,15 +7241,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 7304 "src/ocaml/preprocess/parser_raw.ml" +# 7247 "src/ocaml/preprocess/parser_raw.ml" in -# 3771 "src/ocaml/preprocess/parser_raw.mly" +# 3736 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7310 "src/ocaml/preprocess/parser_raw.ml" +# 7253 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7329,9 +7272,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.direction_flag) = -# 4109 "src/ocaml/preprocess/parser_raw.mly" +# 4074 "src/ocaml/preprocess/parser_raw.mly" ( Upto ) -# 7335 "src/ocaml/preprocess/parser_raw.ml" +# 7278 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7354,9 +7297,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.direction_flag) = -# 4110 "src/ocaml/preprocess/parser_raw.mly" +# 4075 "src/ocaml/preprocess/parser_raw.mly" ( Downto ) -# 7360 "src/ocaml/preprocess/parser_raw.ml" +# 7303 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7367,38 +7310,14 @@ module Tables = struct }); (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 _menhir_s = _menhir_env.MenhirLib.EngineTypes.current 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 - -# 4325 "src/ocaml/preprocess/parser_raw.mly" - ( expr_of_lwt_bindings ~loc:_loc _1 (merloc _endpos__2_ _3) ) -# 7402 "src/ocaml/preprocess/parser_raw.ml" + let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in + let _endpos = _startpos in + let _v : (string Location.loc option) = +# 4230 "src/ocaml/preprocess/parser_raw.mly" + ( None ) +# 7321 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7411,95 +7330,26 @@ module Tables = struct 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.semv = _2; + MenhirLib.EngineTypes.startp = _startpos__2_; + MenhirLib.EngineTypes.endp = _endpos__2_; 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; - }; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 _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_xs_ in - let _v : (Parsetree.expression) = let _5 = - let xs = - let xs = -# 253 "" - ( List.rev xs ) -# 7464 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1278 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 7469 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2928 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 7475 "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 - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 7486 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7492 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos = _endpos__5_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) in - -# 4327 "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 ) -# 7503 "src/ocaml/preprocess/parser_raw.ml" + let _endpos = _endpos__2_ in + let _v : (string Location.loc option) = +# 4231 "src/ocaml/preprocess/parser_raw.mly" + ( Some _2 ) +# 7353 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7512,19 +7362,19 @@ module Tables = struct 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.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.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.semv = _2; + MenhirLib.EngineTypes.startp = _startpos__2_; + MenhirLib.EngineTypes.endp = _endpos__2_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _menhir_s; MenhirLib.EngineTypes.semv = _1; @@ -7535,36 +7385,49 @@ module Tables = struct }; }; } = _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 _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__3_ in - let _v : (Parsetree.expression) = let _2 = - let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in - let _2 = - let _1 = _1_inlined1 in - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 7553 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7559 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos = _endpos__3_ in + let _endpos = _endpos__4_ in + let _v : (Parsetree.extension) = +# 4243 "src/ocaml/preprocess/parser_raw.mly" + ( (_2, _3) ) +# 7399 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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 : ( +# 878 "src/ocaml/preprocess/parser_raw.mly" + (string * Location.t * string * Location.t * string option) +# 7420 "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 _loc = (_startpos, _endpos) 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 -# 4331 "src/ocaml/preprocess/parser_raw.mly" - ( reloc_exp ~loc:_loc (Fake.app Fake.Lwt.in_lwt _3) ) -# 7568 "src/ocaml/preprocess/parser_raw.ml" +# 4245 "src/ocaml/preprocess/parser_raw.mly" + ( mk_quotedext ~loc:_sloc _1 ) +# 7431 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7577,14 +7440,14 @@ module Tables = struct 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.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.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; @@ -7592,79 +7455,67 @@ module Tables = struct 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.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_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; - }; + MenhirLib.EngineTypes.state = _menhir_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_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_xs_ in - let _v : (Parsetree.expression) = let _5 = - let xs = - let xs = -# 253 "" - ( List.rev xs ) -# 7630 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1278 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 7635 "src/ocaml/preprocess/parser_raw.ml" - - in + let _endpos = _endpos__1_inlined3_ in + let _v : (Parsetree.extension_constructor) = let attrs = + let _1 = _1_inlined3 in -# 2928 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 7641 "src/ocaml/preprocess/parser_raw.ml" +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7486 "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 - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 7652 "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 -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7658 "src/ocaml/preprocess/parser_raw.ml" +# 1027 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 7498 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__5_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) 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 + +# 1027 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 7509 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos_attrs_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in -# 4333 "src/ocaml/preprocess/parser_raw.mly" - ( mkexp_attrs ~loc:_loc - (Pexp_try(Fake.app Fake.Lwt.in_lwt _3, List.rev _5)) _2 ) -# 7668 "src/ocaml/preprocess/parser_raw.ml" +# 3531 "src/ocaml/preprocess/parser_raw.mly" + ( let info = symbol_info _endpos in + Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) +# 7519 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7677,70 +7528,121 @@ module Tables = struct 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.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.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 = _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; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 _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__5_ in - let _v : (Parsetree.expression) = let _2 = - let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in - let _2 = - let _1 = _1_inlined1 in - -# 4262 "src/ocaml/preprocess/parser_raw.mly" + let _endpos = _endpos__1_inlined2_ in + let _v : (Parsetree.extension_constructor) = let attrs = + let _1 = _1_inlined2 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7732 "src/ocaml/preprocess/parser_raw.ml" - - in +# 7567 "src/ocaml/preprocess/parser_raw.ml" -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7738 "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 + +# 1027 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 7579 "src/ocaml/preprocess/parser_raw.ml" + + in + let cid = + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1027 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 7589 "src/ocaml/preprocess/parser_raw.ml" + + in + let _startpos_cid_ = _startpos__1_ in + let _1 = +# 4048 "src/ocaml/preprocess/parser_raw.mly" + ( () ) +# 7596 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos_attrs_ in + let _symbolstartpos = _startpos_cid_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 3531 "src/ocaml/preprocess/parser_raw.mly" + ( let info = symbol_info _endpos in + Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) +# 7605 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.next = _menhir_stack; + }); + (fun _menhir_env -> + let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in + let { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = ext; + MenhirLib.EngineTypes.startp = _startpos_ext_; + MenhirLib.EngineTypes.endp = _endpos_ext_; + MenhirLib.EngineTypes.next = _menhir_stack; + } = _menhir_stack in + let ext : (Parsetree.extension) = Obj.magic ext in + let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in + let _startpos = _startpos_ext_ in + let _endpos = _endpos_ext_ in + let _v : (Parsetree.core_type) = let _1 = + let _1 = +# 3752 "src/ocaml/preprocess/parser_raw.mly" + ( Ptyp_extension ext ) +# 7631 "src/ocaml/preprocess/parser_raw.ml" + in + let (_endpos__1_, _startpos__1_) = (_endpos_ext_, _startpos_ext_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1064 "src/ocaml/preprocess/parser_raw.mly" + ( mktyp ~loc:_sloc _1 ) +# 7640 "src/ocaml/preprocess/parser_raw.ml" in -# 4336 "src/ocaml/preprocess/parser_raw.mly" - ( Fake.app (Fake.app Fake.Lwt.finally_ _3) _5 ) -# 7744 "src/ocaml/preprocess/parser_raw.ml" +# 3754 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7646 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7753,108 +7655,125 @@ module Tables = struct 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.semv = _4; + MenhirLib.EngineTypes.startp = _startpos__4_; + MenhirLib.EngineTypes.endp = _endpos__4_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _6; - MenhirLib.EngineTypes.startp = _startpos__6_; - MenhirLib.EngineTypes.endp = _endpos__6_; + 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.semv = _2; + MenhirLib.EngineTypes.startp = _startpos__2_; + MenhirLib.EngineTypes.endp = _endpos__2_; 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; - }; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 _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__7_ in - let _v : (Parsetree.expression) = let _5 = - let xs = + let _endpos = _endpos__4_ in + let _v : (Parsetree.attribute) = let _endpos = _endpos__4_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 4218 "src/ocaml/preprocess/parser_raw.mly" + ( mark_symbol_docs _sloc; + mk_attr ~loc:(make_loc _sloc) _2 _3 ) +# 7696 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.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 = +# 2243 "src/ocaml/preprocess/parser_raw.mly" + ( [] ) +# 7714 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2060 "src/ocaml/preprocess/parser_raw.mly" + ( params ) +# 7719 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 "" ( List.rev xs ) -# 7820 "src/ocaml/preprocess/parser_raw.ml" +# 7760 "src/ocaml/preprocess/parser_raw.ml" in -# 1278 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 7825 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2928 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 7831 "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 - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 7841 "src/ocaml/preprocess/parser_raw.ml" +# 7765 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 7847 "src/ocaml/preprocess/parser_raw.ml" +# 2245 "src/ocaml/preprocess/parser_raw.mly" + ( params ) +# 7771 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__7_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) in -# 4338 "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 ) -# 7858 "src/ocaml/preprocess/parser_raw.ml" +# 2060 "src/ocaml/preprocess/parser_raw.mly" + ( params ) +# 7777 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7867,81 +7786,137 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _5; - MenhirLib.EngineTypes.startp = _startpos__5_; - MenhirLib.EngineTypes.endp = _endpos__5_; + 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.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 = _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; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_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 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__6_ in - let _v : (Parsetree.expression) = let _2 = + let _endpos = _endpos_xs_ in + let _v : (Parsetree.function_body) = let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 7825 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7830 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 7836 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 7929 "src/ocaml/preprocess/parser_raw.ml" +# 7847 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 7935 "src/ocaml/preprocess/parser_raw.ml" +# 7853 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__6_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in -# 4342 "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)) ) -# 7945 "src/ocaml/preprocess/parser_raw.ml" +# 2879 "src/ocaml/preprocess/parser_raw.mly" + ( let ext, attrs = _2 in + match ext with + | None -> Pfunction_cases (_3, make_loc _sloc, attrs) + | Some _ -> + (* function%foo extension nodes interrupt the arity *) + let cases = Pfunction_cases (_3, make_loc _sloc, []) in + Pfunction_body + (mkexp_attrs ~loc:_sloc (mkfunction [] None cases) _2) + ) +# 7870 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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.function_body) = +# 2889 "src/ocaml/preprocess/parser_raw.mly" + ( Pfunction_body _1 ) +# 7895 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + MenhirLib.EngineTypes.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) = +# 2501 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 7920 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -7954,63 +7929,45 @@ module Tables = struct 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.semv = _7; + MenhirLib.EngineTypes.startp = _startpos__7_; + MenhirLib.EngineTypes.endp = _endpos__7_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _9; - MenhirLib.EngineTypes.startp = _startpos__9_; - MenhirLib.EngineTypes.endp = _endpos__9_; + MenhirLib.EngineTypes.semv = _6; + MenhirLib.EngineTypes.startp = _startpos__6_; + MenhirLib.EngineTypes.endp = _endpos__6_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _8; - MenhirLib.EngineTypes.startp = _startpos__8_; - MenhirLib.EngineTypes.endp = _endpos__8_; + MenhirLib.EngineTypes.semv = _5; + MenhirLib.EngineTypes.startp = _startpos__5_; + MenhirLib.EngineTypes.endp = _endpos__5_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _7; - MenhirLib.EngineTypes.startp = _startpos__7_; - MenhirLib.EngineTypes.endp = _endpos__7_; + 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 = _6; - MenhirLib.EngineTypes.startp = _startpos__6_; - MenhirLib.EngineTypes.endp = _endpos__6_; + 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.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.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 = _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; - }; - }; - }; + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; + MenhirLib.EngineTypes.next = _menhir_stack; }; }; }; @@ -8019,44 +7976,60 @@ module Tables = struct }; }; } = _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 _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__10_ in - let _v : (Parsetree.expression) = let _2 = - let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in - let _2 = - let _1 = _1_inlined1 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 -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 8000 "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 + +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8044 "src/ocaml/preprocess/parser_raw.ml" +# 8010 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8016 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 8050 "src/ocaml/preprocess/parser_raw.ml" +# 2539 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_letmodule(_4, _5, (merloc _endpos__6_ _7)), _3 ) +# 8022 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__10_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) in + let _endpos__1_ = _endpos__7_ in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in -# 4345 "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)) ) -# 8060 "src/ocaml/preprocess/parser_raw.ml" +# 2503 "src/ocaml/preprocess/parser_raw.mly" + ( let desc, attrs = _1 in + mkexp_attrs ~loc:_sloc desc attrs ) +# 8033 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8069,44 +8042,44 @@ module Tables = struct 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.semv = _6; + MenhirLib.EngineTypes.startp = _startpos__6_; + MenhirLib.EngineTypes.endp = _endpos__6_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _7; - MenhirLib.EngineTypes.startp = _startpos__7_; - MenhirLib.EngineTypes.endp = _endpos__7_; + MenhirLib.EngineTypes.semv = _5; + MenhirLib.EngineTypes.startp = _startpos__5_; + MenhirLib.EngineTypes.endp = _endpos__5_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _6; - MenhirLib.EngineTypes.startp = _startpos__6_; - MenhirLib.EngineTypes.endp = _endpos__6_; + 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.semv = _2_inlined1; + MenhirLib.EngineTypes.startp = _startpos__2_inlined1_; + MenhirLib.EngineTypes.endp = _endpos__2_inlined1_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _4; - MenhirLib.EngineTypes.startp = _startpos__4_; - MenhirLib.EngineTypes.endp = _endpos__4_; + 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 = _3; - MenhirLib.EngineTypes.startp = _startpos__3_; - MenhirLib.EngineTypes.endp = _endpos__3_; + 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_inlined2; - MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; + 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_inlined1; - MenhirLib.EngineTypes.startp = _startpos__1_inlined1_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined1_; + MenhirLib.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; @@ -8122,75 +8095,82 @@ module Tables = struct }; }; } = _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 _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 : (Ocaml_parsing.Ast_helper.str list * 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__8_ in - let _v : (Parsetree.expression) = let _2 = - let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in - let _2 = - let _1 = _1_inlined1 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 + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8120 "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 + +# 1027 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 8131 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 3442 "src/ocaml/preprocess/parser_raw.mly" + ( let vars, args, res = _2 in + Te.decl _1 ~vars ~args ?res ~attrs:_3 ~loc:(make_loc _sloc) ) +# 8141 "src/ocaml/preprocess/parser_raw.ml" -# 4262 "src/ocaml/preprocess/parser_raw.mly" + in + let _3 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8145 "src/ocaml/preprocess/parser_raw.ml" +# 8151 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8157 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 8151 "src/ocaml/preprocess/parser_raw.ml" +# 2541 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_letexception(_4, _6), _3 ) +# 8163 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__8_ in - let _startpos = _startpos__1_ in - let _loc = (_startpos, _endpos) in - -# 4348 "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 - ) -# 8164 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - MenhirLib.EngineTypes.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__1_ = _endpos__6_ in let _endpos = _endpos__1_ in - let _v : (Parsetree.expression) = let _1 = -# 2424 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 8189 "src/ocaml/preprocess/parser_raw.ml" - in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in -# 2570 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 8194 "src/ocaml/preprocess/parser_raw.ml" +# 2503 "src/ocaml/preprocess/parser_raw.mly" + ( let desc, attrs = _1 in + mkexp_attrs ~loc:_sloc desc attrs ) +# 8174 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8203,115 +8183,96 @@ module Tables = struct 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.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.semv = _6; + MenhirLib.EngineTypes.startp = _startpos__6_; + MenhirLib.EngineTypes.endp = _endpos__6_; 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.semv = _5; + MenhirLib.EngineTypes.startp = _startpos__5_; + MenhirLib.EngineTypes.endp = _endpos__5_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 xs : (Parsetree.case list) = Obj.magic xs 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_xs_ in + let _endpos = _endpos__7_ in let _v : (Parsetree.expression) = let _1 = - let _3 = - let xs = - let xs = -# 253 "" - ( List.rev xs ) -# 8243 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1278 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 8248 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2928 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 8254 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos__3_ = _endpos_xs_ in - let _2 = + let _4 = let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8265 "src/ocaml/preprocess/parser_raw.ml" +# 8246 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 8271 "src/ocaml/preprocess/parser_raw.ml" +# 8252 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__3_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in + let _3 = +# 4129 "src/ocaml/preprocess/parser_raw.mly" + ( Fresh ) +# 8258 "src/ocaml/preprocess/parser_raw.ml" + in -# 2426 "src/ocaml/preprocess/parser_raw.mly" - ( let loc = make_loc _sloc in - let cases = _3 in - (* There are two choices of where to put attributes: on the - Pexp_function node; on the Pfunction_cases body. We put them on the - Pexp_function node here because the compiler only uses - Pfunction_cases attributes for enabling/disabling warnings in - typechecking. For standalone function cases, we want the compiler to - respect, e.g., [@inline] attributes. - *) - let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in - mkexp_attrs ~loc:_sloc desc _2 - ) -# 8291 "src/ocaml/preprocess/parser_raw.ml" +# 2543 "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 ) +# 8265 "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 -# 2570 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 8297 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.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) = -# 4265 "src/ocaml/preprocess/parser_raw.mly" - ( None ) -# 8315 "src/ocaml/preprocess/parser_raw.ml" +# 2503 "src/ocaml/preprocess/parser_raw.mly" + ( let desc, attrs = _1 in + mkexp_attrs ~loc:_sloc desc attrs ) +# 8276 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8324,26 +8285,106 @@ module Tables = struct 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.semv = _7; + MenhirLib.EngineTypes.startp = _startpos__7_; + MenhirLib.EngineTypes.endp = _endpos__7_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 _2 : (string Location.loc) = Obj.magic _2 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__2_ in - let _v : (string Location.loc option) = -# 4266 "src/ocaml/preprocess/parser_raw.mly" - ( Some _2 ) -# 8347 "src/ocaml/preprocess/parser_raw.ml" + 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 + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8355 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8361 "src/ocaml/preprocess/parser_raw.ml" + + in + let _3 = + let _1 = _1_inlined1 in + +# 4130 "src/ocaml/preprocess/parser_raw.mly" + ( Override ) +# 8369 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2543 "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 ) +# 8377 "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 + +# 2503 "src/ocaml/preprocess/parser_raw.mly" + ( let desc, attrs = _1 in + mkexp_attrs ~loc:_sloc desc attrs ) +# 8388 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8356,72 +8397,91 @@ module Tables = struct 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.semv = _6; + MenhirLib.EngineTypes.startp = _startpos__6_; + MenhirLib.EngineTypes.endp = _endpos__6_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _3; - MenhirLib.EngineTypes.startp = _startpos__3_; - MenhirLib.EngineTypes.endp = _endpos__3_; + MenhirLib.EngineTypes.semv = _5; + MenhirLib.EngineTypes.startp = _startpos__5_; + MenhirLib.EngineTypes.endp = _endpos__5_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _2; - MenhirLib.EngineTypes.startp = _startpos__2_; - MenhirLib.EngineTypes.endp = _endpos__2_; + MenhirLib.EngineTypes.semv = _4; + MenhirLib.EngineTypes.startp = _startpos__4_; + MenhirLib.EngineTypes.endp = _endpos__4_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 : unit = Obj.magic _4 in - let _3 : (Parsetree.payload) = Obj.magic _3 in - let _2 : (string Location.loc) = Obj.magic _2 in + let _6 : (Parsetree.function_body) = Obj.magic _6 in + let _5 : unit = Obj.magic _5 in + let _4 : (Parsetree.core_type option) = Obj.magic _4 in + let _3 : (Parsetree.function_param list) = 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.extension) = -# 4278 "src/ocaml/preprocess/parser_raw.mly" - ( (_2, _3) ) -# 8393 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - MenhirLib.EngineTypes.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 : ( -# 905 "src/ocaml/preprocess/parser_raw.mly" - (string * Location.t * string * Location.t * string option) -# 8414 "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__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 + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8460 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8466 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2549 "src/ocaml/preprocess/parser_raw.mly" + ( let body_constraint = Option.map (fun x -> Pconstraint x) _4 in + mkfunction _3 body_constraint _6, _2 + ) +# 8474 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__1_ = _endpos__6_ 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 -# 4280 "src/ocaml/preprocess/parser_raw.mly" - ( mk_quotedext ~loc:_sloc _1 ) -# 8425 "src/ocaml/preprocess/parser_raw.ml" +# 2503 "src/ocaml/preprocess/parser_raw.mly" + ( let desc, attrs = _1 in + mkexp_attrs ~loc:_sloc desc attrs ) +# 8485 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8434,14 +8494,14 @@ module Tables = struct 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.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.semv = _4; + MenhirLib.EngineTypes.startp = _startpos__4_; + MenhirLib.EngineTypes.endp = _endpos__4_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _3; @@ -8449,67 +8509,86 @@ module Tables = struct 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.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 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__1_inlined3_ in - let _v : (Parsetree.extension_constructor) = let attrs = - let _1 = _1_inlined3 in - -# 4262 "src/ocaml/preprocess/parser_raw.mly" + let _endpos = _endpos_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _5 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 8548 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8553 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8559 "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 + +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8480 "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 - -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 8492 "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 +# 8569 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8575 "src/ocaml/preprocess/parser_raw.ml" + + in -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 8503 "src/ocaml/preprocess/parser_raw.ml" +# 2553 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_match(_3, _5), _2 ) +# 8581 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos_attrs_ in + let _endpos__1_ = _endpos_xs_ in + let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3566 "src/ocaml/preprocess/parser_raw.mly" - ( let info = symbol_info _endpos in - Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 8513 "src/ocaml/preprocess/parser_raw.ml" +# 2503 "src/ocaml/preprocess/parser_raw.mly" + ( let desc, attrs = _1 in + mkexp_attrs ~loc:_sloc desc attrs ) +# 8592 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8522,121 +8601,101 @@ module Tables = struct 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.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.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 = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 : (Longident.t) = Obj.magic _1_inlined1 in - let _3 : unit = Obj.magic _3 in - let _1 : (string) = Obj.magic _1 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_inlined2_ in - let _v : (Parsetree.extension_constructor) = let attrs = - let _1 = _1_inlined2 in - -# 4262 "src/ocaml/preprocess/parser_raw.mly" + let _endpos = _endpos_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _5 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 8655 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8660 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8666 "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 + +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8561 "src/ocaml/preprocess/parser_raw.ml" +# 8676 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8682 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2555 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_try(_3, _5), _2 ) +# 8688 "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 - -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 8573 "src/ocaml/preprocess/parser_raw.ml" - - in - let cid = - let _endpos = _endpos__1_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 8583 "src/ocaml/preprocess/parser_raw.ml" - - in - let _startpos_cid_ = _startpos__1_ in - let _1 = -# 4083 "src/ocaml/preprocess/parser_raw.mly" - ( () ) -# 8590 "src/ocaml/preprocess/parser_raw.ml" - in - let _endpos = _endpos_attrs_ in - let _symbolstartpos = _startpos_cid_ in + let _endpos__1_ = _endpos_xs_ in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3566 "src/ocaml/preprocess/parser_raw.mly" - ( let info = symbol_info _endpos in - Te.rebind cid lid ~attrs ~loc:(make_loc _sloc) ~info ) -# 8599 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - MenhirLib.EngineTypes.next = _menhir_stack; - }); - (fun _menhir_env -> - let _menhir_stack = _menhir_env.MenhirLib.EngineTypes.stack in - let { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = ext; - MenhirLib.EngineTypes.startp = _startpos_ext_; - MenhirLib.EngineTypes.endp = _endpos_ext_; - MenhirLib.EngineTypes.next = _menhir_stack; - } = _menhir_stack in - let ext : (Parsetree.extension) = Obj.magic ext in - let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in - let _startpos = _startpos_ext_ in - let _endpos = _endpos_ext_ in - let _v : (Parsetree.core_type) = let _1 = - let _1 = -# 3787 "src/ocaml/preprocess/parser_raw.mly" - ( Ptyp_extension ext ) -# 8625 "src/ocaml/preprocess/parser_raw.ml" - in - let (_endpos__1_, _startpos__1_) = (_endpos_ext_, _startpos_ext_) in - let _endpos = _endpos__1_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 1099 "src/ocaml/preprocess/parser_raw.mly" - ( mktyp ~loc:_sloc _1 ) -# 8634 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 3789 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 8640 "src/ocaml/preprocess/parser_raw.ml" +# 2503 "src/ocaml/preprocess/parser_raw.mly" + ( let desc, attrs = _1 in + mkexp_attrs ~loc:_sloc desc attrs ) +# 8699 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8649,268 +8708,122 @@ module Tables = struct 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.semv = _1_inlined4; + MenhirLib.EngineTypes.startp = _startpos__1_inlined4_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined4_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _3; - MenhirLib.EngineTypes.startp = _startpos__3_; - MenhirLib.EngineTypes.endp = _endpos__3_; + MenhirLib.EngineTypes.semv = _6; + MenhirLib.EngineTypes.startp = _startpos__6_; + MenhirLib.EngineTypes.endp = _endpos__6_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _2; - MenhirLib.EngineTypes.startp = _startpos__2_; - MenhirLib.EngineTypes.endp = _endpos__2_; + MenhirLib.EngineTypes.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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_inlined4 : (Parsetree.expression) = Obj.magic _1_inlined4 in + let _6 : unit = Obj.magic _6 in + let _1_inlined3 : (Parsetree.expression) = Obj.magic _1_inlined3 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 - -# 4253 "src/ocaml/preprocess/parser_raw.mly" - ( mark_symbol_docs _sloc; - mk_attr ~loc:(make_loc _sloc) _2 _3 ) -# 8690 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.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 = -# 2278 "src/ocaml/preprocess/parser_raw.mly" - ( [] ) -# 8708 "src/ocaml/preprocess/parser_raw.ml" - in - -# 2095 "src/ocaml/preprocess/parser_raw.mly" - ( params ) -# 8713 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 _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.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let params = - let params = - let xs = -# 253 "" - ( List.rev xs ) -# 8754 "src/ocaml/preprocess/parser_raw.ml" + let _endpos = _endpos__1_inlined4_ in + let _v : (Parsetree.expression) = let _1 = + let _7 = + let _1 = _1_inlined4 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8776 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 8759 "src/ocaml/preprocess/parser_raw.ml" +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8781 "src/ocaml/preprocess/parser_raw.ml" in - -# 2280 "src/ocaml/preprocess/parser_raw.mly" - ( params ) -# 8765 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2095 "src/ocaml/preprocess/parser_raw.mly" - ( params ) -# 8771 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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.function_body) = let _3 = - let xs = - let xs = -# 253 "" - ( List.rev xs ) -# 8819 "src/ocaml/preprocess/parser_raw.ml" + let _5 = + let _1 = _1_inlined3 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8789 "src/ocaml/preprocess/parser_raw.ml" in -# 1278 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 8824 "src/ocaml/preprocess/parser_raw.ml" +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8794 "src/ocaml/preprocess/parser_raw.ml" in - -# 2928 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 8830 "src/ocaml/preprocess/parser_raw.ml" - - in - let _endpos__3_ = _endpos_xs_ in - let _2 = - let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in let _2 = - let _1 = _1_inlined1 in - -# 4262 "src/ocaml/preprocess/parser_raw.mly" + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 8841 "src/ocaml/preprocess/parser_raw.ml" +# 8804 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8810 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 8847 "src/ocaml/preprocess/parser_raw.ml" +# 2561 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), Some (merloc _endpos__6_ _7)), _2 ) +# 8816 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__3_ in + let _endpos__1_ = _endpos__1_inlined4_ in + let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2914 "src/ocaml/preprocess/parser_raw.mly" - ( let ext, attrs = _2 in - match ext with - | None -> Pfunction_cases (_3, make_loc _sloc, attrs) - | Some _ -> - (* function%foo extension nodes interrupt the arity *) - let cases = Pfunction_cases (_3, make_loc _sloc, []) in - Pfunction_body - (mkexp_attrs ~loc:_sloc (mkfunction [] None cases) _2) - ) -# 8864 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - MenhirLib.EngineTypes.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.function_body) = -# 2924 "src/ocaml/preprocess/parser_raw.mly" - ( Pfunction_body _1 ) -# 8889 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - MenhirLib.EngineTypes.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) = -# 2536 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 8914 "src/ocaml/preprocess/parser_raw.ml" +# 2503 "src/ocaml/preprocess/parser_raw.mly" + ( let desc, attrs = _1 in + mkexp_attrs ~loc:_sloc desc attrs ) +# 8827 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -8923,45 +8836,63 @@ module Tables = struct 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.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.semv = _1_inlined6; + MenhirLib.EngineTypes.startp = _startpos__1_inlined6_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined6_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _5; - MenhirLib.EngineTypes.startp = _startpos__5_; - MenhirLib.EngineTypes.endp = _endpos__5_; + 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_inlined3; - MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; + 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_inlined2; - MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; + MenhirLib.EngineTypes.semv = _6; + MenhirLib.EngineTypes.startp = _startpos__6_; + MenhirLib.EngineTypes.endp = _endpos__6_; 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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _2; - MenhirLib.EngineTypes.startp = _startpos__2_; - MenhirLib.EngineTypes.endp = _endpos__2_; + MenhirLib.EngineTypes.semv = _4; + MenhirLib.EngineTypes.startp = _startpos__4_; + MenhirLib.EngineTypes.endp = _endpos__4_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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; + }; + }; + }; }; }; }; @@ -8970,60 +8901,130 @@ module Tables = struct }; }; } = _menhir_stack in - let _7 : (Parsetree.expression) = Obj.magic _7 in + let xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined6 : (Parsetree.attributes) = Obj.magic _1_inlined6 in + let _1_inlined5 : (string Location.loc option) = Obj.magic _1_inlined5 in + let _1_inlined4 : unit = Obj.magic _1_inlined4 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_inlined3 : (Parsetree.expression) = Obj.magic _1_inlined3 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 _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 _endpos = _endpos_xs_ 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 + let _7 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined4_, _1_inlined6, _1_inlined5, _1_inlined4) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 8928 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8933 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 8939 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8950 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 8956 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 8976 "src/ocaml/preprocess/parser_raw.ml" + + in -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 8994 "src/ocaml/preprocess/parser_raw.ml" +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8982 "src/ocaml/preprocess/parser_raw.ml" in - let _3 = + let _5 = + let _1 = _1_inlined3 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8990 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 8995 "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 -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9004 "src/ocaml/preprocess/parser_raw.ml" +# 9005 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9010 "src/ocaml/preprocess/parser_raw.ml" +# 9011 "src/ocaml/preprocess/parser_raw.ml" in -# 2574 "src/ocaml/preprocess/parser_raw.mly" - ( Pexp_letmodule(_4, _5, (merloc _endpos__6_ _7)), _3 ) -# 9016 "src/ocaml/preprocess/parser_raw.ml" +# 2561 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), Some (merloc _endpos__6_ _7)), _2 ) +# 9017 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos__1_ = _endpos__7_ in + let _endpos__1_ = _endpos_xs_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2538 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9027 "src/ocaml/preprocess/parser_raw.ml" +# 9028 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9036,50 +9037,62 @@ module Tables = struct 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.semv = _1_inlined6; + MenhirLib.EngineTypes.startp = _startpos__1_inlined6_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined6_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _5; - MenhirLib.EngineTypes.startp = _startpos__5_; - MenhirLib.EngineTypes.endp = _endpos__5_; + MenhirLib.EngineTypes.semv = _6; + MenhirLib.EngineTypes.startp = _startpos__6_; + MenhirLib.EngineTypes.endp = _endpos__6_; 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; 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.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_inlined3; - MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; + 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_inlined2; - MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; + 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_inlined1; - MenhirLib.EngineTypes.startp = _startpos__1_inlined1_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined1_; + MenhirLib.EngineTypes.semv = _4; + MenhirLib.EngineTypes.startp = _startpos__4_; + MenhirLib.EngineTypes.endp = _endpos__4_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _2; - MenhirLib.EngineTypes.startp = _startpos__2_; - MenhirLib.EngineTypes.endp = _endpos__2_; + 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; + 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; + }; + }; }; }; }; @@ -9089,82 +9102,404 @@ module Tables = struct }; }; } = _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 : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * - Parsetree.core_type option) = Obj.magic _2_inlined1 in - let _1_inlined3 : (string) = Obj.magic _1_inlined3 in + let _1_inlined6 : (Parsetree.expression) = Obj.magic _1_inlined6 in + let _6 : unit = Obj.magic _6 in + let xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined5 : (Parsetree.attributes) = Obj.magic _1_inlined5 in + let _1_inlined4 : (string Location.loc option) = Obj.magic _1_inlined4 in + let _1_inlined3 : unit = Obj.magic _1_inlined3 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 _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 _endpos = _endpos__1_inlined6_ 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 _7 = + let _1 = _1_inlined6 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9126 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9131 "src/ocaml/preprocess/parser_raw.ml" + + in + let _5 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined3_, _1_inlined5, _1_inlined4, _1_inlined3) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 9142 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 9147 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 9153 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9164 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 9170 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 9190 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9196 "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 -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9114 "src/ocaml/preprocess/parser_raw.ml" +# 9206 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos__3_ = _endpos__1_inlined1_ in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 9212 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2561 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), Some (merloc _endpos__6_ _7)), _2 ) +# 9218 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__1_ = _endpos__1_inlined6_ in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2503 "src/ocaml/preprocess/parser_raw.mly" + ( let desc, attrs = _1 in + mkexp_attrs ~loc:_sloc desc attrs ) +# 9229 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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_inlined1; + MenhirLib.EngineTypes.startp = _startpos_xs_inlined1_; + MenhirLib.EngineTypes.endp = _endpos_xs_inlined1_; + MenhirLib.EngineTypes.next = { + MenhirLib.EngineTypes.state = _; + MenhirLib.EngineTypes.semv = _1_inlined8; + MenhirLib.EngineTypes.startp = _startpos__1_inlined8_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined8_; + MenhirLib.EngineTypes.next = { + MenhirLib.EngineTypes.state = _; + MenhirLib.EngineTypes.semv = _1_inlined7; + MenhirLib.EngineTypes.startp = _startpos__1_inlined7_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined7_; + MenhirLib.EngineTypes.next = { + MenhirLib.EngineTypes.state = _; + MenhirLib.EngineTypes.semv = _1_inlined6; + MenhirLib.EngineTypes.startp = _startpos__1_inlined6_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined6_; + 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 = _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 = _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_inlined1 : (Parsetree.case list) = Obj.magic xs_inlined1 in + let _1_inlined8 : (Parsetree.attributes) = Obj.magic _1_inlined8 in + let _1_inlined7 : (string Location.loc option) = Obj.magic _1_inlined7 in + let _1_inlined6 : unit = Obj.magic _1_inlined6 in + let _6 : unit = Obj.magic _6 in + let xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined5 : (Parsetree.attributes) = Obj.magic _1_inlined5 in + let _1_inlined4 : (string Location.loc option) = Obj.magic _1_inlined4 in + let _1_inlined3 : unit = Obj.magic _1_inlined3 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_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let _7 = + let (_endpos_xs_, _startpos__1_, xs, _1_inlined2, _1_inlined1, _1) = (_endpos_xs_inlined1_, _startpos__1_inlined6_, xs_inlined1, _1_inlined8, _1_inlined7, _1_inlined6) in let _1 = - let _endpos = _endpos__1_ in + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 9351 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 9356 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 9362 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9373 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 9379 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 9125 "src/ocaml/preprocess/parser_raw.ml" +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 9399 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__3_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in -# 3477 "src/ocaml/preprocess/parser_raw.mly" - ( let vars, args, res = _2 in - Te.decl _1 ~vars ~args ?res ~attrs:_3 ~loc:(make_loc _sloc) ) -# 9135 "src/ocaml/preprocess/parser_raw.ml" +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9405 "src/ocaml/preprocess/parser_raw.ml" in - let _3 = + let _5 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined3_, _1_inlined5, _1_inlined4, _1_inlined3) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 9416 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 9421 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 9427 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9438 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 9444 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 9464 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9470 "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 -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9145 "src/ocaml/preprocess/parser_raw.ml" +# 9480 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9151 "src/ocaml/preprocess/parser_raw.ml" +# 9486 "src/ocaml/preprocess/parser_raw.ml" in -# 2576 "src/ocaml/preprocess/parser_raw.mly" - ( Pexp_letexception(_4, _6), _3 ) -# 9157 "src/ocaml/preprocess/parser_raw.ml" +# 2561 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), Some (merloc _endpos__6_ _7)), _2 ) +# 9492 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos__1_ = _endpos__6_ in + let _endpos__1_ = _endpos_xs_inlined1_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2538 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9168 "src/ocaml/preprocess/parser_raw.ml" +# 9503 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9177,19 +9512,19 @@ module Tables = struct 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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _6; - MenhirLib.EngineTypes.startp = _startpos__6_; - MenhirLib.EngineTypes.endp = _endpos__6_; + MenhirLib.EngineTypes.semv = _4; + MenhirLib.EngineTypes.startp = _startpos__4_; + MenhirLib.EngineTypes.endp = _endpos__4_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _5; - MenhirLib.EngineTypes.startp = _startpos__5_; - MenhirLib.EngineTypes.endp = _endpos__5_; + 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; @@ -9201,72 +9536,71 @@ module Tables = struct 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; - }; + MenhirLib.EngineTypes.state = _menhir_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.expression) = Obj.magic _1_inlined3 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 _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 _endpos = _endpos__1_inlined3_ in let _v : (Parsetree.expression) = let _1 = - let _4 = + let _5 = + let _1 = _1_inlined3 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9566 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9571 "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 -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9240 "src/ocaml/preprocess/parser_raw.ml" +# 9581 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9246 "src/ocaml/preprocess/parser_raw.ml" +# 9587 "src/ocaml/preprocess/parser_raw.ml" in - let _3 = -# 4164 "src/ocaml/preprocess/parser_raw.mly" - ( Fresh ) -# 9252 "src/ocaml/preprocess/parser_raw.ml" - in -# 2578 "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 ) -# 9259 "src/ocaml/preprocess/parser_raw.ml" +# 2563 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), None), _2 ) +# 9593 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos__1_ = _endpos__7_ in + let _endpos__1_ = _endpos__1_inlined3_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2538 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9270 "src/ocaml/preprocess/parser_raw.ml" +# 9604 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9279,19 +9613,19 @@ module Tables = struct 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.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.semv = _1_inlined5; + MenhirLib.EngineTypes.startp = _startpos__1_inlined5_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined5_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _5; - MenhirLib.EngineTypes.startp = _startpos__5_; - MenhirLib.EngineTypes.endp = _endpos__5_; + 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; @@ -9299,25 +9633,31 @@ module Tables = struct 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.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.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.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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; + }; }; }; }; @@ -9326,59 +9666,115 @@ module Tables = struct }; }; } = _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 xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined5 : (Parsetree.attributes) = Obj.magic _1_inlined5 in + let _1_inlined4 : (string Location.loc option) = Obj.magic _1_inlined4 in + let _1_inlined3 : unit = Obj.magic _1_inlined3 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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = - let _4 = - let (_1_inlined1, _1) = (_1_inlined3, _1_inlined2) in + let _5 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined3_, _1_inlined5, _1_inlined4, _1_inlined3) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 9691 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 9696 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 9702 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9713 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 9719 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 9739 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 9745 "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 -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9349 "src/ocaml/preprocess/parser_raw.ml" +# 9755 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9355 "src/ocaml/preprocess/parser_raw.ml" - - in - let _3 = - let _1 = _1_inlined1 in - -# 4165 "src/ocaml/preprocess/parser_raw.mly" - ( Override ) -# 9363 "src/ocaml/preprocess/parser_raw.ml" +# 9761 "src/ocaml/preprocess/parser_raw.ml" in -# 2578 "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 ) -# 9371 "src/ocaml/preprocess/parser_raw.ml" +# 2563 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), None), _2 ) +# 9767 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos__1_ = _endpos__7_ in + let _endpos__1_ = _endpos_xs_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2538 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9382 "src/ocaml/preprocess/parser_raw.ml" +# 9778 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9432,10 +9828,10 @@ module Tables = struct }; }; } = _menhir_stack in - let _6 : (Parsetree.function_body) = Obj.magic _6 in - let _5 : unit = Obj.magic _5 in - let _4 : (Parsetree.core_type option) = Obj.magic _4 in - let _3 : (Parsetree.function_param list) = Obj.magic _3 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 @@ -9448,23 +9844,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 9454 "src/ocaml/preprocess/parser_raw.ml" +# 9850 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 9460 "src/ocaml/preprocess/parser_raw.ml" +# 9856 "src/ocaml/preprocess/parser_raw.ml" in -# 2584 "src/ocaml/preprocess/parser_raw.mly" - ( let body_constraint = Option.map (fun x -> Pconstraint x) _4 in - mkfunction _3 body_constraint _6, _2 - ) -# 9468 "src/ocaml/preprocess/parser_raw.ml" +# 2565 "src/ocaml/preprocess/parser_raw.mly" + ( Pexp_while(_3, (merloc _endpos__4_ _5)), _2 ) +# 9862 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__6_ in @@ -9472,10 +9866,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2538 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 9479 "src/ocaml/preprocess/parser_raw.ml" +# 9873 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -9488,518 +9882,19 @@ module Tables = struct 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.semv = _10; + MenhirLib.EngineTypes.startp = _startpos__10_; + MenhirLib.EngineTypes.endp = _endpos__10_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _4; - MenhirLib.EngineTypes.startp = _startpos__4_; - MenhirLib.EngineTypes.endp = _endpos__4_; + MenhirLib.EngineTypes.semv = _9; + MenhirLib.EngineTypes.startp = _startpos__9_; + MenhirLib.EngineTypes.endp = _endpos__9_; 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 "" - ( List.rev xs ) -# 9542 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1278 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 9547 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2928 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 9553 "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 - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 9563 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 9569 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2588 "src/ocaml/preprocess/parser_raw.mly" - ( Pexp_match(_3, _5), _2 ) -# 9575 "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 - -# 2538 "src/ocaml/preprocess/parser_raw.mly" - ( let desc, attrs = _1 in - mkexp_attrs ~loc:_sloc desc attrs ) -# 9586 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 "" - ( List.rev xs ) -# 9649 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1278 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 9654 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2928 "src/ocaml/preprocess/parser_raw.mly" - ( xs ) -# 9660 "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 - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 9670 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 9676 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2590 "src/ocaml/preprocess/parser_raw.mly" - ( Pexp_try(_3, _5), _2 ) -# 9682 "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 - -# 2538 "src/ocaml/preprocess/parser_raw.mly" - ( let desc, attrs = _1 in - mkexp_attrs ~loc:_sloc desc attrs ) -# 9693 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 9772 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 9778 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2596 "src/ocaml/preprocess/parser_raw.mly" - ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), Some (merloc _endpos__6_ _7)), _2 ) -# 9784 "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 - -# 2538 "src/ocaml/preprocess/parser_raw.mly" - ( let desc, attrs = _1 in - mkexp_attrs ~loc:_sloc desc attrs ) -# 9795 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 9860 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 9866 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2598 "src/ocaml/preprocess/parser_raw.mly" - ( Pexp_ifthenelse(_3, (merloc _endpos__4_ _5), None), _2 ) -# 9872 "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 - -# 2538 "src/ocaml/preprocess/parser_raw.mly" - ( let desc, attrs = _1 in - mkexp_attrs ~loc:_sloc desc attrs ) -# 9883 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 9955 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 9961 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2600 "src/ocaml/preprocess/parser_raw.mly" - ( Pexp_while(_3, (merloc _endpos__4_ _5)), _2 ) -# 9967 "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 - -# 2538 "src/ocaml/preprocess/parser_raw.mly" - ( let desc, attrs = _1 in - mkexp_attrs ~loc:_sloc desc attrs ) -# 9978 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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.semv = _8; + MenhirLib.EngineTypes.startp = _startpos__8_; + MenhirLib.EngineTypes.endp = _endpos__8_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _7; @@ -10072,21 +9967,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10078 "src/ocaml/preprocess/parser_raw.ml" +# 9973 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 10084 "src/ocaml/preprocess/parser_raw.ml" +# 9979 "src/ocaml/preprocess/parser_raw.ml" in -# 2607 "src/ocaml/preprocess/parser_raw.mly" +# 2572 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_for(_3, (merloc _endpos__4_ _5), (merloc _endpos__6_ _7), _6, (merloc _endpos__8_ _9)), _2 ) -# 10090 "src/ocaml/preprocess/parser_raw.ml" +# 9985 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__10_ in @@ -10094,10 +9989,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2538 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 10101 "src/ocaml/preprocess/parser_raw.ml" +# 9996 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10146,21 +10041,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10152 "src/ocaml/preprocess/parser_raw.ml" +# 10047 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 10158 "src/ocaml/preprocess/parser_raw.ml" +# 10053 "src/ocaml/preprocess/parser_raw.ml" in -# 2609 "src/ocaml/preprocess/parser_raw.mly" +# 2574 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_assert _3, _2 ) -# 10164 "src/ocaml/preprocess/parser_raw.ml" +# 10059 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -10168,10 +10063,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2538 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 10175 "src/ocaml/preprocess/parser_raw.ml" +# 10070 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10220,21 +10115,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10226 "src/ocaml/preprocess/parser_raw.ml" +# 10121 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 10232 "src/ocaml/preprocess/parser_raw.ml" +# 10127 "src/ocaml/preprocess/parser_raw.ml" in -# 2611 "src/ocaml/preprocess/parser_raw.mly" +# 2576 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_lazy _3, _2 ) -# 10238 "src/ocaml/preprocess/parser_raw.ml" +# 10133 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -10242,10 +10137,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2538 "src/ocaml/preprocess/parser_raw.mly" +# 2503 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 10249 "src/ocaml/preprocess/parser_raw.ml" +# 10144 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10280,18 +10175,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 10284 "src/ocaml/preprocess/parser_raw.ml" +# 10179 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1129 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 10289 "src/ocaml/preprocess/parser_raw.ml" +# 10184 "src/ocaml/preprocess/parser_raw.ml" in -# 2615 "src/ocaml/preprocess/parser_raw.mly" +# 2580 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, _2) ) -# 10295 "src/ocaml/preprocess/parser_raw.ml" +# 10190 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -10299,15 +10194,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10305 "src/ocaml/preprocess/parser_raw.ml" +# 10200 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10311 "src/ocaml/preprocess/parser_raw.ml" +# 10206 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10336,24 +10231,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 10340 "src/ocaml/preprocess/parser_raw.ml" +# 10235 "src/ocaml/preprocess/parser_raw.ml" in -# 1245 "src/ocaml/preprocess/parser_raw.mly" +# 1210 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 10345 "src/ocaml/preprocess/parser_raw.ml" +# 10240 "src/ocaml/preprocess/parser_raw.ml" in -# 2981 "src/ocaml/preprocess/parser_raw.mly" +# 2946 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 10351 "src/ocaml/preprocess/parser_raw.ml" +# 10246 "src/ocaml/preprocess/parser_raw.ml" in -# 2617 "src/ocaml/preprocess/parser_raw.mly" +# 2582 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_tuple(_1) ) -# 10357 "src/ocaml/preprocess/parser_raw.ml" +# 10252 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -10361,15 +10256,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10367 "src/ocaml/preprocess/parser_raw.ml" +# 10262 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10373 "src/ocaml/preprocess/parser_raw.ml" +# 10268 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10405,15 +10300,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 10411 "src/ocaml/preprocess/parser_raw.ml" +# 10306 "src/ocaml/preprocess/parser_raw.ml" in -# 2619 "src/ocaml/preprocess/parser_raw.mly" +# 2584 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct(_1, Some _2) ) -# 10417 "src/ocaml/preprocess/parser_raw.ml" +# 10312 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -10421,15 +10316,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10427 "src/ocaml/preprocess/parser_raw.ml" +# 10322 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10433 "src/ocaml/preprocess/parser_raw.ml" +# 10328 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10460,24 +10355,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2621 "src/ocaml/preprocess/parser_raw.mly" +# 2586 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_variant(_1, Some _2) ) -# 10466 "src/ocaml/preprocess/parser_raw.ml" +# 10361 "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 -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10475 "src/ocaml/preprocess/parser_raw.ml" +# 10370 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10481 "src/ocaml/preprocess/parser_raw.ml" +# 10376 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10490,9 +10385,9 @@ module Tables = struct 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.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = op; @@ -10507,54 +10402,66 @@ module Tables = struct }; }; } = _menhir_stack in - let e2 : (Parsetree.expression) = Obj.magic e2 in + let _1 : (Parsetree.expression) = Obj.magic _1 in let op : ( -# 841 "src/ocaml/preprocess/parser_raw.mly" +# 814 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10515 "src/ocaml/preprocess/parser_raw.ml" +# 10410 "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 _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 10422 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 10427 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3968 "src/ocaml/preprocess/parser_raw.mly" +# 3933 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10527 "src/ocaml/preprocess/parser_raw.ml" +# 10434 "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 -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10536 "src/ocaml/preprocess/parser_raw.ml" +# 10443 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10542 "src/ocaml/preprocess/parser_raw.ml" +# 10449 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let _startpos__1_ = _startpos_e1_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10552 "src/ocaml/preprocess/parser_raw.ml" +# 10459 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10558 "src/ocaml/preprocess/parser_raw.ml" +# 10465 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10567,71 +10474,156 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = op; - MenhirLib.EngineTypes.startp = _startpos_op_; - MenhirLib.EngineTypes.endp = _endpos_op_; + MenhirLib.EngineTypes.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; 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 : ( -# 842 "src/ocaml/preprocess/parser_raw.mly" - (string) -# 10592 "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 = + 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 = _; + 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 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 op : ( +# 814 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 10520 "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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 10535 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 10540 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 10546 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 10557 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 10563 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 10583 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 10589 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = let _1 = -# 3969 "src/ocaml/preprocess/parser_raw.mly" +# 3933 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10604 "src/ocaml/preprocess/parser_raw.ml" +# 10596 "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 -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10613 "src/ocaml/preprocess/parser_raw.ml" +# 10605 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10619 "src/ocaml/preprocess/parser_raw.ml" +# 10611 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10629 "src/ocaml/preprocess/parser_raw.ml" +# 10621 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10635 "src/ocaml/preprocess/parser_raw.ml" +# 10627 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10644,9 +10636,9 @@ module Tables = struct 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.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = op; @@ -10661,54 +10653,66 @@ module Tables = struct }; }; } = _menhir_stack in - let e2 : (Parsetree.expression) = Obj.magic e2 in + let _1 : (Parsetree.expression) = Obj.magic _1 in let op : ( -# 843 "src/ocaml/preprocess/parser_raw.mly" +# 815 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10669 "src/ocaml/preprocess/parser_raw.ml" +# 10661 "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 _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 10673 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 10678 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3970 "src/ocaml/preprocess/parser_raw.mly" +# 3934 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10681 "src/ocaml/preprocess/parser_raw.ml" +# 10685 "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 -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10690 "src/ocaml/preprocess/parser_raw.ml" +# 10694 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10696 "src/ocaml/preprocess/parser_raw.ml" +# 10700 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let _startpos__1_ = _startpos_e1_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10706 "src/ocaml/preprocess/parser_raw.ml" +# 10710 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10712 "src/ocaml/preprocess/parser_raw.ml" +# 10716 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10721,71 +10725,156 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = op; - MenhirLib.EngineTypes.startp = _startpos_op_; - MenhirLib.EngineTypes.endp = _endpos_op_; + MenhirLib.EngineTypes.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; 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; + 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 = _; + 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 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 op : ( -# 844 "src/ocaml/preprocess/parser_raw.mly" +# 815 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10746 "src/ocaml/preprocess/parser_raw.ml" +# 10771 "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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 10786 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 10791 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 10797 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 10808 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 10814 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 10834 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 10840 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3971 "src/ocaml/preprocess/parser_raw.mly" +# 3934 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10758 "src/ocaml/preprocess/parser_raw.ml" +# 10847 "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 -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10767 "src/ocaml/preprocess/parser_raw.ml" +# 10856 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10773 "src/ocaml/preprocess/parser_raw.ml" +# 10862 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10783 "src/ocaml/preprocess/parser_raw.ml" +# 10872 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10789 "src/ocaml/preprocess/parser_raw.ml" +# 10878 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10798,9 +10887,9 @@ module Tables = struct 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.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = op; @@ -10815,54 +10904,66 @@ module Tables = struct }; }; } = _menhir_stack in - let e2 : (Parsetree.expression) = Obj.magic e2 in + let _1 : (Parsetree.expression) = Obj.magic _1 in let op : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) -# 10823 "src/ocaml/preprocess/parser_raw.ml" +# 10912 "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 _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 10924 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 10929 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3972 "src/ocaml/preprocess/parser_raw.mly" +# 3935 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 10835 "src/ocaml/preprocess/parser_raw.ml" +# 10936 "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 -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10844 "src/ocaml/preprocess/parser_raw.ml" +# 10945 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10850 "src/ocaml/preprocess/parser_raw.ml" +# 10951 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let _startpos__1_ = _startpos_e1_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10860 "src/ocaml/preprocess/parser_raw.ml" +# 10961 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10866 "src/ocaml/preprocess/parser_raw.ml" +# 10967 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10875,66 +10976,156 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + MenhirLib.EngineTypes.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; 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; + 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 = _; + 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 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 op : ( +# 816 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 11022 "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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 11037 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 11042 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 11048 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11059 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 11065 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 11085 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11091 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3973 "src/ocaml/preprocess/parser_raw.mly" - ("+") -# 10908 "src/ocaml/preprocess/parser_raw.ml" +# 3935 "src/ocaml/preprocess/parser_raw.mly" + ( op ) +# 11098 "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 -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10916 "src/ocaml/preprocess/parser_raw.ml" +# 11107 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10922 "src/ocaml/preprocess/parser_raw.ml" +# 11113 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 10932 "src/ocaml/preprocess/parser_raw.ml" +# 11123 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 10938 "src/ocaml/preprocess/parser_raw.ml" +# 11129 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -10947,14 +11138,14 @@ module Tables = struct 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.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + 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; @@ -10964,49 +11155,66 @@ module Tables = struct }; }; } = _menhir_stack in - let e2 : (Parsetree.expression) = Obj.magic e2 in - let _1 : unit = Obj.magic _1 in + let _1 : (Parsetree.expression) = Obj.magic _1 in + let op : ( +# 817 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 11163 "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 _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11175 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11180 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3974 "src/ocaml/preprocess/parser_raw.mly" - ("+.") -# 10980 "src/ocaml/preprocess/parser_raw.ml" +# 3936 "src/ocaml/preprocess/parser_raw.mly" + ( op ) +# 11187 "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 -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 10988 "src/ocaml/preprocess/parser_raw.ml" +# 11196 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 10994 "src/ocaml/preprocess/parser_raw.ml" +# 11202 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let _startpos__1_ = _startpos_e1_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11004 "src/ocaml/preprocess/parser_raw.ml" +# 11212 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11010 "src/ocaml/preprocess/parser_raw.ml" +# 11218 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11019,66 +11227,156 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + MenhirLib.EngineTypes.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; 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; + 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 = _; + 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 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 op : ( +# 817 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 11273 "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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 11288 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 11293 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 11299 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11310 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 11316 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 11336 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11342 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3975 "src/ocaml/preprocess/parser_raw.mly" - ("+=") -# 11052 "src/ocaml/preprocess/parser_raw.ml" +# 3936 "src/ocaml/preprocess/parser_raw.mly" + ( op ) +# 11349 "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 -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11060 "src/ocaml/preprocess/parser_raw.ml" +# 11358 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11066 "src/ocaml/preprocess/parser_raw.ml" +# 11364 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11076 "src/ocaml/preprocess/parser_raw.ml" +# 11374 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11082 "src/ocaml/preprocess/parser_raw.ml" +# 11380 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11091,14 +11389,14 @@ module Tables = struct 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.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + 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; @@ -11108,49 +11406,66 @@ module Tables = struct }; }; } = _menhir_stack in - let e2 : (Parsetree.expression) = Obj.magic e2 in - let _1 : unit = Obj.magic _1 in + let _1 : (Parsetree.expression) = Obj.magic _1 in + let op : ( +# 818 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 11414 "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 _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11426 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11431 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3976 "src/ocaml/preprocess/parser_raw.mly" - ("-") -# 11124 "src/ocaml/preprocess/parser_raw.ml" +# 3937 "src/ocaml/preprocess/parser_raw.mly" + ( op ) +# 11438 "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 -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11132 "src/ocaml/preprocess/parser_raw.ml" +# 11447 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11138 "src/ocaml/preprocess/parser_raw.ml" +# 11453 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let _startpos__1_ = _startpos_e1_ in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11148 "src/ocaml/preprocess/parser_raw.ml" +# 11463 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11154 "src/ocaml/preprocess/parser_raw.ml" +# 11469 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11163,138 +11478,156 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + MenhirLib.EngineTypes.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; 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; + 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 = _; + 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 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 op : ( +# 818 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 11524 "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 = -# 3977 "src/ocaml/preprocess/parser_raw.mly" - ("-.") -# 11196 "src/ocaml/preprocess/parser_raw.ml" - in - let _endpos = _endpos__1_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in - -# 1089 "src/ocaml/preprocess/parser_raw.mly" - ( mkoperator ~loc:_sloc _1 ) -# 11204 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2623 "src/ocaml/preprocess/parser_raw.mly" - ( mkinfix e1 op e2 ) -# 11210 "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 - -# 1095 "src/ocaml/preprocess/parser_raw.mly" - ( mkexp ~loc:_sloc _1 ) -# 11220 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 2541 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 11226 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 11539 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 11544 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 11550 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11561 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 11567 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 11587 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11593 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3978 "src/ocaml/preprocess/parser_raw.mly" - ("*") -# 11268 "src/ocaml/preprocess/parser_raw.ml" +# 3937 "src/ocaml/preprocess/parser_raw.mly" + ( op ) +# 11600 "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 -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11276 "src/ocaml/preprocess/parser_raw.ml" +# 11609 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11282 "src/ocaml/preprocess/parser_raw.ml" +# 11615 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11292 "src/ocaml/preprocess/parser_raw.ml" +# 11625 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11298 "src/ocaml/preprocess/parser_raw.ml" +# 11631 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11307,9 +11640,9 @@ module Tables = struct 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.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; @@ -11324,49 +11657,62 @@ module Tables = struct }; }; } = _menhir_stack in - let e2 : (Parsetree.expression) = Obj.magic e2 in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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 _endpos = _endpos__1_inlined1_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11674 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11679 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3979 "src/ocaml/preprocess/parser_raw.mly" - ("%") -# 11340 "src/ocaml/preprocess/parser_raw.ml" +# 3938 "src/ocaml/preprocess/parser_raw.mly" + ("+") +# 11686 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11348 "src/ocaml/preprocess/parser_raw.ml" +# 11694 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11354 "src/ocaml/preprocess/parser_raw.ml" +# 11700 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11364 "src/ocaml/preprocess/parser_raw.ml" +# 11710 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11370 "src/ocaml/preprocess/parser_raw.ml" +# 11716 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11379,66 +11725,152 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + MenhirLib.EngineTypes.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; 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; + 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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 11783 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 11788 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 11794 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11805 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 11811 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 11831 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11837 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3980 "src/ocaml/preprocess/parser_raw.mly" - ("=") -# 11412 "src/ocaml/preprocess/parser_raw.ml" +# 3938 "src/ocaml/preprocess/parser_raw.mly" + ("+") +# 11844 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11420 "src/ocaml/preprocess/parser_raw.ml" +# 11852 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11426 "src/ocaml/preprocess/parser_raw.ml" +# 11858 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11436 "src/ocaml/preprocess/parser_raw.ml" +# 11868 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11442 "src/ocaml/preprocess/parser_raw.ml" +# 11874 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11451,9 +11883,9 @@ module Tables = struct 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.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; @@ -11468,49 +11900,62 @@ module Tables = struct }; }; } = _menhir_stack in - let e2 : (Parsetree.expression) = Obj.magic e2 in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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 _endpos = _endpos__1_inlined1_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11917 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 11922 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3981 "src/ocaml/preprocess/parser_raw.mly" - ("<") -# 11484 "src/ocaml/preprocess/parser_raw.ml" +# 3939 "src/ocaml/preprocess/parser_raw.mly" + ("+.") +# 11929 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11492 "src/ocaml/preprocess/parser_raw.ml" +# 11937 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11498 "src/ocaml/preprocess/parser_raw.ml" +# 11943 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11508 "src/ocaml/preprocess/parser_raw.ml" +# 11953 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11514 "src/ocaml/preprocess/parser_raw.ml" +# 11959 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11523,66 +11968,152 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + MenhirLib.EngineTypes.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; 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; + 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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 12026 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 12031 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 12037 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12048 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 12054 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 12074 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12080 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3982 "src/ocaml/preprocess/parser_raw.mly" - (">") -# 11556 "src/ocaml/preprocess/parser_raw.ml" +# 3939 "src/ocaml/preprocess/parser_raw.mly" + ("+.") +# 12087 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11564 "src/ocaml/preprocess/parser_raw.ml" +# 12095 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11570 "src/ocaml/preprocess/parser_raw.ml" +# 12101 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11580 "src/ocaml/preprocess/parser_raw.ml" +# 12111 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11586 "src/ocaml/preprocess/parser_raw.ml" +# 12117 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11595,9 +12126,9 @@ module Tables = struct 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.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; @@ -11612,49 +12143,62 @@ module Tables = struct }; }; } = _menhir_stack in - let e2 : (Parsetree.expression) = Obj.magic e2 in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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 _endpos = _endpos__1_inlined1_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12160 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12165 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3983 "src/ocaml/preprocess/parser_raw.mly" - ("or") -# 11628 "src/ocaml/preprocess/parser_raw.ml" +# 3940 "src/ocaml/preprocess/parser_raw.mly" + ("+=") +# 12172 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11636 "src/ocaml/preprocess/parser_raw.ml" +# 12180 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11642 "src/ocaml/preprocess/parser_raw.ml" +# 12186 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11652 "src/ocaml/preprocess/parser_raw.ml" +# 12196 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11658 "src/ocaml/preprocess/parser_raw.ml" +# 12202 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11667,66 +12211,152 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + MenhirLib.EngineTypes.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; 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; + 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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 12269 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 12274 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 12280 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12291 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 12297 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 12317 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12323 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3984 "src/ocaml/preprocess/parser_raw.mly" - ("||") -# 11700 "src/ocaml/preprocess/parser_raw.ml" +# 3940 "src/ocaml/preprocess/parser_raw.mly" + ("+=") +# 12330 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11708 "src/ocaml/preprocess/parser_raw.ml" +# 12338 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11714 "src/ocaml/preprocess/parser_raw.ml" +# 12344 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11724 "src/ocaml/preprocess/parser_raw.ml" +# 12354 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11730 "src/ocaml/preprocess/parser_raw.ml" +# 12360 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11739,9 +12369,9 @@ module Tables = struct 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.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; @@ -11756,49 +12386,62 @@ module Tables = struct }; }; } = _menhir_stack in - let e2 : (Parsetree.expression) = Obj.magic e2 in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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 _endpos = _endpos__1_inlined1_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12403 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12408 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3985 "src/ocaml/preprocess/parser_raw.mly" - ("&") -# 11772 "src/ocaml/preprocess/parser_raw.ml" +# 3941 "src/ocaml/preprocess/parser_raw.mly" + ("-") +# 12415 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11780 "src/ocaml/preprocess/parser_raw.ml" +# 12423 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11786 "src/ocaml/preprocess/parser_raw.ml" +# 12429 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11796 "src/ocaml/preprocess/parser_raw.ml" +# 12439 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11802 "src/ocaml/preprocess/parser_raw.ml" +# 12445 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11811,66 +12454,152 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + MenhirLib.EngineTypes.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; 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; + 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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 12512 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 12517 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 12523 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12534 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 12540 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 12560 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12566 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3986 "src/ocaml/preprocess/parser_raw.mly" - ("&&") -# 11844 "src/ocaml/preprocess/parser_raw.ml" +# 3941 "src/ocaml/preprocess/parser_raw.mly" + ("-") +# 12573 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11852 "src/ocaml/preprocess/parser_raw.ml" +# 12581 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11858 "src/ocaml/preprocess/parser_raw.ml" +# 12587 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11868 "src/ocaml/preprocess/parser_raw.ml" +# 12597 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11874 "src/ocaml/preprocess/parser_raw.ml" +# 12603 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11883,9 +12612,9 @@ module Tables = struct 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.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; @@ -11900,49 +12629,62 @@ module Tables = struct }; }; } = _menhir_stack in - let e2 : (Parsetree.expression) = Obj.magic e2 in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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 _endpos = _endpos__1_inlined1_ in let _v : (Parsetree.expression) = let _1 = let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12646 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12651 "src/ocaml/preprocess/parser_raw.ml" + + in let op = let _1 = -# 3987 "src/ocaml/preprocess/parser_raw.mly" - (":=") -# 11916 "src/ocaml/preprocess/parser_raw.ml" +# 3942 "src/ocaml/preprocess/parser_raw.mly" + ("-.") +# 12658 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 11924 "src/ocaml/preprocess/parser_raw.ml" +# 12666 "src/ocaml/preprocess/parser_raw.ml" in -# 2623 "src/ocaml/preprocess/parser_raw.mly" +# 2588 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix e1 op e2 ) -# 11930 "src/ocaml/preprocess/parser_raw.ml" +# 12672 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_e2_, _startpos_e1_) in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11940 "src/ocaml/preprocess/parser_raw.ml" +# 12682 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11946 "src/ocaml/preprocess/parser_raw.ml" +# 12688 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -11955,45 +12697,152 @@ module Tables = struct 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.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; + 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 = _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 _2 : (Parsetree.expression) = Obj.magic _2 in - let _1 : (string) = Obj.magic _1 in + let xs : (Parsetree.case list) = Obj.magic xs 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 _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__1_ in - let _endpos = _endpos__2_ in + let _startpos = _startpos_e1_ in + let _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let _1 = - let _loc__1_ = (_startpos__1_, _endpos__1_) in + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 12755 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 12760 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 12766 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12777 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 12783 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 12803 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12809 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3942 "src/ocaml/preprocess/parser_raw.mly" + ("-.") +# 12816 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 12824 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2625 "src/ocaml/preprocess/parser_raw.mly" - ( mkuminus ~oploc:_loc__1_ _1 _2 ) -# 11981 "src/ocaml/preprocess/parser_raw.ml" +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 12830 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos__1_ = _endpos__2_ in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 11991 "src/ocaml/preprocess/parser_raw.ml" +# 12840 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 11997 "src/ocaml/preprocess/parser_raw.ml" +# 12846 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12006,45 +12855,79 @@ module Tables = struct 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.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.state = _; MenhirLib.EngineTypes.semv = _1; MenhirLib.EngineTypes.startp = _startpos__1_; MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 _2 : (Parsetree.expression) = Obj.magic _2 in - let _1 : (string) = Obj.magic _1 in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_ in - let _endpos = _endpos__2_ in + let _startpos = _startpos_e1_ in + let _endpos = _endpos__1_inlined1_ in let _v : (Parsetree.expression) = let _1 = let _1 = - let _loc__1_ = (_startpos__1_, _endpos__1_) in + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12889 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 12894 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3943 "src/ocaml/preprocess/parser_raw.mly" + ("*") +# 12901 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 12909 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2627 "src/ocaml/preprocess/parser_raw.mly" - ( mkuplus ~oploc:_loc__1_ _1 _2 ) -# 12032 "src/ocaml/preprocess/parser_raw.ml" +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 12915 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos__1_ = _endpos__2_ in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 12042 "src/ocaml/preprocess/parser_raw.ml" +# 12925 "src/ocaml/preprocess/parser_raw.ml" in -# 2541 "src/ocaml/preprocess/parser_raw.mly" +# 2506 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 12048 "src/ocaml/preprocess/parser_raw.ml" +# 12931 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12057,36 +12940,152 @@ module Tables = struct 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.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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 = _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 _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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__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 + let _startpos = _startpos_e1_ in + let _endpos = _endpos_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 12998 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13003 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13009 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13020 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 13026 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 13046 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13052 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3943 "src/ocaml/preprocess/parser_raw.mly" + ("*") +# 13059 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 13067 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 13073 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 13083 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2543 "src/ocaml/preprocess/parser_raw.mly" - ( expr_of_let_bindings ~loc:_sloc _1 (merloc _endpos__2_ _3) ) -# 12090 "src/ocaml/preprocess/parser_raw.ml" +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13089 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12099,62 +13098,79 @@ module Tables = struct 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.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.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; 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; - }; + 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 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 : ( -# 847 "src/ocaml/preprocess/parser_raw.mly" - (string) -# 12132 "src/ocaml/preprocess/parser_raw.ml" - ) = Obj.magic _1 in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_ in - let _endpos = _endpos_body_ in - let _v : (Parsetree.expression) = let pbop_op = + let _startpos = _startpos_e1_ in + let _endpos = _endpos__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13132 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13137 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3944 "src/ocaml/preprocess/parser_raw.mly" + ("%") +# 13144 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 13152 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 13158 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 12144 "src/ocaml/preprocess/parser_raw.ml" +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 13168 "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 -# 2545 "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}) ) -# 12158 "src/ocaml/preprocess/parser_raw.ml" +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13174 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12167,37 +13183,4060 @@ module Tables = struct 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.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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 = _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 _3 : (Parsetree.expression) = Obj.magic _3 in - let _2 : unit = Obj.magic _2 in - let _1 : (Parsetree.expression) = Obj.magic _1 in + let xs : (Parsetree.case list) = Obj.magic xs 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 _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__1_ in - let _endpos = _endpos__3_ in - let _v : (Parsetree.expression) = let _endpos = _endpos__3_ in + let _startpos = _startpos_e1_ in + let _endpos = _endpos_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 13241 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13246 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13252 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13263 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 13269 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 13289 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13295 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3944 "src/ocaml/preprocess/parser_raw.mly" + ("%") +# 13302 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 13310 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 13316 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 13326 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13332 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = e1; + MenhirLib.EngineTypes.startp = _startpos_e1_; + MenhirLib.EngineTypes.endp = _endpos_e1_; + MenhirLib.EngineTypes.next = _menhir_stack; + }; + }; + } = _menhir_stack in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13375 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13380 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3945 "src/ocaml/preprocess/parser_raw.mly" + ("=") +# 13387 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 13395 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 13401 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 13411 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13417 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 13484 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13489 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13495 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13506 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 13512 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 13532 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13538 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3945 "src/ocaml/preprocess/parser_raw.mly" + ("=") +# 13545 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 13553 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 13559 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 13569 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13575 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = e1; + MenhirLib.EngineTypes.startp = _startpos_e1_; + MenhirLib.EngineTypes.endp = _endpos_e1_; + MenhirLib.EngineTypes.next = _menhir_stack; + }; + }; + } = _menhir_stack in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13618 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13623 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3946 "src/ocaml/preprocess/parser_raw.mly" + ("<") +# 13630 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 13638 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 13644 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 13654 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13660 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 13727 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13732 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13738 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13749 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 13755 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 13775 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13781 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3946 "src/ocaml/preprocess/parser_raw.mly" + ("<") +# 13788 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 13796 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 13802 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 13812 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13818 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = e1; + MenhirLib.EngineTypes.startp = _startpos_e1_; + MenhirLib.EngineTypes.endp = _endpos_e1_; + MenhirLib.EngineTypes.next = _menhir_stack; + }; + }; + } = _menhir_stack in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13861 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13866 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3947 "src/ocaml/preprocess/parser_raw.mly" + (">") +# 13873 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 13881 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 13887 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 13897 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13903 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 13970 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13975 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 13981 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 13992 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 13998 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 14018 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14024 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3947 "src/ocaml/preprocess/parser_raw.mly" + (">") +# 14031 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 14039 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 14045 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 14055 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14061 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = e1; + MenhirLib.EngineTypes.startp = _startpos_e1_; + MenhirLib.EngineTypes.endp = _endpos_e1_; + MenhirLib.EngineTypes.next = _menhir_stack; + }; + }; + } = _menhir_stack in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14104 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14109 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3948 "src/ocaml/preprocess/parser_raw.mly" + ("or") +# 14116 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 14124 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 14130 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 14140 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14146 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 14213 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 14218 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 14224 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14235 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 14241 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 14261 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14267 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3948 "src/ocaml/preprocess/parser_raw.mly" + ("or") +# 14274 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 14282 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 14288 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 14298 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14304 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = e1; + MenhirLib.EngineTypes.startp = _startpos_e1_; + MenhirLib.EngineTypes.endp = _endpos_e1_; + MenhirLib.EngineTypes.next = _menhir_stack; + }; + }; + } = _menhir_stack in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14347 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14352 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3949 "src/ocaml/preprocess/parser_raw.mly" + ("||") +# 14359 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 14367 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 14373 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 14383 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14389 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 14456 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 14461 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 14467 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14478 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 14484 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 14504 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14510 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3949 "src/ocaml/preprocess/parser_raw.mly" + ("||") +# 14517 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 14525 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 14531 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 14541 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14547 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = e1; + MenhirLib.EngineTypes.startp = _startpos_e1_; + MenhirLib.EngineTypes.endp = _endpos_e1_; + MenhirLib.EngineTypes.next = _menhir_stack; + }; + }; + } = _menhir_stack in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14590 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14595 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3950 "src/ocaml/preprocess/parser_raw.mly" + ("&") +# 14602 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 14610 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 14616 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 14626 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14632 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 14699 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 14704 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 14710 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14721 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 14727 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 14747 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14753 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3950 "src/ocaml/preprocess/parser_raw.mly" + ("&") +# 14760 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 14768 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 14774 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 14784 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14790 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = e1; + MenhirLib.EngineTypes.startp = _startpos_e1_; + MenhirLib.EngineTypes.endp = _endpos_e1_; + MenhirLib.EngineTypes.next = _menhir_stack; + }; + }; + } = _menhir_stack in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14833 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14838 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3951 "src/ocaml/preprocess/parser_raw.mly" + ("&&") +# 14845 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 14853 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 14859 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 14869 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14875 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 14942 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 14947 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 14953 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14964 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 14970 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 14990 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 14996 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3951 "src/ocaml/preprocess/parser_raw.mly" + ("&&") +# 15003 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 15011 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 15017 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 15027 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15033 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = e1; + MenhirLib.EngineTypes.startp = _startpos_e1_; + MenhirLib.EngineTypes.endp = _endpos_e1_; + MenhirLib.EngineTypes.next = _menhir_stack; + }; + }; + } = _menhir_stack in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15076 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15081 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3952 "src/ocaml/preprocess/parser_raw.mly" + (":=") +# 15088 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 15096 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 15102 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 15112 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15118 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let _1 = + let e2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 15185 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 15190 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 15196 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15207 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 15213 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 15233 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15239 "src/ocaml/preprocess/parser_raw.ml" + + in + let op = + let _1 = +# 3952 "src/ocaml/preprocess/parser_raw.mly" + (":=") +# 15246 "src/ocaml/preprocess/parser_raw.ml" + in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1054 "src/ocaml/preprocess/parser_raw.mly" + ( mkoperator ~loc:_sloc _1 ) +# 15254 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2588 "src/ocaml/preprocess/parser_raw.mly" + ( mkinfix e1 op e2 ) +# 15260 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_e1_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 15270 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15276 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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.expression) = 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.expression) = let _1 = + let _1 = + let _2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15312 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15317 "src/ocaml/preprocess/parser_raw.ml" + + in + let _loc__1_ = (_startpos__1_, _endpos__1_) in + +# 2590 "src/ocaml/preprocess/parser_raw.mly" + ( mkuminus ~oploc:_loc__1_ _1 _2 ) +# 15324 "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 + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 15334 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15340 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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_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 _1 : (string) = 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 (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 15400 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 15405 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 15411 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15422 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 15428 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 15448 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15454 "src/ocaml/preprocess/parser_raw.ml" + + in + let _loc__1_ = (_startpos__1_, _endpos__1_) in + +# 2590 "src/ocaml/preprocess/parser_raw.mly" + ( mkuminus ~oploc:_loc__1_ _1 _2 ) +# 15461 "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 + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 15471 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15477 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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.expression) = 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.expression) = let _1 = + let _1 = + let _2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15513 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15518 "src/ocaml/preprocess/parser_raw.ml" + + in + let _loc__1_ = (_startpos__1_, _endpos__1_) in + +# 2592 "src/ocaml/preprocess/parser_raw.mly" + ( mkuplus ~oploc:_loc__1_ _1 _2 ) +# 15525 "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 + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 15535 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15541 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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_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 _1 : (string) = 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 (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 15601 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 15606 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 15612 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15623 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 15629 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 15649 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15655 "src/ocaml/preprocess/parser_raw.ml" + + in + let _loc__1_ = (_startpos__1_, _endpos__1_) in + +# 2592 "src/ocaml/preprocess/parser_raw.mly" + ( mkuplus ~oploc:_loc__1_ _1 _2 ) +# 15662 "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 + +# 1060 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc _1 ) +# 15672 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2506 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15678 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 + +# 2508 "src/ocaml/preprocess/parser_raw.mly" + ( expr_of_let_bindings ~loc:_sloc _1 (merloc _endpos__2_ _3) ) +# 15720 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 : ( +# 820 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 15762 "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 + +# 1027 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 15774 "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 + +# 2510 "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}) ) +# 15788 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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.expression) = 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 _3 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15829 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15834 "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 _loc__2_ = (_startpos__2_, _endpos__2_) in + let _sloc = (_symbolstartpos, _endpos) in + +# 2516 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp_cons ~loc:_sloc _loc__2_ (ghexp ~loc:_sloc (Pexp_tuple[_1;(merloc _endpos__2_ _3)])) ) +# 15845 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 : (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 _3 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 15910 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 15915 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 15921 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15932 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 15938 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 15958 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 15964 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _loc__2_ = (_startpos__2_, _endpos__2_) in + let _sloc = (_symbolstartpos, _endpos) in + +# 2516 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp_cons ~loc:_sloc _loc__2_ (ghexp ~loc:_sloc (Pexp_tuple[_1;(merloc _endpos__2_ _3)])) ) +# 15975 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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.expression) = Obj.magic _1_inlined1 in + let _2 : unit = Obj.magic _2 in + let _1 : ( +# 838 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 16010 "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_inlined1_ in + let _v : (Parsetree.expression) = let _3 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16020 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16025 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos__1_inlined1_ in + let _1 = + let _1 = +# 3881 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16033 "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" + ( mkrhs _1 _sloc ) +# 16041 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2518 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc (Pexp_setinstvar(_1, _3)) ) +# 16050 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 : ( +# 838 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 16106 "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 : (Parsetree.expression) = let _3 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 16119 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 16124 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 16130 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16141 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 16147 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 16167 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16173 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _1 = + let _1 = +# 3881 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16181 "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" + ( mkrhs _1 _sloc ) +# 16189 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2518 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc (Pexp_setinstvar(_1, _3)) ) +# 16198 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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.expression) = Obj.magic _1_inlined2 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__1_inlined2_ in + let _v : (Parsetree.expression) = let _5 = + let _1 = _1_inlined2 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16253 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16258 "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 + +# 1027 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 16270 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__5_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2520 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc (Pexp_setfield(_1, _3, _5)) ) +# 16279 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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.case list) = Obj.magic xs in + let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in + let _1_inlined3 : (string Location.loc option) = Obj.magic _1_inlined3 in + let _1_inlined2 : unit = Obj.magic _1_inlined2 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_xs_ in + let _v : (Parsetree.expression) = let _5 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined2_, _1_inlined4, _1_inlined3, _1_inlined2) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 16358 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 16363 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 16369 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16380 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 16386 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 16406 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16412 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__5_ = _endpos_xs_ 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 + +# 1027 "src/ocaml/preprocess/parser_raw.mly" + ( mkrhs _1 _sloc ) +# 16424 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__5_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2520 "src/ocaml/preprocess/parser_raw.mly" + ( mkexp ~loc:_sloc (Pexp_setfield(_1, _3, _5)) ) +# 16433 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _; + 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 _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let r = + let v = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16504 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16509 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2521 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 16515 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2481 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Paren, i, r ) +# 16521 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_array_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2522 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) +# 16531 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let r = + let v = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 16626 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 16631 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 16637 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16648 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 16654 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 16674 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16680 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2521 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 16686 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2481 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Paren, i, r ) +# 16692 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_array_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2522 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) +# 16702 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _; + 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 _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let r = + let v = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16773 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16778 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2521 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 16784 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2483 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Brace, i, r ) +# 16790 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_array_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2522 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) +# 16800 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let r = + let v = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 16895 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 16900 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 16906 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16917 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 16923 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 16943 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 16949 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2521 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 16955 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2483 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Brace, i, r ) +# 16961 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_array_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2522 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) +# 16971 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _; + 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 _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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__1_inlined1_ in + let _v : (Parsetree.expression) = let _1 = + let r = + let v = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17042 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17047 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2521 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 17053 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2485 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Bracket, i, r ) +# 17059 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_array_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2522 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) +# 17069 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let r = + let v = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 17164 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 17169 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 17175 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17186 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 17192 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 17212 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17218 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2521 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 17224 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2485 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Bracket, i, r ) +# 17230 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_array_) in + let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in - let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 2551 "src/ocaml/preprocess/parser_raw.mly" - ( mkexp_cons ~loc:_sloc _loc__2_ (ghexp ~loc:_sloc (Pexp_tuple[_1;(merloc _endpos__2_ _3)])) ) -# 12201 "src/ocaml/preprocess/parser_raw.ml" +# 2522 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) +# 17240 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12210,55 +17249,113 @@ module Tables = struct 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.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.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 _3 : (Parsetree.expression) = Obj.magic _3 in - let _2 : unit = Obj.magic _2 in - let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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 : ( +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12236 "src/ocaml/preprocess/parser_raw.ml" - ) = Obj.magic _1 in +# 17302 "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__1_ in - let _endpos = _endpos__3_ in + let _startpos = _startpos_array_ in + let _endpos = _endpos__1_inlined1_ in let _v : (Parsetree.expression) = let _1 = - let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 12245 "src/ocaml/preprocess/parser_raw.ml" + let r = + let v = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17315 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17320 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2523 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 17326 "src/ocaml/preprocess/parser_raw.ml" + + in + let i = +# 2986 "src/ocaml/preprocess/parser_raw.mly" + ( es ) +# 17332 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__1_ in - let _symbolstartpos = _startpos__1_ in - let _sloc = (_symbolstartpos, _endpos) in + let d = + let _1 = +# 124 "" + ( None ) +# 17338 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2497 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 17343 "src/ocaml/preprocess/parser_raw.ml" + + in -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 12253 "src/ocaml/preprocess/parser_raw.ml" +# 2481 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Paren, i, r ) +# 17349 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__3_ in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_array_) in + let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2553 "src/ocaml/preprocess/parser_raw.mly" - ( mkexp ~loc:_sloc (Pexp_setinstvar(_1, _3)) ) -# 12262 "src/ocaml/preprocess/parser_raw.ml" +# 2524 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) +# 17359 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12271,61 +17368,186 @@ module Tables = struct 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.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.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_inlined1; - MenhirLib.EngineTypes.startp = _startpos__1_inlined1_; - MenhirLib.EngineTypes.endp = _endpos__1_inlined1_; + 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.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.state = _; MenhirLib.EngineTypes.semv = _1; MenhirLib.EngineTypes.startp = _startpos__1_; MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 _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 xs : (Parsetree.case list) = Obj.magic xs 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 _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 : ( +# 819 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 17442 "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__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 + let _startpos = _startpos_array_ in + let _endpos = _endpos_xs_ in + let _v : (Parsetree.expression) = let _1 = + let r = + let v = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 17458 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 17463 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 17469 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17480 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 17486 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 17506 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17512 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2523 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 17518 "src/ocaml/preprocess/parser_raw.ml" + + in + let i = +# 2986 "src/ocaml/preprocess/parser_raw.mly" + ( es ) +# 17524 "src/ocaml/preprocess/parser_raw.ml" + in + let d = + let _1 = +# 124 "" + ( None ) +# 17530 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2497 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 17535 "src/ocaml/preprocess/parser_raw.ml" + + in -# 1062 "src/ocaml/preprocess/parser_raw.mly" - ( mkrhs _1 _sloc ) -# 12320 "src/ocaml/preprocess/parser_raw.ml" +# 2481 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Paren, i, r ) +# 17541 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos = _endpos__5_ in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_array_) in + let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2555 "src/ocaml/preprocess/parser_raw.mly" - ( mkexp ~loc:_sloc (Pexp_setfield(_1, _3, _5)) ) -# 12329 "src/ocaml/preprocess/parser_raw.ml" +# 2524 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) +# 17551 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12338,14 +17560,14 @@ module Tables = struct 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.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; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + 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; @@ -12353,9 +17575,9 @@ module Tables = struct 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.semv = es; + MenhirLib.EngineTypes.startp = _startpos_es_; + MenhirLib.EngineTypes.endp = _endpos_es_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _3; @@ -12363,15 +17585,27 @@ module Tables = struct 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.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; + 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; + }; + }; }; }; }; @@ -12379,36 +17613,83 @@ module Tables = struct }; }; } = _menhir_stack in - let v : (Parsetree.expression) = Obj.magic v in - let _1 : unit = Obj.magic _1 in + let _1_inlined2 : (Parsetree.expression) = Obj.magic _1_inlined2 in + let _1_inlined1 : unit = Obj.magic _1_inlined1 in let _5 : unit = Obj.magic _5 in - let i : (Parsetree.expression) = Obj.magic i in + let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in - let d : unit = Obj.magic d in + let _2 : ( +# 819 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 17625 "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 _endpos = _endpos__1_inlined2_ in let _v : (Parsetree.expression) = let _1 = - let r = -# 2556 "src/ocaml/preprocess/parser_raw.mly" - (Some v) -# 12397 "src/ocaml/preprocess/parser_raw.ml" + let r = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let v = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17641 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17646 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2523 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 17652 "src/ocaml/preprocess/parser_raw.ml" + + in + let i = +# 2986 "src/ocaml/preprocess/parser_raw.mly" + ( es ) +# 17658 "src/ocaml/preprocess/parser_raw.ml" in + let d = + let _1 = + let _2 = _2_inlined1 in + let x = +# 2497 "src/ocaml/preprocess/parser_raw.mly" + (_2) +# 17666 "src/ocaml/preprocess/parser_raw.ml" + in + +# 126 "" + ( Some x ) +# 17671 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2497 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 17677 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2516 "src/ocaml/preprocess/parser_raw.mly" +# 2481 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 12402 "src/ocaml/preprocess/parser_raw.ml" +# 17683 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos_array_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2557 "src/ocaml/preprocess/parser_raw.mly" - ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 12412 "src/ocaml/preprocess/parser_raw.ml" +# 2524 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) +# 17693 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12421,40 +17702,70 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + 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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = i; - MenhirLib.EngineTypes.startp = _startpos_i_; - MenhirLib.EngineTypes.endp = _endpos_i_; + 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.semv = _1_inlined1; + MenhirLib.EngineTypes.startp = _startpos__1_inlined1_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined1_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = d; - MenhirLib.EngineTypes.startp = _startpos_d_; - MenhirLib.EngineTypes.endp = _endpos_d_; + MenhirLib.EngineTypes.semv = _5; + MenhirLib.EngineTypes.startp = _startpos__5_; + MenhirLib.EngineTypes.endp = _endpos__5_; 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; + 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; + }; + }; + }; + }; + }; }; }; }; @@ -12462,36 +17773,138 @@ module Tables = struct }; }; } = _menhir_stack in - let v : (Parsetree.expression) = Obj.magic v in - let _1 : unit = Obj.magic _1 in + let xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in + let _1_inlined3 : (string Location.loc option) = Obj.magic _1_inlined3 in + let _1_inlined2 : unit = Obj.magic _1_inlined2 in + let _1_inlined1 : unit = Obj.magic _1_inlined1 in let _5 : unit = Obj.magic _5 in - let i : (Parsetree.expression) = Obj.magic i in + let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in - let d : unit = Obj.magic d in + let _2 : ( +# 819 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 17788 "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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = - let r = -# 2556 "src/ocaml/preprocess/parser_raw.mly" - (Some v) -# 12480 "src/ocaml/preprocess/parser_raw.ml" + let r = + let (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined2_, _1_inlined4, _1_inlined3, _1_inlined2, _1_inlined1) in + let v = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 17807 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 17812 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 17818 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17829 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 17835 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 17855 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17861 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2523 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 17867 "src/ocaml/preprocess/parser_raw.ml" + + in + let i = +# 2986 "src/ocaml/preprocess/parser_raw.mly" + ( es ) +# 17873 "src/ocaml/preprocess/parser_raw.ml" in + let d = + let _1 = + let _2 = _2_inlined1 in + let x = +# 2497 "src/ocaml/preprocess/parser_raw.mly" + (_2) +# 17881 "src/ocaml/preprocess/parser_raw.ml" + in + +# 126 "" + ( Some x ) +# 17886 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2497 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 17892 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2518 "src/ocaml/preprocess/parser_raw.mly" - ( array, d, Brace, i, r ) -# 12485 "src/ocaml/preprocess/parser_raw.ml" +# 2481 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Paren, i, r ) +# 17898 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_array_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2557 "src/ocaml/preprocess/parser_raw.mly" - ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 12495 "src/ocaml/preprocess/parser_raw.ml" +# 2524 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) +# 17908 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12504,9 +17917,9 @@ module Tables = struct 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.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; @@ -12519,9 +17932,9 @@ module Tables = struct 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.semv = es; + MenhirLib.EngineTypes.startp = _startpos_es_; + MenhirLib.EngineTypes.endp = _endpos_es_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _3; @@ -12529,9 +17942,9 @@ module Tables = struct 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.semv = _2; + MenhirLib.EngineTypes.startp = _startpos__2_; + MenhirLib.EngineTypes.endp = _endpos__2_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _menhir_s; MenhirLib.EngineTypes.semv = array; @@ -12545,36 +17958,72 @@ module Tables = struct }; }; } = _menhir_stack in - let v : (Parsetree.expression) = Obj.magic v in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 in let _1 : unit = Obj.magic _1 in let _5 : unit = Obj.magic _5 in - let i : (Parsetree.expression) = Obj.magic i in + let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in - let d : unit = Obj.magic d in + let _2 : ( +# 819 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 17970 "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 _endpos = _endpos__1_inlined1_ in let _v : (Parsetree.expression) = let _1 = - let r = -# 2556 "src/ocaml/preprocess/parser_raw.mly" - (Some v) -# 12563 "src/ocaml/preprocess/parser_raw.ml" + let r = + let v = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17983 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 17988 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2523 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 17994 "src/ocaml/preprocess/parser_raw.ml" + + in + let i = +# 2986 "src/ocaml/preprocess/parser_raw.mly" + ( es ) +# 18000 "src/ocaml/preprocess/parser_raw.ml" in + let d = + let _1 = +# 124 "" + ( None ) +# 18006 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2497 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 18011 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2520 "src/ocaml/preprocess/parser_raw.mly" - ( array, d, Bracket, i, r ) -# 12568 "src/ocaml/preprocess/parser_raw.ml" +# 2483 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Brace, i, r ) +# 18017 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_array_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2557 "src/ocaml/preprocess/parser_raw.mly" - ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 12578 "src/ocaml/preprocess/parser_raw.ml" +# 2524 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) +# 18027 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12587,40 +18036,58 @@ module Tables = struct 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.semv = xs; + MenhirLib.EngineTypes.startp = _startpos_xs_; + MenhirLib.EngineTypes.endp = _endpos_xs_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + 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.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = es; - MenhirLib.EngineTypes.startp = _startpos_es_; - MenhirLib.EngineTypes.endp = _endpos_es_; + 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.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.semv = _5; + MenhirLib.EngineTypes.startp = _startpos__5_; + MenhirLib.EngineTypes.endp = _endpos__5_; 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; + 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; + }; + }; + }; }; }; }; @@ -12628,57 +18095,127 @@ module Tables = struct }; }; } = _menhir_stack in - let v : (Parsetree.expression) = Obj.magic v in + let xs : (Parsetree.case list) = Obj.magic xs 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 _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 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12640 "src/ocaml/preprocess/parser_raw.ml" +# 18110 "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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = - let r = -# 2558 "src/ocaml/preprocess/parser_raw.mly" + let r = + let v = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 18126 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 18131 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 18137 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18148 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 18154 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 18174 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18180 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2523 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12650 "src/ocaml/preprocess/parser_raw.ml" - in +# 18186 "src/ocaml/preprocess/parser_raw.ml" + + in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12655 "src/ocaml/preprocess/parser_raw.ml" +# 18192 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12661 "src/ocaml/preprocess/parser_raw.ml" +# 18198 "src/ocaml/preprocess/parser_raw.ml" in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12666 "src/ocaml/preprocess/parser_raw.ml" +# 18203 "src/ocaml/preprocess/parser_raw.ml" in -# 2516 "src/ocaml/preprocess/parser_raw.mly" - ( array, d, Paren, i, r ) -# 12672 "src/ocaml/preprocess/parser_raw.ml" +# 2483 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Brace, i, r ) +# 18209 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_array_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2559 "src/ocaml/preprocess/parser_raw.mly" +# 2524 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12682 "src/ocaml/preprocess/parser_raw.ml" +# 18219 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12691,9 +18228,9 @@ module Tables = struct 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.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; @@ -12744,70 +18281,298 @@ module Tables = struct }; }; } = _menhir_stack in - let v : (Parsetree.expression) = Obj.magic v in + let _1_inlined2 : (Parsetree.expression) = Obj.magic _1_inlined2 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 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12756 "src/ocaml/preprocess/parser_raw.ml" +# 18293 "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 _endpos = _endpos__1_inlined2_ in let _v : (Parsetree.expression) = let _1 = let r = - let _1 = _1_inlined1 in + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let v = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18309 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18314 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2558 "src/ocaml/preprocess/parser_raw.mly" +# 2523 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12770 "src/ocaml/preprocess/parser_raw.ml" +# 18320 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12776 "src/ocaml/preprocess/parser_raw.ml" +# 18326 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 12784 "src/ocaml/preprocess/parser_raw.ml" +# 18334 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 12789 "src/ocaml/preprocess/parser_raw.ml" +# 18339 "src/ocaml/preprocess/parser_raw.ml" in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12795 "src/ocaml/preprocess/parser_raw.ml" +# 18345 "src/ocaml/preprocess/parser_raw.ml" in -# 2516 "src/ocaml/preprocess/parser_raw.mly" - ( array, d, Paren, i, r ) -# 12801 "src/ocaml/preprocess/parser_raw.ml" +# 2483 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Brace, i, r ) +# 18351 "src/ocaml/preprocess/parser_raw.ml" + + in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos_array_) in + let _endpos = _endpos__1_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2524 "src/ocaml/preprocess/parser_raw.mly" + ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) +# 18361 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in + let _1_inlined3 : (string Location.loc option) = Obj.magic _1_inlined3 in + let _1_inlined2 : unit = Obj.magic _1_inlined2 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 : ( +# 819 "src/ocaml/preprocess/parser_raw.mly" + (string) +# 18456 "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_xs_ in + let _v : (Parsetree.expression) = let _1 = + let r = + let (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined2_, _1_inlined4, _1_inlined3, _1_inlined2, _1_inlined1) in + let v = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 18475 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 18480 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 18486 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18497 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 18503 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 18523 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18529 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2523 "src/ocaml/preprocess/parser_raw.mly" + (Some v) +# 18535 "src/ocaml/preprocess/parser_raw.ml" + + in + let i = +# 2986 "src/ocaml/preprocess/parser_raw.mly" + ( es ) +# 18541 "src/ocaml/preprocess/parser_raw.ml" + in + let d = + let _1 = + let _2 = _2_inlined1 in + let x = +# 2497 "src/ocaml/preprocess/parser_raw.mly" + (_2) +# 18549 "src/ocaml/preprocess/parser_raw.ml" + in + +# 126 "" + ( Some x ) +# 18554 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2497 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 18560 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2483 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Brace, i, r ) +# 18566 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_array_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2559 "src/ocaml/preprocess/parser_raw.mly" +# 2524 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12811 "src/ocaml/preprocess/parser_raw.ml" +# 18576 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12820,9 +18585,9 @@ module Tables = struct 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.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; @@ -12861,57 +18626,72 @@ module Tables = struct }; }; } = _menhir_stack in - let v : (Parsetree.expression) = Obj.magic v in + let _1_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 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 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12873 "src/ocaml/preprocess/parser_raw.ml" +# 18638 "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 _endpos = _endpos__1_inlined1_ in let _v : (Parsetree.expression) = let _1 = - let r = -# 2558 "src/ocaml/preprocess/parser_raw.mly" + let r = + let v = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18651 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18656 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2523 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 12883 "src/ocaml/preprocess/parser_raw.ml" - in +# 18662 "src/ocaml/preprocess/parser_raw.ml" + + in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 12888 "src/ocaml/preprocess/parser_raw.ml" +# 18668 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 12894 "src/ocaml/preprocess/parser_raw.ml" +# 18674 "src/ocaml/preprocess/parser_raw.ml" in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 12899 "src/ocaml/preprocess/parser_raw.ml" +# 18679 "src/ocaml/preprocess/parser_raw.ml" in -# 2518 "src/ocaml/preprocess/parser_raw.mly" - ( array, d, Brace, i, r ) -# 12905 "src/ocaml/preprocess/parser_raw.ml" +# 2485 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Bracket, i, r ) +# 18685 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined1_, _startpos_array_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2559 "src/ocaml/preprocess/parser_raw.mly" +# 2524 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 12915 "src/ocaml/preprocess/parser_raw.ml" +# 18695 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -12924,50 +18704,56 @@ module Tables = struct 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.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.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.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = es; - MenhirLib.EngineTypes.startp = _startpos_es_; - MenhirLib.EngineTypes.endp = _endpos_es_; + 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.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.semv = _5; + MenhirLib.EngineTypes.startp = _startpos__5_; + MenhirLib.EngineTypes.endp = _endpos__5_; 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.semv = es; + MenhirLib.EngineTypes.startp = _startpos_es_; + MenhirLib.EngineTypes.endp = _endpos_es_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + 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 = array; - MenhirLib.EngineTypes.startp = _startpos_array_; - MenhirLib.EngineTypes.endp = _endpos_array_; - MenhirLib.EngineTypes.next = _menhir_stack; + MenhirLib.EngineTypes.state = _; + MenhirLib.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; + }; }; }; }; @@ -12977,70 +18763,127 @@ module Tables = struct }; }; } = _menhir_stack in - let v : (Parsetree.expression) = Obj.magic v in + let xs : (Parsetree.case list) = Obj.magic xs 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 _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 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 12989 "src/ocaml/preprocess/parser_raw.ml" +# 18778 "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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let r = - let _1 = _1_inlined1 in + let v = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 18794 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 18799 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 18805 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18816 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 18822 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 18842 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18848 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2558 "src/ocaml/preprocess/parser_raw.mly" +# 2523 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 13003 "src/ocaml/preprocess/parser_raw.ml" +# 18854 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 13009 "src/ocaml/preprocess/parser_raw.ml" +# 18860 "src/ocaml/preprocess/parser_raw.ml" in let d = - let _1 = - let _2 = _2_inlined1 in - let x = -# 2532 "src/ocaml/preprocess/parser_raw.mly" - (_2) -# 13017 "src/ocaml/preprocess/parser_raw.ml" - in - -# 126 "" - ( Some x ) -# 13022 "src/ocaml/preprocess/parser_raw.ml" - - in + let _1 = +# 124 "" + ( None ) +# 18866 "src/ocaml/preprocess/parser_raw.ml" + in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 13028 "src/ocaml/preprocess/parser_raw.ml" +# 18871 "src/ocaml/preprocess/parser_raw.ml" in -# 2518 "src/ocaml/preprocess/parser_raw.mly" - ( array, d, Brace, i, r ) -# 13034 "src/ocaml/preprocess/parser_raw.ml" +# 2485 "src/ocaml/preprocess/parser_raw.mly" + ( array, d, Bracket, i, r ) +# 18877 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_array_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2559 "src/ocaml/preprocess/parser_raw.mly" +# 2524 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 13044 "src/ocaml/preprocess/parser_raw.ml" +# 18887 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13053,14 +18896,14 @@ module Tables = struct 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.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; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + 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; @@ -13082,11 +18925,23 @@ module Tables = struct 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; + 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; + }; + }; }; }; }; @@ -13094,57 +18949,83 @@ module Tables = struct }; }; } = _menhir_stack in - let v : (Parsetree.expression) = Obj.magic v in - let _1 : unit = Obj.magic _1 in + let _1_inlined2 : (Parsetree.expression) = Obj.magic _1_inlined2 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 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 13106 "src/ocaml/preprocess/parser_raw.ml" +# 18961 "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 _endpos = _endpos__1_inlined2_ in let _v : (Parsetree.expression) = let _1 = - let r = -# 2558 "src/ocaml/preprocess/parser_raw.mly" + let r = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let v = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18977 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 18982 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2523 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 13116 "src/ocaml/preprocess/parser_raw.ml" - in +# 18988 "src/ocaml/preprocess/parser_raw.ml" + + in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 13121 "src/ocaml/preprocess/parser_raw.ml" +# 18994 "src/ocaml/preprocess/parser_raw.ml" in let d = - let _1 = -# 124 "" - ( None ) -# 13127 "src/ocaml/preprocess/parser_raw.ml" - in + let _1 = + let _2 = _2_inlined1 in + let x = +# 2497 "src/ocaml/preprocess/parser_raw.mly" + (_2) +# 19002 "src/ocaml/preprocess/parser_raw.ml" + in + +# 126 "" + ( Some x ) +# 19007 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 13132 "src/ocaml/preprocess/parser_raw.ml" +# 19013 "src/ocaml/preprocess/parser_raw.ml" in -# 2520 "src/ocaml/preprocess/parser_raw.mly" +# 2485 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 13138 "src/ocaml/preprocess/parser_raw.ml" +# 19019 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in + let (_endpos__1_, _startpos__1_) = (_endpos__1_inlined2_, _startpos_array_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2559 "src/ocaml/preprocess/parser_raw.mly" +# 2524 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 13148 "src/ocaml/preprocess/parser_raw.ml" +# 19029 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13157,50 +19038,68 @@ module Tables = struct 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.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.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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = es; - MenhirLib.EngineTypes.startp = _startpos_es_; - MenhirLib.EngineTypes.endp = _endpos_es_; + 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.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.semv = _5; + MenhirLib.EngineTypes.startp = _startpos__5_; + MenhirLib.EngineTypes.endp = _endpos__5_; 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.semv = es; + MenhirLib.EngineTypes.startp = _startpos_es_; + MenhirLib.EngineTypes.endp = _endpos_es_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; + 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 = array; - MenhirLib.EngineTypes.startp = _startpos_array_; - MenhirLib.EngineTypes.endp = _endpos_array_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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; + }; + }; + }; }; }; }; @@ -13210,70 +19109,138 @@ module Tables = struct }; }; } = _menhir_stack in - let v : (Parsetree.expression) = Obj.magic v in + let xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in + let _1_inlined3 : (string Location.loc option) = Obj.magic _1_inlined3 in + let _1_inlined2 : unit = Obj.magic _1_inlined2 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 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 13222 "src/ocaml/preprocess/parser_raw.ml" +# 19124 "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 _endpos = _endpos_xs_ in let _v : (Parsetree.expression) = let _1 = let r = - let _1 = _1_inlined1 in + let (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined2_, _1_inlined4, _1_inlined3, _1_inlined2, _1_inlined1) in + let v = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 19143 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 19148 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 19154 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 19165 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 19171 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 19191 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 19197 "src/ocaml/preprocess/parser_raw.ml" + + in -# 2558 "src/ocaml/preprocess/parser_raw.mly" +# 2523 "src/ocaml/preprocess/parser_raw.mly" (Some v) -# 13236 "src/ocaml/preprocess/parser_raw.ml" +# 19203 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 13242 "src/ocaml/preprocess/parser_raw.ml" +# 19209 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 13250 "src/ocaml/preprocess/parser_raw.ml" +# 19217 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 13255 "src/ocaml/preprocess/parser_raw.ml" +# 19222 "src/ocaml/preprocess/parser_raw.ml" in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 13261 "src/ocaml/preprocess/parser_raw.ml" +# 19228 "src/ocaml/preprocess/parser_raw.ml" in -# 2520 "src/ocaml/preprocess/parser_raw.mly" +# 2485 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 13267 "src/ocaml/preprocess/parser_raw.ml" +# 19234 "src/ocaml/preprocess/parser_raw.ml" in - let (_endpos__1_, _startpos__1_) = (_endpos_v_, _startpos_array_) in + let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_array_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2559 "src/ocaml/preprocess/parser_raw.mly" +# 2524 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 13277 "src/ocaml/preprocess/parser_raw.ml" +# 19244 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13303,9 +19270,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2561 "src/ocaml/preprocess/parser_raw.mly" +# 2526 "src/ocaml/preprocess/parser_raw.mly" ( Exp.attr _1 _2 ) -# 13309 "src/ocaml/preprocess/parser_raw.ml" +# 19276 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13349,15 +19316,15 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.function_param list) = let ty_params = -# 2809 "src/ocaml/preprocess/parser_raw.mly" +# 2774 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13355 "src/ocaml/preprocess/parser_raw.ml" +# 19322 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2958 "src/ocaml/preprocess/parser_raw.mly" +# 2923 "src/ocaml/preprocess/parser_raw.mly" ( (* We desugar (type a b c) to (type a) (type b) (type c). If we do this desugaring, the loc for each parameter is a ghost. *) @@ -13371,7 +19338,7 @@ module Tables = struct (fun x -> { pparam_loc = loc; pparam_desc = Pparam_newtype x }) ty_params ) -# 13375 "src/ocaml/preprocess/parser_raw.ml" +# 19342 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13397,11 +19364,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2972 "src/ocaml/preprocess/parser_raw.mly" +# 2937 "src/ocaml/preprocess/parser_raw.mly" ( let a, b, c = _1 in [ { pparam_loc = make_loc _sloc; pparam_desc = Pparam_val (a, b, c) } ] ) -# 13405 "src/ocaml/preprocess/parser_raw.ml" +# 19372 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13427,18 +19394,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 13431 "src/ocaml/preprocess/parser_raw.ml" +# 19398 "src/ocaml/preprocess/parser_raw.ml" in -# 1185 "src/ocaml/preprocess/parser_raw.mly" +# 1150 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 13436 "src/ocaml/preprocess/parser_raw.ml" +# 19403 "src/ocaml/preprocess/parser_raw.ml" in -# 2977 "src/ocaml/preprocess/parser_raw.mly" +# 2942 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13442 "src/ocaml/preprocess/parser_raw.ml" +# 19409 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13461,9 +19428,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = -# 2451 "src/ocaml/preprocess/parser_raw.mly" +# 2416 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13467 "src/ocaml/preprocess/parser_raw.ml" +# 19434 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13493,9 +19460,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2452 "src/ocaml/preprocess/parser_raw.mly" +# 2417 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13499 "src/ocaml/preprocess/parser_raw.ml" +# 19466 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13533,24 +19500,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2454 "src/ocaml/preprocess/parser_raw.mly" +# 2419 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_sequence(_1, _3) ) -# 13539 "src/ocaml/preprocess/parser_raw.ml" +# 19506 "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 -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 13548 "src/ocaml/preprocess/parser_raw.ml" +# 19515 "src/ocaml/preprocess/parser_raw.ml" in -# 2455 "src/ocaml/preprocess/parser_raw.mly" +# 2420 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13554 "src/ocaml/preprocess/parser_raw.ml" +# 19521 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13604,11 +19571,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2457 "src/ocaml/preprocess/parser_raw.mly" +# 2422 "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)) ) -# 13612 "src/ocaml/preprocess/parser_raw.ml" +# 19579 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13631,9 +19598,9 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.core_type) = -# 3682 "src/ocaml/preprocess/parser_raw.mly" +# 3647 "src/ocaml/preprocess/parser_raw.mly" ( ty ) -# 13637 "src/ocaml/preprocess/parser_raw.ml" +# 19604 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13679,19 +19646,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 1060 "src/ocaml/preprocess/parser_raw.mly" +# 1025 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13685 "src/ocaml/preprocess/parser_raw.ml" +# 19652 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3694 "src/ocaml/preprocess/parser_raw.mly" +# 3659 "src/ocaml/preprocess/parser_raw.mly" ( Optional label ) -# 13690 "src/ocaml/preprocess/parser_raw.ml" +# 19657 "src/ocaml/preprocess/parser_raw.ml" in -# 3688 "src/ocaml/preprocess/parser_raw.mly" +# 3653 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13695 "src/ocaml/preprocess/parser_raw.ml" +# 19662 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13699,15 +19666,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13705 "src/ocaml/preprocess/parser_raw.ml" +# 19672 "src/ocaml/preprocess/parser_raw.ml" in -# 3690 "src/ocaml/preprocess/parser_raw.mly" +# 3655 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13711 "src/ocaml/preprocess/parser_raw.ml" +# 19678 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13754,9 +19721,9 @@ module Tables = struct let _1 : (Parsetree.core_type) = Obj.magic _1 in let _2 : unit = Obj.magic _2 in let label : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 13760 "src/ocaml/preprocess/parser_raw.ml" +# 19727 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos_label_ in @@ -13764,19 +19731,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 1060 "src/ocaml/preprocess/parser_raw.mly" +# 1025 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13770 "src/ocaml/preprocess/parser_raw.ml" +# 19737 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3696 "src/ocaml/preprocess/parser_raw.mly" +# 3661 "src/ocaml/preprocess/parser_raw.mly" ( Labelled label ) -# 13775 "src/ocaml/preprocess/parser_raw.ml" +# 19742 "src/ocaml/preprocess/parser_raw.ml" in -# 3688 "src/ocaml/preprocess/parser_raw.mly" +# 3653 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13780 "src/ocaml/preprocess/parser_raw.ml" +# 19747 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_codomain_, _startpos_label_) in @@ -13784,15 +19751,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13790 "src/ocaml/preprocess/parser_raw.ml" +# 19757 "src/ocaml/preprocess/parser_raw.ml" in -# 3690 "src/ocaml/preprocess/parser_raw.mly" +# 3655 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13796 "src/ocaml/preprocess/parser_raw.ml" +# 19763 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13831,19 +19798,19 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let domain = -# 1060 "src/ocaml/preprocess/parser_raw.mly" +# 1025 "src/ocaml/preprocess/parser_raw.mly" ( extra_rhs_core_type _1 ~pos:_endpos__1_ ) -# 13837 "src/ocaml/preprocess/parser_raw.ml" +# 19804 "src/ocaml/preprocess/parser_raw.ml" in let label = -# 3698 "src/ocaml/preprocess/parser_raw.mly" +# 3663 "src/ocaml/preprocess/parser_raw.mly" ( Nolabel ) -# 13842 "src/ocaml/preprocess/parser_raw.ml" +# 19809 "src/ocaml/preprocess/parser_raw.ml" in -# 3688 "src/ocaml/preprocess/parser_raw.mly" +# 3653 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_arrow(label, domain, codomain) ) -# 13847 "src/ocaml/preprocess/parser_raw.ml" +# 19814 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_codomain_ in @@ -13851,15 +19818,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 13857 "src/ocaml/preprocess/parser_raw.ml" +# 19824 "src/ocaml/preprocess/parser_raw.ml" in -# 3690 "src/ocaml/preprocess/parser_raw.mly" +# 3655 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13863 "src/ocaml/preprocess/parser_raw.ml" +# 19830 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13890,9 +19857,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Lexing.position * Parsetree.functor_parameter) = let _startpos = _startpos__1_ in -# 1472 "src/ocaml/preprocess/parser_raw.mly" +# 1437 "src/ocaml/preprocess/parser_raw.mly" ( _startpos, Unit ) -# 13896 "src/ocaml/preprocess/parser_raw.ml" +# 19863 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13948,16 +19915,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 13954 "src/ocaml/preprocess/parser_raw.ml" +# 19921 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1475 "src/ocaml/preprocess/parser_raw.mly" +# 1440 "src/ocaml/preprocess/parser_raw.mly" ( _startpos, Named (x, mty) ) -# 13961 "src/ocaml/preprocess/parser_raw.ml" +# 19928 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13980,9 +19947,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1464 "src/ocaml/preprocess/parser_raw.mly" +# 1429 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 13986 "src/ocaml/preprocess/parser_raw.ml" +# 19953 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -13999,9 +19966,9 @@ module Tables = struct let _endpos = _startpos in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3481 "src/ocaml/preprocess/parser_raw.mly" +# 3446 "src/ocaml/preprocess/parser_raw.mly" ( ([],Pcstr_tuple [],None) ) -# 14005 "src/ocaml/preprocess/parser_raw.ml" +# 19972 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14032,9 +19999,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3482 "src/ocaml/preprocess/parser_raw.mly" +# 3447 "src/ocaml/preprocess/parser_raw.mly" ( ([],_2,None) ) -# 14038 "src/ocaml/preprocess/parser_raw.ml" +# 20005 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14079,9 +20046,9 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3484 "src/ocaml/preprocess/parser_raw.mly" +# 3449 "src/ocaml/preprocess/parser_raw.mly" ( ([],_2,Some _4) ) -# 14085 "src/ocaml/preprocess/parser_raw.ml" +# 20052 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14144,24 +20111,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14148 "src/ocaml/preprocess/parser_raw.ml" +# 20115 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1129 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14153 "src/ocaml/preprocess/parser_raw.ml" +# 20120 "src/ocaml/preprocess/parser_raw.ml" in -# 3617 "src/ocaml/preprocess/parser_raw.mly" +# 3582 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14159 "src/ocaml/preprocess/parser_raw.ml" +# 20126 "src/ocaml/preprocess/parser_raw.ml" in -# 3487 "src/ocaml/preprocess/parser_raw.mly" +# 3452 "src/ocaml/preprocess/parser_raw.mly" ( (_2,_4,Some _6) ) -# 14165 "src/ocaml/preprocess/parser_raw.ml" +# 20132 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14192,9 +20159,9 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Ocaml_parsing.Ast_helper.str list * Parsetree.constructor_arguments * Parsetree.core_type option) = -# 3489 "src/ocaml/preprocess/parser_raw.mly" +# 3454 "src/ocaml/preprocess/parser_raw.mly" ( ([],Pcstr_tuple [],Some _2) ) -# 14198 "src/ocaml/preprocess/parser_raw.ml" +# 20165 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14243,24 +20210,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14247 "src/ocaml/preprocess/parser_raw.ml" +# 20214 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1129 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14252 "src/ocaml/preprocess/parser_raw.ml" +# 20219 "src/ocaml/preprocess/parser_raw.ml" in -# 3617 "src/ocaml/preprocess/parser_raw.mly" +# 3582 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14258 "src/ocaml/preprocess/parser_raw.ml" +# 20225 "src/ocaml/preprocess/parser_raw.ml" in -# 3491 "src/ocaml/preprocess/parser_raw.mly" +# 3456 "src/ocaml/preprocess/parser_raw.mly" ( (_2,Pcstr_tuple [],Some _4) ) -# 14264 "src/ocaml/preprocess/parser_raw.ml" +# 20231 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14309,9 +20276,9 @@ module Tables = struct Parsetree.attributes * Location.t * Ocaml_parsing.Docstrings.info) = let attrs = let _1 = _1_inlined2 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14315 "src/ocaml/preprocess/parser_raw.ml" +# 20282 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined2_ in @@ -14321,23 +20288,23 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14327 "src/ocaml/preprocess/parser_raw.ml" +# 20294 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3429 "src/ocaml/preprocess/parser_raw.mly" +# 3394 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let info = symbol_info _endpos in let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 14341 "src/ocaml/preprocess/parser_raw.ml" +# 20308 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14379,9 +20346,9 @@ module Tables = struct Parsetree.attributes * Location.t * Ocaml_parsing.Docstrings.info) = let attrs = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14385 "src/ocaml/preprocess/parser_raw.ml" +# 20352 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined1_ in @@ -14390,29 +20357,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14396 "src/ocaml/preprocess/parser_raw.ml" +# 20363 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_cid_ = _startpos__1_ in let _1 = -# 4083 "src/ocaml/preprocess/parser_raw.mly" +# 4048 "src/ocaml/preprocess/parser_raw.mly" ( () ) -# 14403 "src/ocaml/preprocess/parser_raw.ml" +# 20370 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos_cid_ in let _sloc = (_symbolstartpos, _endpos) in -# 3429 "src/ocaml/preprocess/parser_raw.mly" +# 3394 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let info = symbol_info _endpos in let loc = make_loc _sloc in cid, vars, args, res, attrs, loc, info ) -# 14416 "src/ocaml/preprocess/parser_raw.ml" +# 20383 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14483,9 +20450,9 @@ module Tables = struct 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 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14489 "src/ocaml/preprocess/parser_raw.ml" +# 20456 "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 @@ -14498,9 +20465,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined4 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14504 "src/ocaml/preprocess/parser_raw.ml" +# 20471 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14509,26 +20476,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14513 "src/ocaml/preprocess/parser_raw.ml" +# 20480 "src/ocaml/preprocess/parser_raw.ml" in -# 1146 "src/ocaml/preprocess/parser_raw.mly" +# 1111 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14518 "src/ocaml/preprocess/parser_raw.ml" +# 20485 "src/ocaml/preprocess/parser_raw.ml" in -# 3332 "src/ocaml/preprocess/parser_raw.mly" +# 3297 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14524 "src/ocaml/preprocess/parser_raw.ml" +# 20491 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined3 in -# 3367 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 14532 "src/ocaml/preprocess/parser_raw.ml" +# 20499 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14537,29 +20504,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14543 "src/ocaml/preprocess/parser_raw.ml" +# 20510 "src/ocaml/preprocess/parser_raw.ml" in let flag = -# 4103 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 14549 "src/ocaml/preprocess/parser_raw.ml" +# 20516 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14556 "src/ocaml/preprocess/parser_raw.ml" +# 20523 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3304 "src/ocaml/preprocess/parser_raw.mly" +# 3269 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14568,7 +20535,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14572 "src/ocaml/preprocess/parser_raw.ml" +# 20539 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14645,9 +20612,9 @@ module Tables = struct 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 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14651 "src/ocaml/preprocess/parser_raw.ml" +# 20618 "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 @@ -14661,9 +20628,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined5 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14667 "src/ocaml/preprocess/parser_raw.ml" +# 20634 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined5_ in @@ -14672,26 +20639,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14676 "src/ocaml/preprocess/parser_raw.ml" +# 20643 "src/ocaml/preprocess/parser_raw.ml" in -# 1146 "src/ocaml/preprocess/parser_raw.mly" +# 1111 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14681 "src/ocaml/preprocess/parser_raw.ml" +# 20648 "src/ocaml/preprocess/parser_raw.ml" in -# 3332 "src/ocaml/preprocess/parser_raw.mly" +# 3297 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14687 "src/ocaml/preprocess/parser_raw.ml" +# 20654 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined4 in -# 3367 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 14695 "src/ocaml/preprocess/parser_raw.ml" +# 20662 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14700,9 +20667,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14706 "src/ocaml/preprocess/parser_raw.ml" +# 20673 "src/ocaml/preprocess/parser_raw.ml" in let flag = @@ -14711,24 +20678,24 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4105 "src/ocaml/preprocess/parser_raw.mly" +# 4070 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 14717 "src/ocaml/preprocess/parser_raw.ml" +# 20684 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14725 "src/ocaml/preprocess/parser_raw.ml" +# 20692 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3304 "src/ocaml/preprocess/parser_raw.mly" +# 3269 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14737,7 +20704,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14741 "src/ocaml/preprocess/parser_raw.ml" +# 20708 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14801,9 +20768,9 @@ module Tables = struct 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 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14807 "src/ocaml/preprocess/parser_raw.ml" +# 20774 "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 @@ -14816,9 +20783,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14822 "src/ocaml/preprocess/parser_raw.ml" +# 20789 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -14827,18 +20794,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14831 "src/ocaml/preprocess/parser_raw.ml" +# 20798 "src/ocaml/preprocess/parser_raw.ml" in -# 1146 "src/ocaml/preprocess/parser_raw.mly" +# 1111 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14836 "src/ocaml/preprocess/parser_raw.ml" +# 20803 "src/ocaml/preprocess/parser_raw.ml" in -# 3332 "src/ocaml/preprocess/parser_raw.mly" +# 3297 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14842 "src/ocaml/preprocess/parser_raw.ml" +# 20809 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14847,29 +20814,29 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 14853 "src/ocaml/preprocess/parser_raw.ml" +# 20820 "src/ocaml/preprocess/parser_raw.ml" in let flag = -# 4099 "src/ocaml/preprocess/parser_raw.mly" +# 4064 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 14859 "src/ocaml/preprocess/parser_raw.ml" +# 20826 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14866 "src/ocaml/preprocess/parser_raw.ml" +# 20833 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3304 "src/ocaml/preprocess/parser_raw.mly" +# 3269 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -14878,7 +20845,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 14882 "src/ocaml/preprocess/parser_raw.ml" +# 20849 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -14948,9 +20915,9 @@ module Tables = struct 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 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 14954 "src/ocaml/preprocess/parser_raw.ml" +# 20921 "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 @@ -14964,9 +20931,9 @@ module Tables = struct Parsetree.type_declaration) = let attrs2 = let _1 = _1_inlined4 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14970 "src/ocaml/preprocess/parser_raw.ml" +# 20937 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -14975,18 +20942,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 14979 "src/ocaml/preprocess/parser_raw.ml" +# 20946 "src/ocaml/preprocess/parser_raw.ml" in -# 1146 "src/ocaml/preprocess/parser_raw.mly" +# 1111 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 14984 "src/ocaml/preprocess/parser_raw.ml" +# 20951 "src/ocaml/preprocess/parser_raw.ml" in -# 3332 "src/ocaml/preprocess/parser_raw.mly" +# 3297 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 14990 "src/ocaml/preprocess/parser_raw.ml" +# 20957 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -14995,32 +20962,32 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15001 "src/ocaml/preprocess/parser_raw.ml" +# 20968 "src/ocaml/preprocess/parser_raw.ml" in let flag = let _1 = _1_inlined2 in -# 4100 "src/ocaml/preprocess/parser_raw.mly" +# 4065 "src/ocaml/preprocess/parser_raw.mly" ( Nonrecursive ) -# 15009 "src/ocaml/preprocess/parser_raw.ml" +# 20976 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15017 "src/ocaml/preprocess/parser_raw.ml" +# 20984 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3304 "src/ocaml/preprocess/parser_raw.mly" +# 3269 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -15029,7 +20996,7 @@ module Tables = struct (flag, ext), Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ) -# 15033 "src/ocaml/preprocess/parser_raw.ml" +# 21000 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15048,17 +21015,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15054 "src/ocaml/preprocess/parser_raw.ml" +# 21021 "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) = -# 3938 "src/ocaml/preprocess/parser_raw.mly" +# 3903 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15062 "src/ocaml/preprocess/parser_raw.ml" +# 21029 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15077,17 +21044,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15083 "src/ocaml/preprocess/parser_raw.ml" +# 21050 "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) = -# 3939 "src/ocaml/preprocess/parser_raw.mly" +# 3904 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15091 "src/ocaml/preprocess/parser_raw.ml" +# 21058 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15117,9 +21084,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.structure) = -# 1338 "src/ocaml/preprocess/parser_raw.mly" +# 1303 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15123 "src/ocaml/preprocess/parser_raw.ml" +# 21090 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15135,9 +21102,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (string) = -# 3990 "src/ocaml/preprocess/parser_raw.mly" +# 3955 "src/ocaml/preprocess/parser_raw.mly" ( "" ) -# 15141 "src/ocaml/preprocess/parser_raw.ml" +# 21108 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15167,9 +21134,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 3991 "src/ocaml/preprocess/parser_raw.mly" +# 3956 "src/ocaml/preprocess/parser_raw.mly" ( ";.." ) -# 15173 "src/ocaml/preprocess/parser_raw.ml" +# 21140 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15199,9 +21166,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.signature) = -# 1345 "src/ocaml/preprocess/parser_raw.mly" +# 1310 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15205 "src/ocaml/preprocess/parser_raw.ml" +# 21172 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15245,9 +21212,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.extension) = -# 4283 "src/ocaml/preprocess/parser_raw.mly" +# 4248 "src/ocaml/preprocess/parser_raw.mly" ( (_2, _3) ) -# 15251 "src/ocaml/preprocess/parser_raw.ml" +# 21218 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15266,9 +21233,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 908 "src/ocaml/preprocess/parser_raw.mly" +# 881 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 15272 "src/ocaml/preprocess/parser_raw.ml" +# 21239 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15277,9 +21244,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4285 "src/ocaml/preprocess/parser_raw.mly" +# 4250 "src/ocaml/preprocess/parser_raw.mly" ( mk_quotedext ~loc:_sloc _1 ) -# 15283 "src/ocaml/preprocess/parser_raw.ml" +# 21250 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15325,9 +21292,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _3 : unit = Obj.magic _3 in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15331 "src/ocaml/preprocess/parser_raw.ml" +# 21298 "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 @@ -15336,34 +21303,34 @@ module Tables = struct let _v : (Parsetree.label_declaration) = let _5 = let _1 = _1_inlined3 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15342 "src/ocaml/preprocess/parser_raw.ml" +# 21309 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3600 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15351 "src/ocaml/preprocess/parser_raw.ml" +# 21318 "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 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15359 "src/ocaml/preprocess/parser_raw.ml" +# 21326 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15367 "src/ocaml/preprocess/parser_raw.ml" +# 21334 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15374,10 +21341,10 @@ module Tables = struct _startpos__2_ in let _sloc = (_symbolstartpos, _endpos) in -# 3508 "src/ocaml/preprocess/parser_raw.mly" +# 3473 "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 ) -# 15381 "src/ocaml/preprocess/parser_raw.ml" +# 21348 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15437,9 +21404,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _3 : unit = Obj.magic _3 in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15443 "src/ocaml/preprocess/parser_raw.ml" +# 21410 "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 @@ -15448,43 +21415,43 @@ module Tables = struct let _v : (Parsetree.label_declaration) = let _7 = let _1 = _1_inlined4 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15454 "src/ocaml/preprocess/parser_raw.ml" +# 21421 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__7_ = _endpos__1_inlined4_ in let _5 = let _1 = _1_inlined3 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15463 "src/ocaml/preprocess/parser_raw.ml" +# 21430 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3600 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15472 "src/ocaml/preprocess/parser_raw.ml" +# 21439 "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 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15480 "src/ocaml/preprocess/parser_raw.ml" +# 21447 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15488 "src/ocaml/preprocess/parser_raw.ml" +# 21455 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__2_ = _startpos__1_inlined1_ in @@ -15495,14 +21462,14 @@ module Tables = struct _startpos__2_ in let _sloc = (_symbolstartpos, _endpos) in -# 3513 "src/ocaml/preprocess/parser_raw.mly" +# 3478 "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 ) -# 15506 "src/ocaml/preprocess/parser_raw.ml" +# 21473 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15525,9 +21492,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.label_declaration list) = -# 3502 "src/ocaml/preprocess/parser_raw.mly" +# 3467 "src/ocaml/preprocess/parser_raw.mly" ( [_1] ) -# 15531 "src/ocaml/preprocess/parser_raw.ml" +# 21498 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15550,9 +21517,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.label_declaration list) = -# 3503 "src/ocaml/preprocess/parser_raw.mly" +# 3468 "src/ocaml/preprocess/parser_raw.mly" ( [_1] ) -# 15556 "src/ocaml/preprocess/parser_raw.ml" +# 21523 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15582,9 +21549,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.label_declaration list) = -# 3504 "src/ocaml/preprocess/parser_raw.mly" +# 3469 "src/ocaml/preprocess/parser_raw.mly" ( _1 :: _2 ) -# 15588 "src/ocaml/preprocess/parser_raw.ml" +# 21555 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15603,9 +21570,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15609 "src/ocaml/preprocess/parser_raw.ml" +# 21576 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15616,24 +21583,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15622 "src/ocaml/preprocess/parser_raw.ml" +# 21589 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2469 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15631 "src/ocaml/preprocess/parser_raw.ml" +# 21598 "src/ocaml/preprocess/parser_raw.ml" in -# 2496 "src/ocaml/preprocess/parser_raw.mly" +# 2461 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 15637 "src/ocaml/preprocess/parser_raw.ml" +# 21604 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15666,9 +21633,9 @@ module Tables = struct let cty : (Parsetree.core_type) = Obj.magic cty in let _2 : unit = Obj.magic _2 in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15672 "src/ocaml/preprocess/parser_raw.ml" +# 21639 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -15679,18 +21646,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 15685 "src/ocaml/preprocess/parser_raw.ml" +# 21652 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2469 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 15694 "src/ocaml/preprocess/parser_raw.ml" +# 21661 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_x_ = _startpos__1_ in @@ -15698,11 +21665,11 @@ module Tables = struct let _symbolstartpos = _startpos_x_ in let _sloc = (_symbolstartpos, _endpos) in -# 2498 "src/ocaml/preprocess/parser_raw.mly" +# 2463 "src/ocaml/preprocess/parser_raw.mly" ( let lab, pat = x in lab, mkpat ~loc:_sloc (Ppat_constraint (pat, cty)) ) -# 15706 "src/ocaml/preprocess/parser_raw.ml" +# 21673 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15725,9 +21692,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4022 "src/ocaml/preprocess/parser_raw.mly" +# 3987 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 15731 "src/ocaml/preprocess/parser_raw.ml" +# 21698 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15750,9 +21717,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.arg_label * Parsetree.expression) = -# 2792 "src/ocaml/preprocess/parser_raw.mly" +# 2757 "src/ocaml/preprocess/parser_raw.mly" ( (Nolabel, _1) ) -# 15756 "src/ocaml/preprocess/parser_raw.ml" +# 21723 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15778,17 +21745,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 852 "src/ocaml/preprocess/parser_raw.mly" +# 825 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15784 "src/ocaml/preprocess/parser_raw.ml" +# 21751 "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) = -# 2794 "src/ocaml/preprocess/parser_raw.mly" +# 2759 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled _1, _2) ) -# 15792 "src/ocaml/preprocess/parser_raw.ml" +# 21759 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15813,9 +21780,9 @@ module Tables = struct }; } = _menhir_stack in let label : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15819 "src/ocaml/preprocess/parser_raw.ml" +# 21786 "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 @@ -15823,10 +21790,10 @@ module Tables = struct let _endpos = _endpos_label_ in let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2796 "src/ocaml/preprocess/parser_raw.mly" +# 2761 "src/ocaml/preprocess/parser_raw.mly" ( let loc = _loc_label_ in (Labelled label, mkexpvar ~loc label) ) -# 15830 "src/ocaml/preprocess/parser_raw.ml" +# 21797 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15871,9 +21838,9 @@ module Tables = struct let _5 : unit = Obj.magic _5 in let ty : (Parsetree.type_constraint) = Obj.magic ty in let label : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15877 "src/ocaml/preprocess/parser_raw.ml" +# 21844 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic label in let _2 : unit = Obj.magic _2 in let _1 : unit = Obj.magic _1 in @@ -15883,10 +21850,10 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression) = let _endpos = _endpos__5_ in let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2799 "src/ocaml/preprocess/parser_raw.mly" +# 2764 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled label, mkexp_constraint ~loc:(_startpos__2_, _endpos) (mkexpvar ~loc:_loc_label_ label) ty) ) -# 15890 "src/ocaml/preprocess/parser_raw.ml" +# 21857 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15911,9 +21878,9 @@ module Tables = struct }; } = _menhir_stack in let label : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15917 "src/ocaml/preprocess/parser_raw.ml" +# 21884 "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 @@ -15921,10 +21888,10 @@ module Tables = struct let _endpos = _endpos_label_ in let _v : (Asttypes.arg_label * Parsetree.expression) = let _loc_label_ = (_startpos_label_, _endpos_label_) in -# 2802 "src/ocaml/preprocess/parser_raw.mly" +# 2767 "src/ocaml/preprocess/parser_raw.mly" ( let loc = _loc_label_ in (Optional label, mkexpvar ~loc label) ) -# 15928 "src/ocaml/preprocess/parser_raw.ml" +# 21895 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -15950,17 +21917,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 882 "src/ocaml/preprocess/parser_raw.mly" +# 855 "src/ocaml/preprocess/parser_raw.mly" (string) -# 15956 "src/ocaml/preprocess/parser_raw.ml" +# 21923 "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) = -# 2805 "src/ocaml/preprocess/parser_raw.mly" +# 2770 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, _2) ) -# 15964 "src/ocaml/preprocess/parser_raw.ml" +# 21931 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16013,15 +21980,15 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 = let _1 = _1_inlined1 in -# 2492 "src/ocaml/preprocess/parser_raw.mly" +# 2457 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16019 "src/ocaml/preprocess/parser_raw.ml" +# 21986 "src/ocaml/preprocess/parser_raw.ml" in -# 2466 "src/ocaml/preprocess/parser_raw.mly" +# 2431 "src/ocaml/preprocess/parser_raw.mly" ( (Optional (fst _3), _4, snd _3) ) -# 16025 "src/ocaml/preprocess/parser_raw.ml" +# 21992 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16046,9 +22013,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 16052 "src/ocaml/preprocess/parser_raw.ml" +# 22019 "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 @@ -16061,24 +22028,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 16067 "src/ocaml/preprocess/parser_raw.ml" +# 22034 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2469 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 16076 "src/ocaml/preprocess/parser_raw.ml" +# 22043 "src/ocaml/preprocess/parser_raw.ml" in -# 2468 "src/ocaml/preprocess/parser_raw.mly" +# 2433 "src/ocaml/preprocess/parser_raw.mly" ( (Optional (fst _2), None, snd _2) ) -# 16082 "src/ocaml/preprocess/parser_raw.ml" +# 22049 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16125,9 +22092,9 @@ module Tables = struct let _3 : (Parsetree.pattern) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 882 "src/ocaml/preprocess/parser_raw.mly" +# 855 "src/ocaml/preprocess/parser_raw.mly" (string) -# 16131 "src/ocaml/preprocess/parser_raw.ml" +# 22098 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -16135,15 +22102,15 @@ module Tables = struct let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = let _4 = let _1 = _1_inlined1 in -# 2492 "src/ocaml/preprocess/parser_raw.mly" +# 2457 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16141 "src/ocaml/preprocess/parser_raw.ml" +# 22108 "src/ocaml/preprocess/parser_raw.ml" in -# 2470 "src/ocaml/preprocess/parser_raw.mly" +# 2435 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, _4, _3) ) -# 16147 "src/ocaml/preprocess/parser_raw.ml" +# 22114 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16169,17 +22136,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.pattern) = Obj.magic _2 in let _1 : ( -# 882 "src/ocaml/preprocess/parser_raw.mly" +# 855 "src/ocaml/preprocess/parser_raw.mly" (string) -# 16175 "src/ocaml/preprocess/parser_raw.ml" +# 22142 "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) = -# 2472 "src/ocaml/preprocess/parser_raw.mly" +# 2437 "src/ocaml/preprocess/parser_raw.mly" ( (Optional _1, None, _2) ) -# 16183 "src/ocaml/preprocess/parser_raw.ml" +# 22150 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16223,9 +22190,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2474 "src/ocaml/preprocess/parser_raw.mly" +# 2439 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled (fst _3), None, snd _3) ) -# 16229 "src/ocaml/preprocess/parser_raw.ml" +# 22196 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16250,9 +22217,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 16256 "src/ocaml/preprocess/parser_raw.ml" +# 22223 "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 @@ -16265,24 +22232,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 16271 "src/ocaml/preprocess/parser_raw.ml" +# 22238 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2504 "src/ocaml/preprocess/parser_raw.mly" +# 2469 "src/ocaml/preprocess/parser_raw.mly" ( (_1.Location.txt, mkpat ~loc:_sloc (Ppat_var _1)) ) -# 16280 "src/ocaml/preprocess/parser_raw.ml" +# 22247 "src/ocaml/preprocess/parser_raw.ml" in -# 2476 "src/ocaml/preprocess/parser_raw.mly" +# 2441 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled (fst _2), None, snd _2) ) -# 16286 "src/ocaml/preprocess/parser_raw.ml" +# 22253 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16308,17 +22275,17 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.pattern) = Obj.magic _2 in let _1 : ( -# 852 "src/ocaml/preprocess/parser_raw.mly" +# 825 "src/ocaml/preprocess/parser_raw.mly" (string) -# 16314 "src/ocaml/preprocess/parser_raw.ml" +# 22281 "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) = -# 2478 "src/ocaml/preprocess/parser_raw.mly" +# 2443 "src/ocaml/preprocess/parser_raw.mly" ( (Labelled _1, None, _2) ) -# 16322 "src/ocaml/preprocess/parser_raw.ml" +# 22289 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16341,9 +22308,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern) = -# 2480 "src/ocaml/preprocess/parser_raw.mly" +# 2445 "src/ocaml/preprocess/parser_raw.mly" ( (Nolabel, None, _1) ) -# 16347 "src/ocaml/preprocess/parser_raw.ml" +# 22314 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16368,9 +22335,9 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option * bool) = -# 2844 "src/ocaml/preprocess/parser_raw.mly" +# 2809 "src/ocaml/preprocess/parser_raw.mly" ( let p,e,c = _1 in (p,e,c,false) ) -# 16374 "src/ocaml/preprocess/parser_raw.ml" +# 22341 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16397,9 +22364,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2847 "src/ocaml/preprocess/parser_raw.mly" +# 2812 "src/ocaml/preprocess/parser_raw.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1, None, true) ) -# 16403 "src/ocaml/preprocess/parser_raw.ml" +# 22370 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16434,15 +22401,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2812 "src/ocaml/preprocess/parser_raw.mly" +# 2777 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16440 "src/ocaml/preprocess/parser_raw.ml" +# 22407 "src/ocaml/preprocess/parser_raw.ml" in -# 2816 "src/ocaml/preprocess/parser_raw.mly" +# 2781 "src/ocaml/preprocess/parser_raw.mly" ( (_1, _2, None) ) -# 16446 "src/ocaml/preprocess/parser_raw.ml" +# 22413 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16491,13 +22458,13 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2812 "src/ocaml/preprocess/parser_raw.mly" +# 2777 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16497 "src/ocaml/preprocess/parser_raw.ml" +# 22464 "src/ocaml/preprocess/parser_raw.ml" in -# 2818 "src/ocaml/preprocess/parser_raw.mly" +# 2783 "src/ocaml/preprocess/parser_raw.mly" ( let v = _1 in (* PR#7344 *) let t = match _2 with @@ -16507,7 +22474,7 @@ module Tables = struct in (v, _4, Some t) ) -# 16511 "src/ocaml/preprocess/parser_raw.ml" +# 22478 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16579,24 +22546,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 16583 "src/ocaml/preprocess/parser_raw.ml" +# 22550 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1129 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 16588 "src/ocaml/preprocess/parser_raw.ml" +# 22555 "src/ocaml/preprocess/parser_raw.ml" in -# 3617 "src/ocaml/preprocess/parser_raw.mly" +# 3582 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16594 "src/ocaml/preprocess/parser_raw.ml" +# 22561 "src/ocaml/preprocess/parser_raw.ml" in -# 3621 "src/ocaml/preprocess/parser_raw.mly" +# 3586 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 16600 "src/ocaml/preprocess/parser_raw.ml" +# 22567 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__3_ = _startpos_xs_ in @@ -16605,19 +22572,19 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2812 "src/ocaml/preprocess/parser_raw.mly" +# 2777 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16611 "src/ocaml/preprocess/parser_raw.ml" +# 22578 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2828 "src/ocaml/preprocess/parser_raw.mly" +# 2793 "src/ocaml/preprocess/parser_raw.mly" ( let t = ghtyp ~loc:(_loc__3_) _3 in (_1, _5, Some (Pvc_constraint { locally_abstract_univars = []; typ=t })) ) -# 16621 "src/ocaml/preprocess/parser_raw.ml" +# 22588 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16690,27 +22657,27 @@ module Tables = struct let _endpos = _endpos__8_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = let _4 = -# 2809 "src/ocaml/preprocess/parser_raw.mly" +# 2774 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 16696 "src/ocaml/preprocess/parser_raw.ml" +# 22663 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2812 "src/ocaml/preprocess/parser_raw.mly" +# 2777 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 16705 "src/ocaml/preprocess/parser_raw.ml" +# 22672 "src/ocaml/preprocess/parser_raw.ml" in -# 2833 "src/ocaml/preprocess/parser_raw.mly" +# 2798 "src/ocaml/preprocess/parser_raw.mly" ( let constraint' = Pvc_constraint { locally_abstract_univars=_4; typ = _6} in (_1, _8, Some constraint') ) -# 16714 "src/ocaml/preprocess/parser_raw.ml" +# 22681 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16748,9 +22715,9 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = -# 2838 "src/ocaml/preprocess/parser_raw.mly" +# 2803 "src/ocaml/preprocess/parser_raw.mly" ( (_1, _3, None) ) -# 16754 "src/ocaml/preprocess/parser_raw.ml" +# 22721 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16802,9 +22769,9 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.value_constraint option) = -# 2840 "src/ocaml/preprocess/parser_raw.mly" +# 2805 "src/ocaml/preprocess/parser_raw.mly" ( (_1, _5, Some(Pvc_constraint { locally_abstract_univars=[]; typ=_3 })) ) -# 16808 "src/ocaml/preprocess/parser_raw.ml" +# 22775 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16866,36 +22833,36 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16872 "src/ocaml/preprocess/parser_raw.ml" +# 22839 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16881 "src/ocaml/preprocess/parser_raw.ml" +# 22848 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2867 "src/ocaml/preprocess/parser_raw.mly" +# 2832 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 16893 "src/ocaml/preprocess/parser_raw.ml" +# 22860 "src/ocaml/preprocess/parser_raw.ml" in -# 2857 "src/ocaml/preprocess/parser_raw.mly" +# 2822 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16899 "src/ocaml/preprocess/parser_raw.ml" +# 22866 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16925,9 +22892,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 2858 "src/ocaml/preprocess/parser_raw.mly" +# 2823 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 16931 "src/ocaml/preprocess/parser_raw.ml" +# 22898 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -16982,41 +22949,41 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16988 "src/ocaml/preprocess/parser_raw.ml" +# 22955 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 16997 "src/ocaml/preprocess/parser_raw.ml" +# 22964 "src/ocaml/preprocess/parser_raw.ml" in let ext = -# 4269 "src/ocaml/preprocess/parser_raw.mly" +# 4234 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 17003 "src/ocaml/preprocess/parser_raw.ml" +# 22970 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2867 "src/ocaml/preprocess/parser_raw.mly" +# 2832 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 17014 "src/ocaml/preprocess/parser_raw.ml" +# 22981 "src/ocaml/preprocess/parser_raw.ml" in -# 2857 "src/ocaml/preprocess/parser_raw.mly" +# 2822 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17020 "src/ocaml/preprocess/parser_raw.ml" +# 22987 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17085,18 +23052,18 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17091 "src/ocaml/preprocess/parser_raw.ml" +# 23058 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let attrs1 = let _1 = _1_inlined2 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17100 "src/ocaml/preprocess/parser_raw.ml" +# 23067 "src/ocaml/preprocess/parser_raw.ml" in let ext = @@ -17105,27 +23072,27 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4271 "src/ocaml/preprocess/parser_raw.mly" +# 4236 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "extension"; None ) -# 17111 "src/ocaml/preprocess/parser_raw.ml" +# 23078 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2867 "src/ocaml/preprocess/parser_raw.mly" +# 2832 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in mklbs ext rec_flag (mklb ~loc:_sloc true body attrs) ) -# 17123 "src/ocaml/preprocess/parser_raw.ml" +# 23090 "src/ocaml/preprocess/parser_raw.ml" in -# 2857 "src/ocaml/preprocess/parser_raw.mly" +# 2822 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17129 "src/ocaml/preprocess/parser_raw.ml" +# 23096 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17155,9 +23122,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Ast_helper.let_bindings) = -# 2858 "src/ocaml/preprocess/parser_raw.mly" +# 2823 "src/ocaml/preprocess/parser_raw.mly" ( addlb _1 _2 ) -# 17161 "src/ocaml/preprocess/parser_raw.ml" +# 23128 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17180,9 +23147,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 2508 "src/ocaml/preprocess/parser_raw.mly" +# 2473 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17186 "src/ocaml/preprocess/parser_raw.ml" +# 23153 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17220,24 +23187,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2510 "src/ocaml/preprocess/parser_raw.mly" +# 2475 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_1, _3) ) -# 17226 "src/ocaml/preprocess/parser_raw.ml" +# 23193 "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 -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 17235 "src/ocaml/preprocess/parser_raw.ml" +# 23202 "src/ocaml/preprocess/parser_raw.ml" in -# 2511 "src/ocaml/preprocess/parser_raw.mly" +# 2476 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17241 "src/ocaml/preprocess/parser_raw.ml" +# 23208 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17271,15 +23238,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2812 "src/ocaml/preprocess/parser_raw.mly" +# 2777 "src/ocaml/preprocess/parser_raw.mly" ( mkpatvar ~loc:_sloc _1 ) -# 17277 "src/ocaml/preprocess/parser_raw.ml" +# 23244 "src/ocaml/preprocess/parser_raw.ml" in -# 2884 "src/ocaml/preprocess/parser_raw.mly" +# 2849 "src/ocaml/preprocess/parser_raw.mly" ( (pat, exp) ) -# 17283 "src/ocaml/preprocess/parser_raw.ml" +# 23250 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17305,9 +23272,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2887 "src/ocaml/preprocess/parser_raw.mly" +# 2852 "src/ocaml/preprocess/parser_raw.mly" ( (mkpatvar ~loc:_loc _1, mkexpvar ~loc:_loc _1) ) -# 17311 "src/ocaml/preprocess/parser_raw.ml" +# 23278 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17358,10 +23325,10 @@ module Tables = struct let _startpos = _startpos_pat_ in let _endpos = _endpos_exp_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2889 "src/ocaml/preprocess/parser_raw.mly" +# 2854 "src/ocaml/preprocess/parser_raw.mly" ( let loc = (_startpos_pat_, _endpos_typ_) in (ghpat ~loc (Ppat_constraint(pat, typ)), exp) ) -# 17365 "src/ocaml/preprocess/parser_raw.ml" +# 23332 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17398,9 +23365,9 @@ module Tables = struct let _startpos = _startpos_pat_ in let _endpos = _endpos_exp_ in let _v : (Parsetree.pattern * Parsetree.expression) = -# 2892 "src/ocaml/preprocess/parser_raw.mly" +# 2857 "src/ocaml/preprocess/parser_raw.mly" ( (pat, exp) ) -# 17404 "src/ocaml/preprocess/parser_raw.ml" +# 23371 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17423,10 +23390,10 @@ module Tables = struct let _startpos = _startpos_body_ in let _endpos = _endpos_body_ in let _v : (Parsetree.pattern * Parsetree.expression * Parsetree.binding_op list) = -# 2896 "src/ocaml/preprocess/parser_raw.mly" +# 2861 "src/ocaml/preprocess/parser_raw.mly" ( let let_pat, let_exp = body in let_pat, let_exp, [] ) -# 17430 "src/ocaml/preprocess/parser_raw.ml" +# 23397 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17458,9 +23425,9 @@ module Tables = struct } = _menhir_stack in let body : (Parsetree.pattern * Parsetree.expression) = Obj.magic body in let _1 : ( -# 848 "src/ocaml/preprocess/parser_raw.mly" +# 821 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17464 "src/ocaml/preprocess/parser_raw.ml" +# 23431 "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 @@ -17471,22 +23438,22 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17477 "src/ocaml/preprocess/parser_raw.ml" +# 23444 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_body_ in let _symbolstartpos = _startpos_bindings_ in let _sloc = (_symbolstartpos, _endpos) in -# 2899 "src/ocaml/preprocess/parser_raw.mly" +# 2864 "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 ) -# 17490 "src/ocaml/preprocess/parser_raw.ml" +# 23457 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17504,7 +23471,7 @@ module Tables = struct let _v : (Parsetree.class_expr Parsetree.class_infos list) = # 211 "" ( [] ) -# 17508 "src/ocaml/preprocess/parser_raw.ml" +# 23475 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17568,9 +23535,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17574 "src/ocaml/preprocess/parser_raw.ml" +# 23541 "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 @@ -17583,9 +23550,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17589 "src/ocaml/preprocess/parser_raw.ml" +# 23556 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17595,24 +23562,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17601 "src/ocaml/preprocess/parser_raw.ml" +# 23568 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17609 "src/ocaml/preprocess/parser_raw.ml" +# 23576 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2073 "src/ocaml/preprocess/parser_raw.mly" +# 2038 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17620,13 +23587,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id body ~virt ~params ~attrs ~loc ~text ~docs ) -# 17624 "src/ocaml/preprocess/parser_raw.ml" +# 23591 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17630 "src/ocaml/preprocess/parser_raw.ml" +# 23597 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17644,7 +23611,7 @@ module Tables = struct let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 17648 "src/ocaml/preprocess/parser_raw.ml" +# 23615 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17715,9 +23682,9 @@ module Tables = struct let cty : (Parsetree.class_type) = Obj.magic cty in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17721 "src/ocaml/preprocess/parser_raw.ml" +# 23688 "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 @@ -17730,9 +23697,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17736 "src/ocaml/preprocess/parser_raw.ml" +# 23703 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17742,24 +23709,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17748 "src/ocaml/preprocess/parser_raw.ml" +# 23715 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17756 "src/ocaml/preprocess/parser_raw.ml" +# 23723 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2372 "src/ocaml/preprocess/parser_raw.mly" +# 2337 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17767,13 +23734,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id cty ~virt ~params ~attrs ~loc ~text ~docs ) -# 17771 "src/ocaml/preprocess/parser_raw.ml" +# 23738 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17777 "src/ocaml/preprocess/parser_raw.ml" +# 23744 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17791,7 +23758,7 @@ module Tables = struct let _v : (Parsetree.class_type Parsetree.class_infos list) = # 211 "" ( [] ) -# 17795 "src/ocaml/preprocess/parser_raw.ml" +# 23762 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17862,9 +23829,9 @@ module Tables = struct let csig : (Parsetree.class_type) = Obj.magic csig in let _6 : unit = Obj.magic _6 in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 17868 "src/ocaml/preprocess/parser_raw.ml" +# 23835 "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 @@ -17877,9 +23844,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17883 "src/ocaml/preprocess/parser_raw.ml" +# 23850 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -17889,24 +23856,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 17895 "src/ocaml/preprocess/parser_raw.ml" +# 23862 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 17903 "src/ocaml/preprocess/parser_raw.ml" +# 23870 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2411 "src/ocaml/preprocess/parser_raw.mly" +# 2376 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -17914,13 +23881,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Ci.mk id csig ~virt ~params ~attrs ~loc ~text ~docs ) -# 17918 "src/ocaml/preprocess/parser_raw.ml" +# 23885 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 17924 "src/ocaml/preprocess/parser_raw.ml" +# 23891 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17938,7 +23905,7 @@ module Tables = struct let _v : (Parsetree.module_binding list) = # 211 "" ( [] ) -# 17942 "src/ocaml/preprocess/parser_raw.ml" +# 23909 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -17999,9 +23966,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18005 "src/ocaml/preprocess/parser_raw.ml" +# 23972 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18011,24 +23978,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18017 "src/ocaml/preprocess/parser_raw.ml" +# 23984 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18025 "src/ocaml/preprocess/parser_raw.ml" +# 23992 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1719 "src/ocaml/preprocess/parser_raw.mly" +# 1684 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in @@ -18036,13 +24003,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Mb.mk name body ~attrs ~loc ~text ~docs ) -# 18040 "src/ocaml/preprocess/parser_raw.ml" +# 24007 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18046 "src/ocaml/preprocess/parser_raw.ml" +# 24013 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18060,7 +24027,7 @@ module Tables = struct let _v : (Parsetree.module_declaration list) = # 211 "" ( [] ) -# 18064 "src/ocaml/preprocess/parser_raw.ml" +# 24031 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18128,9 +24095,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18134 "src/ocaml/preprocess/parser_raw.ml" +# 24101 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18140,24 +24107,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18146 "src/ocaml/preprocess/parser_raw.ml" +# 24113 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18154 "src/ocaml/preprocess/parser_raw.ml" +# 24121 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2014 "src/ocaml/preprocess/parser_raw.mly" +# 1979 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let docs = symbol_docs _sloc in @@ -18165,13 +24132,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Md.mk name mty ~attrs ~loc ~text ~docs ) -# 18169 "src/ocaml/preprocess/parser_raw.ml" +# 24136 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18175 "src/ocaml/preprocess/parser_raw.ml" +# 24142 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18189,7 +24156,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 18193 "src/ocaml/preprocess/parser_raw.ml" +# 24160 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18221,7 +24188,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 18225 "src/ocaml/preprocess/parser_raw.ml" +# 24192 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18239,7 +24206,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 18243 "src/ocaml/preprocess/parser_raw.ml" +# 24210 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18304,9 +24271,9 @@ module Tables = struct 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 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 18310 "src/ocaml/preprocess/parser_raw.ml" +# 24277 "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 @@ -18319,9 +24286,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18325 "src/ocaml/preprocess/parser_raw.ml" +# 24292 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -18330,18 +24297,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18334 "src/ocaml/preprocess/parser_raw.ml" +# 24301 "src/ocaml/preprocess/parser_raw.ml" in -# 1146 "src/ocaml/preprocess/parser_raw.mly" +# 1111 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 18339 "src/ocaml/preprocess/parser_raw.ml" +# 24306 "src/ocaml/preprocess/parser_raw.ml" in -# 3332 "src/ocaml/preprocess/parser_raw.mly" +# 3297 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18345 "src/ocaml/preprocess/parser_raw.ml" +# 24312 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -18350,24 +24317,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18356 "src/ocaml/preprocess/parser_raw.ml" +# 24323 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18364 "src/ocaml/preprocess/parser_raw.ml" +# 24331 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3321 "src/ocaml/preprocess/parser_raw.mly" +# 3286 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -18376,13 +24343,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18380 "src/ocaml/preprocess/parser_raw.ml" +# 24347 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18386 "src/ocaml/preprocess/parser_raw.ml" +# 24353 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18400,7 +24367,7 @@ module Tables = struct let _v : (Parsetree.type_declaration list) = # 211 "" ( [] ) -# 18404 "src/ocaml/preprocess/parser_raw.ml" +# 24371 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18472,9 +24439,9 @@ module Tables = struct 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 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 18478 "src/ocaml/preprocess/parser_raw.ml" +# 24445 "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 @@ -18487,9 +24454,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18493 "src/ocaml/preprocess/parser_raw.ml" +# 24460 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -18498,26 +24465,26 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 18502 "src/ocaml/preprocess/parser_raw.ml" +# 24469 "src/ocaml/preprocess/parser_raw.ml" in -# 1146 "src/ocaml/preprocess/parser_raw.mly" +# 1111 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 18507 "src/ocaml/preprocess/parser_raw.ml" +# 24474 "src/ocaml/preprocess/parser_raw.ml" in -# 3332 "src/ocaml/preprocess/parser_raw.mly" +# 3297 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18513 "src/ocaml/preprocess/parser_raw.ml" +# 24480 "src/ocaml/preprocess/parser_raw.ml" in let kind_priv_manifest = let _1 = _1_inlined3 in -# 3367 "src/ocaml/preprocess/parser_raw.mly" +# 3332 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 18521 "src/ocaml/preprocess/parser_raw.ml" +# 24488 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -18526,24 +24493,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 18532 "src/ocaml/preprocess/parser_raw.ml" +# 24499 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18540 "src/ocaml/preprocess/parser_raw.ml" +# 24507 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3321 "src/ocaml/preprocess/parser_raw.mly" +# 3286 "src/ocaml/preprocess/parser_raw.mly" ( let (kind, priv, manifest) = kind_priv_manifest in let docs = symbol_docs _sloc in @@ -18552,13 +24519,13 @@ module Tables = struct let text = symbol_text _symbolstartpos in Type.mk id ~params ~cstrs ~kind ~priv ?manifest ~attrs ~loc ~docs ~text ) -# 18556 "src/ocaml/preprocess/parser_raw.ml" +# 24523 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18562 "src/ocaml/preprocess/parser_raw.ml" +# 24529 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18576,7 +24543,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 211 "" ( [] ) -# 18580 "src/ocaml/preprocess/parser_raw.ml" +# 24547 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18608,7 +24575,7 @@ module Tables = struct let _v : (Parsetree.attributes) = # 213 "" ( x :: xs ) -# 18612 "src/ocaml/preprocess/parser_raw.ml" +# 24579 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18626,7 +24593,7 @@ module Tables = struct let _v : (Parsetree.signature_item list list) = # 211 "" ( [] ) -# 18630 "src/ocaml/preprocess/parser_raw.ml" +# 24597 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18659,21 +24626,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1072 "src/ocaml/preprocess/parser_raw.mly" +# 1037 "src/ocaml/preprocess/parser_raw.mly" ( text_sig _startpos ) -# 18665 "src/ocaml/preprocess/parser_raw.ml" +# 24632 "src/ocaml/preprocess/parser_raw.ml" in -# 1867 "src/ocaml/preprocess/parser_raw.mly" +# 1832 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18671 "src/ocaml/preprocess/parser_raw.ml" +# 24638 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18677 "src/ocaml/preprocess/parser_raw.ml" +# 24644 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18706,21 +24673,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1070 "src/ocaml/preprocess/parser_raw.mly" +# 1035 "src/ocaml/preprocess/parser_raw.mly" ( text_sig _startpos @ [_1] ) -# 18712 "src/ocaml/preprocess/parser_raw.ml" +# 24679 "src/ocaml/preprocess/parser_raw.ml" in -# 1867 "src/ocaml/preprocess/parser_raw.mly" +# 1832 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18718 "src/ocaml/preprocess/parser_raw.ml" +# 24685 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18724 "src/ocaml/preprocess/parser_raw.ml" +# 24691 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18738,7 +24705,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 18742 "src/ocaml/preprocess/parser_raw.ml" +# 24709 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18771,40 +24738,40 @@ module Tables = struct let _1 = let ys = let items = -# 1132 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 18777 "src/ocaml/preprocess/parser_raw.ml" +# 24744 "src/ocaml/preprocess/parser_raw.ml" in -# 1598 "src/ocaml/preprocess/parser_raw.mly" +# 1563 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 18782 "src/ocaml/preprocess/parser_raw.ml" +# 24749 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _startpos = _startpos__1_ in -# 1068 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos ) -# 18790 "src/ocaml/preprocess/parser_raw.ml" +# 24757 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 18796 "src/ocaml/preprocess/parser_raw.ml" +# 24763 "src/ocaml/preprocess/parser_raw.ml" in -# 1614 "src/ocaml/preprocess/parser_raw.mly" +# 1579 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18802 "src/ocaml/preprocess/parser_raw.ml" +# 24769 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18808 "src/ocaml/preprocess/parser_raw.ml" +# 24775 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18856,70 +24823,70 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18862 "src/ocaml/preprocess/parser_raw.ml" +# 24829 "src/ocaml/preprocess/parser_raw.ml" in -# 1605 "src/ocaml/preprocess/parser_raw.mly" +# 1570 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 18867 "src/ocaml/preprocess/parser_raw.ml" +# 24834 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18875 "src/ocaml/preprocess/parser_raw.ml" +# 24842 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1085 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 18885 "src/ocaml/preprocess/parser_raw.ml" +# 24852 "src/ocaml/preprocess/parser_raw.ml" in -# 1134 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 18891 "src/ocaml/preprocess/parser_raw.ml" +# 24858 "src/ocaml/preprocess/parser_raw.ml" in -# 1598 "src/ocaml/preprocess/parser_raw.mly" +# 1563 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 18897 "src/ocaml/preprocess/parser_raw.ml" +# 24864 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _startpos = _startpos__1_ in -# 1068 "src/ocaml/preprocess/parser_raw.mly" +# 1033 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos ) -# 18905 "src/ocaml/preprocess/parser_raw.ml" +# 24872 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 18911 "src/ocaml/preprocess/parser_raw.ml" +# 24878 "src/ocaml/preprocess/parser_raw.ml" in -# 1614 "src/ocaml/preprocess/parser_raw.mly" +# 1579 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18917 "src/ocaml/preprocess/parser_raw.ml" +# 24884 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18923 "src/ocaml/preprocess/parser_raw.ml" +# 24890 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18952,21 +24919,21 @@ module Tables = struct let _1 = let _startpos = _startpos__1_ in -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 18958 "src/ocaml/preprocess/parser_raw.ml" +# 24925 "src/ocaml/preprocess/parser_raw.ml" in -# 1614 "src/ocaml/preprocess/parser_raw.mly" +# 1579 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 18964 "src/ocaml/preprocess/parser_raw.ml" +# 24931 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 18970 "src/ocaml/preprocess/parser_raw.ml" +# 24937 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -18984,7 +24951,7 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = # 211 "" ( [] ) -# 18988 "src/ocaml/preprocess/parser_raw.ml" +# 24955 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19016,15 +24983,15 @@ module Tables = struct let _v : (Parsetree.class_type_field list list) = let x = let _startpos = _startpos__1_ in -# 1080 "src/ocaml/preprocess/parser_raw.mly" +# 1045 "src/ocaml/preprocess/parser_raw.mly" ( text_csig _startpos @ [_1] ) -# 19022 "src/ocaml/preprocess/parser_raw.ml" +# 24989 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19028 "src/ocaml/preprocess/parser_raw.ml" +# 24995 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19042,7 +25009,7 @@ module Tables = struct let _v : (Parsetree.class_field list list) = # 211 "" ( [] ) -# 19046 "src/ocaml/preprocess/parser_raw.ml" +# 25013 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19074,15 +25041,15 @@ module Tables = struct let _v : (Parsetree.class_field list list) = let x = let _startpos = _startpos__1_ in -# 1078 "src/ocaml/preprocess/parser_raw.mly" +# 1043 "src/ocaml/preprocess/parser_raw.mly" ( text_cstr _startpos @ [_1] ) -# 19080 "src/ocaml/preprocess/parser_raw.ml" +# 25047 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19086 "src/ocaml/preprocess/parser_raw.ml" +# 25053 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19100,7 +25067,7 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = # 211 "" ( [] ) -# 19104 "src/ocaml/preprocess/parser_raw.ml" +# 25071 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19132,15 +25099,15 @@ module Tables = struct let _v : (Parsetree.structure_item list list) = let x = let _startpos = _startpos__1_ in -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 19138 "src/ocaml/preprocess/parser_raw.ml" +# 25105 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19144 "src/ocaml/preprocess/parser_raw.ml" +# 25111 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19158,7 +25125,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = # 211 "" ( [] ) -# 19162 "src/ocaml/preprocess/parser_raw.ml" +# 25129 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19191,32 +25158,32 @@ module Tables = struct let _1 = let x = let _1 = -# 1132 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 19197 "src/ocaml/preprocess/parser_raw.ml" +# 25164 "src/ocaml/preprocess/parser_raw.ml" in -# 1385 "src/ocaml/preprocess/parser_raw.mly" +# 1350 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19202 "src/ocaml/preprocess/parser_raw.ml" +# 25169 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 19208 "src/ocaml/preprocess/parser_raw.ml" +# 25175 "src/ocaml/preprocess/parser_raw.ml" in -# 1397 "src/ocaml/preprocess/parser_raw.mly" +# 1362 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19214 "src/ocaml/preprocess/parser_raw.ml" +# 25181 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19220 "src/ocaml/preprocess/parser_raw.ml" +# 25187 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19268,58 +25235,58 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19274 "src/ocaml/preprocess/parser_raw.ml" +# 25241 "src/ocaml/preprocess/parser_raw.ml" in -# 1605 "src/ocaml/preprocess/parser_raw.mly" +# 1570 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 19279 "src/ocaml/preprocess/parser_raw.ml" +# 25246 "src/ocaml/preprocess/parser_raw.ml" in -# 1076 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 19285 "src/ocaml/preprocess/parser_raw.ml" +# 25252 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19293 "src/ocaml/preprocess/parser_raw.ml" +# 25260 "src/ocaml/preprocess/parser_raw.ml" in -# 1134 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 19299 "src/ocaml/preprocess/parser_raw.ml" +# 25266 "src/ocaml/preprocess/parser_raw.ml" in -# 1385 "src/ocaml/preprocess/parser_raw.mly" +# 1350 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19305 "src/ocaml/preprocess/parser_raw.ml" +# 25272 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 19311 "src/ocaml/preprocess/parser_raw.ml" +# 25278 "src/ocaml/preprocess/parser_raw.ml" in -# 1397 "src/ocaml/preprocess/parser_raw.mly" +# 1362 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19317 "src/ocaml/preprocess/parser_raw.ml" +# 25284 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19323 "src/ocaml/preprocess/parser_raw.ml" +# 25290 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19351,27 +25318,27 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase list list) = let x = let _1 = let _1 = -# 1076 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 19357 "src/ocaml/preprocess/parser_raw.ml" +# 25324 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19363 "src/ocaml/preprocess/parser_raw.ml" +# 25330 "src/ocaml/preprocess/parser_raw.ml" in -# 1397 "src/ocaml/preprocess/parser_raw.mly" +# 1362 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19369 "src/ocaml/preprocess/parser_raw.ml" +# 25336 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19375 "src/ocaml/preprocess/parser_raw.ml" +# 25342 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19406,29 +25373,29 @@ module Tables = struct let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1085 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 19413 "src/ocaml/preprocess/parser_raw.ml" +# 25380 "src/ocaml/preprocess/parser_raw.ml" in let _startpos = _startpos__1_ in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 19420 "src/ocaml/preprocess/parser_raw.ml" +# 25387 "src/ocaml/preprocess/parser_raw.ml" in -# 1397 "src/ocaml/preprocess/parser_raw.mly" +# 1362 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 19426 "src/ocaml/preprocess/parser_raw.ml" +# 25393 "src/ocaml/preprocess/parser_raw.ml" in # 213 "" ( x :: xs ) -# 19432 "src/ocaml/preprocess/parser_raw.ml" +# 25399 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19467,7 +25434,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 124 "" ( None ) -# 19471 "src/ocaml/preprocess/parser_raw.ml" +# 25438 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -19475,9 +25442,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19481 "src/ocaml/preprocess/parser_raw.ml" +# 25448 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19485,7 +25452,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3207 "src/ocaml/preprocess/parser_raw.mly" +# 3172 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19499,13 +25466,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19503 "src/ocaml/preprocess/parser_raw.ml" +# 25470 "src/ocaml/preprocess/parser_raw.ml" in -# 1322 "src/ocaml/preprocess/parser_raw.mly" +# 1287 "src/ocaml/preprocess/parser_raw.mly" ( [x], None ) -# 19509 "src/ocaml/preprocess/parser_raw.ml" +# 25476 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19551,7 +25518,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.pattern) list * unit option) = let _2 = # 126 "" ( Some x ) -# 19555 "src/ocaml/preprocess/parser_raw.ml" +# 25522 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -19559,9 +25526,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19565 "src/ocaml/preprocess/parser_raw.ml" +# 25532 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19569,7 +25536,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3207 "src/ocaml/preprocess/parser_raw.mly" +# 3172 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19583,13 +25550,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19587 "src/ocaml/preprocess/parser_raw.ml" +# 25554 "src/ocaml/preprocess/parser_raw.ml" in -# 1322 "src/ocaml/preprocess/parser_raw.mly" +# 1287 "src/ocaml/preprocess/parser_raw.mly" ( [x], None ) -# 19593 "src/ocaml/preprocess/parser_raw.ml" +# 25560 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19652,9 +25619,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19658 "src/ocaml/preprocess/parser_raw.ml" +# 25625 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19662,7 +25629,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3207 "src/ocaml/preprocess/parser_raw.mly" +# 3172 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19676,13 +25643,13 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19680 "src/ocaml/preprocess/parser_raw.ml" +# 25647 "src/ocaml/preprocess/parser_raw.ml" in -# 1324 "src/ocaml/preprocess/parser_raw.mly" +# 1289 "src/ocaml/preprocess/parser_raw.mly" ( [x], Some y ) -# 19686 "src/ocaml/preprocess/parser_raw.ml" +# 25653 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19738,9 +25705,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 19744 "src/ocaml/preprocess/parser_raw.ml" +# 25711 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -19748,7 +25715,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 3207 "src/ocaml/preprocess/parser_raw.mly" +# 3172 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, pat = match opat with | None -> @@ -19762,158 +25729,14 @@ module Tables = struct in label, mkpat_opt_constraint ~loc:constraint_loc pat octy ) -# 19766 "src/ocaml/preprocess/parser_raw.ml" +# 25733 "src/ocaml/preprocess/parser_raw.ml" in -# 1328 "src/ocaml/preprocess/parser_raw.mly" +# 1293 "src/ocaml/preprocess/parser_raw.mly" ( let xs, y = tail in x :: xs, y ) -# 19773 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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 * - Parsetree.value_constraint option * 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 - -# 4258 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 19836 "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 - -# 4262 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 19846 "src/ocaml/preprocess/parser_raw.ml" - - in - -# 4275 "src/ocaml/preprocess/parser_raw.mly" - ( _1, _2 ) -# 19852 "src/ocaml/preprocess/parser_raw.ml" - - in - let _loc__4_ = (_startpos__4_, _endpos__4_) in - -# 4315 "src/ocaml/preprocess/parser_raw.mly" - ( let (ext, attr) = _2 in - mklbs ext _3 (mklb ~loc:_loc__4_ true _4 (attr@_5)) ) -# 19860 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - MenhirLib.EngineTypes.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) = -# 4319 "src/ocaml/preprocess/parser_raw.mly" - ( _1 ) -# 19885 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - 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) = -# 4320 "src/ocaml/preprocess/parser_raw.mly" - ( addlb _1 _2 ) -# 19917 "src/ocaml/preprocess/parser_raw.ml" +# 25740 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -19950,9 +25773,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.case) = -# 2932 "src/ocaml/preprocess/parser_raw.mly" +# 2897 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 (merloc _endpos__2_ _3) ) -# 19956 "src/ocaml/preprocess/parser_raw.ml" +# 25779 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20003,9 +25826,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.case) = -# 2934 "src/ocaml/preprocess/parser_raw.mly" +# 2899 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 ~guard:(merloc _endpos__2_ _3) (merloc _endpos__4_ _5) ) -# 20009 "src/ocaml/preprocess/parser_raw.ml" +# 25832 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20043,10 +25866,10 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.case) = let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2936 "src/ocaml/preprocess/parser_raw.mly" +# 2901 "src/ocaml/preprocess/parser_raw.mly" ( Exp.case _1 (merloc _endpos__2_ (Exp.unreachable ~loc:(make_loc _loc__3_) ())) ) -# 20050 "src/ocaml/preprocess/parser_raw.ml" +# 25873 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20107,9 +25930,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20113 "src/ocaml/preprocess/parser_raw.ml" +# 25936 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20118,49 +25941,49 @@ module Tables = struct let _6 = let _1 = _1_inlined3 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20124 "src/ocaml/preprocess/parser_raw.ml" +# 25947 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20133 "src/ocaml/preprocess/parser_raw.ml" +# 25956 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3600 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20142 "src/ocaml/preprocess/parser_raw.ml" +# 25965 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20149 "src/ocaml/preprocess/parser_raw.ml" +# 25972 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20157 "src/ocaml/preprocess/parser_raw.ml" +# 25980 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3901 "src/ocaml/preprocess/parser_raw.mly" +# 3866 "src/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__4_ with | Some _ as info_before_semi -> info_before_semi @@ -20168,13 +25991,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20172 "src/ocaml/preprocess/parser_raw.ml" +# 25995 "src/ocaml/preprocess/parser_raw.ml" in -# 3882 "src/ocaml/preprocess/parser_raw.mly" +# 3847 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = tail in (head :: f, c) ) -# 20178 "src/ocaml/preprocess/parser_raw.ml" +# 26001 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20215,15 +26038,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3912 "src/ocaml/preprocess/parser_raw.mly" +# 3877 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20221 "src/ocaml/preprocess/parser_raw.ml" +# 26044 "src/ocaml/preprocess/parser_raw.ml" in -# 3882 "src/ocaml/preprocess/parser_raw.mly" +# 3847 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = tail in (head :: f, c) ) -# 20227 "src/ocaml/preprocess/parser_raw.ml" +# 26050 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20277,9 +26100,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20283 "src/ocaml/preprocess/parser_raw.ml" +# 26106 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20288,49 +26111,49 @@ module Tables = struct let _6 = let _1 = _1_inlined3 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20294 "src/ocaml/preprocess/parser_raw.ml" +# 26117 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos__1_inlined3_ in let _4 = let _1 = _1_inlined2 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20303 "src/ocaml/preprocess/parser_raw.ml" +# 26126 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3600 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20312 "src/ocaml/preprocess/parser_raw.ml" +# 26135 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20319 "src/ocaml/preprocess/parser_raw.ml" +# 26142 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20327 "src/ocaml/preprocess/parser_raw.ml" +# 26150 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3901 "src/ocaml/preprocess/parser_raw.mly" +# 3866 "src/ocaml/preprocess/parser_raw.mly" ( let info = match rhs_info _endpos__4_ with | Some _ as info_before_semi -> info_before_semi @@ -20338,13 +26161,13 @@ module Tables = struct in let attrs = add_info_attrs info (_4 @ _6) in Of.tag ~loc:(make_loc _sloc) ~attrs _1 _3 ) -# 20342 "src/ocaml/preprocess/parser_raw.ml" +# 26165 "src/ocaml/preprocess/parser_raw.ml" in -# 3885 "src/ocaml/preprocess/parser_raw.mly" +# 3850 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20348 "src/ocaml/preprocess/parser_raw.ml" +# 26171 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20378,15 +26201,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3912 "src/ocaml/preprocess/parser_raw.mly" +# 3877 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20384 "src/ocaml/preprocess/parser_raw.ml" +# 26207 "src/ocaml/preprocess/parser_raw.ml" in -# 3885 "src/ocaml/preprocess/parser_raw.mly" +# 3850 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20390 "src/ocaml/preprocess/parser_raw.ml" +# 26213 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20426,9 +26249,9 @@ module Tables = struct let _1_inlined1 : (Parsetree.core_type) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20432 "src/ocaml/preprocess/parser_raw.ml" +# 26255 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -20437,50 +26260,50 @@ module Tables = struct let _4 = let _1 = _1_inlined2 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20443 "src/ocaml/preprocess/parser_raw.ml" +# 26266 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__4_ = _endpos__1_inlined2_ in let _3 = let _1 = _1_inlined1 in -# 3635 "src/ocaml/preprocess/parser_raw.mly" +# 3600 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20452 "src/ocaml/preprocess/parser_raw.ml" +# 26275 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20459 "src/ocaml/preprocess/parser_raw.ml" +# 26282 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20467 "src/ocaml/preprocess/parser_raw.ml" +# 26290 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3894 "src/ocaml/preprocess/parser_raw.mly" +# 3859 "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 ) -# 20478 "src/ocaml/preprocess/parser_raw.ml" +# 26301 "src/ocaml/preprocess/parser_raw.ml" in -# 3888 "src/ocaml/preprocess/parser_raw.mly" +# 3853 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20484 "src/ocaml/preprocess/parser_raw.ml" +# 26307 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20507,15 +26330,15 @@ module Tables = struct let _symbolstartpos = _startpos_ty_ in let _sloc = (_symbolstartpos, _endpos) in -# 3912 "src/ocaml/preprocess/parser_raw.mly" +# 3877 "src/ocaml/preprocess/parser_raw.mly" ( Of.inherit_ ~loc:(make_loc _sloc) ty ) -# 20513 "src/ocaml/preprocess/parser_raw.ml" +# 26336 "src/ocaml/preprocess/parser_raw.ml" in -# 3888 "src/ocaml/preprocess/parser_raw.mly" +# 3853 "src/ocaml/preprocess/parser_raw.mly" ( [head], Closed ) -# 20519 "src/ocaml/preprocess/parser_raw.ml" +# 26342 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20538,9 +26361,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.object_field list * Asttypes.closed_flag) = -# 3890 "src/ocaml/preprocess/parser_raw.mly" +# 3855 "src/ocaml/preprocess/parser_raw.mly" ( [], Open ) -# 20544 "src/ocaml/preprocess/parser_raw.ml" +# 26367 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20585,9 +26408,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20591 "src/ocaml/preprocess/parser_raw.ml" +# 26414 "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 @@ -20598,41 +26421,41 @@ module Tables = struct Parsetree.attributes) = let ty = let _1 = _1_inlined2 in -# 3631 "src/ocaml/preprocess/parser_raw.mly" +# 3596 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20604 "src/ocaml/preprocess/parser_raw.ml" +# 26427 "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 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20612 "src/ocaml/preprocess/parser_raw.ml" +# 26435 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20620 "src/ocaml/preprocess/parser_raw.ml" +# 26443 "src/ocaml/preprocess/parser_raw.ml" in let attrs = -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20626 "src/ocaml/preprocess/parser_raw.ml" +# 26449 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4161 "src/ocaml/preprocess/parser_raw.mly" +# 4126 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20631 "src/ocaml/preprocess/parser_raw.ml" +# 26454 "src/ocaml/preprocess/parser_raw.ml" in -# 2217 "src/ocaml/preprocess/parser_raw.mly" +# 2182 "src/ocaml/preprocess/parser_raw.mly" ( (label, private_, Cfk_virtual ty), attrs ) -# 20636 "src/ocaml/preprocess/parser_raw.ml" +# 26459 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20670,9 +26493,9 @@ module Tables = struct } = _menhir_stack in let _5 : (Parsetree.expression) = Obj.magic _5 in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20676 "src/ocaml/preprocess/parser_raw.ml" +# 26499 "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 @@ -20683,36 +26506,36 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20689 "src/ocaml/preprocess/parser_raw.ml" +# 26512 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20697 "src/ocaml/preprocess/parser_raw.ml" +# 26520 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20703 "src/ocaml/preprocess/parser_raw.ml" +# 26526 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4164 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20708 "src/ocaml/preprocess/parser_raw.ml" +# 26531 "src/ocaml/preprocess/parser_raw.ml" in -# 2219 "src/ocaml/preprocess/parser_raw.mly" +# 2184 "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 ) -# 20716 "src/ocaml/preprocess/parser_raw.ml" +# 26539 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20756,9 +26579,9 @@ module Tables = struct } = _menhir_stack in let _5 : (Parsetree.expression) = Obj.magic _5 in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20762 "src/ocaml/preprocess/parser_raw.ml" +# 26585 "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 @@ -20770,39 +26593,39 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20776 "src/ocaml/preprocess/parser_raw.ml" +# 26599 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20784 "src/ocaml/preprocess/parser_raw.ml" +# 26607 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20792 "src/ocaml/preprocess/parser_raw.ml" +# 26615 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4165 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 20798 "src/ocaml/preprocess/parser_raw.ml" +# 26621 "src/ocaml/preprocess/parser_raw.ml" in -# 2219 "src/ocaml/preprocess/parser_raw.mly" +# 2184 "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 ) -# 20806 "src/ocaml/preprocess/parser_raw.ml" +# 26629 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20861,9 +26684,9 @@ module Tables = struct let _1_inlined2 : (Parsetree.core_type) = Obj.magic _1_inlined2 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20867 "src/ocaml/preprocess/parser_raw.ml" +# 26690 "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 @@ -20874,45 +26697,45 @@ module Tables = struct Parsetree.attributes) = let _6 = let _1 = _1_inlined2 in -# 3631 "src/ocaml/preprocess/parser_raw.mly" +# 3596 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20880 "src/ocaml/preprocess/parser_raw.ml" +# 26703 "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 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20889 "src/ocaml/preprocess/parser_raw.ml" +# 26712 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 20897 "src/ocaml/preprocess/parser_raw.ml" +# 26720 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20903 "src/ocaml/preprocess/parser_raw.ml" +# 26726 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4164 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 20908 "src/ocaml/preprocess/parser_raw.ml" +# 26731 "src/ocaml/preprocess/parser_raw.ml" in -# 2225 "src/ocaml/preprocess/parser_raw.mly" +# 2190 "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 ) -# 20916 "src/ocaml/preprocess/parser_raw.ml" +# 26739 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -20977,9 +26800,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.core_type) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 20983 "src/ocaml/preprocess/parser_raw.ml" +# 26806 "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 @@ -20991,48 +26814,48 @@ module Tables = struct Parsetree.attributes) = let _6 = let _1 = _1_inlined3 in -# 3631 "src/ocaml/preprocess/parser_raw.mly" +# 3596 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 20997 "src/ocaml/preprocess/parser_raw.ml" +# 26820 "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 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21006 "src/ocaml/preprocess/parser_raw.ml" +# 26829 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21014 "src/ocaml/preprocess/parser_raw.ml" +# 26837 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21022 "src/ocaml/preprocess/parser_raw.ml" +# 26845 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4165 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 21028 "src/ocaml/preprocess/parser_raw.ml" +# 26851 "src/ocaml/preprocess/parser_raw.ml" in -# 2225 "src/ocaml/preprocess/parser_raw.mly" +# 2190 "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 ) -# 21036 "src/ocaml/preprocess/parser_raw.ml" +# 26859 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21112,9 +26935,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21118 "src/ocaml/preprocess/parser_raw.ml" +# 26941 "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 @@ -21123,38 +26946,38 @@ module Tables = struct let _endpos = _endpos__11_ in let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) * Parsetree.attributes) = let _7 = -# 2809 "src/ocaml/preprocess/parser_raw.mly" +# 2774 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 21129 "src/ocaml/preprocess/parser_raw.ml" +# 26952 "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 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21137 "src/ocaml/preprocess/parser_raw.ml" +# 26960 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21145 "src/ocaml/preprocess/parser_raw.ml" +# 26968 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21152 "src/ocaml/preprocess/parser_raw.ml" +# 26975 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = -# 4164 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 21158 "src/ocaml/preprocess/parser_raw.ml" +# 26981 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__11_ in @@ -21170,7 +26993,7 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2231 "src/ocaml/preprocess/parser_raw.mly" +# 2196 "src/ocaml/preprocess/parser_raw.mly" ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in let poly_exp = let exp, poly = @@ -21181,7 +27004,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21185 "src/ocaml/preprocess/parser_raw.ml" +# 27008 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21267,9 +27090,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21273 "src/ocaml/preprocess/parser_raw.ml" +# 27096 "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 @@ -21279,41 +27102,41 @@ module Tables = struct let _endpos = _endpos__11_ in let _v : ((string Location.loc * Asttypes.private_flag * Parsetree.class_field_kind) * Parsetree.attributes) = let _7 = -# 2809 "src/ocaml/preprocess/parser_raw.mly" +# 2774 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 21285 "src/ocaml/preprocess/parser_raw.ml" +# 27108 "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 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21293 "src/ocaml/preprocess/parser_raw.ml" +# 27116 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 21301 "src/ocaml/preprocess/parser_raw.ml" +# 27124 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21310 "src/ocaml/preprocess/parser_raw.ml" +# 27133 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = -# 4165 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 21317 "src/ocaml/preprocess/parser_raw.ml" +# 27140 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__11_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -21328,7 +27151,7 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2231 "src/ocaml/preprocess/parser_raw.mly" +# 2196 "src/ocaml/preprocess/parser_raw.mly" ( let poly_exp_loc = (_startpos__7_, _endpos__11_) in let poly_exp = let exp, poly = @@ -21339,7 +27162,7 @@ module Tables = struct ghexp ~loc:poly_exp_loc (Pexp_poly(exp, Some poly)) in (_4, _3, Cfk_concrete (_1, poly_exp)), _2 ) -# 21343 "src/ocaml/preprocess/parser_raw.ml" +# 27166 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21358,17 +27181,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21364 "src/ocaml/preprocess/parser_raw.ml" +# 27187 "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) = -# 4015 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21372 "src/ocaml/preprocess/parser_raw.ml" +# 27195 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21399,9 +27222,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21405 "src/ocaml/preprocess/parser_raw.ml" +# 27228 "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 @@ -21409,9 +27232,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 4016 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21415 "src/ocaml/preprocess/parser_raw.ml" +# 27238 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21430,17 +27253,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21436 "src/ocaml/preprocess/parser_raw.ml" +# 27259 "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) = -# 4015 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21444 "src/ocaml/preprocess/parser_raw.ml" +# 27267 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21471,9 +27294,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21477 "src/ocaml/preprocess/parser_raw.ml" +# 27300 "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 @@ -21481,9 +27304,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 4016 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21487 "src/ocaml/preprocess/parser_raw.ml" +# 27310 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21506,14 +27329,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = let _1 = -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4020 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21512 "src/ocaml/preprocess/parser_raw.ml" +# 27335 "src/ocaml/preprocess/parser_raw.ml" in -# 4015 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21517 "src/ocaml/preprocess/parser_raw.ml" +# 27340 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21551,20 +27374,20 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Longident.t) = let _1 = let _1 = -# 3995 "src/ocaml/preprocess/parser_raw.mly" +# 3960 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 21557 "src/ocaml/preprocess/parser_raw.ml" +# 27380 "src/ocaml/preprocess/parser_raw.ml" in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4020 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21562 "src/ocaml/preprocess/parser_raw.ml" +# 27385 "src/ocaml/preprocess/parser_raw.ml" in -# 4015 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21568 "src/ocaml/preprocess/parser_raw.ml" +# 27391 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21587,14 +27410,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = let _1 = -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4020 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21593 "src/ocaml/preprocess/parser_raw.ml" +# 27416 "src/ocaml/preprocess/parser_raw.ml" in -# 4015 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21598 "src/ocaml/preprocess/parser_raw.ml" +# 27421 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21633,15 +27456,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4020 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21639 "src/ocaml/preprocess/parser_raw.ml" +# 27462 "src/ocaml/preprocess/parser_raw.ml" in -# 4016 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21645 "src/ocaml/preprocess/parser_raw.ml" +# 27468 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21694,20 +27517,20 @@ module Tables = struct let _v : (Longident.t) = let _3 = let (_2, _1) = (_2_inlined1, _1_inlined1) in let _1 = -# 3995 "src/ocaml/preprocess/parser_raw.mly" +# 3960 "src/ocaml/preprocess/parser_raw.mly" ( "::" ) -# 21700 "src/ocaml/preprocess/parser_raw.ml" +# 27523 "src/ocaml/preprocess/parser_raw.ml" in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4020 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21705 "src/ocaml/preprocess/parser_raw.ml" +# 27528 "src/ocaml/preprocess/parser_raw.ml" in -# 4016 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21711 "src/ocaml/preprocess/parser_raw.ml" +# 27534 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21746,15 +27569,15 @@ module Tables = struct let _v : (Longident.t) = let _3 = let _1 = _1_inlined1 in -# 4055 "src/ocaml/preprocess/parser_raw.mly" +# 4020 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 21752 "src/ocaml/preprocess/parser_raw.ml" +# 27575 "src/ocaml/preprocess/parser_raw.ml" in -# 4016 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21758 "src/ocaml/preprocess/parser_raw.ml" +# 27581 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21777,9 +27600,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4015 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21783 "src/ocaml/preprocess/parser_raw.ml" +# 27606 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21816,9 +27639,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 4016 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21822 "src/ocaml/preprocess/parser_raw.ml" +# 27645 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21837,17 +27660,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21843 "src/ocaml/preprocess/parser_raw.ml" +# 27666 "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) = -# 4015 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21851 "src/ocaml/preprocess/parser_raw.ml" +# 27674 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21878,9 +27701,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21884 "src/ocaml/preprocess/parser_raw.ml" +# 27707 "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 @@ -21888,9 +27711,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 4016 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21894 "src/ocaml/preprocess/parser_raw.ml" +# 27717 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21909,17 +27732,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21915 "src/ocaml/preprocess/parser_raw.ml" +# 27738 "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) = -# 4015 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21923 "src/ocaml/preprocess/parser_raw.ml" +# 27746 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21950,9 +27773,9 @@ module Tables = struct }; } = _menhir_stack in let _3 : ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 21956 "src/ocaml/preprocess/parser_raw.ml" +# 27779 "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 @@ -21960,9 +27783,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 4016 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 21966 "src/ocaml/preprocess/parser_raw.ml" +# 27789 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -21985,9 +27808,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4015 "src/ocaml/preprocess/parser_raw.mly" +# 3980 "src/ocaml/preprocess/parser_raw.mly" ( Lident _1 ) -# 21991 "src/ocaml/preprocess/parser_raw.ml" +# 27814 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22024,9 +27847,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Longident.t) = -# 4016 "src/ocaml/preprocess/parser_raw.mly" +# 3981 "src/ocaml/preprocess/parser_raw.mly" ( Ldot(_1,_3) ) -# 22030 "src/ocaml/preprocess/parser_raw.ml" +# 27853 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22049,9 +27872,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4031 "src/ocaml/preprocess/parser_raw.mly" +# 3996 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22055 "src/ocaml/preprocess/parser_raw.ml" +# 27878 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22098,9 +27921,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4033 "src/ocaml/preprocess/parser_raw.mly" +# 3998 "src/ocaml/preprocess/parser_raw.mly" ( lapply ~loc:_sloc _1 _3 ) -# 22104 "src/ocaml/preprocess/parser_raw.ml" +# 27927 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22123,9 +27946,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4028 "src/ocaml/preprocess/parser_raw.mly" +# 3993 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22129 "src/ocaml/preprocess/parser_raw.ml" +# 27952 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22155,9 +27978,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = -# 1674 "src/ocaml/preprocess/parser_raw.mly" +# 1639 "src/ocaml/preprocess/parser_raw.mly" ( me ) -# 22161 "src/ocaml/preprocess/parser_raw.ml" +# 27984 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22202,24 +28025,24 @@ module Tables = struct let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1681 "src/ocaml/preprocess/parser_raw.mly" +# 1646 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_constraint(me, mty) ) -# 22208 "src/ocaml/preprocess/parser_raw.ml" +# 28031 "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 -# 1105 "src/ocaml/preprocess/parser_raw.mly" +# 1070 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22217 "src/ocaml/preprocess/parser_raw.ml" +# 28040 "src/ocaml/preprocess/parser_raw.ml" in -# 1685 "src/ocaml/preprocess/parser_raw.mly" +# 1650 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22223 "src/ocaml/preprocess/parser_raw.ml" +# 28046 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22250,25 +28073,25 @@ module Tables = struct let _endpos = _endpos_body_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1683 "src/ocaml/preprocess/parser_raw.mly" +# 1648 "src/ocaml/preprocess/parser_raw.mly" ( let (_, arg) = arg_and_pos in Pmod_functor(arg, body) ) -# 22257 "src/ocaml/preprocess/parser_raw.ml" +# 28080 "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 -# 1105 "src/ocaml/preprocess/parser_raw.mly" +# 1070 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22266 "src/ocaml/preprocess/parser_raw.ml" +# 28089 "src/ocaml/preprocess/parser_raw.ml" in -# 1685 "src/ocaml/preprocess/parser_raw.mly" +# 1650 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22272 "src/ocaml/preprocess/parser_raw.ml" +# 28095 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22298,9 +28121,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_mty_ in let _v : (Parsetree.module_type) = -# 1934 "src/ocaml/preprocess/parser_raw.mly" +# 1899 "src/ocaml/preprocess/parser_raw.mly" ( mty ) -# 22304 "src/ocaml/preprocess/parser_raw.ml" +# 28127 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22331,25 +28154,25 @@ module Tables = struct let _endpos = _endpos_body_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1941 "src/ocaml/preprocess/parser_raw.mly" +# 1906 "src/ocaml/preprocess/parser_raw.mly" ( let (_, arg) = arg_and_pos in Pmty_functor(arg, body) ) -# 22338 "src/ocaml/preprocess/parser_raw.ml" +# 28161 "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 -# 1107 "src/ocaml/preprocess/parser_raw.mly" +# 1072 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 22347 "src/ocaml/preprocess/parser_raw.ml" +# 28170 "src/ocaml/preprocess/parser_raw.ml" in -# 1944 "src/ocaml/preprocess/parser_raw.mly" +# 1909 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22353 "src/ocaml/preprocess/parser_raw.ml" +# 28176 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22395,18 +28218,18 @@ module Tables = struct let _v : (Parsetree.module_expr) = let attrs = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22401 "src/ocaml/preprocess/parser_raw.ml" +# 28224 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1498 "src/ocaml/preprocess/parser_raw.mly" +# 1463 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_structure s) ) -# 22410 "src/ocaml/preprocess/parser_raw.ml" +# 28233 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22459,22 +28282,22 @@ module Tables = struct let _v : (Parsetree.module_expr) = let attrs = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22465 "src/ocaml/preprocess/parser_raw.ml" +# 28288 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_me_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1508 "src/ocaml/preprocess/parser_raw.mly" +# 1473 "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 ) ) -# 22478 "src/ocaml/preprocess/parser_raw.ml" +# 28301 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22497,9 +28320,9 @@ module Tables = struct let _startpos = _startpos_me_ in let _endpos = _endpos_me_ in let _v : (Parsetree.module_expr) = -# 1514 "src/ocaml/preprocess/parser_raw.mly" +# 1479 "src/ocaml/preprocess/parser_raw.mly" ( me ) -# 22503 "src/ocaml/preprocess/parser_raw.ml" +# 28326 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22529,9 +28352,9 @@ module Tables = struct let _startpos = _startpos_me_ in let _endpos = _endpos_attr_ in let _v : (Parsetree.module_expr) = -# 1516 "src/ocaml/preprocess/parser_raw.mly" +# 1481 "src/ocaml/preprocess/parser_raw.mly" ( Mod.attr me attr ) -# 22535 "src/ocaml/preprocess/parser_raw.ml" +# 28358 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22560,30 +28383,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22566 "src/ocaml/preprocess/parser_raw.ml" +# 28389 "src/ocaml/preprocess/parser_raw.ml" in -# 1520 "src/ocaml/preprocess/parser_raw.mly" +# 1485 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_ident x ) -# 22572 "src/ocaml/preprocess/parser_raw.ml" +# 28395 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1105 "src/ocaml/preprocess/parser_raw.mly" +# 1070 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22581 "src/ocaml/preprocess/parser_raw.ml" +# 28404 "src/ocaml/preprocess/parser_raw.ml" in -# 1535 "src/ocaml/preprocess/parser_raw.mly" +# 1500 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22587 "src/ocaml/preprocess/parser_raw.ml" +# 28410 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22614,24 +28437,24 @@ module Tables = struct let _endpos = _endpos_me2_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1523 "src/ocaml/preprocess/parser_raw.mly" +# 1488 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_apply(me1, me2) ) -# 22620 "src/ocaml/preprocess/parser_raw.ml" +# 28443 "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 -# 1105 "src/ocaml/preprocess/parser_raw.mly" +# 1070 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22629 "src/ocaml/preprocess/parser_raw.ml" +# 28452 "src/ocaml/preprocess/parser_raw.ml" in -# 1535 "src/ocaml/preprocess/parser_raw.mly" +# 1500 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22635 "src/ocaml/preprocess/parser_raw.ml" +# 28458 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22669,24 +28492,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1526 "src/ocaml/preprocess/parser_raw.mly" +# 1491 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_apply_unit me ) -# 22675 "src/ocaml/preprocess/parser_raw.ml" +# 28498 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_me_) in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1105 "src/ocaml/preprocess/parser_raw.mly" +# 1070 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22684 "src/ocaml/preprocess/parser_raw.ml" +# 28507 "src/ocaml/preprocess/parser_raw.ml" in -# 1535 "src/ocaml/preprocess/parser_raw.mly" +# 1500 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22690 "src/ocaml/preprocess/parser_raw.ml" +# 28513 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22710,24 +28533,24 @@ module Tables = struct let _endpos = _endpos_ex_ in let _v : (Parsetree.module_expr) = let _1 = let _1 = -# 1529 "src/ocaml/preprocess/parser_raw.mly" +# 1494 "src/ocaml/preprocess/parser_raw.mly" ( Pmod_extension ex ) -# 22716 "src/ocaml/preprocess/parser_raw.ml" +# 28539 "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 -# 1105 "src/ocaml/preprocess/parser_raw.mly" +# 1070 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22725 "src/ocaml/preprocess/parser_raw.ml" +# 28548 "src/ocaml/preprocess/parser_raw.ml" in -# 1535 "src/ocaml/preprocess/parser_raw.mly" +# 1500 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22731 "src/ocaml/preprocess/parser_raw.ml" +# 28554 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22755,25 +28578,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 1532 "src/ocaml/preprocess/parser_raw.mly" +# 1497 "src/ocaml/preprocess/parser_raw.mly" ( let id = mkrhs Ast_helper.hole_txt _loc in Pmod_extension (id, PStr []) ) -# 22762 "src/ocaml/preprocess/parser_raw.ml" +# 28585 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1105 "src/ocaml/preprocess/parser_raw.mly" +# 1070 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc _1 ) -# 22771 "src/ocaml/preprocess/parser_raw.ml" +# 28594 "src/ocaml/preprocess/parser_raw.ml" in -# 1535 "src/ocaml/preprocess/parser_raw.mly" +# 1500 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22777 "src/ocaml/preprocess/parser_raw.ml" +# 28600 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22792,17 +28615,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let x : ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 22798 "src/ocaml/preprocess/parser_raw.ml" +# 28621 "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) = -# 1481 "src/ocaml/preprocess/parser_raw.mly" +# 1446 "src/ocaml/preprocess/parser_raw.mly" ( Some x ) -# 22806 "src/ocaml/preprocess/parser_raw.ml" +# 28629 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22825,9 +28648,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string option) = -# 1484 "src/ocaml/preprocess/parser_raw.mly" +# 1449 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 22831 "src/ocaml/preprocess/parser_raw.ml" +# 28654 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22885,9 +28708,9 @@ module Tables = struct let _1_inlined3 : (Longident.t) = Obj.magic _1_inlined3 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 22891 "src/ocaml/preprocess/parser_raw.ml" +# 28714 "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 @@ -22898,9 +28721,9 @@ module Tables = struct let _v : (Parsetree.module_substitution * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22904 "src/ocaml/preprocess/parser_raw.ml" +# 28727 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -22910,9 +28733,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22916 "src/ocaml/preprocess/parser_raw.ml" +# 28739 "src/ocaml/preprocess/parser_raw.ml" in let uid = @@ -22921,31 +28744,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 22927 "src/ocaml/preprocess/parser_raw.ml" +# 28750 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22935 "src/ocaml/preprocess/parser_raw.ml" +# 28758 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1974 "src/ocaml/preprocess/parser_raw.mly" +# 1939 "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 ) -# 22949 "src/ocaml/preprocess/parser_raw.ml" +# 28772 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -22991,18 +28814,18 @@ module Tables = struct let _v : (Parsetree.module_type) = let attrs = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 22997 "src/ocaml/preprocess/parser_raw.ml" +# 28820 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1810 "src/ocaml/preprocess/parser_raw.mly" +# 1775 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc ~attrs (Pmty_signature s) ) -# 23006 "src/ocaml/preprocess/parser_raw.ml" +# 28829 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23055,22 +28878,22 @@ module Tables = struct let _v : (Parsetree.module_type) = let attrs = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23061 "src/ocaml/preprocess/parser_raw.ml" +# 28884 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_mty_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1822 "src/ocaml/preprocess/parser_raw.mly" +# 1787 "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 ) ) -# 23074 "src/ocaml/preprocess/parser_raw.ml" +# 28897 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23123,18 +28946,18 @@ module Tables = struct let _v : (Parsetree.module_type) = let _4 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23129 "src/ocaml/preprocess/parser_raw.ml" +# 28952 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1828 "src/ocaml/preprocess/parser_raw.mly" +# 1793 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc ~attrs:_4 (Pmty_typeof _5) ) -# 23138 "src/ocaml/preprocess/parser_raw.ml" +# 28961 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23171,9 +28994,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.module_type) = -# 1830 "src/ocaml/preprocess/parser_raw.mly" +# 1795 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 23177 "src/ocaml/preprocess/parser_raw.ml" +# 29000 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23203,9 +29026,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_type) = -# 1836 "src/ocaml/preprocess/parser_raw.mly" +# 1801 "src/ocaml/preprocess/parser_raw.mly" ( Mty.attr _1 _2 ) -# 23209 "src/ocaml/preprocess/parser_raw.ml" +# 29032 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23234,30 +29057,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23240 "src/ocaml/preprocess/parser_raw.ml" +# 29063 "src/ocaml/preprocess/parser_raw.ml" in -# 1839 "src/ocaml/preprocess/parser_raw.mly" +# 1804 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_ident _1 ) -# 23246 "src/ocaml/preprocess/parser_raw.ml" +# 29069 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1107 "src/ocaml/preprocess/parser_raw.mly" +# 1072 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23255 "src/ocaml/preprocess/parser_raw.ml" +# 29078 "src/ocaml/preprocess/parser_raw.ml" in -# 1852 "src/ocaml/preprocess/parser_raw.mly" +# 1817 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23261 "src/ocaml/preprocess/parser_raw.ml" +# 29084 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23302,24 +29125,24 @@ module Tables = struct let _endpos = _endpos__4_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1841 "src/ocaml/preprocess/parser_raw.mly" +# 1806 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_functor(Unit, _4) ) -# 23308 "src/ocaml/preprocess/parser_raw.ml" +# 29131 "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 -# 1107 "src/ocaml/preprocess/parser_raw.mly" +# 1072 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23317 "src/ocaml/preprocess/parser_raw.ml" +# 29140 "src/ocaml/preprocess/parser_raw.ml" in -# 1852 "src/ocaml/preprocess/parser_raw.mly" +# 1817 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23323 "src/ocaml/preprocess/parser_raw.ml" +# 29146 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23357,24 +29180,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1844 "src/ocaml/preprocess/parser_raw.mly" +# 1809 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_functor(Named (mknoloc None, _1), _3) ) -# 23363 "src/ocaml/preprocess/parser_raw.ml" +# 29186 "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 -# 1107 "src/ocaml/preprocess/parser_raw.mly" +# 1072 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23372 "src/ocaml/preprocess/parser_raw.ml" +# 29195 "src/ocaml/preprocess/parser_raw.ml" in -# 1852 "src/ocaml/preprocess/parser_raw.mly" +# 1817 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23378 "src/ocaml/preprocess/parser_raw.ml" +# 29201 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23416,18 +29239,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 23420 "src/ocaml/preprocess/parser_raw.ml" +# 29243 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 23425 "src/ocaml/preprocess/parser_raw.ml" +# 29248 "src/ocaml/preprocess/parser_raw.ml" in -# 1846 "src/ocaml/preprocess/parser_raw.mly" +# 1811 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_with(_1, _3) ) -# 23431 "src/ocaml/preprocess/parser_raw.ml" +# 29254 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_xs_ in @@ -23435,15 +29258,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1107 "src/ocaml/preprocess/parser_raw.mly" +# 1072 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23441 "src/ocaml/preprocess/parser_raw.ml" +# 29264 "src/ocaml/preprocess/parser_raw.ml" in -# 1852 "src/ocaml/preprocess/parser_raw.mly" +# 1817 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23447 "src/ocaml/preprocess/parser_raw.ml" +# 29270 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23467,23 +29290,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.module_type) = let _1 = let _1 = -# 1850 "src/ocaml/preprocess/parser_raw.mly" +# 1815 "src/ocaml/preprocess/parser_raw.mly" ( Pmty_extension _1 ) -# 23473 "src/ocaml/preprocess/parser_raw.ml" +# 29296 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1107 "src/ocaml/preprocess/parser_raw.mly" +# 1072 "src/ocaml/preprocess/parser_raw.mly" ( mkmty ~loc:_sloc _1 ) -# 23481 "src/ocaml/preprocess/parser_raw.ml" +# 29304 "src/ocaml/preprocess/parser_raw.ml" in -# 1852 "src/ocaml/preprocess/parser_raw.mly" +# 1817 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23487 "src/ocaml/preprocess/parser_raw.ml" +# 29310 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23550,9 +29373,9 @@ module Tables = struct let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23556 "src/ocaml/preprocess/parser_raw.ml" +# 29379 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -23562,31 +29385,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23568 "src/ocaml/preprocess/parser_raw.ml" +# 29391 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23576 "src/ocaml/preprocess/parser_raw.ml" +# 29399 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1756 "src/ocaml/preprocess/parser_raw.mly" +# 1721 "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 ) -# 23590 "src/ocaml/preprocess/parser_raw.ml" +# 29413 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23660,9 +29483,9 @@ module Tables = struct let _v : (Parsetree.module_type_declaration * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23666 "src/ocaml/preprocess/parser_raw.ml" +# 29489 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -23672,31 +29495,31 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23678 "src/ocaml/preprocess/parser_raw.ml" +# 29501 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23686 "src/ocaml/preprocess/parser_raw.ml" +# 29509 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2032 "src/ocaml/preprocess/parser_raw.mly" +# 1997 "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 ) -# 23700 "src/ocaml/preprocess/parser_raw.ml" +# 29523 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23719,9 +29542,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4040 "src/ocaml/preprocess/parser_raw.mly" +# 4005 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 23725 "src/ocaml/preprocess/parser_raw.ml" +# 29548 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23737,9 +29560,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.mutable_flag) = -# 4121 "src/ocaml/preprocess/parser_raw.mly" +# 4086 "src/ocaml/preprocess/parser_raw.mly" ( Immutable ) -# 23743 "src/ocaml/preprocess/parser_raw.ml" +# 29566 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23762,9 +29585,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag) = -# 4122 "src/ocaml/preprocess/parser_raw.mly" +# 4087 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 23768 "src/ocaml/preprocess/parser_raw.ml" +# 29591 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23780,9 +29603,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 4130 "src/ocaml/preprocess/parser_raw.mly" +# 4095 "src/ocaml/preprocess/parser_raw.mly" ( Immutable, Concrete ) -# 23786 "src/ocaml/preprocess/parser_raw.ml" +# 29609 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23805,9 +29628,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 4132 "src/ocaml/preprocess/parser_raw.mly" +# 4097 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Concrete ) -# 23811 "src/ocaml/preprocess/parser_raw.ml" +# 29634 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23830,9 +29653,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 4134 "src/ocaml/preprocess/parser_raw.mly" +# 4099 "src/ocaml/preprocess/parser_raw.mly" ( Immutable, Virtual ) -# 23836 "src/ocaml/preprocess/parser_raw.ml" +# 29659 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23862,9 +29685,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 4137 "src/ocaml/preprocess/parser_raw.mly" +# 4102 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Virtual ) -# 23868 "src/ocaml/preprocess/parser_raw.ml" +# 29691 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23894,9 +29717,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag * Asttypes.virtual_flag) = -# 4137 "src/ocaml/preprocess/parser_raw.mly" +# 4102 "src/ocaml/preprocess/parser_raw.mly" ( Mutable, Virtual ) -# 23900 "src/ocaml/preprocess/parser_raw.ml" +# 29723 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23926,9 +29749,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (string) = -# 4092 "src/ocaml/preprocess/parser_raw.mly" +# 4057 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 23932 "src/ocaml/preprocess/parser_raw.ml" +# 29755 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23947,9 +29770,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 23953 "src/ocaml/preprocess/parser_raw.ml" +# 29776 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -23959,15 +29782,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 23965 "src/ocaml/preprocess/parser_raw.ml" +# 29788 "src/ocaml/preprocess/parser_raw.ml" in # 221 "" ( [ x ] ) -# 23971 "src/ocaml/preprocess/parser_raw.ml" +# 29794 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -23993,9 +29816,9 @@ module Tables = struct } = _menhir_stack in let xs : (string Location.loc list) = Obj.magic xs in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 23999 "src/ocaml/preprocess/parser_raw.ml" +# 29822 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -24005,15 +29828,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 24011 "src/ocaml/preprocess/parser_raw.ml" +# 29834 "src/ocaml/preprocess/parser_raw.ml" in # 223 "" ( x :: xs ) -# 24017 "src/ocaml/preprocess/parser_raw.ml" +# 29840 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24032,22 +29855,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let s : ( -# 903 "src/ocaml/preprocess/parser_raw.mly" +# 876 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 24038 "src/ocaml/preprocess/parser_raw.ml" +# 29861 "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 = -# 4088 "src/ocaml/preprocess/parser_raw.mly" +# 4053 "src/ocaml/preprocess/parser_raw.mly" ( let body, _, _ = s in body ) -# 24046 "src/ocaml/preprocess/parser_raw.ml" +# 29869 "src/ocaml/preprocess/parser_raw.ml" in # 221 "" ( [ x ] ) -# 24051 "src/ocaml/preprocess/parser_raw.ml" +# 29874 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24073,22 +29896,22 @@ module Tables = struct } = _menhir_stack in let xs : (string list) = Obj.magic xs in let s : ( -# 903 "src/ocaml/preprocess/parser_raw.mly" +# 876 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 24079 "src/ocaml/preprocess/parser_raw.ml" +# 29902 "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 = -# 4088 "src/ocaml/preprocess/parser_raw.mly" +# 4053 "src/ocaml/preprocess/parser_raw.mly" ( let body, _, _ = s in body ) -# 24087 "src/ocaml/preprocess/parser_raw.ml" +# 29910 "src/ocaml/preprocess/parser_raw.ml" in # 223 "" ( x :: xs ) -# 24092 "src/ocaml/preprocess/parser_raw.ml" +# 29915 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24111,14 +29934,14 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4117 "src/ocaml/preprocess/parser_raw.mly" +# 4082 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24117 "src/ocaml/preprocess/parser_raw.ml" +# 29940 "src/ocaml/preprocess/parser_raw.ml" in -# 3341 "src/ocaml/preprocess/parser_raw.mly" +# 3306 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, priv, Some ty) ) -# 24122 "src/ocaml/preprocess/parser_raw.ml" +# 29945 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24148,14 +29971,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4118 "src/ocaml/preprocess/parser_raw.mly" +# 4083 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24154 "src/ocaml/preprocess/parser_raw.ml" +# 29977 "src/ocaml/preprocess/parser_raw.ml" in -# 3341 "src/ocaml/preprocess/parser_raw.mly" +# 3306 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, priv, Some ty) ) -# 24159 "src/ocaml/preprocess/parser_raw.ml" +# 29982 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24178,26 +30001,26 @@ module Tables = struct let _startpos = _startpos_cs_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4117 "src/ocaml/preprocess/parser_raw.mly" +# 4082 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24184 "src/ocaml/preprocess/parser_raw.ml" +# 30007 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24190 "src/ocaml/preprocess/parser_raw.ml" +# 30013 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24195 "src/ocaml/preprocess/parser_raw.ml" +# 30018 "src/ocaml/preprocess/parser_raw.ml" in -# 3345 "src/ocaml/preprocess/parser_raw.mly" +# 3310 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24201 "src/ocaml/preprocess/parser_raw.ml" +# 30024 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24227,26 +30050,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4118 "src/ocaml/preprocess/parser_raw.mly" +# 4083 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24233 "src/ocaml/preprocess/parser_raw.ml" +# 30056 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24239 "src/ocaml/preprocess/parser_raw.ml" +# 30062 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24244 "src/ocaml/preprocess/parser_raw.ml" +# 30067 "src/ocaml/preprocess/parser_raw.ml" in -# 3345 "src/ocaml/preprocess/parser_raw.mly" +# 3310 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24250 "src/ocaml/preprocess/parser_raw.ml" +# 30073 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24283,33 +30106,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4117 "src/ocaml/preprocess/parser_raw.mly" +# 4082 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24289 "src/ocaml/preprocess/parser_raw.ml" +# 30112 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24296 "src/ocaml/preprocess/parser_raw.ml" +# 30119 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24301 "src/ocaml/preprocess/parser_raw.ml" +# 30124 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24307 "src/ocaml/preprocess/parser_raw.ml" +# 30130 "src/ocaml/preprocess/parser_raw.ml" in -# 3345 "src/ocaml/preprocess/parser_raw.mly" +# 3310 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24313 "src/ocaml/preprocess/parser_raw.ml" +# 30136 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24353,33 +30176,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_cs_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4118 "src/ocaml/preprocess/parser_raw.mly" +# 4083 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24359 "src/ocaml/preprocess/parser_raw.ml" +# 30182 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24366 "src/ocaml/preprocess/parser_raw.ml" +# 30189 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24371 "src/ocaml/preprocess/parser_raw.ml" +# 30194 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24377 "src/ocaml/preprocess/parser_raw.ml" +# 30200 "src/ocaml/preprocess/parser_raw.ml" in -# 3345 "src/ocaml/preprocess/parser_raw.mly" +# 3310 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_variant cs, priv, oty) ) -# 24383 "src/ocaml/preprocess/parser_raw.ml" +# 30206 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24402,26 +30225,26 @@ module Tables = struct let _startpos = _startpos__3_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4117 "src/ocaml/preprocess/parser_raw.mly" +# 4082 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24408 "src/ocaml/preprocess/parser_raw.ml" +# 30231 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24414 "src/ocaml/preprocess/parser_raw.ml" +# 30237 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24419 "src/ocaml/preprocess/parser_raw.ml" +# 30242 "src/ocaml/preprocess/parser_raw.ml" in -# 3349 "src/ocaml/preprocess/parser_raw.mly" +# 3314 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24425 "src/ocaml/preprocess/parser_raw.ml" +# 30248 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24451,26 +30274,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4118 "src/ocaml/preprocess/parser_raw.mly" +# 4083 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24457 "src/ocaml/preprocess/parser_raw.ml" +# 30280 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24463 "src/ocaml/preprocess/parser_raw.ml" +# 30286 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24468 "src/ocaml/preprocess/parser_raw.ml" +# 30291 "src/ocaml/preprocess/parser_raw.ml" in -# 3349 "src/ocaml/preprocess/parser_raw.mly" +# 3314 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24474 "src/ocaml/preprocess/parser_raw.ml" +# 30297 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24507,33 +30330,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4117 "src/ocaml/preprocess/parser_raw.mly" +# 4082 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24513 "src/ocaml/preprocess/parser_raw.ml" +# 30336 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24520 "src/ocaml/preprocess/parser_raw.ml" +# 30343 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24525 "src/ocaml/preprocess/parser_raw.ml" +# 30348 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24531 "src/ocaml/preprocess/parser_raw.ml" +# 30354 "src/ocaml/preprocess/parser_raw.ml" in -# 3349 "src/ocaml/preprocess/parser_raw.mly" +# 3314 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24537 "src/ocaml/preprocess/parser_raw.ml" +# 30360 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24577,33 +30400,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__3_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4118 "src/ocaml/preprocess/parser_raw.mly" +# 4083 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24583 "src/ocaml/preprocess/parser_raw.ml" +# 30406 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24590 "src/ocaml/preprocess/parser_raw.ml" +# 30413 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24595 "src/ocaml/preprocess/parser_raw.ml" +# 30418 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24601 "src/ocaml/preprocess/parser_raw.ml" +# 30424 "src/ocaml/preprocess/parser_raw.ml" in -# 3349 "src/ocaml/preprocess/parser_raw.mly" +# 3314 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_open, priv, oty) ) -# 24607 "src/ocaml/preprocess/parser_raw.ml" +# 30430 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24640,26 +30463,26 @@ module Tables = struct let _startpos = _startpos__3_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4117 "src/ocaml/preprocess/parser_raw.mly" +# 4082 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24646 "src/ocaml/preprocess/parser_raw.ml" +# 30469 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24652 "src/ocaml/preprocess/parser_raw.ml" +# 30475 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24657 "src/ocaml/preprocess/parser_raw.ml" +# 30480 "src/ocaml/preprocess/parser_raw.ml" in -# 3353 "src/ocaml/preprocess/parser_raw.mly" +# 3318 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24663 "src/ocaml/preprocess/parser_raw.ml" +# 30486 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24703,26 +30526,26 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4118 "src/ocaml/preprocess/parser_raw.mly" +# 4083 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24709 "src/ocaml/preprocess/parser_raw.ml" +# 30532 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = # 124 "" ( None ) -# 24715 "src/ocaml/preprocess/parser_raw.ml" +# 30538 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24720 "src/ocaml/preprocess/parser_raw.ml" +# 30543 "src/ocaml/preprocess/parser_raw.ml" in -# 3353 "src/ocaml/preprocess/parser_raw.mly" +# 3318 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24726 "src/ocaml/preprocess/parser_raw.ml" +# 30549 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24773,33 +30596,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4117 "src/ocaml/preprocess/parser_raw.mly" +# 4082 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 24779 "src/ocaml/preprocess/parser_raw.ml" +# 30602 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24786 "src/ocaml/preprocess/parser_raw.ml" +# 30609 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24791 "src/ocaml/preprocess/parser_raw.ml" +# 30614 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24797 "src/ocaml/preprocess/parser_raw.ml" +# 30620 "src/ocaml/preprocess/parser_raw.ml" in -# 3353 "src/ocaml/preprocess/parser_raw.mly" +# 3318 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24803 "src/ocaml/preprocess/parser_raw.ml" +# 30626 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24857,33 +30680,33 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos__5_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = let priv = -# 4118 "src/ocaml/preprocess/parser_raw.mly" +# 4083 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 24863 "src/ocaml/preprocess/parser_raw.ml" +# 30686 "src/ocaml/preprocess/parser_raw.ml" in let oty = let _1 = let x = # 191 "" ( x ) -# 24870 "src/ocaml/preprocess/parser_raw.ml" +# 30693 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 24875 "src/ocaml/preprocess/parser_raw.ml" +# 30698 "src/ocaml/preprocess/parser_raw.ml" in -# 3357 "src/ocaml/preprocess/parser_raw.mly" +# 3322 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24881 "src/ocaml/preprocess/parser_raw.ml" +# 30704 "src/ocaml/preprocess/parser_raw.ml" in -# 3353 "src/ocaml/preprocess/parser_raw.mly" +# 3318 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_record ls, priv, oty) ) -# 24887 "src/ocaml/preprocess/parser_raw.ml" +# 30710 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24921,24 +30744,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3777 "src/ocaml/preprocess/parser_raw.mly" +# 3742 "src/ocaml/preprocess/parser_raw.mly" ( let (f, c) = meth_list in Ptyp_object (f, c) ) -# 24927 "src/ocaml/preprocess/parser_raw.ml" +# 30750 "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 -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 24936 "src/ocaml/preprocess/parser_raw.ml" +# 30759 "src/ocaml/preprocess/parser_raw.ml" in -# 3781 "src/ocaml/preprocess/parser_raw.mly" +# 3746 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24942 "src/ocaml/preprocess/parser_raw.ml" +# 30765 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -24969,24 +30792,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3779 "src/ocaml/preprocess/parser_raw.mly" +# 3744 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_object ([], Closed) ) -# 24975 "src/ocaml/preprocess/parser_raw.ml" +# 30798 "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 -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 24984 "src/ocaml/preprocess/parser_raw.ml" +# 30807 "src/ocaml/preprocess/parser_raw.ml" in -# 3781 "src/ocaml/preprocess/parser_raw.mly" +# 3746 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 24990 "src/ocaml/preprocess/parser_raw.ml" +# 30813 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25039,37 +30862,37 @@ module Tables = struct let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined2 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25045 "src/ocaml/preprocess/parser_raw.ml" +# 30868 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25054 "src/ocaml/preprocess/parser_raw.ml" +# 30877 "src/ocaml/preprocess/parser_raw.ml" in let override = -# 4164 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 25060 "src/ocaml/preprocess/parser_raw.ml" +# 30883 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1775 "src/ocaml/preprocess/parser_raw.mly" +# 1740 "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 ) -# 25073 "src/ocaml/preprocess/parser_raw.ml" +# 30896 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25129,40 +30952,40 @@ module Tables = struct let _v : (Parsetree.module_expr Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25135 "src/ocaml/preprocess/parser_raw.ml" +# 30958 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let attrs1 = let _1 = _1_inlined2 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25144 "src/ocaml/preprocess/parser_raw.ml" +# 30967 "src/ocaml/preprocess/parser_raw.ml" in let override = let _1 = _1_inlined1 in -# 4165 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 25152 "src/ocaml/preprocess/parser_raw.ml" +# 30975 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1775 "src/ocaml/preprocess/parser_raw.mly" +# 1740 "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 ) -# 25166 "src/ocaml/preprocess/parser_raw.ml" +# 30989 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25215,9 +31038,9 @@ module Tables = struct let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25221 "src/ocaml/preprocess/parser_raw.ml" +# 31044 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -25227,36 +31050,36 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 25233 "src/ocaml/preprocess/parser_raw.ml" +# 31056 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25241 "src/ocaml/preprocess/parser_raw.ml" +# 31064 "src/ocaml/preprocess/parser_raw.ml" in let override = -# 4164 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 25247 "src/ocaml/preprocess/parser_raw.ml" +# 31070 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1790 "src/ocaml/preprocess/parser_raw.mly" +# 1755 "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 ) -# 25260 "src/ocaml/preprocess/parser_raw.ml" +# 31083 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25316,9 +31139,9 @@ module Tables = struct let _v : (Longident.t Location.loc Parsetree.open_infos * string Location.loc option) = let attrs2 = let _1 = _1_inlined4 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25322 "src/ocaml/preprocess/parser_raw.ml" +# 31145 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -25328,39 +31151,39 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 25334 "src/ocaml/preprocess/parser_raw.ml" +# 31157 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined2 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25342 "src/ocaml/preprocess/parser_raw.ml" +# 31165 "src/ocaml/preprocess/parser_raw.ml" in let override = let _1 = _1_inlined1 in -# 4165 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 25350 "src/ocaml/preprocess/parser_raw.ml" +# 31173 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1790 "src/ocaml/preprocess/parser_raw.mly" +# 1755 "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 ) -# 25364 "src/ocaml/preprocess/parser_raw.ml" +# 31187 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25379,17 +31202,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 889 "src/ocaml/preprocess/parser_raw.mly" +# 862 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25385 "src/ocaml/preprocess/parser_raw.ml" +# 31208 "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) = -# 3954 "src/ocaml/preprocess/parser_raw.mly" +# 3919 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25393 "src/ocaml/preprocess/parser_raw.ml" +# 31216 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25408,17 +31231,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 847 "src/ocaml/preprocess/parser_raw.mly" +# 820 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25414 "src/ocaml/preprocess/parser_raw.ml" +# 31237 "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) = -# 3955 "src/ocaml/preprocess/parser_raw.mly" +# 3920 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25422 "src/ocaml/preprocess/parser_raw.ml" +# 31245 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25437,17 +31260,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 848 "src/ocaml/preprocess/parser_raw.mly" +# 821 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25443 "src/ocaml/preprocess/parser_raw.ml" +# 31266 "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) = -# 3956 "src/ocaml/preprocess/parser_raw.mly" +# 3921 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25451 "src/ocaml/preprocess/parser_raw.ml" +# 31274 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25487,17 +31310,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25493 "src/ocaml/preprocess/parser_raw.ml" +# 31316 "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) = -# 3957 "src/ocaml/preprocess/parser_raw.mly" +# 3922 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"(" ^ _3 ^ ")" ) -# 25501 "src/ocaml/preprocess/parser_raw.ml" +# 31324 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25544,17 +31367,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25550 "src/ocaml/preprocess/parser_raw.ml" +# 31373 "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) = -# 3958 "src/ocaml/preprocess/parser_raw.mly" +# 3923 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "(" ^ _3 ^ ")<-" ) -# 25558 "src/ocaml/preprocess/parser_raw.ml" +# 31381 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25594,17 +31417,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25600 "src/ocaml/preprocess/parser_raw.ml" +# 31423 "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) = -# 3959 "src/ocaml/preprocess/parser_raw.mly" +# 3924 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"[" ^ _3 ^ "]" ) -# 25608 "src/ocaml/preprocess/parser_raw.ml" +# 31431 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25651,17 +31474,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25657 "src/ocaml/preprocess/parser_raw.ml" +# 31480 "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) = -# 3960 "src/ocaml/preprocess/parser_raw.mly" +# 3925 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "[" ^ _3 ^ "]<-" ) -# 25665 "src/ocaml/preprocess/parser_raw.ml" +# 31488 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25701,17 +31524,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25707 "src/ocaml/preprocess/parser_raw.ml" +# 31530 "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) = -# 3961 "src/ocaml/preprocess/parser_raw.mly" +# 3926 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^"{" ^ _3 ^ "}" ) -# 25715 "src/ocaml/preprocess/parser_raw.ml" +# 31538 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25758,17 +31581,17 @@ module Tables = struct let _3 : (string) = Obj.magic _3 in let _2 : unit = Obj.magic _2 in let _1 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25764 "src/ocaml/preprocess/parser_raw.ml" +# 31587 "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) = -# 3962 "src/ocaml/preprocess/parser_raw.mly" +# 3927 "src/ocaml/preprocess/parser_raw.mly" ( "."^ _1 ^ "{" ^ _3 ^ "}<-" ) -# 25772 "src/ocaml/preprocess/parser_raw.ml" +# 31595 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25787,17 +31610,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 900 "src/ocaml/preprocess/parser_raw.mly" +# 873 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25793 "src/ocaml/preprocess/parser_raw.ml" +# 31616 "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) = -# 3963 "src/ocaml/preprocess/parser_raw.mly" +# 3928 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25801 "src/ocaml/preprocess/parser_raw.ml" +# 31624 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25820,9 +31643,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3964 "src/ocaml/preprocess/parser_raw.mly" +# 3929 "src/ocaml/preprocess/parser_raw.mly" ( "!" ) -# 25826 "src/ocaml/preprocess/parser_raw.ml" +# 31649 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25841,22 +31664,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 841 "src/ocaml/preprocess/parser_raw.mly" +# 814 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25847 "src/ocaml/preprocess/parser_raw.ml" +# 31670 "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 = -# 3968 "src/ocaml/preprocess/parser_raw.mly" +# 3933 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25855 "src/ocaml/preprocess/parser_raw.ml" +# 31678 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25860 "src/ocaml/preprocess/parser_raw.ml" +# 31683 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25875,22 +31698,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 842 "src/ocaml/preprocess/parser_raw.mly" +# 815 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25881 "src/ocaml/preprocess/parser_raw.ml" +# 31704 "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 = -# 3969 "src/ocaml/preprocess/parser_raw.mly" +# 3934 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25889 "src/ocaml/preprocess/parser_raw.ml" +# 31712 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25894 "src/ocaml/preprocess/parser_raw.ml" +# 31717 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25909,22 +31732,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 843 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25915 "src/ocaml/preprocess/parser_raw.ml" +# 31738 "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 = -# 3970 "src/ocaml/preprocess/parser_raw.mly" +# 3935 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25923 "src/ocaml/preprocess/parser_raw.ml" +# 31746 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25928 "src/ocaml/preprocess/parser_raw.ml" +# 31751 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25943,22 +31766,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 844 "src/ocaml/preprocess/parser_raw.mly" +# 817 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25949 "src/ocaml/preprocess/parser_raw.ml" +# 31772 "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 = -# 3971 "src/ocaml/preprocess/parser_raw.mly" +# 3936 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25957 "src/ocaml/preprocess/parser_raw.ml" +# 31780 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25962 "src/ocaml/preprocess/parser_raw.ml" +# 31785 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -25977,22 +31800,22 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let op : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 818 "src/ocaml/preprocess/parser_raw.mly" (string) -# 25983 "src/ocaml/preprocess/parser_raw.ml" +# 31806 "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 = -# 3972 "src/ocaml/preprocess/parser_raw.mly" +# 3937 "src/ocaml/preprocess/parser_raw.mly" ( op ) -# 25991 "src/ocaml/preprocess/parser_raw.ml" +# 31814 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 25996 "src/ocaml/preprocess/parser_raw.ml" +# 31819 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26015,14 +31838,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3973 "src/ocaml/preprocess/parser_raw.mly" +# 3938 "src/ocaml/preprocess/parser_raw.mly" ("+") -# 26021 "src/ocaml/preprocess/parser_raw.ml" +# 31844 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26026 "src/ocaml/preprocess/parser_raw.ml" +# 31849 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26045,14 +31868,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3974 "src/ocaml/preprocess/parser_raw.mly" +# 3939 "src/ocaml/preprocess/parser_raw.mly" ("+.") -# 26051 "src/ocaml/preprocess/parser_raw.ml" +# 31874 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26056 "src/ocaml/preprocess/parser_raw.ml" +# 31879 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26075,14 +31898,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3975 "src/ocaml/preprocess/parser_raw.mly" +# 3940 "src/ocaml/preprocess/parser_raw.mly" ("+=") -# 26081 "src/ocaml/preprocess/parser_raw.ml" +# 31904 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26086 "src/ocaml/preprocess/parser_raw.ml" +# 31909 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26105,14 +31928,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3976 "src/ocaml/preprocess/parser_raw.mly" +# 3941 "src/ocaml/preprocess/parser_raw.mly" ("-") -# 26111 "src/ocaml/preprocess/parser_raw.ml" +# 31934 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26116 "src/ocaml/preprocess/parser_raw.ml" +# 31939 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26135,14 +31958,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3977 "src/ocaml/preprocess/parser_raw.mly" +# 3942 "src/ocaml/preprocess/parser_raw.mly" ("-.") -# 26141 "src/ocaml/preprocess/parser_raw.ml" +# 31964 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26146 "src/ocaml/preprocess/parser_raw.ml" +# 31969 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26165,14 +31988,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3978 "src/ocaml/preprocess/parser_raw.mly" +# 3943 "src/ocaml/preprocess/parser_raw.mly" ("*") -# 26171 "src/ocaml/preprocess/parser_raw.ml" +# 31994 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26176 "src/ocaml/preprocess/parser_raw.ml" +# 31999 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26195,14 +32018,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3979 "src/ocaml/preprocess/parser_raw.mly" +# 3944 "src/ocaml/preprocess/parser_raw.mly" ("%") -# 26201 "src/ocaml/preprocess/parser_raw.ml" +# 32024 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26206 "src/ocaml/preprocess/parser_raw.ml" +# 32029 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26225,14 +32048,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3980 "src/ocaml/preprocess/parser_raw.mly" +# 3945 "src/ocaml/preprocess/parser_raw.mly" ("=") -# 26231 "src/ocaml/preprocess/parser_raw.ml" +# 32054 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26236 "src/ocaml/preprocess/parser_raw.ml" +# 32059 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26255,14 +32078,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3981 "src/ocaml/preprocess/parser_raw.mly" +# 3946 "src/ocaml/preprocess/parser_raw.mly" ("<") -# 26261 "src/ocaml/preprocess/parser_raw.ml" +# 32084 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26266 "src/ocaml/preprocess/parser_raw.ml" +# 32089 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26285,14 +32108,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3982 "src/ocaml/preprocess/parser_raw.mly" +# 3947 "src/ocaml/preprocess/parser_raw.mly" (">") -# 26291 "src/ocaml/preprocess/parser_raw.ml" +# 32114 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26296 "src/ocaml/preprocess/parser_raw.ml" +# 32119 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26315,14 +32138,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3983 "src/ocaml/preprocess/parser_raw.mly" +# 3948 "src/ocaml/preprocess/parser_raw.mly" ("or") -# 26321 "src/ocaml/preprocess/parser_raw.ml" +# 32144 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26326 "src/ocaml/preprocess/parser_raw.ml" +# 32149 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26345,14 +32168,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3984 "src/ocaml/preprocess/parser_raw.mly" +# 3949 "src/ocaml/preprocess/parser_raw.mly" ("||") -# 26351 "src/ocaml/preprocess/parser_raw.ml" +# 32174 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26356 "src/ocaml/preprocess/parser_raw.ml" +# 32179 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26375,14 +32198,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3985 "src/ocaml/preprocess/parser_raw.mly" +# 3950 "src/ocaml/preprocess/parser_raw.mly" ("&") -# 26381 "src/ocaml/preprocess/parser_raw.ml" +# 32204 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26386 "src/ocaml/preprocess/parser_raw.ml" +# 32209 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26405,14 +32228,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3986 "src/ocaml/preprocess/parser_raw.mly" +# 3951 "src/ocaml/preprocess/parser_raw.mly" ("&&") -# 26411 "src/ocaml/preprocess/parser_raw.ml" +# 32234 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26416 "src/ocaml/preprocess/parser_raw.ml" +# 32239 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26435,14 +32258,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = let _1 = -# 3987 "src/ocaml/preprocess/parser_raw.mly" +# 3952 "src/ocaml/preprocess/parser_raw.mly" (":=") -# 26441 "src/ocaml/preprocess/parser_raw.ml" +# 32264 "src/ocaml/preprocess/parser_raw.ml" in -# 3965 "src/ocaml/preprocess/parser_raw.mly" +# 3930 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 26446 "src/ocaml/preprocess/parser_raw.ml" +# 32269 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26465,9 +32288,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (bool) = -# 3867 "src/ocaml/preprocess/parser_raw.mly" +# 3832 "src/ocaml/preprocess/parser_raw.mly" ( true ) -# 26471 "src/ocaml/preprocess/parser_raw.ml" +# 32294 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26483,9 +32306,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (bool) = -# 3868 "src/ocaml/preprocess/parser_raw.mly" +# 3833 "src/ocaml/preprocess/parser_raw.mly" ( false ) -# 26489 "src/ocaml/preprocess/parser_raw.ml" +# 32312 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26503,7 +32326,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26507 "src/ocaml/preprocess/parser_raw.ml" +# 32330 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26528,7 +32351,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26532 "src/ocaml/preprocess/parser_raw.ml" +# 32355 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26546,7 +32369,7 @@ module Tables = struct let _v : (unit option) = # 114 "" ( None ) -# 26550 "src/ocaml/preprocess/parser_raw.ml" +# 32373 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26571,7 +32394,7 @@ module Tables = struct let _v : (unit option) = # 116 "" ( Some x ) -# 26575 "src/ocaml/preprocess/parser_raw.ml" +# 32398 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26589,7 +32412,7 @@ module Tables = struct let _v : (string Location.loc option) = # 114 "" ( None ) -# 26593 "src/ocaml/preprocess/parser_raw.ml" +# 32416 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26614,9 +32437,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 26620 "src/ocaml/preprocess/parser_raw.ml" +# 32443 "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 @@ -26629,21 +32452,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 26635 "src/ocaml/preprocess/parser_raw.ml" +# 32458 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 26641 "src/ocaml/preprocess/parser_raw.ml" +# 32464 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26647 "src/ocaml/preprocess/parser_raw.ml" +# 32470 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26661,7 +32484,7 @@ module Tables = struct let _v : (Parsetree.core_type option) = # 114 "" ( None ) -# 26665 "src/ocaml/preprocess/parser_raw.ml" +# 32488 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26693,12 +32516,12 @@ module Tables = struct let _v : (Parsetree.core_type option) = let x = # 183 "" ( x ) -# 26697 "src/ocaml/preprocess/parser_raw.ml" +# 32520 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26702 "src/ocaml/preprocess/parser_raw.ml" +# 32525 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26716,7 +32539,7 @@ module Tables = struct let _v : (Parsetree.core_type option) = # 114 "" ( None ) -# 26720 "src/ocaml/preprocess/parser_raw.ml" +# 32543 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26748,12 +32571,12 @@ module Tables = struct let _v : (Parsetree.core_type option) = let x = # 183 "" ( x ) -# 26752 "src/ocaml/preprocess/parser_raw.ml" +# 32575 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26757 "src/ocaml/preprocess/parser_raw.ml" +# 32580 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26771,7 +32594,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 26775 "src/ocaml/preprocess/parser_raw.ml" +# 32598 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26784,9 +32607,9 @@ module Tables = struct 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.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; @@ -26795,20 +32618,160 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; }; } = _menhir_stack in - let x : (Parsetree.expression) = Obj.magic x in + let _1_inlined1 : (Parsetree.expression) = 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_x_ in - let _v : (Parsetree.expression option) = let x = + let _endpos = _endpos__1_inlined1_ in + let _v : (Parsetree.expression option) = let x = + let x = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 32633 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 32638 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 183 "" + ( x ) +# 32644 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 116 "" + ( Some x ) +# 32650 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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_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 _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 option) = let x = + let x = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 32709 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 32714 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 32720 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 32731 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 32737 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 32757 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 32763 "src/ocaml/preprocess/parser_raw.ml" + + in + # 183 "" ( x ) -# 26807 "src/ocaml/preprocess/parser_raw.ml" - in +# 32769 "src/ocaml/preprocess/parser_raw.ml" + + in # 116 "" ( Some x ) -# 26812 "src/ocaml/preprocess/parser_raw.ml" +# 32775 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26826,7 +32789,7 @@ module Tables = struct let _v : (Parsetree.module_type option) = # 114 "" ( None ) -# 26830 "src/ocaml/preprocess/parser_raw.ml" +# 32793 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26858,12 +32821,12 @@ module Tables = struct let _v : (Parsetree.module_type option) = let x = # 183 "" ( x ) -# 26862 "src/ocaml/preprocess/parser_raw.ml" +# 32825 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26867 "src/ocaml/preprocess/parser_raw.ml" +# 32830 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26881,7 +32844,7 @@ module Tables = struct let _v : (Parsetree.pattern option) = # 114 "" ( None ) -# 26885 "src/ocaml/preprocess/parser_raw.ml" +# 32848 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26913,12 +32876,12 @@ module Tables = struct let _v : (Parsetree.pattern option) = let x = # 183 "" ( x ) -# 26917 "src/ocaml/preprocess/parser_raw.ml" +# 32880 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26922 "src/ocaml/preprocess/parser_raw.ml" +# 32885 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26936,7 +32899,7 @@ module Tables = struct let _v : (Parsetree.expression option) = # 114 "" ( None ) -# 26940 "src/ocaml/preprocess/parser_raw.ml" +# 32903 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26968,12 +32931,12 @@ module Tables = struct let _v : (Parsetree.expression option) = let x = # 183 "" ( x ) -# 26972 "src/ocaml/preprocess/parser_raw.ml" +# 32935 "src/ocaml/preprocess/parser_raw.ml" in # 116 "" ( Some x ) -# 26977 "src/ocaml/preprocess/parser_raw.ml" +# 32940 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -26991,7 +32954,7 @@ module Tables = struct let _v : (Parsetree.type_constraint option) = # 114 "" ( None ) -# 26995 "src/ocaml/preprocess/parser_raw.ml" +# 32958 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27016,7 +32979,7 @@ module Tables = struct let _v : (Parsetree.type_constraint option) = # 116 "" ( Some x ) -# 27020 "src/ocaml/preprocess/parser_raw.ml" +# 32983 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27035,17 +32998,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 882 "src/ocaml/preprocess/parser_raw.mly" +# 855 "src/ocaml/preprocess/parser_raw.mly" (string) -# 27041 "src/ocaml/preprocess/parser_raw.ml" +# 33004 "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) = -# 4176 "src/ocaml/preprocess/parser_raw.mly" +# 4141 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27049 "src/ocaml/preprocess/parser_raw.ml" +# 33012 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27077,18 +33040,18 @@ module Tables = struct } = _menhir_stack in let _3 : unit = Obj.magic _3 in let _2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 27083 "src/ocaml/preprocess/parser_raw.ml" +# 33046 "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) = -# 4177 "src/ocaml/preprocess/parser_raw.mly" +# 4142 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 27092 "src/ocaml/preprocess/parser_raw.ml" +# 33055 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27142,9 +33105,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1544 "src/ocaml/preprocess/parser_raw.mly" +# 1509 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc (Pmod_constraint(me, mty)) ) -# 27148 "src/ocaml/preprocess/parser_raw.ml" +# 33111 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27181,9 +33144,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.module_expr) = -# 1551 "src/ocaml/preprocess/parser_raw.mly" +# 1516 "src/ocaml/preprocess/parser_raw.mly" ( me (* TODO consider reloc *) ) -# 27187 "src/ocaml/preprocess/parser_raw.ml" +# 33150 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27201,9 +33164,9 @@ module Tables = struct 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.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; @@ -27226,33 +33189,205 @@ module Tables = struct }; } = _menhir_stack in let _5 : unit = Obj.magic _5 in - let e : (Parsetree.expression) = Obj.magic e in + let _1_inlined2 : (Parsetree.expression) = 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__5_ in - let _v : (Parsetree.module_expr) = let e = -# 1574 "src/ocaml/preprocess/parser_raw.mly" + let _v : (Parsetree.module_expr) = let e = + let _1 = _1_inlined2 in + let e = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33206 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33211 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1539 "src/ocaml/preprocess/parser_raw.mly" ( e ) -# 27240 "src/ocaml/preprocess/parser_raw.ml" +# 33217 "src/ocaml/preprocess/parser_raw.ml" + + in + let attrs = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33225 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__5_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1524 "src/ocaml/preprocess/parser_raw.mly" + ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) +# 33234 "src/ocaml/preprocess/parser_raw.ml" in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _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 = _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 xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in + let _1_inlined3 : (string Location.loc option) = Obj.magic _1_inlined3 in + let _1_inlined2 : unit = 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__5_ in + let _v : (Parsetree.module_expr) = let e = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined2_, _1_inlined4, _1_inlined3, _1_inlined2) in + let e = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 33314 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 33319 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 33325 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33336 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 33342 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 33362 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33368 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1539 "src/ocaml/preprocess/parser_raw.mly" + ( e ) +# 33374 "src/ocaml/preprocess/parser_raw.ml" + + in let attrs = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27247 "src/ocaml/preprocess/parser_raw.ml" +# 33382 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1559 "src/ocaml/preprocess/parser_raw.mly" +# 1524 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27256 "src/ocaml/preprocess/parser_raw.ml" +# 33391 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27270,9 +33405,9 @@ module Tables = struct 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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _2_inlined1; @@ -27280,9 +33415,9 @@ module Tables = struct 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.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; @@ -27307,9 +33442,146 @@ module Tables = struct }; } = _menhir_stack in let _5 : unit = Obj.magic _5 in - let _1_inlined2 : (Parsetree.module_type) = Obj.magic _1_inlined2 in + let _1_inlined3 : (Parsetree.module_type) = Obj.magic _1_inlined3 in let _2_inlined1 : unit = Obj.magic _2_inlined1 in - let e : (Parsetree.expression) = Obj.magic e in + let _1_inlined2 : (Parsetree.expression) = 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__5_ in + let _v : (Parsetree.module_expr) = let e = + let (_endpos__1_inlined1_, _startpos__1_inlined1_, _startpos__1_, _1_inlined1, _2, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _startpos__1_inlined2_, _1_inlined3, _2_inlined1, _1_inlined2) in + let ty = + 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 + +# 3807 "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 ) +# 33467 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos_ty_ = _endpos__1_inlined1_ in + let e = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33475 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33480 "src/ocaml/preprocess/parser_raw.ml" + + in + let _startpos_e_ = _startpos__1_ in + let _endpos = _endpos_ty_ in + let _startpos = _startpos_e_ in + let _loc = (_startpos, _endpos) in + +# 1541 "src/ocaml/preprocess/parser_raw.mly" + ( ghexp ~loc:_loc (Pexp_constraint (e, ty)) ) +# 33490 "src/ocaml/preprocess/parser_raw.ml" + + in + let attrs = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33498 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__5_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1524 "src/ocaml/preprocess/parser_raw.mly" + ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) +# 33507 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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_inlined5; + MenhirLib.EngineTypes.startp = _startpos__1_inlined5_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined5_; + 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 = 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 = _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_inlined5 : (Parsetree.module_type) = Obj.magic _1_inlined5 in + let _2_inlined1 : unit = Obj.magic _2_inlined1 in + let xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in + let _1_inlined3 : (string Location.loc option) = Obj.magic _1_inlined3 in + let _1_inlined2 : unit = 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 @@ -27317,44 +33589,253 @@ module Tables = struct 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 (_endpos__1_inlined3_, _startpos__1_inlined3_, _startpos__1_, _1_inlined3, _2, _1_inlined2, _1_inlined1, _1) = (_endpos__1_inlined5_, _startpos__1_inlined5_, _startpos__1_inlined2_, _1_inlined5, _2_inlined1, _1_inlined4, _1_inlined3, _1_inlined2) in let ty = + 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 -# 3842 "src/ocaml/preprocess/parser_raw.mly" +# 3807 "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 ) -# 27331 "src/ocaml/preprocess/parser_raw.ml" +# 33604 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos_ty_ = _endpos__1_inlined3_ in + let e = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 33615 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 33620 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 33626 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33637 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 33643 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 33663 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33669 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos_ty_ = _endpos__1_ in + let _startpos_e_ = _startpos__1_ in let _endpos = _endpos_ty_ in let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1576 "src/ocaml/preprocess/parser_raw.mly" +# 1541 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_constraint (e, ty)) ) -# 27341 "src/ocaml/preprocess/parser_raw.ml" +# 33679 "src/ocaml/preprocess/parser_raw.ml" + + in + let attrs = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33687 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__5_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1524 "src/ocaml/preprocess/parser_raw.mly" + ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) +# 33696 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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_inlined4; + MenhirLib.EngineTypes.startp = _startpos__1_inlined4_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined4_; + 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_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; + 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_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_inlined4 : (Parsetree.module_type) = Obj.magic _1_inlined4 in + let _4 : unit = Obj.magic _4 in + let _1_inlined3 : (Parsetree.module_type) = Obj.magic _1_inlined3 in + let _2_inlined1 : unit = Obj.magic _2_inlined1 in + let _1_inlined2 : (Parsetree.expression) = 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__5_ in + let _v : (Parsetree.module_expr) = let e = + let (_endpos__1_inlined2_, _startpos__1_inlined2_, _endpos__1_inlined1_, _startpos__1_inlined1_, _startpos__1_, _1_inlined2, _1_inlined1, _2, _1) = (_endpos__1_inlined4_, _startpos__1_inlined4_, _endpos__1_inlined3_, _startpos__1_inlined3_, _startpos__1_inlined2_, _1_inlined4, _1_inlined3, _2_inlined1, _1_inlined2) in + let ty2 = + 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 + +# 3807 "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 ) +# 33786 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos_ty2_ = _endpos__1_inlined2_ in + let ty1 = + 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 + +# 3807 "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 ) +# 33800 "src/ocaml/preprocess/parser_raw.ml" + + in + let e = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33807 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33812 "src/ocaml/preprocess/parser_raw.ml" + + in + let _startpos_e_ = _startpos__1_ in + let _endpos = _endpos_ty2_ in + let _startpos = _startpos_e_ in + let _loc = (_startpos, _endpos) in + +# 1543 "src/ocaml/preprocess/parser_raw.mly" + ( ghexp ~loc:_loc (Pexp_coerce (e, Some ty1, ty2)) ) +# 33822 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27349 "src/ocaml/preprocess/parser_raw.ml" +# 33830 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1559 "src/ocaml/preprocess/parser_raw.mly" +# 1524 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27358 "src/ocaml/preprocess/parser_raw.ml" +# 33839 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27372,9 +33853,9 @@ module Tables = struct 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.semv = _1_inlined6; + MenhirLib.EngineTypes.startp = _startpos__1_inlined6_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined6_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _4; @@ -27382,9 +33863,9 @@ module Tables = struct 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.semv = _1_inlined5; + MenhirLib.EngineTypes.startp = _startpos__1_inlined5_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined5_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _2_inlined1; @@ -27392,25 +33873,43 @@ module Tables = struct 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.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.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; - MenhirLib.EngineTypes.startp = _startpos__2_; - MenhirLib.EngineTypes.endp = _endpos__2_; + MenhirLib.EngineTypes.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = _1; - MenhirLib.EngineTypes.startp = _startpos__1_; - MenhirLib.EngineTypes.endp = _endpos__1_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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; + }; + }; + }; }; }; }; @@ -27421,11 +33920,14 @@ module Tables = struct }; } = _menhir_stack in let _5 : unit = Obj.magic _5 in - let _1_inlined3 : (Parsetree.module_type) = Obj.magic _1_inlined3 in + let _1_inlined6 : (Parsetree.module_type) = Obj.magic _1_inlined6 in let _4 : unit = Obj.magic _4 in - let _1_inlined2 : (Parsetree.module_type) = Obj.magic _1_inlined2 in + let _1_inlined5 : (Parsetree.module_type) = Obj.magic _1_inlined5 in let _2_inlined1 : unit = Obj.magic _2_inlined1 in - let e : (Parsetree.expression) = Obj.magic e in + let xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in + let _1_inlined3 : (string Location.loc option) = Obj.magic _1_inlined3 in + let _1_inlined2 : unit = 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 @@ -27433,57 +33935,123 @@ module Tables = struct 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 (_endpos__1_inlined4_, _startpos__1_inlined4_, _endpos__1_inlined3_, _startpos__1_inlined3_, _startpos__1_, _1_inlined4, _1_inlined3, _2, _1_inlined2, _1_inlined1, _1) = (_endpos__1_inlined6_, _startpos__1_inlined6_, _endpos__1_inlined5_, _startpos__1_inlined5_, _startpos__1_inlined2_, _1_inlined6, _1_inlined5, _2_inlined1, _1_inlined4, _1_inlined3, _1_inlined2) in let ty2 = - let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in + 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 -# 3842 "src/ocaml/preprocess/parser_raw.mly" +# 3807 "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 ) -# 27448 "src/ocaml/preprocess/parser_raw.ml" +# 33950 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos_ty2_ = _endpos__1_inlined1_ in + let _endpos_ty2_ = _endpos__1_inlined4_ in let ty1 = + 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 -# 3842 "src/ocaml/preprocess/parser_raw.mly" +# 3807 "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 ) -# 27461 "src/ocaml/preprocess/parser_raw.ml" +# 33964 "src/ocaml/preprocess/parser_raw.ml" + + in + let e = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 33974 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 33979 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 33985 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 33996 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 34002 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 34022 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 34028 "src/ocaml/preprocess/parser_raw.ml" in + let _startpos_e_ = _startpos__1_ in let _endpos = _endpos_ty2_ in let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1578 "src/ocaml/preprocess/parser_raw.mly" +# 1543 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, Some ty1, ty2)) ) -# 27470 "src/ocaml/preprocess/parser_raw.ml" +# 34038 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27478 "src/ocaml/preprocess/parser_raw.ml" +# 34046 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1559 "src/ocaml/preprocess/parser_raw.mly" +# 1524 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27487 "src/ocaml/preprocess/parser_raw.ml" +# 34055 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27501,9 +34069,9 @@ module Tables = struct 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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _; MenhirLib.EngineTypes.semv = _2_inlined1; @@ -27511,9 +34079,9 @@ module Tables = struct 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.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; @@ -27538,9 +34106,146 @@ module Tables = struct }; } = _menhir_stack in let _5 : unit = Obj.magic _5 in - let _1_inlined2 : (Parsetree.module_type) = Obj.magic _1_inlined2 in + let _1_inlined3 : (Parsetree.module_type) = Obj.magic _1_inlined3 in let _2_inlined1 : unit = Obj.magic _2_inlined1 in - let e : (Parsetree.expression) = Obj.magic e in + let _1_inlined2 : (Parsetree.expression) = 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__5_ in + let _v : (Parsetree.module_expr) = let e = + let (_endpos__1_inlined1_, _startpos__1_inlined1_, _startpos__1_, _1_inlined1, _2, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _startpos__1_inlined2_, _1_inlined3, _2_inlined1, _1_inlined2) 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 + +# 3807 "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 ) +# 34131 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos_ty2_ = _endpos__1_inlined1_ in + let e = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 34139 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 34144 "src/ocaml/preprocess/parser_raw.ml" + + in + let _startpos_e_ = _startpos__1_ in + let _endpos = _endpos_ty2_ in + let _startpos = _startpos_e_ in + let _loc = (_startpos, _endpos) in + +# 1545 "src/ocaml/preprocess/parser_raw.mly" + ( ghexp ~loc:_loc (Pexp_coerce (e, None, ty2)) ) +# 34154 "src/ocaml/preprocess/parser_raw.ml" + + in + let attrs = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 34162 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__5_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 1524 "src/ocaml/preprocess/parser_raw.mly" + ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) +# 34171 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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_inlined5; + MenhirLib.EngineTypes.startp = _startpos__1_inlined5_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined5_; + 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 = 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 = _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_inlined5 : (Parsetree.module_type) = Obj.magic _1_inlined5 in + let _2_inlined1 : unit = Obj.magic _2_inlined1 in + let xs : (Parsetree.case list) = Obj.magic xs in + let _1_inlined4 : (Parsetree.attributes) = Obj.magic _1_inlined4 in + let _1_inlined3 : (string Location.loc option) = Obj.magic _1_inlined3 in + let _1_inlined2 : unit = 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 @@ -27548,44 +34253,110 @@ module Tables = struct 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 (_endpos__1_inlined3_, _startpos__1_inlined3_, _startpos__1_, _1_inlined3, _2, _1_inlined2, _1_inlined1, _1) = (_endpos__1_inlined5_, _startpos__1_inlined5_, _startpos__1_inlined2_, _1_inlined5, _2_inlined1, _1_inlined4, _1_inlined3, _1_inlined2) in let ty2 = + 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 -# 3842 "src/ocaml/preprocess/parser_raw.mly" +# 3807 "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 ) -# 27562 "src/ocaml/preprocess/parser_raw.ml" +# 34268 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos_ty2_ = _endpos__1_inlined3_ in + let e = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 34279 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 34284 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 34290 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 34301 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 34307 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 34327 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 34333 "src/ocaml/preprocess/parser_raw.ml" in - let _endpos_ty2_ = _endpos__1_ in + let _startpos_e_ = _startpos__1_ in let _endpos = _endpos_ty2_ in let _startpos = _startpos_e_ in let _loc = (_startpos, _endpos) in -# 1580 "src/ocaml/preprocess/parser_raw.mly" +# 1545 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_loc (Pexp_coerce (e, None, ty2)) ) -# 27572 "src/ocaml/preprocess/parser_raw.ml" +# 34343 "src/ocaml/preprocess/parser_raw.ml" in let attrs = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27580 "src/ocaml/preprocess/parser_raw.ml" +# 34351 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1559 "src/ocaml/preprocess/parser_raw.mly" +# 1524 "src/ocaml/preprocess/parser_raw.mly" ( mkmod ~loc:_sloc ~attrs (Pmod_unpack e) ) -# 27589 "src/ocaml/preprocess/parser_raw.ml" +# 34360 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27615,9 +34386,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1453 "src/ocaml/preprocess/parser_raw.mly" +# 1418 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27621 "src/ocaml/preprocess/parser_raw.ml" +# 34392 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27647,9 +34418,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1438 "src/ocaml/preprocess/parser_raw.mly" +# 1403 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27653 "src/ocaml/preprocess/parser_raw.ml" +# 34424 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27679,9 +34450,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type) = -# 1413 "src/ocaml/preprocess/parser_raw.mly" +# 1378 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27685 "src/ocaml/preprocess/parser_raw.ml" +# 34456 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27711,9 +34482,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 1418 "src/ocaml/preprocess/parser_raw.mly" +# 1383 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27717 "src/ocaml/preprocess/parser_raw.ml" +# 34488 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27743,9 +34514,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1443 "src/ocaml/preprocess/parser_raw.mly" +# 1408 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27749 "src/ocaml/preprocess/parser_raw.ml" +# 34520 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27775,9 +34546,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1448 "src/ocaml/preprocess/parser_raw.mly" +# 1413 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27781 "src/ocaml/preprocess/parser_raw.ml" +# 34552 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27807,9 +34578,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_expr) = -# 1408 "src/ocaml/preprocess/parser_raw.mly" +# 1373 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27813 "src/ocaml/preprocess/parser_raw.ml" +# 34584 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27839,9 +34610,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.module_type) = -# 1403 "src/ocaml/preprocess/parser_raw.mly" +# 1368 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27845 "src/ocaml/preprocess/parser_raw.ml" +# 34616 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27871,9 +34642,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1428 "src/ocaml/preprocess/parser_raw.mly" +# 1393 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27877 "src/ocaml/preprocess/parser_raw.ml" +# 34648 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27903,9 +34674,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = -# 1423 "src/ocaml/preprocess/parser_raw.mly" +# 1388 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27909 "src/ocaml/preprocess/parser_raw.ml" +# 34680 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27935,9 +34706,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Longident.t) = -# 1433 "src/ocaml/preprocess/parser_raw.mly" +# 1398 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27941 "src/ocaml/preprocess/parser_raw.ml" +# 34712 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -27979,15 +34750,15 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 3066 "src/ocaml/preprocess/parser_raw.mly" +# 3031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 27985 "src/ocaml/preprocess/parser_raw.ml" +# 34756 "src/ocaml/preprocess/parser_raw.ml" in -# 3054 "src/ocaml/preprocess/parser_raw.mly" +# 3019 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 27991 "src/ocaml/preprocess/parser_raw.ml" +# 34762 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28017,14 +34788,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = -# 3068 "src/ocaml/preprocess/parser_raw.mly" +# 3033 "src/ocaml/preprocess/parser_raw.mly" ( Pat.attr _1 _2 ) -# 28023 "src/ocaml/preprocess/parser_raw.ml" +# 34794 "src/ocaml/preprocess/parser_raw.ml" in -# 3054 "src/ocaml/preprocess/parser_raw.mly" +# 3019 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28028 "src/ocaml/preprocess/parser_raw.ml" +# 34799 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28047,14 +34818,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = -# 3070 "src/ocaml/preprocess/parser_raw.mly" +# 3035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28053 "src/ocaml/preprocess/parser_raw.ml" +# 34824 "src/ocaml/preprocess/parser_raw.ml" in -# 3054 "src/ocaml/preprocess/parser_raw.mly" +# 3019 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28058 "src/ocaml/preprocess/parser_raw.ml" +# 34829 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28099,15 +34870,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28105 "src/ocaml/preprocess/parser_raw.ml" +# 34876 "src/ocaml/preprocess/parser_raw.ml" in -# 3073 "src/ocaml/preprocess/parser_raw.mly" +# 3038 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_alias(_1, _3) ) -# 28111 "src/ocaml/preprocess/parser_raw.ml" +# 34882 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -28115,21 +34886,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28121 "src/ocaml/preprocess/parser_raw.ml" +# 34892 "src/ocaml/preprocess/parser_raw.ml" in -# 3084 "src/ocaml/preprocess/parser_raw.mly" +# 3049 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28127 "src/ocaml/preprocess/parser_raw.ml" +# 34898 "src/ocaml/preprocess/parser_raw.ml" in -# 3054 "src/ocaml/preprocess/parser_raw.mly" +# 3019 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28133 "src/ocaml/preprocess/parser_raw.ml" +# 34904 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28154,29 +34925,29 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 3077 "src/ocaml/preprocess/parser_raw.mly" +# 3042 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_tuple(List.rev _1) ) -# 28160 "src/ocaml/preprocess/parser_raw.ml" +# 34931 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28168 "src/ocaml/preprocess/parser_raw.ml" +# 34939 "src/ocaml/preprocess/parser_raw.ml" in -# 3084 "src/ocaml/preprocess/parser_raw.mly" +# 3049 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28174 "src/ocaml/preprocess/parser_raw.ml" +# 34945 "src/ocaml/preprocess/parser_raw.ml" in -# 3054 "src/ocaml/preprocess/parser_raw.mly" +# 3019 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28180 "src/ocaml/preprocess/parser_raw.ml" +# 34951 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28215,30 +34986,30 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 3081 "src/ocaml/preprocess/parser_raw.mly" +# 3046 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_or(_1, _3) ) -# 28221 "src/ocaml/preprocess/parser_raw.ml" +# 34992 "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 -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28230 "src/ocaml/preprocess/parser_raw.ml" +# 35001 "src/ocaml/preprocess/parser_raw.ml" in -# 3084 "src/ocaml/preprocess/parser_raw.mly" +# 3049 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28236 "src/ocaml/preprocess/parser_raw.ml" +# 35007 "src/ocaml/preprocess/parser_raw.ml" in -# 3054 "src/ocaml/preprocess/parser_raw.mly" +# 3019 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28242 "src/ocaml/preprocess/parser_raw.ml" +# 35013 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28286,24 +35057,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28292 "src/ocaml/preprocess/parser_raw.ml" +# 35063 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 28298 "src/ocaml/preprocess/parser_raw.ml" +# 35069 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3056 "src/ocaml/preprocess/parser_raw.mly" +# 3021 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_exception _3) _2) -# 28307 "src/ocaml/preprocess/parser_raw.ml" +# 35078 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28340,9 +35111,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3187 "src/ocaml/preprocess/parser_raw.mly" +# 3152 "src/ocaml/preprocess/parser_raw.mly" ( _3 :: _1 ) -# 28346 "src/ocaml/preprocess/parser_raw.ml" +# 35117 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28379,9 +35150,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3188 "src/ocaml/preprocess/parser_raw.mly" +# 3153 "src/ocaml/preprocess/parser_raw.mly" ( [_3; _1] ) -# 28385 "src/ocaml/preprocess/parser_raw.ml" +# 35156 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28418,9 +35189,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3187 "src/ocaml/preprocess/parser_raw.mly" +# 3152 "src/ocaml/preprocess/parser_raw.mly" ( _3 :: _1 ) -# 28424 "src/ocaml/preprocess/parser_raw.ml" +# 35195 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28457,9 +35228,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (Parsetree.pattern list) = -# 3188 "src/ocaml/preprocess/parser_raw.mly" +# 3153 "src/ocaml/preprocess/parser_raw.mly" ( [_3; _1] ) -# 28463 "src/ocaml/preprocess/parser_raw.ml" +# 35234 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28482,9 +35253,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 3089 "src/ocaml/preprocess/parser_raw.mly" +# 3054 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28488 "src/ocaml/preprocess/parser_raw.ml" +# 35259 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28520,15 +35291,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28526 "src/ocaml/preprocess/parser_raw.ml" +# 35297 "src/ocaml/preprocess/parser_raw.ml" in -# 3092 "src/ocaml/preprocess/parser_raw.mly" +# 3057 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(_1, Some ([], _2)) ) -# 28532 "src/ocaml/preprocess/parser_raw.ml" +# 35303 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -28536,15 +35307,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28542 "src/ocaml/preprocess/parser_raw.ml" +# 35313 "src/ocaml/preprocess/parser_raw.ml" in -# 3098 "src/ocaml/preprocess/parser_raw.mly" +# 3063 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28548 "src/ocaml/preprocess/parser_raw.ml" +# 35319 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28604,24 +35375,24 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let newtypes = -# 2809 "src/ocaml/preprocess/parser_raw.mly" +# 2774 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 28610 "src/ocaml/preprocess/parser_raw.ml" +# 35381 "src/ocaml/preprocess/parser_raw.ml" in let constr = let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28619 "src/ocaml/preprocess/parser_raw.ml" +# 35390 "src/ocaml/preprocess/parser_raw.ml" in -# 3095 "src/ocaml/preprocess/parser_raw.mly" +# 3060 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(constr, Some (newtypes, pat)) ) -# 28625 "src/ocaml/preprocess/parser_raw.ml" +# 35396 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_pat_ in @@ -28629,15 +35400,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28635 "src/ocaml/preprocess/parser_raw.ml" +# 35406 "src/ocaml/preprocess/parser_raw.ml" in -# 3098 "src/ocaml/preprocess/parser_raw.mly" +# 3063 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28641 "src/ocaml/preprocess/parser_raw.ml" +# 35412 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28668,24 +35439,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3097 "src/ocaml/preprocess/parser_raw.mly" +# 3062 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_variant(_1, Some _2) ) -# 28674 "src/ocaml/preprocess/parser_raw.ml" +# 35445 "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 -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28683 "src/ocaml/preprocess/parser_raw.ml" +# 35454 "src/ocaml/preprocess/parser_raw.ml" in -# 3098 "src/ocaml/preprocess/parser_raw.mly" +# 3063 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28689 "src/ocaml/preprocess/parser_raw.ml" +# 35460 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28733,24 +35504,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28739 "src/ocaml/preprocess/parser_raw.ml" +# 35510 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 28745 "src/ocaml/preprocess/parser_raw.ml" +# 35516 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3100 "src/ocaml/preprocess/parser_raw.mly" +# 3065 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_lazy _3) _2) -# 28754 "src/ocaml/preprocess/parser_raw.ml" +# 35525 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28792,15 +35563,15 @@ module Tables = struct let _loc__2_ = (_startpos__2_, _endpos__2_) in let _sloc = (_symbolstartpos, _endpos) in -# 3066 "src/ocaml/preprocess/parser_raw.mly" +# 3031 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_cons ~loc:_sloc _loc__2_ (ghpat ~loc:_sloc (Ppat_tuple[_1;_3])) ) -# 28798 "src/ocaml/preprocess/parser_raw.ml" +# 35569 "src/ocaml/preprocess/parser_raw.ml" in -# 3061 "src/ocaml/preprocess/parser_raw.mly" +# 3026 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28804 "src/ocaml/preprocess/parser_raw.ml" +# 35575 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28830,14 +35601,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = -# 3068 "src/ocaml/preprocess/parser_raw.mly" +# 3033 "src/ocaml/preprocess/parser_raw.mly" ( Pat.attr _1 _2 ) -# 28836 "src/ocaml/preprocess/parser_raw.ml" +# 35607 "src/ocaml/preprocess/parser_raw.ml" in -# 3061 "src/ocaml/preprocess/parser_raw.mly" +# 3026 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28841 "src/ocaml/preprocess/parser_raw.ml" +# 35612 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28860,14 +35631,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = -# 3070 "src/ocaml/preprocess/parser_raw.mly" +# 3035 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28866 "src/ocaml/preprocess/parser_raw.ml" +# 35637 "src/ocaml/preprocess/parser_raw.ml" in -# 3061 "src/ocaml/preprocess/parser_raw.mly" +# 3026 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28871 "src/ocaml/preprocess/parser_raw.ml" +# 35642 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28912,15 +35683,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 28918 "src/ocaml/preprocess/parser_raw.ml" +# 35689 "src/ocaml/preprocess/parser_raw.ml" in -# 3073 "src/ocaml/preprocess/parser_raw.mly" +# 3038 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_alias(_1, _3) ) -# 28924 "src/ocaml/preprocess/parser_raw.ml" +# 35695 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -28928,21 +35699,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28934 "src/ocaml/preprocess/parser_raw.ml" +# 35705 "src/ocaml/preprocess/parser_raw.ml" in -# 3084 "src/ocaml/preprocess/parser_raw.mly" +# 3049 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28940 "src/ocaml/preprocess/parser_raw.ml" +# 35711 "src/ocaml/preprocess/parser_raw.ml" in -# 3061 "src/ocaml/preprocess/parser_raw.mly" +# 3026 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28946 "src/ocaml/preprocess/parser_raw.ml" +# 35717 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -28967,29 +35738,29 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 3077 "src/ocaml/preprocess/parser_raw.mly" +# 3042 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_tuple(List.rev _1) ) -# 28973 "src/ocaml/preprocess/parser_raw.ml" +# 35744 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 28981 "src/ocaml/preprocess/parser_raw.ml" +# 35752 "src/ocaml/preprocess/parser_raw.ml" in -# 3084 "src/ocaml/preprocess/parser_raw.mly" +# 3049 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28987 "src/ocaml/preprocess/parser_raw.ml" +# 35758 "src/ocaml/preprocess/parser_raw.ml" in -# 3061 "src/ocaml/preprocess/parser_raw.mly" +# 3026 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 28993 "src/ocaml/preprocess/parser_raw.ml" +# 35764 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29028,30 +35799,30 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _1 = -# 3081 "src/ocaml/preprocess/parser_raw.mly" +# 3046 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_or(_1, _3) ) -# 29034 "src/ocaml/preprocess/parser_raw.ml" +# 35805 "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 -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 29043 "src/ocaml/preprocess/parser_raw.ml" +# 35814 "src/ocaml/preprocess/parser_raw.ml" in -# 3084 "src/ocaml/preprocess/parser_raw.mly" +# 3049 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29049 "src/ocaml/preprocess/parser_raw.ml" +# 35820 "src/ocaml/preprocess/parser_raw.ml" in -# 3061 "src/ocaml/preprocess/parser_raw.mly" +# 3026 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29055 "src/ocaml/preprocess/parser_raw.ml" +# 35826 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29070,9 +35841,9 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 29076 "src/ocaml/preprocess/parser_raw.ml" +# 35847 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -29084,30 +35855,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 29090 "src/ocaml/preprocess/parser_raw.ml" +# 35861 "src/ocaml/preprocess/parser_raw.ml" in -# 2485 "src/ocaml/preprocess/parser_raw.mly" +# 2450 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_var _1 ) -# 29096 "src/ocaml/preprocess/parser_raw.ml" +# 35867 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 29105 "src/ocaml/preprocess/parser_raw.ml" +# 35876 "src/ocaml/preprocess/parser_raw.ml" in -# 2487 "src/ocaml/preprocess/parser_raw.mly" +# 2452 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29111 "src/ocaml/preprocess/parser_raw.ml" +# 35882 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29131,23 +35902,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 2486 "src/ocaml/preprocess/parser_raw.mly" +# 2451 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_any ) -# 29137 "src/ocaml/preprocess/parser_raw.ml" +# 35908 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 29145 "src/ocaml/preprocess/parser_raw.ml" +# 35916 "src/ocaml/preprocess/parser_raw.ml" in -# 2487 "src/ocaml/preprocess/parser_raw.mly" +# 2452 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29151 "src/ocaml/preprocess/parser_raw.ml" +# 35922 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29170,9 +35941,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.payload) = -# 4288 "src/ocaml/preprocess/parser_raw.mly" +# 4253 "src/ocaml/preprocess/parser_raw.mly" ( PStr _1 ) -# 29176 "src/ocaml/preprocess/parser_raw.ml" +# 35947 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29202,9 +35973,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4289 "src/ocaml/preprocess/parser_raw.mly" +# 4254 "src/ocaml/preprocess/parser_raw.mly" ( PSig _2 ) -# 29208 "src/ocaml/preprocess/parser_raw.ml" +# 35979 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29234,9 +36005,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4290 "src/ocaml/preprocess/parser_raw.mly" +# 4255 "src/ocaml/preprocess/parser_raw.mly" ( PTyp _2 ) -# 29240 "src/ocaml/preprocess/parser_raw.ml" +# 36011 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29266,9 +36037,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.payload) = -# 4291 "src/ocaml/preprocess/parser_raw.mly" +# 4256 "src/ocaml/preprocess/parser_raw.mly" ( PPat (_2, None) ) -# 29272 "src/ocaml/preprocess/parser_raw.ml" +# 36043 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29312,9 +36083,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.payload) = -# 4292 "src/ocaml/preprocess/parser_raw.mly" +# 4257 "src/ocaml/preprocess/parser_raw.mly" ( PPat (_2, Some _4) ) -# 29318 "src/ocaml/preprocess/parser_raw.ml" +# 36089 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29337,9 +36108,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = -# 3625 "src/ocaml/preprocess/parser_raw.mly" +# 3590 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29343 "src/ocaml/preprocess/parser_raw.ml" +# 36114 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29382,24 +36153,24 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 29386 "src/ocaml/preprocess/parser_raw.ml" +# 36157 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1129 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 29391 "src/ocaml/preprocess/parser_raw.ml" +# 36162 "src/ocaml/preprocess/parser_raw.ml" in -# 3617 "src/ocaml/preprocess/parser_raw.mly" +# 3582 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29397 "src/ocaml/preprocess/parser_raw.ml" +# 36168 "src/ocaml/preprocess/parser_raw.ml" in -# 3621 "src/ocaml/preprocess/parser_raw.mly" +# 3586 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 29403 "src/ocaml/preprocess/parser_raw.ml" +# 36174 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__3_, _startpos_xs_) in @@ -29407,15 +36178,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 29413 "src/ocaml/preprocess/parser_raw.ml" +# 36184 "src/ocaml/preprocess/parser_raw.ml" in -# 3627 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29419 "src/ocaml/preprocess/parser_raw.ml" +# 36190 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29438,14 +36209,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = -# 3656 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29444 "src/ocaml/preprocess/parser_raw.ml" +# 36215 "src/ocaml/preprocess/parser_raw.ml" in -# 3625 "src/ocaml/preprocess/parser_raw.mly" +# 3590 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29449 "src/ocaml/preprocess/parser_raw.ml" +# 36220 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29484,33 +36255,33 @@ module Tables = struct let _v : (Parsetree.core_type) = let _1 = let _1 = let _3 = -# 3656 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29490 "src/ocaml/preprocess/parser_raw.ml" +# 36261 "src/ocaml/preprocess/parser_raw.ml" in let _1 = let _1 = let xs = # 253 "" ( List.rev xs ) -# 29497 "src/ocaml/preprocess/parser_raw.ml" +# 36268 "src/ocaml/preprocess/parser_raw.ml" in -# 1164 "src/ocaml/preprocess/parser_raw.mly" +# 1129 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 29502 "src/ocaml/preprocess/parser_raw.ml" +# 36273 "src/ocaml/preprocess/parser_raw.ml" in -# 3617 "src/ocaml/preprocess/parser_raw.mly" +# 3582 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29508 "src/ocaml/preprocess/parser_raw.ml" +# 36279 "src/ocaml/preprocess/parser_raw.ml" in -# 3621 "src/ocaml/preprocess/parser_raw.mly" +# 3586 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_poly(_1, _3) ) -# 29514 "src/ocaml/preprocess/parser_raw.ml" +# 36285 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_xs_ in @@ -29518,15 +36289,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 29524 "src/ocaml/preprocess/parser_raw.ml" +# 36295 "src/ocaml/preprocess/parser_raw.ml" in -# 3627 "src/ocaml/preprocess/parser_raw.mly" +# 3592 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29530 "src/ocaml/preprocess/parser_raw.ml" +# 36301 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29573,9 +36344,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4249 "src/ocaml/preprocess/parser_raw.mly" +# 4214 "src/ocaml/preprocess/parser_raw.mly" ( mk_attr ~loc:(make_loc _sloc) _2 _3 ) -# 29579 "src/ocaml/preprocess/parser_raw.ml" +# 36350 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29656,9 +36427,9 @@ module Tables = struct let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29662 "src/ocaml/preprocess/parser_raw.ml" +# 36433 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -29668,30 +36439,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 29674 "src/ocaml/preprocess/parser_raw.ml" +# 36445 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29682 "src/ocaml/preprocess/parser_raw.ml" +# 36453 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3251 "src/ocaml/preprocess/parser_raw.mly" +# 3216 "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 ) -# 29695 "src/ocaml/preprocess/parser_raw.ml" +# 36466 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29707,14 +36478,14 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.private_flag) = let _1 = -# 4117 "src/ocaml/preprocess/parser_raw.mly" +# 4082 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 29713 "src/ocaml/preprocess/parser_raw.ml" +# 36484 "src/ocaml/preprocess/parser_raw.ml" in -# 4114 "src/ocaml/preprocess/parser_raw.mly" +# 4079 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29718 "src/ocaml/preprocess/parser_raw.ml" +# 36489 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29737,14 +36508,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = let _1 = -# 4118 "src/ocaml/preprocess/parser_raw.mly" +# 4083 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 29743 "src/ocaml/preprocess/parser_raw.ml" +# 36514 "src/ocaml/preprocess/parser_raw.ml" in -# 4114 "src/ocaml/preprocess/parser_raw.mly" +# 4079 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 29748 "src/ocaml/preprocess/parser_raw.ml" +# 36519 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29760,9 +36531,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 4140 "src/ocaml/preprocess/parser_raw.mly" +# 4105 "src/ocaml/preprocess/parser_raw.mly" ( Public, Concrete ) -# 29766 "src/ocaml/preprocess/parser_raw.ml" +# 36537 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29785,9 +36556,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 4141 "src/ocaml/preprocess/parser_raw.mly" +# 4106 "src/ocaml/preprocess/parser_raw.mly" ( Private, Concrete ) -# 29791 "src/ocaml/preprocess/parser_raw.ml" +# 36562 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29810,9 +36581,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 4142 "src/ocaml/preprocess/parser_raw.mly" +# 4107 "src/ocaml/preprocess/parser_raw.mly" ( Public, Virtual ) -# 29816 "src/ocaml/preprocess/parser_raw.ml" +# 36587 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29842,9 +36613,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 4143 "src/ocaml/preprocess/parser_raw.mly" +# 4108 "src/ocaml/preprocess/parser_raw.mly" ( Private, Virtual ) -# 29848 "src/ocaml/preprocess/parser_raw.ml" +# 36619 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29874,9 +36645,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag * Asttypes.virtual_flag) = -# 4144 "src/ocaml/preprocess/parser_raw.mly" +# 4109 "src/ocaml/preprocess/parser_raw.mly" ( Private, Virtual ) -# 29880 "src/ocaml/preprocess/parser_raw.ml" +# 36651 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29892,9 +36663,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.rec_flag) = -# 4095 "src/ocaml/preprocess/parser_raw.mly" +# 4060 "src/ocaml/preprocess/parser_raw.mly" ( Nonrecursive ) -# 29898 "src/ocaml/preprocess/parser_raw.ml" +# 36669 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29917,9 +36688,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.rec_flag) = -# 4096 "src/ocaml/preprocess/parser_raw.mly" +# 4061 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 29923 "src/ocaml/preprocess/parser_raw.ml" +# 36694 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29945,12 +36716,12 @@ module Tables = struct (Longident.t Location.loc * Parsetree.expression) list) = let eo = # 124 "" ( None ) -# 29949 "src/ocaml/preprocess/parser_raw.ml" +# 36720 "src/ocaml/preprocess/parser_raw.ml" in -# 2986 "src/ocaml/preprocess/parser_raw.mly" +# 2951 "src/ocaml/preprocess/parser_raw.mly" ( eo, fields ) -# 29954 "src/ocaml/preprocess/parser_raw.ml" +# 36725 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -29991,18 +36762,18 @@ module Tables = struct let x = # 191 "" ( x ) -# 29995 "src/ocaml/preprocess/parser_raw.ml" +# 36766 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 30000 "src/ocaml/preprocess/parser_raw.ml" +# 36771 "src/ocaml/preprocess/parser_raw.ml" in -# 2986 "src/ocaml/preprocess/parser_raw.mly" +# 2951 "src/ocaml/preprocess/parser_raw.mly" ( eo, fields ) -# 30006 "src/ocaml/preprocess/parser_raw.ml" +# 36777 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30027,17 +36798,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3438 "src/ocaml/preprocess/parser_raw.mly" +# 3403 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30036 "src/ocaml/preprocess/parser_raw.ml" +# 36807 "src/ocaml/preprocess/parser_raw.ml" in -# 1295 "src/ocaml/preprocess/parser_raw.mly" +# 1260 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30041 "src/ocaml/preprocess/parser_raw.ml" +# 36812 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30062,17 +36833,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3438 "src/ocaml/preprocess/parser_raw.mly" +# 3403 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30071 "src/ocaml/preprocess/parser_raw.ml" +# 36842 "src/ocaml/preprocess/parser_raw.ml" in -# 1298 "src/ocaml/preprocess/parser_raw.mly" +# 1263 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30076 "src/ocaml/preprocess/parser_raw.ml" +# 36847 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30104,17 +36875,17 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.constructor_declaration list) = let x = -# 3438 "src/ocaml/preprocess/parser_raw.mly" +# 3403 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Type.constructor cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30113 "src/ocaml/preprocess/parser_raw.ml" +# 36884 "src/ocaml/preprocess/parser_raw.ml" in -# 1302 "src/ocaml/preprocess/parser_raw.mly" +# 1267 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30118 "src/ocaml/preprocess/parser_raw.ml" +# 36889 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30140,23 +36911,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3555 "src/ocaml/preprocess/parser_raw.mly" +# 3520 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30149 "src/ocaml/preprocess/parser_raw.ml" +# 36920 "src/ocaml/preprocess/parser_raw.ml" in -# 3549 "src/ocaml/preprocess/parser_raw.mly" +# 3514 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30154 "src/ocaml/preprocess/parser_raw.ml" +# 36925 "src/ocaml/preprocess/parser_raw.ml" in -# 1295 "src/ocaml/preprocess/parser_raw.mly" +# 1260 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30160 "src/ocaml/preprocess/parser_raw.ml" +# 36931 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30179,14 +36950,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3551 "src/ocaml/preprocess/parser_raw.mly" +# 3516 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30185 "src/ocaml/preprocess/parser_raw.ml" +# 36956 "src/ocaml/preprocess/parser_raw.ml" in -# 1295 "src/ocaml/preprocess/parser_raw.mly" +# 1260 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30190 "src/ocaml/preprocess/parser_raw.ml" +# 36961 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30212,23 +36983,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3555 "src/ocaml/preprocess/parser_raw.mly" +# 3520 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30221 "src/ocaml/preprocess/parser_raw.ml" +# 36992 "src/ocaml/preprocess/parser_raw.ml" in -# 3549 "src/ocaml/preprocess/parser_raw.mly" +# 3514 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30226 "src/ocaml/preprocess/parser_raw.ml" +# 36997 "src/ocaml/preprocess/parser_raw.ml" in -# 1298 "src/ocaml/preprocess/parser_raw.mly" +# 1263 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30232 "src/ocaml/preprocess/parser_raw.ml" +# 37003 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30251,14 +37022,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3551 "src/ocaml/preprocess/parser_raw.mly" +# 3516 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30257 "src/ocaml/preprocess/parser_raw.ml" +# 37028 "src/ocaml/preprocess/parser_raw.ml" in -# 1298 "src/ocaml/preprocess/parser_raw.mly" +# 1263 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30262 "src/ocaml/preprocess/parser_raw.ml" +# 37033 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30291,23 +37062,23 @@ module Tables = struct let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = let _1 = -# 3555 "src/ocaml/preprocess/parser_raw.mly" +# 3520 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30300 "src/ocaml/preprocess/parser_raw.ml" +# 37071 "src/ocaml/preprocess/parser_raw.ml" in -# 3549 "src/ocaml/preprocess/parser_raw.mly" +# 3514 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30305 "src/ocaml/preprocess/parser_raw.ml" +# 37076 "src/ocaml/preprocess/parser_raw.ml" in -# 1302 "src/ocaml/preprocess/parser_raw.mly" +# 1267 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30311 "src/ocaml/preprocess/parser_raw.ml" +# 37082 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30337,14 +37108,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos__1_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3551 "src/ocaml/preprocess/parser_raw.mly" +# 3516 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 30343 "src/ocaml/preprocess/parser_raw.ml" +# 37114 "src/ocaml/preprocess/parser_raw.ml" in -# 1302 "src/ocaml/preprocess/parser_raw.mly" +# 1267 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30348 "src/ocaml/preprocess/parser_raw.ml" +# 37119 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30369,17 +37140,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3555 "src/ocaml/preprocess/parser_raw.mly" +# 3520 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30378 "src/ocaml/preprocess/parser_raw.ml" +# 37149 "src/ocaml/preprocess/parser_raw.ml" in -# 1295 "src/ocaml/preprocess/parser_raw.mly" +# 1260 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30383 "src/ocaml/preprocess/parser_raw.ml" +# 37154 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30404,17 +37175,17 @@ module Tables = struct let _startpos = _startpos_d_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3555 "src/ocaml/preprocess/parser_raw.mly" +# 3520 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30413 "src/ocaml/preprocess/parser_raw.ml" +# 37184 "src/ocaml/preprocess/parser_raw.ml" in -# 1298 "src/ocaml/preprocess/parser_raw.mly" +# 1263 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30418 "src/ocaml/preprocess/parser_raw.ml" +# 37189 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30446,17 +37217,17 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_d_ in let _v : (Parsetree.extension_constructor list) = let x = -# 3555 "src/ocaml/preprocess/parser_raw.mly" +# 3520 "src/ocaml/preprocess/parser_raw.mly" ( let cid, vars, args, res, attrs, loc, info = d in Te.decl cid ~vars ~args ?res ~attrs ~loc ~info ) -# 30455 "src/ocaml/preprocess/parser_raw.ml" +# 37226 "src/ocaml/preprocess/parser_raw.ml" in -# 1302 "src/ocaml/preprocess/parser_raw.mly" +# 1267 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30460 "src/ocaml/preprocess/parser_raw.ml" +# 37231 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30472,9 +37243,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * Parsetree.core_type * Location.t) list) = -# 1140 "src/ocaml/preprocess/parser_raw.mly" +# 1105 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 30478 "src/ocaml/preprocess/parser_raw.ml" +# 37249 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30531,21 +37302,21 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2334 "src/ocaml/preprocess/parser_raw.mly" +# 2299 "src/ocaml/preprocess/parser_raw.mly" ( _1, _3, make_loc _sloc ) -# 30537 "src/ocaml/preprocess/parser_raw.ml" +# 37308 "src/ocaml/preprocess/parser_raw.ml" in # 183 "" ( x ) -# 30543 "src/ocaml/preprocess/parser_raw.ml" +# 37314 "src/ocaml/preprocess/parser_raw.ml" in -# 1142 "src/ocaml/preprocess/parser_raw.mly" +# 1107 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30549 "src/ocaml/preprocess/parser_raw.ml" +# 37320 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30568,9 +37339,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.function_param list) = -# 1173 "src/ocaml/preprocess/parser_raw.mly" +# 1138 "src/ocaml/preprocess/parser_raw.mly" ( List.rev x ) -# 30574 "src/ocaml/preprocess/parser_raw.ml" +# 37345 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30600,9 +37371,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.function_param list) = -# 1175 "src/ocaml/preprocess/parser_raw.mly" +# 1140 "src/ocaml/preprocess/parser_raw.mly" ( List.rev_append x xs ) -# 30606 "src/ocaml/preprocess/parser_raw.ml" +# 37377 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30625,9 +37396,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1154 "src/ocaml/preprocess/parser_raw.mly" +# 1119 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30631 "src/ocaml/preprocess/parser_raw.ml" +# 37402 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30657,9 +37428,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Lexing.position * Parsetree.functor_parameter) list) = -# 1156 "src/ocaml/preprocess/parser_raw.mly" +# 1121 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30663 "src/ocaml/preprocess/parser_raw.ml" +# 37434 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30682,9 +37453,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Asttypes.arg_label * Parsetree.expression) list) = -# 1154 "src/ocaml/preprocess/parser_raw.mly" +# 1119 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30688 "src/ocaml/preprocess/parser_raw.ml" +# 37459 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30714,9 +37485,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Asttypes.arg_label * Parsetree.expression) list) = -# 1156 "src/ocaml/preprocess/parser_raw.mly" +# 1121 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30720 "src/ocaml/preprocess/parser_raw.ml" +# 37491 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30739,9 +37510,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (string list) = -# 1154 "src/ocaml/preprocess/parser_raw.mly" +# 1119 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30745 "src/ocaml/preprocess/parser_raw.ml" +# 37516 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30771,9 +37542,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (string list) = -# 1156 "src/ocaml/preprocess/parser_raw.mly" +# 1121 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30777 "src/ocaml/preprocess/parser_raw.ml" +# 37548 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30807,15 +37578,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3613 "src/ocaml/preprocess/parser_raw.mly" +# 3578 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _2 _sloc ) -# 30813 "src/ocaml/preprocess/parser_raw.ml" +# 37584 "src/ocaml/preprocess/parser_raw.ml" in -# 1154 "src/ocaml/preprocess/parser_raw.mly" +# 1119 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 30819 "src/ocaml/preprocess/parser_raw.ml" +# 37590 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30856,15 +37627,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3613 "src/ocaml/preprocess/parser_raw.mly" +# 3578 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _2 _sloc ) -# 30862 "src/ocaml/preprocess/parser_raw.ml" +# 37633 "src/ocaml/preprocess/parser_raw.ml" in -# 1156 "src/ocaml/preprocess/parser_raw.mly" +# 1121 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30868 "src/ocaml/preprocess/parser_raw.ml" +# 37639 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30889,12 +37660,12 @@ module Tables = struct let _v : (Parsetree.case list) = let _1 = # 124 "" ( None ) -# 30893 "src/ocaml/preprocess/parser_raw.ml" +# 37664 "src/ocaml/preprocess/parser_raw.ml" in -# 1266 "src/ocaml/preprocess/parser_raw.mly" +# 1231 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30898 "src/ocaml/preprocess/parser_raw.ml" +# 37669 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30928,13 +37699,13 @@ module Tables = struct # 126 "" ( Some x ) -# 30932 "src/ocaml/preprocess/parser_raw.ml" +# 37703 "src/ocaml/preprocess/parser_raw.ml" in -# 1266 "src/ocaml/preprocess/parser_raw.mly" +# 1231 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 30938 "src/ocaml/preprocess/parser_raw.ml" +# 37709 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30971,9 +37742,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.case list) = -# 1270 "src/ocaml/preprocess/parser_raw.mly" +# 1235 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 30977 "src/ocaml/preprocess/parser_raw.ml" +# 37748 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -30997,20 +37768,20 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type list) = let xs = let x = -# 3656 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31003 "src/ocaml/preprocess/parser_raw.ml" +# 37774 "src/ocaml/preprocess/parser_raw.ml" in -# 1201 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31008 "src/ocaml/preprocess/parser_raw.ml" +# 37779 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31014 "src/ocaml/preprocess/parser_raw.ml" +# 37785 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31048,20 +37819,20 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type list) = let xs = let x = -# 3656 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31054 "src/ocaml/preprocess/parser_raw.ml" +# 37825 "src/ocaml/preprocess/parser_raw.ml" in -# 1205 "src/ocaml/preprocess/parser_raw.mly" +# 1170 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31059 "src/ocaml/preprocess/parser_raw.ml" +# 37830 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31065 "src/ocaml/preprocess/parser_raw.ml" +# 37836 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31084,14 +37855,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.with_constraint list) = let xs = -# 1201 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31090 "src/ocaml/preprocess/parser_raw.ml" +# 37861 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31095 "src/ocaml/preprocess/parser_raw.ml" +# 37866 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31128,14 +37899,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.with_constraint list) = let xs = -# 1205 "src/ocaml/preprocess/parser_raw.mly" +# 1170 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31134 "src/ocaml/preprocess/parser_raw.ml" +# 37905 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31139 "src/ocaml/preprocess/parser_raw.ml" +# 37910 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31158,14 +37929,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.row_field list) = let xs = -# 1201 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31164 "src/ocaml/preprocess/parser_raw.ml" +# 37935 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31169 "src/ocaml/preprocess/parser_raw.ml" +# 37940 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31202,14 +37973,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.row_field list) = let xs = -# 1205 "src/ocaml/preprocess/parser_raw.mly" +# 1170 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31208 "src/ocaml/preprocess/parser_raw.ml" +# 37979 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31213 "src/ocaml/preprocess/parser_raw.ml" +# 37984 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31232,14 +38003,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1201 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31238 "src/ocaml/preprocess/parser_raw.ml" +# 38009 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31243 "src/ocaml/preprocess/parser_raw.ml" +# 38014 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31276,14 +38047,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1205 "src/ocaml/preprocess/parser_raw.mly" +# 1170 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31282 "src/ocaml/preprocess/parser_raw.ml" +# 38053 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31287 "src/ocaml/preprocess/parser_raw.ml" +# 38058 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31306,14 +38077,14 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = -# 1201 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31312 "src/ocaml/preprocess/parser_raw.ml" +# 38083 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31317 "src/ocaml/preprocess/parser_raw.ml" +# 38088 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31350,14 +38121,14 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = let xs = -# 1205 "src/ocaml/preprocess/parser_raw.mly" +# 1170 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31356 "src/ocaml/preprocess/parser_raw.ml" +# 38127 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31361 "src/ocaml/preprocess/parser_raw.ml" +# 38132 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31380,14 +38151,187 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = let xs = -# 1201 "src/ocaml/preprocess/parser_raw.mly" +# 1166 "src/ocaml/preprocess/parser_raw.mly" ( [ x ] ) -# 31386 "src/ocaml/preprocess/parser_raw.ml" +# 38157 "src/ocaml/preprocess/parser_raw.ml" in -# 1209 "src/ocaml/preprocess/parser_raw.mly" +# 1174 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31391 "src/ocaml/preprocess/parser_raw.ml" +# 38162 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = +# 1170 "src/ocaml/preprocess/parser_raw.mly" + ( x :: xs ) +# 38201 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1174 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 38206 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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) = +# 1197 "src/ocaml/preprocess/parser_raw.mly" + ( x :: xs ) +# 38245 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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) = +# 1201 "src/ocaml/preprocess/parser_raw.mly" + ( [ x2; x1 ] ) +# 38284 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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.expression) = Obj.magic _1 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__1_ in + let _v : (Parsetree.expression list) = let x = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38324 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38329 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1197 "src/ocaml/preprocess/parser_raw.mly" + ( x :: xs ) +# 38335 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31400,38 +38344,119 @@ module Tables = struct 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.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.semv = _1_inlined2; + MenhirLib.EngineTypes.startp = _startpos__1_inlined2_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined2_; 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; + 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 = _; + MenhirLib.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 xs_inlined1 : (Parsetree.case list) = Obj.magic xs_inlined1 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 _2 : unit = Obj.magic _2 in - let xs : (Parsetree.core_type list) = Obj.magic xs 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.core_type list) = let xs = -# 1205 "src/ocaml/preprocess/parser_raw.mly" - ( x :: xs ) -# 31430 "src/ocaml/preprocess/parser_raw.ml" - in - -# 1209 "src/ocaml/preprocess/parser_raw.mly" + let _endpos = _endpos_xs_inlined1_ in + let _v : (Parsetree.expression list) = let x = + let (_endpos_xs_, xs) = (_endpos_xs_inlined1_, xs_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 38400 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 38405 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 31435 "src/ocaml/preprocess/parser_raw.ml" +# 38411 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38422 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 38428 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 38448 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38454 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1197 "src/ocaml/preprocess/parser_raw.mly" + ( x :: xs ) +# 38460 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31444,9 +38469,9 @@ module Tables = struct 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.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; @@ -31454,23 +38479,48 @@ module Tables = struct 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.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_inlined1 : (Parsetree.expression) = Obj.magic _1_inlined1 in let _2 : unit = Obj.magic _2 in - let xs : (Parsetree.core_type 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_xs_ in - let _endpos = _endpos_x_ in - let _v : (Parsetree.core_type list) = -# 1232 "src/ocaml/preprocess/parser_raw.mly" - ( x :: xs ) -# 31474 "src/ocaml/preprocess/parser_raw.ml" + let _startpos = _startpos__1_ in + let _endpos = _endpos__1_inlined1_ in + let _v : (Parsetree.expression list) = let x2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38501 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38506 "src/ocaml/preprocess/parser_raw.ml" + + in + let x1 = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38513 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38518 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1201 "src/ocaml/preprocess/parser_raw.mly" + ( [ x2; x1 ] ) +# 38524 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31483,33 +38533,131 @@ module Tables = struct 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.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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; 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; + 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 x2 : (Parsetree.core_type) = Obj.magic x2 in + let xs : (Parsetree.case list) = Obj.magic xs 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 x1 : (Parsetree.core_type) = Obj.magic x1 in + let _1 : (Parsetree.expression) = Obj.magic _1 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) = -# 1236 "src/ocaml/preprocess/parser_raw.mly" + let _startpos = _startpos__1_ in + let _endpos = _endpos_xs_ in + let _v : (Parsetree.expression list) = let x2 = + let (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 38589 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 38594 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 38600 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38611 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 38617 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 38637 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38643 "src/ocaml/preprocess/parser_raw.ml" + + in + let x1 = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38650 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38655 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1201 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31513 "src/ocaml/preprocess/parser_raw.ml" +# 38661 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31522,33 +38670,131 @@ module Tables = struct 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.semv = _1_inlined3; + MenhirLib.EngineTypes.startp = _startpos__1_inlined3_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined3_; 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.state = _; MenhirLib.EngineTypes.semv = xs; MenhirLib.EngineTypes.startp = _startpos_xs_; MenhirLib.EngineTypes.endp = _endpos_xs_; - MenhirLib.EngineTypes.next = _menhir_stack; + 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 x : (Parsetree.expression) = Obj.magic x in + let _1_inlined3 : (Parsetree.expression) = Obj.magic _1_inlined3 in let _2 : unit = Obj.magic _2 in - let xs : (Parsetree.expression list) = Obj.magic xs 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_xs_ in - let _endpos = _endpos_x_ in - let _v : (Parsetree.expression list) = -# 1232 "src/ocaml/preprocess/parser_raw.mly" - ( x :: xs ) -# 31552 "src/ocaml/preprocess/parser_raw.ml" + let _startpos = _startpos__1_ in + let _endpos = _endpos__1_inlined3_ in + let _v : (Parsetree.expression list) = let x2 = + let _1 = _1_inlined3 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38723 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38728 "src/ocaml/preprocess/parser_raw.ml" + + in + let x1 = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 38738 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 38743 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 38749 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38760 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 38766 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 38786 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38792 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1201 "src/ocaml/preprocess/parser_raw.mly" + ( [ x2; x1 ] ) +# 38798 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31561,33 +38807,204 @@ module Tables = struct 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.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.semv = _1_inlined5; + MenhirLib.EngineTypes.startp = _startpos__1_inlined5_; + MenhirLib.EngineTypes.endp = _endpos__1_inlined5_; 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; + 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 = _2; + MenhirLib.EngineTypes.startp = _startpos__2_; + MenhirLib.EngineTypes.endp = _endpos__2_; + 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 = _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 x2 : (Parsetree.expression) = Obj.magic x2 in + let xs_inlined1 : (Parsetree.case list) = Obj.magic xs_inlined1 in + let _1_inlined5 : (Parsetree.attributes) = Obj.magic _1_inlined5 in + let _1_inlined4 : (string Location.loc option) = Obj.magic _1_inlined4 in + let _1_inlined3 : unit = Obj.magic _1_inlined3 in let _2 : unit = Obj.magic _2 in - let x1 : (Parsetree.expression) = Obj.magic x1 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_x1_ in - let _endpos = _endpos_x2_ in - let _v : (Parsetree.expression list) = -# 1236 "src/ocaml/preprocess/parser_raw.mly" + let _startpos = _startpos__1_ in + let _endpos = _endpos_xs_inlined1_ in + let _v : (Parsetree.expression list) = let x2 = + let (_endpos_xs_, _startpos__1_, xs, _1_inlined2, _1_inlined1, _1) = (_endpos_xs_inlined1_, _startpos__1_inlined3_, xs_inlined1, _1_inlined5, _1_inlined4, _1_inlined3) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 38884 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 38889 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 38895 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38906 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 38912 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 38932 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38938 "src/ocaml/preprocess/parser_raw.ml" + + in + let x1 = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 38948 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 38953 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 38959 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 38970 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 38976 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 38996 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39002 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1201 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31591 "src/ocaml/preprocess/parser_raw.ml" +# 39008 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31624,9 +39041,9 @@ module Tables = struct let _startpos = _startpos_xs_ in let _endpos = _endpos_x_ in let _v : (Parsetree.core_type list) = -# 1232 "src/ocaml/preprocess/parser_raw.mly" +# 1197 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31630 "src/ocaml/preprocess/parser_raw.ml" +# 39047 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31663,9 +39080,9 @@ module Tables = struct let _startpos = _startpos_x1_ in let _endpos = _endpos_x2_ in let _v : (Parsetree.core_type list) = -# 1236 "src/ocaml/preprocess/parser_raw.mly" +# 1201 "src/ocaml/preprocess/parser_raw.mly" ( [ x2; x1 ] ) -# 31669 "src/ocaml/preprocess/parser_raw.ml" +# 39086 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31688,9 +39105,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.row_field) = -# 3852 "src/ocaml/preprocess/parser_raw.mly" +# 3817 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31694 "src/ocaml/preprocess/parser_raw.ml" +# 39111 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31716,9 +39133,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3854 "src/ocaml/preprocess/parser_raw.mly" +# 3819 "src/ocaml/preprocess/parser_raw.mly" ( Rf.inherit_ ~loc:(make_loc _sloc) _1 ) -# 31722 "src/ocaml/preprocess/parser_raw.ml" +# 39139 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31731,24 +39148,36 @@ module Tables = struct 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.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 : (Parsetree.expression) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in - let _startpos = _startpos_x_ in - let _endpos = _endpos_x_ in + let _startpos = _startpos__1_ in + let _endpos = _endpos__1_ in let _v : (Parsetree.expression list) = let _2 = # 124 "" ( None ) -# 31747 "src/ocaml/preprocess/parser_raw.ml" +# 39164 "src/ocaml/preprocess/parser_raw.ml" in + let x = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39170 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39175 "src/ocaml/preprocess/parser_raw.ml" + + in -# 1253 "src/ocaml/preprocess/parser_raw.mly" +# 1218 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31752 "src/ocaml/preprocess/parser_raw.ml" +# 39181 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31761,34 +39190,280 @@ module Tables = struct 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.semv = x; + MenhirLib.EngineTypes.startp = _startpos_x_; + MenhirLib.EngineTypes.endp = _endpos_x_; MenhirLib.EngineTypes.next = { MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = x; - MenhirLib.EngineTypes.startp = _startpos_x_; - MenhirLib.EngineTypes.endp = _endpos_x_; + MenhirLib.EngineTypes.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; 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 x : unit = Obj.magic x in + let _1 : (Parsetree.expression) = Obj.magic _1 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 + let _startpos = _startpos__1_ in + let _endpos = _endpos_x_ in + let _v : (Parsetree.expression list) = let _2 = +# 126 "" + ( Some x ) +# 39213 "src/ocaml/preprocess/parser_raw.ml" + in + let x = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39219 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39224 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1218 "src/ocaml/preprocess/parser_raw.mly" + ( [x] ) +# 39230 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 list) = let _2 = +# 124 "" + ( None ) +# 39276 "src/ocaml/preprocess/parser_raw.ml" + in + let x = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 39285 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 39290 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 39296 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39307 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 39313 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 39333 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39339 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1218 "src/ocaml/preprocess/parser_raw.mly" + ( [x] ) +# 39345 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = 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 x : unit = Obj.magic x 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_x_ in + let _v : (Parsetree.expression list) = let _2 = # 126 "" ( Some x ) -# 31786 "src/ocaml/preprocess/parser_raw.ml" +# 39398 "src/ocaml/preprocess/parser_raw.ml" + in + let x = + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 39407 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 39412 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 39418 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39429 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 39435 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 39455 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39461 "src/ocaml/preprocess/parser_raw.ml" in -# 1253 "src/ocaml/preprocess/parser_raw.mly" +# 1218 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31792 "src/ocaml/preprocess/parser_raw.ml" +# 39467 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31811,23 +39486,160 @@ module Tables = struct 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.semv = _1; + MenhirLib.EngineTypes.startp = _startpos__1_; + MenhirLib.EngineTypes.endp = _endpos__1_; 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 _1 : (Parsetree.expression) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in - let _startpos = _startpos_x_ in + let _startpos = _startpos__1_ in let _endpos = _endpos_xs_ in - let _v : (Parsetree.expression list) = -# 1257 "src/ocaml/preprocess/parser_raw.mly" + let _v : (Parsetree.expression list) = let x = + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39507 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39512 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1222 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 31831 "src/ocaml/preprocess/parser_raw.ml" +# 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 = _; + 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 = xs_inlined1; + MenhirLib.EngineTypes.startp = _startpos_xs_inlined1_; + MenhirLib.EngineTypes.endp = _endpos_xs_inlined1_; + 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.expression list) = Obj.magic xs in + let _2 : unit = Obj.magic _2 in + let xs_inlined1 : (Parsetree.case list) = Obj.magic xs_inlined1 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 list) = let x = + let (_endpos_xs_, xs) = (_endpos_xs_inlined1_, xs_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 39583 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 39588 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 39594 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39605 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 39611 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 39631 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 39637 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 1222 "src/ocaml/preprocess/parser_raw.mly" + ( x :: xs ) +# 39643 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31853,9 +39665,9 @@ module Tables = struct } = _menhir_stack in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31859 "src/ocaml/preprocess/parser_raw.ml" +# 39671 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31863,26 +39675,26 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 31867 "src/ocaml/preprocess/parser_raw.ml" +# 39679 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31874 "src/ocaml/preprocess/parser_raw.ml" +# 39686 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31882 "src/ocaml/preprocess/parser_raw.ml" +# 39694 "src/ocaml/preprocess/parser_raw.ml" in -# 3009 "src/ocaml/preprocess/parser_raw.mly" +# 2974 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31892,13 +39704,13 @@ module Tables = struct label, e in label, e ) -# 31896 "src/ocaml/preprocess/parser_raw.ml" +# 39708 "src/ocaml/preprocess/parser_raw.ml" in -# 1253 "src/ocaml/preprocess/parser_raw.mly" +# 1218 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31902 "src/ocaml/preprocess/parser_raw.ml" +# 39714 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -31931,9 +39743,9 @@ module Tables = struct let x : unit = Obj.magic x in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 31937 "src/ocaml/preprocess/parser_raw.ml" +# 39749 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -31941,26 +39753,26 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 31945 "src/ocaml/preprocess/parser_raw.ml" +# 39757 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 31952 "src/ocaml/preprocess/parser_raw.ml" +# 39764 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 31960 "src/ocaml/preprocess/parser_raw.ml" +# 39772 "src/ocaml/preprocess/parser_raw.ml" in -# 3009 "src/ocaml/preprocess/parser_raw.mly" +# 2974 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -31970,13 +39782,13 @@ module Tables = struct label, e in label, e ) -# 31974 "src/ocaml/preprocess/parser_raw.ml" +# 39786 "src/ocaml/preprocess/parser_raw.ml" in -# 1253 "src/ocaml/preprocess/parser_raw.mly" +# 1218 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 31980 "src/ocaml/preprocess/parser_raw.ml" +# 39792 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32016,9 +39828,9 @@ module Tables = struct let _2 : unit = Obj.magic _2 in let oe : (Parsetree.expression option) = Obj.magic oe in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 32022 "src/ocaml/preprocess/parser_raw.ml" +# 39834 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -32026,21 +39838,21 @@ module Tables = struct let _v : ((string Location.loc * Parsetree.expression) list) = let x = let label = let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32032 "src/ocaml/preprocess/parser_raw.ml" +# 39844 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32040 "src/ocaml/preprocess/parser_raw.ml" +# 39852 "src/ocaml/preprocess/parser_raw.ml" in -# 3009 "src/ocaml/preprocess/parser_raw.mly" +# 2974 "src/ocaml/preprocess/parser_raw.mly" ( let label, e = match oe with | None -> @@ -32050,13 +39862,13 @@ module Tables = struct label, e in label, e ) -# 32054 "src/ocaml/preprocess/parser_raw.ml" +# 39866 "src/ocaml/preprocess/parser_raw.ml" in -# 1257 "src/ocaml/preprocess/parser_raw.mly" +# 1222 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 32060 "src/ocaml/preprocess/parser_raw.ml" +# 39872 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32081,12 +39893,12 @@ module Tables = struct let _v : (Parsetree.pattern list) = let _2 = # 124 "" ( None ) -# 32085 "src/ocaml/preprocess/parser_raw.ml" +# 39897 "src/ocaml/preprocess/parser_raw.ml" in -# 1253 "src/ocaml/preprocess/parser_raw.mly" +# 1218 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32090 "src/ocaml/preprocess/parser_raw.ml" +# 39902 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32120,13 +39932,13 @@ module Tables = struct # 126 "" ( Some x ) -# 32124 "src/ocaml/preprocess/parser_raw.ml" +# 39936 "src/ocaml/preprocess/parser_raw.ml" in -# 1253 "src/ocaml/preprocess/parser_raw.mly" +# 1218 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32130 "src/ocaml/preprocess/parser_raw.ml" +# 39942 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32163,9 +39975,9 @@ module Tables = struct let _startpos = _startpos_x_ in let _endpos = _endpos_xs_ in let _v : (Parsetree.pattern list) = -# 1257 "src/ocaml/preprocess/parser_raw.mly" +# 1222 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 32169 "src/ocaml/preprocess/parser_raw.ml" +# 39981 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32204,7 +40016,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 124 "" ( None ) -# 32208 "src/ocaml/preprocess/parser_raw.ml" +# 40020 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -32212,9 +40024,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32218 "src/ocaml/preprocess/parser_raw.ml" +# 40030 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -32222,7 +40034,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2992 "src/ocaml/preprocess/parser_raw.mly" +# 2957 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -32232,13 +40044,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 32236 "src/ocaml/preprocess/parser_raw.ml" +# 40048 "src/ocaml/preprocess/parser_raw.ml" in -# 1253 "src/ocaml/preprocess/parser_raw.mly" +# 1218 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32242 "src/ocaml/preprocess/parser_raw.ml" +# 40054 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32284,7 +40096,7 @@ module Tables = struct let _v : ((Longident.t Location.loc * Parsetree.expression) list) = let _2 = # 126 "" ( Some x ) -# 32288 "src/ocaml/preprocess/parser_raw.ml" +# 40100 "src/ocaml/preprocess/parser_raw.ml" in let x = let label = @@ -32292,9 +40104,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32298 "src/ocaml/preprocess/parser_raw.ml" +# 40110 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -32302,7 +40114,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2992 "src/ocaml/preprocess/parser_raw.mly" +# 2957 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -32312,13 +40124,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 32316 "src/ocaml/preprocess/parser_raw.ml" +# 40128 "src/ocaml/preprocess/parser_raw.ml" in -# 1253 "src/ocaml/preprocess/parser_raw.mly" +# 1218 "src/ocaml/preprocess/parser_raw.mly" ( [x] ) -# 32322 "src/ocaml/preprocess/parser_raw.ml" +# 40134 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32374,9 +40186,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32380 "src/ocaml/preprocess/parser_raw.ml" +# 40192 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_label_ = _startpos__1_ in @@ -32384,7 +40196,7 @@ module Tables = struct let _symbolstartpos = _startpos_label_ in let _sloc = (_symbolstartpos, _endpos) in -# 2992 "src/ocaml/preprocess/parser_raw.mly" +# 2957 "src/ocaml/preprocess/parser_raw.mly" ( let constraint_loc, label, e = match eo with | None -> @@ -32394,13 +40206,13 @@ module Tables = struct (_startpos_c_, _endpos), label, e in label, mkexp_opt_constraint ~loc:constraint_loc e c ) -# 32398 "src/ocaml/preprocess/parser_raw.ml" +# 40210 "src/ocaml/preprocess/parser_raw.ml" in -# 1257 "src/ocaml/preprocess/parser_raw.mly" +# 1222 "src/ocaml/preprocess/parser_raw.mly" ( x :: xs ) -# 32404 "src/ocaml/preprocess/parser_raw.ml" +# 40216 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32423,14 +40235,14 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = -# 2424 "src/ocaml/preprocess/parser_raw.mly" +# 2389 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32429 "src/ocaml/preprocess/parser_raw.ml" +# 40241 "src/ocaml/preprocess/parser_raw.ml" in -# 2462 "src/ocaml/preprocess/parser_raw.mly" +# 2427 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32434 "src/ocaml/preprocess/parser_raw.ml" +# 40246 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32479,18 +40291,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 32483 "src/ocaml/preprocess/parser_raw.ml" +# 40295 "src/ocaml/preprocess/parser_raw.ml" in -# 1278 "src/ocaml/preprocess/parser_raw.mly" +# 1243 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 32488 "src/ocaml/preprocess/parser_raw.ml" +# 40300 "src/ocaml/preprocess/parser_raw.ml" in -# 2928 "src/ocaml/preprocess/parser_raw.mly" +# 2893 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 32494 "src/ocaml/preprocess/parser_raw.ml" +# 40306 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos_xs_ in @@ -32499,22 +40311,22 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32505 "src/ocaml/preprocess/parser_raw.ml" +# 40317 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 32511 "src/ocaml/preprocess/parser_raw.ml" +# 40323 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2426 "src/ocaml/preprocess/parser_raw.mly" +# 2391 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let cases = _3 in (* There are two choices of where to put attributes: on the @@ -32527,13 +40339,13 @@ module Tables = struct let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in mkexp_attrs ~loc:_sloc desc _2 ) -# 32531 "src/ocaml/preprocess/parser_raw.ml" +# 40343 "src/ocaml/preprocess/parser_raw.ml" in -# 2462 "src/ocaml/preprocess/parser_raw.mly" +# 2427 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32537 "src/ocaml/preprocess/parser_raw.ml" +# 40349 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32601,18 +40413,18 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = let attrs = let _1 = _1_inlined4 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32607 "src/ocaml/preprocess/parser_raw.ml" +# 40419 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined4_ in let attrs2 = let _1 = _1_inlined3 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32616 "src/ocaml/preprocess/parser_raw.ml" +# 40428 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -32622,17 +40434,17 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 32628 "src/ocaml/preprocess/parser_raw.ml" +# 40440 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32636 "src/ocaml/preprocess/parser_raw.ml" +# 40448 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in @@ -32640,14 +40452,14 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3468 "src/ocaml/preprocess/parser_raw.mly" +# 3433 "src/ocaml/preprocess/parser_raw.mly" ( let vars, args, res = vars_args_res in let loc = make_loc (_startpos, _endpos_attrs2_) in let docs = symbol_docs _sloc in Te.mk_exception ~attrs (Te.decl id ~vars ~args ?res ~attrs:(attrs1 @ attrs2) ~loc ~docs) , ext ) -# 32651 "src/ocaml/preprocess/parser_raw.ml" +# 40463 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32673,21 +40485,21 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 32677 "src/ocaml/preprocess/parser_raw.ml" +# 40489 "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 -# 1055 "src/ocaml/preprocess/parser_raw.mly" +# 1020 "src/ocaml/preprocess/parser_raw.mly" ( extra_sig _startpos _endpos _1 ) -# 32685 "src/ocaml/preprocess/parser_raw.ml" +# 40497 "src/ocaml/preprocess/parser_raw.ml" in -# 1858 "src/ocaml/preprocess/parser_raw.mly" +# 1823 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32691 "src/ocaml/preprocess/parser_raw.ml" +# 40503 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32719,9 +40531,9 @@ module Tables = struct let _v : (Parsetree.signature_item) = let _2 = let _1 = _1_inlined1 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32725 "src/ocaml/preprocess/parser_raw.ml" +# 40537 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -32729,10 +40541,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1873 "src/ocaml/preprocess/parser_raw.mly" +# 1838 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in mksig ~loc:_sloc (Psig_extension (_1, (add_docs_attrs docs _2))) ) -# 32736 "src/ocaml/preprocess/parser_raw.ml" +# 40548 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32756,23 +40568,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1877 "src/ocaml/preprocess/parser_raw.mly" +# 1842 "src/ocaml/preprocess/parser_raw.mly" ( Psig_attribute _1 ) -# 32762 "src/ocaml/preprocess/parser_raw.ml" +# 40574 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1103 "src/ocaml/preprocess/parser_raw.mly" +# 1068 "src/ocaml/preprocess/parser_raw.mly" ( mksig ~loc:_sloc _1 ) -# 32770 "src/ocaml/preprocess/parser_raw.ml" +# 40582 "src/ocaml/preprocess/parser_raw.ml" in -# 1879 "src/ocaml/preprocess/parser_raw.mly" +# 1844 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32776 "src/ocaml/preprocess/parser_raw.ml" +# 40588 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32796,23 +40608,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1882 "src/ocaml/preprocess/parser_raw.mly" +# 1847 "src/ocaml/preprocess/parser_raw.mly" ( psig_value _1 ) -# 32802 "src/ocaml/preprocess/parser_raw.ml" +# 40614 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32810 "src/ocaml/preprocess/parser_raw.ml" +# 40622 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32816 "src/ocaml/preprocess/parser_raw.ml" +# 40628 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32836,23 +40648,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1884 "src/ocaml/preprocess/parser_raw.mly" +# 1849 "src/ocaml/preprocess/parser_raw.mly" ( psig_value _1 ) -# 32842 "src/ocaml/preprocess/parser_raw.ml" +# 40654 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32850 "src/ocaml/preprocess/parser_raw.ml" +# 40662 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32856 "src/ocaml/preprocess/parser_raw.ml" +# 40668 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32887,26 +40699,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1314 "src/ocaml/preprocess/parser_raw.mly" +# 1279 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 32893 "src/ocaml/preprocess/parser_raw.ml" +# 40705 "src/ocaml/preprocess/parser_raw.ml" in -# 3287 "src/ocaml/preprocess/parser_raw.mly" +# 3252 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32898 "src/ocaml/preprocess/parser_raw.ml" +# 40710 "src/ocaml/preprocess/parser_raw.ml" in -# 3270 "src/ocaml/preprocess/parser_raw.mly" +# 3235 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32904 "src/ocaml/preprocess/parser_raw.ml" +# 40716 "src/ocaml/preprocess/parser_raw.ml" in -# 1886 "src/ocaml/preprocess/parser_raw.mly" +# 1851 "src/ocaml/preprocess/parser_raw.mly" ( psig_type _1 ) -# 32910 "src/ocaml/preprocess/parser_raw.ml" +# 40722 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -32914,15 +40726,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32920 "src/ocaml/preprocess/parser_raw.ml" +# 40732 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32926 "src/ocaml/preprocess/parser_raw.ml" +# 40738 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -32957,26 +40769,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1314 "src/ocaml/preprocess/parser_raw.mly" +# 1279 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 32963 "src/ocaml/preprocess/parser_raw.ml" +# 40775 "src/ocaml/preprocess/parser_raw.ml" in -# 3287 "src/ocaml/preprocess/parser_raw.mly" +# 3252 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32968 "src/ocaml/preprocess/parser_raw.ml" +# 40780 "src/ocaml/preprocess/parser_raw.ml" in -# 3275 "src/ocaml/preprocess/parser_raw.mly" +# 3240 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32974 "src/ocaml/preprocess/parser_raw.ml" +# 40786 "src/ocaml/preprocess/parser_raw.ml" in -# 1888 "src/ocaml/preprocess/parser_raw.mly" +# 1853 "src/ocaml/preprocess/parser_raw.mly" ( psig_typesubst _1 ) -# 32980 "src/ocaml/preprocess/parser_raw.ml" +# 40792 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -32984,15 +40796,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 32990 "src/ocaml/preprocess/parser_raw.ml" +# 40802 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 32996 "src/ocaml/preprocess/parser_raw.ml" +# 40808 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33077,16 +40889,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33083 "src/ocaml/preprocess/parser_raw.ml" +# 40895 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = -# 1306 "src/ocaml/preprocess/parser_raw.mly" +# 1271 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 33090 "src/ocaml/preprocess/parser_raw.ml" +# 40902 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -33094,46 +40906,46 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33100 "src/ocaml/preprocess/parser_raw.ml" +# 40912 "src/ocaml/preprocess/parser_raw.ml" in let _4 = -# 4103 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 33106 "src/ocaml/preprocess/parser_raw.ml" +# 40918 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33113 "src/ocaml/preprocess/parser_raw.ml" +# 40925 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3542 "src/ocaml/preprocess/parser_raw.mly" +# 3507 "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 ) -# 33125 "src/ocaml/preprocess/parser_raw.ml" +# 40937 "src/ocaml/preprocess/parser_raw.ml" in -# 3529 "src/ocaml/preprocess/parser_raw.mly" +# 3494 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33131 "src/ocaml/preprocess/parser_raw.ml" +# 40943 "src/ocaml/preprocess/parser_raw.ml" in -# 1890 "src/ocaml/preprocess/parser_raw.mly" +# 1855 "src/ocaml/preprocess/parser_raw.mly" ( psig_typext _1 ) -# 33137 "src/ocaml/preprocess/parser_raw.ml" +# 40949 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -33141,15 +40953,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33147 "src/ocaml/preprocess/parser_raw.ml" +# 40959 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33153 "src/ocaml/preprocess/parser_raw.ml" +# 40965 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33241,16 +41053,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33247 "src/ocaml/preprocess/parser_raw.ml" +# 41059 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = -# 1306 "src/ocaml/preprocess/parser_raw.mly" +# 1271 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 33254 "src/ocaml/preprocess/parser_raw.ml" +# 41066 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -33258,9 +41070,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33264 "src/ocaml/preprocess/parser_raw.ml" +# 41076 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -33269,41 +41081,41 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4105 "src/ocaml/preprocess/parser_raw.mly" +# 4070 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 33275 "src/ocaml/preprocess/parser_raw.ml" +# 41087 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33283 "src/ocaml/preprocess/parser_raw.ml" +# 41095 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3542 "src/ocaml/preprocess/parser_raw.mly" +# 3507 "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 ) -# 33295 "src/ocaml/preprocess/parser_raw.ml" +# 41107 "src/ocaml/preprocess/parser_raw.ml" in -# 3529 "src/ocaml/preprocess/parser_raw.mly" +# 3494 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33301 "src/ocaml/preprocess/parser_raw.ml" +# 41113 "src/ocaml/preprocess/parser_raw.ml" in -# 1890 "src/ocaml/preprocess/parser_raw.mly" +# 1855 "src/ocaml/preprocess/parser_raw.mly" ( psig_typext _1 ) -# 33307 "src/ocaml/preprocess/parser_raw.ml" +# 41119 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -33311,15 +41123,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33317 "src/ocaml/preprocess/parser_raw.ml" +# 41129 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33323 "src/ocaml/preprocess/parser_raw.ml" +# 41135 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33343,23 +41155,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1892 "src/ocaml/preprocess/parser_raw.mly" +# 1857 "src/ocaml/preprocess/parser_raw.mly" ( psig_exception _1 ) -# 33349 "src/ocaml/preprocess/parser_raw.ml" +# 41161 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33357 "src/ocaml/preprocess/parser_raw.ml" +# 41169 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33363 "src/ocaml/preprocess/parser_raw.ml" +# 41175 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33422,9 +41234,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33428 "src/ocaml/preprocess/parser_raw.ml" +# 41240 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -33434,37 +41246,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33440 "src/ocaml/preprocess/parser_raw.ml" +# 41252 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33448 "src/ocaml/preprocess/parser_raw.ml" +# 41260 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1923 "src/ocaml/preprocess/parser_raw.mly" +# 1888 "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 ) -# 33462 "src/ocaml/preprocess/parser_raw.ml" +# 41274 "src/ocaml/preprocess/parser_raw.ml" in -# 1894 "src/ocaml/preprocess/parser_raw.mly" +# 1859 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 33468 "src/ocaml/preprocess/parser_raw.ml" +# 41280 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -33472,15 +41284,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33478 "src/ocaml/preprocess/parser_raw.ml" +# 41290 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33484 "src/ocaml/preprocess/parser_raw.ml" +# 41296 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33550,9 +41362,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33556 "src/ocaml/preprocess/parser_raw.ml" +# 41368 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in @@ -33563,9 +41375,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33569 "src/ocaml/preprocess/parser_raw.ml" +# 41381 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos_id_, _startpos_id_) = (_endpos__1_, _startpos__1_) in @@ -33573,9 +41385,9 @@ module Tables = struct let _symbolstartpos = _startpos_id_ in let _sloc = (_symbolstartpos, _endpos) in -# 1964 "src/ocaml/preprocess/parser_raw.mly" +# 1929 "src/ocaml/preprocess/parser_raw.mly" ( Mty.alias ~loc:(make_loc _sloc) id ) -# 33579 "src/ocaml/preprocess/parser_raw.ml" +# 41391 "src/ocaml/preprocess/parser_raw.ml" in let name = @@ -33584,37 +41396,37 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33590 "src/ocaml/preprocess/parser_raw.ml" +# 41402 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33598 "src/ocaml/preprocess/parser_raw.ml" +# 41410 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1955 "src/ocaml/preprocess/parser_raw.mly" +# 1920 "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 ) -# 33612 "src/ocaml/preprocess/parser_raw.ml" +# 41424 "src/ocaml/preprocess/parser_raw.ml" in -# 1896 "src/ocaml/preprocess/parser_raw.mly" +# 1861 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_module body, ext) ) -# 33618 "src/ocaml/preprocess/parser_raw.ml" +# 41430 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -33622,15 +41434,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33628 "src/ocaml/preprocess/parser_raw.ml" +# 41440 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33634 "src/ocaml/preprocess/parser_raw.ml" +# 41446 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33654,23 +41466,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1898 "src/ocaml/preprocess/parser_raw.mly" +# 1863 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modsubst body, ext) ) -# 33660 "src/ocaml/preprocess/parser_raw.ml" +# 41472 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33668 "src/ocaml/preprocess/parser_raw.ml" +# 41480 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33674 "src/ocaml/preprocess/parser_raw.ml" +# 41486 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33756,9 +41568,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33762 "src/ocaml/preprocess/parser_raw.ml" +# 41574 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -33768,49 +41580,49 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 33774 "src/ocaml/preprocess/parser_raw.ml" +# 41586 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33782 "src/ocaml/preprocess/parser_raw.ml" +# 41594 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2000 "src/ocaml/preprocess/parser_raw.mly" +# 1965 "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 ) -# 33796 "src/ocaml/preprocess/parser_raw.ml" +# 41608 "src/ocaml/preprocess/parser_raw.ml" in -# 1314 "src/ocaml/preprocess/parser_raw.mly" +# 1279 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 33802 "src/ocaml/preprocess/parser_raw.ml" +# 41614 "src/ocaml/preprocess/parser_raw.ml" in -# 1989 "src/ocaml/preprocess/parser_raw.mly" +# 1954 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33808 "src/ocaml/preprocess/parser_raw.ml" +# 41620 "src/ocaml/preprocess/parser_raw.ml" in -# 1900 "src/ocaml/preprocess/parser_raw.mly" +# 1865 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_recmodule l, ext) ) -# 33814 "src/ocaml/preprocess/parser_raw.ml" +# 41626 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -33818,15 +41630,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33824 "src/ocaml/preprocess/parser_raw.ml" +# 41636 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33830 "src/ocaml/preprocess/parser_raw.ml" +# 41642 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33850,23 +41662,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1902 "src/ocaml/preprocess/parser_raw.mly" +# 1867 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modtype body, ext) ) -# 33856 "src/ocaml/preprocess/parser_raw.ml" +# 41668 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33864 "src/ocaml/preprocess/parser_raw.ml" +# 41676 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33870 "src/ocaml/preprocess/parser_raw.ml" +# 41682 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33890,23 +41702,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1904 "src/ocaml/preprocess/parser_raw.mly" +# 1869 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_modtypesubst body, ext) ) -# 33896 "src/ocaml/preprocess/parser_raw.ml" +# 41708 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33904 "src/ocaml/preprocess/parser_raw.ml" +# 41716 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33910 "src/ocaml/preprocess/parser_raw.ml" +# 41722 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -33930,23 +41742,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1906 "src/ocaml/preprocess/parser_raw.mly" +# 1871 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Psig_open body, ext) ) -# 33936 "src/ocaml/preprocess/parser_raw.ml" +# 41748 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 33944 "src/ocaml/preprocess/parser_raw.ml" +# 41756 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 33950 "src/ocaml/preprocess/parser_raw.ml" +# 41762 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34002,38 +41814,38 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34008 "src/ocaml/preprocess/parser_raw.ml" +# 41820 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34017 "src/ocaml/preprocess/parser_raw.ml" +# 41829 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1740 "src/ocaml/preprocess/parser_raw.mly" +# 1705 "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 ) -# 34031 "src/ocaml/preprocess/parser_raw.ml" +# 41843 "src/ocaml/preprocess/parser_raw.ml" in -# 1908 "src/ocaml/preprocess/parser_raw.mly" +# 1873 "src/ocaml/preprocess/parser_raw.mly" ( psig_include _1 ) -# 34037 "src/ocaml/preprocess/parser_raw.ml" +# 41849 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -34041,15 +41853,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34047 "src/ocaml/preprocess/parser_raw.ml" +# 41859 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34053 "src/ocaml/preprocess/parser_raw.ml" +# 41865 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34126,9 +41938,9 @@ module Tables = struct let cty : (Parsetree.class_type) = Obj.magic cty in let _7 : unit = Obj.magic _7 in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 34132 "src/ocaml/preprocess/parser_raw.ml" +# 41944 "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 @@ -34146,9 +41958,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34152 "src/ocaml/preprocess/parser_raw.ml" +# 41964 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -34158,24 +41970,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 34164 "src/ocaml/preprocess/parser_raw.ml" +# 41976 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34172 "src/ocaml/preprocess/parser_raw.ml" +# 41984 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2355 "src/ocaml/preprocess/parser_raw.mly" +# 2320 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -34183,25 +41995,25 @@ module Tables = struct ext, Ci.mk id cty ~virt ~params ~attrs ~loc ~docs ) -# 34187 "src/ocaml/preprocess/parser_raw.ml" +# 41999 "src/ocaml/preprocess/parser_raw.ml" in -# 1314 "src/ocaml/preprocess/parser_raw.mly" +# 1279 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 34193 "src/ocaml/preprocess/parser_raw.ml" +# 42005 "src/ocaml/preprocess/parser_raw.ml" in -# 2343 "src/ocaml/preprocess/parser_raw.mly" +# 2308 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34199 "src/ocaml/preprocess/parser_raw.ml" +# 42011 "src/ocaml/preprocess/parser_raw.ml" in -# 1910 "src/ocaml/preprocess/parser_raw.mly" +# 1875 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_class l, ext) ) -# 34205 "src/ocaml/preprocess/parser_raw.ml" +# 42017 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -34209,15 +42021,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34215 "src/ocaml/preprocess/parser_raw.ml" +# 42027 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34221 "src/ocaml/preprocess/parser_raw.ml" +# 42033 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34241,23 +42053,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.signature_item) = let _1 = let _1 = -# 1912 "src/ocaml/preprocess/parser_raw.mly" +# 1877 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Psig_class_type l, ext) ) -# 34247 "src/ocaml/preprocess/parser_raw.ml" +# 42059 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1120 "src/ocaml/preprocess/parser_raw.mly" +# 1085 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mksig_ext ~loc:_sloc _1 ) -# 34255 "src/ocaml/preprocess/parser_raw.ml" +# 42067 "src/ocaml/preprocess/parser_raw.ml" in -# 1914 "src/ocaml/preprocess/parser_raw.mly" +# 1879 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34261 "src/ocaml/preprocess/parser_raw.ml" +# 42073 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34280,9 +42092,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.constant) = -# 3928 "src/ocaml/preprocess/parser_raw.mly" +# 3893 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34286 "src/ocaml/preprocess/parser_raw.ml" +# 42098 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34307,18 +42119,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 824 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 34313 "src/ocaml/preprocess/parser_raw.ml" +# 42125 "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) = -# 3929 "src/ocaml/preprocess/parser_raw.mly" +# 3894 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _2 in Pconst_integer("-" ^ n, m) ) -# 34322 "src/ocaml/preprocess/parser_raw.ml" +# 42134 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34343,18 +42155,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 830 "src/ocaml/preprocess/parser_raw.mly" +# 803 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 34349 "src/ocaml/preprocess/parser_raw.ml" +# 42161 "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) = -# 3930 "src/ocaml/preprocess/parser_raw.mly" +# 3895 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _2 in Pconst_float("-" ^ f, m) ) -# 34358 "src/ocaml/preprocess/parser_raw.ml" +# 42170 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34379,18 +42191,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 824 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 34385 "src/ocaml/preprocess/parser_raw.ml" +# 42197 "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) = -# 3931 "src/ocaml/preprocess/parser_raw.mly" +# 3896 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _2 in Pconst_integer (n, m) ) -# 34394 "src/ocaml/preprocess/parser_raw.ml" +# 42206 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34415,18 +42227,18 @@ module Tables = struct }; } = _menhir_stack in let _2 : ( -# 830 "src/ocaml/preprocess/parser_raw.mly" +# 803 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 34421 "src/ocaml/preprocess/parser_raw.ml" +# 42233 "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) = -# 3932 "src/ocaml/preprocess/parser_raw.mly" +# 3897 "src/ocaml/preprocess/parser_raw.mly" ( let (f, m) = _2 in Pconst_float(f, m) ) -# 34430 "src/ocaml/preprocess/parser_raw.ml" +# 42242 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34467,18 +42279,18 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 3199 "src/ocaml/preprocess/parser_raw.mly" +# 3164 "src/ocaml/preprocess/parser_raw.mly" ( let fields, closed = _1 in let closed = match closed with Some () -> Open | None -> Closed in fields, closed ) -# 34475 "src/ocaml/preprocess/parser_raw.ml" +# 42287 "src/ocaml/preprocess/parser_raw.ml" in -# 3170 "src/ocaml/preprocess/parser_raw.mly" +# 3135 "src/ocaml/preprocess/parser_raw.mly" ( let (fields, closed) = _2 in Ppat_record(fields, closed) ) -# 34482 "src/ocaml/preprocess/parser_raw.ml" +# 42294 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34486,15 +42298,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34492 "src/ocaml/preprocess/parser_raw.ml" +# 42304 "src/ocaml/preprocess/parser_raw.ml" in -# 3184 "src/ocaml/preprocess/parser_raw.mly" +# 3149 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34498 "src/ocaml/preprocess/parser_raw.ml" +# 42310 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34533,15 +42345,15 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _2 = -# 3193 "src/ocaml/preprocess/parser_raw.mly" +# 3158 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 34539 "src/ocaml/preprocess/parser_raw.ml" +# 42351 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 3175 "src/ocaml/preprocess/parser_raw.mly" +# 3140 "src/ocaml/preprocess/parser_raw.mly" ( fst (mktailpat _loc__3_ _2) ) -# 34545 "src/ocaml/preprocess/parser_raw.ml" +# 42357 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34549,15 +42361,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34555 "src/ocaml/preprocess/parser_raw.ml" +# 42367 "src/ocaml/preprocess/parser_raw.ml" in -# 3184 "src/ocaml/preprocess/parser_raw.mly" +# 3149 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34561 "src/ocaml/preprocess/parser_raw.ml" +# 42373 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34596,14 +42408,14 @@ module Tables = struct let _v : (Parsetree.pattern) = let _1 = let _1 = let _2 = -# 3193 "src/ocaml/preprocess/parser_raw.mly" +# 3158 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 34602 "src/ocaml/preprocess/parser_raw.ml" +# 42414 "src/ocaml/preprocess/parser_raw.ml" in -# 3179 "src/ocaml/preprocess/parser_raw.mly" +# 3144 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_array _2 ) -# 34607 "src/ocaml/preprocess/parser_raw.ml" +# 42419 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -34611,15 +42423,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34617 "src/ocaml/preprocess/parser_raw.ml" +# 42429 "src/ocaml/preprocess/parser_raw.ml" in -# 3184 "src/ocaml/preprocess/parser_raw.mly" +# 3149 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34623 "src/ocaml/preprocess/parser_raw.ml" +# 42435 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34650,24 +42462,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3181 "src/ocaml/preprocess/parser_raw.mly" +# 3146 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_array [] ) -# 34656 "src/ocaml/preprocess/parser_raw.ml" +# 42468 "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 -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 34665 "src/ocaml/preprocess/parser_raw.ml" +# 42477 "src/ocaml/preprocess/parser_raw.ml" in -# 3184 "src/ocaml/preprocess/parser_raw.mly" +# 3149 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 34671 "src/ocaml/preprocess/parser_raw.ml" +# 42483 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34685,9 +42497,9 @@ module Tables = struct 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.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; @@ -34698,17 +42510,157 @@ module Tables = struct }; } = _menhir_stack in let _3 : unit = Obj.magic _3 in - let _2 : (Parsetree.expression) = Obj.magic _2 in + let _1_inlined1 : (Parsetree.expression) = 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 _endpos = _endpos__3_ in + let _v : (Parsetree.expression) = let _2 = + let _1 = _1_inlined1 in + let _1 = +# 2389 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 42524 "src/ocaml/preprocess/parser_raw.ml" + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 42529 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in let _startpos = _startpos__1_ in -# 4303 "src/ocaml/preprocess/parser_raw.mly" +# 4268 "src/ocaml/preprocess/parser_raw.mly" ( Fake.Meta.code _startpos _endpos _2 ) -# 34712 "src/ocaml/preprocess/parser_raw.ml" +# 42537 "src/ocaml/preprocess/parser_raw.ml" + in + { + MenhirLib.EngineTypes.state = _menhir_s; + MenhirLib.EngineTypes.semv = Obj.repr _v; + MenhirLib.EngineTypes.startp = _startpos; + MenhirLib.EngineTypes.endp = _endpos; + 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 = _; + 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 _3 : unit = Obj.magic _3 in + let xs : (Parsetree.case list) = Obj.magic xs 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 _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 (_startpos__1_, _1_inlined2, _1_inlined1, _1) = (_startpos__1_inlined1_, _1_inlined3, _1_inlined2, _1_inlined1) in + let _1 = + let _3 = + let xs = + let xs = +# 253 "" + ( List.rev xs ) +# 42602 "src/ocaml/preprocess/parser_raw.ml" + in + +# 1243 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 42607 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2893 "src/ocaml/preprocess/parser_raw.mly" + ( xs ) +# 42613 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos__3_ = _endpos_xs_ in + let _2 = + let (_1_inlined1, _1) = (_1_inlined2, _1_inlined1) in + let _2 = + let _1 = _1_inlined1 in + +# 4227 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 42624 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 4240 "src/ocaml/preprocess/parser_raw.mly" + ( _1, _2 ) +# 42630 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _symbolstartpos = _startpos__1_ in + let _sloc = (_symbolstartpos, _endpos) in + +# 2391 "src/ocaml/preprocess/parser_raw.mly" + ( let loc = make_loc _sloc in + let cases = _3 in + (* There are two choices of where to put attributes: on the + Pexp_function node; on the Pfunction_cases body. We put them on the + Pexp_function node here because the compiler only uses + Pfunction_cases attributes for enabling/disabling warnings in + typechecking. For standalone function cases, we want the compiler to + respect, e.g., [@inline] attributes. + *) + let desc = mkfunction [] None (Pfunction_cases (cases, loc, [])) in + mkexp_attrs ~loc:_sloc desc _2 + ) +# 42650 "src/ocaml/preprocess/parser_raw.ml" + + in + +# 2535 "src/ocaml/preprocess/parser_raw.mly" + ( _1 ) +# 42656 "src/ocaml/preprocess/parser_raw.ml" + + in + let _endpos = _endpos__3_ in + let _startpos = _startpos__1_ in + +# 4268 "src/ocaml/preprocess/parser_raw.mly" + ( Fake.Meta.code _startpos _endpos _2 ) +# 42664 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34740,9 +42692,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _endpos = _endpos__2_ in let _startpos = _startpos__1_ in -# 4305 "src/ocaml/preprocess/parser_raw.mly" +# 4270 "src/ocaml/preprocess/parser_raw.mly" ( Fake.Meta.uncode _startpos _endpos _2 ) -# 34746 "src/ocaml/preprocess/parser_raw.ml" +# 42698 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34782,9 +42734,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2632 "src/ocaml/preprocess/parser_raw.mly" +# 2597 "src/ocaml/preprocess/parser_raw.mly" ( reloc_exp ~loc:_sloc _2 ) -# 34788 "src/ocaml/preprocess/parser_raw.ml" +# 42740 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34831,9 +42783,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2638 "src/ocaml/preprocess/parser_raw.mly" +# 2603 "src/ocaml/preprocess/parser_raw.mly" ( mkexp_constraint ~loc:_sloc _2 _3 ) -# 34837 "src/ocaml/preprocess/parser_raw.ml" +# 42789 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34885,14 +42837,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2639 "src/ocaml/preprocess/parser_raw.mly" +# 2604 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34891 "src/ocaml/preprocess/parser_raw.ml" +# 42843 "src/ocaml/preprocess/parser_raw.ml" in -# 2516 "src/ocaml/preprocess/parser_raw.mly" +# 2481 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 34896 "src/ocaml/preprocess/parser_raw.ml" +# 42848 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34900,9 +42852,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2640 "src/ocaml/preprocess/parser_raw.mly" +# 2605 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34906 "src/ocaml/preprocess/parser_raw.ml" +# 42858 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -34954,14 +42906,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2639 "src/ocaml/preprocess/parser_raw.mly" +# 2604 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 34960 "src/ocaml/preprocess/parser_raw.ml" +# 42912 "src/ocaml/preprocess/parser_raw.ml" in -# 2518 "src/ocaml/preprocess/parser_raw.mly" +# 2483 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 34965 "src/ocaml/preprocess/parser_raw.ml" +# 42917 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -34969,9 +42921,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2640 "src/ocaml/preprocess/parser_raw.mly" +# 2605 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 34975 "src/ocaml/preprocess/parser_raw.ml" +# 42927 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35023,14 +42975,14 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2639 "src/ocaml/preprocess/parser_raw.mly" +# 2604 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35029 "src/ocaml/preprocess/parser_raw.ml" +# 42981 "src/ocaml/preprocess/parser_raw.ml" in -# 2520 "src/ocaml/preprocess/parser_raw.mly" +# 2485 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35034 "src/ocaml/preprocess/parser_raw.ml" +# 42986 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35038,9 +42990,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2640 "src/ocaml/preprocess/parser_raw.mly" +# 2605 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr builtin_indexing_operators ~loc:_sloc _1 ) -# 35044 "src/ocaml/preprocess/parser_raw.ml" +# 42996 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35086,9 +43038,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35092 "src/ocaml/preprocess/parser_raw.ml" +# 43044 "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 @@ -35096,31 +43048,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2641 "src/ocaml/preprocess/parser_raw.mly" +# 2606 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35102 "src/ocaml/preprocess/parser_raw.ml" +# 43054 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35107 "src/ocaml/preprocess/parser_raw.ml" +# 43059 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 35113 "src/ocaml/preprocess/parser_raw.ml" +# 43065 "src/ocaml/preprocess/parser_raw.ml" in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35118 "src/ocaml/preprocess/parser_raw.ml" +# 43070 "src/ocaml/preprocess/parser_raw.ml" in -# 2516 "src/ocaml/preprocess/parser_raw.mly" +# 2481 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 35124 "src/ocaml/preprocess/parser_raw.ml" +# 43076 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35128,9 +43080,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2642 "src/ocaml/preprocess/parser_raw.mly" +# 2607 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35134 "src/ocaml/preprocess/parser_raw.ml" +# 43086 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35188,9 +43140,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35194 "src/ocaml/preprocess/parser_raw.ml" +# 43146 "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 @@ -35200,39 +43152,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2641 "src/ocaml/preprocess/parser_raw.mly" +# 2606 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35206 "src/ocaml/preprocess/parser_raw.ml" +# 43158 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35211 "src/ocaml/preprocess/parser_raw.ml" +# 43163 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 35219 "src/ocaml/preprocess/parser_raw.ml" +# 43171 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 35224 "src/ocaml/preprocess/parser_raw.ml" +# 43176 "src/ocaml/preprocess/parser_raw.ml" in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35230 "src/ocaml/preprocess/parser_raw.ml" +# 43182 "src/ocaml/preprocess/parser_raw.ml" in -# 2516 "src/ocaml/preprocess/parser_raw.mly" +# 2481 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Paren, i, r ) -# 35236 "src/ocaml/preprocess/parser_raw.ml" +# 43188 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35240,9 +43192,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2642 "src/ocaml/preprocess/parser_raw.mly" +# 2607 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35246 "src/ocaml/preprocess/parser_raw.ml" +# 43198 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35288,9 +43240,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35294 "src/ocaml/preprocess/parser_raw.ml" +# 43246 "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 @@ -35298,31 +43250,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2641 "src/ocaml/preprocess/parser_raw.mly" +# 2606 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35304 "src/ocaml/preprocess/parser_raw.ml" +# 43256 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35309 "src/ocaml/preprocess/parser_raw.ml" +# 43261 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 35315 "src/ocaml/preprocess/parser_raw.ml" +# 43267 "src/ocaml/preprocess/parser_raw.ml" in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35320 "src/ocaml/preprocess/parser_raw.ml" +# 43272 "src/ocaml/preprocess/parser_raw.ml" in -# 2518 "src/ocaml/preprocess/parser_raw.mly" +# 2483 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 35326 "src/ocaml/preprocess/parser_raw.ml" +# 43278 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35330,9 +43282,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2642 "src/ocaml/preprocess/parser_raw.mly" +# 2607 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35336 "src/ocaml/preprocess/parser_raw.ml" +# 43288 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35390,9 +43342,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35396 "src/ocaml/preprocess/parser_raw.ml" +# 43348 "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 @@ -35402,39 +43354,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2641 "src/ocaml/preprocess/parser_raw.mly" +# 2606 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35408 "src/ocaml/preprocess/parser_raw.ml" +# 43360 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35413 "src/ocaml/preprocess/parser_raw.ml" +# 43365 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 35421 "src/ocaml/preprocess/parser_raw.ml" +# 43373 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 35426 "src/ocaml/preprocess/parser_raw.ml" +# 43378 "src/ocaml/preprocess/parser_raw.ml" in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35432 "src/ocaml/preprocess/parser_raw.ml" +# 43384 "src/ocaml/preprocess/parser_raw.ml" in -# 2518 "src/ocaml/preprocess/parser_raw.mly" +# 2483 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Brace, i, r ) -# 35438 "src/ocaml/preprocess/parser_raw.ml" +# 43390 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35442,9 +43394,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2642 "src/ocaml/preprocess/parser_raw.mly" +# 2607 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35448 "src/ocaml/preprocess/parser_raw.ml" +# 43400 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35490,9 +43442,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35496 "src/ocaml/preprocess/parser_raw.ml" +# 43448 "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 @@ -35500,31 +43452,31 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2641 "src/ocaml/preprocess/parser_raw.mly" +# 2606 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35506 "src/ocaml/preprocess/parser_raw.ml" +# 43458 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35511 "src/ocaml/preprocess/parser_raw.ml" +# 43463 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = # 124 "" ( None ) -# 35517 "src/ocaml/preprocess/parser_raw.ml" +# 43469 "src/ocaml/preprocess/parser_raw.ml" in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35522 "src/ocaml/preprocess/parser_raw.ml" +# 43474 "src/ocaml/preprocess/parser_raw.ml" in -# 2520 "src/ocaml/preprocess/parser_raw.mly" +# 2485 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35528 "src/ocaml/preprocess/parser_raw.ml" +# 43480 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35532,9 +43484,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2642 "src/ocaml/preprocess/parser_raw.mly" +# 2607 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35538 "src/ocaml/preprocess/parser_raw.ml" +# 43490 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35592,9 +43544,9 @@ module Tables = struct let es : (Parsetree.expression list) = Obj.magic es in let _3 : unit = Obj.magic _3 in let _2 : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 35598 "src/ocaml/preprocess/parser_raw.ml" +# 43550 "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 @@ -35604,39 +43556,39 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.expression) = let _1 = let r = -# 2641 "src/ocaml/preprocess/parser_raw.mly" +# 2606 "src/ocaml/preprocess/parser_raw.mly" ( None ) -# 35610 "src/ocaml/preprocess/parser_raw.ml" +# 43562 "src/ocaml/preprocess/parser_raw.ml" in let i = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 35615 "src/ocaml/preprocess/parser_raw.ml" +# 43567 "src/ocaml/preprocess/parser_raw.ml" in let d = let _1 = let _2 = _2_inlined1 in let x = -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" (_2) -# 35623 "src/ocaml/preprocess/parser_raw.ml" +# 43575 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 35628 "src/ocaml/preprocess/parser_raw.ml" +# 43580 "src/ocaml/preprocess/parser_raw.ml" in -# 2532 "src/ocaml/preprocess/parser_raw.mly" +# 2497 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35634 "src/ocaml/preprocess/parser_raw.ml" +# 43586 "src/ocaml/preprocess/parser_raw.ml" in -# 2520 "src/ocaml/preprocess/parser_raw.mly" +# 2485 "src/ocaml/preprocess/parser_raw.mly" ( array, d, Bracket, i, r ) -# 35640 "src/ocaml/preprocess/parser_raw.ml" +# 43592 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__5_, _startpos_array_) in @@ -35644,9 +43596,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2642 "src/ocaml/preprocess/parser_raw.mly" +# 2607 "src/ocaml/preprocess/parser_raw.mly" ( mk_indexop_expr user_indexing_operators ~loc:_sloc _1 ) -# 35650 "src/ocaml/preprocess/parser_raw.ml" +# 43602 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35700,15 +43652,15 @@ module Tables = struct let attrs = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35706 "src/ocaml/preprocess/parser_raw.ml" +# 43658 "src/ocaml/preprocess/parser_raw.ml" in -# 2655 "src/ocaml/preprocess/parser_raw.mly" +# 2620 "src/ocaml/preprocess/parser_raw.mly" ( e.pexp_desc, (ext, attrs @ e.pexp_attributes) ) -# 35712 "src/ocaml/preprocess/parser_raw.ml" +# 43664 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -35716,10 +43668,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2648 "src/ocaml/preprocess/parser_raw.mly" +# 2613 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35723 "src/ocaml/preprocess/parser_raw.ml" +# 43675 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35768,24 +43720,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35774 "src/ocaml/preprocess/parser_raw.ml" +# 43726 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35780 "src/ocaml/preprocess/parser_raw.ml" +# 43732 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2657 "src/ocaml/preprocess/parser_raw.mly" +# 2622 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct (mkloc (Lident "()") (make_loc _sloc), None), _2 ) -# 35789 "src/ocaml/preprocess/parser_raw.ml" +# 43741 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -35793,10 +43745,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2648 "src/ocaml/preprocess/parser_raw.mly" +# 2613 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35800 "src/ocaml/preprocess/parser_raw.ml" +# 43752 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35846,9 +43798,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 35852 "src/ocaml/preprocess/parser_raw.ml" +# 43804 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -35856,21 +43808,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35862 "src/ocaml/preprocess/parser_raw.ml" +# 43814 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35868 "src/ocaml/preprocess/parser_raw.ml" +# 43820 "src/ocaml/preprocess/parser_raw.ml" in -# 2663 "src/ocaml/preprocess/parser_raw.mly" +# 2628 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_new(_3), _2 ) -# 35874 "src/ocaml/preprocess/parser_raw.ml" +# 43826 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -35878,10 +43830,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2648 "src/ocaml/preprocess/parser_raw.mly" +# 2613 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35885 "src/ocaml/preprocess/parser_raw.ml" +# 43837 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -35944,21 +43896,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 35950 "src/ocaml/preprocess/parser_raw.ml" +# 43902 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 35956 "src/ocaml/preprocess/parser_raw.ml" +# 43908 "src/ocaml/preprocess/parser_raw.ml" in -# 2665 "src/ocaml/preprocess/parser_raw.mly" +# 2630 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_pack _4, _3 ) -# 35962 "src/ocaml/preprocess/parser_raw.ml" +# 43914 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -35966,10 +43918,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2648 "src/ocaml/preprocess/parser_raw.mly" +# 2613 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 35973 "src/ocaml/preprocess/parser_raw.ml" +# 43925 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36047,11 +43999,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3842 "src/ocaml/preprocess/parser_raw.mly" +# 3807 "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 ) -# 36055 "src/ocaml/preprocess/parser_raw.ml" +# 44007 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -36059,24 +44011,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36065 "src/ocaml/preprocess/parser_raw.ml" +# 44017 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 36071 "src/ocaml/preprocess/parser_raw.ml" +# 44023 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2667 "src/ocaml/preprocess/parser_raw.mly" +# 2632 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_constraint (ghexp ~loc:_sloc (Pexp_pack _4), _6), _3 ) -# 36080 "src/ocaml/preprocess/parser_raw.ml" +# 44032 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__7_ in @@ -36084,10 +44036,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2648 "src/ocaml/preprocess/parser_raw.mly" +# 2613 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 36091 "src/ocaml/preprocess/parser_raw.ml" +# 44043 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36152,27 +44104,27 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 36156 "src/ocaml/preprocess/parser_raw.ml" +# 44108 "src/ocaml/preprocess/parser_raw.ml" in -# 2169 "src/ocaml/preprocess/parser_raw.mly" +# 2134 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36161 "src/ocaml/preprocess/parser_raw.ml" +# 44113 "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 -# 1056 "src/ocaml/preprocess/parser_raw.mly" +# 1021 "src/ocaml/preprocess/parser_raw.mly" ( extra_cstr _startpos _endpos _1 ) -# 36170 "src/ocaml/preprocess/parser_raw.ml" +# 44122 "src/ocaml/preprocess/parser_raw.ml" in -# 2156 "src/ocaml/preprocess/parser_raw.mly" +# 2121 "src/ocaml/preprocess/parser_raw.mly" ( Cstr.mk _1 _2 ) -# 36176 "src/ocaml/preprocess/parser_raw.ml" +# 44128 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -36180,21 +44132,21 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36186 "src/ocaml/preprocess/parser_raw.ml" +# 44138 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 36192 "src/ocaml/preprocess/parser_raw.ml" +# 44144 "src/ocaml/preprocess/parser_raw.ml" in -# 2673 "src/ocaml/preprocess/parser_raw.mly" +# 2638 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_object _3, _2 ) -# 36198 "src/ocaml/preprocess/parser_raw.ml" +# 44150 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -36202,10 +44154,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2648 "src/ocaml/preprocess/parser_raw.mly" +# 2613 "src/ocaml/preprocess/parser_raw.mly" ( let desc, attrs = _1 in mkexp_attrs ~loc:_sloc desc attrs ) -# 36209 "src/ocaml/preprocess/parser_raw.ml" +# 44161 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36234,30 +44186,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36240 "src/ocaml/preprocess/parser_raw.ml" +# 44192 "src/ocaml/preprocess/parser_raw.ml" in -# 2681 "src/ocaml/preprocess/parser_raw.mly" +# 2646 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_ident (_1) ) -# 36246 "src/ocaml/preprocess/parser_raw.ml" +# 44198 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36255 "src/ocaml/preprocess/parser_raw.ml" +# 44207 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36261 "src/ocaml/preprocess/parser_raw.ml" +# 44213 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36281,23 +44233,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2683 "src/ocaml/preprocess/parser_raw.mly" +# 2648 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_constant _1 ) -# 36287 "src/ocaml/preprocess/parser_raw.ml" +# 44239 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36295 "src/ocaml/preprocess/parser_raw.ml" +# 44247 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36301 "src/ocaml/preprocess/parser_raw.ml" +# 44253 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36326,30 +44278,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36332 "src/ocaml/preprocess/parser_raw.ml" +# 44284 "src/ocaml/preprocess/parser_raw.ml" in -# 2685 "src/ocaml/preprocess/parser_raw.mly" +# 2650 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_construct(_1, None) ) -# 36338 "src/ocaml/preprocess/parser_raw.ml" +# 44290 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36347 "src/ocaml/preprocess/parser_raw.ml" +# 44299 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36353 "src/ocaml/preprocess/parser_raw.ml" +# 44305 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36373,23 +44325,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2687 "src/ocaml/preprocess/parser_raw.mly" +# 2652 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_variant(_1, None) ) -# 36379 "src/ocaml/preprocess/parser_raw.ml" +# 44331 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36387 "src/ocaml/preprocess/parser_raw.ml" +# 44339 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36393 "src/ocaml/preprocess/parser_raw.ml" +# 44345 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36415,9 +44367,9 @@ module Tables = struct } = _menhir_stack in let _2 : (Parsetree.expression) = Obj.magic _2 in let _1 : ( -# 889 "src/ocaml/preprocess/parser_raw.mly" +# 862 "src/ocaml/preprocess/parser_raw.mly" (string) -# 36421 "src/ocaml/preprocess/parser_raw.ml" +# 44373 "src/ocaml/preprocess/parser_raw.ml" ) = Obj.magic _1 in let _endpos__0_ = _menhir_stack.MenhirLib.EngineTypes.endp in let _startpos = _startpos__1_ in @@ -36429,15 +44381,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 36435 "src/ocaml/preprocess/parser_raw.ml" +# 44387 "src/ocaml/preprocess/parser_raw.ml" in -# 2689 "src/ocaml/preprocess/parser_raw.mly" +# 2654 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 36441 "src/ocaml/preprocess/parser_raw.ml" +# 44393 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -36445,15 +44397,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36451 "src/ocaml/preprocess/parser_raw.ml" +# 44403 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36457 "src/ocaml/preprocess/parser_raw.ml" +# 44409 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36486,23 +44438,23 @@ module Tables = struct let _1 = let _1 = let _1 = -# 2690 "src/ocaml/preprocess/parser_raw.mly" +# 2655 "src/ocaml/preprocess/parser_raw.mly" ("!") -# 36492 "src/ocaml/preprocess/parser_raw.ml" +# 44444 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 36500 "src/ocaml/preprocess/parser_raw.ml" +# 44452 "src/ocaml/preprocess/parser_raw.ml" in -# 2691 "src/ocaml/preprocess/parser_raw.mly" +# 2656 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_apply(_1, [Nolabel,_2]) ) -# 36506 "src/ocaml/preprocess/parser_raw.ml" +# 44458 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_ in @@ -36510,15 +44462,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36516 "src/ocaml/preprocess/parser_raw.ml" +# 44468 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36522 "src/ocaml/preprocess/parser_raw.ml" +# 44474 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36557,14 +44509,14 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 3004 "src/ocaml/preprocess/parser_raw.mly" +# 2969 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 36563 "src/ocaml/preprocess/parser_raw.ml" +# 44515 "src/ocaml/preprocess/parser_raw.ml" in -# 2693 "src/ocaml/preprocess/parser_raw.mly" +# 2658 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_override _2 ) -# 36568 "src/ocaml/preprocess/parser_raw.ml" +# 44520 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -36572,15 +44524,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36578 "src/ocaml/preprocess/parser_raw.ml" +# 44530 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36584 "src/ocaml/preprocess/parser_raw.ml" +# 44536 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36611,24 +44563,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2699 "src/ocaml/preprocess/parser_raw.mly" +# 2664 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_override [] ) -# 36617 "src/ocaml/preprocess/parser_raw.ml" +# 44569 "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 -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36626 "src/ocaml/preprocess/parser_raw.ml" +# 44578 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36632 "src/ocaml/preprocess/parser_raw.ml" +# 44584 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36672,15 +44624,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36678 "src/ocaml/preprocess/parser_raw.ml" +# 44630 "src/ocaml/preprocess/parser_raw.ml" in -# 2701 "src/ocaml/preprocess/parser_raw.mly" +# 2666 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_field(_1, _3) ) -# 36684 "src/ocaml/preprocess/parser_raw.ml" +# 44636 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -36688,15 +44640,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36694 "src/ocaml/preprocess/parser_raw.ml" +# 44646 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36700 "src/ocaml/preprocess/parser_raw.ml" +# 44652 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36754,24 +44706,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36760 "src/ocaml/preprocess/parser_raw.ml" +# 44712 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1799 "src/ocaml/preprocess/parser_raw.mly" +# 1764 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36769 "src/ocaml/preprocess/parser_raw.ml" +# 44721 "src/ocaml/preprocess/parser_raw.ml" in -# 2703 "src/ocaml/preprocess/parser_raw.mly" +# 2668 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, _4) ) -# 36775 "src/ocaml/preprocess/parser_raw.ml" +# 44727 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36779,15 +44731,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36785 "src/ocaml/preprocess/parser_raw.ml" +# 44737 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36791 "src/ocaml/preprocess/parser_raw.ml" +# 44743 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36840,9 +44792,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 3004 "src/ocaml/preprocess/parser_raw.mly" +# 2969 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 36846 "src/ocaml/preprocess/parser_raw.ml" +# 44798 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -36850,18 +44802,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36856 "src/ocaml/preprocess/parser_raw.ml" +# 44808 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1799 "src/ocaml/preprocess/parser_raw.mly" +# 1764 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 36865 "src/ocaml/preprocess/parser_raw.ml" +# 44817 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_od_ = _startpos__1_ in @@ -36869,10 +44821,10 @@ module Tables = struct let _symbolstartpos = _startpos_od_ in let _sloc = (_symbolstartpos, _endpos) in -# 2705 "src/ocaml/preprocess/parser_raw.mly" +# 2670 "src/ocaml/preprocess/parser_raw.mly" ( (* TODO: review the location of Pexp_override *) Pexp_open(od, mkexp ~loc:_sloc (Pexp_override _4)) ) -# 36876 "src/ocaml/preprocess/parser_raw.ml" +# 44828 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -36880,15 +44832,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36886 "src/ocaml/preprocess/parser_raw.ml" +# 44838 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36892 "src/ocaml/preprocess/parser_raw.ml" +# 44844 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36919,9 +44871,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 36925 "src/ocaml/preprocess/parser_raw.ml" +# 44877 "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 @@ -36933,23 +44885,23 @@ module Tables = struct let _3 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36939 "src/ocaml/preprocess/parser_raw.ml" +# 44891 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 36947 "src/ocaml/preprocess/parser_raw.ml" +# 44899 "src/ocaml/preprocess/parser_raw.ml" in -# 2712 "src/ocaml/preprocess/parser_raw.mly" +# 2677 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_send(_1, _3) ) -# 36953 "src/ocaml/preprocess/parser_raw.ml" +# 44905 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -36957,15 +44909,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 36963 "src/ocaml/preprocess/parser_raw.ml" +# 44915 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 36969 "src/ocaml/preprocess/parser_raw.ml" +# 44921 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -36997,9 +44949,9 @@ module Tables = struct } = _menhir_stack in let _3 : (Parsetree.expression) = Obj.magic _3 in let _1_inlined1 : ( -# 900 "src/ocaml/preprocess/parser_raw.mly" +# 873 "src/ocaml/preprocess/parser_raw.mly" (string) -# 37003 "src/ocaml/preprocess/parser_raw.ml" +# 44955 "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 @@ -37013,15 +44965,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1089 "src/ocaml/preprocess/parser_raw.mly" +# 1054 "src/ocaml/preprocess/parser_raw.mly" ( mkoperator ~loc:_sloc _1 ) -# 37019 "src/ocaml/preprocess/parser_raw.ml" +# 44971 "src/ocaml/preprocess/parser_raw.ml" in -# 2714 "src/ocaml/preprocess/parser_raw.mly" +# 2679 "src/ocaml/preprocess/parser_raw.mly" ( mkinfix _1 _2 _3 ) -# 37025 "src/ocaml/preprocess/parser_raw.ml" +# 44977 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -37029,15 +44981,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37035 "src/ocaml/preprocess/parser_raw.ml" +# 44987 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37041 "src/ocaml/preprocess/parser_raw.ml" +# 44993 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37061,23 +45013,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2716 "src/ocaml/preprocess/parser_raw.mly" +# 2681 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_extension _1 ) -# 37067 "src/ocaml/preprocess/parser_raw.ml" +# 45019 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37075 "src/ocaml/preprocess/parser_raw.ml" +# 45027 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37081 "src/ocaml/preprocess/parser_raw.ml" +# 45033 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37105,25 +45057,25 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 2718 "src/ocaml/preprocess/parser_raw.mly" +# 2683 "src/ocaml/preprocess/parser_raw.mly" ( let id = mkrhs Ast_helper.hole_txt _loc in Pexp_extension (id, PStr []) ) -# 37112 "src/ocaml/preprocess/parser_raw.ml" +# 45064 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37121 "src/ocaml/preprocess/parser_raw.ml" +# 45073 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37127 "src/ocaml/preprocess/parser_raw.ml" +# 45079 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37171,18 +45123,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2720 "src/ocaml/preprocess/parser_raw.mly" +# 2685 "src/ocaml/preprocess/parser_raw.mly" (Lident "()") -# 37177 "src/ocaml/preprocess/parser_raw.ml" +# 45129 "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 -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37186 "src/ocaml/preprocess/parser_raw.ml" +# 45138 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -37192,25 +45144,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37198 "src/ocaml/preprocess/parser_raw.ml" +# 45150 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1799 "src/ocaml/preprocess/parser_raw.mly" +# 1764 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37207 "src/ocaml/preprocess/parser_raw.ml" +# 45159 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2721 "src/ocaml/preprocess/parser_raw.mly" +# 2686 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:(_loc__3_) (Pexp_construct(_3, None))) ) -# 37214 "src/ocaml/preprocess/parser_raw.ml" +# 45166 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -37218,15 +45170,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37224 "src/ocaml/preprocess/parser_raw.ml" +# 45176 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37230 "src/ocaml/preprocess/parser_raw.ml" +# 45182 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37265,25 +45217,25 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2727 "src/ocaml/preprocess/parser_raw.mly" +# 2692 "src/ocaml/preprocess/parser_raw.mly" ( let (exten, fields) = _2 in Pexp_record(fields, exten) ) -# 37272 "src/ocaml/preprocess/parser_raw.ml" +# 45224 "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 -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37281 "src/ocaml/preprocess/parser_raw.ml" +# 45233 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37287 "src/ocaml/preprocess/parser_raw.ml" +# 45239 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37342,27 +45294,27 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37348 "src/ocaml/preprocess/parser_raw.ml" +# 45300 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1799 "src/ocaml/preprocess/parser_raw.mly" +# 1764 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37357 "src/ocaml/preprocess/parser_raw.ml" +# 45309 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in -# 2734 "src/ocaml/preprocess/parser_raw.mly" +# 2699 "src/ocaml/preprocess/parser_raw.mly" ( let (exten, fields) = _4 in Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_record(fields, exten))) ) -# 37366 "src/ocaml/preprocess/parser_raw.ml" +# 45318 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37370,15 +45322,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37376 "src/ocaml/preprocess/parser_raw.ml" +# 45328 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37382 "src/ocaml/preprocess/parser_raw.ml" +# 45334 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37417,14 +45369,14 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37423 "src/ocaml/preprocess/parser_raw.ml" +# 45375 "src/ocaml/preprocess/parser_raw.ml" in -# 2742 "src/ocaml/preprocess/parser_raw.mly" +# 2707 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_array(_2) ) -# 37428 "src/ocaml/preprocess/parser_raw.ml" +# 45380 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -37432,15 +45384,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37438 "src/ocaml/preprocess/parser_raw.ml" +# 45390 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37444 "src/ocaml/preprocess/parser_raw.ml" +# 45396 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37471,24 +45423,24 @@ module Tables = struct let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = let _1 = let _1 = -# 2748 "src/ocaml/preprocess/parser_raw.mly" +# 2713 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_array [] ) -# 37477 "src/ocaml/preprocess/parser_raw.ml" +# 45429 "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 -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37486 "src/ocaml/preprocess/parser_raw.ml" +# 45438 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37492 "src/ocaml/preprocess/parser_raw.ml" +# 45444 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37541,9 +45493,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37547 "src/ocaml/preprocess/parser_raw.ml" +# 45499 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -37551,25 +45503,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37557 "src/ocaml/preprocess/parser_raw.ml" +# 45509 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1799 "src/ocaml/preprocess/parser_raw.mly" +# 1764 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37566 "src/ocaml/preprocess/parser_raw.ml" +# 45518 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in -# 2750 "src/ocaml/preprocess/parser_raw.mly" +# 2715 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array(_4))) ) -# 37573 "src/ocaml/preprocess/parser_raw.ml" +# 45525 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37577,15 +45529,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37583 "src/ocaml/preprocess/parser_raw.ml" +# 45535 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37589 "src/ocaml/preprocess/parser_raw.ml" +# 45541 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37636,26 +45588,26 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37642 "src/ocaml/preprocess/parser_raw.ml" +# 45594 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1799 "src/ocaml/preprocess/parser_raw.mly" +# 1764 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37651 "src/ocaml/preprocess/parser_raw.ml" +# 45603 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__4_ in -# 2752 "src/ocaml/preprocess/parser_raw.mly" +# 2717 "src/ocaml/preprocess/parser_raw.mly" ( (* TODO: review the location of Pexp_array *) Pexp_open(od, mkexp ~loc:(_startpos__3_, _endpos) (Pexp_array [])) ) -# 37659 "src/ocaml/preprocess/parser_raw.ml" +# 45611 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__4_ in @@ -37663,15 +45615,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37669 "src/ocaml/preprocess/parser_raw.ml" +# 45621 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37675 "src/ocaml/preprocess/parser_raw.ml" +# 45627 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37710,15 +45662,15 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _2 = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37716 "src/ocaml/preprocess/parser_raw.ml" +# 45668 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2760 "src/ocaml/preprocess/parser_raw.mly" +# 2725 "src/ocaml/preprocess/parser_raw.mly" ( fst (mktailexp _loc__3_ _2) ) -# 37722 "src/ocaml/preprocess/parser_raw.ml" +# 45674 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -37726,15 +45678,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37732 "src/ocaml/preprocess/parser_raw.ml" +# 45684 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37738 "src/ocaml/preprocess/parser_raw.ml" +# 45690 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37787,9 +45739,9 @@ module Tables = struct let _v : (Parsetree.expression) = let _1 = let _1 = let _4 = -# 3021 "src/ocaml/preprocess/parser_raw.mly" +# 2986 "src/ocaml/preprocess/parser_raw.mly" ( es ) -# 37793 "src/ocaml/preprocess/parser_raw.ml" +# 45745 "src/ocaml/preprocess/parser_raw.ml" in let od = let _1 = @@ -37797,30 +45749,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37803 "src/ocaml/preprocess/parser_raw.ml" +# 45755 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1799 "src/ocaml/preprocess/parser_raw.mly" +# 1764 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37812 "src/ocaml/preprocess/parser_raw.ml" +# 45764 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _loc__5_ = (_startpos__5_, _endpos__5_) in -# 2766 "src/ocaml/preprocess/parser_raw.mly" +# 2731 "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) ) -# 37824 "src/ocaml/preprocess/parser_raw.ml" +# 45776 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -37828,15 +45780,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37834 "src/ocaml/preprocess/parser_raw.ml" +# 45786 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37840 "src/ocaml/preprocess/parser_raw.ml" +# 45792 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -37884,18 +45836,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 2771 "src/ocaml/preprocess/parser_raw.mly" +# 2736 "src/ocaml/preprocess/parser_raw.mly" (Lident "[]") -# 37890 "src/ocaml/preprocess/parser_raw.ml" +# 45842 "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 -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37899 "src/ocaml/preprocess/parser_raw.ml" +# 45851 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__3_, _startpos__3_) = (_endpos__2_inlined1_, _startpos__1_inlined1_) in @@ -37905,25 +45857,25 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 37911 "src/ocaml/preprocess/parser_raw.ml" +# 45863 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1799 "src/ocaml/preprocess/parser_raw.mly" +# 1764 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 37920 "src/ocaml/preprocess/parser_raw.ml" +# 45872 "src/ocaml/preprocess/parser_raw.ml" in let _loc__3_ = (_startpos__3_, _endpos__3_) in -# 2772 "src/ocaml/preprocess/parser_raw.mly" +# 2737 "src/ocaml/preprocess/parser_raw.mly" ( Pexp_open(od, mkexp ~loc:_loc__3_ (Pexp_construct(_3, None))) ) -# 37927 "src/ocaml/preprocess/parser_raw.ml" +# 45879 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -37931,15 +45883,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 37937 "src/ocaml/preprocess/parser_raw.ml" +# 45889 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 37943 "src/ocaml/preprocess/parser_raw.ml" +# 45895 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38032,11 +45984,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3842 "src/ocaml/preprocess/parser_raw.mly" +# 3807 "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 ) -# 38040 "src/ocaml/preprocess/parser_raw.ml" +# 45992 "src/ocaml/preprocess/parser_raw.ml" in let _5 = @@ -38044,15 +45996,15 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38050 "src/ocaml/preprocess/parser_raw.ml" +# 46002 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 38056 "src/ocaml/preprocess/parser_raw.ml" +# 46008 "src/ocaml/preprocess/parser_raw.ml" in let od = @@ -38061,18 +46013,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38067 "src/ocaml/preprocess/parser_raw.ml" +# 46019 "src/ocaml/preprocess/parser_raw.ml" in let _loc__1_ = (_startpos__1_, _endpos__1_) in -# 1799 "src/ocaml/preprocess/parser_raw.mly" +# 1764 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _loc__1_ in let me = Mod.ident ~loc _1 in Opn.mk ~loc me ) -# 38076 "src/ocaml/preprocess/parser_raw.ml" +# 46028 "src/ocaml/preprocess/parser_raw.ml" in let _startpos_od_ = _startpos__1_ in @@ -38080,12 +46032,12 @@ module Tables = struct let _symbolstartpos = _startpos_od_ in let _sloc = (_symbolstartpos, _endpos) in -# 2780 "src/ocaml/preprocess/parser_raw.mly" +# 2745 "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) ) -# 38089 "src/ocaml/preprocess/parser_raw.ml" +# 46041 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__9_ in @@ -38093,15 +46045,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1095 "src/ocaml/preprocess/parser_raw.mly" +# 1060 "src/ocaml/preprocess/parser_raw.mly" ( mkexp ~loc:_sloc _1 ) -# 38099 "src/ocaml/preprocess/parser_raw.ml" +# 46051 "src/ocaml/preprocess/parser_raw.ml" in -# 2651 "src/ocaml/preprocess/parser_raw.mly" +# 2616 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38105 "src/ocaml/preprocess/parser_raw.ml" +# 46057 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38130,30 +46082,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38136 "src/ocaml/preprocess/parser_raw.ml" +# 46088 "src/ocaml/preprocess/parser_raw.ml" in -# 3104 "src/ocaml/preprocess/parser_raw.mly" +# 3069 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_var (_1) ) -# 38142 "src/ocaml/preprocess/parser_raw.ml" +# 46094 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38151 "src/ocaml/preprocess/parser_raw.ml" +# 46103 "src/ocaml/preprocess/parser_raw.ml" in -# 3105 "src/ocaml/preprocess/parser_raw.mly" +# 3070 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38157 "src/ocaml/preprocess/parser_raw.ml" +# 46109 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38176,9 +46128,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 3106 "src/ocaml/preprocess/parser_raw.mly" +# 3071 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38182 "src/ocaml/preprocess/parser_raw.ml" +# 46134 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38218,9 +46170,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3111 "src/ocaml/preprocess/parser_raw.mly" +# 3076 "src/ocaml/preprocess/parser_raw.mly" ( reloc_pat ~loc:_sloc _2 ) -# 38224 "src/ocaml/preprocess/parser_raw.ml" +# 46176 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38243,9 +46195,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = -# 3113 "src/ocaml/preprocess/parser_raw.mly" +# 3078 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38249 "src/ocaml/preprocess/parser_raw.ml" +# 46201 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38308,9 +46260,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38314 "src/ocaml/preprocess/parser_raw.ml" +# 46266 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -38318,24 +46270,24 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38324 "src/ocaml/preprocess/parser_raw.ml" +# 46276 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 38330 "src/ocaml/preprocess/parser_raw.ml" +# 46282 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3115 "src/ocaml/preprocess/parser_raw.mly" +# 3080 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_unpack _4) _3 ) -# 38339 "src/ocaml/preprocess/parser_raw.ml" +# 46291 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38412,11 +46364,11 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3842 "src/ocaml/preprocess/parser_raw.mly" +# 3807 "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 ) -# 38420 "src/ocaml/preprocess/parser_raw.ml" +# 46372 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -38425,9 +46377,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38431 "src/ocaml/preprocess/parser_raw.ml" +# 46383 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__4_, _startpos__4_) = (_endpos__1_inlined3_, _startpos__1_inlined3_) in @@ -38436,15 +46388,15 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38442 "src/ocaml/preprocess/parser_raw.ml" +# 46394 "src/ocaml/preprocess/parser_raw.ml" in -# 4275 "src/ocaml/preprocess/parser_raw.mly" +# 4240 "src/ocaml/preprocess/parser_raw.mly" ( _1, _2 ) -# 38448 "src/ocaml/preprocess/parser_raw.ml" +# 46400 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in @@ -38452,11 +46404,11 @@ module Tables = struct let _loc__4_ = (_startpos__4_, _endpos__4_) in let _sloc = (_symbolstartpos, _endpos) in -# 3117 "src/ocaml/preprocess/parser_raw.mly" +# 3082 "src/ocaml/preprocess/parser_raw.mly" ( mkpat_attrs ~loc:_sloc (Ppat_constraint(mkpat ~loc:_loc__4_ (Ppat_unpack _4), _6)) _3 ) -# 38460 "src/ocaml/preprocess/parser_raw.ml" +# 46412 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38480,23 +46432,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3125 "src/ocaml/preprocess/parser_raw.mly" +# 3090 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_any ) -# 38486 "src/ocaml/preprocess/parser_raw.ml" +# 46438 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38494 "src/ocaml/preprocess/parser_raw.ml" +# 46446 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38500 "src/ocaml/preprocess/parser_raw.ml" +# 46452 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38520,23 +46472,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3127 "src/ocaml/preprocess/parser_raw.mly" +# 3092 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constant _1 ) -# 38526 "src/ocaml/preprocess/parser_raw.ml" +# 46478 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38534 "src/ocaml/preprocess/parser_raw.ml" +# 46486 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38540 "src/ocaml/preprocess/parser_raw.ml" +# 46492 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38574,24 +46526,24 @@ module Tables = struct let _endpos = _endpos__3_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3129 "src/ocaml/preprocess/parser_raw.mly" +# 3094 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_interval (_1, _3) ) -# 38580 "src/ocaml/preprocess/parser_raw.ml" +# 46532 "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 -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38589 "src/ocaml/preprocess/parser_raw.ml" +# 46541 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38595 "src/ocaml/preprocess/parser_raw.ml" +# 46547 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38620,30 +46572,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38626 "src/ocaml/preprocess/parser_raw.ml" +# 46578 "src/ocaml/preprocess/parser_raw.ml" in -# 3131 "src/ocaml/preprocess/parser_raw.mly" +# 3096 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_construct(_1, None) ) -# 38632 "src/ocaml/preprocess/parser_raw.ml" +# 46584 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38641 "src/ocaml/preprocess/parser_raw.ml" +# 46593 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38647 "src/ocaml/preprocess/parser_raw.ml" +# 46599 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38667,23 +46619,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3133 "src/ocaml/preprocess/parser_raw.mly" +# 3098 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_variant(_1, None) ) -# 38673 "src/ocaml/preprocess/parser_raw.ml" +# 46625 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38681 "src/ocaml/preprocess/parser_raw.ml" +# 46633 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38687 "src/ocaml/preprocess/parser_raw.ml" +# 46639 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38720,15 +46672,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38726 "src/ocaml/preprocess/parser_raw.ml" +# 46678 "src/ocaml/preprocess/parser_raw.ml" in -# 3135 "src/ocaml/preprocess/parser_raw.mly" +# 3100 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_type (_2) ) -# 38732 "src/ocaml/preprocess/parser_raw.ml" +# 46684 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -38736,15 +46688,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38742 "src/ocaml/preprocess/parser_raw.ml" +# 46694 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38748 "src/ocaml/preprocess/parser_raw.ml" +# 46700 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38787,15 +46739,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38793 "src/ocaml/preprocess/parser_raw.ml" +# 46745 "src/ocaml/preprocess/parser_raw.ml" in -# 3137 "src/ocaml/preprocess/parser_raw.mly" +# 3102 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, _3) ) -# 38799 "src/ocaml/preprocess/parser_raw.ml" +# 46751 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__3_ in @@ -38803,15 +46755,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38809 "src/ocaml/preprocess/parser_raw.ml" +# 46761 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38815 "src/ocaml/preprocess/parser_raw.ml" +# 46767 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38859,18 +46811,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 3138 "src/ocaml/preprocess/parser_raw.mly" +# 3103 "src/ocaml/preprocess/parser_raw.mly" (Lident "[]") -# 38865 "src/ocaml/preprocess/parser_raw.ml" +# 46817 "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 -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38874 "src/ocaml/preprocess/parser_raw.ml" +# 46826 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -38879,18 +46831,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38885 "src/ocaml/preprocess/parser_raw.ml" +# 46837 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3139 "src/ocaml/preprocess/parser_raw.mly" +# 3104 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 38894 "src/ocaml/preprocess/parser_raw.ml" +# 46846 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -38898,15 +46850,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38904 "src/ocaml/preprocess/parser_raw.ml" +# 46856 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 38910 "src/ocaml/preprocess/parser_raw.ml" +# 46862 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -38954,18 +46906,18 @@ module Tables = struct let _3 = let (_endpos__2_, _startpos__1_, _2, _1) = (_endpos__2_inlined1_, _startpos__1_inlined1_, _2_inlined1, _1_inlined1) in let _1 = -# 3140 "src/ocaml/preprocess/parser_raw.mly" +# 3105 "src/ocaml/preprocess/parser_raw.mly" (Lident "()") -# 38960 "src/ocaml/preprocess/parser_raw.ml" +# 46912 "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 -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38969 "src/ocaml/preprocess/parser_raw.ml" +# 46921 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__3_ = _endpos__2_inlined1_ in @@ -38974,18 +46926,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 38980 "src/ocaml/preprocess/parser_raw.ml" +# 46932 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__3_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3141 "src/ocaml/preprocess/parser_raw.mly" +# 3106 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open(_1, mkpat ~loc:_sloc (Ppat_construct(_3, None))) ) -# 38989 "src/ocaml/preprocess/parser_raw.ml" +# 46941 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__2_inlined1_ in @@ -38993,15 +46945,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 38999 "src/ocaml/preprocess/parser_raw.ml" +# 46951 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39005 "src/ocaml/preprocess/parser_raw.ml" +# 46957 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39058,15 +47010,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 39064 "src/ocaml/preprocess/parser_raw.ml" +# 47016 "src/ocaml/preprocess/parser_raw.ml" in -# 3143 "src/ocaml/preprocess/parser_raw.mly" +# 3108 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_open (_1, _4) ) -# 39070 "src/ocaml/preprocess/parser_raw.ml" +# 47022 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__5_ in @@ -39074,15 +47026,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39080 "src/ocaml/preprocess/parser_raw.ml" +# 47032 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39086 "src/ocaml/preprocess/parser_raw.ml" +# 47038 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39134,24 +47086,24 @@ module Tables = struct let _endpos = _endpos__5_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3153 "src/ocaml/preprocess/parser_raw.mly" +# 3118 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_constraint(_2, _4) ) -# 39140 "src/ocaml/preprocess/parser_raw.ml" +# 47092 "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 -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39149 "src/ocaml/preprocess/parser_raw.ml" +# 47101 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39155 "src/ocaml/preprocess/parser_raw.ml" +# 47107 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39175,23 +47127,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.pattern) = let _1 = let _1 = -# 3164 "src/ocaml/preprocess/parser_raw.mly" +# 3129 "src/ocaml/preprocess/parser_raw.mly" ( Ppat_extension _1 ) -# 39181 "src/ocaml/preprocess/parser_raw.ml" +# 47133 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1097 "src/ocaml/preprocess/parser_raw.mly" +# 1062 "src/ocaml/preprocess/parser_raw.mly" ( mkpat ~loc:_sloc _1 ) -# 39189 "src/ocaml/preprocess/parser_raw.ml" +# 47141 "src/ocaml/preprocess/parser_raw.ml" in -# 3121 "src/ocaml/preprocess/parser_raw.mly" +# 3086 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39195 "src/ocaml/preprocess/parser_raw.ml" +# 47147 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39210,17 +47162,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 39216 "src/ocaml/preprocess/parser_raw.ml" +# 47168 "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) = -# 4183 "src/ocaml/preprocess/parser_raw.mly" +# 4148 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39224 "src/ocaml/preprocess/parser_raw.ml" +# 47176 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39239,17 +47191,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 39245 "src/ocaml/preprocess/parser_raw.ml" +# 47197 "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) = -# 4184 "src/ocaml/preprocess/parser_raw.mly" +# 4149 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 39253 "src/ocaml/preprocess/parser_raw.ml" +# 47205 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39272,9 +47224,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4185 "src/ocaml/preprocess/parser_raw.mly" +# 4150 "src/ocaml/preprocess/parser_raw.mly" ( "and" ) -# 39278 "src/ocaml/preprocess/parser_raw.ml" +# 47230 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39297,9 +47249,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4186 "src/ocaml/preprocess/parser_raw.mly" +# 4151 "src/ocaml/preprocess/parser_raw.mly" ( "as" ) -# 39303 "src/ocaml/preprocess/parser_raw.ml" +# 47255 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39322,9 +47274,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4187 "src/ocaml/preprocess/parser_raw.mly" +# 4152 "src/ocaml/preprocess/parser_raw.mly" ( "assert" ) -# 39328 "src/ocaml/preprocess/parser_raw.ml" +# 47280 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39347,9 +47299,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4188 "src/ocaml/preprocess/parser_raw.mly" +# 4153 "src/ocaml/preprocess/parser_raw.mly" ( "begin" ) -# 39353 "src/ocaml/preprocess/parser_raw.ml" +# 47305 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39372,9 +47324,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4189 "src/ocaml/preprocess/parser_raw.mly" +# 4154 "src/ocaml/preprocess/parser_raw.mly" ( "class" ) -# 39378 "src/ocaml/preprocess/parser_raw.ml" +# 47330 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39397,9 +47349,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4190 "src/ocaml/preprocess/parser_raw.mly" +# 4155 "src/ocaml/preprocess/parser_raw.mly" ( "constraint" ) -# 39403 "src/ocaml/preprocess/parser_raw.ml" +# 47355 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39422,9 +47374,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4191 "src/ocaml/preprocess/parser_raw.mly" +# 4156 "src/ocaml/preprocess/parser_raw.mly" ( "do" ) -# 39428 "src/ocaml/preprocess/parser_raw.ml" +# 47380 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39447,9 +47399,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4192 "src/ocaml/preprocess/parser_raw.mly" +# 4157 "src/ocaml/preprocess/parser_raw.mly" ( "done" ) -# 39453 "src/ocaml/preprocess/parser_raw.ml" +# 47405 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39472,9 +47424,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4193 "src/ocaml/preprocess/parser_raw.mly" +# 4158 "src/ocaml/preprocess/parser_raw.mly" ( "downto" ) -# 39478 "src/ocaml/preprocess/parser_raw.ml" +# 47430 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39497,9 +47449,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4194 "src/ocaml/preprocess/parser_raw.mly" +# 4159 "src/ocaml/preprocess/parser_raw.mly" ( "else" ) -# 39503 "src/ocaml/preprocess/parser_raw.ml" +# 47455 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39522,9 +47474,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4195 "src/ocaml/preprocess/parser_raw.mly" +# 4160 "src/ocaml/preprocess/parser_raw.mly" ( "end" ) -# 39528 "src/ocaml/preprocess/parser_raw.ml" +# 47480 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39547,9 +47499,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4196 "src/ocaml/preprocess/parser_raw.mly" +# 4161 "src/ocaml/preprocess/parser_raw.mly" ( "exception" ) -# 39553 "src/ocaml/preprocess/parser_raw.ml" +# 47505 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39572,9 +47524,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4197 "src/ocaml/preprocess/parser_raw.mly" +# 4162 "src/ocaml/preprocess/parser_raw.mly" ( "external" ) -# 39578 "src/ocaml/preprocess/parser_raw.ml" +# 47530 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39597,9 +47549,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4198 "src/ocaml/preprocess/parser_raw.mly" +# 4163 "src/ocaml/preprocess/parser_raw.mly" ( "false" ) -# 39603 "src/ocaml/preprocess/parser_raw.ml" +# 47555 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39622,9 +47574,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4199 "src/ocaml/preprocess/parser_raw.mly" +# 4164 "src/ocaml/preprocess/parser_raw.mly" ( "for" ) -# 39628 "src/ocaml/preprocess/parser_raw.ml" +# 47580 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39647,9 +47599,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4200 "src/ocaml/preprocess/parser_raw.mly" +# 4165 "src/ocaml/preprocess/parser_raw.mly" ( "fun" ) -# 39653 "src/ocaml/preprocess/parser_raw.ml" +# 47605 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39672,9 +47624,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4201 "src/ocaml/preprocess/parser_raw.mly" +# 4166 "src/ocaml/preprocess/parser_raw.mly" ( "function" ) -# 39678 "src/ocaml/preprocess/parser_raw.ml" +# 47630 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39697,9 +47649,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4202 "src/ocaml/preprocess/parser_raw.mly" +# 4167 "src/ocaml/preprocess/parser_raw.mly" ( "functor" ) -# 39703 "src/ocaml/preprocess/parser_raw.ml" +# 47655 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39722,9 +47674,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4203 "src/ocaml/preprocess/parser_raw.mly" +# 4168 "src/ocaml/preprocess/parser_raw.mly" ( "if" ) -# 39728 "src/ocaml/preprocess/parser_raw.ml" +# 47680 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39747,9 +47699,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4204 "src/ocaml/preprocess/parser_raw.mly" +# 4169 "src/ocaml/preprocess/parser_raw.mly" ( "in" ) -# 39753 "src/ocaml/preprocess/parser_raw.ml" +# 47705 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39772,9 +47724,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4205 "src/ocaml/preprocess/parser_raw.mly" +# 4170 "src/ocaml/preprocess/parser_raw.mly" ( "include" ) -# 39778 "src/ocaml/preprocess/parser_raw.ml" +# 47730 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39797,9 +47749,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4206 "src/ocaml/preprocess/parser_raw.mly" +# 4171 "src/ocaml/preprocess/parser_raw.mly" ( "inherit" ) -# 39803 "src/ocaml/preprocess/parser_raw.ml" +# 47755 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39822,9 +47774,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4207 "src/ocaml/preprocess/parser_raw.mly" +# 4172 "src/ocaml/preprocess/parser_raw.mly" ( "initializer" ) -# 39828 "src/ocaml/preprocess/parser_raw.ml" +# 47780 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39847,9 +47799,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4208 "src/ocaml/preprocess/parser_raw.mly" +# 4173 "src/ocaml/preprocess/parser_raw.mly" ( "lazy" ) -# 39853 "src/ocaml/preprocess/parser_raw.ml" +# 47805 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39872,9 +47824,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4209 "src/ocaml/preprocess/parser_raw.mly" +# 4174 "src/ocaml/preprocess/parser_raw.mly" ( "let" ) -# 39878 "src/ocaml/preprocess/parser_raw.ml" +# 47830 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39897,9 +47849,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4210 "src/ocaml/preprocess/parser_raw.mly" +# 4175 "src/ocaml/preprocess/parser_raw.mly" ( "match" ) -# 39903 "src/ocaml/preprocess/parser_raw.ml" +# 47855 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39922,9 +47874,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4211 "src/ocaml/preprocess/parser_raw.mly" +# 4176 "src/ocaml/preprocess/parser_raw.mly" ( "method" ) -# 39928 "src/ocaml/preprocess/parser_raw.ml" +# 47880 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39947,9 +47899,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4212 "src/ocaml/preprocess/parser_raw.mly" +# 4177 "src/ocaml/preprocess/parser_raw.mly" ( "module" ) -# 39953 "src/ocaml/preprocess/parser_raw.ml" +# 47905 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39972,9 +47924,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4213 "src/ocaml/preprocess/parser_raw.mly" +# 4178 "src/ocaml/preprocess/parser_raw.mly" ( "mutable" ) -# 39978 "src/ocaml/preprocess/parser_raw.ml" +# 47930 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -39997,9 +47949,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4214 "src/ocaml/preprocess/parser_raw.mly" +# 4179 "src/ocaml/preprocess/parser_raw.mly" ( "new" ) -# 40003 "src/ocaml/preprocess/parser_raw.ml" +# 47955 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40022,9 +47974,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4215 "src/ocaml/preprocess/parser_raw.mly" +# 4180 "src/ocaml/preprocess/parser_raw.mly" ( "nonrec" ) -# 40028 "src/ocaml/preprocess/parser_raw.ml" +# 47980 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40047,9 +47999,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4216 "src/ocaml/preprocess/parser_raw.mly" +# 4181 "src/ocaml/preprocess/parser_raw.mly" ( "object" ) -# 40053 "src/ocaml/preprocess/parser_raw.ml" +# 48005 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40072,9 +48024,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4217 "src/ocaml/preprocess/parser_raw.mly" +# 4182 "src/ocaml/preprocess/parser_raw.mly" ( "of" ) -# 40078 "src/ocaml/preprocess/parser_raw.ml" +# 48030 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40097,9 +48049,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4218 "src/ocaml/preprocess/parser_raw.mly" +# 4183 "src/ocaml/preprocess/parser_raw.mly" ( "open" ) -# 40103 "src/ocaml/preprocess/parser_raw.ml" +# 48055 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40122,9 +48074,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4219 "src/ocaml/preprocess/parser_raw.mly" +# 4184 "src/ocaml/preprocess/parser_raw.mly" ( "or" ) -# 40128 "src/ocaml/preprocess/parser_raw.ml" +# 48080 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40147,9 +48099,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4220 "src/ocaml/preprocess/parser_raw.mly" +# 4185 "src/ocaml/preprocess/parser_raw.mly" ( "private" ) -# 40153 "src/ocaml/preprocess/parser_raw.ml" +# 48105 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40172,9 +48124,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4221 "src/ocaml/preprocess/parser_raw.mly" +# 4186 "src/ocaml/preprocess/parser_raw.mly" ( "rec" ) -# 40178 "src/ocaml/preprocess/parser_raw.ml" +# 48130 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40197,9 +48149,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4222 "src/ocaml/preprocess/parser_raw.mly" +# 4187 "src/ocaml/preprocess/parser_raw.mly" ( "sig" ) -# 40203 "src/ocaml/preprocess/parser_raw.ml" +# 48155 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40222,9 +48174,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4223 "src/ocaml/preprocess/parser_raw.mly" +# 4188 "src/ocaml/preprocess/parser_raw.mly" ( "struct" ) -# 40228 "src/ocaml/preprocess/parser_raw.ml" +# 48180 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40247,9 +48199,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4224 "src/ocaml/preprocess/parser_raw.mly" +# 4189 "src/ocaml/preprocess/parser_raw.mly" ( "then" ) -# 40253 "src/ocaml/preprocess/parser_raw.ml" +# 48205 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40272,9 +48224,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4225 "src/ocaml/preprocess/parser_raw.mly" +# 4190 "src/ocaml/preprocess/parser_raw.mly" ( "to" ) -# 40278 "src/ocaml/preprocess/parser_raw.ml" +# 48230 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40297,9 +48249,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4226 "src/ocaml/preprocess/parser_raw.mly" +# 4191 "src/ocaml/preprocess/parser_raw.mly" ( "true" ) -# 40303 "src/ocaml/preprocess/parser_raw.ml" +# 48255 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40322,9 +48274,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4227 "src/ocaml/preprocess/parser_raw.mly" +# 4192 "src/ocaml/preprocess/parser_raw.mly" ( "try" ) -# 40328 "src/ocaml/preprocess/parser_raw.ml" +# 48280 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40347,9 +48299,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4228 "src/ocaml/preprocess/parser_raw.mly" +# 4193 "src/ocaml/preprocess/parser_raw.mly" ( "type" ) -# 40353 "src/ocaml/preprocess/parser_raw.ml" +# 48305 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40372,9 +48324,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4229 "src/ocaml/preprocess/parser_raw.mly" +# 4194 "src/ocaml/preprocess/parser_raw.mly" ( "val" ) -# 40378 "src/ocaml/preprocess/parser_raw.ml" +# 48330 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40397,9 +48349,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4230 "src/ocaml/preprocess/parser_raw.mly" +# 4195 "src/ocaml/preprocess/parser_raw.mly" ( "virtual" ) -# 40403 "src/ocaml/preprocess/parser_raw.ml" +# 48355 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40422,9 +48374,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4231 "src/ocaml/preprocess/parser_raw.mly" +# 4196 "src/ocaml/preprocess/parser_raw.mly" ( "when" ) -# 40428 "src/ocaml/preprocess/parser_raw.ml" +# 48380 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40447,9 +48399,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4232 "src/ocaml/preprocess/parser_raw.mly" +# 4197 "src/ocaml/preprocess/parser_raw.mly" ( "while" ) -# 40453 "src/ocaml/preprocess/parser_raw.ml" +# 48405 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40472,9 +48424,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4233 "src/ocaml/preprocess/parser_raw.mly" +# 4198 "src/ocaml/preprocess/parser_raw.mly" ( "with" ) -# 40478 "src/ocaml/preprocess/parser_raw.ml" +# 48430 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40497,9 +48449,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.type_exception * string Location.loc option) = -# 3445 "src/ocaml/preprocess/parser_raw.mly" +# 3410 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40503 "src/ocaml/preprocess/parser_raw.ml" +# 48455 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40573,18 +48525,18 @@ module Tables = struct let _v : (Parsetree.type_exception * string Location.loc option) = let attrs = let _1 = _1_inlined5 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40579 "src/ocaml/preprocess/parser_raw.ml" +# 48531 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs_ = _endpos__1_inlined5_ in let attrs2 = let _1 = _1_inlined4 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40588 "src/ocaml/preprocess/parser_raw.ml" +# 48540 "src/ocaml/preprocess/parser_raw.ml" in let lid = @@ -40593,9 +48545,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40599 "src/ocaml/preprocess/parser_raw.ml" +# 48551 "src/ocaml/preprocess/parser_raw.ml" in let id = @@ -40604,30 +48556,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 40610 "src/ocaml/preprocess/parser_raw.ml" +# 48562 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40618 "src/ocaml/preprocess/parser_raw.ml" +# 48570 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3454 "src/ocaml/preprocess/parser_raw.mly" +# 3419 "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 ) -# 40631 "src/ocaml/preprocess/parser_raw.ml" +# 48583 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40657,9 +48609,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.expression) = -# 2907 "src/ocaml/preprocess/parser_raw.mly" +# 2872 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 40663 "src/ocaml/preprocess/parser_raw.ml" +# 48615 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40706,10 +48658,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2909 "src/ocaml/preprocess/parser_raw.mly" +# 2874 "src/ocaml/preprocess/parser_raw.mly" ( ghexp ~loc:_sloc (mkfunction _1 _2 _4) ) -# 40713 "src/ocaml/preprocess/parser_raw.ml" +# 48665 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40736,39 +48688,39 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 40740 "src/ocaml/preprocess/parser_raw.ml" +# 48692 "src/ocaml/preprocess/parser_raw.ml" in let xs = let items = -# 1132 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 40746 "src/ocaml/preprocess/parser_raw.ml" +# 48698 "src/ocaml/preprocess/parser_raw.ml" in -# 1598 "src/ocaml/preprocess/parser_raw.mly" +# 1563 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 40751 "src/ocaml/preprocess/parser_raw.ml" +# 48703 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 40757 "src/ocaml/preprocess/parser_raw.ml" +# 48709 "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 -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1019 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 40766 "src/ocaml/preprocess/parser_raw.ml" +# 48718 "src/ocaml/preprocess/parser_raw.ml" in -# 1591 "src/ocaml/preprocess/parser_raw.mly" +# 1556 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40772 "src/ocaml/preprocess/parser_raw.ml" +# 48724 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40809,7 +48761,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 40813 "src/ocaml/preprocess/parser_raw.ml" +# 48765 "src/ocaml/preprocess/parser_raw.ml" in let xs = let items = @@ -40817,93 +48769,65 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40823 "src/ocaml/preprocess/parser_raw.ml" +# 48775 "src/ocaml/preprocess/parser_raw.ml" in -# 1605 "src/ocaml/preprocess/parser_raw.mly" +# 1570 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 40828 "src/ocaml/preprocess/parser_raw.ml" +# 48780 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 40836 "src/ocaml/preprocess/parser_raw.ml" +# 48788 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1085 "src/ocaml/preprocess/parser_raw.mly" +# 1050 "src/ocaml/preprocess/parser_raw.mly" ( mark_rhs_docs _startpos _endpos; _1 ) -# 40846 "src/ocaml/preprocess/parser_raw.ml" +# 48798 "src/ocaml/preprocess/parser_raw.ml" in -# 1134 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 40852 "src/ocaml/preprocess/parser_raw.ml" +# 48804 "src/ocaml/preprocess/parser_raw.ml" in -# 1598 "src/ocaml/preprocess/parser_raw.mly" +# 1563 "src/ocaml/preprocess/parser_raw.mly" ( items ) -# 40858 "src/ocaml/preprocess/parser_raw.ml" +# 48810 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 40864 "src/ocaml/preprocess/parser_raw.ml" +# 48816 "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 -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1019 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 40873 "src/ocaml/preprocess/parser_raw.ml" +# 48825 "src/ocaml/preprocess/parser_raw.ml" in -# 1591 "src/ocaml/preprocess/parser_raw.mly" +# 1556 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40879 "src/ocaml/preprocess/parser_raw.ml" - in - { - MenhirLib.EngineTypes.state = _menhir_s; - MenhirLib.EngineTypes.semv = Obj.repr _v; - MenhirLib.EngineTypes.startp = _startpos; - MenhirLib.EngineTypes.endp = _endpos; - MenhirLib.EngineTypes.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 - -# 4311 "src/ocaml/preprocess/parser_raw.mly" - ( val_of_lwt_bindings ~loc:_loc _1 ) -# 40907 "src/ocaml/preprocess/parser_raw.ml" +# 48831 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40929,9 +48853,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1620 "src/ocaml/preprocess/parser_raw.mly" +# 1585 "src/ocaml/preprocess/parser_raw.mly" ( val_of_let_bindings ~loc:_sloc _1 ) -# 40935 "src/ocaml/preprocess/parser_raw.ml" +# 48859 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -40965,9 +48889,9 @@ module Tables = struct let _2 = let _1 = _1_inlined1 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40971 "src/ocaml/preprocess/parser_raw.ml" +# 48895 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -40975,10 +48899,10 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1623 "src/ocaml/preprocess/parser_raw.mly" +# 1588 "src/ocaml/preprocess/parser_raw.mly" ( let docs = symbol_docs _sloc in Pstr_extension (_1, add_docs_attrs docs _2) ) -# 40982 "src/ocaml/preprocess/parser_raw.ml" +# 48906 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined1_ in @@ -40986,15 +48910,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1101 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( mkstr ~loc:_sloc _1 ) -# 40992 "src/ocaml/preprocess/parser_raw.ml" +# 48916 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 40998 "src/ocaml/preprocess/parser_raw.ml" +# 48922 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41018,23 +48942,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1626 "src/ocaml/preprocess/parser_raw.mly" +# 1591 "src/ocaml/preprocess/parser_raw.mly" ( Pstr_attribute _1 ) -# 41024 "src/ocaml/preprocess/parser_raw.ml" +# 48948 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1101 "src/ocaml/preprocess/parser_raw.mly" +# 1066 "src/ocaml/preprocess/parser_raw.mly" ( mkstr ~loc:_sloc _1 ) -# 41032 "src/ocaml/preprocess/parser_raw.ml" +# 48956 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41038 "src/ocaml/preprocess/parser_raw.ml" +# 48962 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41058,23 +48982,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1630 "src/ocaml/preprocess/parser_raw.mly" +# 1595 "src/ocaml/preprocess/parser_raw.mly" ( pstr_primitive _1 ) -# 41064 "src/ocaml/preprocess/parser_raw.ml" +# 48988 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41072 "src/ocaml/preprocess/parser_raw.ml" +# 48996 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41078 "src/ocaml/preprocess/parser_raw.ml" +# 49002 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41098,23 +49022,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1632 "src/ocaml/preprocess/parser_raw.mly" +# 1597 "src/ocaml/preprocess/parser_raw.mly" ( pstr_primitive _1 ) -# 41104 "src/ocaml/preprocess/parser_raw.ml" +# 49028 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41112 "src/ocaml/preprocess/parser_raw.ml" +# 49036 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41118 "src/ocaml/preprocess/parser_raw.ml" +# 49042 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41149,26 +49073,26 @@ module Tables = struct let _1 = let _1 = let _1 = -# 1314 "src/ocaml/preprocess/parser_raw.mly" +# 1279 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 41155 "src/ocaml/preprocess/parser_raw.ml" +# 49079 "src/ocaml/preprocess/parser_raw.ml" in -# 3287 "src/ocaml/preprocess/parser_raw.mly" +# 3252 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41160 "src/ocaml/preprocess/parser_raw.ml" +# 49084 "src/ocaml/preprocess/parser_raw.ml" in -# 3270 "src/ocaml/preprocess/parser_raw.mly" +# 3235 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41166 "src/ocaml/preprocess/parser_raw.ml" +# 49090 "src/ocaml/preprocess/parser_raw.ml" in -# 1634 "src/ocaml/preprocess/parser_raw.mly" +# 1599 "src/ocaml/preprocess/parser_raw.mly" ( pstr_type _1 ) -# 41172 "src/ocaml/preprocess/parser_raw.ml" +# 49096 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_bs_, _startpos_a_) in @@ -41176,15 +49100,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41182 "src/ocaml/preprocess/parser_raw.ml" +# 49106 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41188 "src/ocaml/preprocess/parser_raw.ml" +# 49112 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41269,16 +49193,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41275 "src/ocaml/preprocess/parser_raw.ml" +# 49199 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in let cs = -# 1306 "src/ocaml/preprocess/parser_raw.mly" +# 1271 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 41282 "src/ocaml/preprocess/parser_raw.ml" +# 49206 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in @@ -41286,46 +49210,46 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41292 "src/ocaml/preprocess/parser_raw.ml" +# 49216 "src/ocaml/preprocess/parser_raw.ml" in let _4 = -# 4103 "src/ocaml/preprocess/parser_raw.mly" +# 4068 "src/ocaml/preprocess/parser_raw.mly" ( Recursive ) -# 41298 "src/ocaml/preprocess/parser_raw.ml" +# 49222 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41305 "src/ocaml/preprocess/parser_raw.ml" +# 49229 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3542 "src/ocaml/preprocess/parser_raw.mly" +# 3507 "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 ) -# 41317 "src/ocaml/preprocess/parser_raw.ml" +# 49241 "src/ocaml/preprocess/parser_raw.ml" in -# 3525 "src/ocaml/preprocess/parser_raw.mly" +# 3490 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41323 "src/ocaml/preprocess/parser_raw.ml" +# 49247 "src/ocaml/preprocess/parser_raw.ml" in -# 1636 "src/ocaml/preprocess/parser_raw.mly" +# 1601 "src/ocaml/preprocess/parser_raw.mly" ( pstr_typext _1 ) -# 41329 "src/ocaml/preprocess/parser_raw.ml" +# 49253 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -41333,15 +49257,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41339 "src/ocaml/preprocess/parser_raw.ml" +# 49263 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41345 "src/ocaml/preprocess/parser_raw.ml" +# 49269 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41433,16 +49357,16 @@ module Tables = struct let attrs2 = let _1 = _1_inlined4 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41439 "src/ocaml/preprocess/parser_raw.ml" +# 49363 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined4_ in let cs = -# 1306 "src/ocaml/preprocess/parser_raw.mly" +# 1271 "src/ocaml/preprocess/parser_raw.mly" ( List.rev xs ) -# 41446 "src/ocaml/preprocess/parser_raw.ml" +# 49370 "src/ocaml/preprocess/parser_raw.ml" in let tid = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined3_, _startpos__1_inlined3_, _1_inlined3) in @@ -41450,9 +49374,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41456 "src/ocaml/preprocess/parser_raw.ml" +# 49380 "src/ocaml/preprocess/parser_raw.ml" in let _4 = @@ -41461,41 +49385,41 @@ module Tables = struct let _startpos = _startpos__1_ in let _loc = (_startpos, _endpos) in -# 4105 "src/ocaml/preprocess/parser_raw.mly" +# 4070 "src/ocaml/preprocess/parser_raw.mly" ( not_expecting _loc "nonrec flag"; Recursive ) -# 41467 "src/ocaml/preprocess/parser_raw.ml" +# 49391 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41475 "src/ocaml/preprocess/parser_raw.ml" +# 49399 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3542 "src/ocaml/preprocess/parser_raw.mly" +# 3507 "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 ) -# 41487 "src/ocaml/preprocess/parser_raw.ml" +# 49411 "src/ocaml/preprocess/parser_raw.ml" in -# 3525 "src/ocaml/preprocess/parser_raw.mly" +# 3490 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41493 "src/ocaml/preprocess/parser_raw.ml" +# 49417 "src/ocaml/preprocess/parser_raw.ml" in -# 1636 "src/ocaml/preprocess/parser_raw.mly" +# 1601 "src/ocaml/preprocess/parser_raw.mly" ( pstr_typext _1 ) -# 41499 "src/ocaml/preprocess/parser_raw.ml" +# 49423 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined4_ in @@ -41503,15 +49427,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41509 "src/ocaml/preprocess/parser_raw.ml" +# 49433 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41515 "src/ocaml/preprocess/parser_raw.ml" +# 49439 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41535,23 +49459,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1638 "src/ocaml/preprocess/parser_raw.mly" +# 1603 "src/ocaml/preprocess/parser_raw.mly" ( pstr_exception _1 ) -# 41541 "src/ocaml/preprocess/parser_raw.ml" +# 49465 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41549 "src/ocaml/preprocess/parser_raw.ml" +# 49473 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41555 "src/ocaml/preprocess/parser_raw.ml" +# 49479 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41614,9 +49538,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41620 "src/ocaml/preprocess/parser_raw.ml" +# 49544 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41626,36 +49550,36 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41632 "src/ocaml/preprocess/parser_raw.ml" +# 49556 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41640 "src/ocaml/preprocess/parser_raw.ml" +# 49564 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1664 "src/ocaml/preprocess/parser_raw.mly" +# 1629 "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 ) -# 41653 "src/ocaml/preprocess/parser_raw.ml" +# 49577 "src/ocaml/preprocess/parser_raw.ml" in -# 1640 "src/ocaml/preprocess/parser_raw.mly" +# 1605 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41659 "src/ocaml/preprocess/parser_raw.ml" +# 49583 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined3_ in @@ -41663,15 +49587,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41669 "src/ocaml/preprocess/parser_raw.ml" +# 49593 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41675 "src/ocaml/preprocess/parser_raw.ml" +# 49599 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41750,9 +49674,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41756 "src/ocaml/preprocess/parser_raw.ml" +# 49680 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -41762,24 +49686,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 41768 "src/ocaml/preprocess/parser_raw.ml" +# 49692 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41776 "src/ocaml/preprocess/parser_raw.ml" +# 49700 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1703 "src/ocaml/preprocess/parser_raw.mly" +# 1668 "src/ocaml/preprocess/parser_raw.mly" ( let loc = make_loc _sloc in let attrs = attrs1 @ attrs2 in @@ -41787,25 +49711,25 @@ module Tables = struct ext, Mb.mk name body ~attrs ~loc ~docs ) -# 41791 "src/ocaml/preprocess/parser_raw.ml" +# 49715 "src/ocaml/preprocess/parser_raw.ml" in -# 1314 "src/ocaml/preprocess/parser_raw.mly" +# 1279 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 41797 "src/ocaml/preprocess/parser_raw.ml" +# 49721 "src/ocaml/preprocess/parser_raw.ml" in -# 1691 "src/ocaml/preprocess/parser_raw.mly" +# 1656 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41803 "src/ocaml/preprocess/parser_raw.ml" +# 49727 "src/ocaml/preprocess/parser_raw.ml" in -# 1642 "src/ocaml/preprocess/parser_raw.mly" +# 1607 "src/ocaml/preprocess/parser_raw.mly" ( pstr_recmodule _1 ) -# 41809 "src/ocaml/preprocess/parser_raw.ml" +# 49733 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -41813,15 +49737,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41819 "src/ocaml/preprocess/parser_raw.ml" +# 49743 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41825 "src/ocaml/preprocess/parser_raw.ml" +# 49749 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41845,23 +49769,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1644 "src/ocaml/preprocess/parser_raw.mly" +# 1609 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Pstr_modtype body, ext) ) -# 41851 "src/ocaml/preprocess/parser_raw.ml" +# 49775 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41859 "src/ocaml/preprocess/parser_raw.ml" +# 49783 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41865 "src/ocaml/preprocess/parser_raw.ml" +# 49789 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41885,23 +49809,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1646 "src/ocaml/preprocess/parser_raw.mly" +# 1611 "src/ocaml/preprocess/parser_raw.mly" ( let (body, ext) = _1 in (Pstr_open body, ext) ) -# 41891 "src/ocaml/preprocess/parser_raw.ml" +# 49815 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 41899 "src/ocaml/preprocess/parser_raw.ml" +# 49823 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41905 "src/ocaml/preprocess/parser_raw.ml" +# 49829 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -41971,9 +49895,9 @@ module Tables = struct let _1_inlined3 : (Parsetree.attributes) = Obj.magic _1_inlined3 in let body : (Parsetree.class_expr) = Obj.magic body in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 41977 "src/ocaml/preprocess/parser_raw.ml" +# 49901 "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 @@ -41991,9 +49915,9 @@ module Tables = struct let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 41997 "src/ocaml/preprocess/parser_raw.ml" +# 49921 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -42003,24 +49927,24 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42009 "src/ocaml/preprocess/parser_raw.ml" +# 49933 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42017 "src/ocaml/preprocess/parser_raw.ml" +# 49941 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 2057 "src/ocaml/preprocess/parser_raw.mly" +# 2022 "src/ocaml/preprocess/parser_raw.mly" ( let attrs = attrs1 @ attrs2 in let loc = make_loc _sloc in @@ -42028,25 +49952,25 @@ module Tables = struct ext, Ci.mk id body ~virt ~params ~attrs ~loc ~docs ) -# 42032 "src/ocaml/preprocess/parser_raw.ml" +# 49956 "src/ocaml/preprocess/parser_raw.ml" in -# 1314 "src/ocaml/preprocess/parser_raw.mly" +# 1279 "src/ocaml/preprocess/parser_raw.mly" ( let (x, b) = a in x, b :: bs ) -# 42038 "src/ocaml/preprocess/parser_raw.ml" +# 49962 "src/ocaml/preprocess/parser_raw.ml" in -# 2046 "src/ocaml/preprocess/parser_raw.mly" +# 2011 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42044 "src/ocaml/preprocess/parser_raw.ml" +# 49968 "src/ocaml/preprocess/parser_raw.ml" in -# 1648 "src/ocaml/preprocess/parser_raw.mly" +# 1613 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Pstr_class l, ext) ) -# 42050 "src/ocaml/preprocess/parser_raw.ml" +# 49974 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos_bs_ in @@ -42054,15 +49978,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 42060 "src/ocaml/preprocess/parser_raw.ml" +# 49984 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42066 "src/ocaml/preprocess/parser_raw.ml" +# 49990 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42086,23 +50010,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.structure_item) = let _1 = let _1 = -# 1650 "src/ocaml/preprocess/parser_raw.mly" +# 1615 "src/ocaml/preprocess/parser_raw.mly" ( let (ext, l) = _1 in (Pstr_class_type l, ext) ) -# 42092 "src/ocaml/preprocess/parser_raw.ml" +# 50016 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 42100 "src/ocaml/preprocess/parser_raw.ml" +# 50024 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42106 "src/ocaml/preprocess/parser_raw.ml" +# 50030 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42158,38 +50082,38 @@ module Tables = struct let attrs2 = let _1 = _1_inlined2 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42164 "src/ocaml/preprocess/parser_raw.ml" +# 50088 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined2_ in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42173 "src/ocaml/preprocess/parser_raw.ml" +# 50097 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1740 "src/ocaml/preprocess/parser_raw.mly" +# 1705 "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 ) -# 42187 "src/ocaml/preprocess/parser_raw.ml" +# 50111 "src/ocaml/preprocess/parser_raw.ml" in -# 1652 "src/ocaml/preprocess/parser_raw.mly" +# 1617 "src/ocaml/preprocess/parser_raw.mly" ( pstr_include _1 ) -# 42193 "src/ocaml/preprocess/parser_raw.ml" +# 50117 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__1_ = _endpos__1_inlined2_ in @@ -42197,15 +50121,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1118 "src/ocaml/preprocess/parser_raw.mly" +# 1083 "src/ocaml/preprocess/parser_raw.mly" ( wrap_mkstr_ext ~loc:_sloc _1 ) -# 42203 "src/ocaml/preprocess/parser_raw.ml" +# 50127 "src/ocaml/preprocess/parser_raw.ml" in -# 1654 "src/ocaml/preprocess/parser_raw.mly" +# 1619 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42209 "src/ocaml/preprocess/parser_raw.ml" +# 50133 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42228,9 +50152,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4168 "src/ocaml/preprocess/parser_raw.mly" +# 4133 "src/ocaml/preprocess/parser_raw.mly" ( "-" ) -# 42234 "src/ocaml/preprocess/parser_raw.ml" +# 50158 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42253,9 +50177,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 4169 "src/ocaml/preprocess/parser_raw.mly" +# 4134 "src/ocaml/preprocess/parser_raw.mly" ( "-." ) -# 42259 "src/ocaml/preprocess/parser_raw.ml" +# 50183 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42308,9 +50232,9 @@ module Tables = struct let _v : (Parsetree.row_field) = let _5 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42314 "src/ocaml/preprocess/parser_raw.ml" +# 50238 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined1_ in @@ -42319,18 +50243,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 42323 "src/ocaml/preprocess/parser_raw.ml" +# 50247 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 42328 "src/ocaml/preprocess/parser_raw.ml" +# 50252 "src/ocaml/preprocess/parser_raw.ml" in -# 3872 "src/ocaml/preprocess/parser_raw.mly" +# 3837 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42334 "src/ocaml/preprocess/parser_raw.ml" +# 50258 "src/ocaml/preprocess/parser_raw.ml" in let _1 = @@ -42338,20 +50262,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42344 "src/ocaml/preprocess/parser_raw.ml" +# 50268 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3858 "src/ocaml/preprocess/parser_raw.mly" +# 3823 "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 ) -# 42355 "src/ocaml/preprocess/parser_raw.ml" +# 50279 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42383,9 +50307,9 @@ module Tables = struct let _v : (Parsetree.row_field) = let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42389 "src/ocaml/preprocess/parser_raw.ml" +# 50313 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__2_ = _endpos__1_inlined1_ in @@ -42394,20 +50318,20 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42400 "src/ocaml/preprocess/parser_raw.ml" +# 50324 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3862 "src/ocaml/preprocess/parser_raw.mly" +# 3827 "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 [] ) -# 42411 "src/ocaml/preprocess/parser_raw.ml" +# 50335 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42439,7 +50363,7 @@ module Tables = struct let _v : (Parsetree.toplevel_phrase) = let arg = # 124 "" ( None ) -# 42443 "src/ocaml/preprocess/parser_raw.ml" +# 50367 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined1_ in let dir = @@ -42448,18 +50372,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42454 "src/ocaml/preprocess/parser_raw.ml" +# 50378 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4066 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42463 "src/ocaml/preprocess/parser_raw.ml" +# 50387 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42490,9 +50414,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : ( -# 903 "src/ocaml/preprocess/parser_raw.mly" +# 876 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 42496 "src/ocaml/preprocess/parser_raw.ml" +# 50420 "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 @@ -42503,23 +50427,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 4070 "src/ocaml/preprocess/parser_raw.mly" +# 4035 "src/ocaml/preprocess/parser_raw.mly" ( let (s, _, _) = _1 in Pdir_string s ) -# 42509 "src/ocaml/preprocess/parser_raw.ml" +# 50433 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1123 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42517 "src/ocaml/preprocess/parser_raw.ml" +# 50441 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42523 "src/ocaml/preprocess/parser_raw.ml" +# 50447 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42529,18 +50453,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42535 "src/ocaml/preprocess/parser_raw.ml" +# 50459 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4066 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42544 "src/ocaml/preprocess/parser_raw.ml" +# 50468 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42571,9 +50495,9 @@ module Tables = struct }; } = _menhir_stack in let _1_inlined2 : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 824 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 42577 "src/ocaml/preprocess/parser_raw.ml" +# 50501 "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 @@ -42584,23 +50508,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 4071 "src/ocaml/preprocess/parser_raw.mly" +# 4036 "src/ocaml/preprocess/parser_raw.mly" ( let (n, m) = _1 in Pdir_int (n ,m) ) -# 42590 "src/ocaml/preprocess/parser_raw.ml" +# 50514 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1123 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42598 "src/ocaml/preprocess/parser_raw.ml" +# 50522 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42604 "src/ocaml/preprocess/parser_raw.ml" +# 50528 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42610,18 +50534,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42616 "src/ocaml/preprocess/parser_raw.ml" +# 50540 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4066 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42625 "src/ocaml/preprocess/parser_raw.ml" +# 50549 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42661,23 +50585,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 4072 "src/ocaml/preprocess/parser_raw.mly" +# 4037 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_ident _1 ) -# 42667 "src/ocaml/preprocess/parser_raw.ml" +# 50591 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1123 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42675 "src/ocaml/preprocess/parser_raw.ml" +# 50599 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42681 "src/ocaml/preprocess/parser_raw.ml" +# 50605 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42687,18 +50611,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42693 "src/ocaml/preprocess/parser_raw.ml" +# 50617 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4066 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42702 "src/ocaml/preprocess/parser_raw.ml" +# 50626 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42738,23 +50662,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 4073 "src/ocaml/preprocess/parser_raw.mly" +# 4038 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_ident _1 ) -# 42744 "src/ocaml/preprocess/parser_raw.ml" +# 50668 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1123 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42752 "src/ocaml/preprocess/parser_raw.ml" +# 50676 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42758 "src/ocaml/preprocess/parser_raw.ml" +# 50682 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42764,18 +50688,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42770 "src/ocaml/preprocess/parser_raw.ml" +# 50694 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4066 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42779 "src/ocaml/preprocess/parser_raw.ml" +# 50703 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42815,23 +50739,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 4074 "src/ocaml/preprocess/parser_raw.mly" +# 4039 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_bool false ) -# 42821 "src/ocaml/preprocess/parser_raw.ml" +# 50745 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1123 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42829 "src/ocaml/preprocess/parser_raw.ml" +# 50753 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42835 "src/ocaml/preprocess/parser_raw.ml" +# 50759 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42841,18 +50765,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42847 "src/ocaml/preprocess/parser_raw.ml" +# 50771 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4066 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42856 "src/ocaml/preprocess/parser_raw.ml" +# 50780 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42892,23 +50816,23 @@ module Tables = struct let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let x = let _1 = -# 4075 "src/ocaml/preprocess/parser_raw.mly" +# 4040 "src/ocaml/preprocess/parser_raw.mly" ( Pdir_bool true ) -# 42898 "src/ocaml/preprocess/parser_raw.ml" +# 50822 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1123 "src/ocaml/preprocess/parser_raw.mly" +# 1088 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive_arg ~loc:_sloc _1 ) -# 42906 "src/ocaml/preprocess/parser_raw.ml" +# 50830 "src/ocaml/preprocess/parser_raw.ml" in # 126 "" ( Some x ) -# 42912 "src/ocaml/preprocess/parser_raw.ml" +# 50836 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_arg_ = _endpos__1_inlined2_ in @@ -42918,18 +50842,18 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 42924 "src/ocaml/preprocess/parser_raw.ml" +# 50848 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_arg_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 4066 "src/ocaml/preprocess/parser_raw.mly" +# 4031 "src/ocaml/preprocess/parser_raw.mly" ( mk_directive ~loc:_sloc dir arg ) -# 42933 "src/ocaml/preprocess/parser_raw.ml" +# 50857 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -42969,37 +50893,37 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 42975 "src/ocaml/preprocess/parser_raw.ml" +# 50899 "src/ocaml/preprocess/parser_raw.ml" in -# 1605 "src/ocaml/preprocess/parser_raw.mly" +# 1570 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 42980 "src/ocaml/preprocess/parser_raw.ml" +# 50904 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1066 "src/ocaml/preprocess/parser_raw.mly" +# 1031 "src/ocaml/preprocess/parser_raw.mly" ( text_str _startpos @ [_1] ) -# 42988 "src/ocaml/preprocess/parser_raw.ml" +# 50912 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _endpos = _endpos__1_ in let _startpos = _startpos__1_ in -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1019 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 42997 "src/ocaml/preprocess/parser_raw.ml" +# 50921 "src/ocaml/preprocess/parser_raw.ml" in -# 1354 "src/ocaml/preprocess/parser_raw.mly" +# 1319 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def _1 ) -# 43003 "src/ocaml/preprocess/parser_raw.ml" +# 50927 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43032,21 +50956,21 @@ module Tables = struct let _1 = # 260 "" ( List.flatten xss ) -# 43036 "src/ocaml/preprocess/parser_raw.ml" +# 50960 "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 -# 1054 "src/ocaml/preprocess/parser_raw.mly" +# 1019 "src/ocaml/preprocess/parser_raw.mly" ( extra_str _startpos _endpos _1 ) -# 43044 "src/ocaml/preprocess/parser_raw.ml" +# 50968 "src/ocaml/preprocess/parser_raw.ml" in -# 1358 "src/ocaml/preprocess/parser_raw.mly" +# 1323 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def _1 ) -# 43050 "src/ocaml/preprocess/parser_raw.ml" +# 50974 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43076,9 +51000,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.toplevel_phrase) = -# 1362 "src/ocaml/preprocess/parser_raw.mly" +# 1327 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43082 "src/ocaml/preprocess/parser_raw.ml" +# 51006 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43101,9 +51025,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Parsetree.toplevel_phrase) = -# 1365 "src/ocaml/preprocess/parser_raw.mly" +# 1330 "src/ocaml/preprocess/parser_raw.mly" ( raise End_of_file ) -# 43107 "src/ocaml/preprocess/parser_raw.ml" +# 51031 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43126,9 +51050,9 @@ module Tables = struct let _startpos = _startpos_ty_ in let _endpos = _endpos_ty_ in let _v : (Parsetree.core_type) = -# 3708 "src/ocaml/preprocess/parser_raw.mly" +# 3673 "src/ocaml/preprocess/parser_raw.mly" ( ty ) -# 43132 "src/ocaml/preprocess/parser_raw.ml" +# 51056 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43156,18 +51080,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 43160 "src/ocaml/preprocess/parser_raw.ml" +# 51084 "src/ocaml/preprocess/parser_raw.ml" in -# 1245 "src/ocaml/preprocess/parser_raw.mly" +# 1210 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 43165 "src/ocaml/preprocess/parser_raw.ml" +# 51089 "src/ocaml/preprocess/parser_raw.ml" in -# 3711 "src/ocaml/preprocess/parser_raw.mly" +# 3676 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_tuple tys ) -# 43171 "src/ocaml/preprocess/parser_raw.ml" +# 51095 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos_xs_, _startpos_xs_) in @@ -43175,15 +51099,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43181 "src/ocaml/preprocess/parser_raw.ml" +# 51105 "src/ocaml/preprocess/parser_raw.ml" in -# 3713 "src/ocaml/preprocess/parser_raw.mly" +# 3678 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43187 "src/ocaml/preprocess/parser_raw.ml" +# 51111 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43213,9 +51137,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.type_constraint) = -# 3024 "src/ocaml/preprocess/parser_raw.mly" +# 2989 "src/ocaml/preprocess/parser_raw.mly" ( Pconstraint _2 ) -# 43219 "src/ocaml/preprocess/parser_raw.ml" +# 51143 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43259,9 +51183,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__4_ in let _v : (Parsetree.type_constraint) = -# 3025 "src/ocaml/preprocess/parser_raw.mly" +# 2990 "src/ocaml/preprocess/parser_raw.mly" ( Pcoerce (Some _2, _4) ) -# 43265 "src/ocaml/preprocess/parser_raw.ml" +# 51189 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43291,9 +51215,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.type_constraint) = -# 3026 "src/ocaml/preprocess/parser_raw.mly" +# 2991 "src/ocaml/preprocess/parser_raw.mly" ( Pcoerce (None, _2) ) -# 43297 "src/ocaml/preprocess/parser_raw.ml" +# 51221 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43309,9 +51233,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = -# 3361 "src/ocaml/preprocess/parser_raw.mly" +# 3326 "src/ocaml/preprocess/parser_raw.mly" ( (Ptype_abstract, Public, None) ) -# 43315 "src/ocaml/preprocess/parser_raw.ml" +# 51239 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43341,9 +51265,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.type_kind * Asttypes.private_flag * Parsetree.core_type option) = -# 3363 "src/ocaml/preprocess/parser_raw.mly" +# 3328 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 43347 "src/ocaml/preprocess/parser_raw.ml" +# 51271 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43366,9 +51290,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4025 "src/ocaml/preprocess/parser_raw.mly" +# 3990 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43372 "src/ocaml/preprocess/parser_raw.ml" +# 51296 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43398,9 +51322,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) = -# 3378 "src/ocaml/preprocess/parser_raw.mly" +# 3343 "src/ocaml/preprocess/parser_raw.mly" ( _2, _1 ) -# 43404 "src/ocaml/preprocess/parser_raw.ml" +# 51328 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43416,9 +51340,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = -# 3371 "src/ocaml/preprocess/parser_raw.mly" +# 3336 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 43422 "src/ocaml/preprocess/parser_raw.ml" +# 51346 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43441,9 +51365,9 @@ module Tables = struct let _startpos = _startpos_p_ in let _endpos = _endpos_p_ in let _v : ((Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list) = -# 3373 "src/ocaml/preprocess/parser_raw.mly" +# 3338 "src/ocaml/preprocess/parser_raw.mly" ( [p] ) -# 43447 "src/ocaml/preprocess/parser_raw.ml" +# 51371 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43483,18 +51407,18 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 43487 "src/ocaml/preprocess/parser_raw.ml" +# 51411 "src/ocaml/preprocess/parser_raw.ml" in -# 1217 "src/ocaml/preprocess/parser_raw.mly" +# 1182 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 43492 "src/ocaml/preprocess/parser_raw.ml" +# 51416 "src/ocaml/preprocess/parser_raw.ml" in -# 3375 "src/ocaml/preprocess/parser_raw.mly" +# 3340 "src/ocaml/preprocess/parser_raw.mly" ( ps ) -# 43498 "src/ocaml/preprocess/parser_raw.ml" +# 51422 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43525,24 +51449,24 @@ module Tables = struct let _endpos = _endpos_tyvar_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3383 "src/ocaml/preprocess/parser_raw.mly" +# 3348 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_var tyvar ) -# 43531 "src/ocaml/preprocess/parser_raw.ml" +# 51455 "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 -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43540 "src/ocaml/preprocess/parser_raw.ml" +# 51464 "src/ocaml/preprocess/parser_raw.ml" in -# 3386 "src/ocaml/preprocess/parser_raw.mly" +# 3351 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43546 "src/ocaml/preprocess/parser_raw.ml" +# 51470 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43566,23 +51490,23 @@ module Tables = struct let _endpos = _endpos__1_ in let _v : (Parsetree.core_type) = let _1 = let _1 = -# 3385 "src/ocaml/preprocess/parser_raw.mly" +# 3350 "src/ocaml/preprocess/parser_raw.mly" ( Ptyp_any ) -# 43572 "src/ocaml/preprocess/parser_raw.ml" +# 51496 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1099 "src/ocaml/preprocess/parser_raw.mly" +# 1064 "src/ocaml/preprocess/parser_raw.mly" ( mktyp ~loc:_sloc _1 ) -# 43580 "src/ocaml/preprocess/parser_raw.ml" +# 51504 "src/ocaml/preprocess/parser_raw.ml" in -# 3386 "src/ocaml/preprocess/parser_raw.mly" +# 3351 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43586 "src/ocaml/preprocess/parser_raw.ml" +# 51510 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43598,9 +51522,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3390 "src/ocaml/preprocess/parser_raw.mly" +# 3355 "src/ocaml/preprocess/parser_raw.mly" ( NoVariance, NoInjectivity ) -# 43604 "src/ocaml/preprocess/parser_raw.ml" +# 51528 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43623,9 +51547,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3391 "src/ocaml/preprocess/parser_raw.mly" +# 3356 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, NoInjectivity ) -# 43629 "src/ocaml/preprocess/parser_raw.ml" +# 51553 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43648,9 +51572,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3392 "src/ocaml/preprocess/parser_raw.mly" +# 3357 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, NoInjectivity ) -# 43654 "src/ocaml/preprocess/parser_raw.ml" +# 51578 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43673,9 +51597,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3393 "src/ocaml/preprocess/parser_raw.mly" +# 3358 "src/ocaml/preprocess/parser_raw.mly" ( NoVariance, Injective ) -# 43679 "src/ocaml/preprocess/parser_raw.ml" +# 51603 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43705,9 +51629,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3394 "src/ocaml/preprocess/parser_raw.mly" +# 3359 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, Injective ) -# 43711 "src/ocaml/preprocess/parser_raw.ml" +# 51635 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43737,9 +51661,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3394 "src/ocaml/preprocess/parser_raw.mly" +# 3359 "src/ocaml/preprocess/parser_raw.mly" ( Covariant, Injective ) -# 43743 "src/ocaml/preprocess/parser_raw.ml" +# 51667 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43769,9 +51693,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3395 "src/ocaml/preprocess/parser_raw.mly" +# 3360 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, Injective ) -# 43775 "src/ocaml/preprocess/parser_raw.ml" +# 51699 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43801,9 +51725,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.variance * Asttypes.injectivity) = -# 3395 "src/ocaml/preprocess/parser_raw.mly" +# 3360 "src/ocaml/preprocess/parser_raw.mly" ( Contravariant, Injective ) -# 43807 "src/ocaml/preprocess/parser_raw.ml" +# 51731 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43822,21 +51746,21 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 843 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43828 "src/ocaml/preprocess/parser_raw.ml" +# 51752 "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 -# 3397 "src/ocaml/preprocess/parser_raw.mly" +# 3362 "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) ) -# 43840 "src/ocaml/preprocess/parser_raw.ml" +# 51764 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43855,21 +51779,21 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 889 "src/ocaml/preprocess/parser_raw.mly" +# 862 "src/ocaml/preprocess/parser_raw.mly" (string) -# 43861 "src/ocaml/preprocess/parser_raw.ml" +# 51785 "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 -# 3402 "src/ocaml/preprocess/parser_raw.mly" +# 3367 "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) ) -# 43873 "src/ocaml/preprocess/parser_raw.ml" +# 51797 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43903,39 +51827,39 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 43907 "src/ocaml/preprocess/parser_raw.ml" +# 51831 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _1 = -# 1132 "src/ocaml/preprocess/parser_raw.mly" +# 1097 "src/ocaml/preprocess/parser_raw.mly" ( [] ) -# 43913 "src/ocaml/preprocess/parser_raw.ml" +# 51837 "src/ocaml/preprocess/parser_raw.ml" in -# 1385 "src/ocaml/preprocess/parser_raw.mly" +# 1350 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43918 "src/ocaml/preprocess/parser_raw.ml" +# 51842 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 43924 "src/ocaml/preprocess/parser_raw.ml" +# 51848 "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 -# 1058 "src/ocaml/preprocess/parser_raw.mly" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( extra_def _startpos _endpos _1 ) -# 43933 "src/ocaml/preprocess/parser_raw.ml" +# 51857 "src/ocaml/preprocess/parser_raw.ml" in -# 1378 "src/ocaml/preprocess/parser_raw.mly" +# 1343 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43939 "src/ocaml/preprocess/parser_raw.ml" +# 51863 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -43983,7 +51907,7 @@ module Tables = struct let ys = # 260 "" ( List.flatten xss ) -# 43987 "src/ocaml/preprocess/parser_raw.ml" +# 51911 "src/ocaml/preprocess/parser_raw.ml" in let xs = let _1 = @@ -43991,61 +51915,61 @@ module Tables = struct let _1 = let _1 = let attrs = -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 43997 "src/ocaml/preprocess/parser_raw.ml" +# 51921 "src/ocaml/preprocess/parser_raw.ml" in -# 1605 "src/ocaml/preprocess/parser_raw.mly" +# 1570 "src/ocaml/preprocess/parser_raw.mly" ( mkstrexp e attrs ) -# 44002 "src/ocaml/preprocess/parser_raw.ml" +# 51926 "src/ocaml/preprocess/parser_raw.ml" in -# 1076 "src/ocaml/preprocess/parser_raw.mly" +# 1041 "src/ocaml/preprocess/parser_raw.mly" ( Ptop_def [_1] ) -# 44008 "src/ocaml/preprocess/parser_raw.ml" +# 51932 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__1_ = _startpos_e_ in let _startpos = _startpos__1_ in -# 1074 "src/ocaml/preprocess/parser_raw.mly" +# 1039 "src/ocaml/preprocess/parser_raw.mly" ( text_def _startpos @ [_1] ) -# 44016 "src/ocaml/preprocess/parser_raw.ml" +# 51940 "src/ocaml/preprocess/parser_raw.ml" in -# 1134 "src/ocaml/preprocess/parser_raw.mly" +# 1099 "src/ocaml/preprocess/parser_raw.mly" ( x ) -# 44022 "src/ocaml/preprocess/parser_raw.ml" +# 51946 "src/ocaml/preprocess/parser_raw.ml" in -# 1385 "src/ocaml/preprocess/parser_raw.mly" +# 1350 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44028 "src/ocaml/preprocess/parser_raw.ml" +# 51952 "src/ocaml/preprocess/parser_raw.ml" in # 267 "" ( xs @ ys ) -# 44034 "src/ocaml/preprocess/parser_raw.ml" +# 51958 "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 -# 1058 "src/ocaml/preprocess/parser_raw.mly" +# 1023 "src/ocaml/preprocess/parser_raw.mly" ( extra_def _startpos _endpos _1 ) -# 44043 "src/ocaml/preprocess/parser_raw.ml" +# 51967 "src/ocaml/preprocess/parser_raw.ml" in -# 1378 "src/ocaml/preprocess/parser_raw.mly" +# 1343 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44049 "src/ocaml/preprocess/parser_raw.ml" +# 51973 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44082,9 +52006,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__3_ in let _v : (string) = -# 3942 "src/ocaml/preprocess/parser_raw.mly" +# 3907 "src/ocaml/preprocess/parser_raw.mly" ( _2 ) -# 44088 "src/ocaml/preprocess/parser_raw.ml" +# 52012 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44103,17 +52027,17 @@ module Tables = struct MenhirLib.EngineTypes.next = _menhir_stack; } = _menhir_stack in let _1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44109 "src/ocaml/preprocess/parser_raw.ml" +# 52033 "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) = -# 3950 "src/ocaml/preprocess/parser_raw.mly" +# 3915 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44117 "src/ocaml/preprocess/parser_raw.ml" +# 52041 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44136,9 +52060,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (string) = -# 3951 "src/ocaml/preprocess/parser_raw.mly" +# 3916 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44142 "src/ocaml/preprocess/parser_raw.ml" +# 52066 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44161,9 +52085,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Longident.t) = -# 4019 "src/ocaml/preprocess/parser_raw.mly" +# 3984 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44167 "src/ocaml/preprocess/parser_raw.ml" +# 52091 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44208,9 +52132,9 @@ module Tables = struct let ty : (Parsetree.core_type) = Obj.magic ty in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44214 "src/ocaml/preprocess/parser_raw.ml" +# 52138 "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 @@ -44221,33 +52145,33 @@ module Tables = struct Parsetree.attributes) = let label = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44227 "src/ocaml/preprocess/parser_raw.ml" +# 52151 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44235 "src/ocaml/preprocess/parser_raw.ml" +# 52159 "src/ocaml/preprocess/parser_raw.ml" in let attrs = -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44241 "src/ocaml/preprocess/parser_raw.ml" +# 52165 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4161 "src/ocaml/preprocess/parser_raw.mly" +# 4126 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 44246 "src/ocaml/preprocess/parser_raw.ml" +# 52170 "src/ocaml/preprocess/parser_raw.ml" in -# 2203 "src/ocaml/preprocess/parser_raw.mly" +# 2168 "src/ocaml/preprocess/parser_raw.mly" ( (label, mutable_, Cfk_virtual ty), attrs ) -# 44251 "src/ocaml/preprocess/parser_raw.ml" +# 52175 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44292,9 +52216,9 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44298 "src/ocaml/preprocess/parser_raw.ml" +# 52222 "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 @@ -44305,33 +52229,33 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44311 "src/ocaml/preprocess/parser_raw.ml" +# 52235 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44319 "src/ocaml/preprocess/parser_raw.ml" +# 52243 "src/ocaml/preprocess/parser_raw.ml" in let _2 = -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44325 "src/ocaml/preprocess/parser_raw.ml" +# 52249 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4164 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 44330 "src/ocaml/preprocess/parser_raw.ml" +# 52254 "src/ocaml/preprocess/parser_raw.ml" in -# 2205 "src/ocaml/preprocess/parser_raw.mly" +# 2170 "src/ocaml/preprocess/parser_raw.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 44335 "src/ocaml/preprocess/parser_raw.ml" +# 52259 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44382,9 +52306,9 @@ module Tables = struct let _6 : (Parsetree.expression) = Obj.magic _6 in let _5 : unit = Obj.magic _5 in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44388 "src/ocaml/preprocess/parser_raw.ml" +# 52312 "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 @@ -44396,36 +52320,36 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44402 "src/ocaml/preprocess/parser_raw.ml" +# 52326 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44410 "src/ocaml/preprocess/parser_raw.ml" +# 52334 "src/ocaml/preprocess/parser_raw.ml" in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44418 "src/ocaml/preprocess/parser_raw.ml" +# 52342 "src/ocaml/preprocess/parser_raw.ml" in let _1 = -# 4165 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 44424 "src/ocaml/preprocess/parser_raw.ml" +# 52348 "src/ocaml/preprocess/parser_raw.ml" in -# 2205 "src/ocaml/preprocess/parser_raw.mly" +# 2170 "src/ocaml/preprocess/parser_raw.mly" ( (_4, _3, Cfk_concrete (_1, _6)), _2 ) -# 44429 "src/ocaml/preprocess/parser_raw.ml" +# 52353 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44477,9 +52401,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : (Parsetree.type_constraint) = Obj.magic _5 in let _1_inlined1 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44483 "src/ocaml/preprocess/parser_raw.ml" +# 52407 "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 @@ -44490,30 +52414,30 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined1_, _startpos__1_inlined1_, _1_inlined1) in let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44496 "src/ocaml/preprocess/parser_raw.ml" +# 52420 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44504 "src/ocaml/preprocess/parser_raw.ml" +# 52428 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined1_ in let _2 = -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44511 "src/ocaml/preprocess/parser_raw.ml" +# 52435 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_, _startpos__1_) in let _1 = -# 4164 "src/ocaml/preprocess/parser_raw.mly" +# 4129 "src/ocaml/preprocess/parser_raw.mly" ( Fresh ) -# 44517 "src/ocaml/preprocess/parser_raw.ml" +# 52441 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__1_, _startpos__1_) = (_endpos__0_, _endpos__0_) in let _endpos = _endpos__7_ in @@ -44529,11 +52453,11 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2208 "src/ocaml/preprocess/parser_raw.mly" +# 2173 "src/ocaml/preprocess/parser_raw.mly" ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 44537 "src/ocaml/preprocess/parser_raw.ml" +# 52461 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44591,9 +52515,9 @@ module Tables = struct let _6 : unit = Obj.magic _6 in let _5 : (Parsetree.type_constraint) = Obj.magic _5 in let _1_inlined2 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 44597 "src/ocaml/preprocess/parser_raw.ml" +# 52521 "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 @@ -44605,33 +52529,33 @@ module Tables = struct Parsetree.attributes) = let _4 = let (_endpos__1_, _startpos__1_, _1) = (_endpos__1_inlined2_, _startpos__1_inlined2_, _1_inlined2) in let _1 = -# 3916 "src/ocaml/preprocess/parser_raw.mly" +# 3881 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44611 "src/ocaml/preprocess/parser_raw.ml" +# 52535 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__1_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44619 "src/ocaml/preprocess/parser_raw.ml" +# 52543 "src/ocaml/preprocess/parser_raw.ml" in let _startpos__4_ = _startpos__1_inlined2_ in let _2 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44628 "src/ocaml/preprocess/parser_raw.ml" +# 52552 "src/ocaml/preprocess/parser_raw.ml" in let (_endpos__2_, _startpos__2_) = (_endpos__1_inlined1_, _startpos__1_inlined1_) in let _1 = -# 4165 "src/ocaml/preprocess/parser_raw.mly" +# 4130 "src/ocaml/preprocess/parser_raw.mly" ( Override ) -# 44635 "src/ocaml/preprocess/parser_raw.ml" +# 52559 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__7_ in let _symbolstartpos = if _startpos__1_ != _endpos__1_ then @@ -44646,11 +52570,11 @@ module Tables = struct _startpos__4_ in let _sloc = (_symbolstartpos, _endpos) in -# 2208 "src/ocaml/preprocess/parser_raw.mly" +# 2173 "src/ocaml/preprocess/parser_raw.mly" ( let e = mkexp_constraint ~loc:_sloc _7 _5 in (_4, _3, Cfk_concrete (_1, e)), _2 ) -# 44654 "src/ocaml/preprocess/parser_raw.ml" +# 52578 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44717,9 +52641,9 @@ module Tables = struct let _v : (Parsetree.value_description * string Location.loc option) = let attrs2 = let _1 = _1_inlined3 in -# 4258 "src/ocaml/preprocess/parser_raw.mly" +# 4223 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44723 "src/ocaml/preprocess/parser_raw.ml" +# 52647 "src/ocaml/preprocess/parser_raw.ml" in let _endpos_attrs2_ = _endpos__1_inlined3_ in @@ -44729,30 +52653,30 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 44735 "src/ocaml/preprocess/parser_raw.ml" +# 52659 "src/ocaml/preprocess/parser_raw.ml" in let attrs1 = let _1 = _1_inlined1 in -# 4262 "src/ocaml/preprocess/parser_raw.mly" +# 4227 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 44743 "src/ocaml/preprocess/parser_raw.ml" +# 52667 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos_attrs2_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3232 "src/ocaml/preprocess/parser_raw.mly" +# 3197 "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 ) -# 44756 "src/ocaml/preprocess/parser_raw.ml" +# 52680 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44768,9 +52692,9 @@ module Tables = struct let _startpos = _menhir_stack.MenhirLib.EngineTypes.endp in let _endpos = _startpos in let _v : (Asttypes.virtual_flag) = -# 4125 "src/ocaml/preprocess/parser_raw.mly" +# 4090 "src/ocaml/preprocess/parser_raw.mly" ( Concrete ) -# 44774 "src/ocaml/preprocess/parser_raw.ml" +# 52698 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44793,9 +52717,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.virtual_flag) = -# 4126 "src/ocaml/preprocess/parser_raw.mly" +# 4091 "src/ocaml/preprocess/parser_raw.mly" ( Virtual ) -# 44799 "src/ocaml/preprocess/parser_raw.ml" +# 52723 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44818,9 +52742,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.mutable_flag) = -# 4149 "src/ocaml/preprocess/parser_raw.mly" +# 4114 "src/ocaml/preprocess/parser_raw.mly" ( Immutable ) -# 44824 "src/ocaml/preprocess/parser_raw.ml" +# 52748 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44850,9 +52774,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag) = -# 4150 "src/ocaml/preprocess/parser_raw.mly" +# 4115 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 44856 "src/ocaml/preprocess/parser_raw.ml" +# 52780 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44882,9 +52806,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.mutable_flag) = -# 4151 "src/ocaml/preprocess/parser_raw.mly" +# 4116 "src/ocaml/preprocess/parser_raw.mly" ( Mutable ) -# 44888 "src/ocaml/preprocess/parser_raw.ml" +# 52812 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44907,9 +52831,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = -# 4156 "src/ocaml/preprocess/parser_raw.mly" +# 4121 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 44913 "src/ocaml/preprocess/parser_raw.ml" +# 52837 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44939,9 +52863,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 4157 "src/ocaml/preprocess/parser_raw.mly" +# 4122 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 44945 "src/ocaml/preprocess/parser_raw.ml" +# 52869 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -44971,9 +52895,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 4158 "src/ocaml/preprocess/parser_raw.mly" +# 4123 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 44977 "src/ocaml/preprocess/parser_raw.ml" +# 52901 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45035,27 +52959,27 @@ module Tables = struct let xs = # 253 "" ( List.rev xs ) -# 45039 "src/ocaml/preprocess/parser_raw.ml" +# 52963 "src/ocaml/preprocess/parser_raw.ml" in -# 1146 "src/ocaml/preprocess/parser_raw.mly" +# 1111 "src/ocaml/preprocess/parser_raw.mly" ( xs ) -# 45044 "src/ocaml/preprocess/parser_raw.ml" +# 52968 "src/ocaml/preprocess/parser_raw.ml" in -# 3332 "src/ocaml/preprocess/parser_raw.mly" +# 3297 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 45050 "src/ocaml/preprocess/parser_raw.ml" +# 52974 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__6_ = _endpos_xs_ in let _5 = let _1 = _1_inlined2 in -# 3656 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 45059 "src/ocaml/preprocess/parser_raw.ml" +# 52983 "src/ocaml/preprocess/parser_raw.ml" in let _3 = @@ -45064,16 +52988,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45070 "src/ocaml/preprocess/parser_raw.ml" +# 52994 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__6_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3575 "src/ocaml/preprocess/parser_raw.mly" +# 3540 "src/ocaml/preprocess/parser_raw.mly" ( let lident = loc_last _3 in Pwith_type (_3, @@ -45083,7 +53007,7 @@ module Tables = struct ~manifest:_5 ~priv:_4 ~loc:(make_loc _sloc))) ) -# 45087 "src/ocaml/preprocess/parser_raw.ml" +# 53011 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45136,9 +53060,9 @@ module Tables = struct let _v : (Parsetree.with_constraint) = let _5 = let _1 = _1_inlined2 in -# 3656 "src/ocaml/preprocess/parser_raw.mly" +# 3621 "src/ocaml/preprocess/parser_raw.mly" ( _1 ) -# 45142 "src/ocaml/preprocess/parser_raw.ml" +# 53066 "src/ocaml/preprocess/parser_raw.ml" in let _endpos__5_ = _endpos__1_inlined2_ in @@ -45148,16 +53072,16 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45154 "src/ocaml/preprocess/parser_raw.ml" +# 53078 "src/ocaml/preprocess/parser_raw.ml" in let _endpos = _endpos__5_ in let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 3588 "src/ocaml/preprocess/parser_raw.mly" +# 3553 "src/ocaml/preprocess/parser_raw.mly" ( let lident = loc_last _3 in Pwith_typesubst (_3, @@ -45165,7 +53089,7 @@ module Tables = struct ~params:_2 ~manifest:_5 ~loc:(make_loc _sloc))) ) -# 45169 "src/ocaml/preprocess/parser_raw.ml" +# 53093 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45214,9 +53138,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45220 "src/ocaml/preprocess/parser_raw.ml" +# 53144 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -45225,15 +53149,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45231 "src/ocaml/preprocess/parser_raw.ml" +# 53155 "src/ocaml/preprocess/parser_raw.ml" in -# 3596 "src/ocaml/preprocess/parser_raw.mly" +# 3561 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_module (_2, _4) ) -# 45237 "src/ocaml/preprocess/parser_raw.ml" +# 53161 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45282,9 +53206,9 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45288 "src/ocaml/preprocess/parser_raw.ml" +# 53212 "src/ocaml/preprocess/parser_raw.ml" in let _2 = @@ -45293,15 +53217,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45299 "src/ocaml/preprocess/parser_raw.ml" +# 53223 "src/ocaml/preprocess/parser_raw.ml" in -# 3598 "src/ocaml/preprocess/parser_raw.mly" +# 3563 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modsubst (_2, _4) ) -# 45305 "src/ocaml/preprocess/parser_raw.ml" +# 53229 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45357,15 +53281,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45363 "src/ocaml/preprocess/parser_raw.ml" +# 53287 "src/ocaml/preprocess/parser_raw.ml" in -# 3600 "src/ocaml/preprocess/parser_raw.mly" +# 3565 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modtype (l, rhs) ) -# 45369 "src/ocaml/preprocess/parser_raw.ml" +# 53293 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45421,15 +53345,15 @@ module Tables = struct let _symbolstartpos = _startpos__1_ in let _sloc = (_symbolstartpos, _endpos) in -# 1062 "src/ocaml/preprocess/parser_raw.mly" +# 1027 "src/ocaml/preprocess/parser_raw.mly" ( mkrhs _1 _sloc ) -# 45427 "src/ocaml/preprocess/parser_raw.ml" +# 53351 "src/ocaml/preprocess/parser_raw.ml" in -# 3602 "src/ocaml/preprocess/parser_raw.mly" +# 3567 "src/ocaml/preprocess/parser_raw.mly" ( Pwith_modtypesubst (l, rhs) ) -# 45433 "src/ocaml/preprocess/parser_raw.ml" +# 53357 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45452,9 +53376,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__1_ in let _v : (Asttypes.private_flag) = -# 3605 "src/ocaml/preprocess/parser_raw.mly" +# 3570 "src/ocaml/preprocess/parser_raw.mly" ( Public ) -# 45458 "src/ocaml/preprocess/parser_raw.ml" +# 53382 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45484,9 +53408,9 @@ module Tables = struct let _startpos = _startpos__1_ in let _endpos = _endpos__2_ in let _v : (Asttypes.private_flag) = -# 3606 "src/ocaml/preprocess/parser_raw.mly" +# 3571 "src/ocaml/preprocess/parser_raw.mly" ( Private ) -# 45490 "src/ocaml/preprocess/parser_raw.ml" +# 53414 "src/ocaml/preprocess/parser_raw.ml" in { MenhirLib.EngineTypes.state = _menhir_s; @@ -45515,19 +53439,17 @@ module MenhirInterpreter = 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 : ( -# 917 "src/ocaml/preprocess/parser_raw.mly" +# 890 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45528 "src/ocaml/preprocess/parser_raw.ml" +# 53451 "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 @@ -45535,9 +53457,9 @@ module MenhirInterpreter = struct | T_THEN : unit terminal | T_STRUCT : unit terminal | T_STRING : ( -# 903 "src/ocaml/preprocess/parser_raw.mly" +# 876 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string option) -# 45541 "src/ocaml/preprocess/parser_raw.ml" +# 53463 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_STAR : unit terminal | T_SIG : unit terminal @@ -45548,22 +53470,22 @@ module MenhirInterpreter = struct | T_RBRACKET : unit terminal | T_RBRACE : unit terminal | T_QUOTED_STRING_ITEM : ( -# 908 "src/ocaml/preprocess/parser_raw.mly" +# 881 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 45554 "src/ocaml/preprocess/parser_raw.ml" +# 53476 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_QUOTED_STRING_EXPR : ( -# 905 "src/ocaml/preprocess/parser_raw.mly" +# 878 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t * string * Location.t * string option) -# 45559 "src/ocaml/preprocess/parser_raw.ml" +# 53481 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_QUOTE : unit terminal | T_QUESTION : unit terminal | T_PRIVATE : unit terminal | T_PREFIXOP : ( -# 889 "src/ocaml/preprocess/parser_raw.mly" +# 862 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45567 "src/ocaml/preprocess/parser_raw.ml" +# 53489 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_PLUSEQ : unit terminal | T_PLUSDOT : unit terminal @@ -45571,9 +53493,9 @@ module MenhirInterpreter = struct | T_PERCENT : unit terminal | T_OR : unit terminal | T_OPTLABEL : ( -# 882 "src/ocaml/preprocess/parser_raw.mly" +# 855 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45577 "src/ocaml/preprocess/parser_raw.ml" +# 53499 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_OPEN : unit terminal | T_OF : unit terminal @@ -45586,19 +53508,17 @@ module MenhirInterpreter = struct | 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 : ( -# 865 "src/ocaml/preprocess/parser_raw.mly" +# 838 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45596 "src/ocaml/preprocess/parser_raw.ml" +# 53517 "src/ocaml/preprocess/parser_raw.ml" ) terminal - | T_LET_LWT : unit terminal | T_LETOP : ( -# 847 "src/ocaml/preprocess/parser_raw.mly" +# 820 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45602 "src/ocaml/preprocess/parser_raw.ml" +# 53522 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_LET : unit terminal | T_LESSMINUS : unit terminal @@ -45616,49 +53536,49 @@ module MenhirInterpreter = struct | T_LBRACE : unit terminal | T_LAZY : unit terminal | T_LABEL : ( -# 852 "src/ocaml/preprocess/parser_raw.mly" +# 825 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45622 "src/ocaml/preprocess/parser_raw.ml" +# 53542 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INT : ( -# 851 "src/ocaml/preprocess/parser_raw.mly" +# 824 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 45627 "src/ocaml/preprocess/parser_raw.ml" +# 53547 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INITIALIZER : unit terminal | T_INHERIT : unit terminal | T_INFIXOP4 : ( -# 845 "src/ocaml/preprocess/parser_raw.mly" +# 818 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45634 "src/ocaml/preprocess/parser_raw.ml" +# 53554 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP3 : ( -# 844 "src/ocaml/preprocess/parser_raw.mly" +# 817 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45639 "src/ocaml/preprocess/parser_raw.ml" +# 53559 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP2 : ( -# 843 "src/ocaml/preprocess/parser_raw.mly" +# 816 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45644 "src/ocaml/preprocess/parser_raw.ml" +# 53564 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP1 : ( -# 842 "src/ocaml/preprocess/parser_raw.mly" +# 815 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45649 "src/ocaml/preprocess/parser_raw.ml" +# 53569 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INFIXOP0 : ( -# 841 "src/ocaml/preprocess/parser_raw.mly" +# 814 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45654 "src/ocaml/preprocess/parser_raw.ml" +# 53574 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_INCLUDE : unit terminal | T_IN : unit terminal | T_IF : unit terminal | T_HASHOP : ( -# 900 "src/ocaml/preprocess/parser_raw.mly" +# 873 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45662 "src/ocaml/preprocess/parser_raw.ml" +# 53582 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_HASH : unit terminal | T_GREATERRBRACKET : unit terminal @@ -45668,14 +53588,12 @@ module MenhirInterpreter = struct | T_FUNCTOR : unit terminal | T_FUNCTION : unit terminal | T_FUN : unit terminal - | T_FOR_LWT : unit terminal | T_FOR : unit terminal | T_FLOAT : ( -# 830 "src/ocaml/preprocess/parser_raw.mly" +# 803 "src/ocaml/preprocess/parser_raw.mly" (string * char option) -# 45677 "src/ocaml/preprocess/parser_raw.ml" +# 53596 "src/ocaml/preprocess/parser_raw.ml" ) terminal - | T_FINALLY_LWT : unit terminal | T_FALSE : unit terminal | T_EXTERNAL : unit terminal | T_EXCEPTION : unit terminal @@ -45687,25 +53605,25 @@ module MenhirInterpreter = struct | T_DOWNTO : unit terminal | T_DOTTILDE : unit terminal | T_DOTOP : ( -# 846 "src/ocaml/preprocess/parser_raw.mly" +# 819 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45693 "src/ocaml/preprocess/parser_raw.ml" +# 53611 "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 : ( -# 925 "src/ocaml/preprocess/parser_raw.mly" +# 898 "src/ocaml/preprocess/parser_raw.mly" (Docstrings.docstring) -# 45702 "src/ocaml/preprocess/parser_raw.ml" +# 53620 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_DO : unit terminal | T_CONSTRAINT : unit terminal | T_COMMENT : ( -# 924 "src/ocaml/preprocess/parser_raw.mly" +# 897 "src/ocaml/preprocess/parser_raw.mly" (string * Location.t) -# 45709 "src/ocaml/preprocess/parser_raw.ml" +# 53627 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_COMMA : unit terminal | T_COLONGREATER : unit terminal @@ -45714,9 +53632,9 @@ module MenhirInterpreter = struct | T_COLON : unit terminal | T_CLASS : unit terminal | T_CHAR : ( -# 810 "src/ocaml/preprocess/parser_raw.mly" +# 783 "src/ocaml/preprocess/parser_raw.mly" (char) -# 45720 "src/ocaml/preprocess/parser_raw.ml" +# 53638 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_BEGIN : unit terminal | T_BARRBRACKET : unit terminal @@ -45727,9 +53645,9 @@ module MenhirInterpreter = struct | T_ASSERT : unit terminal | T_AS : unit terminal | T_ANDOP : ( -# 848 "src/ocaml/preprocess/parser_raw.mly" +# 821 "src/ocaml/preprocess/parser_raw.mly" (string) -# 45733 "src/ocaml/preprocess/parser_raw.ml" +# 53651 "src/ocaml/preprocess/parser_raw.ml" ) terminal | T_AND : unit terminal | T_AMPERSAND : unit terminal @@ -45870,8 +53788,6 @@ module MenhirInterpreter = struct 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 @@ -45936,7 +53852,6 @@ module MenhirInterpreter = struct | 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_delimited_type_supporting_local_open : (Parsetree.core_type) nonterminal | N_delimited_type : (Parsetree.core_type) nonterminal @@ -45990,266 +53905,254 @@ module MenhirInterpreter = struct | 1 -> X (T T_WITH) | 2 -> - X (T T_WHILE_LWT) - | 3 -> X (T T_WHILE) - | 4 -> + | 3 -> X (T T_WHEN) - | 5 -> + | 4 -> X (T T_VIRTUAL) - | 6 -> + | 5 -> X (T T_VAL) - | 7 -> + | 6 -> X (T T_UNDERSCORE) - | 8 -> + | 7 -> X (T T_UIDENT) - | 9 -> + | 8 -> X (T T_TYPE) - | 10 -> - X (T T_TRY_LWT) - | 11 -> + | 9 -> X (T T_TRY) - | 12 -> + | 10 -> X (T T_TRUE) - | 13 -> + | 11 -> X (T T_TO) - | 14 -> + | 12 -> X (T T_TILDE) - | 15 -> + | 13 -> X (T T_THEN) - | 16 -> + | 14 -> X (T T_STRUCT) - | 17 -> + | 15 -> X (T T_STRING) - | 18 -> + | 16 -> X (T T_STAR) - | 19 -> + | 17 -> X (T T_SIG) - | 20 -> + | 18 -> X (T T_SEMISEMI) - | 21 -> + | 19 -> X (T T_SEMI) - | 22 -> + | 20 -> X (T T_RPAREN) - | 23 -> + | 21 -> X (T T_REC) - | 24 -> + | 22 -> X (T T_RBRACKET) - | 25 -> + | 23 -> X (T T_RBRACE) - | 26 -> + | 24 -> X (T T_QUOTED_STRING_ITEM) - | 27 -> + | 25 -> X (T T_QUOTED_STRING_EXPR) - | 28 -> + | 26 -> X (T T_QUOTE) - | 29 -> + | 27 -> X (T T_QUESTION) - | 30 -> + | 28 -> X (T T_PRIVATE) - | 31 -> + | 29 -> X (T T_PREFIXOP) - | 32 -> + | 30 -> X (T T_PLUSEQ) - | 33 -> + | 31 -> X (T T_PLUSDOT) - | 34 -> + | 32 -> X (T T_PLUS) - | 35 -> + | 33 -> X (T T_PERCENT) - | 36 -> + | 34 -> X (T T_OR) - | 37 -> + | 35 -> X (T T_OPTLABEL) - | 38 -> + | 36 -> X (T T_OPEN) - | 39 -> + | 37 -> X (T T_OF) - | 40 -> + | 38 -> X (T T_OBJECT) - | 41 -> + | 39 -> X (T T_NONREC) - | 42 -> + | 40 -> X (T T_NEW) - | 43 -> + | 41 -> X (T T_MUTABLE) - | 44 -> + | 42 -> X (T T_MODULE) - | 45 -> + | 43 -> X (T T_MINUSGREATER) - | 46 -> + | 44 -> X (T T_MINUSDOT) - | 47 -> + | 45 -> X (T T_MINUS) - | 48 -> + | 46 -> X (T T_METHOD) - | 49 -> - X (T T_MATCH_LWT) - | 50 -> + | 47 -> X (T T_MATCH) - | 51 -> + | 48 -> X (T T_LPAREN) - | 52 -> + | 49 -> X (T T_LIDENT) - | 53 -> - X (T T_LET_LWT) - | 54 -> + | 50 -> X (T T_LETOP) - | 55 -> + | 51 -> X (T T_LET) - | 56 -> + | 52 -> X (T T_LESSMINUS) - | 57 -> + | 53 -> X (T T_LESS) - | 58 -> + | 54 -> X (T T_LBRACKETPERCENTPERCENT) - | 59 -> + | 55 -> X (T T_LBRACKETPERCENT) - | 60 -> + | 56 -> X (T T_LBRACKETLESS) - | 61 -> + | 57 -> X (T T_LBRACKETGREATER) - | 62 -> + | 58 -> X (T T_LBRACKETBAR) - | 63 -> + | 59 -> X (T T_LBRACKETATATAT) - | 64 -> + | 60 -> X (T T_LBRACKETATAT) - | 65 -> + | 61 -> X (T T_LBRACKETAT) - | 66 -> + | 62 -> X (T T_LBRACKET) - | 67 -> + | 63 -> X (T T_LBRACELESS) - | 68 -> + | 64 -> X (T T_LBRACE) - | 69 -> + | 65 -> X (T T_LAZY) - | 70 -> + | 66 -> X (T T_LABEL) - | 71 -> + | 67 -> X (T T_INT) - | 72 -> + | 68 -> X (T T_INITIALIZER) - | 73 -> + | 69 -> X (T T_INHERIT) - | 74 -> + | 70 -> X (T T_INFIXOP4) - | 75 -> + | 71 -> X (T T_INFIXOP3) - | 76 -> + | 72 -> X (T T_INFIXOP2) - | 77 -> + | 73 -> X (T T_INFIXOP1) - | 78 -> + | 74 -> X (T T_INFIXOP0) - | 79 -> + | 75 -> X (T T_INCLUDE) - | 80 -> + | 76 -> X (T T_IN) - | 81 -> + | 77 -> X (T T_IF) - | 82 -> + | 78 -> X (T T_HASHOP) - | 83 -> + | 79 -> X (T T_HASH) - | 84 -> + | 80 -> X (T T_GREATERRBRACKET) - | 85 -> + | 81 -> X (T T_GREATERRBRACE) - | 86 -> + | 82 -> X (T T_GREATERDOT) - | 87 -> + | 83 -> X (T T_GREATER) - | 88 -> + | 84 -> X (T T_FUNCTOR) - | 89 -> + | 85 -> X (T T_FUNCTION) - | 90 -> + | 86 -> X (T T_FUN) - | 91 -> - X (T T_FOR_LWT) - | 92 -> + | 87 -> X (T T_FOR) - | 93 -> + | 88 -> X (T T_FLOAT) - | 94 -> - X (T T_FINALLY_LWT) - | 95 -> + | 89 -> X (T T_FALSE) - | 96 -> + | 90 -> X (T T_EXTERNAL) - | 97 -> + | 91 -> X (T T_EXCEPTION) - | 98 -> + | 92 -> X (T T_EQUAL) - | 99 -> + | 93 -> X (T T_EOL) - | 100 -> + | 94 -> X (T T_EOF) - | 101 -> + | 95 -> X (T T_END) - | 102 -> + | 96 -> X (T T_ELSE) - | 103 -> + | 97 -> X (T T_DOWNTO) - | 104 -> + | 98 -> X (T T_DOTTILDE) - | 105 -> + | 99 -> X (T T_DOTOP) - | 106 -> + | 100 -> X (T T_DOTLESS) - | 107 -> + | 101 -> X (T T_DOTDOT) - | 108 -> + | 102 -> X (T T_DOT) - | 109 -> + | 103 -> X (T T_DONE) - | 110 -> + | 104 -> X (T T_DOCSTRING) - | 111 -> + | 105 -> X (T T_DO) - | 112 -> + | 106 -> X (T T_CONSTRAINT) - | 113 -> + | 107 -> X (T T_COMMENT) - | 114 -> + | 108 -> X (T T_COMMA) - | 115 -> + | 109 -> X (T T_COLONGREATER) - | 116 -> + | 110 -> X (T T_COLONEQUAL) - | 117 -> + | 111 -> X (T T_COLONCOLON) - | 118 -> + | 112 -> X (T T_COLON) - | 119 -> + | 113 -> X (T T_CLASS) - | 120 -> + | 114 -> X (T T_CHAR) - | 121 -> + | 115 -> X (T T_BEGIN) - | 122 -> + | 116 -> X (T T_BARRBRACKET) - | 123 -> + | 117 -> X (T T_BARBAR) - | 124 -> + | 118 -> X (T T_BAR) - | 125 -> + | 119 -> X (T T_BANG) - | 126 -> + | 120 -> X (T T_BACKQUOTE) - | 127 -> + | 121 -> X (T T_ASSERT) - | 128 -> + | 122 -> X (T T_AS) - | 129 -> + | 123 -> X (T T_ANDOP) - | 130 -> + | 124 -> X (T T_AND) - | 131 -> + | 125 -> X (T T_AMPERSAND) - | 132 -> + | 126 -> X (T T_AMPERAMPER) | _ -> assert false @@ -46257,186 +54160,180 @@ module MenhirInterpreter = struct and nonterminal = fun nt -> match nt with - | 235 -> - X (N N_additive) - | 234 -> - X (N N_alias_type) - | 233 -> - X (N N_and_let_binding) | 232 -> - X (N N_any_longident) + X (N N_additive) | 231 -> - X (N N_atomic_type) + X (N N_alias_type) | 230 -> - X (N N_attr_id) + X (N N_and_let_binding) | 229 -> - X (N N_attr_payload) + X (N N_any_longident) | 228 -> - X (N N_attribute) + X (N N_atomic_type) | 227 -> - X (N N_class_expr) + X (N N_attr_id) | 226 -> - X (N N_class_field) + X (N N_attr_payload) | 225 -> - X (N N_class_fun_binding) + X (N N_attribute) | 224 -> - X (N N_class_fun_def) + X (N N_class_expr) | 223 -> - X (N N_class_longident) + X (N N_class_field) | 222 -> - X (N N_class_self_pattern) + X (N N_class_fun_binding) | 221 -> - X (N N_class_self_type) + X (N N_class_fun_def) | 220 -> - X (N N_class_sig_field) + X (N N_class_longident) | 219 -> - X (N N_class_signature) + X (N N_class_self_pattern) | 218 -> - X (N N_class_simple_expr) + X (N N_class_self_type) | 217 -> - X (N N_class_type) + X (N N_class_sig_field) | 216 -> - X (N N_class_type_declarations) + X (N N_class_signature) | 215 -> - X (N N_clty_longident) + X (N N_class_simple_expr) | 214 -> - X (N N_constant) + X (N N_class_type) | 213 -> - X (N N_constr_extra_nonprefix_ident) + X (N N_class_type_declarations) | 212 -> - X (N N_constr_ident) + X (N N_clty_longident) | 211 -> - X (N N_constr_longident) + X (N N_constant) | 210 -> - X (N N_constrain_field) + X (N N_constr_extra_nonprefix_ident) | 209 -> - X (N N_constructor_arguments) + X (N N_constr_ident) | 208 -> - X (N N_constructor_declarations) + X (N N_constr_longident) | 207 -> - X (N N_core_type) + X (N N_constrain_field) | 206 -> - X (N N_delimited_type) + X (N N_constructor_arguments) | 205 -> - X (N N_delimited_type_supporting_local_open) + X (N N_constructor_declarations) | 204 -> - X (N N_direction_flag) + X (N N_core_type) | 203 -> - X (N N_expr) + X (N N_delimited_type) | 202 -> - X (N N_ext) + X (N N_delimited_type_supporting_local_open) | 201 -> - X (N N_extension) + X (N N_direction_flag) | 200 -> - X (N N_extension_constructor_rebind_BAR_) + X (N N_ext) | 199 -> - X (N N_extension_constructor_rebind_epsilon_) + X (N N_extension) | 198 -> - X (N N_extension_type) + X (N N_extension_constructor_rebind_BAR_) | 197 -> - X (N N_floating_attribute) + X (N N_extension_constructor_rebind_epsilon_) | 196 -> - X (N N_formal_class_parameters) + X (N N_extension_type) | 195 -> - X (N N_fun_body) + X (N N_floating_attribute) | 194 -> - X (N N_fun_expr) + X (N N_formal_class_parameters) | 193 -> - X (N N_fun_param_as_list) + X (N N_fun_body) | 192 -> - X (N N_fun_params) + X (N N_fun_expr) | 191 -> - X (N N_fun_seq_expr) + X (N N_fun_param_as_list) | 190 -> - X (N N_function_type) + X (N N_fun_params) | 189 -> - X (N N_functor_arg) + X (N N_fun_seq_expr) | 188 -> - X (N N_functor_args) + X (N N_function_type) | 187 -> - X (N N_generalized_constructor_arguments) + X (N N_functor_arg) | 186 -> - X (N N_generic_constructor_declaration_BAR_) + X (N N_functor_args) | 185 -> - X (N N_generic_constructor_declaration_epsilon_) + X (N N_generalized_constructor_arguments) | 184 -> - X (N N_generic_type_declaration_no_nonrec_flag_type_subst_kind_) + X (N N_generic_constructor_declaration_BAR_) | 183 -> - X (N N_generic_type_declaration_nonrec_flag_type_kind_) + X (N N_generic_constructor_declaration_epsilon_) | 182 -> - X (N N_ident) + X (N N_generic_type_declaration_no_nonrec_flag_type_subst_kind_) | 181 -> - X (N N_implementation) + X (N N_generic_type_declaration_nonrec_flag_type_kind_) | 180 -> - X (N N_index_mod) + X (N N_ident) | 179 -> - X (N N_interface) + X (N N_implementation) | 178 -> - X (N N_item_extension) + X (N N_index_mod) | 177 -> - X (N N_label_declaration) + X (N N_interface) | 176 -> - X (N N_label_declaration_semi) + X (N N_item_extension) | 175 -> - X (N N_label_declarations) + X (N N_label_declaration) | 174 -> - X (N N_label_let_pattern) + X (N N_label_declaration_semi) | 173 -> - X (N N_label_longident) + X (N N_label_declarations) | 172 -> - X (N N_labeled_simple_expr) + X (N N_label_let_pattern) | 171 -> - X (N N_labeled_simple_pattern) + X (N N_label_longident) | 170 -> - X (N N_let_binding_body) + X (N N_labeled_simple_expr) | 169 -> - X (N N_let_binding_body_no_punning) + X (N N_labeled_simple_pattern) | 168 -> - X (N N_let_bindings_ext_) + X (N N_let_binding_body) | 167 -> - X (N N_let_bindings_no_ext_) + X (N N_let_binding_body_no_punning) | 166 -> - X (N N_let_pattern) + X (N N_let_bindings_ext_) | 165 -> - X (N N_letop_binding_body) + X (N N_let_bindings_no_ext_) | 164 -> - X (N N_letop_bindings) + X (N N_let_pattern) | 163 -> - X (N N_list_and_class_declaration_) + X (N N_letop_binding_body) | 162 -> - X (N N_list_and_class_description_) + X (N N_letop_bindings) | 161 -> - X (N N_list_and_class_type_declaration_) + X (N N_list_and_class_declaration_) | 160 -> - X (N N_list_and_module_binding_) + X (N N_list_and_class_description_) | 159 -> - X (N N_list_and_module_declaration_) + X (N N_list_and_class_type_declaration_) | 158 -> - X (N N_list_attribute_) + X (N N_list_and_module_binding_) | 157 -> - X (N N_list_generic_and_type_declaration_type_kind__) + X (N N_list_and_module_declaration_) | 156 -> - X (N N_list_generic_and_type_declaration_type_subst_kind__) + X (N N_list_attribute_) | 155 -> - X (N N_list_post_item_attribute_) + X (N N_list_generic_and_type_declaration_type_kind__) | 154 -> - X (N N_list_signature_element_) + X (N N_list_generic_and_type_declaration_type_subst_kind__) | 153 -> - X (N N_list_structure_element_) + X (N N_list_post_item_attribute_) | 152 -> - X (N N_list_text_csig_class_sig_field__) + X (N N_list_signature_element_) | 151 -> - X (N N_list_text_cstr_class_field__) + X (N N_list_structure_element_) | 150 -> - X (N N_list_text_str_structure_item__) + X (N N_list_text_csig_class_sig_field__) | 149 -> - X (N N_list_use_file_element_) + X (N N_list_text_cstr_class_field__) | 148 -> - X (N N_listx_SEMI_record_pat_field_UNDERSCORE_) + X (N N_list_text_str_structure_item__) | 147 -> - X (N N_lwt_binding) + X (N N_list_use_file_element_) | 146 -> - X (N N_lwt_bindings) + X (N N_listx_SEMI_record_pat_field_UNDERSCORE_) | 145 -> X (N N_match_case) | 144 -> @@ -46703,22 +54600,22 @@ module MenhirInterpreter = struct 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\000U\000\218\001\205\001\205\001\149\000\132\001\205\000\b\001\149\001=\000\016\000\018\000\022\001\149\001=\000\024\001\149\001=\000\026\000$\0008\000@\000R\001\149\001=\000h\000\016\000F\000\144\000\188\000`\000\144\000\188\000h\000&\000.\000@\000B\000D\000F\000H\000J\000Z\001\149\001=\000\016\000\018\001\005\000.\000\238\000\018\000(\001=\000\014\001\149\001=\000h\000F\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\001i\000.\000r\000\134\001i\0002\000r\000\138\001i\0004\000r\000\234\000\248\000\252\001\004\001\b\001\n\000\231\000.\000j\000/\000\238\000\016\000\018\000:\000\018\000j\001m\000<\000j\000\238\000L\000h\000:\001m\000Z\001\149\001=\000Z\000\020\000P\001=\000\016\000\"\001=\000\020\001\149\001=\000@\000F\000\252\000T\000`\000\252\000h\000\154\000\252\000F\000`\0005\000\016\000:\001m\0007\000;\000{\000.\000\230\000;\0009\000j\000\198\000\018\000>\000h\000j\000\238\000j\000t\000j\000\238\000x\001\205\000*\0006\000D\000F\000N\000\252\001\149\001=\000h\000\014\001=\000V\001\149\001=\000j\001\r\000\218\000\018\000j\001\019\001\021\001\191\001\201\001=\000^\000`\000d\001\149\001=\000f\001\149\001=\000h\000@\000~\000j\000r\000l\001\149\001=\0000\000\155\000~\000\134\0002\000\138\001\021\001)\0004\001[\000\238\000z\000\250\000\227\000|\0002\000\227\000\134\000\168\001\015\000h\001\015\000.\000\218\000\018\001\027\000\218\000j\001\029\001\175\000\250\000\254\001m\000=\000C\000\\\000s\000&\000\237\001\015\000\218\000h\000\207\000C\000\\\001\029\001}\001\141\001\147\001\155\001\157\001\207\000&\001\207\000\168\001\175\000=\001}\001\159\000.\001\201\001\213\001\002\000:\001m\001\155\001\207\001}\000I\000q\000\127\0002\000\250\000q\000\245\000P\001\b\000\229\000\131\001\b\001\213\001=\001\213\001=\001\159\000I\0002\000q\000\250\000\127\0002\000\127\0002\000\127\0002\000\176\000\137\0002\000\245\000\245\001\159\000\219\000\198\000\140\001\149\001=\000\144\000\168\000=\000\188\000\192\000\242\000/\0001\000W\000Y\000]\000_\000\216\000_\001\173\000\245\001\r\000\218\000h\000.\000\196\001\149\001=\000Y\000\175\000\179\000\230\000\181\000\230\000\181\000\236\000\181\000\250\000\181\001\002\000/\001\201\000\245\000\181\001\147\001\167\000h\000\020\000j\000\243\000\243\000.\000Y\001\167\001\171\000`\000\236\000.\000\181\000.\000\238\001\159\000.\000\181\000\181\000\236\000.\000\181\000.\000\134\0002\000k\0002\000\181\000,\000k\000]\000\181\000\213\000,\000\016\000,\000\225\001)\000\246\000k\000\246\000/\000\030\000h\000j\000\238\001\159\001]\000.\000j\000<\000h\001]\000\198\000n\000/\000L\000\016\000h\000\181\000\238\001\159\001M\000\211\000.\000j\000\171\000h\000\020\000\243\000.\000\142\000Y\000\198\000p\000N\000\252\001\149\001=\000\178\001=\000h\000.\001\005\000\238\000h\000.\000\\\000\178\001=\000\141\001{\001y\000\\\000\251\001\001\000\004\000\020\0009\001[\000\198\000>\000\234\001\213\000\031\001\213\000\145\000\226\001\159\000\198\001\159\000;\000Z\000\020\000\251\000\198\001\001\000\\\001\001\001\201\001\015\000\218\000\018\001m\001\023\001m\001\147\000\234\001\001\001\r\000\198\001\015\000\218\000\234\001\015\000!\000\129\001\006\000!\001{\001\001\001\001\000.\001\001\000.\001y\000\\\000\205\001\007\000h\000.\001\007\000.\000\238\001\001\000.\000\205\001\201\001\r\001\147\001\007\000\162\000\134\000\136\000j\000\198\000\138\000j\000\210\000\214\000\140\001\149\001=\000\244\001\149\001=\000\164\001\149\001=\000\180\001\149\001=\000\250\000\181\000\n\000\182\001\149\001=\000Y\000\143\001W\001\131\001\129\000\238\001\207\000\221\000\\\000\180\001\149\001=\000\133\000\250\001#\001#\000\184\001\149\001=\000\181\000\162\000\186\001\149\001=\000\181\000\198\000\252\000-\000/\000[\000\166\000[\000\168\000j\000\212\000h\000\180\001\149\001=\000\133\001\000\001\149\001=\000[\000\218\000h\000K\000[\000\030\000h\000j\000\232\001\159\000\238\001\159\000\232\001\159\000A\000.\000j\000<\000j\000L\000[\000\245\001\r\000\218\000h\000.\000D\000F\000Z\001\149\001=\001\007\000\238\001\001\000.\000^\000`\000n\000Y\000\238\001\159\000\198\000g\000u\000\230\000\245\000[\001\017\001\147\001\167\001\173\001%\000\162\000g\001'\001Q\000\162\000g\001\127\001\133\000&\001\133\000B\001\151\000\230\001\151\001\167\000[\001\215\001\151\000D\001\151\000F\001\151\000H\001\151\000J\001\151\000^\001\151\000`\001\151\000t\001\151\000\150\001\151\000\152\001\151\000\154\001\151\000\156\001\151\000\158\001\151\000\176\001\151\000\198\001\151\000\234\001\151\000\236\001\151\000\248\001\151\001\b\001\151\001\n\001\151\001\201\001\151\000,\000H\001\205\000g\001\151\000g\001\006\001=\000W\000\238\001\159\000\198\000g\000\173\000\198\000g\000\230\000\181\000\236\000\181\000\250\000\181\001\002\000/\001\201\000\175\000\177\000\230\000\181\001S\001U\000\130\001\205\000<\000\181\000\n\000g\000Z\000\020\001\149\001=\001m\000\198\001\001\000\215\000\163\0017\0017\001\149\001=\0000\001\005\000\198\001\007\000\238\001\001\000\198\001\007\001\011\0017\001\006\001=\001\005\001\011\0017\001A\001{\001\011\001A\001\005\001\011\0017\000v\001\205\000\128\001\205\000\160\001\149\001=\001\007\0017\000\194\001\149\001=\000/\000\238\000\135\000:\001m\000\218\001\159\000\167\000\198\000$\000\241\000\241\0017\001\159\000\196\001\149\001=\000\018\000h\000\236\000.\000\134\001\169\000P\000\138\000X\000\249\000j\000\238\000\135\000\218\001\213\000\165\001=\000,\001=\001\213\001_\0004\001a\001_\001c\000y\000&\001\207\001\163\001\207\000\198\000h\001\r\000\218\000h\001\167\001=\0017\000\238\000\135\000\218\001\163\000\\\001\207\001\207\001\163\000\\\001\207\001\207\001w\001=\0017\001\171\000\238\000\020\001\149\001=\000T\0009\000j\000\234\000\134\000\138\001_\0004\000\216\000\250\001\169\001w\001=\000\151\000\250\001u\000\239\000\145\0017\001s\001u\001\159\000\198\000>\000\138\001_\0004\000\216\001\161\001\169\001w\001=\000\138\001_\0004\000\216\001\161\001\161\000?\000\145\0017\000=\000B\000>\000\159\000\147\0017\001u\001s\001u\0009\000j\000\234\000\239\000\145\0017\000?\000\145\0017\000=\000B\000\159\000\147\0017\000*\000N\000\252\001\149\001=\001\015\0017\001\149\001=\001\015\0017\000Z\000\020\001\149\001=\001m\000\234\001\001\0017\001\149\001=\000\018\000\234\001\015\0017\0000\001\005\000\238\001\001\0017\001\006\001=\001\005\000\238\001\001\0017\001?\001?\001\005\000\198\001\r\0017\000\238\001\001\001\t\0017\001{\001\t\000\160\001\149\001=\001\001\0017\000\196\001\149\001=\001\169\000\240\000\020\001\149\001=\000\012\000'\000\134\000{\0002\001\137\000j\000\198\000R\001=\000h\001\159\000.\001\187\000\014\001=\000\012\000X\000X\000\012\000\247\000j\000\238\001\159\0017\000b\001=\000\012\000>\000>\000\012\000\157\000j\000\238\000\167\0017\000\148\001=\000p\000N\000\252\001=\001\r\000\162\000\134\000}\0002\001\175\000\230\001\159\001\159\001\147\001\175\001\183\001\201\001=\001\r\000\162\001\183\001\183\0017\000\226\001=\001\159\000\198\001\159\001\165\0017\0011\000\204\001e\0017\001\139\001\185\0011\001\183\0017\001\006\001=\000'\001\137\000j\000\198\001\183\0017\001C\001C\001\149\001=\000'\001\137\000j\000\238\000j\000\238\000C\000\\\000\134\001\159\000C\000\\\000\207\000C\000\\\001\029\001\147\001\179\001\183\001\179\001\179\001\179\0017\001\006\001=\000'\001\137\000j\000\238\001\179\0017\001E\001E\000)\000a\000e\000\161\000\233\000\253\000\255\001\003\0015\001e\0017\001o\001\006\001=\0009\000j\000?\000\145\0017\001;\001;\001q\001\006\001=\0009\000j\000\234\000\239\000\145\0017\0019\0019\001\139\001\177\0015\000c\0015\001\159\000\240\001\149\001=\000'\001\137\000j\000\198\000R\001=\001\189\000\014\000\252\001=\000\249\000j\000\198\000g\000A\000\198\000g\000+\0017\001=\000\012\000X\000X\000\012\000%\000j\000\238\001\159\000\249\000j\000\198\000g\000A\000\198\000g\000b\000\252\001=\000\159\000j\000\238\000\020\000\243\000\218\001\159\000\198\000g\000\167\000\198\000g\000Q\001\129\000A\000\209\000\198\001\127\001\135\001\131\001\031\0017\001=\000\012\000>\000>\000\012\000#\000j\000\238\000\167\000\159\000j\000\238\000\020\000\243\000\218\001\159\000\198\000g\000\167\000\198\000g\000Q\000\146\001=\000g\0017\000\148\000\252\001=\000h\000p\000H\001\205\001=\000\155\001U\0017\000N\000\252\001=\001\r\000\162\000\134\000}\0002\001\191\000\182\001=\001W\000\\\001O\000\162\001\147\001\181\000\142\000[\000[\000\139\001Y\001Y\001\191\001\199\001\201\001\211\001\199\001\193\001\193\001\199\001=\001\r\000\162\001\199\001=\000\155\001U\0017\001\199\000.\000\238\001\179\000.\001\199\001\002\000j\000\223\0017\001=\001\199\000\223\0017\000\226\001=\001\165\0017\001/\000\204\001e\0017\001\139\001\197\001/\001\199\000\238\001\179\000\198\001\199\001W\001\195\001\195\0017\001\006\001=\000'\001\137\000j\001\195\0017\001G\001G\000)\000M\000p\001\149\001=\000\155\001U\0017\000S\000e\000\161\000\235\000\255\001%\001\211\0013\001Q\001\211\001e\0017\001o\001;\001\139\001\177\000O\000g\0017\0013\000\169\001%\0013\001Q\001\203\0002\000\169\0002\001\203\0002\0017\001\151\000\173\000\198\000g\001I\000\162\000g\001\004\001K\001K\000\252\000g\000.\000~\000\246\000o\000\246\001\151\000,\000o\000\134\0002\000o\0002\000\136\000m\000\172\000\138\000[\000\004\000i\001[\000\209\000\217\000,\000i\000i\000\153\0004\001\r\000\218\000j\000/\000\212\000h\000o\000.\000r\001\151\000\134\000o\0002\000r\001\151\000\138\000o\0004\000r\001\151\000\218\000h\000g\000.\000r\001\151\000\134\000g\0002\000r\001\151\000\138\000g\0004\000r\001\151\001\r\000\212\000h\000o\000.\000r\001\151\000\134\000o\0002\000r\001\151\000\138\000o\0004\000r\001\151\001[\000r\001\151\000\139\001\151\000g\000.\000\134\000g\0002\000\138\000g\0004\001\r\000\212\000h\000o\000.\000\134\000o\0002\000\138\000o\0004\001[\000o\000.\000\134\000o\0002\000\138\000o\0004\000g\000\028\000\208\001\153\000g\000\224\000g\000\220\000g\000\224\000g\000\220\000\198\000g\001\153\000g\000\224\000g\000\220\001\135\000g\000\\\000g\000\\\000\218\000g\001#\000\133\000g\000 \001\151\000\206\001\151\000\204\000g\000\204\000[\001\151\000\174\000[\000\153\0004\001\151\000\217\000,\000m\000\172\000m\000\172\000o\0002\000g\001\149\001=\001\007\000\162\000g\000Z\001\149\001=\001\005\001\011\000\162\000g\000\196\001\149\001=\001\169\001w\001=\000\162\000g\000g\000Q\000g\000\211\000.\000j\000\238\000\020\000\243\000\218\001\159\000\198\000g\000\135\000\218\001\159\000\198\000g\000A\000\198\000g\000Q\001U\0017\001\151\000\246\000o\000\246\000[\000Z\001\149\001=\001\007\000.\000\238\001\001\000.\000g\000.\000A\000.\000g\000\004\000\133\000g\000\004\000\133\001\151\000.\000\232\001\001\000.\000\238\001\001\000.\000\232\001\001\000.\001\007\0017\001\149\001=\001\007\0017\000g\0017\0013\0013\000\169\0002\000\165\001=\000,\001=\000\216\001!\001\207\000,\001!\000\176\001!\000\176\000C\000\\\001}\000w\000.\000\168\001\175\000=\000\230\001\159\001\159\000\230\001\159\000\138\001_\0004\000\216\001\159\001\161\000\239\000=\000B\000\159\000\250\001\169\000\198\001\167\001=\000\149\0017\001u\001\145\001s\001u\001\143\001\145\001\169\000\198\001\167\001=\0009\000j\000=\000B\000\159\000\149\0017\000O\000\204\001\007\001\001\000.\000\167\0017\000c\000\204\001\001\000.\000\181\000.\000\238\001\159\000.\001\189\001/\000\204\000g\000\004\000\133\000g\000\004\000\133\000\190\000g\000\190\000g\000g\000\224\000g\000\220\001\203\0002\001=\000g\000\224\000g\000\220\000O\000\202\001k\000\000\000c\000\202\001g\000\000\000h\000\236\000.\0001\000\203\001\015\000\218\000h\000\236\000.\0001\001m\001\025\001m\001\171\001\209\000\202\000\000\000\201\001\167\000\202\000\000\000\199\001\159\000\202\000\000\000g\000\202\000\197\000\000\000\195\001\015\000\202\000\000\000\193\001\r\000\202\000\000\000\191\001\007\000\202\000\000\000\189\001\001\000\202\000\000\000\187\000\251\000\202\000\000\000\181\000\202\000\185\000\000\000-\000\202\000\183\001\r\000\218\000\000\000\168\001m\000\026\000$\000\144\000\192\000-\001\r\000\202\000E\000G\000*\000M\001-\000g\0017\000*\001-\000*\000\000\000*\000G\000M\001+\001+\000g\0017\001+\001+\0003\000g\0017\001+\000\202\001+\000\202") + (16, "\000\000\000\006\000D\000\004\000\006\000\b\000\n\000\012\000\016\000\018\000\020\000\022\000\024\000\028\000\030\000$\000,\000:\000F\000J\000L\000N\000P\000R\000T\000V\000^\000`\000d\000h\000\132\000\138\000\140\000\152\000\154\000\156\000\170\000\172\000\174\000\176\000\180\000\182\000\184\000\192\000\194\000\196\000\208\000\212\000\214\000\228\000\232\000\244\000\246\000\250\000U\000\206\001\199\001\199\001\145\000|\001\199\000\012\001\145\0019\000b\000\"\000<\000>\000@\000B\000D\000F\000Z\000\\\000f\000l\000\142\000\144\000\146\000\148\000\150\000\158\000\168\000\186\000\200\000b\000(\000\204\001e\000*\000j\000~\001e\000.\000j\000\130\001e\0000\000j\000\222\000\236\000\240\000\248\000\252\000\254\000\231\000*\000d\000/\000\226\000\014\000\016\0004\0006\000\016\000d\001i\0008\000d\000\226\000H\000b\0006\001i\000V\001\145\0019\000\016\000$\0019\000\018\001\145\0019\000<\000B\000\240\000P\000\\\000\240\000b\000\146\000\240\000B\000\\\0005\000\014\0006\001i\0007\000;\000{\000*\000\218\000;\0009\000d\000\186\000\016\000\022\000:\000b\000*\000d\000\226\000d\000l\000d\000\226\000p\001\199\000\014\000\016\000\018\001\145\0019\000P\0009\000d\000?\000\145\000z\001\199\000\020\001\145\0019\000 \000<\000N\001\145\0019\000b\000\014\000B\000\136\000\178\000\\\000\136\000\178\000b\000B\000V\001\145\0019\000\014\000\016\001\005\000*\000\226\000V\000\018\000L\0019\000\014\000\030\0019\000&\0002\000@\000B\000J\000\240\001\145\0019\000b\000\012\0019\000R\001\145\0019\000d\001\r\000\206\000\016\000d\001\019\001\021\001\185\001\195\0019\000Z\000\\\000`\001\145\0019\000b\000<\000v\000d\000j\000f\000v\000~\000.\000\130\001\021\001%\0000\001W\000\226\000r\000\238\000\227\000t\000.\000\227\000~\000\160\001\015\000b\001\015\000*\000\206\000\016\001\027\000\206\000d\001\029\001\169\000\238\000\242\001i\000=\000C\000X\000s\000\"\000\237\001\015\000\206\000b\000\207\000C\000X\001\029\001y\001\137\001\143\001\149\001\151\001\201\000\"\001\201\000\160\001\169\000=\001y\001\153\000*\001\195\001\207\000\246\0006\001i\001\149\001\201\001y\000I\000q\000\127\000.\000\238\000q\000\245\000L\000\252\000\229\000\131\000\252\001\207\0019\001\207\0019\001\153\000I\000.\000q\000\238\000\127\000.\000\127\000.\000\127\000.\000\168\000\137\000.\000\245\000\245\001\153\000\219\000\186\000\132\001\145\0019\000\136\000\160\000=\000\178\000\180\000\230\000/\0001\000W\000Y\000]\000_\000\204\000_\001\167\000\245\001\r\000\206\000b\000*\000\184\001\145\0019\000Y\000\175\000\179\000\218\000\181\000\218\000\181\000\224\000\181\000\238\000\181\000\246\000/\001\195\000\245\000\181\001\143\001\161\000b\000\018\000d\000\243\000\243\000*\000Y\001\161\001\165\000\\\000\224\000*\000\181\000*\000\226\001\153\000*\000\181\000\181\000\224\000*\000\181\000*\000~\000.\000k\000.\000\181\000(\000k\000]\000\181\000\213\000(\000\014\000(\000\225\001%\000\234\000k\000\234\000/\000\026\000b\000d\000\226\001\153\001Y\000*\000d\0008\000b\001Y\000\186\000h\000J\000\240\001\145\0019\000\170\0019\000b\000*\001\005\000\226\000b\000*\000X\000\170\0019\000\141\001w\001u\000X\000\251\001\001\000\004\000\018\0009\001W\000\186\000:\000\222\001\207\000\031\001\207\000\145\000\214\001\153\000\186\001\153\000;\000V\000\018\000\251\000\186\001\001\000X\001\001\001\195\001\015\000\206\000\016\001i\001\023\001i\001\143\000\222\001\001\001\r\000\186\001\015\000\206\000\222\001\015\000!\000\129\000\250\000!\001w\001\001\001\001\000*\001\001\000*\001u\000X\000\205\001\007\000b\000*\001\007\000*\000\226\001\001\000*\000\205\001\195\001\r\001\143\001\007\000\154\000~\000\128\000d\000\186\000\130\000d\000\198\000\202\000\132\001\145\0019\000\232\001\145\0019\000\156\001\145\0019\000\172\001\145\0019\000\238\000\181\000\b\000\174\001\145\0019\000H\000\014\000b\000\181\000\226\001\153\001I\000\211\000*\000d\000\171\000b\000\018\000\243\000*\000\134\000Y\000Y\000\143\001S\001\127\001}\000\226\001\201\000\221\000X\000\172\001\145\0019\000\133\000\218\000\172\001\145\0019\000\133\000\238\001#\001#\000\176\001\145\0019\000\181\000\186\000\240\000-\000/\000[\000\158\000[\000\160\000d\000\200\000b\000\172\001\145\0019\000\133\000(\000\244\001\145\0019\000[\000\206\000b\000K\000\172\001\145\0019\000\133\000[\000\026\000b\000d\000\220\001\153\000\226\001\153\000\220\001\153\000A\000*\000d\0008\000d\000H\000[\000\245\001\r\000\206\000b\000*\000@\000B\000V\001\145\0019\001\007\000\226\001\001\000*\000Z\000\\\000f\000Y\000\226\001\153\000\186\000g\000u\000\218\000\172\001\145\0019\000\133\000\245\000[\001\017\001\143\001\161\001\167\001M\000\154\000g\001{\001\129\000\"\000\172\001\145\0019\000\133\001\129\000>\000\172\001\145\0019\000\133\001\129\000@\000\172\001\145\0019\000\133\001\129\000B\000\172\001\145\0019\000\133\001\129\000D\000\172\001\145\0019\000\133\001\129\000F\000\172\001\145\0019\000\133\001\129\000Z\000\172\001\145\0019\000\133\001\129\000\\\000\172\001\145\0019\000\133\001\129\000l\000\172\001\145\0019\000\133\001\129\000\142\000\172\001\145\0019\000\133\001\129\000\144\000\172\001\145\0019\000\133\001\129\000\146\000\172\001\145\0019\000\133\001\129\000\148\000\172\001\145\0019\000\133\001\129\000\150\000\172\001\145\0019\000\133\001\129\000\168\000\172\001\145\0019\000\133\001\129\000\186\000\172\001\145\0019\000\133\001\129\000\218\000\172\001\145\0019\000\133\001\129\000\222\000\172\001\145\0019\000\133\001\129\000\224\000\172\001\145\0019\000\133\001\129\000\236\000\172\001\145\0019\000\133\001\129\000\252\000\172\001\145\0019\000\133\001\129\000\254\000\172\001\145\0019\000\133\001\129\001\195\001\161\000[\001\209\000\172\001\145\0019\000\133\001\129\000(\000D\001\199\000g\000g\000\250\0019\000/\000\186\000g\000\226\000\018\000\243\000\206\001\153\000\186\000g\000\135\0006\001i\000\206\001\153\000\186\000g\000A\000\186\000g\000Q\001}\000A\000\209\000\186\001{\001\131\001\127\000W\000\226\001\153\000\186\000g\000\173\000\186\000g\000\218\000\181\000\224\000\181\000\238\000\181\000\246\000/\001\195\000\175\000\177\000\218\000\181\001O\001Q\000\163\0013\0013\001\205\001\129\000\173\000\186\000g\001E\000\154\000g\000\248\001G\001G\000\240\000g\000*\000v\000\234\000o\000\234\001\129\000(\000o\000~\000.\000o\000.\000\128\000m\000\164\000\130\000[\000\004\000i\001W\000\209\000\217\000(\000i\000i\000\153\0000\001\r\000\206\000d\000/\000\134\000[\000\200\000b\000o\000*\000j\000\172\001\145\0019\000\133\001\129\000~\000o\000.\000j\000\172\001\145\0019\000\133\001\129\000\130\000o\0000\000j\000\172\001\145\0019\000\133\001\129\000\206\000b\000g\000*\000j\000\172\001\145\0019\000\133\001\129\000~\000g\000.\000j\000\172\001\145\0019\000\133\001\129\000\130\000g\0000\000j\000\172\001\145\0019\000\133\001\129\001\r\000\200\000b\000o\000*\000j\000\172\001\145\0019\000\133\001\129\000~\000o\000.\000j\000\172\001\145\0019\000\133\001\129\000\130\000o\0000\000j\000\172\001\145\0019\000\133\001\129\001W\000j\000\172\001\145\0019\000\133\001\129\000[\000\139\001U\001U\001\129\000g\000*\000~\000g\000.\000\130\000g\0000\001\r\000\200\000b\000o\000*\000~\000o\000.\000\130\000o\0000\001W\000o\000o\000*\000~\000o\000.\000\130\000o\0000\000g\000\024\000\196\001\147\000g\000\212\000g\000\208\001\129\001\131\000g\000X\000g\000X\000\206\000g\001#\000\133\000g\000\028\000\172\001\145\0019\000\133\000\194\000\172\001\145\0019\000\133\001\129\001\129\000\194\000\172\001\145\0019\000\133\001\129\000\192\000g\000\192\000[\000\172\001\145\0019\000\133\000\166\001\129\000\166\000[\000\153\0000\000\172\001\145\0019\000\133\001\129\000\217\000(\000m\000\164\000m\000\164\000o\000.\000g\001\145\0019\001\007\000\154\000g\000V\001\145\0019\001\005\000\186\001\007\000\226\001\001\000\186\001\007\001\011\000\154\000g\001w\001\011\000\184\001\145\0019\000\016\000b\000\224\000*\000~\001\163\000L\000\130\000T\000\249\000d\000\226\000\135\000\206\001\207\000\165\0019\000(\0019\001\207\001[\0000\001]\001[\001_\000y\000\"\001\201\001\157\001\201\000\226\000\135\000\206\001\157\000X\001\201\001\201\001\157\000X\001\201\001\201\001s\0019\000\154\000g\001\165\001\145\0019\000,\000\155\001Q\0013\000g\000\211\000*\000d\000Q\000\172\001\145\0019\000\133\001\129\000\234\000o\000\234\000[\000V\001\145\0019\001\007\000*\000\226\001\001\000*\000g\000*\000A\000*\000g\000\004\000\133\000\172\001\145\0019\000\133\000*\000\220\001\001\000*\000\226\001\001\000*\000\220\001\001\000*\001\129\000*\000\220\001\001\000*\000\226\001\001\000*\000\220\001\001\000*\001\007\0013\001\145\0019\001\007\0013\000V\000\018\001\145\0019\001i\000\186\001\001\000\215\0013\001\145\0019\000,\001\005\001\011\0013\000\250\0019\001\005\001\011\0013\001=\001=\001\005\001\011\0013\000n\001\199\0008\000\181\000\b\000g\000x\001\199\000\152\001\145\0019\001\007\0013\000\182\001\145\0019\000/\000\226\000\135\000\206\001\153\000\167\000\186\000 \000\241\000\241\0013\001\153\000\184\001\145\0019\001\163\000\186\000b\001\r\000\206\000b\001\161\0019\0013\001s\0019\0013\000\226\000&\000J\000\240\001\145\0019\001\015\0013\001\145\0019\001\015\0013\000V\000\018\001\145\0019\001i\000\222\001\001\0013\001\145\0019\000\016\000\222\001\015\0013\000,\001\005\000\226\001\001\0013\000\250\0019\001\005\000\226\001\001\0013\001;\001;\001\005\000\186\001\r\0013\000\226\001\001\001\t\0013\001w\001\t\000\152\001\145\0019\001\001\0013\000\184\001\145\0019\001\163\000\228\000\018\001\145\0019\000\n\000'\000~\000{\000.\001\133\000d\000\186\000N\0019\000b\001\153\000*\001\181\000\012\0019\000\n\000T\000T\000\n\000\247\000d\000\226\001\153\0013\000^\0019\000\n\000:\000:\000\n\000\157\000d\000\226\000\167\0013\000\140\0019\000h\000J\000\240\0019\001\r\000\154\000~\000}\000.\001\169\000\218\001\153\001\153\001\143\001\169\001\177\001\195\0019\001\r\000\154\001\177\001\177\0013\000\214\0019\001\153\000\186\001\153\001\159\0013\001-\000\192\001a\0013\001\135\001\179\001-\001\177\0013\000\250\0019\000'\001\133\000d\000\186\001\177\0013\001?\001?\001\145\0019\000'\001\133\000d\000\226\000d\000\226\000C\000X\000~\001\153\000C\000X\000\207\000C\000X\001\029\001\143\001\173\001\177\001\173\001\173\001\173\0013\000\250\0019\000'\001\133\000d\000\226\001\173\0013\001A\001A\000)\000a\000e\000\161\000\233\000\253\000\255\001\003\0011\001a\0013\001k\000\250\0019\0009\000d\000?\000\145\0013\0017\0017\001m\000\250\0019\0009\000d\000\222\000~\000\130\001[\0000\000\204\000\238\001\163\001s\0019\000\151\000\238\001q\000\239\000\145\0013\0015\001o\001q\001\153\000\186\000:\000\130\001[\0000\000\204\001\155\001\163\001s\0019\000\130\001[\0000\000\204\001\155\001\155\0015\001\135\001\171\0011\000c\0011\001\153\000\228\001\145\0019\000'\001\133\000d\000\186\000N\0019\001\183\000\012\000\240\0019\000\249\000d\000\186\000g\000A\000\186\000g\000+\0013\0019\000\n\000T\000T\000\n\000%\000d\000\226\001\153\000\249\000d\000\186\000g\000A\000\186\000g\000^\000\240\0019\000:\000\159\000d\000\226\000\018\000\243\000\206\001\153\000\186\000g\000\167\000\186\000g\000Q\001\031\0013\0019\000\n\000:\000:\000\n\000#\000d\000\226\000\167\000\159\000d\000\226\000\018\000\243\000\206\001\153\000\186\000g\000\167\000\186\000g\000Q\000\138\0019\000g\0013\000\140\000\240\0019\000b\000h\000D\001\199\0019\000\155\001Q\0013\000J\000\240\0019\001\r\000\154\000~\000}\000.\001\185\000\174\0019\001S\000X\001K\000\154\001\143\001\175\000\139\001\185\001\193\001\195\001\205\001\193\001\187\001\187\001\193\0019\001\r\000\154\001\193\0019\000\155\001Q\0013\001\193\000*\000\226\001\173\000*\001\193\000\246\000d\000\223\0013\0019\001\193\000\223\0013\000\214\0019\001\159\0013\001+\000\192\001a\0013\001\135\001\191\001+\001\193\000\226\001\173\000\186\001\193\001S\001\189\001\189\0013\000\250\0019\000'\001\133\000d\001\189\0013\001C\001C\000)\000M\000h\000S\000e\000\161\000\235\000\255\001/\001M\001a\0013\001k\0017\001\135\001\171\000O\000g\0013\001/\000\169\001/\001M\001\197\000.\000\169\000.\000g\0013\001/\001/\000O\000\192\001\007\001\001\000*\000\181\000*\000\226\001\153\000*\001\183\001+\000\192\000g\000\004\000\133\001\197\000.\0013\000=\000>\000\159\000\238\001\163\000\186\001\161\0019\000\149\0013\001q\001\141\001o\001q\001\139\001\141\001\163\000\186\001\161\0019\0009\000d\000?\000\145\0013\000=\000>\000\159\000\149\0013\000\169\000.\000\165\0019\000(\0019\000\204\001!\001\201\000(\001!\000\168\001!\000\168\000C\000X\001y\000w\000*\000\160\001\169\000=\000\218\001\153\001\153\000\218\001\153\000\130\001[\0000\000\204\001\153\001\155\000\239\000\222\000\239\000\145\0013\000=\000>\000\159\000\147\0013\001q\001o\001q\0009\000d\000\222\000\239\000\145\0013\000=\000>\000\159\000\147\0013\000c\000\192\001\001\000*\000\167\0013\001\197\000.\0019\000g\000\212\000g\000\208\000O\000\190\001g\000\000\000c\000\190\001c\000\000\000b\000\224\000*\0001\000\203\001\015\000\206\000b\000\224\000*\0001\001i\001\025\001i\001\165\001\203\000\190\000\000\000\201\001\161\000\190\000\000\000\199\001\153\000\190\000\000\000g\000\190\000\197\000\000\000\195\001\015\000\190\000\000\000\193\001\r\000\190\000\000\000\191\001\007\000\190\000\000\000\189\001\001\000\190\000\000\000\187\000\251\000\190\000\000\000\181\000\190\000\185\000\000\000-\000\190\000\183\001\r\000\206\000\000\000\160\001i\000\022\000 \000\136\000\180\000-\001\r\000\190\000E\000G\000&\000M\001)\000g\0013\000&\001)\000&\000\000\000&\000G\000M\001'\001'\000g\0013\001'\001'\0003\000g\0013\001'\000\190\001'\000\190") and rhs = - ((16, "\001k\001g\000\203\000\201\000\199\000\197\000\195\000\193\000\191\000\189\000\187\000\185\000\183\000E\0003\000F\000D\001}\001\213\001\002\000:\001m\001\006\001=\001U\0017\001\025\001\171\001\157\000=\001\207\000=\000h\000w\000.\000=\000\168\001\175\001\207\000\168\001\175\000h\000w\000.\000\168\001\175\001\015\000\218\001\155\000:\001m\000\016\000U\000U\000\218\001\205\000\169\000\132\001\205\001\203\0002\001\181\000\182\001=\001\193\001O\000\162\001\199\000p\000N\001=\001\r\000\162\001\199\000p\000N\000\252\001=\001\r\000\162\001\199\001\199\001\201\001\181\000\139\001\147\000\148\001=\001\199\000\223\0017\000\148\000\252\001=\001\199\000\223\0017\000\014\000+\0017\000b\001\031\0017\000\226\001=\001\165\0017\000\146\001=\000g\0017\001e\0017\001\139\000\198\001\199\000\238\001\179\000\198\001\199\001W\001\195\001W\000\\\001\199\001W\001\193\001\021\000h\000\181\000.\000h\000\181\000\238\001\159\000.\000h\001\159\000.\000\148\001=\001\183\0017\000\014\001=\000\247\000j\000\238\001\159\0017\000b\001=\000\157\000j\000\238\000\167\0017\000\226\001=\001\165\0017\001e\0017\001\139\001\175\000\134\000}\0002\001\175\001\147\000R\001=\001\187\0011\000\204\001\183\001\201\000p\000N\001=\001\r\000\162\001\183\000p\000N\000\252\001=\001\r\000\162\001\183\000h\001\199\000.\001\191\000\134\000}\0002\001\191\000h\001\199\000\238\001\179\000.\000R\001=\001\189\001/\000\204\001\183\000\207\000C\000\\\001\179\000j\000\238\000C\000\\\001\179\000C\000\\\001\179\000\240\000\020\001\149\001=\000'\001\137\000j\000\198\001\183\0017\001C\001\029\000\144\000\242\000$\000\188\000\134\0002\000h\000.\000\192\000\026\000\018\000h\000\236\000.\001\171\001\r\001\r\000\218\000h\000\236\000.\000h\000\236\000.\001\171\001\159\000\198\001\159\001\207\000y\000&\001\207\000\138\001_\0004\000\250\000\151\001\213\001\159\001\201\000\237\001\141\001\155\000h\001\159\000.\000h\000Z\001\149\001=\001\001\000.\000\134\000I\0002\000\134\000\250\000\127\0002\000\134\000q\000\250\000\127\0002\000|\000\227\000\127\0002\000|\0002\000z\000\227\000\127\0002\000z\000\227\000\127\000\176\000\137\0002\000\028\000\208\001%\000\162\000g\000d\001\149\001=\000g\000\004\000\133\000\022\001\149\001=\000g\000\022\001\149\001=\000g\000\004\000\133\000\022\001\149\001=\000g\000\190\000g\000\022\001\149\001=\000g\000\004\000\133\000\190\000g\000\006\001\149\001=\000g\000\224\000g\000\220\000\184\001\149\001=\000\181\000\198\000g\001\153\000g\000\224\000g\000\220\000\184\001\149\001=\000\181\000\162\000g\000\224\000g\000\220\001\133\000\180\001\149\001=\000\133\000H\001\205\000x\001\205\000\169\0002\0008\000\250\001\169\000\198\001\167\001=\001\169\000\198\001\167\001=\001\147\000\128\001\205\001\203\0002\000\134\000{\0002\000\180\001\149\001=\000\133\001\127\000[\000p\000Z\001\149\001=\001\005\001\011\000\162\000g\000p\000\196\001\149\001=\001\169\001w\001=\000\162\000g\000p\000N\001\149\001=\001\007\000\162\000g\000p\000N\000\252\001\149\001=\001\007\000\162\000g\000\182\001\149\001=\001\129\000\221\000\\\001\135\000f\001\149\001=\000g\000\004\000\133\000\024\001\149\001=\000g\000\004\000\133\000\164\001\149\001=\000g\000 \001\151\000\206\001\151\000\164\001\149\001=\000g\000 \001\151\000\b\001\149\001=\000g\000\224\000g\000\220\000\186\001\149\001=\000\181\000\198\000g\001\153\000g\000\224\000g\000\220\001\000\001\149\001=\000[\000\140\001\149\001=\000[\000[\000\139\000u\001\167\000[\000\245\000[\001\133\000\158\001\151\001\133\000\156\001\151\001\133\000\154\001\151\001\133\000\152\001\151\001\133\000\150\001\151\001\133\000F\001\151\001\133\000D\001\151\001\133\000B\001\151\001\133\000`\001\151\001\133\000^\001\151\001\133\000&\001\151\001\133\000H\001\151\001\133\000\198\001\151\001\133\000t\001\151\001\133\000\176\001\151\001\133\000J\001\151\001\133\000\248\001\151\001\133\001\b\001\151\001\133\001\n\001\151\001\133\000\234\001\151\000K\001\151\001\215\001\151\001Q\000\162\000g\000n\001I\000\162\000g\001\133\000\236\001\151\000j\000r\001\151\000[\000\218\001[\000r\001\151\000[\000\218\000h\000g\000.\000r\001\151\000[\000\218\000\138\000g\0004\000r\001\151\000[\000\218\000\134\000g\0002\000r\001\151\000[\000\212\000h\000o\000.\000r\001\151\000[\000\218\001\r\000\212\000h\000o\000.\000r\001\151\000[\000\212\000\138\000o\0004\000r\001\151\000[\000\218\001\r\000\212\000\138\000o\0004\000r\001\151\000[\000\212\000\134\000o\0002\000r\001\151\000[\000\218\001\r\000\212\000\134\000o\0002\000r\001\151\001\133\001\201\000h\000\020\000\243\000.\001W\000\143\001\133\001\133\000,\001\133\000,\000g\001\133\000,\000H\001\205\000g\000C\000\207\000C\000\\\001}\000j\000\238\000C\000\\\001}\000C\000\\\001}\000h\000.\000h\001\005\000\238\001\001\000.\000\141\000P\001\163\000\238\001\163\000\\\001\207\000\238\000\135\000\218\001\163\000\\\001\207\000\238\001\207\000\238\000\135\000\218\001\207\000\250\001\169\001w\001=\001\169\001w\001=\000\020\001\149\001=\0009\000j\000\234\000\239\000\145\0017\000\020\001\149\001=\000T\0009\000j\000\234\000\239\000\145\0017\000\020\001\149\001=\0009\000j\000?\000\145\0017\000\020\001\149\001=\000T\0009\000j\000?\000\145\0017\000\018\000j\000O\000\202\000,\000\216\000c\000\202\000v\001\205\000\169\0002\0006\000\249\000j\000\238\000\165\001=\000\249\000j\000\238\000\165\001=\000,\001=\001c\001a\001a\001_\000j\000j\000\238\001\159\001\021\000[\000\142\000[\000\030\000j\000\030\000h\000j\000A\000.\000<\000j\000L\000[\000<\000h\001]\000\211\000.\000<\000j\000L\000h\001M\000\211\000.\000L\000\171\000\030\000h\001]\000.\000\030\000j\000\142\000Y\000Y\001S\000/\000/\000Q\000/\000A\000\198\000g\000/\000\238\000\135\000\218\001\159\000\198\000g\000/\000\238\000\020\000\243\000\218\001\159\000\198\000g\000\173\000\198\000g\000W\000\238\001\159\000\198\000g\000p\001\149\001=\000\155\001U\0017\001Q\001\211\000p\001=\000\155\001U\0017\000p\000H\001\205\001=\000\155\001U\0017\001O\001\211\000\181\000\181\000\238\001\159\000/\000Q\000/\000Y\000\238\001\159\000\198\000g\000\173\000\198\000g\001K\001I\001\004\001K\001\006\001=\000'\001\137\000j\001\195\0017\001G\001\006\001=\000'\001\137\000j\000\238\001\179\0017\001E\001\006\001=\000'\001\137\000j\000\198\001\183\0017\001C\001\006\001=\001\005\001\011\0017\001A\001\006\001=\001\005\000\238\001\001\0017\001?\001\201\001=\001\006\001=\0009\000j\000?\000\145\0017\001;\001\006\001=\0009\000j\000\234\000\239\000\145\0017\0019\000\163\0017\000*\0015\000a\0015\000*\0013\000*\000g\0017\0013\000M\0013\001\185\0011\001\197\001/\000M\001-\000*\001+\000*\000g\0017\001+\000M\001+\000G\001+\001[\000\219\000\213\001[\000\219\000\213\000,\001[\000\219\000\213\000,\000\016\000\225\001[\000\219\000\213\000,\001)\000l\001\149\001=\000\155\001U\0017\001'\001%\001\211\000\181\000\\\000g\000\181\000\n\000g\000\\\000g\000\181\000\\\000\218\000j\000\238\000\165\001=\000,\001=\001!\001\207\000,\001!\000j\000\238\000\165\001=\000,\001=\001\207\000,\000j\000\238\000\165\001=\001\207\000\216\001=\000#\000j\000\238\000\167\001=\000\159\000j\000Q\000\252\001=\000\159\000j\000Q\001=\000\159\000j\000\238\000\167\000\198\000g\000\252\001=\000\159\000j\000\238\000\167\000\198\000g\001=\000\159\000j\000\238\000\020\000\243\000\218\001\159\000\198\000g\000\252\001=\000\159\000j\000\238\000\020\000\243\000\218\001\159\000\198\000g\000j\001\015\000\218\000j\000\018\001\015\000\218\000\018\001m\000h\000\236\000.\0001\001\015\000\218\001m\001\015\000\218\000h\000\236\000.\001\015\000\218\0001\001m\001\015\000\218\001m\000j\001\r\000\218\000j\000\018\001\r\000\218\000\018\000/\001\r\000\218\000/\001\027\001\015\000h\001\015\000.\001\019\000\198\001\007\000\238\001\001\000\198\001\007\001{\001\011\000\238\001\001\001{\001\t\000\"\001=\000O\000\204\000\178\001=\001y\000\\\001\007\000\205\001\007\001\201\001\r\001\007\000\205\001\007\000h\000.\001\147\000\016\000\018\000\016\000Z\001\149\001=\000\018\000\234\001\015\0017\000(\001=\000c\000\204\000\178\001=\001y\000\\\001\001\000Z\000\020\000P\001=\001\007\000h\001\001\000.\001\001\001\201\000\251\000h\000.\000\\\001\001\001\001\000\\\001\001\001\001\000\004\000\129\001\147\000Z\000\020\001\149\001=\001m\000\215\0017\000Z\000\020\001\149\001=\001m\000\234\001\001\0017\001\023\000X\000X\000\012\000X\000\012\000\012\000X\000\254\001m\000j\000j\000\243\000$\000$\000\241\001\159\000>\001\159\001\161\000>\001\161\001\159\000\198\001\161\001\159\000\198\000>\001\161\000\216\000>\000\216\001\159\000\198\000\216\001\159\000\198\000>\000\216\000\138\001_\0004\000>\000\138\001_\0004\001\159\000\198\000\138\001_\0004\001\159\000\198\000>\000\138\001_\0004\000t\001!\000\176\000t\000\176\000N\001\149\001=\001\007\0017\000N\000\252\001\149\001=\001\007\0017\000N\001\149\001=\001\015\0017\000N\000\252\001\149\001=\001\015\0017\000@\000n\001\004\000\212\000h\001i\000.\000\212\000h\001i\000.\000r\000\212\000\134\001i\0002\000\212\000\134\001i\0002\000r\000\212\000\138\001i\0004\000\212\000\138\001i\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\207\000\238\001\159\000\198\001\151\000\198\001\001\000\198\000\181\000\198\000g\000A\000L\000<\000j\000\238\000h\001\007\000\238\001\001\000.\000h\001\007\000.\000h\000\014\001=\001\151\000.\000h\000\014\001=\001\151\000\238\001\001\000.\000h\000\014\001=\001\151\000\238\001\001\000\232\001\001\000.\000h\000\014\001=\001\151\000\232\001\001\000.\001\209\000\202\001\167\000\202\001\159\000\202\000g\000\202\001\015\000\202\001\r\000\202\001\007\000\202\001\001\000\202\000\251\000\202\000\181\000\202\000-\000\202\000\181\000\236\000\181\000\181\001\201\000\175\000\181\001\002\000/\000\179\000\181\000\250\000\181\000\196\001\149\001=\000\181\000\179\000\230\000\181\000\181\000\230\000\181\000\177\000\230\000\181\000\173\000\230\000\181\000Y\001\167\000\181\001\167\000h\000\020\000\243\000.\000Y\000\245\000\181\000\140\001\149\001=\000Y\000\173\000\236\000\181\000\173\001\201\000\175\000\173\001\002\000/\000\177\000\173\000\250\000\181\000j\000\016\000O\000\238\000c\000\238\001\159\000<\000\181\000<\000\181\000\n\000g\001\159\000\135\000\218\001\159\001\213\000\135\000\218\001\213\000\130\001\205\001\203\0002\000\194\001\149\001=\000/\000\238\000\167\000\198\000\241\0017\000>\000>\000\012\000>\000\012\000\012\000>\0000\000i\000[\000\004\000i\001s\001u\000\151\001u\001s\001\143\001u\001\145\000\149\001u\000\149\001\145\001s\001u\000\147\001u\000\145\000\226\001\159\000\198\001\159\001\131\000\143\001\131\001{\000\141\001{\001Y\000\139\001Y\000\245\000\137\000\245\000:\001m\000\135\000:\001m\001#\000\250\001#\000\133\000\250\001#\001\213\000\131\001\b\001\213\000!\000\129\001\006\000!\000q\000\127\000\250\000q\001\159\000}\000\230\001\159\000;\000{\000\230\000;\001\207\000y\000&\001\207\000w\000\230\001\159\001\159\000\230\001\159\000u\000\230\001\151\001\151\000\230\001\151\000s\000&\001\207\001\207\000&\001\207\000I\001\159\001\151\001\151\000,\001\151\000,\000o\000j\000\217\000j\000\217\000,\000j\000\217\000,\000m\000\181\000\181\000,\000\181\000,\000k\001[\000\209\000\217\001[\000\209\000\217\000,\001[\000\209\000\217\000,\000i\001\127\000\180\001\149\001=\000\133\000\196\001\149\001=\001\169\001w\001=\0017\0015\001e\0017\001\139\000)\000\161\001o\001;\001q\0019\000\020\001\149\001=\0009\000=\000B\000\159\000\147\0017\000\020\001\149\001=\000T\0009\000=\000B\000\159\000\147\0017\000e\000Z\001\149\001=\001\005\001\t\0017\000Z\001\149\001=\001\005\000\198\001\r\0017\001\003\000Z\001\149\001=\0000\001\005\000\238\001\001\0017\001?\000\255\000\253\000\233\000\160\001\149\001=\001\001\0017\000\240\001\149\001=\000'\001\137\000j\000\238\001\179\0017\001E\001\177\001\173\000`\000\144\000`\000\188\000F\000\144\000F\000\188\000\138\001)\0004\000\134\000k\0002\000~\000k\000\246\000~\000\246\000\214\001\151\000\174\000\210\000[\000h\000g\000.\000h\000g\000A\000.\000[\000\218\000h\000g\000.\000[\000\218\000\138\000g\0004\000[\000\218\000\134\000g\0002\000[\000\212\000h\000o\000.\000[\000\218\001\r\000\212\000h\000o\000.\000[\000\212\000\138\000o\0004\000[\000\218\001\r\000\212\000\138\000o\0004\000[\000\212\000\134\000o\0002\000[\000\218\001\r\000\212\000\134\000o\0002\000\244\001\149\001=\000g\000\204\000\244\001\149\001=\000\204\000V\001\149\001=\001\191\000h\000Z\001\149\001=\001\007\000.\000h\000Z\001\149\001=\001\007\000\238\001\001\000.\000R\001\149\001=\001\189\001/\000\204\000-\001\173\001\167\000\245\000@\000[\000\252\000[\000\136\000m\000\172\000\136\000\172\000[\000\218\001[\001\r\000\218\000h\000g\000.\001\r\000\218\000\136\000m\000\172\000[\000\168\000j\000[\000\166\000[\001\147\000\016\001\r\000\218\000h\000.\000\138\000\153\0004\001\r\000\218\000\138\000\153\0004\000~\000o\000\246\000~\000\246\001\r\000\218\000~\000o\000\246\001\r\000\218\000~\000\246\000\134\000o\0002\001\r\000\218\000\134\000o\0002\001\r\000\218\000\134\0002\001\r\000\218\000h\000Z\001\149\001=\001\007\000\238\001\001\000.\000/\000W\000h\000\181\000.\000]\000h\000Z\001\149\001=\001\005\000.\000h\000Z\001\149\001=\001\005\000\238\001\001\000.\000\016\000_\000_\000\216\000_\001\167\000\245\000\168\000=\001\r\000\218\000]\001\r\000\218\000\134\0002\001\r\000\218\000h\000.\001\r\000\218\000h\000\181\000.\000h\000\181\000\238\001\159\000.\001\147\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\000e\000\196\001\149\001=\001\169\000\198\001\167\001=\0017\000\198\000g\001\129\000\209\000\198\001\135\0013\000g\0017\0013\001%\001Q\001e\0017\001\139\000\161\000)\001o\001;\000\020\001\149\001=\0009\000=\000B\000\159\000\149\0017\000\020\001\149\001=\000T\0009\000=\000B\000\159\000\149\0017\000S\000Z\001\149\001=\001\005\001\011\0017\000Z\001\149\001=\0000\001\005\001\011\0017\001A\000\255\000\235\000\240\001\149\001=\000'\001\137\000j\001\195\0017\001G\001\177\000\160\001\149\001=\001\007\0017\000`\000^\000\245\000P\000\229\000\131\001=\000\245\001=\000\168\001m\000\168\001m\000$\000\168\001m\000\144\000\168\001m\000-\000\168\001m\001\r\000\168\001m\000\192\000\168\001m\000\026\000g\0017\000*\001-\000*\000G\000*\000\202\001\207\000s\000\238\001\159\000\238\001\159\000\232\001\159\000\232\001\159\000\198\000\239\001\029\0005\0007\000;\000h\000{\000.\000:\001m\000\016\000F\000`\000\252\000F\000\252\000\252\000F\000`\000\252\000\252\000`\000\154\000@\001+\000\202\000g\0017\001+\000\202\000h\000\231\000.\000j\0001\001\017\001=\000%\000j\000\238\001\159\001=\000\249\000j\000\198\000g\000\252\001=\000\249\000j\000\198\000g\001=\000\249\000j\000A\000\198\000g\000\252\001=\000\249\000j\000A\000\198\000g\000\014\001\149\001=\000/\000\238\000\167\0017\000\012\000\012\000X\000\012\000\012\000X\000\012\000>\000\012\000\012\000>\000\020\0009\001[\000\031\001\213\000\145\000\020\0009\001[\000\234\001\213\000Z\001\r\000\198\001\015\000Z\001\r\000\234\001\015\000Z\000\020\000\251\000\198\001\001\000Z\000\020\000\251\000\234\001\001\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\017\000\018\000\022\000\026\000\027\000\028\000\029\000\030\000 \000$\000&\000)\000.\0001\0003\0004\0005\0008\0009\000=\000>\000A\000D\000J\000Q\000S\000U\000V\000[\000a\000d\000g\000k\000o\000q\000r\000t\000x\000z\000}\000\127\000\128\000\131\000\136\000\136\000\139\000\139\000\143\000\150\000\157\000\161\000\163\000\164\000\165\000\169\000\170\000\175\000\177\000\183\000\190\000\193\000\194\000\198\000\203\000\208\000\209\000\213\000\218\000\221\000\232\000\233\000\234\000\235\000\236\000\237\000\239\000\241\000\242\000\243\000\244\000\247\000\248\000\249\000\254\001\001\001\002\001\005\001\006\001\t\001\012\001\r\001\014\001\015\001\017\001\018\001\019\001\020\001\023\001\029\001 \001$\001)\001-\001/\0013\0019\001:\001;\001>\001D\001H\001N\001T\001\\\001c\001n\001w\001x\001|\001|\001~\001\130\001\131\001\136\001\140\001\141\001\145\001\145\001\148\001\152\001\153\001\154\001\162\001\171\001\178\001\186\001\193\001\199\001\205\001\213\001\219\001\226\001\237\001\241\001\245\001\247\001\248\001\250\001\252\001\255\002\002\002\005\002\b\002\011\002\014\002\017\002\020\002\023\002\026\002\029\002 \002#\002&\002)\002,\002/\0022\0025\0028\002:\002<\002?\002C\002F\002I\002N\002U\002\\\002c\002j\002s\002z\002\131\002\138\002\147\002\149\002\153\002\154\002\155\002\156\002\158\002\161\002\166\002\167\002\171\002\176\002\179\002\181\002\186\002\187\002\187\002\189\002\193\002\199\002\201\002\205\002\209\002\212\002\221\002\231\002\239\002\248\002\249\002\250\002\252\002\252\002\254\003\000\003\004\003\005\003\n\003\017\003\018\003\019\003\021\003\022\003\025\003\026\003\027\003\029\003\031\003$\003&\003(\003-\003/\0034\0036\003:\003<\003>\003?\003@\003A\003C\003G\003N\003V\003Y\003^\003d\003f\003k\003r\003t\003u\003x\003z\003{\003\128\003\131\003\132\003\135\003\135\003\143\003\143\003\152\003\152\003\161\003\161\003\167\003\167\003\174\003\174\003\176\003\176\003\184\003\184\003\193\003\193\003\195\003\195\003\197\003\199\003\199\003\201\003\205\003\207\003\207\003\209\003\209\003\211\003\211\003\213\003\213\003\215\003\219\003\221\003\223\003\226\003\230\003\236\003\241\003\247\003\248\003\250\003\253\004\002\004\005\004\012\004\015\004\021\004\023\004\027\004\028\004\029\004\"\004&\004+\0042\004:\004D\004O\004P\004S\004T\004W\004X\004[\004\\\004_\004d\004g\004h\004k\004l\004o\004p\004s\004t\004w\004x\004|\004}\004\127\004\131\004\133\004\135\004\137\004\141\004\146\004\147\004\149\004\150\004\152\004\155\004\156\004\157\004\158\004\159\004\166\004\170\004\175\004\180\004\183\004\185\004\186\004\190\004\193\004\196\004\197\004\204\004\212\004\213\004\213\004\214\004\214\004\215\004\216\004\218\004\220\004\222\004\223\004\225\004\226\004\228\004\229\004\231\004\232\004\234\004\237\004\241\004\242\004\244\004\247\004\251\004\254\005\002\005\007\005\r\005\016\005\018\005\023\005\029\005\"\005(\005)\005*\005+\005/\0054\0058\005=\005A\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^\005^\005_\005_\005a\005a\005c\005c\005e\005e\005g\005g\005i\005i\005k\005k\005m\005m\005n\005o\005r\005w\005z\005\127\005\134\005\143\005\150\005\152\005\154\005\156\005\158\005\160\005\162\005\164\005\166\005\168\005\170\005\172\005\175\005\177\005\178\005\181\005\182\005\185\005\189\005\192\005\195\005\198\005\201\005\202\005\204\005\210\005\212\005\216\005\219\005\221\005\222\005\225\005\226\005\229\005\230\005\231\005\232\005\234\005\236\005\238\005\242\005\243\005\246\005\247\005\250\005\254\006\007\006\007\006\b\006\b\006\t\006\n\006\012\006\014\006\014\006\015\006\016\006\019\006\020\006\021\006\023\006\024\006\025\006\026\006\027\006\029\006\031\006 \006!\006#\006#\006(\006)\006+\006,\006.\006/\0061\0062\0064\0066\0069\006:\006<\006?\006@\006C\006D\006G\006H\006K\006L\006O\006P\006S\006T\006W\006Z\006]\006`\006c\006f\006i\006j\006k\006l\006n\006q\006s\006v\006z\006{\006}\006\128\006\131\006\135\006\140\006\141\006\145\006\152\006\153\006\155\006\156\006\157\006\158\006\160\006\162\006\171\006\181\006\182\006\188\006\195\006\196\006\205\006\206\006\207\006\208\006\213\006\223\006\224\006\225\006\227\006\229\006\231\006\233\006\236\006\239\006\242\006\244\006\247\006\249\006\252\007\000\007\005\007\n\007\015\007\020\007\027\007 \007'\007,\0073\0078\007<\007@\007F\007N\007T\007U\007V\007W\007X\007Z\007\\\007_\007a\007d\007i\007n\007q\007t\007u\007v\007z\007}\007\130\007\133\007\135\007\140\007\144\007\147\007\152\007\156\007\166\007\167\007\168\007\171\007\172\007\178\007\186\007\187\007\188\007\191\007\192\007\193\007\195\007\198\007\202\007\206\007\211\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\238\007\239\007\240\007\241\007\242\007\243\007\244\007\245\007\246\007\247\007\248\007\249\007\250\007\251\007\252\007\253\007\254\007\255\b\000\b\001\b\002\b\003\b\004\b\005\b\006\b\007\b\b\b\t\b\n\b\011\b\012\b\r\b\021\b\023\b\027\b\028\b\031\b \b!\b#\b$\b%\b&\b(\b1\b;\b<\bB\bJ\bK\bL\bU\bV\b[\b\\\b]\bb\bd\bf\bi\bl\bo\br\bu\bx\b{\b}\b\127\b\128\b\129\b\130\b\132\b\136\b\138\b\138\b\140\b\141\b\143\b\143\b\144\b\147\b\149\b\150\b\150\b\151\b\152\b\153\b\155\b\157\b\159\b\161\b\162\b\163\b\165\b\169\b\172\b\173\b\174\b\175\b\180\b\185\b\191\b\197\b\204\b\211\b\211\b\212\b\213\b\215\b\217\b\218\b\220\b\222\b\228\b\233\b\237\b\241\b\246\b\251\b\252\b\254")) + ((16, "\001g\001c\000\203\000\201\000\199\000\197\000\195\000\193\000\191\000\189\000\187\000\185\000\183\000E\0003\000B\000@\001y\001\207\000\246\0006\001i\000\250\0019\001Q\0013\001\025\001\165\001\151\000=\001\201\000=\000b\000w\000*\000=\000\160\001\169\001\201\000\160\001\169\000b\000w\000*\000\160\001\169\001\015\000\206\001\149\0006\001i\000\014\000U\000U\000\206\001\199\000\169\000|\001\199\001\197\000.\001\175\000\174\0019\001\187\001K\000\154\001\193\000h\000J\0019\001\r\000\154\001\193\000h\000J\000\240\0019\001\r\000\154\001\193\001\193\001\195\001\175\000\139\001\143\000\140\0019\001\193\000\223\0013\000\140\000\240\0019\001\193\000\223\0013\000\012\000+\0013\000^\001\031\0013\000\214\0019\001\159\0013\000\138\0019\000g\0013\001a\0013\001\135\000\186\001\193\000\226\001\173\000\186\001\193\001S\001\189\001S\000X\001\193\001S\001\187\001\021\000b\000\181\000*\000b\000\181\000\226\001\153\000*\000b\001\153\000*\000\140\0019\001\177\0013\000\012\0019\000\247\000d\000\226\001\153\0013\000^\0019\000\157\000d\000\226\000\167\0013\000\214\0019\001\159\0013\001a\0013\001\135\001\169\000~\000}\000.\001\169\001\143\000N\0019\001\181\001-\000\192\001\177\001\195\000h\000J\0019\001\r\000\154\001\177\000h\000J\000\240\0019\001\r\000\154\001\177\000b\001\193\000*\001\185\000~\000}\000.\001\185\000b\001\193\000\226\001\173\000*\000N\0019\001\183\001+\000\192\001\177\000\207\000C\000X\001\173\000d\000\226\000C\000X\001\173\000C\000X\001\173\000\228\000\018\001\145\0019\000'\001\133\000d\000\186\001\177\0013\001?\001\029\000\136\000\230\000 \000\178\000~\000.\000b\000*\000\180\000\022\000\016\000b\000\224\000*\001\165\001\r\001\r\000\206\000b\000\224\000*\000b\000\224\000*\001\165\001\153\000\186\001\153\001\201\000y\000\"\001\201\000\130\001[\0000\000\238\000\151\001\207\001\153\001\195\000\237\001\137\001\149\000b\001\153\000*\000b\000V\001\145\0019\001\001\000*\000~\000I\000.\000~\000\238\000\127\000.\000~\000q\000\238\000\127\000.\000t\000\227\000\127\000.\000t\000.\000r\000\227\000\127\000.\000r\000\227\000\127\000\168\000\137\000.\000\024\000\196\000D\001\199\000p\001\199\000\169\000.\0004\000\238\001\163\000\186\001\161\0019\001\163\000\186\001\161\0019\001\143\000x\001\199\001\197\000.\000~\000{\000.\000\172\001\145\0019\000\133\001{\000[\000h\000V\001\145\0019\001\005\001\011\000\154\000g\000h\000\184\001\145\0019\001\163\001s\0019\000\154\000g\000h\000J\001\145\0019\001\007\000\154\000g\000h\000J\000\240\001\145\0019\001\007\000\154\000g\000\174\001\145\0019\001}\000\221\000X\001\131\000`\001\145\0019\000g\000\004\000\133\000\020\001\145\0019\000g\000\004\000\133\000\156\001\145\0019\000g\000\028\001\129\000\194\001\129\000\156\001\145\0019\000g\000\028\001\129\000\194\000\172\001\145\0019\000\133\000\156\001\145\0019\000g\000\028\000\172\001\145\0019\000\133\000\194\001\129\000\156\001\145\0019\000g\000\028\000\172\001\145\0019\000\133\000\194\000\172\001\145\0019\000\133\000\156\001\145\0019\000g\000\028\001\129\000\156\001\145\0019\000g\000\028\000\172\001\145\0019\000\133\000\006\001\145\0019\000g\000\212\000g\000\208\000\176\001\145\0019\000\181\000\186\000g\001\147\000g\000\212\000g\000\208\000\244\001\145\0019\000[\000\132\001\145\0019\000[\000[\000\139\000u\001\161\000[\000\245\000[\001\129\000\150\001\129\001\129\000\150\000\172\001\145\0019\000\133\001\129\000\148\001\129\001\129\000\148\000\172\001\145\0019\000\133\001\129\000\146\001\129\001\129\000\146\000\172\001\145\0019\000\133\001\129\000\144\001\129\001\129\000\144\000\172\001\145\0019\000\133\001\129\000\142\001\129\001\129\000\142\000\172\001\145\0019\000\133\001\129\000B\001\129\001\129\000B\000\172\001\145\0019\000\133\001\129\000@\001\129\001\129\000@\000\172\001\145\0019\000\133\001\129\000>\001\129\001\129\000>\000\172\001\145\0019\000\133\001\129\000\\\001\129\001\129\000\\\000\172\001\145\0019\000\133\001\129\000Z\001\129\001\129\000Z\000\172\001\145\0019\000\133\001\129\000\"\001\129\001\129\000\"\000\172\001\145\0019\000\133\001\129\000D\001\129\001\129\000D\000\172\001\145\0019\000\133\001\129\000\186\001\129\001\129\000\186\000\172\001\145\0019\000\133\001\129\000l\001\129\001\129\000l\000\172\001\145\0019\000\133\001\129\000\168\001\129\001\129\000\168\000\172\001\145\0019\000\133\001\129\000F\001\129\001\129\000F\000\172\001\145\0019\000\133\001\129\000\236\001\129\001\129\000\236\000\172\001\145\0019\000\133\001\129\000\252\001\129\001\129\000\252\000\172\001\145\0019\000\133\001\129\000\254\001\129\001\129\000\254\000\172\001\145\0019\000\133\001\129\000\222\001\129\001\129\000\222\000\172\001\145\0019\000\133\000K\001\129\000K\000\172\001\145\0019\000\133\001\209\001\129\001\209\000\172\001\145\0019\000\133\001M\000\154\000g\000f\001E\000\154\000g\001\129\000\224\001\129\001\129\000\224\000\172\001\145\0019\000\133\000d\000j\001\129\000d\000j\000\172\001\145\0019\000\133\000[\000\206\001W\000j\001\129\000[\000\206\001W\000j\000\172\001\145\0019\000\133\000[\000\206\000b\000g\000*\000j\001\129\000[\000\206\000b\000g\000*\000j\000\172\001\145\0019\000\133\000[\000\206\000\130\000g\0000\000j\001\129\000[\000\206\000\130\000g\0000\000j\000\172\001\145\0019\000\133\000[\000\206\000~\000g\000.\000j\001\129\000[\000\206\000~\000g\000.\000j\000\172\001\145\0019\000\133\000[\000\200\000b\000o\000*\000j\001\129\000[\000\200\000b\000o\000*\000j\000\172\001\145\0019\000\133\000[\000\206\001\r\000\200\000b\000o\000*\000j\001\129\000[\000\206\001\r\000\200\000b\000o\000*\000j\000\172\001\145\0019\000\133\000[\000\200\000\130\000o\0000\000j\001\129\000[\000\200\000\130\000o\0000\000j\000\172\001\145\0019\000\133\000[\000\206\001\r\000\200\000\130\000o\0000\000j\001\129\000[\000\206\001\r\000\200\000\130\000o\0000\000j\000\172\001\145\0019\000\133\000[\000\200\000~\000o\000.\000j\001\129\000[\000\200\000~\000o\000.\000j\000\172\001\145\0019\000\133\000[\000\206\001\r\000\200\000~\000o\000.\000j\001\129\000[\000\206\001\r\000\200\000~\000o\000.\000j\000\172\001\145\0019\000\133\001\129\001\195\000b\000\018\000\243\000*\001S\000\143\001\129\001\129\000(\001\129\000(\000g\001\129\000(\000D\001\199\000g\000C\000\207\000C\000X\001y\000d\000\226\000C\000X\001y\000C\000X\001y\000b\000*\000b\001\005\000\226\001\001\000*\000\141\000L\001\157\000\226\001\157\000X\001\201\000\226\000\135\000\206\001\157\000X\001\201\000\226\001\201\000\226\000\135\000\206\001\201\000\238\001\163\001s\0019\001\163\001s\0019\000\018\001\145\0019\0009\000d\000\222\000\239\000\145\0013\000\018\001\145\0019\000P\0009\000d\000\222\000\239\000\145\0013\000\018\001\145\0019\0009\000d\000?\000\145\0013\000\018\001\145\0019\000P\0009\000d\000?\000\145\0013\000\016\000d\000O\000\190\000(\000\204\000c\000\190\000n\001\199\000\169\000.\0002\000\249\000d\000\226\000\165\0019\000\249\000d\000\226\000\165\0019\000(\0019\001_\001]\001]\001[\000d\000d\000\226\001\153\001\021\000[\000\134\000[\000\026\000d\000\026\000b\000d\000A\000*\0008\000d\000H\000[\0008\000b\001Y\000\211\000*\0008\000d\000H\000b\001I\000\211\000*\000H\000\171\000\026\000b\001Y\000*\000\026\000d\000\134\000Y\000Y\001O\000/\000/\000Q\000/\000A\000\186\000g\000/\000\226\000\135\000\206\001\153\000\186\000g\000/\000\226\000\018\000\243\000\206\001\153\000\186\000g\000\173\000\186\000g\000W\000\226\001\153\000\186\000g\000h\001\145\0019\000\155\001Q\0013\001M\001\205\000h\0019\000\155\001Q\0013\000h\000D\001\199\0019\000\155\001Q\0013\001K\001\205\000\181\000\181\000\226\001\153\000/\000Q\000/\000Y\000\226\001\153\000\186\000g\000\173\000\186\000g\001G\001E\000\248\001G\000\250\0019\000'\001\133\000d\001\189\0013\001C\000\250\0019\000'\001\133\000d\000\226\001\173\0013\001A\000\250\0019\000'\001\133\000d\000\186\001\177\0013\001?\000\250\0019\001\005\001\011\0013\001=\000\250\0019\001\005\000\226\001\001\0013\001;\001\195\0019\000\250\0019\0009\000d\000?\000\145\0013\0017\000\250\0019\0009\000d\000\222\000\239\000\145\0013\0015\000\163\0013\000&\0011\000a\0011\000&\001/\000&\000g\0013\001/\000M\001/\001\179\001-\001\191\001+\000M\001)\000&\001'\000&\000g\0013\001'\000M\001'\000G\001'\001W\000\219\000\213\001W\000\219\000\213\000(\001W\000\219\000\213\000(\000\014\000\225\001W\000\219\000\213\000(\001%\000\181\000X\000g\000\181\000\b\000g\000X\000g\000\181\000X\000\206\000d\000\226\000\165\0019\000(\0019\001!\001\201\000(\001!\000d\000\226\000\165\0019\000(\0019\001\201\000(\000d\000\226\000\165\0019\001\201\000\204\0019\000#\000d\000\226\000\167\0019\000\159\000d\000Q\000\240\0019\000\159\000d\000Q\0019\000\159\000d\000\226\000\167\000\186\000g\000\240\0019\000\159\000d\000\226\000\167\000\186\000g\0019\000\159\000d\000\226\000\018\000\243\000\206\001\153\000\186\000g\000\240\0019\000\159\000d\000\226\000\018\000\243\000\206\001\153\000\186\000g\000d\001\015\000\206\000d\000\016\001\015\000\206\000\016\001i\000b\000\224\000*\0001\001\015\000\206\001i\001\015\000\206\000b\000\224\000*\001\015\000\206\0001\001i\001\015\000\206\001i\000d\001\r\000\206\000d\000\016\001\r\000\206\000\016\000/\001\r\000\206\000/\001\027\001\015\000b\001\015\000*\001\019\000\186\001\007\000\226\001\001\000\186\001\007\001w\001\011\000\226\001\001\001w\001\t\000\030\0019\000O\000\192\000\170\0019\001u\000X\001\007\000\205\001\007\001\195\001\r\001\007\000\205\001\007\000b\000*\001\143\000\014\000\016\000\014\000V\001\145\0019\000\016\000\222\001\015\0013\000$\0019\000c\000\192\000\170\0019\001u\000X\001\001\000V\000\018\000L\0019\001\007\000b\001\001\000*\001\001\001\195\000\251\000b\000*\000X\001\001\001\001\000X\001\001\001\001\000\004\000\129\001\143\000V\000\018\001\145\0019\001i\000\215\0013\000V\000\018\001\145\0019\001i\000\222\001\001\0013\001\023\000T\000T\000\n\000T\000\n\000\n\000T\000\242\001i\000d\000d\000\243\000 \000 \000\241\001\153\000:\001\153\001\155\000:\001\155\001\153\000\186\001\155\001\153\000\186\000:\001\155\000\204\000:\000\204\001\153\000\186\000\204\001\153\000\186\000:\000\204\000\130\001[\0000\000:\000\130\001[\0000\001\153\000\186\000\130\001[\0000\001\153\000\186\000:\000\130\001[\0000\000l\001!\000\168\000l\000\168\000J\001\145\0019\001\007\0013\000J\000\240\001\145\0019\001\007\0013\000J\001\145\0019\001\015\0013\000J\000\240\001\145\0019\001\015\0013\000<\000f\000\248\000\200\000b\001e\000*\000\200\000b\001e\000*\000j\000\200\000~\001e\000.\000\200\000~\001e\000.\000j\000\200\000\130\001e\0000\000\200\000\130\001e\0000\000j\000\158\000\240\000\150\000\148\000\146\000\144\000\142\000B\000@\000>\000\\\000Z\000\"\000D\000\186\000l\000\168\000F\000\236\000\252\000\254\000\222\000\252\000\238\000(\000\246\000d\000\226\001\201\000\226\001\153\000\186\001\129\000\186\000\172\001\145\0019\000\133\000\186\001\001\000\186\000\181\000\186\000g\000A\000H\0008\000d\000\226\000b\001\007\000\226\001\001\000*\000b\001\007\000*\000b\000\012\0019\001\129\000*\000b\000\012\0019\000\172\001\145\0019\000\133\000*\000b\000\012\0019\001\129\000\226\001\001\000*\000b\000\012\0019\000\172\001\145\0019\000\133\000\226\001\001\000*\000b\000\012\0019\001\129\000\226\001\001\000\220\001\001\000*\000b\000\012\0019\000\172\001\145\0019\000\133\000\226\001\001\000\220\001\001\000*\000b\000\012\0019\001\129\000\220\001\001\000*\000b\000\012\0019\000\172\001\145\0019\000\133\000\220\001\001\000*\001\203\000\190\001\161\000\190\001\153\000\190\000g\000\190\001\015\000\190\001\r\000\190\001\007\000\190\001\001\000\190\000\251\000\190\000\181\000\190\000-\000\190\000\181\000\224\000\181\000\181\001\195\000\175\000\181\000\246\000/\000\179\000\181\000\238\000\181\000\184\001\145\0019\000\181\000\179\000\218\000\181\000\181\000\218\000\181\000\177\000\218\000\181\000\173\000\218\000\181\000Y\001\161\000\181\001\161\000b\000\018\000\243\000*\000Y\000\245\000\181\000\132\001\145\0019\000Y\000\173\000\224\000\181\000\173\001\195\000\175\000\173\000\246\000/\000\177\000\173\000\238\000\181\000d\000\014\000O\000\226\000c\000\226\001\153\0008\000\181\0008\000\181\000\b\000g\001\153\000\135\000\206\001\153\001\207\000\135\000\206\001\207\000z\001\199\001\197\000.\000\182\001\145\0019\000/\000\226\000\167\000\186\000\241\0013\000:\000:\000\n\000:\000\n\000\n\000:\000,\000i\000[\000\004\000i\001o\001q\000\151\001q\001o\001\139\001q\001\141\000\149\001q\000\149\001\141\001o\001q\000\147\001q\000\145\000\214\001\153\000\186\001\153\001\127\000\143\001\127\001w\000\141\001w\001U\000\139\001U\000\245\000\137\000\245\0006\001i\000\135\0006\001i\001#\000\238\001#\000\133\000\238\001#\001\207\000\131\000\252\001\207\000!\000\129\000\250\000!\000q\000\127\000\238\000q\001\153\000}\000\218\001\153\000;\000{\000\218\000;\001\201\000y\000\"\001\201\000w\000\218\001\153\001\153\000\218\001\153\000u\000\218\001\129\000u\000\218\000\172\001\145\0019\000\133\001\129\000\218\001\129\001\129\000\218\000\172\001\145\0019\000\133\000\172\001\145\0019\000\133\000\218\001\129\000\172\001\145\0019\000\133\000\218\000\172\001\145\0019\000\133\000s\000\"\001\201\001\201\000\"\001\201\000I\001\153\001\129\001\129\000(\000\172\001\145\0019\000\133\000\172\001\145\0019\000\133\000(\001\129\000(\000o\000\172\001\145\0019\000\133\000(\000o\000d\000\217\000d\000\217\000(\000d\000\217\000(\000m\000\181\000\181\000(\000\181\000(\000k\001W\000\209\000\217\001W\000\209\000\217\000(\001W\000\209\000\217\000(\000i\001{\000\172\001\145\0019\000\133\000\184\001\145\0019\001\163\001s\0019\0013\0011\001a\0013\001\135\000)\000\161\001k\0017\001m\0015\000\018\001\145\0019\0009\000=\000>\000\159\000\147\0013\000\018\001\145\0019\000P\0009\000=\000>\000\159\000\147\0013\000e\000V\001\145\0019\001\005\001\t\0013\000V\001\145\0019\001\005\000\186\001\r\0013\001\003\000V\001\145\0019\000,\001\005\000\226\001\001\0013\001;\000\255\000\253\000\233\000\152\001\145\0019\001\001\0013\000\228\001\145\0019\000'\001\133\000d\000\226\001\173\0013\001A\001\171\001\167\000\\\000\136\000\\\000\178\000B\000\136\000B\000\178\000\130\001%\0000\000~\000k\000.\000v\000k\000\234\000v\000\234\000\202\001\129\000\166\000\202\000\172\001\145\0019\000\133\000\166\000\198\000[\000b\000g\000*\000b\000g\000A\000*\000[\000\206\000b\000g\000*\000[\000\206\000\130\000g\0000\000[\000\206\000~\000g\000.\000[\000\200\000b\000o\000*\000[\000\206\001\r\000\200\000b\000o\000*\000[\000\200\000\130\000o\0000\000[\000\206\001\r\000\200\000\130\000o\0000\000[\000\200\000~\000o\000.\000[\000\206\001\r\000\200\000~\000o\000.\000\232\001\145\0019\000g\000\192\000\232\001\145\0019\000\192\000R\001\145\0019\001\185\000b\000V\001\145\0019\001\007\000*\000b\000V\001\145\0019\001\007\000\226\001\001\000*\000N\001\145\0019\001\183\001+\000\192\000-\001\167\001\161\000\245\000<\000[\000\240\000[\000\128\000m\000\164\000\128\000\164\000[\000\206\001W\001\r\000\206\000b\000g\000*\001\r\000\206\000\128\000m\000\164\000[\000\160\000d\000[\000\158\000[\001\143\000\014\001\r\000\206\000b\000*\000\130\000\153\0000\001\r\000\206\000\130\000\153\0000\000v\000o\000\234\000v\000\234\001\r\000\206\000v\000o\000\234\001\r\000\206\000v\000\234\000~\000o\000.\001\r\000\206\000~\000o\000.\001\r\000\206\000~\000.\001\r\000\206\000b\000V\001\145\0019\001\007\000\226\001\001\000*\000/\000W\000b\000\181\000*\000]\000b\000V\001\145\0019\001\005\000*\000b\000V\001\145\0019\001\005\000\226\001\001\000*\000\014\000_\000_\000\204\000_\001\161\000\245\000\160\000=\001\r\000\206\000]\001\r\000\206\000~\000.\001\r\000\206\000b\000*\001\r\000\206\000b\000\181\000*\000b\000\181\000\226\001\153\000*\001\143\000d\000\016\000\250\000\246\000\244\000\232\000\228\000\214\000\212\000\208\000\196\000\194\000\192\000\184\000\182\000\180\000\176\000\174\000\172\000\170\000\156\000\154\000\152\000\140\000\138\000\132\000h\000`\000^\000V\000T\000R\000P\000N\000L\000J\000F\000:\000,\000$\000\030\000\028\000\024\000\022\000\020\000\018\000\012\000\n\000\b\000\006\000\004\000e\000\184\001\145\0019\001\163\000\186\001\161\0019\0013\000\186\000g\001}\000\209\000\186\001\131\001/\000g\0013\001/\001M\001a\0013\001\135\000\161\000)\001k\0017\000\018\001\145\0019\0009\000=\000>\000\159\000\149\0013\000\018\001\145\0019\000P\0009\000=\000>\000\159\000\149\0013\000S\000V\001\145\0019\001\005\001\011\0013\000V\001\145\0019\000,\001\005\001\011\0013\001=\000\255\000\235\000\228\001\145\0019\000'\001\133\000d\001\189\0013\001C\001\171\000\152\001\145\0019\001\007\0013\000\\\000Z\000\245\000L\000\229\000\131\0019\000\245\0019\000\160\001i\000\160\001i\000 \000\160\001i\000\136\000\160\001i\000-\000\160\001i\001\r\000\160\001i\000\180\000\160\001i\000\022\000g\0013\000&\001)\000&\000G\000&\000\190\001\201\000s\000\226\001\153\000\226\001\153\000\220\001\153\000\220\001\153\000\186\000\239\001\029\0005\0007\000;\000b\000{\000*\0006\001i\000\014\000B\000\\\000\240\000B\000\240\000\240\000B\000\\\000\240\000\240\000\\\000\146\000<\001'\000\190\000g\0013\001'\000\190\000b\000\231\000*\000d\0001\001\017\0019\000%\000d\000\226\001\153\0019\000\249\000d\000\186\000g\000\240\0019\000\249\000d\000\186\000g\0019\000\249\000d\000A\000\186\000g\000\240\0019\000\249\000d\000A\000\186\000g\000\012\001\145\0019\000/\000\226\000\167\0013\000\n\000\n\000T\000\n\000\n\000T\000\n\000:\000\n\000\n\000:\000\018\0009\001W\000\031\001\207\000\145\000\018\0009\001W\000\222\001\207\000V\001\r\000\186\001\015\000V\001\r\000\222\001\015\000V\000\018\000\251\000\186\001\001\000V\000\018\000\251\000\222\001\001\000\186\000\186\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\017\000\018\000\022\000\026\000\027\000\028\000\029\000\030\000 \000$\000&\000)\000.\0001\0003\0004\0005\0008\0009\000=\000>\000A\000D\000J\000Q\000S\000U\000V\000[\000a\000d\000g\000k\000o\000q\000r\000t\000x\000z\000}\000\127\000\128\000\131\000\136\000\136\000\139\000\139\000\143\000\150\000\157\000\161\000\163\000\164\000\165\000\169\000\170\000\175\000\177\000\183\000\190\000\193\000\194\000\198\000\203\000\208\000\209\000\213\000\218\000\221\000\232\000\233\000\234\000\235\000\236\000\237\000\239\000\241\000\242\000\243\000\244\000\247\000\248\000\249\000\254\001\001\001\002\001\005\001\006\001\t\001\012\001\r\001\014\001\015\001\017\001\018\001\019\001\020\001\023\001\029\001 \001$\001)\001-\001/\0013\0019\001:\001;\001;\001=\001A\001B\001G\001K\001L\001P\001P\001S\001W\001X\001Y\001a\001j\001q\001y\001\128\001\134\001\140\001\148\001\159\001\170\001\184\001\190\001\199\001\206\001\217\001\221\001\225\001\227\001\228\001\230\001\232\001\235\001\241\001\244\001\250\001\253\002\003\002\006\002\012\002\015\002\021\002\024\002\030\002!\002'\002*\0020\0023\0029\002<\002B\002E\002K\002N\002T\002W\002]\002`\002f\002i\002o\002r\002x\002{\002\129\002\132\002\138\002\141\002\147\002\150\002\156\002\158\002\163\002\165\002\170\002\173\002\177\002\180\002\186\002\189\002\195\002\200\002\208\002\215\002\225\002\232\002\242\002\249\003\003\003\n\003\020\003\029\003)\0030\003:\003C\003O\003V\003`\003i\003u\003w\003{\003|\003}\003~\003\128\003\131\003\136\003\137\003\141\003\146\003\149\003\151\003\156\003\157\003\157\003\159\003\163\003\169\003\171\003\175\003\179\003\182\003\191\003\201\003\209\003\218\003\219\003\220\003\222\003\222\003\224\003\226\003\230\003\231\003\236\003\243\003\244\003\245\003\247\003\248\003\251\003\252\003\253\003\255\004\001\004\006\004\b\004\n\004\015\004\017\004\022\004\024\004\028\004\030\004 \004!\004\"\004#\004%\004)\0040\0048\004;\004@\004F\004H\004M\004T\004V\004W\004Z\004\\\004]\004b\004e\004f\004i\004i\004q\004q\004z\004z\004\131\004\131\004\137\004\137\004\144\004\144\004\146\004\146\004\154\004\154\004\163\004\163\004\165\004\165\004\167\004\169\004\169\004\171\004\175\004\177\004\177\004\179\004\179\004\181\004\181\004\183\004\183\004\185\004\189\004\191\004\193\004\196\004\200\004\206\004\211\004\214\004\219\004\222\004\229\004\232\004\238\004\240\004\244\004\245\004\246\004\251\004\255\005\004\005\011\005\019\005\029\005(\005)\005,\005-\0050\0051\0054\0055\0058\005=\005@\005A\005D\005E\005H\005I\005L\005M\005P\005Q\005U\005V\005X\005\\\005^\005`\005b\005f\005k\005l\005n\005o\005q\005t\005u\005v\005w\005x\005\127\005\131\005\136\005\141\005\144\005\146\005\147\005\151\005\154\005\157\005\158\005\165\005\173\005\174\005\174\005\175\005\175\005\176\005\177\005\179\005\181\005\183\005\184\005\186\005\187\005\189\005\190\005\192\005\193\005\195\005\198\005\202\005\203\005\205\005\208\005\212\005\215\005\219\005\224\005\230\005\233\005\235\005\240\005\246\005\251\006\001\006\002\006\003\006\004\006\b\006\r\006\017\006\022\006\026\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\0066\0066\0067\0067\0068\0068\006:\006:\006<\006<\006>\006>\006@\006E\006E\006G\006G\006I\006I\006K\006K\006L\006M\006P\006U\006X\006]\006e\006l\006v\006\127\006\139\006\146\006\156\006\158\006\160\006\162\006\164\006\166\006\168\006\170\006\172\006\174\006\176\006\178\006\181\006\183\006\184\006\187\006\188\006\191\006\195\006\198\006\201\006\204\006\207\006\208\006\210\006\216\006\218\006\222\006\225\006\227\006\228\006\231\006\232\006\235\006\236\006\237\006\238\006\240\006\242\006\244\006\248\006\249\006\252\006\253\007\000\007\004\007\r\007\r\007\014\007\014\007\015\007\016\007\018\007\020\007\020\007\021\007\022\007\025\007\026\007\027\007\029\007\030\007\031\007 \007!\007#\007%\007&\007'\007)\007)\007.\007/\0071\0072\0074\0075\0077\0078\007:\007<\007?\007@\007B\007E\007F\007I\007J\007M\007N\007Q\007R\007U\007V\007Y\007Z\007]\007`\007c\007f\007l\007o\007u\007{\007\132\007\135\007\138\007\139\007\140\007\141\007\143\007\147\007\152\007\155\007\161\007\163\007\166\007\170\007\171\007\173\007\176\007\179\007\183\007\188\007\189\007\193\007\200\007\201\007\203\007\204\007\205\007\206\007\208\007\210\007\219\007\229\007\230\007\236\007\243\007\244\007\253\007\254\007\255\b\000\b\005\b\015\b\016\b\017\b\019\b\021\b\023\b\025\b\028\b\031\b\"\b$\b'\b-\b/\b2\b6\b;\b@\bE\bJ\bQ\bV\b]\bb\bi\bn\br\bv\b|\b\132\b\138\b\139\b\140\b\141\b\142\b\144\b\146\b\149\b\151\b\154\b\159\b\164\b\167\b\170\b\171\b\172\b\176\b\179\b\184\b\187\b\189\b\194\b\198\b\201\b\206\b\210\b\220\b\221\b\222\b\225\b\226\b\232\b\240\b\241\b\242\b\245\b\246\b\247\b\249\b\252\t\000\t\004\t\t\t\014\t\015\t\016\t\017\t\018\t\019\t\020\t\021\t\022\t\023\t\024\t\025\t\026\t\027\t\028\t\029\t\030\t\031\t \t!\t\"\t#\t$\t%\t&\t'\t(\t)\t*\t+\t,\t-\t.\t/\t0\t1\t2\t3\t4\t5\t6\t7\t8\t9\t:\t;\t<\t=\t>\t?\t@\tA\tB\tC\tK\tM\tQ\tR\tU\tV\tX\tY\tZ\t[\t]\tf\tp\tq\tw\t\127\t\128\t\129\t\138\t\139\t\144\t\145\t\146\t\151\t\153\t\155\t\158\t\161\t\164\t\167\t\170\t\173\t\176\t\178\t\180\t\181\t\182\t\183\t\185\t\189\t\191\t\191\t\193\t\194\t\196\t\196\t\197\t\200\t\202\t\203\t\203\t\204\t\205\t\206\t\208\t\210\t\212\t\214\t\215\t\216\t\218\t\222\t\225\t\226\t\227\t\228\t\233\t\238\t\244\t\250\n\001\n\b\n\b\n\t\n\n\n\012\n\014\n\015\n\017\n\019\n\025\n\030\n\"\n&\n+\n0\n1\n3")) 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\131\001\132\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\129\001\130\001\156\001\157\001\158\001\133\001\134\001\135\001\136\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\005\002\006\002\007\002\b\002\t\002\n\002\011\002\012\002\r\002\014\002\003\002\004\002\015\002\016\002\017\002\018\002\019\002\020\002\021\002\022\002\023\002\024\002\025\002\026\002\027\002\028\002\029\002\030\002\031\002 \002!\002\"\002#\002$\002%\002&\002'\002(\002)\002*\002+\002,\002-\002.\002/\0020\0021\0022\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\002\138\002\139\002\140\002\141\002\142\002\143\002\144\002\145\002\146\002\147\002\148\002\149\002\150\002\151\002\152\002\153\002\154\002\155\002\156\002\157\002\158\002r\002s\002t\002u\002h\002i\002l\002m\002n\002o\002p\002q\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\002j\002k\002v\002w\005\220\005\221\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\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\181\002\182\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\232\002\233\002\234\002\235\002\236\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\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\003\017\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#\003$\003%\003&\003'\003(\003)\003*\003+\003,\003-\003.\003/\0030\0031\0032\0033\0034\0035\0036\0037\0038\0039\003:\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\003U\003V\003W\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\003u\003v\003w\003x\003y\003z\003{\003|\003}\003~\003\127\003\128\003\129\003\130\003\131\003\132\003\133\003\134\003\135\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\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\225\003\226\003\227\003\228\003\229\003\230\003\231\003\232\003\233\003\234\003\235\003\236\003\237\003\238\003\239\003\240\003\241\003\242\003\243\003\244\003\245\003\246\003\247\003\248\003\249\003\250\003\251\003\252\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\222\005\223\005\224\005\225\005\226\005\227\005\228\005\229\005\230\005\231\005\232\005\140\005\141\005\142\005\233\005\234\005\235\005\236\005\237\005\238\005\239\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\240\005\241\005\242\005\243\005\244\005\245\005\246\005\247\002\159\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\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\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\0073\0074\0075\0076\0077\0078\0079\007:\007;\007<\007=\007>\007?\007@\007A\007B\007C\007D\007E\007F\007G\007H\007I\007J\007K\007L\007M\007N\007O\007P") + (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\128\001\129\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~\001\127\001\153\001\154\001\155\001\130\001\131\001\132\001\133\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\238\001\239\001\240\001\241\001\242\001\243\001\244\001\245\001\246\001\247\001\236\001\237\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\024\002\025\002\026\002\027\002\028\002\029\002\030\002\031\002 \002!\002\"\002#\002$\002%\002&\002'\002(\002)\002*\002+\002,\002-\002.\002/\0020\0021\0022\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\002\137\002\138\002\139\002\140\002\141\002\142\002\143\002\144\002\145\002\146\002\147\002\148\002\149\002\150\002\151\002\152\002\153\002\154\002\155\002\156\002\157\002m\002n\002o\002p\002b\002c\002f\002g\002h\002i\002j\002k\002l\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\002d\002e\002q\002r\004\t\004\n\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\230\002\231\002\232\002\233\002\234\002\235\0034\0035\0036\0037\0038\0039\003:\003;\003<\003=\003>\003?\003@\003A\002\182\002\183\002\184\002\185\002\186\002\187\002\200\002\201\002\202\002\203\002\204\002\205\002\236\002\237\002\238\002\239\002\240\002\241\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\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\242\002\243\002\244\002\245\002\246\002\247\002\248\002\249\002\250\002\251\002\252\002\253\003\028\003\029\003\030\003\031\003 \003!\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\"\003#\003$\003%\003&\003'\003(\003)\003*\003+\003,\003-\003.\003/\0030\0031\0032\0033\003\016\003\017\003\018\003\019\003\020\003\021\003\022\003\023\003\024\003\025\003\026\003\027\003B\003C\003D\003E\003F\003G\003H\003I\003J\003K\003L\003M\003N\003O\003P\003Q\003R\003S\003T\003U\003V\003W\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\003u\003v\003w\003x\003y\003z\003{\004\011\004\012\004\r\004\014\004\015\004\016\004\017\004\018\004\019\004\020\004\021\003\140\003\141\003\142\004\022\004\023\004\024\004\025\004\026\004\027\004\028\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\225\003\226\003\227\003\228\003\229\003\230\003\231\003\232\003\233\003\234\003\235\003\236\003\237\003\238\003\239\003\240\003\241\003\242\003\243\003\244\003\245\003\246\003\247\003\248\003\249\003\250\003\251\003\252\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\029\004\030\004\031\004 \004!\004\"\004#\004$\004%\002\158\003|\003}\003~\003\127\003\128\003\129\003\130\003\131\003\132\003\133\003\134\003\135\003\136\003\137\003\138\003\139\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\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\0073\0074\0075\0076\0077\0078\0079\007:\007;\007<\007=\007>\007?\007@\007A\007B\007C\007D\007E\007F\007G\007H\007I\007J\007K\007L\007M\007N\007O\007P\007Q\007R\007S\007T\007U\007V\007W\007X\007Y\007Z\007[\007\\\007]\007^\007_\007`\007a\007b\007c\007d\007e\007f\007g\007h\007i\007j\007k\007l\007m\007n\007o\007p\007q\007r\007s\007t\007u\007v\007w\007x\007y\007z\007{\007|\007}\007~\007\127\007\128\007\129\007\130\007\131\007\132\007\133\007\134\007\135\007\136\007\137\007\138\007\139\007\140\007\141\007\142\007\143\007\144\007\145\007\146\007\147\007\148\007\149\007\150\007\151\007\152\007\153\007\154\007\155\007\156\007\157\007\158\007\159\007\160\007\161\007\162\007\163\007\164\007\165\007\166\007\167\007\168\007\169\007\170\007\171\007\172\007\173\007\174\007\175\007\176\007\177\007\178\007\179\007\180\007\181\007\182\007\183\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") and lr0_items = - ((32, "\000\000\000\000\000\002\b\001\000\002 \001\000\011\160\001\000\011\156\001\000\011\152\001\000\011\148\001\000\011\144\001\000\n\220\001\000\011\140\001\000\011\136\001\000\011\132\001\000\011\128\001\000\011|\001\000\011x\001\000\011t\001\000\011p\001\000\011l\001\000\011h\001\000\011d\001\000\011`\001\000\011\\\001\000\011X\001\000\011T\001\000\011P\001\000\011L\001\000\011H\001\000\011D\001\000\n\216\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\244\001\000\n\240\001\000\n\236\001\000\n\232\001\000\n\228\001\000\n\224\001\000\000\132\001\000\000\128\001\000\000\132\002\000\000\132\003\000\002 \002\000\002\b\002\000\000\140\001\000\000\140\002\000\002t\001\000\002t\002\000\002t\003\000\n`\001\000\005\132\001\000\002\004\001\000\002\000\001\000\001\252\001\000\001\248\001\000\002\004\002\000\002\000\002\000\001\252\002\000\001\248\002\000\002\004\003\000\002\000\003\000\001\252\003\000\001\248\003\000\002h\001\000\002h\002\000\002h\003\000\001x\001\000\001d\001\000\002(\001\000\n8\001\000\n$\001\000\n$\002\000\n$\003\000\000\236\001\000\000\232\001\000\n\168\001\000\t\200\001\000\t\196\001\000\t\196\002\000\t\200\002\000\t\192\001\000\t\188\001\000\t\188\002\000\t\192\002\000\012\164\001\000\n\208\001\000\n\164\001\000\n\160\001\000\n\152\001\000\001\144\001\000\001p\001\000\006\236\001\000\001p\002\000\006\152\001\000\006\224\001\000\006\220\001\000\t\200\001\000\t\196\001\000\006\216\001\000\006\240\001\000\007\000\001\000\n\164\002\000\n\160\002\000\n\164\003\000\n\160\003\000\n\164\004\000\n\160\004\000\005\220\001\000\005\216\001\000\n\164\005\000\n\160\005\000\n\160\006\000\n\164\006\000\005T\001\000\003\144\001\000\005\228\001\000\005\228\002\000\012\200\001\000\012\200\002\000\012\200\003\000\012\164\001\000\006\216\001\000\006\232\001\000\006\228\001\000\006\156\001\000\006\248\001\000\006\212\001\000\006\208\001\000\006\204\001\000\006\200\001\000\006\196\001\000\006\188\001\000\006\252\001\000\006\244\001\000\006\184\001\000\006\180\001\000\006\176\001\000\006\172\001\000\006\168\001\000\006\164\001\000\006\168\002\000\006\164\002\000\003\160\001\000\003\160\002\000\006\168\003\000\006\164\003\000\006\168\004\000\006\164\004\000\006\168\005\000\006\176\002\000\006\172\002\000\006\176\003\000\006\172\003\000\006\176\004\000\006\172\004\000\006\176\005\000\006\184\002\000\006\180\002\000\006\184\003\000\006\180\003\000\006\184\004\000\006\180\004\000\006\184\005\000\007\016\001\000\007\004\001\000\006\192\001\000\006\160\001\000\007\b\001\000\007\012\001\000\012\164\002\000\012\164\003\000\012\168\001\000\012\200\004\000\012\200\005\000\000|\001\000\005T\001\000\b\200\001\000\000x\001\000\003\144\001\000\003\148\001\000\b\200\002\000\000x\002\000\007p\001\000\007p\002\000\007p\003\000\007l\001\000\001\200\001\000\001\196\001\000\000p\001\000\000d\001\000\000x\001\000\000x\002\000\001\200\002\000\001\200\003\000\001\200\004\000\005\236\001\000\005\236\002\000\005\236\003\000\005\236\004\000\005\212\001\000\005\180\001\000\005\180\002\000\011\220\001\000\011\216\001\000\003\140\001\000\003\136\001\000\011\220\002\000\011\216\002\000\003\140\002\000\003\136\002\000\011\220\003\000\011\216\003\000\003\140\003\000\003\136\003\000\012\152\001\000\012\132\001\000\012x\001\000\012\132\002\000\011\220\004\000\003\140\004\000\012\140\001\000\012|\001\000\012\140\002\000\012h\001\000\012\148\001\000\012\144\001\000\012\136\001\000\012\128\001\000\012\136\002\000\012\144\002\000\012\\\001\000\012p\001\000\012l\001\000\012l\002\000\012\\\002\000\b\252\001\000\012h\002\000\t\000\001\000\012h\003\000\t\000\002\000\t\000\003\000\011\220\005\000\003\140\005\000\005L\001\000\003\140\006\000\012T\001\000\005T\001\000\001|\001\000\006t\001\000\006d\001\000\006T\001\000\006L\001\000\001\200\001\000\001\196\001\000\001\128\001\000\001p\001\000\000p\001\000\000d\001\000\005L\001\000\003L\001\000\003L\002\000\005L\001\000\006\132\001\000\006\128\001\000\005L\001\000\005$\001\000\005\028\001\000\005\020\001\000\005$\002\000\005\028\002\000\005\020\002\000\002$\001\000\002$\002\000\004\184\001\000\004\180\001\000\003\172\001\000\000@\001\000\000<\001\000\006\140\001\000\006\136\001\000\006\140\002\000\006\140\003\000\006\140\004\000\007\136\001\000\007\132\001\000\007\128\001\000\007|\001\000\007x\001\000\007t\001\000\007\136\002\000\007\132\002\000\007\128\002\000\007|\002\000\007\136\003\000\007\132\003\000\007\128\003\000\007|\003\000\n\024\001\000\n\024\002\000\n\024\003\000\005|\001\000\005\136\001\000\005\128\001\000\005\136\002\000\005\128\002\000\005\136\003\000\005\128\003\000\005\156\001\000\000\228\001\000\n\024\004\000\004\136\001\000\004\136\002\000\012\004\001\000\012\000\001\000\001\244\001\000\001\244\002\000\001\244\003\000\002d\001\000\002d\002\000\002d\003\000\012\164\001\000\n \001\000\n\028\001\000\t\232\001\000\t\228\001\000\001\144\001\000\001p\001\000\n8\001\000\006\152\001\000\nt\001\000\np\001\000\012\168\001\000\002\248\001\000\002\248\002\000\004\252\001\000\004\252\002\000\004\252\003\000\bd\001\000\004\252\004\000\t\216\001\000\t\212\001\000\t\208\001\000\001l\001\000\001l\002\000\t\204\001\000\003\204\001\000\t\204\002\000\t\204\003\000\004\248\001\000\004\244\001\000\004\240\001\000\004\236\001\000\007@\001\000\001\228\001\000\001\224\001\000\007 \001\000\001\228\002\000\001\224\002\000\001\220\001\000\001\216\001\000\001\220\002\000\001\216\002\000\001\212\001\000\001\208\001\000\001\204\001\000\000h\001\000\005\152\001\000\005X\001\000\005P\001\000\005\152\002\000\005\152\003\000\005\152\001\000\005X\001\000\005\152\004\000\005X\002\000\005X\003\000\005\148\001\000\005X\002\000\005P\002\000\005P\003\000\001X\001\000\000h\002\000\001\208\002\000\0064\001\000\0064\002\000\000\\\001\000\003P\001\000\003D\001\000\003P\002\000\012@\001\000\t\028\001\000\t\028\002\000\001\184\001\000\005\152\001\000\005X\001\000\005P\001\000\000t\001\000\005X\002\000\005P\002\000\000t\002\000\001\200\001\000\001\196\001\000\003H\001\000\003H\002\000\003H\003\000\012X\001\000\003H\004\000\001\188\001\000\0024\001\000\001\192\001\000\000X\001\000\012<\001\000\t \001\000\000l\001\000\000`\001\000\t \002\000\t \003\000\000l\001\000\000`\001\000\000l\002\000\000l\003\000\000`\002\000\000D\001\000\001\196\002\000\001\180\001\000\001\196\003\000\001\180\002\000\001\176\001\000\000H\001\000\000H\002\000\000H\003\000\000H\004\000\000t\003\000\t\028\003\000\000l\001\000\000`\001\000\003P\003\000\t$\001\000\b\236\001\000\b\240\001\000\001\208\003\000\001\208\004\000\b\240\002\000\b\240\003\000\012\012\001\000\012\b\001\000\012\b\002\000\007\020\001\000\012\b\003\000\012\b\004\000\b\224\001\000\b\224\002\000\b\224\003\000\000H\001\000\012\b\005\000\b\220\001\000\000H\001\000\012\012\002\000\t(\001\000\001\180\001\000\t$\001\000\001\204\002\000\001\204\003\000\001\212\002\000\001\212\003\000\b\240\001\000\001\212\004\000\001\212\005\000\b\240\001\000\001\216\003\000\001\216\004\000\b\240\001\000\001\228\003\000\001\224\003\000\001\224\004\000\001\228\004\000\b\196\001\000\001\228\005\000\001\228\006\000\b\196\002\000\b\192\001\000\007@\002\000\001\180\001\000\004\248\002\000\004\244\002\000\004\240\002\000\004\236\002\000\007X\001\000\007\244\001\000\007\244\002\000\007\244\003\000\001\\\001\000\n\188\001\000\n\188\002\000\001h\001\000\001t\001\000\001`\001\000\n\144\001\000\012\172\001\000\n\148\001\000\007\244\004\000\n\156\001\000\n\176\001\000\n\172\001\000\n\176\002\000\n\176\003\000\t\184\001\000\n\184\001\000\n\204\001\000\n\200\001\000\n\196\001\000\n\192\001\000\005\136\001\000\001\140\001\000\001\136\001\000\n\204\002\000\n\200\002\000\n\196\002\000\n\192\002\000\005\136\002\000\001\140\002\000\n\204\003\000\n\200\003\000\001\140\003\000\n\200\004\000\007\208\001\000\007\208\002\000\007\208\003\000\007\228\001\000\007\192\001\000\007\212\001\000\007\200\001\000\007\212\002\000\007\216\001\000\007\212\003\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\216\002\000\007\216\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\184\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\003\000\007\184\001\000\007\204\002\000\007\216\001\000\007\204\003\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\196\002\000\007\196\003\000\007\188\002\000\n\184\001\000\007\240\001\000\007\240\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\n\212\001\000\n\180\001\000\007\236\001\000\007\232\001\000\012\164\001\000\n\208\001\000\n\164\001\000\n\160\001\000\n\152\001\000\007\236\002\000\001\144\001\000\001p\001\000\007\236\003\000\006<\001\000\0068\001\000\006<\002\000\007\236\004\000\007\236\005\000\007\236\006\000\n\180\001\000\001\148\001\000\t\192\001\000\t\188\001\000\006\228\001\000\001\144\002\000\001\144\003\000\n\208\002\000\n\152\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\n\152\003\000\n\208\003\000\n\208\004\000\001\180\001\000\n\208\005\000\007\232\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\216\001\000\007\208\004\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\001\140\004\000\001\140\005\000\n\204\004\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\n\204\005\000\n\196\003\000\t\208\001\000\n\196\004\000\t\208\002\000\t\208\003\000\tL\001\000\tH\001\000\tD\001\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\tL\002\000\tH\002\000\tL\003\000\n\192\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007X\002\000\004\248\003\000\004\244\003\000\004\240\003\000\004\236\003\000\004\248\004\000\004\244\004\000\004\240\004\000\004\244\005\000\007(\001\000\004\244\006\000\004\248\005\000\t\216\002\000\t\212\002\000\t\212\003\000\n\144\001\000\004\028\001\000\004\024\001\000\004\020\001\000\004\016\001\000\004\012\001\000\003\252\001\000\003\248\001\000\003\248\002\000\003\200\001\000\003\196\001\000\003\200\002\000\003\200\003\000\001\180\001\000\003\248\003\000\003\248\004\000\003\252\002\000\003\236\001\000\003\232\001\000\003\232\002\000\003\232\003\000\007`\001\000\002\240\001\000\n\144\001\000\004H\001\000\004D\001\000\003\244\001\000\003\240\001\000\b\020\001\000\003\240\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\004@\001\000\004<\001\000\004@\002\000\004@\003\000\001\180\001\000\003\240\003\000\003\240\004\000\003\240\005\000\b\016\001\000\003\244\002\000\012\164\001\000\n\208\001\000\n\164\001\000\n\160\001\000\n\152\001\000\003(\001\000\001\144\001\000\001p\001\000\003(\002\000\003(\003\000\003(\004\000\004\000\001\000\004\000\002\000\011\172\001\000\004(\001\000\002\\\001\000\002X\001\000\002T\001\000\002P\001\000\002\\\002\000\002X\002\000\002\\\003\000\002\\\004\000\002\\\005\000\005\184\001\000\005\184\002\000\003X\001\000\003T\001\000\003T\002\000\003X\002\000\003X\003\000\005\252\001\000\005\240\001\000\005\252\002\000\005\252\003\000\005\232\001\000\005\232\002\000\b\180\001\000\003\\\001\000\b\180\002\000\005\232\003\000\005\232\004\000\005\248\001\000\006\004\001\000\006\000\001\000\005\244\001\000\005\232\005\000\006\004\002\000\012\240\001\000\012\236\001\000\012\240\002\000\012\236\002\000\012\240\003\000\012\236\003\000\r\b\001\000\r\004\001\000\r\b\002\000\012\240\004\000\012\240\005\000\000H\001\000\012\236\004\000\012\236\005\000\000H\001\000\012\236\006\000\b\164\001\000\b\164\002\000\b\164\003\000\001\180\001\000\b\164\004\000\b\164\005\000\001\180\001\000\012d\001\000\r\000\001\000\012\252\001\000\012\248\001\000\012\244\001\000\r\000\002\000\012\252\002\000\r\000\003\000\012\252\003\000\012\252\004\000\012\252\005\000\006\004\001\000\006\000\001\000\005\244\001\000\006\000\002\000\006\004\001\000\006\000\003\000\006\000\001\000\005\244\001\000\005\244\002\000\005\152\001\000\005x\001\000\005X\001\000\005x\002\000\005X\002\000\005X\003\000\003\144\001\000\005x\003\000\006\020\001\000\005t\001\000\006\b\001\000\r\000\004\000\r\000\005\000\006\004\001\000\006\000\001\000\005\244\001\000\012\248\002\000\012\244\002\000\005\136\001\000\012\244\003\000\012\244\004\000\005\152\001\000\005X\001\000\005\136\002\000\012\248\003\000\012\248\004\000\005\152\001\000\005X\001\000\b\228\001\000\b\232\001\000\006\004\003\000\b\232\002\000\b\232\003\000\b\176\001\000\006\004\001\000\006\000\001\000\005\252\004\000\005\244\001\000\006\004\001\000\006\000\001\000\005\244\001\000\005\240\002\000\005\240\003\000\006\004\001\000\006\000\001\000\005\244\001\000\003X\004\000\003X\005\000\005\184\003\000\005\184\004\000\005\188\001\000\005\204\001\000\005\200\001\000\005\192\001\000\005\184\005\000\007\136\001\000\007\132\001\000\007\128\001\000\007|\001\000\007x\001\000\007t\001\000\005\204\002\000\005\204\003\000\007x\002\000\007t\002\000\005\204\001\000\005\200\001\000\005\192\001\000\007x\003\000\007t\003\000\007t\004\000\006\004\001\000\006\000\001\000\005\244\001\000\007t\005\000\005\200\002\000\005\192\002\000\005\196\001\000\005\136\001\000\005\208\001\000\005\204\001\000\005\200\001\000\005\192\001\000\002\\\006\000\002\\\007\000\n\128\001\000\001l\001\000\nD\001\000\n@\001\000\t@\001\000\t<\001\000\t8\001\000\007H\001\000\nh\001\000\012\168\001\000\005|\001\000\t\224\001\000\t\220\001\000\002\128\001\000\002\128\002\000\002\128\003\000\n\020\001\000\n\016\001\000\n\020\002\000\n\016\002\000\n\020\003\000\n\016\003\000\002p\001\000\002l\001\000\002p\002\000\002l\002\000\002p\003\000\002l\003\000\t`\001\000\002\024\001\000\t`\002\000\002\024\002\000\t`\003\000\002\024\003\000\b\212\001\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\005\016\001\000\005\012\001\000\005\b\001\000\005\012\002\000\002`\001\000\002`\002\000\002`\003\000\004\004\001\000\b\172\001\000\0030\001\000\003,\001\000\b\172\002\000\002`\004\000\0078\001\000\0078\002\000\000l\001\000\000`\001\000\002`\005\000\002`\006\000\002D\001\000\002\024\001\000\002D\002\000\002\024\002\000\002D\003\000\002\024\003\000\b\216\001\000\002D\004\000\002\024\004\000\b\216\002\000\b\216\003\000\b\208\001\000\002\016\001\000\002\012\001\000\002\016\002\000\002\012\002\000\002\016\003\000\002\012\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\002\016\004\000\002\012\004\000\002\016\005\000\002x\001\000\002x\002\000\002x\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\002x\004\000\002x\005\000\n<\001\000\n(\001\000\005\140\001\000\nX\001\000\nT\001\000\nH\001\000\n<\002\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\nX\002\000\nX\003\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\nT\002\000\nT\003\000\n\b\002\000\n\000\002\000\t\248\002\000\t\248\003\000\002\024\001\000\002\024\002\000\002\024\003\000\b\216\001\000\002\024\004\000\002|\001\000\002|\002\000\002|\003\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\002|\004\000\nH\002\000\n\012\002\000\n\004\002\000\t\252\002\000\t\244\002\000\t\240\002\000\t\236\002\000\t\236\003\000\002\228\001\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\003 \001\000\003\028\001\000\003\024\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\132\001\000\002L\001\000\003\220\001\000\003\216\001\000\003\220\002\000\003\220\003\000\012L\001\000\012L\002\000\001\180\001\000\012H\001\000\012D\001\000\012H\002\000\012D\002\000\001\180\001\000\012H\003\000\012H\004\000\001\180\001\000\003\220\004\000\003\220\005\000\003\216\002\000\003\224\001\000\003\224\002\000\003\228\001\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\003\228\002\000\n4\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n|\001\000\nx\001\000\nl\001\000\nd\001\000\nP\001\000\nL\001\000\005\144\001\000\005\136\001\000\001\140\001\000\001\136\001\000\n\140\002\000\n\136\002\000\n\132\002\000\n|\002\000\nx\002\000\nl\002\000\nd\002\000\nP\002\000\nL\002\000\005\144\002\000\005\136\002\000\001\140\002\000\012\164\001\000\n\140\003\000\nd\003\000\nL\003\000\001\140\003\000\nd\004\000\006\220\001\000\000@\001\000\006\216\001\000\000<\001\000\n\140\004\000\n\140\005\000\n\140\006\000\n\140\007\000\005\204\001\000\005\200\001\000\005\192\001\000\n\140\b\000\n\140\t\000\006\004\001\000\006\000\001\000\005\244\001\000\n\140\n\000\012\004\001\000\006\232\001\000\012\000\001\000\006\228\001\000\006\156\001\000\002\240\001\000\007\228\001\000\004L\001\000\004L\002\000\004L\003\000\001\180\001\000\004L\004\000\004L\005\000\t\020\001\000\002\136\001\000\t\020\002\000\n4\001\000\002\144\001\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\002\144\002\000\012\176\001\000\n\\\001\000\n0\001\000\n,\001\000\005\004\001\000\001\240\001\000\001\240\002\000\001\240\003\000\005\000\001\000\004,\001\000\002\236\001\000\002\236\002\000\002\236\003\000\t\\\001\000\003@\001\000\003<\001\000\0038\001\000\0034\001\000\003$\001\000\002\244\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\020\001\000\002\188\002\000\003$\001\000\002\244\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\001\000\002\160\001\000\002\156\001\000\002\152\001\000\002\148\001\000\002\020\001\000\002\176\002\000\t\024\001\000\002\176\003\000\t\024\002\000\t\024\003\000\t\024\001\000\n0\001\000\002\140\001\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\002\140\002\000\002\232\001\000\t\024\001\000\002\232\002\000\002\172\002\000\t\024\001\000\002\172\003\000\002\168\002\000\t\024\001\000\002\168\003\000\002\192\002\000\t\024\001\000\002\192\003\000\002\208\002\000\t\024\001\000\002\208\003\000\002\184\002\000\t\024\001\000\002\184\003\000\002\180\002\000\t\024\001\000\002\180\003\000\002\200\002\000\t\024\001\000\002\200\003\000\002\164\002\000\t\024\001\000\002\164\003\000\002\160\002\000\t\024\001\000\002\160\003\000\002\156\002\000\t\024\001\000\002\156\003\000\002\152\002\000\t\024\001\000\002\152\003\000\002\148\002\000\t\024\001\000\002\148\003\000\002\204\002\000\t\024\001\000\002\204\003\000\002\196\002\000\t\024\001\000\002\196\003\000\002\224\002\000\t\024\001\000\002\224\003\000\002\244\002\000\t\024\001\000\002\244\003\000\002\212\002\000\t\024\001\000\002\212\003\000\002\216\002\000\t\024\001\000\002\216\003\000\002\220\002\000\t\024\001\000\002\220\003\000\003$\002\000\t\024\001\000\002\188\003\000\003@\002\000\003<\002\000\0038\002\000\003@\003\000\003@\004\000\003@\005\000\t\024\001\000\003<\003\000\000L\001\000\000L\002\000\n\148\001\000\004$\001\000\004$\002\000\004$\003\000\001\180\001\000\004$\004\000\004$\005\000\b\012\001\000\b\004\001\000\007\252\001\000\007\248\001\000\007\224\001\000\004 \001\000\004 \002\000\004 \003\000\007\224\002\000\007\224\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\248\002\000\007\248\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\b\012\002\000\b\012\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\b\004\002\000\b\004\003\000\007\252\002\000\b\000\001\000\b\b\001\000\007\220\001\000\007\220\002\000\007\220\003\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\004\b\001\000\000L\003\000\b<\001\000\b<\002\000\b(\001\000\b$\001\000\b(\002\000\b$\002\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\b(\003\000\b(\004\000\011\232\001\000\011\228\001\000\006\012\001\000\006\012\002\000\006\012\003\000\006\012\004\000\006\012\005\000\007P\001\000\007P\002\000\006\004\001\000\006\000\001\000\005\244\001\000\006\012\006\000\004\160\001\000\004\160\002\000\006\012\007\000\011\232\002\000\011\228\002\000\011\232\003\000\011\228\003\000\011\232\004\000\011\232\005\000\005\160\001\000\005\204\001\000\005\200\001\000\005\192\001\000\005\160\002\000\005\164\001\000\006\004\001\000\006\000\001\000\005\244\001\000\005\164\002\000\005\164\003\000\005\204\001\000\005\200\001\000\005\192\001\000\005\164\004\000\011\232\006\000\011\232\007\000\004x\001\000\004x\002\000\004x\003\000\004x\004\000\004x\005\000\004x\006\000\005\168\001\000\005\168\002\000\011\232\b\000\011\228\004\000\011\228\005\000\011\228\006\000\003\168\001\000\003\168\002\000\0028\001\000\0028\002\000\011\252\001\000\011\252\002\000\011\252\003\000\011\252\004\000\005\204\001\000\005\200\001\000\005\192\001\000\011\252\005\000\b@\001\000\b@\002\000\b@\003\000\b@\004\000\b@\005\000\b\204\001\000\b0\001\000\b\204\002\000\b\204\003\000\b0\002\000\b0\003\000\001\180\001\000\b@\006\000\b@\007\000\006D\001\000\006@\001\000\006D\002\000\b@\b\000\b@\t\000\b,\001\000\001\180\001\000\011\168\001\000\td\001\000\011\168\002\000\td\002\000\011\168\003\000\td\003\000\001|\001\000\001\128\001\000\001p\001\000\001\128\002\000\001\128\003\000\001l\001\000\011\168\004\000\td\004\000\003d\001\000\001\164\001\000\006\028\001\000\003\180\001\000\003\176\001\000\003\180\002\000\003\176\002\000\003\180\003\000\003\176\003\000\b\204\001\000\b8\001\000\b8\002\000\b8\003\000\000H\001\000\003\180\004\000\003\176\004\000\003\180\005\000\003\176\005\000\003\180\006\000\003\180\007\000\b4\001\000\000H\001\000\001\164\002\000\001\164\003\000\003\192\001\000\003\188\001\000\003\192\002\000\003\184\001\000\t\b\001\000\001\160\001\000\t\b\002\000\001\160\002\000\t\b\003\000\001\160\003\000\000l\001\000\000`\001\000\003d\002\000\t\004\001\000\001\156\001\000\000l\001\000\000`\001\000\011\168\005\000\001\144\001\000\001p\001\000\005\136\001\000\001\140\001\000\001\136\001\000\005\136\002\000\001\140\002\000\001\140\003\000\011\168\006\000\011\168\007\000\011\168\b\000\003t\001\000\003p\001\000\003l\001\000\003h\001\000\b\204\001\000\003t\002\000\003l\002\000\003t\003\000\003l\003\000\003l\004\000\003l\005\000\003l\006\000\000l\001\000\000`\001\000\t\004\001\000\003t\004\000\001\156\001\000\000l\001\000\000`\001\000\003h\002\000\003h\003\000\003h\004\000\000l\001\000\000`\001\000\t\004\001\000\003p\002\000\001\156\001\000\000l\001\000\000`\001\000\td\005\000\td\006\000\td\007\000\001\132\001\000\b \001\000\b\028\001\000\t\136\001\000\t\132\001\000\003\140\001\000\003\136\001\000\003\132\001\000\003\128\001\000\t\136\002\000\t\132\002\000\003\140\002\000\003\136\002\000\003\132\002\000\003\128\002\000\t\136\003\000\t\132\003\000\003\140\003\000\003\136\003\000\003\132\003\000\003\128\003\000\t\136\004\000\003\140\004\000\003\132\004\000\t\136\005\000\003\140\005\000\003\132\005\000\005L\001\000\003\140\006\000\003\132\006\000\003\132\007\000\001\212\001\000\001\208\001\000\001\204\001\000\001l\001\000\006p\001\000\006p\002\000\006p\003\000\006`\001\000\003x\001\000\001\168\001\000\003x\002\000\003x\003\000\003x\004\000\bx\001\000\001\172\001\000\003x\001\000\bx\002\000\003\132\b\000\b\164\001\000\003\132\t\000\003\132\n\000\bp\001\000\bt\001\000\006|\001\000\006x\001\000\006l\001\000\006h\001\000\006\\\001\000\006X\001\000\006H\001\000\001\180\001\000\006|\002\000\006x\002\000\006l\002\000\006h\002\000\006\\\002\000\006X\002\000\006|\003\000\006l\003\000\006\\\003\000\006|\004\000\006|\005\000\006|\006\000\006l\004\000\006\\\004\000\003|\001\000\003|\002\000\003|\003\000\006x\003\000\006x\004\000\006x\005\000\006h\003\000\006X\003\000\006P\001\000\003\140\007\000\b\164\001\000\003\140\b\000\003\140\t\000\t\136\006\000\t\136\007\000\bH\001\000\t\136\b\000\t\136\t\000\b\156\001\000\t\136\n\000\b\156\002\000\b\148\001\000\b\152\001\000\t\132\004\000\003\136\004\000\003\128\004\000\005L\001\000\003\136\005\000\003\128\005\000\003\128\006\000\003\128\007\000\b\164\001\000\003\128\b\000\003\128\t\000\003\136\006\000\b\164\001\000\003\136\007\000\003\136\b\000\t\132\005\000\t\132\006\000\t\132\007\000\t\132\b\000\b\156\001\000\t\132\t\000\004\168\001\000\006\148\001\000\006\144\001\000\006\148\002\000\006\148\003\000\006\148\004\000\006\148\005\000\005\152\001\000\005X\001\000\006\148\006\000\006\144\002\000\006\144\003\000\006\144\004\000\005\152\001\000\005X\001\000\006\144\005\000\t\156\001\000\t\148\001\000\t\144\001\000\006\016\001\000\006\012\001\000\005\224\001\000\006\016\002\000\006\012\002\000\006\016\003\000\006\012\003\000\006\016\004\000\006\012\004\000\006\016\005\000\006\012\005\000\006\016\006\000\006\016\007\000\006\004\001\000\006\000\001\000\005\244\001\000\006\016\b\000\t\156\002\000\t\148\002\000\t\144\002\000\005\224\002\000\t\156\003\000\t\148\003\000\t\144\003\000\005\224\003\000\005\224\004\000\005\216\001\000\005\224\005\000\005\224\006\000\005\152\001\000\005X\001\000\005\224\007\000\t\156\004\000\t\156\005\000\t\156\006\000\t\156\007\000\006\004\001\000\006\000\001\000\005\244\001\000\t\156\b\000\004\128\001\000\004\128\002\000\004\128\003\000\004\128\004\000\006\004\001\000\006\000\001\000\005\244\001\000\004\128\005\000\004\128\006\000\004\128\007\000\t\156\t\000\t\148\004\000\t\144\004\000\t\148\005\000\t\148\006\000\005\136\001\000\t\148\007\000\005\172\001\000\006\004\001\000\006\000\001\000\005\244\001\000\005\172\002\000\t\144\005\000\t\144\006\000\005\176\001\000\005\176\002\000\t\172\001\000\t\172\002\000\t\172\003\000\t\172\004\000\006\004\001\000\006\000\001\000\005\244\001\000\t\172\005\000\td\001\000\td\002\000\td\003\000\td\004\000\t\176\001\000\001T\001\000\001T\002\000\001T\003\000\001T\004\000\012\208\001\000\001T\005\000\002@\001\000\t\000\001\000\002@\002\000\002@\003\000\001T\006\000\001T\007\000\001T\b\000\001 \001\000\001 \002\000\000\244\001\000\001\180\001\000\000\244\002\000\000\244\003\000\001 \003\000\001\000\001\000\001\000\002\000\0060\001\000\006(\001\000\0060\002\000\006,\001\000\006$\001\000\006,\002\000\001\000\003\000\001\000\004\000\001\000\005\000\001\180\001\000\001\000\006\000\001\000\007\000\001\004\001\000\001\004\002\000\b\\\001\000\bT\001\000\b\\\002\000\bX\001\000\bP\001\000\bX\002\000\001\004\003\000\001\004\004\000\001\004\005\000\001\004\006\000\001\004\007\000\000\252\001\000\000\252\002\000\001,\001\000\001(\001\000\001,\002\000\001(\002\000\001,\003\000\001,\004\000\005\136\001\000\001,\005\000\001,\006\000\001\024\001\000\b\248\001\000\001\024\002\000\001\024\003\000\001\024\004\000\b\248\002\000\b\248\003\000\001\180\001\000\b\244\001\000\001\180\001\000\001\028\001\000\001\020\001\000\001,\007\000\001$\001\000\001$\002\000\001(\003\000\005\136\001\000\001(\004\000\001(\005\000\001(\006\000\001$\001\000\001$\001\000\000\252\003\000\000\252\004\000\001\b\001\000\001\b\002\000\001\180\001\000\001\152\001\000\001\152\002\000\001\180\001\000\001\152\003\000\001\b\003\000\001\b\004\000\001 \004\000\001 \005\000\001\012\001\000\001\012\002\000\001\016\001\000\004\196\001\000\004\196\002\000\001T\t\000\001$\001\000\001T\n\000\004p\001\000\004p\002\000\004p\003\000\004p\004\000\004p\005\000\004p\006\000\004p\007\000\001$\001\000\004p\b\000\004p\t\000\001T\011\000\t\176\002\000\t\176\003\000\t\176\004\000\t\176\005\000\t\176\006\000\t\176\007\000\005L\001\000\001L\001\000\001L\002\000\001L\003\000\001L\004\000\001\212\001\000\001\208\001\000\001\204\001\000\001\024\001\000\t(\001\000\b\244\001\000\001\180\001\000\001P\001\000\001P\002\000\001H\001\000\001H\002\000\001H\003\000\012X\001\000\001X\001\000\0024\001\000\001\028\001\000\001H\004\000\001D\001\000\001$\001\000\001P\003\000\001L\005\000\t\176\b\000\t\176\t\000\004h\001\000\004h\002\000\004h\003\000\004h\004\000\004h\005\000\004h\006\000\004h\007\000\004h\b\000\004h\t\000\t\176\n\000\tt\001\000\004\172\001\000\t\140\001\000\tx\001\000\t\168\001\000\t\164\001\000\t\160\001\000\t\152\001\000\004\172\002\000\tl\001\000\tl\002\000\t|\001\000\004\144\001\000\004\144\002\000\004\144\003\000\004\144\004\000\004\144\005\000\b\164\001\000\004\144\006\000\004\144\007\000\004\144\b\000\t|\002\000\t\128\001\000\004\152\001\000\004\152\002\000\004\152\003\000\004\152\004\000\004\152\005\000\004\152\006\000\b\164\001\000\004\152\007\000\004\152\b\000\004\152\t\000\t\128\002\000\tp\001\000\t\180\001\000\004\168\002\000\b\028\002\000\th\001\000\b \002\000\001\180\001\000\011\244\001\000\001T\001\000\011\244\002\000\011\244\003\000\011\244\004\000\011\244\005\000\011\244\006\000\000\208\001\000\001@\001\000\001@\002\000\001@\003\000\000\184\001\000\012\196\001\000\012\188\001\000\012\196\002\000\012\188\002\000\012\196\003\000\012\188\003\000\012\196\004\000\012\188\004\000\012\188\005\000\012\188\006\000\012\196\005\000\012\196\006\000\012\196\007\000\000\184\002\000\000\184\003\000\012\192\001\000\012\184\001\000\012\180\001\000\012\220\001\000\012\212\001\000\012\220\002\000\012\216\001\000\006\028\001\000\012\216\002\000\012\180\002\000\012\180\003\000\012\180\004\000\012\180\005\000\001\180\001\000\012\192\002\000\012\184\002\000\012\192\003\000\012\184\003\000\012\184\004\000\012\184\005\000\012\192\004\000\012\192\005\000\012\192\006\000\000\188\001\000\005H\001\000\005@\001\000\0058\001\000\005H\002\000\005@\002\000\0058\002\000\005H\003\000\005@\003\000\0058\003\000\005H\004\000\005@\004\000\0058\004\000\005H\005\000\005@\005\000\005H\006\000\005H\007\000\005H\b\000\005H\t\000\001\180\001\000\005H\n\000\005H\011\000\005@\006\000\005@\007\000\005@\b\000\0058\005\000\011\176\001\000\007h\001\000\011\176\002\000\011\176\003\000\002H\001\000\011\176\004\000\b\168\001\000\000\188\002\000\000\188\003\000\005D\001\000\005<\001\000\0054\001\000\0050\001\000\012\232\001\000\012\224\001\000\012\232\002\000\012\228\001\000\bH\001\000\012\228\002\000\0050\002\000\0050\003\000\0050\004\000\0050\005\000\005D\002\000\005<\002\000\0054\002\000\005D\003\000\005<\003\000\0054\003\000\005D\004\000\005<\004\000\005D\005\000\005D\006\000\005D\007\000\005D\b\000\001\180\001\000\005D\t\000\005D\n\000\005<\005\000\005<\006\000\005<\007\000\0054\004\000\000\196\001\000\000\196\002\000\000\196\003\000\000\196\004\000\000\180\001\000\000\176\001\000\000\180\002\000\000\180\003\000\001<\001\000\0010\001\000\0044\001\000\0040\001\000\000\160\001\000\000\156\001\000\0044\002\000\0044\003\000\0044\004\000\0044\005\000\0044\006\000\0044\007\000\000\160\002\000\000\156\002\000\000\160\003\000\000\160\004\000\005\136\001\000\000\160\005\000\000\160\006\000\0018\001\000\b\248\001\000\0018\002\000\0018\003\000\0018\004\000\000\148\001\000\000\148\002\000\000\224\001\000\000\220\001\000\000\220\002\000\0048\001\000\000\152\001\000\000\152\002\000\000\172\001\000\000\168\001\000\000\144\001\000\003\212\001\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\003\212\002\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\003\208\001\000\b\188\001\000\000\168\002\000\b\188\002\000\b\184\001\000\0014\001\000\000\164\001\000\000\152\003\000\000\164\002\000\0048\002\000\000\220\003\000\000\164\001\000\000\224\002\000\000\148\003\000\000\164\001\000\000\160\007\000\000\156\003\000\005\136\001\000\000\156\004\000\000\156\005\000\000\164\001\000\000\156\006\000\0040\002\000\0040\003\000\0040\004\000\0040\005\000\001<\002\000\0010\002\000\000\164\001\000\0010\003\000\001<\003\000\001<\004\000\001<\005\000\000\180\004\000\000\164\001\000\0070\001\000\0070\002\000\000\180\005\000\000\180\006\000\000\176\002\000\000\176\003\000\000\164\001\000\000\176\004\000\000\176\005\000\000\192\001\000\000\192\002\000\000\192\003\000\000\192\004\000\001@\004\000\001@\005\000\000\200\001\000\000\200\002\000\000\204\001\000\004\204\001\000\004\204\002\000\000\208\002\000\000\164\001\000\000\212\001\000\000\212\002\000\000\212\003\000\000\212\004\000\000\164\001\000\000\216\001\000\000\216\002\000\011\244\007\000\011\244\b\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\011\244\t\000\011\208\001\000\004\188\001\000\004(\001\000\004(\002\000\004(\003\000\004(\004\000\004(\005\000\004(\006\000\011\224\001\000\011\164\001\000\011\204\001\000\011\240\001\000\011\236\001\000\011\188\001\000\005\004\001\000\005\004\002\000\004\188\002\000\011\192\001\000\004,\001\000\004,\002\000\011\196\001\000\011\196\002\000\011\212\001\000\011\212\002\000\011\200\001\000\011\248\001\000\b\024\001\000\011\184\001\000\011\184\002\000\011\184\003\000\000\136\001\000\011\188\001\000\005\004\001\000\001\240\001\000\011\180\001\000\011\192\001\000\004,\001\000\002\236\001\000\0028\003\000\0028\004\000\003\168\003\000\003\168\004\000\b<\003\000\b<\004\000\000L\004\000\t\024\001\000\t\020\003\000\b\012\001\000\b\004\001\000\007\252\001\000\007\248\001\000\007\224\001\000\004P\001\000\004P\002\000\004P\003\000\004X\001\000\002\240\002\000\002\240\003\000\002\240\004\000\004X\002\000\004X\003\000\004T\001\000\n<\001\000\006\192\001\000\nL\004\000\nL\005\000\n|\003\000\nx\003\000\n|\004\000\nx\004\000\nx\005\000\t4\001\000\t0\001\000\t,\001\000\t\024\001\000\t4\002\000\t0\002\000\t4\003\000\n\136\003\000\n\132\003\000\n\136\004\000\n\132\004\000\n\132\005\000\nP\003\000\nP\004\000\nP\005\000\nl\003\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\bl\001\000\bl\002\000\bl\003\000\tX\001\000\tT\001\000\tP\001\000\tX\002\000\tT\002\000\tP\002\000\tX\003\000\tT\003\000\tP\003\000\tX\004\000\tT\004\000\tX\005\000\bh\001\000\nl\004\000\nl\005\000\n\140\001\000\n\136\001\000\n\132\001\000\n|\001\000\nx\001\000\nl\001\000\nd\001\000\nP\001\000\nL\001\000\005\144\001\000\005\136\001\000\005\128\001\000\001\140\001\000\001\136\001\000\n\140\002\000\n\136\002\000\n\132\002\000\n|\002\000\nx\002\000\nl\002\000\nd\002\000\nP\002\000\nL\002\000\005\144\002\000\005\136\002\000\005\128\002\000\001\140\002\000\012\168\001\000\005\128\003\000\005\144\003\000\n\b\002\000\n\000\002\000\t\248\002\000\003\028\002\000\003\020\002\000\003\012\002\000\t\248\003\000\003\012\003\000\t\248\004\000\003\012\004\000\t\248\005\000\003\012\005\000\003\012\006\000\t\024\001\000\003\012\007\000\n\b\003\000\003\028\003\000\n\b\004\000\003\028\004\000\n\b\005\000\003\028\005\000\003\028\006\000\t\024\001\000\003\028\007\000\n\000\003\000\003\020\003\000\n\000\004\000\003\020\004\000\n\000\005\000\003\020\005\000\003\020\006\000\t\024\001\000\003\020\007\000\nH\002\000\n\012\002\000\n\004\002\000\t\252\002\000\t\244\002\000\t\240\002\000\t\236\002\000\003 \002\000\003\024\002\000\003\016\002\000\003\b\002\000\003\004\002\000\003\000\002\000\002\252\002\000\t\236\003\000\003\000\003\000\t\236\004\000\003\000\004\000\t\236\005\000\003\000\005\000\003\000\006\000\t\024\001\000\003\000\007\000\t\244\003\000\003\b\003\000\t\244\004\000\003\b\004\000\t\244\005\000\003\b\005\000\003\b\006\000\t\024\001\000\003\b\007\000\t\240\003\000\003\004\003\000\t\240\004\000\003\004\004\000\t\240\005\000\003\004\005\000\003\004\006\000\t\024\001\000\003\004\007\000\n\012\003\000\n\004\003\000\t\252\003\000\005\136\001\000\005\128\001\000\003 \003\000\003\024\003\000\003\016\003\000\n\012\004\000\n\004\004\000\t\252\004\000\003 \004\000\003\024\004\000\003\016\004\000\t\252\005\000\003\016\005\000\t\252\006\000\003\016\006\000\t\252\007\000\003\016\007\000\003\016\b\000\t\024\001\000\003\016\t\000\n\012\005\000\003 \005\000\n\012\006\000\003 \006\000\n\012\007\000\003 \007\000\003 \b\000\t\024\001\000\003 \t\000\n\004\005\000\003\024\005\000\n\004\006\000\003\024\006\000\n\004\007\000\003\024\007\000\003\024\b\000\t\024\001\000\003\024\t\000\nH\003\000\002\252\003\000\002\252\004\000\t\024\001\000\002\252\005\000\b\188\001\000\002\132\002\000\t\024\001\000\002\228\002\000\t\236\004\000\t\236\005\000\t\244\003\000\t\244\004\000\t\244\005\000\t\240\003\000\t\240\004\000\t\240\005\000\n\012\003\000\n\004\003\000\t\252\003\000\005\136\001\000\005\128\001\000\n\012\004\000\n\004\004\000\t\252\004\000\t\252\005\000\t\252\006\000\t\252\007\000\n\012\005\000\n\012\006\000\n\012\007\000\n\004\005\000\n\004\006\000\n\004\007\000\nH\003\000\t\248\004\000\t\248\005\000\n\b\003\000\n\b\004\000\n\b\005\000\n\000\003\000\n\000\004\000\n\000\005\000\002x\006\000\001\232\001\000\001\236\001\000\002x\007\000\002x\b\000\002x\t\000\002x\n\000\002x\011\000\002\016\006\000\002\016\007\000\002\016\b\000\002\016\t\000\002\012\005\000\002\012\006\000\002\012\007\000\002\012\b\000\002\012\t\000\002\012\n\000\002\012\011\000\002`\007\000\005\012\003\000\005\012\004\000\005\012\005\000\005\016\002\000\005\b\002\000\005\016\003\000\005\b\003\000\b\212\002\000\t`\004\000\b\216\001\000\002\024\004\000\002p\004\000\002l\004\000\002p\005\000\002l\005\000\t\024\001\000\002p\006\000\002l\006\000\002l\007\000\t\024\001\000\002l\b\000\n\020\004\000\n\016\004\000\n\016\005\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\002\128\004\000\t\220\002\000\t\024\001\000\t\220\003\000\nX\001\000\nT\001\000\nH\001\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\t\224\002\000\nh\002\000\nh\003\000\t\024\001\000\007H\002\000\t@\002\000\t<\002\000\t8\002\000\t@\003\000\t<\003\000\t@\004\000\nD\002\000\n@\002\000\n@\003\000\n\128\002\000\n\128\003\000\002\\\b\000\002X\003\000\002X\004\000\005\204\001\000\005\200\001\000\005\192\001\000\002X\005\000\002X\006\000\002X\007\000\002P\002\000\002P\003\000\002P\004\000\002P\005\000\002P\006\000\002P\007\000\002P\b\000\002T\002\000\002T\003\000\002T\004\000\002T\005\000\002T\006\000\002T\007\000\002T\b\000\002T\t\000\011\172\002\000\004D\002\000\007`\002\000\003\232\004\000\003\232\005\000\003\236\002\000\012H\001\000\012D\001\000\004\028\002\000\004\024\002\000\004\028\003\000\004\028\004\000\004\028\005\000\004\028\006\000\001\180\001\000\004\028\007\000\004\028\b\000\b\204\001\000\004\024\003\000\004\024\004\000\004\024\005\000\001\180\001\000\004\024\006\000\004\024\007\000\004\020\002\000\004\020\003\000\004\020\004\000\004\016\002\000\004\252\005\000\004\252\006\000\t\024\001\000\002\248\003\000\nt\002\000\np\002\000\np\003\000\nX\001\000\nT\001\000\nH\001\000\n8\002\000\n\012\001\000\n\b\001\000\n\004\001\000\n\000\001\000\t\252\001\000\t\248\001\000\t\244\001\000\t\240\001\000\t\236\001\000\n \002\000\n\028\002\000\n \003\000\n\028\003\000\n \004\000\n\028\004\000\n \005\000\n\028\005\000\005\204\001\000\005\200\001\000\005\192\001\000\n\028\006\000\n \006\000\n \007\000\006\004\001\000\006\000\001\000\005\244\001\000\n \b\000\t\232\002\000\t\228\002\000\t\228\003\000\t\232\003\000\t\232\004\000\002d\004\000\002d\005\000\b\216\001\000\002d\006\000\001\244\004\000\001\244\005\000\b\216\001\000\001\244\006\000\t\024\001\000\007\136\004\000\007\132\004\000\007\128\004\000\007|\004\000\007|\005\000\007\136\005\000\007\136\006\000\006\004\001\000\006\000\001\000\005\244\001\000\007\136\007\000\007\132\005\000\007\128\005\000\007\132\006\000\007\128\006\000\006\004\001\000\006\000\001\000\005\244\001\000\007\128\007\000\007\132\007\000\007\132\b\000\006\004\001\000\006\000\001\000\005\244\001\000\007\132\t\000\006\140\005\000\005\204\001\000\005\200\001\000\005\192\001\000\006\140\006\000\006\136\002\000\006\136\003\000\006\136\004\000\005\204\001\000\005\200\001\000\005\192\001\000\006\136\005\000\004\184\002\000\004\184\003\000\004\184\004\000\004\180\002\000\002$\003\000\002$\004\000\005$\003\000\005\028\003\000\005\020\003\000\005$\004\000\005\028\004\000\005\020\004\000\005\028\005\000\005\020\005\000\005\028\006\000\005\020\006\000\005,\001\000\005\020\007\000\005(\001\000\005 \001\000\005\024\001\000\000l\001\000\000`\001\000\005 \002\000\005\024\002\000\005\024\003\000\006\132\002\000\006\128\002\000\006\128\003\000\003L\003\000\003L\004\000\003L\005\000\t\012\001\000\000p\002\000\000d\002\000\000p\003\000\000d\003\000\000p\004\000\000p\005\000\000d\004\000\t\012\002\000\t\012\003\000\001\180\001\000\t\016\001\000\001\196\002\000\001\180\001\000\t\016\002\000\t\016\003\000\001\180\001\000\006t\002\000\006t\003\000\006t\004\000\006d\002\000\006L\002\000\001\180\001\000\006T\002\000\012T\002\000\011\220\006\000\011\220\007\000\011\220\b\000\003x\001\000\002,\001\000\003x\002\000\002,\002\000\002,\003\000\002,\004\000\002,\005\000\011\220\t\000\b\144\001\000\b\140\001\000\011\220\n\000\b\140\002\000\b\144\002\000\b|\001\000\b\132\001\000\b\128\001\000\b\136\001\000\003|\001\000\0020\001\000\0020\002\000\0020\003\000\0020\004\000\011\216\004\000\003\136\004\000\005L\001\000\003\136\005\000\011\216\005\000\011\216\006\000\011\216\007\000\011\216\b\000\b\144\001\000\b\140\001\000\011\216\t\000\005\180\003\000\005\180\004\000\005\236\005\000\005\204\001\000\005\200\001\000\005\192\001\000\006\004\001\000\006\000\001\000\005\244\001\000\001\200\005\000\001\200\006\000\012\200\006\000\012\200\007\000\005\228\003\000\005\228\004\000\n\164\007\000\006\004\001\000\006\000\001\000\005\244\001\000\n\164\b\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\000\236\002\000\000\232\002\000\000\232\003\000\000\236\003\000\001\180\001\000\000\236\004\000\000\236\005\000\n$\004\000\n$\005\000\n$\006\000\002h\004\000\002h\005\000\b\216\001\000\002h\006\000\002\004\004\000\002\000\004\000\001\252\004\000\001\248\004\000\002\004\005\000\001\252\005\000\b\216\001\000\002\004\006\000\001\252\006\000\002\004\007\000\002\004\b\000\002\000\005\000\002\000\006\000\002t\004\000\002t\005\000\002t\006\000\002t\007\000\000\140\003\000\000\140\004\000\002\b\003\000\002\b\004\000\002\b\005\000\002\b\006\000\002\b\007\000\003\152\001\000\003\152\002\000\000\000\001\000\000\004\000\000\003\164\001\000\003\164\002\000\000\004\001\000\000\b\000\000\012\164\001\000\005`\001\000\001p\001\000\005`\002\000\005`\003\000\005d\001\000\000\b\001\000\005\152\001\000\005p\001\000\005l\001\000\005h\001\000\005X\001\000\005p\002\000\005l\002\000\005h\002\000\005X\002\000\012\164\001\000\005l\003\000\005l\004\000\005l\005\000\005p\003\000\005h\003\000\000P\001\000\005\\\001\000\000T\001\000\007\140\001\000\007\140\002\000\000\012\000\000\000\012\001\000\007\144\001\000\007\144\002\000\000\016\000\000\000\016\001\000\007\148\001\000\001\180\001\000\007\148\002\000\000\020\000\000\007\152\001\000\007\152\002\000\000\020\001\000\000\024\000\000\000\024\001\000\007\156\001\000\005\152\001\000\005X\001\000\007\156\002\000\000\028\000\000\000\028\001\000\007\160\001\000\005\136\001\000\007\160\002\000\000 \000\000\000 \001\000\007\164\001\000\005\204\001\000\005\200\001\000\005\192\001\000\007\164\002\000\000$\000\000\000$\001\000\007\168\001\000\006\004\001\000\006\000\001\000\005\244\001\000\007\168\002\000\000(\000\000\000(\001\000\007\172\001\000\007\172\002\000\000,\000\000\007\216\001\000\007\204\001\000\007\196\001\000\007\188\001\000\007\184\001\000\007\176\001\000\007\176\002\000\000,\001\000\0000\000\000\007\180\001\000\007\180\002\000\0000\001\000\005\144\001\000\005\136\001\000\005\144\002\000\005\136\002\000\0004\000\000\012(\001\000\012$\001\000\012 \001\000\012\028\001\000\012\024\001\000\012\020\001\000\012\016\001\000\012(\002\000\012$\002\000\012 \002\000\012\028\002\000\012\024\002\000\012\020\002\000\012\016\002\000\012(\003\000\012\020\003\000\012\024\003\000\012$\003\000\012\028\003\000\012 \003\000\005\144\001\000\005\136\001\000\0128\001\000\0004\001\000\0124\001\000\0124\002\000\004\212\001\000\004\212\002\000\012,\001\000\012,\002\000\012,\003\000\0120\001\000\0120\002\000\0008\000\000\004\224\001\000\004\220\001\000\004\232\001\000\004\228\001\000\004\228\002\000\004\232\002\000\004\224\002\000\004\224\003\000\004\224\004\000\004\220\002\000\0008\001\000\012\160\001\000\012\160\002\000\012\160\003\000\012\160\004\000\012\156\001\000\012\156\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\000[\000\\\000^\000_\000`\000b\000c\000d\000k\000l\000m\000n\000o\000p\000s\000t\000u\000w\000y\000{\000|\000}\000\127\000\128\000\129\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\156\000\158\000\159\000\160\000\162\000\164\000\165\000\167\000\169\000\171\000\172\000\174\000\176\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\194\000\195\000\196\000\198\000\199\000\200\000\201\000\202\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\222\000\226\000\230\000\231\000\233\000\234\000\236\000\238\000\239\000\240\000\241\000\244\000\245\000\246\000\247\000\248\000\249\000\250\000\251\000\252\000\254\000\255\001\000\001\001\001\003\001\005\001\006\001\b\001\012\001\018\001\020\001\021\001\022\001\024\001\028\001\031\001 \001!\001#\001$\001%\001&\001(\001)\001*\001+\0011\0015\0019\001:\001;\001<\001=\001?\001A\001B\001C\001D\001E\001F\001G\001H\001I\001J\001K\001L\001M\001N\001O\001P\001W\001Y\001[\001]\001^\001_\001`\001a\001b\001c\001e\001g\001h\001i\001j\001k\001l\001p\001q\001s\001t\001v\001x\001y\001z\001}\001~\001\129\001\130\001\133\001\134\001\135\001\136\001\137\001\139\001\140\001\141\001\142\001\143\001\144\001\145\001\146\001\148\001\149\001\151\001\152\001\153\001\157\001\160\001\162\001\163\001\164\001\165\001\166\001\167\001\168\001\169\001\170\001\171\001\175\001\176\001\179\001\180\001\181\001\182\001\183\001\185\001\186\001\187\001\189\001\190\001\191\001\192\001\193\001\196\001\197\001\198\001\199\001\201\001\202\001\203\001\204\001\206\001\207\001\208\001\209\001\211\001\212\001\214\001\215\001\217\001\218\001\220\001\222\001\223\001\224\001\225\001\227\001\228\001\230\001\231\001\234\001\235\001\236\001\238\001\239\001\240\001\241\001\243\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\b\002\t\002\n\002\011\002\012\002\019\002\025\002\028\002\029\002\030\002\031\002 \002!\002\"\002$\002%\002+\002,\0022\0023\0029\002:\002@\002A\002B\002C\002E\002K\002L\002O\002W\002X\002Z\002[\002\\\002]\002^\002_\002`\002c\002d\002e\002l\002m\002n\002p\002q\002w\002}\002~\002\127\002\133\002\134\002\136\002\137\002\138\002\139\002\147\002\149\002\150\002\151\002\157\002\161\002\164\002\165\002\166\002\167\002\168\002\169\002\170\002\171\002\177\002\179\002\180\002\182\002\183\002\185\002\186\002\187\002\188\002\190\002\191\002\192\002\193\002\194\002\197\002\199\002\200\002\201\002\208\002\209\002\211\002\212\002\213\002\214\002\215\002\216\002\224\002\225\002\226\002\227\002\228\002\229\002\230\002\235\002\237\002\238\002\239\002\240\002\241\002\242\002\244\002\245\002\246\002\247\002\249\002\250\002\251\002\252\002\253\002\255\003\000\003\001\003\002\003\003\003\007\003\b\003\n\003\012\003\014\003\016\003\017\003\018\003\020\003\021\003\023\003\025\003\026\003\028\003\029\003\031\003 \003$\003&\003(\003)\003-\003.\0032\0033\0036\0038\003:\003;\003<\003=\003>\003?\003C\003F\003G\003J\003K\003L\003O\003P\003R\003S\003T\003U\003Y\003]\003^\003b\003c\003d\003e\003f\003j\003q\003r\003w\003x\003y\003}\003~\003\127\003\128\003\130\003\131\003\135\003\136\003\138\003\140\003\143\003\144\003\145\003\147\003\148\003\149\003\150\003\151\003\152\003\154\003\156\003\158\003\160\003\162\003\164\003\166\003\168\003\170\003\171\003\179\003\180\003\181\003\182\003\183\003\184\003\186\003\187\003\188\003\189\003\190\003\193\003\194\003\195\003\197\003\199\003\201\003\204\003\205\003\206\003\207\003\209\003\211\003\213\003\220\003\221\003\222\003\223\003\224\003\230\003\231\003\232\003\233\003\234\003\247\003\248\004\005\004\006\004\007\004\n\004\011\004\012\004\r\004\014\004\016\004\017\004\018\004\019\004 \004'\004(\004)\004A\004C\004D\004E\004F\004H\004J\004M\004N\004P\004Q\004R\004S\004T\004U\004V\004c\004d\004q\004}\004\130\004\131\004\133\004\135\004\136\004\137\004\138\004\142\004\143\004\147\004\148\004\150\004\152\004\154\004\156\004\157\004\159\004\160\004\161\004\163\004\164\004\166\004\179\004\180\004\181\004\182\004\183\004\185\004\186\004\187\004\188\004\190\004\191\004\192\004\193\004\220\004\221\004\244\004\245\004\247\004\248\004\250\004\252\005\t\005\n\005\012\005\r\005\015\005\016\005\018\005\019\005\021\005\022\005\024\005\025\005\027\005\028\005\030\005\031\005!\005\"\005$\005%\005'\005(\005*\005+\005-\005.\0050\0051\0053\0054\0056\0057\0059\005:\005<\005=\005?\005@\005B\005C\005E\005F\005H\005K\005L\005M\005N\005O\005P\005Q\005R\005T\005U\005W\005X\005Y\005_\005`\005a\005b\005h\005i\005o\005p\005v\005w\005x\005y\005z\005|\005}\005\131\005\132\005\133\005\134\005\135\005\137\005\144\005\145\005\146\005\149\005\150\005\151\005\152\005\153\005\154\005\158\005\159\005\160\005\161\005\162\005\164\005\166\005\167\005\168\005\169\005\173\005\174\005\178\005\179\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\208\005\209\005\210\005\211\005\212\005\213\005\214\005\216\005\217\005\218\005\219\005\221\005\222\005\223\005\225\005\226\005\227\005\228\005\230\005\232\005\234\005\236\005\237\005\239\005\240\005\241\005\242\005\244\005\245\005\246\005\247\005\249\005\251\005\253\005\255\006\000\006\002\006\004\006\006\006\007\006\b\006\n\006\011\006\012\006\014\006\015\006\016\006\018\006\020\006\024\006\025\006\029\006\030\006 \006#\006%\006&\006'\006(\006)\006-\0060\0062\0063\0064\0067\006<\006=\006>\006A\006F\006G\006H\006I\006J\006L\006R\006X\006^\006a\006d\006g\006h\006l\006m\006n\006o\006p\006r\006s\006t\006u\006w\006x\006y\006z\006|\006}\006~\006\127\006\135\006\141\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\161\006\162\006\163\006\164\006\165\006\166\006\168\006\169\006\170\006\171\006\172\006\175\006\178\006\179\006\180\006\182\006\183\006\184\006\186\006\187\006\188\006\189\006\190\006\192\006\193\006\194\006\196\006\197\006\198\006\199\006\202\006\203\006\204\006\205\006\208\006\209\006\215\006\217\006\219\006\221\006\223\006\224\006\228\006\229\006\233\006\237\006\239\006\240\006\243\006\244\006\245\006\246\006\247\006\251\006\252\006\253\006\254\006\255\007\000\007\004\007\005\007\006\007\007\007\t\007\n\007\012\007\r\007\014\007\018\007\019\007\020\007\021\007\022\007\023\007\024\007\025\007\029\007\030\007\031\007 \007!\007\"\007$\007%\007&\007'\007(\007)\007*\007,\007-\007.\007/\0070\0071\0072\0073\0075\0076\0077\0078\0079\007;\007<\007>\007?\007@\007A\007B\007D\007E\007F\007G\007I\007J\007L\007M\007N\007O\007P\007Q\007R\007S\007T\007V\007X\007Y\007Z\007\\\007]\007^\007`\007a\007b\007c\007e\007g\007h\007i\007k\007l\007m\007o\007p\007r\007t\007u\007v\007w\007y\007z\007|\007}\007~\007\127\007\128\007\129\007\130\007\131\007\132\007\133\007\135\007\136\007\137\007\138\007\139\007\140\007\141\007\142\007\144\007\145\007\146\007\147\007\148\007\149\007\150\007\151\007\152\007\153\007\155\007\156\007\157\007\158\007\162\007\165\007\166\007\167\007\168\007\169\007\170\007\172\007\174\007\175\007\177\007\178\007\179\007\180\007\181\007\182\007\183\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\210\007\211\007\212\007\213\007\214\007\215\007\216\007\217\007\218\007\219\007\220\007\222\007\223\007\224\007\225\007\226\007\227\007\228\007\229\007\230\007\232\007\234\007\235\007\236\007\237\007\238\007\239\007\240\007\241\007\242\007\243\007\244\007\246\007\248\007\250\007\252\007\253\007\254\007\255\b\000\b\001\b\002\b\003\b\006\b\b\b\t\b\011\b\012\b\r\b\014\b\015\b\017\b\019\b\021\b\022\b\023\b\024\b\025\b\026\b\027\b\030\b!\b$\b'\b)\b*\b+\b,\b.\b/\b0\b1\b2\b3\b4\b5\b6\b7\b8\b9\b:\b;\b<\b=\bA\bC\bD\bF\bG\bH\bI\bJ\bK\bN\bQ\bS\bT\bU\bV\bX\bY\bZ\b[\b\\\b]\b^\b_\b`\ba\bb\bd\be\bf\bh\bl\bm\bn\bo\bp\bq\br\bt\bu\bv\bx\by\bz\b|\b}\b~\b\127\b\128\b\130\b\131\b\133\b\134\b\135\b\137\b\138\b\151\b\164\b\166\b\167\b\168\b\169\b\171\b\172\b\173\b\175\b\176\b\177\b\179\b\180\b\182\b\183\b\185\b\186\b\187\b\188\b\189\b\192\b\193\b\194\b\195\b\196\b\198\b\199\b\200\b\201\b\202\b\203\b\205\b\206\b\207\b\208\b\209\b\210\b\211\b\212\b\213\b\214\b\215\b\216\b\217\b\218\b\220\b\221\b\222\b\223\b\225\b\226\b\227\b\228\b\229\b\230\b\231\b\232\b\233\b\234\b\235\b\236\b\237\b\238\b\239\b\240\b\241\b\242\b\243\b\244\b\245\b\246\b\247\b\248\b\249\b\250\b\251\b\253\b\254\b\255\t\001\t\002\t\003\t\004\t\005\t\006\t\007\t\b\t\t\t\n\t\011\t\012\t\r\t\016\t\017\t\020\t\021\t\022\t\023\t\024\t\025\t\026\t\027\t\029\t#\t$\t%\t'\t(\t)\t*\t+\t,\t.\t/\t0\t2\t3\t4\t5\t9\t;\t<\t>\t?\t@\tA\tB\tC\tD\tE\tR\tS\tT\tW\tZ\t]\t_\t`\ta\tb\tc\tq\t~\t\128\t\129\t\135\t\137\t\139\t\141\t\142\t\144\t\146\t\148\t\150\t\151\t\153\t\155\t\157\t\159\t\160\t\162\t\176\t\178\t\180\t\182\t\183\t\185\t\187\t\189\t\191\t\192\t\194\t\196\t\198\t\200\t\201\t\203\t\211\t\217\t\219\t\221\t\223\t\224\t\226\t\228\t\230\t\232\t\233\t\235\t\237\t\239\t\241\t\242\t\244\t\246\t\247\t\249\t\251\t\253\t\254\t\255\n\000\n\001\n\002\n\003\n\004\n\005\n\n\n\r\n\014\n\015\n\016\n\017\n\018\n\019\n\020\n\021\n\022\n\023\n\024\n\025\n\026\n\027\n\028\n\029\n\030\n\031\n \n!\n\"\n#\n$\n%\n&\n'\n(\n)\n*\n+\n,\n-\n.\n/\n0\n1\n2\n3\n4\n5\n6\n8\n9\n:\n;\n>\n@\nB\nE\nF\nH\nI\nJ\nK\nX\nZ\n[\nh\ni\nj\nl\no\nq\nr\ns\nt\nu\nv\nw\nx\ny\nz\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\140\n\141\n\142\n\143\n\144\n\145\n\146\n\147\n\148\n\149\n\153\n\154\n\155\n\156\n\158\n\159\n\160\n\162\n\163\n\165\n\166\n\167\n\168\n\169\n\170\n\171\n\172\n\173\n\175\n\176\n\177\n\178\n\191\n\193\n\195\n\197\n\202\n\203\n\204\n\208\n\209\n\211\n\212\n\213\n\214\n\215\n\216\n\218\n\219\n\220\n\222\n\227\n\228\n\229\n\233\n\234\n\236\n\241\n\242\n\243\n\247\n\248\n\252\n\253\n\254\n\255\011\003\011\004\011\005\011\006\011\007\011\b\011\t\011\n\011\r\011\016\011\018\011\020\011\021\011\022\011\027\011\029\011\030\011\031\011 \011!\011\"\011#\011$\011'\011)\011*\011+\011,\011-\011/\0112\0113\0115\0116\0117\0118\0119\011;\011<\011=\011>\011?\011@\011B\011D\011E\011F\011G\011J\011K\011L\011M\011N\011O\011P\011Q\011S\011T\011U\011V\011X\011Z\011[\011\\\011]\011`\011a\011b\011c\011g\011k\011l\011m\011n\011o\011p\011t\011u\011|\011}\011~\011\128\011\129\011\130\011\131\011\132\011\133\011\134\011\136\011\140\011\142\011\145\011\146\011\147\011\148\011\149\011\150\011\151\011\152\011\153\011\154\011\155\011\156\011\157\011\158\011\159\011\160\011\161\011\162\011\163\011\164\011\165\011\166\011\167\011\168\011\171\011\172\011\173\011\174\011\175\011\180\011\184\011\186\011\187\011\188\011\189\011\190\011\191\011\192\011\193\011\194\011\195\011\196\011\197\011\198\011\199\011\200\011\201\011\203\011\204\011\205\011\206\011\207\011\208\011\209\011\210\011\213\011\214\011\215\011\216\011\218\011\219\011\220\011\221\011\225\011\226\011\227\011\228\011\232\011\233\011\234\011\235\011\236\011\237\011\238\011\244\011\245\011\246\011\247\011\248\011\249\011\250\011\252\011\254\011\255\012\006\012\r\012\014\012\015\012\016\012\017\012\018\012\021\012\022\012\023\012\024\012\025\012\026\012\027\012\028\012\029\012\030\012\031\012 \012!\012#\012$\012%\012&\012'\012(\012)\012*\012+\012,\012-\012.\012/\0120\0121\0122")) + ((32, "\000\000\000\000\000\002X\001\000\001\244\001\000\0124\001\000\0120\001\000\012,\001\000\012(\001\000\012$\001\000\011p\001\000\012 \001\000\012\028\001\000\012\024\001\000\012\020\001\000\012\016\001\000\012\012\001\000\012\b\001\000\012\004\001\000\012\000\001\000\011\252\001\000\011\248\001\000\011\244\001\000\011\240\001\000\011\236\001\000\011\232\001\000\011\228\001\000\011\224\001\000\011\220\001\000\011\216\001\000\011l\001\000\011\212\001\000\011\208\001\000\011\204\001\000\011\200\001\000\011\196\001\000\011\192\001\000\011\188\001\000\011\184\001\000\011\180\001\000\011\176\001\000\011\172\001\000\011\168\001\000\011\164\001\000\011\160\001\000\011\156\001\000\011\152\001\000\011\148\001\000\011\144\001\000\011\140\001\000\011\136\001\000\011\132\001\000\011\128\001\000\011|\001\000\011x\001\000\011t\001\000\000\132\001\000\000\128\001\000\000\132\002\000\000\132\003\000\001\244\002\000\002X\002\000\000\140\001\000\000\140\002\000\rX\001\000\rX\002\000\rX\003\000\r4\001\000\007L\001\000\006\248\001\000\007@\001\000\007<\001\000\0078\001\000\007P\001\000\007`\001\000\007H\001\000\007D\001\000\006\252\001\000\007X\001\000\0074\001\000\0070\001\000\007,\001\000\007(\001\000\007$\001\000\007\028\001\000\007\\\001\000\007T\001\000\007\024\001\000\007\020\001\000\007\016\001\000\007\012\001\000\007\b\001\000\007\004\001\000\007\b\002\000\007\004\002\000\004\012\001\000\004\012\002\000\007\b\003\000\007\004\003\000\007\b\004\000\007\004\004\000\007\b\005\000\007\016\002\000\007\012\002\000\007\016\003\000\007\012\003\000\007\016\004\000\007\012\004\000\007\016\005\000\007\024\002\000\007\020\002\000\007\024\003\000\007\020\003\000\007\024\004\000\007\020\004\000\007\024\005\000\007p\001\000\007d\001\000\007 \001\000\007\000\001\000\007h\001\000\007l\001\000\r4\002\000\r4\003\000\r8\001\000\rX\004\000\rX\005\000\000|\001\000\005\180\001\000\001\252\001\000\t<\001\000\000x\001\000\003\252\001\000\004\000\001\000\t<\002\000\000x\002\000\007\212\001\000\007\212\002\000\007\212\003\000\007\208\001\000\001\200\001\000\001\196\001\000\000p\001\000\000d\001\000\000x\001\000\000x\002\000\001\200\002\000\001\200\003\000\001\200\004\000\005\180\001\000\003\252\001\000\006D\001\000\006D\002\000\n\024\001\000\n\020\001\000\003\248\001\000\003\244\001\000\003\240\001\000\003\236\001\000\n\024\002\000\n\020\002\000\003\248\002\000\003\244\002\000\003\240\002\000\003\236\002\000\n\024\003\000\n\020\003\000\003\248\003\000\003\244\003\000\003\240\003\000\003\236\003\000\r(\001\000\r\020\001\000\r\b\001\000\r\020\002\000\n\024\004\000\003\248\004\000\003\240\004\000\r\028\001\000\r\012\001\000\r\028\002\000\012\248\001\000\r$\001\000\r \001\000\r\024\001\000\r\016\001\000\r\024\002\000\r \002\000\012\236\001\000\r\000\001\000\012\252\001\000\012\252\002\000\012\236\002\000\tp\001\000\012\248\002\000\tt\001\000\012\248\003\000\tt\002\000\tt\003\000\n\024\005\000\003\248\005\000\003\240\005\000\005\172\001\000\003\248\006\000\003\240\006\000\012\228\001\000\005\180\001\000\001|\001\000\001x\001\000\006\212\001\000\006\196\001\000\006\180\001\000\006\172\001\000\001\200\001\000\001\196\001\000\001\128\001\000\001p\001\000\000p\001\000\000d\001\000\001p\002\000\005\172\001\000\003\184\001\000\003\184\002\000\005\172\001\000\006\228\001\000\006\224\001\000\005\172\001\000\005\132\001\000\005|\001\000\005t\001\000\005\132\002\000\005|\002\000\005t\002\000\001\248\001\000\001\248\002\000\n\244\001\000\005\228\001\000\012l\001\000\012h\001\000\003\248\001\000\003\244\001\000\012l\002\000\012h\002\000\003\248\002\000\003\244\002\000\012l\003\000\012h\003\000\003\248\003\000\003\244\003\000\012l\004\000\003\248\004\000\012l\005\000\003\248\005\000\005\172\001\000\003\248\006\000\003\248\007\000\t\024\001\000\003\248\b\000\b\176\001\000\b\176\002\000\002<\001\000\002<\002\000\002<\003\000\001d\001\000\n\204\001\000\n\184\001\000\n\184\002\000\n\184\003\000\000\236\001\000\000\232\001\000\011<\001\000\nX\001\000\nT\001\000\nT\002\000\nX\002\000\nP\001\000\nL\001\000\nL\002\000\nP\002\000\r4\001\000\011d\001\000\0118\001\000\0114\001\000\011,\001\000\001\144\001\000\001p\001\000\nX\001\000\nT\001\000\0078\001\000\0118\002\000\0114\002\000\0118\003\000\0114\003\000\0118\004\000\0114\004\000\006<\001\000\0068\001\000\0118\005\000\0114\005\000\0114\006\000\0118\006\000\006L\001\000\006L\002\000\006L\003\000\006L\004\000\0064\001\000\006\020\001\000\006\020\002\000\005$\001\000\005 \001\000\004\024\001\000\000@\001\000\000<\001\000\006\236\001\000\006\232\001\000\006\236\002\000\006\236\003\000\006\236\004\000\007\252\001\000\007\248\001\000\007\244\001\000\007\240\001\000\007\236\001\000\007\232\001\000\007\228\001\000\007\224\001\000\007\220\001\000\007\216\001\000\007\252\002\000\007\248\002\000\007\244\002\000\007\240\002\000\007\236\002\000\007\232\002\000\007\228\002\000\007\224\002\000\007\252\003\000\007\248\003\000\007\244\003\000\007\240\003\000\007\236\003\000\007\232\003\000\007\228\003\000\007\224\003\000\n\172\001\000\n\172\002\000\n\172\003\000\005\220\001\000\005\232\001\000\005\224\001\000\005\232\002\000\005\224\002\000\005\232\003\000\005\224\003\000\005\252\001\000\000\228\001\000\n\172\004\000\004\244\001\000\004\244\002\000\012\148\001\000\012\144\001\000\0028\001\000\0028\002\000\0028\003\000\r4\001\000\n\180\001\000\n\176\001\000\n|\001\000\nx\001\000\001\144\001\000\001p\001\000\n\204\001\000\006\248\001\000\011\b\001\000\011\004\001\000\r8\001\000\003<\001\000\0038\001\000\003<\002\000\0038\002\000\003,\001\000\nh\001\000\nd\001\000\n`\001\000\001l\001\000\001l\002\000\n\\\001\000\0048\001\000\n\\\002\000\n\\\003\000\005d\001\000\005`\001\000\005\\\001\000\005X\001\000\007\160\001\000\001\228\001\000\001\224\001\000\007\128\001\000\001\228\002\000\001\224\002\000\001\220\001\000\001\216\001\000\001\220\002\000\001\216\002\000\001\212\001\000\001\208\001\000\001\204\001\000\000h\001\000\005\248\001\000\005\184\001\000\005\176\001\000\005\248\002\000\005\248\003\000\005\248\001\000\005\184\001\000\005\248\004\000\005\184\002\000\005\184\003\000\005\244\001\000\005\184\002\000\005\176\002\000\005\176\003\000\001X\001\000\000h\002\000\001\208\002\000\006\148\001\000\006\148\002\000\000\\\001\000\003\188\001\000\003\176\001\000\003\188\002\000\012\208\001\000\t\160\001\000\t\160\002\000\001\184\001\000\005\248\001\000\005\184\001\000\005\176\001\000\000t\001\000\005\184\002\000\005\176\002\000\000t\002\000\001\200\001\000\001\196\001\000\003\180\001\000\003\180\002\000\003\180\003\000\012\232\001\000\003\180\004\000\001\188\001\000\002\b\001\000\001\192\001\000\000X\001\000\012\204\001\000\t\164\001\000\000l\001\000\000`\001\000\t\164\002\000\t\164\003\000\000l\001\000\000`\001\000\000l\002\000\000l\003\000\000`\002\000\000D\001\000\001\196\002\000\001\180\001\000\001\196\003\000\001\180\002\000\001\176\001\000\000H\001\000\000H\002\000\000H\003\000\000H\004\000\000t\003\000\t\160\003\000\000l\001\000\000`\001\000\003\188\003\000\t\168\001\000\t`\001\000\td\001\000\001\208\003\000\001\208\004\000\td\002\000\td\003\000\012\156\001\000\012\152\001\000\012\152\002\000\007t\001\000\012\152\003\000\012\152\004\000\tT\001\000\tT\002\000\tT\003\000\000H\001\000\012\152\005\000\tP\001\000\000H\001\000\012\156\002\000\t\172\001\000\001\180\001\000\t\168\001\000\001\204\002\000\001\204\003\000\001\212\002\000\001\212\003\000\td\001\000\001\212\004\000\001\212\005\000\td\001\000\001\216\003\000\001\216\004\000\td\001\000\001\228\003\000\001\224\003\000\001\224\004\000\001\228\004\000\t8\001\000\001\228\005\000\001\228\006\000\t8\002\000\t4\001\000\007\160\002\000\001\180\001\000\005d\002\000\005`\002\000\005\\\002\000\005X\002\000\007\188\001\000\bh\001\000\bh\002\000\bh\003\000\001\\\001\000\011P\001\000\011P\002\000\001h\001\000\001t\001\000\001`\001\000\011$\001\000\r<\001\000\011(\001\000\bh\004\000\0110\001\000\011D\001\000\011@\001\000\011D\002\000\011D\003\000\nH\001\000\011L\001\000\011`\001\000\011\\\001\000\011X\001\000\011T\001\000\005\232\001\000\001\140\001\000\001\136\001\000\011`\002\000\011\\\002\000\011X\002\000\011T\002\000\005\232\002\000\001\140\002\000\011`\003\000\011\\\003\000\001\140\003\000\011\\\004\000\bD\001\000\bD\002\000\bD\003\000\bX\001\000\b4\001\000\bH\001\000\b<\001\000\bH\002\000\bL\001\000\bH\003\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\bL\002\000\bL\003\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\b,\002\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\003\000\b,\001\000\b@\002\000\bL\001\000\b@\003\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\b8\002\000\b8\003\000\b0\002\000\011L\001\000\bd\001\000\bd\002\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\011h\001\000\011H\001\000\b`\001\000\b\\\001\000\r4\001\000\011d\001\000\0118\001\000\0114\001\000\011,\001\000\b`\002\000\001\144\001\000\001p\001\000\b`\003\000\006\156\001\000\006\152\001\000\006\156\002\000\b`\004\000\b`\005\000\b`\006\000\011H\001\000\001\148\001\000\nP\001\000\nL\001\000\007D\001\000\001\144\002\000\001\144\003\000\011d\002\000\011,\002\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\011,\003\000\011d\003\000\011d\004\000\001\180\001\000\011d\005\000\b\\\002\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\bL\001\000\bD\004\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\001\140\004\000\001\140\005\000\011`\004\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\011`\005\000\011X\003\000\n`\001\000\011X\004\000\n`\002\000\n`\003\000\t\220\001\000\t\216\001\000\t\212\001\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\t\220\002\000\t\216\002\000\t\220\003\000\011T\003\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\007\188\002\000\005d\003\000\005`\003\000\005\\\003\000\005X\003\000\005d\004\000\005`\004\000\005\\\004\000\005`\005\000\007\136\001\000\005`\006\000\005d\005\000\nh\002\000\nd\002\000\nd\003\000\011$\001\000\004\180\001\000\004\176\001\000\004h\001\000\004d\001\000\004d\002\000\0044\001\000\0040\001\000\0044\002\000\0044\003\000\001\180\001\000\004d\003\000\004d\004\000\004h\002\000\004X\001\000\004T\001\000\004T\002\000\004T\003\000\007\196\001\000\004\148\001\000\0020\001\000\002,\001\000\002(\001\000\002$\001\000\0020\002\000\002,\002\000\0020\003\000\0020\004\000\0020\005\000\006\024\001\000\006\024\002\000\003\196\001\000\003\192\001\000\003\192\002\000\003\196\002\000\003\196\003\000\006\\\001\000\006P\001\000\006\\\002\000\006\\\003\000\006H\001\000\006H\002\000\t(\001\000\003\200\001\000\t(\002\000\006H\003\000\006H\004\000\006X\001\000\006d\001\000\006`\001\000\006T\001\000\006H\005\000\006d\002\000\r\128\001\000\r|\001\000\r\128\002\000\r|\002\000\r\128\003\000\r|\003\000\r\152\001\000\r\148\001\000\r\152\002\000\r\128\004\000\r\128\005\000\000H\001\000\r|\004\000\r|\005\000\000H\001\000\r|\006\000\t\024\001\000\t\024\002\000\t\024\003\000\001\180\001\000\t\024\004\000\t\024\005\000\001\180\001\000\012\244\001\000\r\144\001\000\r\140\001\000\r\136\001\000\r\132\001\000\r\144\002\000\r\140\002\000\r\144\003\000\r\140\003\000\r\140\004\000\r\140\005\000\006d\001\000\006`\001\000\006T\001\000\006`\002\000\006d\001\000\006`\003\000\006`\001\000\006T\001\000\006T\002\000\005\248\001\000\005\216\001\000\005\184\001\000\005\216\002\000\005\184\002\000\005\184\003\000\003\252\001\000\005\216\003\000\006t\001\000\005\212\001\000\006h\001\000\r\144\004\000\r\144\005\000\006d\001\000\006`\001\000\006T\001\000\r\136\002\000\r\132\002\000\005\232\001\000\r\132\003\000\r\132\004\000\005\248\001\000\005\184\001\000\005\232\002\000\r\136\003\000\r\136\004\000\005\248\001\000\005\184\001\000\tX\001\000\t\\\001\000\006d\003\000\t\\\002\000\t\\\003\000\t$\001\000\006d\001\000\006`\001\000\006\\\004\000\006T\001\000\006d\001\000\006`\001\000\006T\001\000\006P\002\000\006P\003\000\006d\001\000\006`\001\000\006T\001\000\003\196\004\000\003\196\005\000\006\024\003\000\006\024\004\000\006\028\001\000\006,\001\000\006(\001\000\006 \001\000\006\024\005\000\007\252\001\000\007\248\001\000\007\244\001\000\007\240\001\000\007\236\001\000\007\232\001\000\007\228\001\000\007\224\001\000\007\220\001\000\007\216\001\000\006,\002\000\006,\003\000\007\220\002\000\007\216\002\000\006,\001\000\006(\001\000\006 \001\000\007\220\003\000\007\216\003\000\007\216\004\000\006d\001\000\006`\001\000\006T\001\000\007\216\005\000\006(\002\000\006 \002\000\006$\001\000\005\232\001\000\0060\001\000\006,\001\000\006(\001\000\006 \001\000\0020\006\000\0020\007\000\011\020\001\000\001l\001\000\n\216\001\000\n\212\001\000\t\208\001\000\t\204\001\000\t\200\001\000\007\172\001\000\007\168\001\000\n\252\001\000\r8\001\000\005\220\001\000\nt\001\000\np\001\000\nl\001\000\002d\001\000\002d\002\000\002d\003\000\n\168\001\000\n\164\001\000\n\168\002\000\n\164\002\000\n\168\003\000\n\164\003\000\002T\001\000\002P\001\000\002L\001\000\002H\001\000\002D\001\000\002@\001\000\002T\002\000\002P\002\000\002L\002\000\002H\002\000\002D\002\000\002@\002\000\002T\003\000\002P\003\000\002L\003\000\002H\003\000\002D\003\000\002@\003\000\t\240\001\000\t\156\001\000\t\152\001\000\t\240\002\000\t\156\002\000\t\152\002\000\t\240\003\000\t\156\003\000\t\152\003\000\tH\001\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\005p\001\000\005l\001\000\005h\001\000\005l\002\000\0024\001\000\0024\002\000\0024\003\000\004`\001\000\004\\\001\000\b\136\001\000\004\\\002\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\004\172\001\000\004\168\001\000\004\172\002\000\004\172\003\000\001\180\001\000\004\\\003\000\004\\\004\000\004\\\005\000\b\132\001\000\004`\002\000\r4\001\000\011d\001\000\0118\001\000\0114\001\000\011,\001\000\003\148\001\000\001\144\001\000\001p\001\000\003\148\002\000\003\148\003\000\003\148\004\000\004l\001\000\004l\002\000\004p\001\000\t \001\000\003\156\001\000\003\152\001\000\t \002\000\0024\004\000\007\152\001\000\007\152\002\000\000l\001\000\000`\001\000\0024\005\000\0024\006\000\t\156\001\000\t\152\001\000\002\024\001\000\t\156\002\000\t\152\002\000\002\024\002\000\t\156\003\000\t\152\003\000\002\024\003\000\t\156\004\000\t\152\004\000\tL\001\000\002\024\004\000\t\156\005\000\t\152\005\000\t\156\006\000\t\156\001\000\t\152\001\000\t\156\007\000\t\156\002\000\t\152\002\000\t\156\b\000\t\156\003\000\t\152\003\000\t\156\t\000\t\156\004\000\t\152\004\000\tL\001\000\tL\002\000\tL\003\000\tD\001\000\002\\\001\000\002\\\002\000\002\\\003\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\002\\\004\000\002\\\005\000\n\208\001\000\n\188\001\000\005\236\001\000\n\236\001\000\n\232\001\000\n\220\001\000\n\208\002\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\n\236\002\000\n\236\003\000\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\n\232\002\000\n\232\003\000\n\156\002\000\n\148\002\000\n\140\002\000\n\140\003\000\t\196\001\000\t\188\001\000\t\184\001\000\t\156\001\000\t\152\001\000\t\196\002\000\t\188\002\000\t\184\002\000\t\156\002\000\t\152\002\000\t\196\003\000\t\188\003\000\t\184\003\000\t\156\003\000\t\152\003\000\t\196\004\000\t\188\004\000\t\184\004\000\t\156\004\000\t\152\004\000\tL\001\000\t\196\005\000\t\188\005\000\002`\001\000\002`\002\000\002`\003\000\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\002`\004\000\n\220\002\000\n\160\002\000\n\152\002\000\n\144\002\000\n\136\002\000\n\132\002\000\n\128\002\000\n\128\003\000\003\028\001\000\003\024\001\000\t\156\001\000\t\152\001\000\003\028\002\000\t\156\002\000\t\152\002\000\003\028\003\000\t\156\003\000\t\152\003\000\003\028\004\000\t\156\004\000\t\152\004\000\tL\001\000\003\028\005\000\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\003\140\001\000\003\136\001\000\003\132\001\000\003\128\001\000\003|\001\000\003x\001\000\003t\001\000\003p\001\000\003l\001\000\003h\001\000\003d\001\000\003`\001\000\003\\\001\000\003X\001\000\003T\001\000\003P\001\000\003L\001\000\003H\001\000\003D\001\000\003@\001\000\002h\001\000\002 \001\000\004H\001\000\004D\001\000\004H\002\000\004H\003\000\012\220\001\000\012\220\002\000\001\180\001\000\012\216\001\000\012\212\001\000\012\216\002\000\012\212\002\000\001\180\001\000\012\216\003\000\012\216\004\000\001\180\001\000\004H\004\000\004H\005\000\004D\002\000\004L\001\000\004L\002\000\004P\001\000\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\004P\002\000\n\200\001\000\011 \001\000\011\028\001\000\011\024\001\000\011\016\001\000\011\012\001\000\011\000\001\000\n\248\001\000\n\228\001\000\n\224\001\000\005\240\001\000\005\232\001\000\001\140\001\000\001\136\001\000\011 \002\000\011\028\002\000\011\024\002\000\011\016\002\000\011\012\002\000\011\000\002\000\n\248\002\000\n\228\002\000\n\224\002\000\005\240\002\000\005\232\002\000\001\140\002\000\r4\001\000\011 \003\000\n\248\003\000\n\224\003\000\001\140\003\000\n\248\004\000\007<\001\000\000@\001\000\0078\001\000\000<\001\000\011 \004\000\011 \005\000\011 \006\000\011 \007\000\006,\001\000\006(\001\000\006 \001\000\011 \b\000\011 \t\000\006d\001\000\006`\001\000\006T\001\000\011 \n\000\012\148\001\000\007H\001\000\012\144\001\000\007D\001\000\006\252\001\000\003,\001\000\bX\001\000\004\184\001\000\004\184\002\000\004\184\003\000\001\180\001\000\004\184\004\000\004\184\005\000\t\140\001\000\t\136\001\000\002l\001\000\t\140\002\000\t\136\002\000\t\156\001\000\t\152\001\000\t\140\003\000\t\156\002\000\t\152\002\000\t\140\004\000\t\156\003\000\t\152\003\000\t\140\005\000\t\156\004\000\t\152\004\000\t\140\006\000\tL\001\000\n\200\001\000\002t\001\000\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\002t\002\000\r@\001\000\n\240\001\000\n\196\001\000\n\192\001\000\004\152\001\000\003(\001\000\003(\002\000\003(\003\000\t\236\001\000\t\148\001\000\t\144\001\000\003\172\001\000\003\168\001\000\003\164\001\000\003\160\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\204\002\000\002\200\002\000\t\156\001\000\t\152\001\000\002\204\003\000\t\156\002\000\t\152\002\000\002\204\004\000\t\156\003\000\t\152\003\000\002\204\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\204\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\003\000\002\200\001\000\002\196\001\000\002\192\001\000\002\188\001\000\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\180\002\000\002\176\002\000\t\156\001\000\t\152\001\000\002\180\003\000\t\156\002\000\t\152\002\000\002\180\004\000\t\156\003\000\t\152\003\000\002\180\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\180\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\003\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\172\002\000\002\168\002\000\t\156\001\000\t\152\001\000\002\172\003\000\t\156\002\000\t\152\002\000\002\172\004\000\t\156\003\000\t\152\003\000\002\172\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\172\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\003\000\002\168\001\000\002\164\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\002\164\002\000\002\160\002\000\t\156\001\000\t\152\001\000\002\164\003\000\t\156\002\000\t\152\002\000\002\164\004\000\t\156\003\000\t\152\003\000\002\164\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\164\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\212\002\000\002\208\002\000\t\156\001\000\t\152\001\000\002\212\003\000\t\156\002\000\t\152\002\000\002\212\004\000\t\156\003\000\t\152\003\000\002\212\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\212\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\001\000\002\224\001\000\002\220\001\000\002\216\001\000\002\212\001\000\002\208\003\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\244\002\000\002\240\002\000\t\156\001\000\t\152\001\000\002\244\003\000\t\156\002\000\t\152\002\000\002\244\004\000\t\156\003\000\t\152\003\000\002\244\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\244\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\003\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\196\002\000\002\192\002\000\t\156\001\000\t\152\001\000\002\196\003\000\t\156\002\000\t\152\002\000\002\196\004\000\t\156\003\000\t\152\003\000\002\196\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\196\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\003\000\002\192\001\000\002\188\001\000\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\188\002\000\002\184\002\000\t\156\001\000\t\152\001\000\002\188\003\000\t\156\002\000\t\152\002\000\002\188\004\000\t\156\003\000\t\152\003\000\002\188\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\188\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\003\000\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\228\002\000\002\224\002\000\t\156\001\000\t\152\001\000\002\228\003\000\t\156\002\000\t\152\002\000\002\228\004\000\t\156\003\000\t\152\003\000\002\228\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\228\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\001\000\002\224\003\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\156\002\000\002\152\002\000\t\156\001\000\t\152\001\000\002\156\003\000\t\156\002\000\t\152\002\000\002\156\004\000\t\156\003\000\t\152\003\000\002\156\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\156\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\148\002\000\002\144\002\000\t\156\001\000\t\152\001\000\002\148\003\000\t\156\002\000\t\152\002\000\002\148\004\000\t\156\003\000\t\152\003\000\002\148\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\148\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\140\002\000\002\136\002\000\t\156\001\000\t\152\001\000\002\140\003\000\t\156\002\000\t\152\002\000\002\140\004\000\t\156\003\000\t\152\003\000\002\140\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\140\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\132\002\000\002\128\002\000\t\156\001\000\t\152\001\000\002\132\003\000\t\156\002\000\t\152\002\000\002\132\004\000\t\156\003\000\t\152\003\000\002\132\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\132\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002|\002\000\002x\002\000\t\156\001\000\t\152\001\000\002|\003\000\t\156\002\000\t\152\002\000\002|\004\000\t\156\003\000\t\152\003\000\002|\005\000\t\156\004\000\t\152\004\000\tL\001\000\002|\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\236\002\000\002\232\002\000\t\156\001\000\t\152\001\000\002\236\003\000\t\156\002\000\t\152\002\000\002\236\004\000\t\156\003\000\t\152\003\000\002\236\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\236\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\003\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\220\002\000\002\216\002\000\t\156\001\000\t\152\001\000\002\220\003\000\t\156\002\000\t\152\002\000\002\220\004\000\t\156\003\000\t\152\003\000\002\220\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\220\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\001\000\002\224\001\000\002\220\001\000\002\216\003\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\t\148\002\000\t\144\002\000\t\156\001\000\t\152\001\000\t\148\003\000\t\156\002\000\t\152\002\000\t\148\004\000\t\156\003\000\t\152\003\000\t\148\005\000\t\156\004\000\t\152\004\000\t\148\006\000\tL\001\000\t\148\001\000\t\144\003\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\003\020\002\000\003\016\002\000\t\156\001\000\t\152\001\000\003\020\003\000\t\156\002\000\t\152\002\000\003\020\004\000\t\156\003\000\t\152\003\000\003\020\005\000\t\156\004\000\t\152\004\000\tL\001\000\003\020\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\003\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\0034\002\000\0030\002\000\t\156\001\000\t\152\001\000\0034\003\000\t\156\002\000\t\152\002\000\0034\004\000\t\156\003\000\t\152\003\000\0034\005\000\t\156\004\000\t\152\004\000\tL\001\000\0034\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\003\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002\252\002\000\002\248\002\000\t\156\001\000\t\152\001\000\002\252\003\000\t\156\002\000\t\152\002\000\002\252\004\000\t\156\003\000\t\152\003\000\002\252\005\000\t\156\004\000\t\152\004\000\tL\001\000\002\252\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\003\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\003\004\002\000\003\000\002\000\t\156\001\000\t\152\001\000\003\004\003\000\t\156\002\000\t\152\002\000\003\004\004\000\t\156\003\000\t\152\003\000\003\004\005\000\t\156\004\000\t\152\004\000\tL\001\000\003\004\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\003\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\003\012\002\000\003\b\002\000\t\156\001\000\t\152\001\000\003\012\003\000\t\156\002\000\t\152\002\000\003\012\004\000\t\156\003\000\t\152\003\000\003\012\005\000\t\156\004\000\t\152\004\000\tL\001\000\003\012\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\003\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\003\144\002\000\n\196\001\000\002p\001\000\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\002p\002\000\003$\001\000\003 \001\000\t\156\001\000\t\152\001\000\003$\002\000\t\156\002\000\t\152\002\000\003$\003\000\t\156\003\000\t\152\003\000\003$\004\000\t\156\004\000\t\152\004\000\tL\001\000\003$\005\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003 \002\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\003\172\002\000\003\168\002\000\003\164\002\000\003\172\003\000\003\172\004\000\003\172\005\000\003\168\003\000\000L\001\000\000L\002\000\011$\001\000\004\136\001\000\004\132\001\000\004\128\001\000\004|\001\000\004x\001\000\012@\001\000\012@\002\000\012\216\001\000\012\212\001\000\004\136\002\000\004\132\002\000\004\136\003\000\004\136\004\000\004\136\005\000\004\136\006\000\001\180\001\000\004\136\007\000\004\136\b\000\t@\001\000\004\132\003\000\t@\002\000\t@\003\000\004\132\004\000\004\132\005\000\001\180\001\000\004\132\006\000\004\132\007\000\004\128\002\000\004\128\003\000\004\128\004\000\004|\002\000\012D\001\000\007\204\001\000\012D\002\000\012D\003\000\002\028\001\000\012D\004\000\t\028\001\000\011(\001\000\004\144\001\000\004\144\002\000\004\144\003\000\001\180\001\000\004\144\004\000\004\144\005\000\b\128\001\000\bx\001\000\bp\001\000\bl\001\000\bT\001\000\004\140\001\000\004\140\002\000\004\140\003\000\bT\002\000\bT\003\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\bl\002\000\bl\003\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\b\128\002\000\b\128\003\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\bx\002\000\bx\003\000\bp\002\000\bt\001\000\b|\001\000\bP\001\000\bP\002\000\bP\003\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\004t\001\000\000L\003\000\005\012\001\000\005\012\002\000\000L\004\000\004\152\002\000\t\148\001\000\t\144\001\000\t\136\003\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\b\128\001\000\bx\001\000\bp\001\000\bl\001\000\bT\001\000\004\188\001\000\004\188\002\000\004\188\003\000\004\196\001\000\003,\002\000\003,\003\000\003,\004\000\004\196\002\000\004\196\003\000\004\192\001\000\n\208\001\000\007 \001\000\n\224\004\000\n\224\005\000\011\016\003\000\011\012\003\000\011\016\004\000\011\012\004\000\011\012\005\000\t\192\001\000\t\180\001\000\t\176\001\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\t\192\002\000\t\180\002\000\t\192\003\000\011\028\003\000\011\024\003\000\011\028\004\000\011\024\004\000\011\024\005\000\n\228\003\000\n\228\004\000\n\228\005\000\011\000\003\000\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\b\224\001\000\b\224\002\000\b\224\003\000\t\232\001\000\t\228\001\000\t\224\001\000\t\232\002\000\t\228\002\000\t\224\002\000\t\232\003\000\t\228\003\000\t\224\003\000\t\232\004\000\t\228\004\000\t\232\005\000\b\220\001\000\011\000\004\000\011\000\005\000\011 \001\000\011\028\001\000\011\024\001\000\011\016\001\000\011\012\001\000\011\000\001\000\n\248\001\000\n\228\001\000\n\224\001\000\005\240\001\000\005\232\001\000\005\224\001\000\001\140\001\000\001\136\001\000\011 \002\000\011\028\002\000\011\024\002\000\011\016\002\000\011\012\002\000\011\000\002\000\n\248\002\000\n\228\002\000\n\224\002\000\005\240\002\000\005\232\002\000\005\224\002\000\001\140\002\000\r8\001\000\005\224\003\000\005\240\003\000\004@\001\000\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\004@\002\000\n\156\002\000\n\148\002\000\n\140\002\000\003\132\002\000\003\128\002\000\003t\002\000\003p\002\000\003d\002\000\003`\002\000\n\140\003\000\003d\003\000\003`\003\000\n\140\004\000\003d\004\000\003`\004\000\n\140\005\000\003d\005\000\003`\005\000\003d\006\000\003`\006\000\t\156\001\000\t\152\001\000\003d\007\000\t\156\002\000\t\152\002\000\003d\b\000\t\156\003\000\t\152\003\000\003d\t\000\t\156\004\000\t\152\004\000\tL\001\000\003d\n\000\t\148\001\000\t\144\001\000\003\144\001\000\003`\007\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\156\003\000\003\132\003\000\003\128\003\000\n\156\004\000\003\132\004\000\003\128\004\000\n\156\005\000\003\132\005\000\003\128\005\000\003\132\006\000\003\128\006\000\t\156\001\000\t\152\001\000\003\132\007\000\t\156\002\000\t\152\002\000\003\132\b\000\t\156\003\000\t\152\003\000\003\132\t\000\t\156\004\000\t\152\004\000\tL\001\000\003\132\n\000\t\148\001\000\t\144\001\000\003\144\001\000\003\128\007\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\148\003\000\003t\003\000\003p\003\000\n\148\004\000\003t\004\000\003p\004\000\n\148\005\000\003t\005\000\003p\005\000\003t\006\000\003p\006\000\t\156\001\000\t\152\001\000\003t\007\000\t\156\002\000\t\152\002\000\003t\b\000\t\156\003\000\t\152\003\000\003t\t\000\t\156\004\000\t\152\004\000\tL\001\000\003t\n\000\t\148\001\000\t\144\001\000\003\144\001\000\003p\007\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\220\002\000\n\160\002\000\n\152\002\000\n\144\002\000\n\136\002\000\n\132\002\000\n\128\002\000\003\140\002\000\003\136\002\000\003|\002\000\003x\002\000\003l\002\000\003h\002\000\003\\\002\000\003X\002\000\003T\002\000\003P\002\000\003L\002\000\003H\002\000\003D\002\000\003@\002\000\n\128\003\000\003L\003\000\003H\003\000\n\128\004\000\003L\004\000\003H\004\000\n\128\005\000\003L\005\000\003H\005\000\003L\006\000\003H\006\000\t\156\001\000\t\152\001\000\003L\007\000\t\156\002\000\t\152\002\000\003L\b\000\t\156\003\000\t\152\003\000\003L\t\000\t\156\004\000\t\152\004\000\tL\001\000\003L\n\000\t\148\001\000\t\144\001\000\003\144\001\000\003H\007\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\136\003\000\003\\\003\000\003X\003\000\n\136\004\000\003\\\004\000\003X\004\000\n\136\005\000\003\\\005\000\003X\005\000\003\\\006\000\003X\006\000\t\156\001\000\t\152\001\000\003\\\007\000\t\156\002\000\t\152\002\000\003\\\b\000\t\156\003\000\t\152\003\000\003\\\t\000\t\156\004\000\t\152\004\000\tL\001\000\003\\\n\000\t\148\001\000\t\144\001\000\003\144\001\000\003X\007\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\132\003\000\003T\003\000\003P\003\000\n\132\004\000\003T\004\000\003P\004\000\n\132\005\000\003T\005\000\003P\005\000\003T\006\000\003P\006\000\t\156\001\000\t\152\001\000\003T\007\000\t\156\002\000\t\152\002\000\003T\b\000\t\156\003\000\t\152\003\000\003T\t\000\t\156\004\000\t\152\004\000\tL\001\000\003T\n\000\t\148\001\000\t\144\001\000\003\144\001\000\003P\007\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\160\003\000\n\152\003\000\n\144\003\000\005\232\001\000\005\224\001\000\003\140\003\000\003\136\003\000\003|\003\000\003x\003\000\003l\003\000\003h\003\000\n\160\004\000\n\152\004\000\n\144\004\000\003\140\004\000\003\136\004\000\003|\004\000\003x\004\000\003l\004\000\003h\004\000\n\144\005\000\003l\005\000\003h\005\000\n\144\006\000\003l\006\000\003h\006\000\n\144\007\000\003l\007\000\003h\007\000\003l\b\000\003h\b\000\t\156\001\000\t\152\001\000\003l\t\000\t\156\002\000\t\152\002\000\003l\n\000\t\156\003\000\t\152\003\000\003l\011\000\t\156\004\000\t\152\004\000\tL\001\000\003l\012\000\t\148\001\000\t\144\001\000\003\144\001\000\003h\t\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\160\005\000\003\140\005\000\003\136\005\000\n\160\006\000\003\140\006\000\003\136\006\000\n\160\007\000\003\140\007\000\003\136\007\000\003\140\b\000\003\136\b\000\t\156\001\000\t\152\001\000\003\140\t\000\t\156\002\000\t\152\002\000\003\140\n\000\t\156\003\000\t\152\003\000\003\140\011\000\t\156\004\000\t\152\004\000\tL\001\000\003\140\012\000\t\148\001\000\t\144\001\000\003\144\001\000\003\136\t\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\152\005\000\003|\005\000\003x\005\000\n\152\006\000\003|\006\000\003x\006\000\n\152\007\000\003|\007\000\003x\007\000\003|\b\000\003x\b\000\t\156\001\000\t\152\001\000\003|\t\000\t\156\002\000\t\152\002\000\003|\n\000\t\156\003\000\t\152\003\000\003|\011\000\t\156\004\000\t\152\004\000\tL\001\000\003|\012\000\t\148\001\000\t\144\001\000\003\144\001\000\003x\t\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\220\003\000\003D\003\000\003@\003\000\003D\004\000\003@\004\000\t\156\001\000\t\152\001\000\003D\005\000\t\156\002\000\t\152\002\000\003D\006\000\t\156\003\000\t\152\003\000\003D\007\000\t\156\004\000\t\152\004\000\tL\001\000\003D\b\000\t\148\001\000\t\144\001\000\003\144\001\000\003@\005\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\004<\001\000\t0\001\000\002h\002\000\t0\002\000\t,\001\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\024\002\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\n\128\004\000\n\128\005\000\n\136\003\000\n\136\004\000\n\136\005\000\n\132\003\000\n\132\004\000\n\132\005\000\n\160\003\000\n\152\003\000\n\144\003\000\005\232\001\000\005\224\001\000\n\160\004\000\n\152\004\000\n\144\004\000\n\144\005\000\n\144\006\000\n\144\007\000\n\160\005\000\n\160\006\000\n\160\007\000\n\152\005\000\n\152\006\000\n\152\007\000\n\220\003\000\t\196\006\000\n\140\004\000\n\140\005\000\n\156\003\000\n\156\004\000\n\156\005\000\n\148\003\000\n\148\004\000\n\148\005\000\002\\\006\000\001\232\001\000\001\236\001\000\002\\\007\000\002\\\b\000\002\\\t\000\002\\\n\000\002\\\011\000\t\152\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\0024\007\000\005l\003\000\005l\004\000\005l\005\000\005p\002\000\005h\002\000\005p\003\000\005h\003\000\tH\002\000\t\240\004\000\t\156\004\000\t\152\004\000\tL\001\000\002T\004\000\002P\004\000\002L\004\000\002H\004\000\002D\004\000\002@\004\000\002T\005\000\002P\005\000\002L\005\000\002H\005\000\002D\005\000\002@\005\000\t\156\001\000\t\152\001\000\002T\006\000\002L\006\000\002H\006\000\t\156\002\000\t\152\002\000\002T\007\000\002L\007\000\002H\007\000\t\156\003\000\t\152\003\000\002T\b\000\002L\b\000\002H\b\000\t\156\004\000\t\152\004\000\tL\001\000\002T\t\000\002L\t\000\002H\t\000\002L\n\000\002H\n\000\t\156\001\000\t\152\001\000\002L\011\000\t\156\002\000\t\152\002\000\002L\012\000\t\156\003\000\t\152\003\000\002L\r\000\t\156\004\000\t\152\004\000\tL\001\000\002L\014\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002H\011\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002P\006\000\002D\006\000\002@\006\000\002D\007\000\002@\007\000\t\156\001\000\t\152\001\000\002D\b\000\t\156\002\000\t\152\002\000\002D\t\000\t\156\003\000\t\152\003\000\002D\n\000\t\156\004\000\t\152\004\000\tL\001\000\002D\011\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\002@\b\000\n\168\004\000\n\164\004\000\n\164\005\000\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\002d\004\000\np\002\000\t\156\001\000\t\152\001\000\np\003\000\t\156\002\000\t\152\002\000\np\004\000\t\156\003\000\t\152\003\000\np\005\000\t\156\004\000\t\152\004\000\tL\001\000\np\006\000\nl\002\000\t\148\001\000\t\144\001\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\nl\003\000\n\236\001\000\n\232\001\000\n\220\001\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\nt\002\000\n\252\002\000\n\252\003\000\t\156\001\000\t\152\001\000\007\172\002\000\t\156\002\000\t\152\002\000\007\172\003\000\t\156\003\000\t\152\003\000\007\172\004\000\t\156\004\000\t\152\004\000\tL\001\000\007\172\005\000\t\148\001\000\t\144\001\000\007\168\002\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\t\208\002\000\t\204\002\000\t\200\002\000\t\208\003\000\t\204\003\000\t\208\004\000\n\216\002\000\n\212\002\000\n\212\003\000\011\020\002\000\011\020\003\000\0020\b\000\002,\003\000\002,\004\000\006,\001\000\006(\001\000\006 \001\000\002,\005\000\002,\006\000\002,\007\000\002$\002\000\002$\003\000\002$\004\000\002$\005\000\006\000\001\000\006,\001\000\006(\001\000\006 \001\000\006\000\002\000\006\004\001\000\006d\001\000\006`\001\000\006T\001\000\006\004\002\000\006\004\003\000\006,\001\000\006(\001\000\006 \001\000\006\004\004\000\002$\006\000\002$\007\000\002$\b\000\006\b\001\000\006\b\002\000\002(\002\000\002(\003\000\002(\004\000\001|\001\000\001\128\001\000\001p\001\000\001\128\002\000\001\128\003\000\001l\001\000\002(\005\000\003\208\001\000\001\164\001\000\006|\001\000\004 \001\000\004\028\001\000\004 \002\000\004\028\002\000\004 \003\000\004\028\003\000\t@\001\000\b\172\001\000\b\172\002\000\b\172\003\000\000H\001\000\004 \004\000\004\028\004\000\004 \005\000\004\028\005\000\004 \006\000\004 \007\000\b\168\001\000\000H\001\000\001\164\002\000\001\164\003\000\004,\001\000\004(\001\000\004,\002\000\004$\001\000\t|\001\000\001\160\001\000\t|\002\000\001\160\002\000\t|\003\000\001\160\003\000\000l\001\000\000`\001\000\003\208\002\000\tx\001\000\001\156\001\000\000l\001\000\000`\001\000\003\224\001\000\003\220\001\000\003\216\001\000\003\212\001\000\t@\001\000\003\224\002\000\003\216\002\000\003\224\003\000\003\216\003\000\003\216\004\000\003\216\005\000\003\216\006\000\000l\001\000\000`\001\000\tx\001\000\003\224\004\000\001\156\001\000\000l\001\000\000`\001\000\003\212\002\000\003\212\003\000\003\212\004\000\000l\001\000\000`\001\000\tx\001\000\003\220\002\000\001\156\001\000\000l\001\000\000`\001\000\002(\006\000\002(\007\000\002(\b\000\002(\t\000\001\132\001\000\004\148\002\000\004\148\003\000\b\216\001\000\004\148\004\000\004\148\005\000\004\148\006\000\007\196\002\000\004T\004\000\004T\005\000\004X\002\000\004\176\002\000\t\156\001\000\t\152\001\000\003<\003\000\t\156\002\000\t\152\002\000\003<\004\000\t\156\003\000\t\152\003\000\003<\005\000\t\156\004\000\t\152\004\000\tL\001\000\003<\006\000\t\148\001\000\t\144\001\000\003\144\001\000\0038\003\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\011\b\002\000\011\004\002\000\011\004\003\000\n\236\001\000\n\232\001\000\n\220\001\000\n\204\002\000\n\160\001\000\n\156\001\000\n\152\001\000\n\148\001\000\n\144\001\000\n\140\001\000\n\136\001\000\n\132\001\000\n\128\001\000\n\180\002\000\n\176\002\000\n\180\003\000\n\176\003\000\n\180\004\000\n\176\004\000\n\180\005\000\n\176\005\000\006,\001\000\006(\001\000\006 \001\000\n\176\006\000\n\180\006\000\n\180\007\000\006d\001\000\006`\001\000\006T\001\000\n\180\b\000\n|\002\000\nx\002\000\nx\003\000\n|\003\000\n|\004\000\0028\004\000\0028\005\000\tL\001\000\0028\006\000\t\156\001\000\t\152\001\000\007\252\004\000\007\244\004\000\007\236\004\000\007\228\004\000\t\156\002\000\t\152\002\000\007\252\005\000\007\244\005\000\007\236\005\000\007\228\005\000\t\156\003\000\t\152\003\000\007\252\006\000\007\244\006\000\007\236\006\000\007\228\006\000\t\156\004\000\t\152\004\000\tL\001\000\007\252\007\000\007\244\007\000\007\236\007\000\007\228\007\000\007\228\b\000\007\252\b\000\007\252\t\000\006d\001\000\006`\001\000\006T\001\000\007\252\n\000\007\244\b\000\007\236\b\000\007\244\t\000\007\236\t\000\006d\001\000\006`\001\000\006T\001\000\007\236\n\000\007\244\n\000\007\244\011\000\006d\001\000\006`\001\000\006T\001\000\007\244\012\000\t\148\001\000\t\144\001\000\007\248\004\000\007\240\004\000\007\232\004\000\007\224\004\000\003\144\001\000\0034\001\000\0030\001\000\003\020\001\000\003\016\001\000\003\012\001\000\003\b\001\000\003\004\001\000\003\000\001\000\002\252\001\000\002\248\001\000\002\244\001\000\002\240\001\000\002\236\001\000\002\232\001\000\002\228\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\002\184\001\000\002\180\001\000\002\176\001\000\002\172\001\000\002\168\001\000\002\164\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\007\224\005\000\007\248\005\000\007\248\006\000\006d\001\000\006`\001\000\006T\001\000\007\248\007\000\007\240\005\000\007\232\005\000\007\240\006\000\007\232\006\000\006d\001\000\006`\001\000\006T\001\000\007\232\007\000\007\240\007\000\007\240\b\000\006d\001\000\006`\001\000\006T\001\000\007\240\t\000\006\236\005\000\006,\001\000\006(\001\000\006 \001\000\006\236\006\000\006\232\002\000\006\232\003\000\006\232\004\000\006,\001\000\006(\001\000\006 \001\000\006\232\005\000\012x\001\000\012t\001\000\006l\001\000\006l\002\000\006l\003\000\006l\004\000\006l\005\000\007\180\001\000\007\180\002\000\006d\001\000\006`\001\000\006T\001\000\006l\006\000\006l\007\000\012x\002\000\012t\002\000\012x\003\000\012t\003\000\012x\004\000\012x\005\000\012x\006\000\012x\007\000\004\228\001\000\004\228\002\000\004\228\003\000\004\228\004\000\004\228\005\000\004\228\006\000\012x\b\000\012t\004\000\012t\005\000\012t\006\000\004\020\001\000\004\020\002\000\b\156\001\000\b\152\001\000\b\156\002\000\b\152\002\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\b\156\003\000\b\156\004\000\002\012\001\000\002\012\002\000\012\140\001\000\012\140\002\000\012\140\003\000\012\140\004\000\006,\001\000\006(\001\000\006 \001\000\012\140\005\000\b\180\001\000\b\180\002\000\b\180\003\000\b\180\004\000\b\180\005\000\t@\001\000\b\164\001\000\b\164\002\000\b\164\003\000\001\180\001\000\b\180\006\000\b\180\007\000\006\164\001\000\006\160\001\000\006\164\002\000\b\180\b\000\b\180\t\000\b\160\001\000\001\180\001\000\012<\001\000\t\244\001\000\012<\002\000\t\244\002\000\012<\003\000\t\244\003\000\012<\004\000\t\244\004\000\012<\005\000\001\144\001\000\001p\001\000\005\232\001\000\001\140\001\000\001\136\001\000\005\232\002\000\001\140\002\000\001\140\003\000\012<\006\000\012<\007\000\012<\b\000\t\244\005\000\t\244\006\000\t\244\007\000\b\148\001\000\b\144\001\000\005\020\001\000\006\244\001\000\006\240\001\000\006\244\002\000\006\244\003\000\006\244\004\000\006\244\005\000\005\248\001\000\005\184\001\000\006\244\006\000\006\240\002\000\006\240\003\000\006\240\004\000\005\248\001\000\005\184\001\000\006\240\005\000\n,\001\000\n$\001\000\n \001\000\006p\001\000\006l\001\000\006@\001\000\006p\002\000\006l\002\000\006p\003\000\006l\003\000\006p\004\000\006l\004\000\006p\005\000\006l\005\000\006p\006\000\006p\007\000\006d\001\000\006`\001\000\006T\001\000\006p\b\000\n,\002\000\n$\002\000\n \002\000\006@\002\000\n,\003\000\n$\003\000\n \003\000\006@\003\000\006@\004\000\0068\001\000\006@\005\000\006@\006\000\005\248\001\000\005\184\001\000\006@\007\000\n,\004\000\n,\005\000\n,\006\000\n,\007\000\006d\001\000\006`\001\000\006T\001\000\n,\b\000\004\236\001\000\004\236\002\000\004\236\003\000\004\236\004\000\006d\001\000\006`\001\000\006T\001\000\004\236\005\000\004\236\006\000\004\236\007\000\n,\t\000\n$\004\000\n \004\000\n$\005\000\n$\006\000\005\232\001\000\n$\007\000\006\012\001\000\006d\001\000\006`\001\000\006T\001\000\006\012\002\000\n \005\000\n \006\000\006\016\001\000\006\016\002\000\n<\001\000\n<\002\000\n<\003\000\n<\004\000\006d\001\000\006`\001\000\006T\001\000\n<\005\000\t\244\001\000\t\244\002\000\t\244\003\000\t\244\004\000\n@\001\000\001T\001\000\001T\002\000\001T\003\000\001T\004\000\r`\001\000\001T\005\000\002\020\001\000\tt\001\000\002\020\002\000\002\020\003\000\001T\006\000\001T\007\000\001T\b\000\001 \001\000\001 \002\000\000\244\001\000\001\180\001\000\000\244\002\000\000\244\003\000\001 \003\000\001\000\001\000\001\000\002\000\006\144\001\000\006\136\001\000\006\144\002\000\006\140\001\000\006\132\001\000\006\140\002\000\001\000\003\000\001\000\004\000\001\000\005\000\001\180\001\000\001\000\006\000\001\000\007\000\001\004\001\000\001\004\002\000\b\208\001\000\b\200\001\000\b\208\002\000\b\204\001\000\b\196\001\000\b\204\002\000\001\004\003\000\001\004\004\000\001\004\005\000\001\004\006\000\001\004\007\000\000\252\001\000\000\252\002\000\001,\001\000\001(\001\000\001,\002\000\001(\002\000\001,\003\000\001,\004\000\005\232\001\000\001,\005\000\001,\006\000\001\024\001\000\tl\001\000\001\024\002\000\001\024\003\000\001\024\004\000\tl\002\000\tl\003\000\001\180\001\000\th\001\000\001\180\001\000\001\028\001\000\001\020\001\000\001,\007\000\001$\001\000\001$\002\000\001(\003\000\005\232\001\000\001(\004\000\001(\005\000\001(\006\000\001$\001\000\001$\001\000\000\252\003\000\000\252\004\000\001\b\001\000\001\b\002\000\001\180\001\000\001\152\001\000\001\152\002\000\001\180\001\000\001\152\003\000\001\b\003\000\001\b\004\000\001 \004\000\001 \005\000\001\012\001\000\001\012\002\000\001\016\001\000\0050\001\000\0050\002\000\001T\t\000\001$\001\000\001T\n\000\004\220\001\000\004\220\002\000\004\220\003\000\004\220\004\000\004\220\005\000\004\220\006\000\004\220\007\000\001$\001\000\004\220\b\000\004\220\t\000\001T\011\000\n@\002\000\n@\003\000\n@\004\000\n@\005\000\n@\006\000\n@\007\000\005\172\001\000\001L\001\000\001L\002\000\001L\003\000\001L\004\000\001\212\001\000\001\208\001\000\001\204\001\000\001\024\001\000\t\172\001\000\th\001\000\001\180\001\000\001P\001\000\001P\002\000\001H\001\000\001H\002\000\001H\003\000\012\232\001\000\001X\001\000\002\b\001\000\001\028\001\000\001H\004\000\001D\001\000\001$\001\000\001P\003\000\001L\005\000\n@\b\000\n@\t\000\004\212\001\000\004\212\002\000\004\212\003\000\004\212\004\000\004\212\005\000\004\212\006\000\004\212\007\000\004\212\b\000\004\212\t\000\n@\n\000\n\004\001\000\005\024\001\000\n\028\001\000\n\b\001\000\n8\001\000\n4\001\000\n0\001\000\n(\001\000\005\024\002\000\t\252\001\000\t\252\002\000\n\012\001\000\004\252\001\000\004\252\002\000\004\252\003\000\004\252\004\000\004\252\005\000\t\024\001\000\004\252\006\000\004\252\007\000\004\252\b\000\n\012\002\000\n\016\001\000\005\004\001\000\005\004\002\000\005\004\003\000\005\004\004\000\005\004\005\000\001\212\001\000\001\208\001\000\001\204\001\000\001l\001\000\006\208\001\000\006\208\002\000\006\208\003\000\006\192\001\000\003\228\001\000\001\168\001\000\003\228\002\000\003\228\003\000\003\228\004\000\b\236\001\000\001\172\001\000\003\228\001\000\b\236\002\000\005\004\006\000\t\024\001\000\005\004\007\000\005\004\b\000\005\004\t\000\b\228\001\000\b\232\001\000\006\220\001\000\006\216\001\000\006\204\001\000\006\200\001\000\006\188\001\000\006\184\001\000\006\168\001\000\001\180\001\000\006\220\002\000\006\216\002\000\006\204\002\000\006\200\002\000\006\188\002\000\006\184\002\000\006\220\003\000\006\204\003\000\006\188\003\000\006\220\004\000\006\220\005\000\006\220\006\000\006\204\004\000\006\188\004\000\003\232\001\000\003\232\002\000\003\232\003\000\006\216\003\000\006\216\004\000\006\216\005\000\006\200\003\000\006\184\003\000\006\176\001\000\n\016\002\000\n\000\001\000\nD\001\000\005\020\002\000\b\144\002\000\t\248\001\000\b\148\002\000\001\180\001\000\012\132\001\000\001T\001\000\012\132\002\000\012\132\003\000\012\132\004\000\012\132\005\000\012\132\006\000\000\208\001\000\001@\001\000\001@\002\000\001@\003\000\000\184\001\000\rT\001\000\rL\001\000\rT\002\000\rL\002\000\rT\003\000\rL\003\000\rT\004\000\rL\004\000\rL\005\000\rL\006\000\rT\005\000\rT\006\000\rT\007\000\000\184\002\000\000\184\003\000\rP\001\000\rH\001\000\rD\001\000\rl\001\000\rd\001\000\rl\002\000\rh\001\000\006|\001\000\rh\002\000\rD\002\000\rD\003\000\rD\004\000\rD\005\000\001\180\001\000\rP\002\000\rH\002\000\rP\003\000\rH\003\000\rH\004\000\rH\005\000\rP\004\000\rP\005\000\rP\006\000\000\188\001\000\005\168\001\000\005\160\001\000\005\152\001\000\005\168\002\000\005\160\002\000\005\152\002\000\b\188\001\000\005\168\003\000\005\160\003\000\005\152\003\000\005\168\004\000\005\160\004\000\005\152\004\000\005\168\005\000\005\160\005\000\005\168\006\000\005\168\007\000\005\168\b\000\005\168\t\000\001\180\001\000\005\168\n\000\005\168\011\000\005\160\006\000\005\160\007\000\005\160\b\000\005\152\005\000\000\188\002\000\000\188\003\000\005\164\001\000\005\156\001\000\005\148\001\000\005\144\001\000\rx\001\000\rp\001\000\rx\002\000\rt\001\000\b\188\001\000\rt\002\000\005\144\002\000\005\144\003\000\005\144\004\000\005\144\005\000\005\164\002\000\005\156\002\000\005\148\002\000\005\164\003\000\005\156\003\000\005\148\003\000\005\164\004\000\005\156\004\000\005\164\005\000\005\164\006\000\005\164\007\000\005\164\b\000\001\180\001\000\005\164\t\000\005\164\n\000\005\156\005\000\005\156\006\000\005\156\007\000\005\148\004\000\000\196\001\000\000\196\002\000\000\196\003\000\000\196\004\000\000\180\001\000\000\176\001\000\000\180\002\000\000\180\003\000\001<\001\000\0010\001\000\004\160\001\000\004\156\001\000\000\160\001\000\000\156\001\000\004\160\002\000\004\160\003\000\004\160\004\000\004\160\005\000\004\160\006\000\004\160\007\000\000\160\002\000\000\156\002\000\000\160\003\000\000\160\004\000\005\232\001\000\000\160\005\000\000\160\006\000\0018\001\000\tl\001\000\0018\002\000\0018\003\000\0018\004\000\000\148\001\000\000\148\002\000\000\224\001\000\000\220\001\000\000\220\002\000\004\164\001\000\000\152\001\000\000\152\002\000\000\172\001\000\000\168\001\000\000\144\001\000\t0\001\000\000\168\002\000\0014\001\000\000\164\001\000\000\152\003\000\000\164\002\000\004\164\002\000\000\220\003\000\000\164\001\000\000\224\002\000\000\148\003\000\000\164\001\000\000\160\007\000\000\156\003\000\005\232\001\000\000\156\004\000\000\156\005\000\000\164\001\000\000\156\006\000\004\156\002\000\004\156\003\000\004\156\004\000\004\156\005\000\001<\002\000\0010\002\000\000\164\001\000\0010\003\000\001<\003\000\001<\004\000\001<\005\000\000\180\004\000\000\164\001\000\007\144\001\000\007\144\002\000\000\180\005\000\000\180\006\000\000\176\002\000\000\176\003\000\000\164\001\000\000\176\004\000\000\176\005\000\000\192\001\000\000\192\002\000\000\192\003\000\000\192\004\000\001@\004\000\001@\005\000\000\200\001\000\000\200\002\000\000\204\001\000\0058\001\000\0058\002\000\000\208\002\000\000\164\001\000\000\212\001\000\000\212\002\000\000\212\003\000\000\212\004\000\000\164\001\000\000\216\001\000\000\216\002\000\012\132\007\000\012\132\b\000\004\204\001\000\004\204\002\000\004\204\003\000\004\204\004\000\004\204\005\000\004\204\006\000\004\204\007\000\004\204\b\000\012\132\t\000\012`\001\000\005(\001\000\004\148\001\000\012p\001\000\0128\001\000\012\\\001\000\012\128\001\000\012|\001\000\005(\002\000\012P\001\000\004\152\001\000\012T\001\000\012T\002\000\012d\001\000\012d\002\000\012X\001\000\012\136\001\000\b\140\001\000\012L\001\000\012L\002\000\012L\003\000\000\136\001\000\012H\001\000\012P\001\000\004\152\001\000\003(\001\000\002\012\003\000\002\012\004\000\004\020\003\000\004\020\004\000\005$\002\000\005$\003\000\005$\004\000\005 \002\000\006\020\003\000\006\020\004\000\006L\005\000\006,\001\000\006(\001\000\006 \001\000\0118\007\000\006d\001\000\006`\001\000\006T\001\000\0118\b\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\000\236\002\000\000\232\002\000\000\232\003\000\000\236\003\000\001\180\001\000\000\236\004\000\000\236\005\000\n\184\004\000\n\184\005\000\n\184\006\000\002<\004\000\002<\005\000\tL\001\000\002<\006\000\b\176\003\000\b\176\004\000\003\248\t\000\012l\006\000\012l\007\000\012l\b\000\003\228\001\000\002\000\001\000\003\228\002\000\002\000\002\000\002\000\003\000\002\000\004\000\002\000\005\000\012l\t\000\t\004\001\000\t\000\001\000\012l\n\000\t\000\002\000\t\004\002\000\b\240\001\000\b\248\001\000\b\244\001\000\b\252\001\000\003\232\001\000\002\004\001\000\002\004\002\000\002\004\003\000\002\004\004\000\012h\004\000\003\244\004\000\005\172\001\000\003\244\005\000\003\244\006\000\t\024\001\000\003\244\007\000\003\244\b\000\012h\005\000\012h\006\000\012h\007\000\012h\b\000\t\004\001\000\t\000\001\000\012h\t\000\001\248\003\000\001\248\004\000\005\132\003\000\005|\003\000\005t\003\000\005\132\004\000\005|\004\000\005t\004\000\005|\005\000\005t\005\000\005|\006\000\005t\006\000\005\140\001\000\005t\007\000\005\136\001\000\005\128\001\000\005x\001\000\000l\001\000\000`\001\000\005\128\002\000\005x\002\000\005x\003\000\006\228\002\000\006\224\002\000\006\224\003\000\003\184\003\000\003\184\004\000\003\184\005\000\t\128\001\000\000p\002\000\000d\002\000\000p\003\000\000d\003\000\000p\004\000\000p\005\000\000d\004\000\t\128\002\000\t\128\003\000\001\180\001\000\t\132\001\000\001\196\002\000\001\180\001\000\t\132\002\000\t\132\003\000\001\180\001\000\006\212\002\000\006\212\003\000\006\212\004\000\006\196\002\000\006\172\002\000\001\180\001\000\006\180\002\000\012\228\002\000\003\240\007\000\003\240\b\000\t\024\001\000\003\240\t\000\003\240\n\000\n\024\006\000\n\024\007\000\n\024\b\000\n\024\t\000\t\016\001\000\n\024\n\000\t\016\002\000\t\b\001\000\t\012\001\000\n\020\004\000\003\244\004\000\003\236\004\000\005\172\001\000\003\244\005\000\003\236\005\000\003\236\006\000\003\236\007\000\t\024\001\000\003\236\b\000\003\236\t\000\n\020\005\000\n\020\006\000\n\020\007\000\n\020\b\000\t\016\001\000\n\020\t\000\006D\003\000\006D\004\000\006d\001\000\006`\001\000\006T\001\000\001\200\005\000\001\200\006\000\rX\006\000\rX\007\000\000\140\003\000\000\140\004\000\002X\003\000\002X\004\000\002X\005\000\002X\006\000\002X\007\000\004\004\001\000\004\004\002\000\000\000\001\000\000\004\000\000\004\016\001\000\004\016\002\000\000\004\001\000\000\b\000\000\r4\001\000\005\192\001\000\001p\001\000\005\192\002\000\005\192\003\000\005\196\001\000\000\b\001\000\005\248\001\000\005\208\001\000\005\204\001\000\005\200\001\000\005\184\001\000\005\208\002\000\005\204\002\000\005\200\002\000\005\184\002\000\r4\001\000\005\204\003\000\005\204\004\000\005\204\005\000\005\208\003\000\005\200\003\000\000P\001\000\005\188\001\000\000T\001\000\b\000\001\000\b\000\002\000\000\012\000\000\000\012\001\000\b\004\001\000\b\004\002\000\000\016\000\000\000\016\001\000\b\b\001\000\001\180\001\000\b\b\002\000\000\020\000\000\b\012\001\000\b\012\002\000\000\020\001\000\000\024\000\000\000\024\001\000\b\016\001\000\005\248\001\000\005\184\001\000\b\016\002\000\000\028\000\000\000\028\001\000\b\020\001\000\005\232\001\000\b\020\002\000\000 \000\000\000 \001\000\b\024\001\000\006,\001\000\006(\001\000\006 \001\000\b\024\002\000\000$\000\000\000$\001\000\b\028\001\000\006d\001\000\006`\001\000\006T\001\000\b\028\002\000\000(\000\000\000(\001\000\b \001\000\b \002\000\000,\000\000\bL\001\000\b@\001\000\b8\001\000\b0\001\000\b,\001\000\b$\001\000\b$\002\000\000,\001\000\0000\000\000\b(\001\000\b(\002\000\0000\001\000\005\240\001\000\005\232\001\000\005\240\002\000\005\232\002\000\0004\000\000\012\184\001\000\012\180\001\000\012\176\001\000\012\172\001\000\012\168\001\000\012\164\001\000\012\160\001\000\012\184\002\000\012\180\002\000\012\176\002\000\012\172\002\000\012\168\002\000\012\164\002\000\012\160\002\000\012\184\003\000\012\164\003\000\012\168\003\000\012\180\003\000\012\172\003\000\012\176\003\000\005\240\001\000\005\232\001\000\012\200\001\000\0004\001\000\012\196\001\000\012\196\002\000\005@\001\000\005@\002\000\012\188\001\000\012\188\002\000\012\188\003\000\012\192\001\000\012\192\002\000\0008\000\000\005L\001\000\005H\001\000\005T\001\000\005P\001\000\005P\002\000\005T\002\000\005L\002\000\005L\003\000\005L\004\000\005H\002\000\0008\001\000\r0\001\000\r0\002\000\r0\003\000\r0\004\000\r,\001\000\r,\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\000D\000E\000F\000G\000H\000I\000J\000K\000L\000M\000N\000O\000P\000Q\000R\000S\000T\000U\000[\000]\000^\000_\000a\000c\000d\000f\000h\000j\000k\000m\000o\000q\000r\000s\000t\000u\000v\000w\000x\000y\000z\000{\000|\000}\000~\000\127\000\128\000\130\000\131\000\132\000\134\000\135\000\136\000\137\000\138\000\142\000\143\000\144\000\145\000\146\000\147\000\149\000\150\000\151\000\157\000\163\000\169\000\170\000\172\000\173\000\176\000\178\000\179\000\180\000\181\000\184\000\185\000\186\000\187\000\188\000\189\000\190\000\191\000\192\000\194\000\195\000\196\000\197\000\200\000\203\000\204\000\206\000\207\000\211\000\217\000\218\000\220\000\221\000\222\000\224\000\228\000\231\000\232\000\233\000\234\000\235\000\239\000\243\000\247\000\249\000\251\000\253\000\254\001\000\001\001\001\002\001\003\001\004\001\005\001\006\001\007\001\b\001\t\001\n\001\012\001\r\001\015\001\016\001\017\001\019\001\020\001\021\001\028\001\031\001!\001#\001%\001&\001'\001)\001*\001+\001,\001-\001.\001/\0010\0011\0012\0014\0015\0016\0017\0019\001:\001;\001<\001F\001N\001V\001W\001X\001Y\001Z\001\\\001^\001_\001`\001a\001b\001c\001d\001e\001f\001g\001h\001i\001j\001q\001s\001u\001x\001z\001{\001}\001\127\001\128\001\129\001\130\001\131\001\132\001\136\001\137\001\139\001\140\001\142\001\144\001\145\001\146\001\149\001\150\001\153\001\154\001\157\001\158\001\159\001\160\001\161\001\163\001\164\001\165\001\166\001\167\001\168\001\169\001\170\001\172\001\173\001\175\001\176\001\177\001\181\001\184\001\186\001\187\001\188\001\189\001\190\001\191\001\192\001\193\001\194\001\195\001\199\001\200\001\203\001\204\001\205\001\206\001\207\001\209\001\210\001\211\001\213\001\214\001\215\001\216\001\217\001\220\001\221\001\222\001\223\001\225\001\226\001\227\001\228\001\230\001\231\001\232\001\233\001\235\001\236\001\238\001\239\001\241\001\242\001\244\001\246\001\247\001\248\001\249\001\251\001\252\001\254\001\255\002\002\002\003\002\004\002\006\002\007\002\b\002\t\002\011\002\015\002\016\002\017\002\018\002\019\002\020\002\021\002\022\002\023\002\024\002\025\002\026\002\027\002\028\002\029\002\030\002 \002!\002\"\002#\002$\002+\0021\0024\0025\0026\0027\0028\0029\002:\002<\002=\002C\002D\002J\002K\002Q\002R\002X\002Y\002Z\002[\002]\002c\002d\002g\002o\002p\002r\002s\002t\002u\002v\002w\002x\002{\002|\002}\002\132\002\133\002\134\002\136\002\137\002\143\002\149\002\150\002\151\002\157\002\158\002\160\002\161\002\162\002\163\002\171\002\173\002\174\002\175\002\181\002\185\002\188\002\189\002\190\002\191\002\192\002\193\002\194\002\195\002\198\002\200\002\201\002\203\002\204\002\206\002\207\002\208\002\209\002\211\002\212\002\213\002\214\002\219\002\221\002\222\002\223\002\224\002\225\002\226\002\228\002\229\002\230\002\231\002\233\002\234\002\235\002\236\002\237\002\239\002\240\002\241\002\242\002\243\002\247\002\248\002\250\002\252\002\254\003\000\003\001\003\002\003\004\003\005\003\007\003\t\003\n\003\012\003\r\003\015\003\016\003\020\003\022\003\024\003\025\003\029\003\030\003\"\003#\003&\003(\003*\003+\003,\003-\003.\003/\0033\0036\0037\003:\003;\003<\003?\003@\003B\003C\003D\003E\003I\003M\003N\003R\003S\003T\003U\003V\003Z\003e\003f\003k\003l\003m\003q\003r\003s\003t\003v\003w\003{\003|\003~\003\128\003\131\003\133\003\134\003\136\003\137\003\139\003\140\003\141\003\142\003\144\003\146\003\148\003\154\003\160\003\166\003\169\003\172\003\175\003\176\003\184\003\185\003\186\003\187\003\188\003\190\003\191\003\192\003\199\003\200\003\202\003\203\003\204\003\205\003\206\003\207\003\215\003\216\003\217\003\218\003\219\003\220\003\221\003\223\003\224\003\225\003\226\003\227\003\230\003\231\003\232\003\235\003\238\003\241\003\245\003\247\003\250\003\253\004\000\004\004\004\005\004\006\004\007\004\b\004\t\004\n\004\016\004\017\004\018\004\019\004\020\004!\004\"\004/\0040\0041\0044\0045\004:\004?\004D\004J\004L\004M\004N\004O\004\\\004c\004d\004f\004i\004l\004o\004s\004\149\004\151\004\152\004\153\004\154\004\156\004\158\004\161\004\162\004\164\004\165\004\166\004\167\004\168\004\169\004\170\004\183\004\184\004\197\004\209\004\214\004\215\004\217\004\219\004\220\004\221\004\222\004\226\004\227\004\231\004\232\004\234\004\236\004\238\004\240\004\241\004\243\004\244\004\245\004\248\004\250\004\253\005\000\005\003\005\007\005\t\005\022\005\023\005\024\005\025\005\026\005\028\005\029\005\030\005\031\005P\005R\005U\005X\005[\005_\005\141\005\143\005\146\005\149\005\152\005\156\005\202\005\204\005\207\005\210\005\213\005\217\006\007\006\t\006\012\006\015\006\018\006\022\006D\006F\006I\006L\006O\006S\006\129\006\131\006\134\006\137\006\140\006\144\006\190\006\192\006\195\006\198\006\201\006\205\006\251\006\253\007\000\007\003\007\006\007\n\0078\007:\007=\007@\007C\007G\007u\007w\007z\007}\007\128\007\132\007\178\007\180\007\183\007\186\007\189\007\193\007\239\007\241\007\244\007\247\007\250\007\254\b,\b.\b1\b4\b7\b;\bi\bk\bn\bq\bt\bx\b\166\b\168\b\171\b\174\b\177\b\181\b\227\b\229\b\232\b\235\b\238\b\242\t \t\"\t%\t(\t+\t/\t]\t_\tb\te\th\tl\t\154\t\156\t\159\t\162\t\165\t\169\t\215\t\217\t\220\t\223\t\226\t\230\n\020\n\022\n\025\n\028\n\031\n#\nQ\nS\nV\nY\n\\\n`\n\142\n\143\n\145\n\158\n\160\n\163\n\166\n\169\n\173\n\219\n\222\n\223\n\224\n\225\n\226\n\227\n\228\n\234\n\235\n\236\n\240\n\241\n\242\n\243\n\245\n\246\n\247\n\249\n\250\n\251\n\252\n\254\n\255\011\000\011\001\011\002\011\003\011\004\011\005\011\006\011\007\011\b\011\t\011\n\011\011\011\r\011\014\011\016\011\017\011\018\011\024\011\025\011\026\011\027\011!\011\"\011(\011)\011/\0110\0111\0112\0113\0115\0116\011<\011=\011>\011?\011@\011A\011B\011p\011v\011w\011x\011z\011{\011|\011}\011~\011\127\011\129\011\130\011\131\011\133\011\134\011\135\011\136\011\184\011\186\011\187\011\189\011\190\011\191\011\192\011\193\011\194\011\195\011\196\011\209\011\210\011\211\011\214\011\217\011\220\011\222\011\223\011\224\011\225\011\226\011\240\011\253\011\255\012\000\012\001\012\014\012\023\012\026\012\029\012 \012\"\012%\012(\012+\012/\012]\012`\012c\012f\012h\012k\012n\012q\012u\012\163\012\166\012\169\012\172\012\174\012\177\012\180\012\183\012\187\012\233\012\254\r\001\r\004\r\007\r\t\r\012\r\015\r\018\r\022\rD\rG\rJ\rM\rO\rR\rU\rX\r\\\r\138\r\141\r\144\r\147\r\149\r\152\r\155\r\158\r\162\r\208\r\219\r\228\r\231\r\234\r\237\r\239\r\242\r\245\r\248\r\252\014*\014-\0140\0143\0145\0148\014;\014>\014B\014p\014s\014v\014y\014{\014~\014\129\014\132\014\136\014\182\014\185\014\187\014\190\014\193\014\196\014\200\014\246\015\003\015\005\015\006\015\007\0155\0156\0157\0158\0159\015:\015;\015<\015=\015B\015E\015F\015G\015H\015I\015J\015K\015L\015M\015N\015O\015P\015Q\015R\015S\015T\015U\015V\015W\015X\015Y\015Z\015[\015\\\015]\015^\015_\015`\015\142\015\143\015\144\015\145\015\146\015\148\015\149\015\150\015\151\015\155\015\161\015\167\015\172\015\177\015\182\015\188\015\190\015\193\015\196\015\199\015\203\015\249\016)\016+\016.\0161\0164\0168\016f\016g\016h\016i\016v\016y\016|\016\127\016\131\016\132\016\178\016\179\016\192\016\193\016\194\016\197\016\200\016\203\016\207\016\253\017\000\017\002\017\003\017\004\017\005\017\006\017\007\017\b\017\t\017\n\017\011\017\015\017\016\017\017\017\018\017\019\017\020\017\021\017\022\017\026\017\027\017\031\017 \017$\017%\017&\017'\017(\017)\017*\017+\017,\017-\017/\0170\0171\0172\0173\0174\0175\0176\0178\017:\017<\017>\017?\017A\017C\017E\017F\017G\017I\017J\017K\017M\017N\017O\017Q\017S\017W\017X\017\\\017`\017c\017e\017f\017g\017j\017o\017p\017q\017t\017y\017z\017{\017|\017}\017~\017\127\017\128\017\129\017\130\017\131\017\132\017\133\017\134\017\135\017\136\017\137\017\140\017\143\017\146\017\150\017\196\017\197\017\198\017\199\017\212\017\214\017\216\017\218\017\223\017\224\017\225\017\229\017\230\017\232\017\233\017\234\017\235\017\236\017\237\017\239\017\245\017\251\018\001\018\b\018\t\018\n\018\014\018\015\018\017\018\022\018\023\018\024\018\028\018\029\018N\018O\018P\018T\018U\018W\018\\\018]\018^\018b\018c\018g\018h\018i\018j\018n\018o\018r\018s\018t\018u\018v\018w\018{\018|\018}\018\127\018\129\018\130\018\131\018\132\018\133\018\134\018\135\018\136\018\137\018\138\018\139\018\140\018\141\018\142\018\143\018\144\018\145\018\147\018\154\018\155\018\156\018\157\018\158\018\159\018\160\018\161\018\165\018\166\018\167\018\168\018\169\018\170\018\171\018\173\018\174\018\176\018\177\018\178\018\180\018\181\018\182\018\183\018\185\018\187\018\189\018\191\018\193\018\194\018\196\018\199\018\201\018\202\018\203\018\204\018\205\018\206\018\207\018\208\018\210\018\211\018\213\018\214\018\215\018\216\018\219\018\220\018\221\018\222\018\225\018\226\018\232\018\234\018\236\018\238\018\240\018\241\018\245\018\246\018\250\018\254\019\000\019\001\019\004\019\005\019\006\019\007\019\b\019\012\019\r\019\014\019\015\019\016\019\017\019\021\019\022\019\023\019\024\019\026\019\027\019\029\019\030\019\031\019#\019$\019%\019&\019'\019(\019)\019*\019.\019/\0190\0191\0192\0193\0195\0196\0197\0198\0199\019:\019;\019=\019>\019?\019@\019A\019B\019C\019D\019F\019G\019H\019I\019J\019L\019M\019O\019P\019Q\019R\019S\019U\019V\019W\019X\019Z\019[\019]\019^\019_\019`\019a\019b\019c\019d\019e\019g\019i\019j\019k\019m\019n\019o\019q\019r\019s\019t\019v\019x\019y\019z\019|\019}\019~\019\128\019\129\019\131\019\133\019\134\019\135\019\136\019\138\019\139\019\141\019\142\019\143\019\144\019\145\019\146\019\147\019\148\019\149\019\150\019\152\019\153\019\154\019\155\019\156\019\157\019\158\019\159\019\161\019\162\019\163\019\164\019\165\019\166\019\167\019\168\019\169\019\170\019\172\019\173\019\174\019\175\019\179\019\182\019\183\019\184\019\185\019\186\019\187\019\189\019\191\019\192\019\194\019\195\019\196\019\197\019\198\019\199\019\200\019\201\019\202\019\203\019\204\019\205\019\206\019\207\019\208\019\209\019\210\019\211\019\212\019\213\019\214\019\215\019\216\019\217\019\218\019\219\019\220\019\221\019\222\019\223\019\224\019\225\019\227\019\228\019\229\019\230\019\231\019\232\019\233\019\234\019\235\019\236\019\240\019\241\019\242\019\243\019\244\019\246\019\247\019\248\019\249\019\251\019\252\019\253\019\254\020\000\020\001\020\002\020\003\020\004\020\012\020\018\020\021\020\022\020\023\020\024\020\025\020\026\020\027\020\028\020\029\020\030\020\031\020 \020!\020\"\020#\020$\020%\020&\020'\020(\020)\020+\020-\020.\020/\0200\0201\0202\0203\0204\0205\0206\0207\0209\020;\020=\020?\020@\020A\020B\020C\020D\020E\020F\020I\020K\020L\020N\020O\020P\020Q\020R\020T\020V\020X\020Y\020Z\020[\020\\\020]\020^\020a\020d\020e\020h\020k\020m\020n\020o\020p\020r\020s\020t\020u\020v\020w\020x\020y\020z\020~\020\128\020\129\020\131\020\132\020\133\020\134\020\135\020\136\020\139\020\142\020\144\020\145\020\146\020\147\020\149\020\150\020\151\020\152\020\153\020\154\020\155\020\156\020\157\020\158\020\159\020\161\020\162\020\163\020\165\020\169\020\170\020\171\020\172\020\173\020\174\020\175\020\177\020\178\020\179\020\181\020\182\020\183\020\185\020\186\020\187\020\188\020\189\020\191\020\192\020\194\020\195\020\196\020\198\020\200\020\201\020\203\020\204\020\205\020\207\020\208\020\209\020\211\020\212\020\214\020\215\020\217\020\218\020\219\020\220\020\221\020\224\020\225\020\226\020\227\020\228\020\230\020\231\020\232\020\233\020\234\020\235\020\237\020\238\020\239\020\240\020\241\020\242\020\243\020\244\020\245\020\246\020\247\020\248\020\249\020\250\020\252\020\253\020\254\020\255\021\001\021\002\021\003\021\004\021\005\021\006\021\007\021\b\021\t\021\n\021\011\021\012\021\r\021\014\021\015\021\016\021\017\021\018\021\019\021\020\021\021\021\022\021\023\021\025\021\026\021\027\021\028\021\029\021\030\021\031\021 \021!\021\"\021#\021$\021%\021(\021)\021*\021+\021,\021-\021.\021/\0210\0211\0212\0216\021:\021;\021B\021C\021D\021F\021G\021H\021I\021J\021K\021L\021N\021O\021P\021Q\021R\021S\021T\021V\021X\021Y\021Z\021[\021^\021_\021`\021a\021b\021c\021d\021e\021g\021h\021i\021j\021l\021n\021o\021q\021r\021s\021t\021u\021x\021y\021z\021{\021~\021\129\021\131\021\133\021\134\021\135\021\140\021\142\021\143\021\144\021\145\021\146\021\147\021\148\021\149\021\152\021\154\021\155\021\156\021\157\021\158\021\160\021\163\021\164\021\166\021\167\021\168\021\169\021\170\021\172\021\173\021\174\021\175\021\176\021\178\021\179\021\180\021\181\021\182\021\184\021\185\021\186\021\187\021\188\021\191\021\194\021\195\021\196\021\198\021\199\021\200\021\201\021\202\021\204\021\205\021\206\021\207\021\211\021\212\021\213\021\214\021\215\021\216\021\217\021\218\021\219\021\220\021\221\021\222\021\223\021\224\021\225\021\226\021\227\021\228\021\229\021\232\021\233\021\234\021\235\021\236\021\241\021\245\021\247\021\248\021\249\021\250\021\251\021\252\021\253\021\254\021\255\022\000\022\001\022\002\022\003\022\004\022\005\022\006\022\b\022\t\022\n\022\011\022\012\022\r\022\014\022\015\022\018\022\019\022\020\022\021\022\023\022\024\022\025\022\026\022\030\022\031\022 \022!\022%\022&\022'\022(\022)\022*\022+\0221\0222\0223\0224\0225\0226\0227\0229\022;\022<\022C\022J\022K\022L\022M\022N\022O\022R\022S\022T\022U\022V\022W\022X\022Y\022Z\022[\022\\\022]\022^\022`\022a\022b\022c\022d\022e\022f\022g\022h\022i\022j\022k\022l\022m\022n\022o")) and nullable = - "\000\000\016)\001\000@\000\000\135\b\000\000\255\224\024\000\000\007\255\240\000\b\016\b \000\006\004\000" + "\000\000\016)\001\000@\000\000\135\b\000\000\255\224\024\000\000\031\255\192\000 @ \128\0000 \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@\b\b\000\004\012\b\000\000\000@\000\000\000\000\000\006\002\000@\000\000@@\000\000\002\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\001\141\194\000\139\005\027\248\145\232\002\003\232\005\000\0068\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\000\000\b\128\000\000\000\001\128\002\000\000\000\016\000\000\000\000\001 \004\016\001\004\000\016\128\000\128\000d\000\000\128\000\207\225 \197\138\173\252\204\244\005\001\247\"\128\007\028\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000@\000\000\000\b\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\001\000\000\000\000\004\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\000\000\000\b\004\000 \000\000\000\000\000\000\002\000\002\000\000\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\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\001\159\194A\139\021[\249\153\232\n\131\238E\000\0148\000\000\000\000H\000@\000\000\002\000\000\000\000\000\001\000\002\000\000\016\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\146\000\017\000\000\000\128\000\000\000\000\000@\000\128\000\004\144\000\128\000\000\004\000\000\000\000\000\002\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\018\000\000\012\000\000\192\000\000\194\225\000\000\128\000\000\000\000\000\012\254\018\012X\170\223\204\207@T\031r(\000q\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\001\128\000\000\000\000\000\000\000\000\000\000\t\000\000\128\b \020\132\000\004\000\003\000\000\004\000\006\127\t\006,Uo\230g\160(\015\184\020\0008\224\001\138@\020$\001\024\018+\000\016\005 \000\000\130\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\023\183d@\130\254*@\0010p:q\193`Ph\003\016\128 @\002 $R\000 \n\000\000\001\004\000\024\132\001\002\000\017\129\"\144\001\000P\000\000\b \000\196 \b\128P\012\t\028\128\000\002\128P\000c\000\000\000\000\000\000\000\000\b\160\000\000\000\000\000\000\000\000\000\b\000\004\000 \000\000 \000\000\128\000\000\016\000\002@\000 \002\b\000!\000\001\000\000\192\000\001\000\000\018\000A\000\016@\001\b\000\b\000\006\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\b\000\000\000\000\000\128\000\000\000\000\000\000\000\000\000\000\196 \b\016\000\140\t\022\128\b\002\160\000\000A\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\001\128\000\028\004\000\024\\ \000\016\000\000\000\000\002\000\012\000\000\192\000\000\194\225\000\000\128\000\000\000\000\000\012n\016\004X(\223\196\143@\016\031@(\0001\192\003\000\0008\b\0000\184@\000 \000\000\000\000\000\000\024\000\001\128\000\001\133\194\000\001\000\000\000\000\000\000\000\128\000\004\144\000\128\000\000\004\000\000\000\000\000\002\000\006\000\000p\016\000ap\128\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\b\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\000b\016\004\b\000F\004\139@\004\001P\000\000\"\128\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\197 \n\130P\012\t\029\128\000\002\128P\000c\000\000\000\000\000\000\000@\000\000\000\000\000\000\000\000\000\0001H\002\132\128#\002E`\002\000\160\000\000\016@\000\000\000\000\000\000\000\000\000\000\000\000\000\000\128\000\000\004@\000\000\000\000\128\001\000\000\000\b\000\000\000@\000\"\000\000\000\000\004\000\b\000\000\000@\000\000\002\000\001\016\000\000\000\000 \000@\000\000\002\000\000\000\016\000\024\132\001\016\n\001\129#\144\000\000P\n\000\012`\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\000\016\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\128\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\003\000\0008\b\0000\184@\000 \000\000\000\000\000\003?\132\131V*\183\2433\208\020\007\220\n\000\228P\000\227\128\002\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\004@\000\000\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\002\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\004\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\006\000\000p\016\000ap\128\000@\000\000\000\000\000\0067\b\002,\020o\226G\160\b\015\160\020\000\024\224\001\138@\020$\001\024\018+\000\016\005\000\000\000\130\000\012R\000\161 \b\192\145X\000\128(\000\000\004\016\012n\016\004X(\223\196\143@\016\031@(\0001\192cp\128\"\193F\254$z\000\128\250\001@\001\142\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\128\000\000\000\000\000\000\000\000\000\000\000@\000\000\000@\000\000\000\000\000\000\000\000\000\017\000\000\000\000\002\000\004\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\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\000cp\128\"\193F\254$z\000\128\250\001@\001\142\000\000@\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\b\006\016\000\000\000\000\000\000\000\000\000\000\000@\000\000Ap\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\136\000\000\000\000\016\000 \000\000\001\000\000\000\b\000\012\000\000\192\000\000\194\225@\000\128\000\000\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\000\000\b\128\000\000\000\001\000\002\000\000\000\016\000\000\000\000\000\004\000\000\000\000\b\000\016\000\000\000\128\000\000\000\000\000\001\000\000\000\000\000\000\004\000\000\016\000\000\002\000\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\001\000\000\012\000\000\224$\000\202\225\000\000\128\000\000\000\000\000\000 \000\000\000 \006\000\b\000\000\000\000\000\000\000\000\001\000\000 \001\000\018 @\000\000\000\000\000\000\000\000 \000\002\000\000\b\002\016\004\000\000\000\000\b\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\016\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\000\000\130\000\012R\000\161 \b\192\145X\000\128)\000\000\020\016\000\128\000\b\000\000 \b@0\000\000\000\000 \000\000\001\000\000 \001\0002 @\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\000\025\252$\026\177U\191\153\158\128\160>\224P\001\227\129{vD\b/\226\164\000\019\007\003\167\028\022\005\006\1280\000\003\000\000\003\011\132\000\002\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\000\000\000\000\000\000\000\000\000\001\000`\000\007\001\000\006\023\b\000\004\000\000\000\000\000\000\000\000\000\000\192\000\000\000\000\000\000\000\000\000\000\000\000") + (127, "'\225 \197\138\173\2433\208\021\007\242(\000q\192O\194A\139\021[\230g\160*\015\228P\000\227\128\004\000\000\000\000\003\000\000\000\000\000\000\000\000\000\000\025\b\002\004\000&\t\022\128\b\006\128\000\001\004\000\016\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000 \b\b\000\004\024 \000\000\001\000\000\000\000\000\000\192\128\016\000\000 @\000\000\002\000\000\000\000\000\000\128\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\000F\194\000\139\005\027\226G\160\b\015\128P\000c\128\012\000\001\192@\003\023\b\000\004\000\000\000\000\000\000\t\000\000\000\000\004\000\016\000\000\002\000\000\000\000\000\018\000\000\000\000\012\000 \000\000\004\000\000\000\000\000\144\004\016\001\004\000B\000\002\000\006@\000\b\000\t\248H1b\171|\204\244\005\001\252\138\000\028p\000\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\128\000\000\000 \000\000\000\000\000\000\000\000\000\000\016\000\000\016\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\001\000\000\000\000\b\b\000\128\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\000\128\000\000\000\000\000\000\000\000\000O\194A\139\021[\230g\160*\015\228P\000\227\128\000\000\000\018\000\016\000\000\002\000\000\000\000\000\004\000\016\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\002H\000H\000\000\b\000\000\000\000\000\016\000@\000\004\144\000\128\000\000\016\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\128\000\006\000\000\192\000\001\139\132\000\002\000\000\000\000\000\000\159\132\131\022*\183\204\207@T\031\200\160\001\199\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\b\000\000\000\000\000\001\128\000\000\000\000\000\000\000\000\000\001 \000 \002\b\004\132\000\004\000\012\000\000\016\000\019\240\144b\197V\249\153\232\n\003\248\020\0008\224\003)\000P\144\004\193\"\176\001\000\200\000\000 \128\000\000\000\000\000\000\000\000\000\000\000 \000\000\000\001\247\217\016 \191\141@\0010p=\199\005\129A\160\025\b\002\004\000$\t\020\128\b\006\000\000\001\004\0002\016\004\b\000L\018)\000\016\012\000\000\002\b\000d \b\128P\024$r\000\000\024\005\000\0060\000\000\000\000\000\000\000\b\160\000\000\000\000\000\000\000\000\000\128\000@\002\000\000\b\000\000@\000\000\016\000\004\128\000\128\b \002\016\000\016\0000\000\000@\000\t\000A\000\016@\004 \000 \000`\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000@\000\000\000\001\027\b\002,\020o\137\030\128 >\001@\001\142\000\016\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000d \b\016\000\152$Z\000 \026\000\000\004\016\000\000\000\000\000\000\016\000\000\000\000\000\000\000\000\000\017\176\128\"\193F\248\145\232\002\003\224\020\000\024\224\003\000\000p\016\000\197\194\000\001\000\000\000\000\000\128\006\000\000\192\000\001\139\132\000\002\000\000\000\000\000\000\141\132\001\022\n7\196\143@\016\031\000\160\000\199\000\024\000\003\128\128\006.\016\000\b\000\000\000\000\000\0000\000\006\000\000\012\\ \000\016\000\000\000\000\000\000@\000\004\144\000\128\000\000\016\000\000\000\000\000 \000\192\000\028\004\0001p\128\000@\000\000\000\000\000\001\128\0008\b\000b\225\000\000\128\000\000\000\000@\000\128\000\000\000 \000\000\000\000\000\000\000\000\000\000\006\000\000\224 \001\139\132\000\002\000\000\000\000\000\000\012\132\001\002\000\019\004\139@\004\003@\000\000\138\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\b\000e \n\130P\024$v\000\000\024\005\000\0060\000\000\000\000\000\000 \000\000\000\000\000\000\000\000\000\001\148\128(H\002`\145X\000\128`\000\000\016@\000\000\000\000\000\000\000\000\000\000\000\000\000 \000\000\002@\000\000\000\001\000\004\000\000\000\128\000\000\004\000\004\128\000\000\000\002\000\b\000\000\001\000\000\000\b\000\t\000\000\000\000\004\000\016\000\000\002\000\000\000\016\0002\016\004@(\012\0189\000\000\012\002\128\003\024\000\000\000\128\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\002\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\016\000\000\000\000\000\000\000\000\012\000\001\192@\003\023\b\000\004\000\000\000\000\000\000\024\000\003\128\128\006.\016\000\b\000\000\000\000\000\002~\018\rX\170\2233=\001@\127\002\128\015\028\000@\000\000\000\000\b\000\000\000\000\000\000\000\000\000\000\200@\016 \0010H\180\000@0\000\000\b \001\144\128 @\002`\145h\000\128`\000\000\016@\003!\000@\128\004\193\"\208\001\000\192\000\000 \128\006B\000\129\000\t\130E\160\002\001\160\000\000A\000\012\132\001\002\000\019\004\139@\004\003@\000\000\130\000\b\000\000\000\000\006\000\000\000\000\000\000\000\000\000\0002\016\004\b\000L\018-\000\016\r\000\000\002\b\000 \000\000\000\000\b\000\000\000\000\000\000\000\000\000\000@\016\016\000\b0@\000\000\002\000\000\000\000\000\001\129\000 \000\000@\128\000\000\004\000\000\000\000\000\001\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\141\132\001\022\n7\196\143@\016\031\000\160\000\199\000\024\000\003\128\128\006.\016\000\b\000\000\000\000\000\000\018\000\000\000\000\b\000 \000\000\004\000\000\000\000\000$\000\000\000\000\024\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\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\004\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\128\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\016\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\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\004\000?\000a \000\031\016\128@\128\016(\176\000\000\000\000\128\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\001\000\000\000\000\000\000\000\000\000\001\144\000<\b\000b\225@\000\128 \002\000\001\000\000\001\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\002\000@\000\000\000\002\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\b\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\016\000\000\000\000\000\000\000\000\000\000\001\000@@\000 \193\000\000\000\b\000\000\000\000\000\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\024\016\002\000\000\004\b\000\000\000@\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\016\000\000\000\000\001\000\000\016\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\001\000\000\000\000\000\192\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\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\016\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@\000\000\000\000\016\000\000\000\000\000\000\000\000\000\004\000\000\004\000\000 \002\000\000\000\000\000\000\000\128\003\000\000`\000\000\197\194\000\001\000\000\004\000\000\000\006B\000\129\000\t\130E\160\002\001\160\000\000A\000\004\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000$\001\004\000A\000\144\128\000\136\001\128\000\002\000\000H\000\b\000\130\001!\000\001\000\003\000\000\004\000\000\128\000\016\000\000@B\001\128\000\000\000\004\000\000\001\000\000 \000\000\128\132\001\000\000\000\000\b\000\000\002@\016@\004\016\t\b\000\b\000\024\000\000 \000\004\128 \128\b \002\016\000\016\0000\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\001\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\004\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\016\012\132\001\002\000\019\004\139@\004\003\000\000\000\130\000\025\b\002\004\000&\t\022\128\b\006\000\000\001\004\0002\016\004\b\000L\018-\000\016\r\000\000\002\b\000\000\000\000\000\000\002\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\001\144\128 @\002`\145h\000\128`\000\000\016@\003!\000@\128\004\193\"\208\001\000\192\000\000 \128\006R\000\161 \t\130E`\002\001\128\000\000A\000\012\164\001PJ\003\004\142\192\000\003\000\160\000\198\000\b\000\000\000\000\002\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\b\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\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\128\000\000\002\000\000\000\000\000\000\000\000\000\t\000A\000\016@\004 \000 \000d\000\000\128\000\000\000@\000\000\000\000\000\000\000\000\000\000\000\000\001?\t\006,Uo\153\158\128\160?\145@\003\142\000\016\000\000\000\000\004\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\144\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\002\000\000\000\000\000\b\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\002\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\0000\000\007\001\000\012\\ \000\016\000\000\000\000\000\004l \b\176Q\190$z\000\128\248\005\000\0068\000\202@\020$\0010H\172\000@0\000\000\b \001\148\128(H\002`\145X\000\128`\000\000\016@#a\000E\130\141\241#\208\004\007\192(\0001\192F\194\000\139\005\027\226G\160\b\015\128P\000c\128\000\000\000\000\000\000\000\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\004\000\000\000\016\000\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\128\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\128\000\000\000\000\000\000\000\000\002\003\b\000\000\000\000\000\000\000\000\000\000\002\000\000\004.\016\000\000\000\000\000\000\000\0000\000\007\001\000\012\\ \000\016\000\000\000\000\000\000$\000\000\000\000\016\000@\000\000\b\000\000\000@\000\192\000\024\000\0001p\160\000@\000\000\000\000\000\001\128\0008\b\000b\225\000\000\128\000\000\000\000\000\001 \000\000\000\000\128\002\000\000\000@\000\000\000\000\002@\000\000\000\001\000\004\000\000\000\128\000\000\000\000\000\128\000\000\000\002\000\b\000\000\001\000\000\000\000\000\000\b\000\000\000\000\000\000\128\000\004\000\000\001\000\000\016\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\b\000\000\192\000\028\004\1285p\128\000@\000\000\000\000\000\000\128\000\000\001\000`\001\000\000\000\000\000\000\000\000\001\000\000@\002\000Q\002\000\000\000\000\000\000\000\000\b\000\001\000\000\004\004 \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\004\000\000\000\000\000\000\000\000\000\000\016\000\000\000\000\004\000\000\000\000\000\000\000\000\000\000e \n\018\000\152$V\000 \024\000\000\004\016\000\202@\020$\0010H\172\000@2\000\000( \002\000\000@\000\001\001\b\006\000\000\000\000\016\000\000\001\000\000@\002\000\209\002\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\b\000\000\000\000\000\000\000\000\159\132\131V*\183\204\207@P\031\192\160\003\199\003\239\178 A\127\026\128\002`\224{\142\011\002\131@0\000\006\000\000\012\\ \000\016\000\000\000\000\000\000$\000\000\000\000\024\000@\000\000\b\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\001\128\0008\b\000b\225\000\000\128\000\000\000\000\000\000\000\000\001\128\000\000\000\000\000\000\000\000\000\000\000") end) (ET) (TI) @@ -46726,59 +54623,59 @@ end let use_file = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1856 lexer lexbuf) : (Parsetree.toplevel_phrase list)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1991 lexer lexbuf) : (Parsetree.toplevel_phrase list)) and toplevel_phrase = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1836 lexer lexbuf) : (Parsetree.toplevel_phrase)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1971 lexer lexbuf) : (Parsetree.toplevel_phrase)) and parse_val_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1830 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1965 lexer lexbuf) : (Longident.t)) and parse_pattern = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1826 lexer lexbuf) : (Parsetree.pattern)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1961 lexer lexbuf) : (Parsetree.pattern)) and parse_mty_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1822 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1957 lexer lexbuf) : (Longident.t)) and parse_module_type = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1818 lexer lexbuf) : (Parsetree.module_type)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1953 lexer lexbuf) : (Parsetree.module_type)) and parse_module_expr = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1814 lexer lexbuf) : (Parsetree.module_expr)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1949 lexer lexbuf) : (Parsetree.module_expr)) and parse_mod_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1810 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1945 lexer lexbuf) : (Longident.t)) and parse_mod_ext_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1806 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1941 lexer lexbuf) : (Longident.t)) and parse_expression = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1802 lexer lexbuf) : (Parsetree.expression)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1937 lexer lexbuf) : (Parsetree.expression)) and parse_core_type = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1798 lexer lexbuf) : (Parsetree.core_type)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1933 lexer lexbuf) : (Parsetree.core_type)) and parse_constr_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1794 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1929 lexer lexbuf) : (Longident.t)) and parse_any_longident = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1776 lexer lexbuf) : (Longident.t)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1911 lexer lexbuf) : (Longident.t)) and interface = fun lexer lexbuf -> - (Obj.magic (MenhirInterpreter.entry `Legacy 1772 lexer lexbuf) : (Parsetree.signature)) + (Obj.magic (MenhirInterpreter.entry `Legacy 1907 lexer lexbuf) : (Parsetree.signature)) and implementation = fun lexer lexbuf -> @@ -46788,59 +54685,59 @@ module Incremental = struct let use_file = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1856 initial_position) : (Parsetree.toplevel_phrase list) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1991 initial_position) : (Parsetree.toplevel_phrase list) MenhirInterpreter.checkpoint) and toplevel_phrase = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1836 initial_position) : (Parsetree.toplevel_phrase) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1971 initial_position) : (Parsetree.toplevel_phrase) MenhirInterpreter.checkpoint) and parse_val_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1830 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1965 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_pattern = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1826 initial_position) : (Parsetree.pattern) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1961 initial_position) : (Parsetree.pattern) MenhirInterpreter.checkpoint) and parse_mty_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1822 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1957 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_module_type = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1818 initial_position) : (Parsetree.module_type) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1953 initial_position) : (Parsetree.module_type) MenhirInterpreter.checkpoint) and parse_module_expr = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1814 initial_position) : (Parsetree.module_expr) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1949 initial_position) : (Parsetree.module_expr) MenhirInterpreter.checkpoint) and parse_mod_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1810 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1945 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_mod_ext_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1806 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1941 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_expression = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1802 initial_position) : (Parsetree.expression) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1937 initial_position) : (Parsetree.expression) MenhirInterpreter.checkpoint) and parse_core_type = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1798 initial_position) : (Parsetree.core_type) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1933 initial_position) : (Parsetree.core_type) MenhirInterpreter.checkpoint) and parse_constr_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1794 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1929 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and parse_any_longident = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1776 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1911 initial_position) : (Longident.t) MenhirInterpreter.checkpoint) and interface = fun initial_position -> - (Obj.magic (MenhirInterpreter.start 1772 initial_position) : (Parsetree.signature) MenhirInterpreter.checkpoint) + (Obj.magic (MenhirInterpreter.start 1907 initial_position) : (Parsetree.signature) MenhirInterpreter.checkpoint) and implementation = fun initial_position -> @@ -46848,12 +54745,12 @@ module Incremental = struct end -# 4355 "src/ocaml/preprocess/parser_raw.mly" +# 4273 "src/ocaml/preprocess/parser_raw.mly" -# 46855 "src/ocaml/preprocess/parser_raw.ml" +# 54752 "src/ocaml/preprocess/parser_raw.ml" # 269 "" -# 46860 "src/ocaml/preprocess/parser_raw.ml" +# 54757 "src/ocaml/preprocess/parser_raw.ml" diff --git a/src/ocaml/preprocess/parser_raw.mli b/src/ocaml/preprocess/parser_raw.mli index 9818215e61..07068589e7 100644 --- a/src/ocaml/preprocess/parser_raw.mli +++ b/src/ocaml/preprocess/parser_raw.mli @@ -3,7 +3,6 @@ type token = | WITH - | WHILE_LWT | WHILE | WHEN | VIRTUAL @@ -11,7 +10,6 @@ type token = | UNDERSCORE | UIDENT of (string) | TYPE - | TRY_LWT | TRY | TRUE | TO @@ -50,11 +48,9 @@ type token = | MINUSDOT | MINUS | METHOD - | MATCH_LWT | MATCH | LPAREN | LIDENT of (string) - | LET_LWT | LETOP of (string) | LET | LESSMINUS @@ -92,10 +88,8 @@ type token = | FUNCTOR | FUNCTION | FUN - | FOR_LWT | FOR | FLOAT of (string * char option) - | FINALLY_LWT | FALSE | EXTERNAL | EXCEPTION @@ -183,7 +177,6 @@ module MenhirInterpreter : sig 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 @@ -191,7 +184,6 @@ module MenhirInterpreter : sig | 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 @@ -230,11 +222,9 @@ module MenhirInterpreter : sig | 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 @@ -272,10 +262,8 @@ module MenhirInterpreter : sig | 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 @@ -452,8 +440,6 @@ module MenhirInterpreter : sig 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 @@ -518,7 +504,6 @@ module MenhirInterpreter : sig | 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_delimited_type_supporting_local_open : (Parsetree.core_type) nonterminal | N_delimited_type : (Parsetree.core_type) nonterminal diff --git a/src/ocaml/preprocess/parser_raw.mly b/src/ocaml/preprocess/parser_raw.mly index aec0e10473..917ab96e82 100644 --- a/src/ocaml/preprocess/parser_raw.mly +++ b/src/ocaml/preprocess/parser_raw.mly @@ -722,33 +722,6 @@ let merloc startpos ?endpos x = 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 @@ -926,13 +899,6 @@ let expr_of_lwt_bindings ~loc lbs body = %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 ">."] @@ -963,10 +929,9 @@ 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 LET /* 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 ...) */ @@ -2531,7 +2496,7 @@ let_pattern [@recovery default_pattern ()]: %inline qualified_dotop: ioption(DOT mod_longident {$2}) DOTOP { $1, $2 }; -fun_expr: +%public fun_expr [@recovery default_expr ()]: simple_expr %prec below_HASH { $1 } | fun_expr_attrs @@ -2566,7 +2531,7 @@ fun_expr: /* END AVOID */ *) ; -%public expr [@recovery default_expr ()]: +%public %inline expr: | or_function(fun_expr) { $1 } ; %inline fun_expr_attrs: @@ -4305,51 +4270,4 @@ attr_payload: { 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 index 5183a550d5..cc51826cc9 100644 --- a/src/ocaml/preprocess/parser_recover.ml +++ b/src/ocaml/preprocess/parser_recover.ml @@ -19,7 +19,6 @@ module Default = struct 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 -> () @@ -27,7 +26,6 @@ module Default = struct | 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 -> () @@ -66,11 +64,9 @@ module Default = struct | 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 -> () @@ -108,10 +104,8 @@ module Default = struct | 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 -> () @@ -281,8 +275,6 @@ module Default = struct | 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 @@ -329,7 +321,7 @@ module Default = struct | MenhirInterpreter.N MenhirInterpreter.N_fun_seq_expr -> raise Not_found | MenhirInterpreter.N MenhirInterpreter.N_fun_params -> raise Not_found | MenhirInterpreter.N MenhirInterpreter.N_fun_param_as_list -> raise Not_found - | MenhirInterpreter.N MenhirInterpreter.N_fun_expr -> raise Not_found + | MenhirInterpreter.N MenhirInterpreter.N_fun_expr -> default_expr () | MenhirInterpreter.N MenhirInterpreter.N_fun_body -> raise Not_found | MenhirInterpreter.N MenhirInterpreter.N_formal_class_parameters -> raise Not_found | MenhirInterpreter.N MenhirInterpreter.N_floating_attribute -> raise Not_found @@ -338,7 +330,6 @@ module Default = struct | 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_delimited_type_supporting_local_open -> raise Not_found | MenhirInterpreter.N MenhirInterpreter.N_delimited_type -> raise Not_found @@ -389,18 +380,16 @@ type decision = | 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;1;2;2;1;2;2;1;1;2;1;1;1;1;1;1;2;3;4;1;1;5;6;6;1;1;2;1;2;3;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;1;4;5;1;1;1;1;1;2;1;2;3;1;1;1;2;2;3;4;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;1;1;1;2;3;4;1;2;3;1;2;3;1;1;2;3;3;1;1;4;1;2;1;1;1;2;3;1;2;3;1;1;1;1;2;1;2;3;1;4;1;1;2;1;1;2;3;1;1;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;2;1;1;2;3;1;4;1;1;1;1;1;2;3;2;3;2;1;2;3;2;1;2;3;4;3;3;3;1;1;3;4;2;3;1;2;1;3;4;2;3;5;1;2;1;2;3;2;3;4;5;3;4;3;4;4;5;6;2;1;2;2;1;1;2;3;1;1;2;1;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;1;2;3;2;3;2;3;3;4;5;2;3;2;3;2;4;4;5;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;2;3;1;2;1;2;3;4;1;5;2;1;2;3;1;2;4;5;4;5;6;2;3;4;5;1;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;4;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;2;3;1;2;3;1;2;3;1;2;3;1;1;2;1;2;3;1;1;1;2;4;1;2;5;6;1;2;3;4;2;3;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;2;3;4;1;1;1;2;3;1;2;1;2;3;4;4;5;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;1;2;1;2;3;1;2;1;2;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;2;3;2;3;4;5;1;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;1;2;1;2;3;4;1;2;3;4;5;1;2;6;1;2;7;2;3;4;5;1;2;1;2;3;4;6;7;1;2;3;4;5;6;1;2;8;4;5;6;1;2;1;2;1;2;3;4;5;1;2;3;4;5;1;2;3;2;3;6;7;1;2;8;9;1;1;2;3;1;1;2;3;1;4;1;1;1;1;2;3;1;2;3;4;5;6;7;1;2;3;1;2;1;1;2;3;2;1;5;1;1;2;3;6;7;8;1;2;3;4;5;6;4;2;3;4;2;5;6;7;1;1;1;2;3;4;5;6;7;1;1;2;3;1;1;2;3;4;1;1;2;8;9;10;1;1;1;2;3;4;5;6;4;4;1;2;3;3;4;5;3;3;1;7;8;9;6;7;1;8;9;10;2;1;1;4;5;6;7;8;9;6;7;8;5;6;7;8;9;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;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;6;7;8;5;1;1;2;3;1;4;1;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;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;1;2;1;2;2;1;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;2;3;4;5;6;1;1;1;1;1;1;2;2;1;2;1;2;1;2;1;1;1;1;2;3;1;1;1;1;3;4;3;4;3;4;4;3;3;4;5;3;4;5;3;4;5;6;7;1;2;3;5;6;7;5;6;7;3;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;2;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;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;7;3;4;5;2;3;3;2;4;4;5;6;7;8;4;4;5;4;2;3;2;2;3;2;2;3;4;2;2;3;2;3;8;3;4;5;6;7;2;3;4;5;6;7;8;2;3;4;5;6;7;8;9;2;2;2;4;5;2;2;3;4;5;6;7;8;3;4;5;6;7;2;3;4;2;5;6;3;2;2;3;2;2;3;4;5;6;6;7;8;2;3;3;4;4;5;6;4;5;6;4;5;5;6;7;5;6;7;7;8;9;5;6;2;3;4;5;2;3;4;2;3;4;3;4;5;6;1;7;1;2;3;2;2;3;3;4;5;2;3;4;5;4;2;3;2;2;3;2;3;4;2;2;2;2;6;7;8;1;2;3;4;5;9;10;2;2;1;1;1;1;1;2;3;4;4;5;5;6;7;8;9;3;4;5;5;6;6;7;3;4;7;8;2;3;3;4;5;4;5;6;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;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;|] + [|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;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;1;4;5;1;1;1;1;1;1;2;1;2;3;1;1;1;2;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;2;1;1;1;2;1;2;1;1;1;2;3;4;5;6;7;8;1;2;1;2;3;1;1;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;1;2;1;1;1;1;1;2;3;4;1;2;3;1;2;3;1;1;2;3;3;1;1;4;1;2;1;1;1;2;3;1;1;1;1;2;1;1;1;2;1;1;2;3;1;1;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;2;1;1;2;3;1;4;1;1;1;1;1;2;3;2;3;2;1;2;3;2;1;2;3;4;3;3;3;1;1;3;4;2;3;1;2;1;3;4;2;3;5;1;2;1;2;3;2;3;4;5;3;4;3;4;4;5;6;2;1;2;2;1;1;2;3;1;1;2;1;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;1;2;3;2;3;2;3;3;4;5;2;3;2;3;2;4;4;5;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;2;3;4;5;1;2;1;2;2;3;1;2;3;1;2;1;2;3;4;1;5;2;1;2;3;1;2;4;5;4;5;6;2;3;4;5;1;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;4;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;2;3;1;2;3;1;2;3;1;2;3;1;1;2;1;2;3;1;1;2;1;2;3;3;4;5;1;2;1;2;3;4;1;2;1;1;1;2;4;1;2;5;6;1;2;3;4;5;6;7;8;9;2;3;1;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;2;3;4;5;1;2;3;4;5;1;1;2;3;1;2;1;2;3;4;4;5;2;1;2;1;2;2;3;2;3;4;5;1;2;3;4;5;6;1;2;1;1;1;1;1;2;3;1;1;2;3;4;5;6;3;2;3;4;5;6;3;2;1;2;1;2;3;4;5;2;2;3;4;5;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;2;3;4;5;6;3;1;2;1;1;2;2;3;4;5;6;7;8;3;2;3;4;5;6;7;2;3;4;2;1;1;2;3;1;4;1;1;2;3;4;5;1;2;3;2;3;2;3;2;3;2;3;2;1;1;2;3;1;3;1;2;4;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;8;9;10;7;3;4;5;6;7;8;9;10;7;3;4;5;6;7;8;9;10;7;2;3;4;5;6;7;8;9;10;7;3;4;5;6;7;8;9;10;7;3;4;5;6;7;8;9;10;7;3;4;5;6;7;8;9;10;11;12;9;5;6;7;8;9;10;11;12;9;5;6;7;8;9;10;11;12;9;3;4;5;6;7;8;5;1;2;2;1;2;6;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;2;3;4;5;1;4;5;1;2;3;3;6;1;1;7;8;9;10;11;6;7;3;4;5;2;3;3;2;4;4;5;6;7;8;9;10;11;12;13;14;11;6;7;8;9;10;11;8;4;4;5;4;2;3;4;5;6;2;3;2;2;3;2;3;4;5;2;2;3;4;2;2;3;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;1;1;2;3;1;5;1;1;1;1;2;3;1;2;3;4;5;6;7;1;2;3;1;2;1;1;2;3;2;1;1;2;3;4;5;6;4;2;3;4;2;6;7;8;9;1;2;3;1;4;5;6;2;4;5;2;2;3;4;5;6;3;2;2;3;2;2;3;4;5;6;6;7;8;2;3;3;4;4;5;6;4;5;6;7;8;8;9;10;8;9;10;10;11;12;4;5;5;6;7;5;6;7;7;8;9;5;6;2;3;4;5;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;1;2;1;2;3;4;5;1;2;3;4;5;1;2;3;6;7;1;2;8;9;1;1;2;3;4;5;1;1;2;3;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;1;1;2;3;1;1;2;3;4;1;1;2;6;7;8;9;1;1;1;2;3;4;5;6;4;4;1;2;3;3;4;5;3;3;1;2;1;1;2;2;1;2;1;2;3;4;5;6;1;1;2;3;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;1;3;4;5;6;7;8;9;10;11;6;7;8;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;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;2;1;1;2;1;2;1;1;1;1;2;3;1;1;1;3;4;3;4;2;3;4;2;3;4;5;7;8;2;3;3;4;5;4;5;6;4;5;6;3;4;9;6;7;8;1;2;3;4;5;9;10;2;2;1;1;1;1;1;2;3;4;4;5;6;7;8;5;6;7;8;9;3;4;3;4;5;6;1;7;1;2;3;2;2;3;3;4;5;2;3;4;5;4;2;3;2;2;3;2;3;4;2;2;2;2;7;8;9;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;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;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 @@ -434,10 +423,8 @@ let can_pop (type a) : a terminal -> bool = function | 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 @@ -466,9 +453,7 @@ let can_pop (type a) : a terminal -> bool = function | 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 @@ -504,275 +489,275 @@ let can_pop (type a) : a terminal -> bool = function | _ -> false let recover = - let r0 = [R 664] in - let r1 = S (T T_UNDERSCORE) :: r0 in - let r2 = [R 147] in + let r0 = [R 232] in + let r1 = S (N N_fun_expr) :: r0 in + let r2 = [R 635] in let r3 = Sub (r1) :: r2 in - let r4 = [R 205] in - let r5 = Sub (r3) :: r4 in - let r6 = [R 599] in - let r7 = Sub (r5) :: r6 in - let r8 = [R 130] in - let r9 = S (T T_DONE) :: r8 in - let r10 = Sub (r7) :: r9 in - let r11 = S (T T_DO) :: r10 in - let r12 = Sub (r7) :: r11 in - let r13 = R 289 :: r12 in - let r14 = [R 696] in - let r15 = S (T T_AND) :: r14 in - let r16 = [R 32] in - let r17 = Sub (r15) :: r16 in - let r18 = [R 136] in - let r19 = [R 33] in - let r20 = [R 518] in - let r21 = S (N N_structure) :: r20 in - let r22 = [R 34] in - let r23 = Sub (r21) :: r22 in - let r24 = [R 35] in - let r25 = S (T T_RBRACKET) :: r24 in - let r26 = Sub (r23) :: r25 in - let r27 = [R 157] in - let r28 = S (T T_DONE) :: r27 in - let r29 = Sub (r7) :: r28 in - let r30 = S (T T_DO) :: r29 in - let r31 = Sub (r7) :: r30 in - let r32 = R 289 :: r31 in - let r33 = [R 353] in - let r34 = [R 126] in - let r35 = Sub (r7) :: r34 in - let r36 = R 289 :: r35 in - let r37 = [R 322] in - let r38 = Sub (r7) :: r37 in - let r39 = S (T T_MINUSGREATER) :: r38 in - let r40 = S (N N_pattern) :: r39 in - let r41 = [R 564] in - let r42 = Sub (r40) :: r41 in - let r43 = [R 154] in - let r44 = Sub (r42) :: r43 in - let r45 = S (T T_WITH) :: r44 in - let r46 = Sub (r7) :: r45 in - let r47 = R 289 :: r46 in - let r48 = [R 138] in - let r49 = [R 654] in - let r50 = [R 649] in - let r51 = S (T T_END) :: r50 in - let r52 = R 306 :: r51 in - let r53 = R 60 :: r52 in - let r54 = R 289 :: r53 in - let r55 = [R 58] in - let r56 = S (T T_RPAREN) :: r55 in - let r57 = [R 682] in - let r58 = [R 625] in - let r59 = [R 623] in - let r60 = [R 92] in - let r61 = [R 678] in - let r62 = S (T T_RPAREN) :: r61 in - let r63 = [R 451] in - let r64 = S (T T_AMPERAMPER) :: r63 in - let r65 = [R 809] in + let r4 = [R 150] in + let r5 = S (T T_DONE) :: r4 in + let r6 = Sub (r3) :: r5 in + let r7 = S (T T_DO) :: r6 in + let r8 = Sub (r3) :: r7 in + let r9 = R 316 :: r8 in + let r10 = [R 733] in + let r11 = S (T T_AND) :: r10 in + let r12 = [R 32] in + let r13 = Sub (r11) :: r12 in + let r14 = [R 125] in + let r15 = [R 33] in + let r16 = [R 547] in + let r17 = S (N N_structure) :: r16 in + let r18 = [R 34] in + let r19 = Sub (r17) :: r18 in + let r20 = [R 35] in + let r21 = S (T T_RBRACKET) :: r20 in + let r22 = Sub (r19) :: r21 in + let r23 = [R 846] in + let r24 = S (T T_LIDENT) :: r23 in + let r25 = [R 31] in + let r26 = S (T T_UNDERSCORE) :: r25 in + let r27 = [R 819] in + let r28 = Sub (r26) :: r27 in + let r29 = [R 236] in + let r30 = Sub (r28) :: r29 in + let r31 = [R 17] in + let r32 = Sub (r30) :: r31 in + let r33 = [R 108] in + let r34 = Sub (r32) :: r33 in + let r35 = [R 552] in + let r36 = Sub (r34) :: r35 in + let r37 = [R 854] in + let r38 = R 322 :: r37 in + let r39 = Sub (r36) :: r38 in + let r40 = S (T T_COLON) :: r39 in + let r41 = Sub (r24) :: r40 in + let r42 = R 316 :: r41 in + let r43 = [R 475] in + let r44 = S (T T_AMPERAMPER) :: r43 in + let r45 = [R 845] in + let r46 = S (T T_RPAREN) :: r45 in + let r47 = Sub (r44) :: r46 in + let r48 = [R 449] in + let r49 = S (T T_RPAREN) :: r48 in + let r50 = R 258 :: r49 in + let r51 = [R 259] in + let r52 = [R 451] in + let r53 = S (T T_RBRACKET) :: r52 in + let r54 = [R 453] in + let r55 = S (T T_RBRACE) :: r54 in + let r56 = [R 365] in + let r57 = [R 127] in + let r58 = [R 256] in + let r59 = S (T T_LIDENT) :: r58 in + let r60 = [R 591] in + let r61 = [R 30] in + let r62 = Sub (r59) :: r61 in + let r63 = [R 501] in + let r64 = S (T T_COLON) :: r63 in + let r65 = [R 114] in let r66 = S (T T_RPAREN) :: r65 in - let r67 = Sub (r64) :: r66 in - let r68 = [R 375] in - let r69 = S (T T_UNDERSCORE) :: r68 in - let r70 = [R 680] in - let r71 = S (T T_RPAREN) :: r70 in - let r72 = Sub (r69) :: r71 in - let r73 = R 289 :: r72 in - let r74 = [R 681] in - let r75 = S (T T_RPAREN) :: r74 in - let r76 = [R 341] in - let r77 = [R 602] in - let r78 = R 297 :: r77 in - let r79 = [R 377] in - let r80 = S (T T_END) :: r79 in - let r81 = Sub (r78) :: r80 in - let r82 = [R 810] in - let r83 = S (T T_LIDENT) :: r82 in - let r84 = [R 31] in - let r85 = S (T T_UNDERSCORE) :: r84 in - let r86 = [R 783] in - let r87 = Sub (r85) :: r86 in - let r88 = [R 209] in - let r89 = Sub (r87) :: r88 in - let r90 = [R 17] in - let r91 = Sub (r89) :: r90 in - let r92 = [R 108] in - let r93 = Sub (r91) :: r92 in - let r94 = [R 523] in - let r95 = Sub (r93) :: r94 in - let r96 = [R 818] in - let r97 = R 295 :: r96 in - let r98 = Sub (r95) :: r97 in - let r99 = S (T T_COLON) :: r98 in - let r100 = Sub (r83) :: r99 in - let r101 = R 289 :: r100 in - let r102 = [R 425] in - let r103 = S (T T_RPAREN) :: r102 in - let r104 = R 231 :: r103 in - let r105 = [R 232] in - let r106 = [R 427] in - let r107 = S (T T_RBRACKET) :: r106 in - let r108 = [R 429] in - let r109 = S (T T_RBRACE) :: r108 in - let r110 = [R 229] in - let r111 = S (T T_LIDENT) :: r110 in - let r112 = [R 30] in - let r113 = Sub (r111) :: r112 in - let r114 = [R 562] in - let r115 = [R 476] in - let r116 = S (T T_COLON) :: r115 in - let r117 = [R 114] in - let r118 = S (T T_RPAREN) :: r117 in - let r119 = S (N N_module_type) :: r118 in - let r120 = R 289 :: r119 in - let r121 = R 135 :: r120 in - let r122 = [R 379] in - let r123 = S (N N_module_expr) :: r122 in - let r124 = R 289 :: r123 in - let r125 = S (T T_OF) :: r124 in - let r126 = [R 365] in - let r127 = S (T T_END) :: r126 in - let r128 = S (N N_structure) :: r127 in - let r129 = [R 339] in - let r130 = S (T T_LIDENT) :: r129 in - let r131 = [R 790] in - let r132 = Sub (r130) :: r131 in - let r133 = [R 93] in - let r134 = S (T T_FALSE) :: r133 in - let r135 = [R 97] in - let r136 = Sub (r134) :: r135 in - let r137 = [R 223] in - let r138 = R 289 :: r137 in - let r139 = R 216 :: r138 in - let r140 = Sub (r136) :: r139 in - let r141 = [R 543] in - let r142 = Sub (r140) :: r141 in - let r143 = [R 758] in - let r144 = R 295 :: r143 in - let r145 = Sub (r142) :: r144 in - let r146 = R 529 :: r145 in - let r147 = S (T T_PLUSEQ) :: r146 in - let r148 = Sub (r132) :: r147 in - let r149 = R 792 :: r148 in - let r150 = R 289 :: r149 in - let r151 = [R 226] in - let r152 = R 295 :: r151 in - let r153 = R 552 :: r152 in - let r154 = R 788 :: r153 in - let r155 = S (T T_LIDENT) :: r154 in - let r156 = R 792 :: r155 in - let r157 = R 289 :: r156 in - let r158 = R 135 :: r157 in - let r159 = [R 759] in - let r160 = R 295 :: r159 in - let r161 = Sub (r142) :: r160 in - let r162 = R 529 :: r161 in - let r163 = S (T T_PLUSEQ) :: r162 in - let r164 = Sub (r132) :: r163 in - let r165 = [R 227] in - let r166 = R 295 :: r165 in - let r167 = R 552 :: r166 in - let r168 = R 788 :: r167 in - let r169 = S (T T_LIDENT) :: r168 in - let r170 = R 792 :: r169 in - let r171 = [R 796] in - let r172 = S (T T_UNDERSCORE) :: r171 in - let r173 = [R 791] in + let r67 = S (N N_module_type) :: r66 in + let r68 = R 316 :: r67 in + let r69 = R 124 :: r68 in + let r70 = [R 638] in + let r71 = R 324 :: r70 in + let r72 = [R 401] in + let r73 = S (T T_END) :: r72 in + let r74 = Sub (r71) :: r73 in + let r75 = [R 253] in + let r76 = R 322 :: r75 in + let r77 = R 581 :: r76 in + let r78 = R 824 :: r77 in + let r79 = S (T T_LIDENT) :: r78 in + let r80 = R 828 :: r79 in + let r81 = R 316 :: r80 in + let r82 = R 124 :: r81 in + let r83 = [R 363] in + let r84 = S (T T_LIDENT) :: r83 in + let r85 = [R 826] in + let r86 = Sub (r84) :: r85 in + let r87 = [R 93] in + let r88 = S (T T_FALSE) :: r87 in + let r89 = [R 97] in + let r90 = Sub (r88) :: r89 in + let r91 = [R 250] in + let r92 = R 316 :: r91 in + let r93 = R 243 :: r92 in + let r94 = Sub (r90) :: r93 in + let r95 = [R 578] in + let r96 = Sub (r94) :: r95 in + let r97 = [R 645] in + let r98 = R 322 :: r97 in + let r99 = Sub (r96) :: r98 in + let r100 = R 558 :: r99 in + let r101 = S (T T_PLUSEQ) :: r100 in + let r102 = Sub (r86) :: r101 in + let r103 = R 828 :: r102 in + let r104 = R 316 :: r103 in + let r105 = [R 254] in + let r106 = R 322 :: r105 in + let r107 = R 581 :: r106 in + let r108 = R 824 :: r107 in + let r109 = S (T T_LIDENT) :: r108 in + let r110 = R 828 :: r109 in + let r111 = [R 646] in + let r112 = R 322 :: r111 in + let r113 = Sub (r96) :: r112 in + let r114 = R 558 :: r113 in + let r115 = S (T T_PLUSEQ) :: r114 in + let r116 = Sub (r86) :: r115 in + let r117 = [R 832] in + let r118 = S (T T_UNDERSCORE) :: r117 in + let r119 = [R 827] in + let r120 = Sub (r118) :: r119 in + let r121 = R 833 :: r120 in + let r122 = [R 604] in + let r123 = Sub (r121) :: r122 in + let r124 = [R 830] in + let r125 = S (T T_RPAREN) :: r124 in + let r126 = [R 831] in + let r127 = [R 605] in + let r128 = [R 432] in + let r129 = S (T T_DOTDOT) :: r128 in + let r130 = [R 825] in + let r131 = [R 433] in + let r132 = [R 96] in + let r133 = S (T T_RPAREN) :: r132 in + let r134 = [R 92] in + let r135 = [R 238] in + let r136 = Sub (r30) :: r135 in + let r137 = S (T T_MINUSGREATER) :: r136 in + let r138 = Sub (r28) :: r137 in + let r139 = [R 441] in + let r140 = [R 554] in + let r141 = Sub (r32) :: r140 in + let r142 = [R 353] in + let r143 = R 316 :: r142 in + let r144 = Sub (r141) :: r143 in + let r145 = [R 126] in + let r146 = S (T T_RBRACKET) :: r145 in + let r147 = Sub (r17) :: r146 in + let r148 = [R 701] in + let r149 = [R 377] in + let r150 = [R 572] in + let r151 = Sub (r94) :: r150 in + let r152 = [R 794] in + let r153 = R 322 :: r152 in + let r154 = Sub (r151) :: r153 in + let r155 = R 558 :: r154 in + let r156 = S (T T_PLUSEQ) :: r155 in + let r157 = Sub (r86) :: r156 in + let r158 = R 828 :: r157 in + let r159 = R 316 :: r158 in + let r160 = [R 795] in + let r161 = R 322 :: r160 in + let r162 = Sub (r151) :: r161 in + let r163 = R 558 :: r162 in + let r164 = S (T T_PLUSEQ) :: r163 in + let r165 = Sub (r86) :: r164 in + let r166 = [R 556] in + let r167 = S (T T_RBRACKET) :: r166 in + let r168 = Sub (r19) :: r167 in + let r169 = [R 346] in + let r170 = Sub (r3) :: r169 in + let r171 = S (T T_MINUSGREATER) :: r170 in + let r172 = S (N N_pattern) :: r171 in + let r173 = [R 593] in let r174 = Sub (r172) :: r173 in - let r175 = R 797 :: r174 in - let r176 = [R 575] in - let r177 = Sub (r175) :: r176 in - let r178 = [R 794] in - let r179 = S (T T_RPAREN) :: r178 in - let r180 = [R 795] in - let r181 = [R 576] in - let r182 = [R 408] in - let r183 = S (T T_DOTDOT) :: r182 in - let r184 = [R 789] in - let r185 = [R 409] in - let r186 = [R 96] in - let r187 = S (T T_RPAREN) :: r186 in - let r188 = [R 211] in - let r189 = Sub (r89) :: r188 in - let r190 = S (T T_MINUSGREATER) :: r189 in - let r191 = Sub (r87) :: r190 in - let r192 = [R 417] in - let r193 = [R 525] in - let r194 = Sub (r91) :: r193 in - let r195 = [R 329] in - let r196 = R 289 :: r195 in - let r197 = Sub (r194) :: r196 in - let r198 = [R 137] in - let r199 = S (T T_RBRACKET) :: r198 in - let r200 = Sub (r21) :: r199 in - let r201 = [R 301] in - let r202 = [R 418] in - let r203 = R 295 :: r202 in - let r204 = S (N N_module_expr) :: r203 in - let r205 = R 289 :: r204 in - let r206 = [R 419] in - let r207 = R 295 :: r206 in - let r208 = S (N N_module_expr) :: r207 in - let r209 = R 289 :: r208 in - let r210 = [R 478] in - let r211 = S (T T_RPAREN) :: r210 in - let r212 = [R 479] in - let r213 = S (T T_RPAREN) :: r212 in - let r214 = S (N N_expr) :: r213 in - let r215 = [R 351] in - let r216 = S (T T_LIDENT) :: r215 in - let r217 = [R 57] in - let r218 = Sub (r216) :: r217 in - let r219 = [R 646] in - let r220 = Sub (r218) :: r219 in - let r221 = R 289 :: r220 in - let r222 = [R 352] in - let r223 = S (T T_LIDENT) :: r222 in - let r224 = [R 354] in - let r225 = [R 359] in - let r226 = [R 290] in - let r227 = [R 125] in - let r228 = Sub (r42) :: r227 in - let r229 = S (T T_WITH) :: r228 in - let r230 = Sub (r7) :: r229 in - let r231 = R 289 :: r230 in - let r232 = [R 153] in - let r233 = Sub (r42) :: r232 in - let r234 = S (T T_WITH) :: r233 in - let r235 = Sub (r7) :: r234 in - let r236 = R 289 :: r235 in - let r237 = [R 647] in - let r238 = S (T T_RPAREN) :: r237 in - let r239 = S (N N_module_expr) :: r238 in - let r240 = R 289 :: r239 in - let r241 = R 135 :: r240 in - let r242 = [R 669] in - let r243 = [R 190] in - let r244 = [R 259] in - let r245 = Sub (r83) :: r244 in - let r246 = [R 319] in - let r247 = R 295 :: r246 in - let r248 = Sub (r245) :: r247 in - let r249 = R 536 :: r248 in - let r250 = R 289 :: r249 in - let r251 = [R 630] in + let r175 = [R 143] in + let r176 = Sub (r174) :: r175 in + let r177 = S (T T_WITH) :: r176 in + let r178 = Sub (r3) :: r177 in + let r179 = R 316 :: r178 in + let r180 = S (T T_UNDERSCORE) :: r148 in + let r181 = [R 691] in + let r182 = [R 686] in + let r183 = S (T T_END) :: r182 in + let r184 = R 333 :: r183 in + let r185 = R 60 :: r184 in + let r186 = R 316 :: r185 in + let r187 = [R 58] in + let r188 = S (T T_RPAREN) :: r187 in + let r189 = [R 719] in + let r190 = [R 661] in + let r191 = [R 659] in + let r192 = [R 715] in + let r193 = S (T T_RPAREN) :: r192 in + let r194 = [R 399] in + let r195 = S (T T_UNDERSCORE) :: r194 in + let r196 = [R 717] in + let r197 = S (T T_RPAREN) :: r196 in + let r198 = Sub (r195) :: r197 in + let r199 = R 316 :: r198 in + let r200 = [R 718] in + let r201 = S (T T_RPAREN) :: r200 in + let r202 = [R 403] in + let r203 = S (N N_module_expr) :: r202 in + let r204 = R 316 :: r203 in + let r205 = S (T T_OF) :: r204 in + let r206 = [R 389] in + let r207 = S (T T_END) :: r206 in + let r208 = S (N N_structure) :: r207 in + let r209 = [R 328] in + let r210 = [R 442] in + let r211 = R 322 :: r210 in + let r212 = S (N N_module_expr) :: r211 in + let r213 = R 316 :: r212 in + let r214 = [R 443] in + let r215 = R 322 :: r214 in + let r216 = S (N N_module_expr) :: r215 in + let r217 = R 316 :: r216 in + let r218 = [R 503] in + let r219 = S (T T_RPAREN) :: r218 in + let r220 = [R 504] in + let r221 = S (T T_RPAREN) :: r220 in + let r222 = S (N N_fun_expr) :: r221 in + let r223 = [R 375] in + let r224 = S (T T_LIDENT) :: r223 in + let r225 = [R 57] in + let r226 = Sub (r224) :: r225 in + let r227 = [R 683] in + let r228 = Sub (r226) :: r227 in + let r229 = R 316 :: r228 in + let r230 = [R 376] in + let r231 = S (T T_LIDENT) :: r230 in + let r232 = [R 378] in + let r233 = [R 383] in + let r234 = [R 317] in + let r235 = [R 142] in + let r236 = Sub (r174) :: r235 in + let r237 = S (T T_WITH) :: r236 in + let r238 = Sub (r3) :: r237 in + let r239 = R 316 :: r238 in + let r240 = [R 670] in + let r241 = S (T T_RPAREN) :: r240 in + let r242 = [R 706] in + let r243 = [R 206] in + let r244 = [R 301] in + let r245 = Sub (r24) :: r244 in + let r246 = [R 304] in + let r247 = Sub (r245) :: r246 in + let r248 = [R 203] in + let r249 = Sub (r3) :: r248 in + let r250 = S (T T_IN) :: r249 in + let r251 = [R 666] in let r252 = [R 91] in - let r253 = [R 593] in + let r253 = [R 629] in let r254 = S (N N_pattern) :: r253 in - let r255 = [R 628] in + let r255 = [R 664] in let r256 = S (T T_RBRACKET) :: r255 in - let r257 = [R 243] in - let r258 = Sub (r216) :: r257 in - let r259 = [R 315] in - let r260 = R 469 :: r259 in - let r261 = R 463 :: r260 in + let r257 = [R 270] in + let r258 = Sub (r224) :: r257 in + let r259 = [R 342] in + let r260 = R 494 :: r259 in + let r261 = R 487 :: r260 in let r262 = Sub (r258) :: r261 in - let r263 = [R 627] in + let r263 = [R 663] in let r264 = S (T T_RBRACE) :: r263 in - let r265 = [R 464] in - let r266 = [R 586] in - let r267 = Sub (r93) :: r266 in - let r268 = [R 571] in + let r265 = [R 488] in + let r266 = [R 619] in + let r267 = Sub (r34) :: r266 in + let r268 = [R 600] in let r269 = Sub (r267) :: r268 in let r270 = [R 120] in let r271 = S (T T_RBRACKET) :: r270 in @@ -781,2816 +766,3049 @@ let recover = let r274 = S (T T_RBRACKET) :: r273 in let r275 = [R 118] in let r276 = S (T T_RBRACKET) :: r275 in - let r277 = [R 397] in - let r278 = Sub (r111) :: r277 in + let r277 = [R 421] in + let r278 = Sub (r59) :: r277 in let r279 = S (T T_BACKQUOTE) :: r278 in - let r280 = [R 771] in - let r281 = R 289 :: r280 in + let r280 = [R 807] in + let r281 = R 316 :: r280 in let r282 = Sub (r279) :: r281 in let r283 = [R 115] in let r284 = S (T T_RBRACKET) :: r283 in let r285 = [R 86] in - let r286 = Sub (r130) :: r285 in + let r286 = Sub (r84) :: r285 in let r287 = [R 26] in - let r288 = [R 340] in + let r288 = [R 364] in let r289 = S (T T_LIDENT) :: r288 in let r290 = S (T T_DOT) :: r289 in - let r291 = S (T T_UIDENT) :: r76 in - let r292 = [R 357] in + let r291 = S (T T_UIDENT) :: r56 in + let r292 = [R 381] in let r293 = Sub (r291) :: r292 in - let r294 = [R 358] in + let r294 = [R 382] in let r295 = S (T T_RPAREN) :: r294 in - let r296 = [R 342] in + let r296 = [R 366] in let r297 = S (T T_UIDENT) :: r296 in let r298 = [R 116] in let r299 = S (T T_RBRACKET) :: r298 in - let r300 = [R 212] in - let r301 = [R 583] in + let r300 = [R 239] in + let r301 = [R 616] in let r302 = S (T T_DOT) :: r297 in let r303 = S (T T_LBRACKETGREATER) :: r274 in let r304 = [R 29] in let r305 = Sub (r303) :: r304 in - let r306 = [R 210] in - let r307 = Sub (r89) :: r306 in + let r306 = [R 237] in + let r307 = Sub (r30) :: r306 in let r308 = S (T T_MINUSGREATER) :: r307 in - let r309 = [R 584] in + let r309 = [R 617] in let r310 = [R 27] in let r311 = [R 113] in let r312 = [R 18] in - let r313 = Sub (r111) :: r312 in - let r314 = [R 572] in - let r315 = [R 567] in - let r316 = Sub (r91) :: r315 in - let r317 = [R 770] in - let r318 = R 289 :: r317 in + let r313 = Sub (r59) :: r312 in + let r314 = [R 601] in + let r315 = [R 596] in + let r316 = Sub (r32) :: r315 in + let r317 = [R 806] in + let r318 = R 316 :: r317 in let r319 = Sub (r316) :: r318 in - let r320 = [R 568] in + let r320 = [R 597] in let r321 = [R 117] in let r322 = S (T T_RBRACKET) :: r321 in let r323 = Sub (r269) :: r322 in - let r324 = [R 560] in + let r324 = [R 589] in let r325 = Sub (r279) :: r324 in let r326 = [R 121] in let r327 = S (T T_RBRACKET) :: r326 in - let r328 = [R 470] in - let r329 = S (T T_UNDERSCORE) :: r57 in - let r330 = [R 677] in + let r328 = [R 495] in + let r329 = S (T T_UNDERSCORE) :: r189 in + let r330 = [R 714] in let r331 = Sub (r329) :: r330 in - let r332 = [R 509] in + let r332 = [R 538] in let r333 = Sub (r331) :: r332 in - let r334 = R 289 :: r333 in + let r334 = R 316 :: r333 in let r335 = [R 87] in - let r336 = [R 687] in + let r336 = [R 724] in let r337 = S (T T_INT) :: r335 in - let r338 = [R 622] in + let r338 = [R 658] in let r339 = Sub (r337) :: r338 in - let r340 = [R 684] in - let r341 = [R 689] in + let r340 = [R 721] in + let r341 = [R 726] in let r342 = S (T T_RBRACKET) :: r341 in let r343 = S (T T_LBRACKET) :: r342 in - let r344 = [R 690] in - let r345 = [R 500] in + let r344 = [R 727] in + let r345 = [R 529] in let r346 = S (N N_pattern) :: r345 in - let r347 = R 289 :: r346 in - let r348 = [R 501] in - let r349 = [R 494] in - let r350 = [R 508] in - let r351 = [R 506] in - let r352 = [R 398] in + let r347 = R 316 :: r346 in + let r348 = [R 530] in + let r349 = [R 523] in + let r350 = [R 537] in + let r351 = [R 535] in + let r352 = [R 422] in let r353 = S (T T_LIDENT) :: r352 in - let r354 = [R 507] in + let r354 = [R 536] in let r355 = Sub (r331) :: r354 in let r356 = S (T T_RPAREN) :: r355 in let r357 = [R 101] in let r358 = [R 100] in let r359 = S (T T_RPAREN) :: r358 in - let r360 = [R 502] in - let r361 = [R 692] in + let r360 = [R 531] in + let r361 = [R 729] in let r362 = S (T T_RPAREN) :: r361 in - let r363 = [R 499] in - let r364 = [R 497] in + let r363 = [R 528] in + let r364 = [R 526] in let r365 = [R 99] in let r366 = S (T T_RPAREN) :: r365 in - let r367 = [R 691] in - let r368 = [R 317] in - let r369 = [R 629] in - let r370 = [R 255] in - let r371 = [R 241] in + let r367 = [R 728] in + let r368 = [R 344] in + let r369 = [R 665] in + let r370 = [R 282] in + let r371 = [R 268] in let r372 = S (T T_LIDENT) :: r371 in - let r373 = [R 254] in + let r373 = [R 281] in let r374 = S (T T_RPAREN) :: r373 in - let r375 = [R 242] in - let r376 = [R 251] in - let r377 = [R 250] in + let r375 = [R 269] in + let r376 = [R 278] in + let r377 = [R 277] in let r378 = S (T T_RPAREN) :: r377 in - let r379 = R 471 :: r378 in - let r380 = [R 472] in - let r381 = [R 274] in - let r382 = Sub (r83) :: r381 in - let r383 = [R 277] in - let r384 = Sub (r382) :: r383 in - let r385 = [R 188] in - let r386 = Sub (r7) :: r385 in - let r387 = S (T T_IN) :: r386 in - let r388 = [R 517] in - let r389 = S (T T_UNDERSCORE) :: r388 in - let r390 = [R 253] in - let r391 = [R 252] in - let r392 = S (T T_RPAREN) :: r391 in - let r393 = R 471 :: r392 in - let r394 = [R 272] in - let r395 = [R 202] in - let r396 = S (T T_RPAREN) :: r395 in - let r397 = [R 256] in - let r398 = [R 747] in - let r399 = Sub (r7) :: r398 in - let r400 = [R 266] in - let r401 = R 295 :: r400 in - let r402 = Sub (r245) :: r401 in - let r403 = R 536 :: r402 in - let r404 = R 289 :: r403 in - let r405 = R 135 :: r404 in - let r406 = [R 150] in - let r407 = Sub (r7) :: r406 in - let r408 = S (T T_IN) :: r407 in - let r409 = S (N N_module_expr) :: r408 in - let r410 = R 289 :: r409 in - let r411 = R 135 :: r410 in - let r412 = [R 151] in - let r413 = Sub (r7) :: r412 in - let r414 = S (T T_IN) :: r413 in - let r415 = S (N N_module_expr) :: r414 in - let r416 = R 289 :: r415 in - let r417 = [R 366] in - let r418 = S (N N_module_expr) :: r417 in - let r419 = S (T T_MINUSGREATER) :: r418 in - let r420 = S (N N_functor_args) :: r419 in - let r421 = [R 213] in - let r422 = [R 214] in - let r423 = S (T T_RPAREN) :: r422 in - let r424 = S (N N_module_type) :: r423 in - let r425 = [R 380] in - let r426 = S (T T_RPAREN) :: r425 in - let r427 = [R 383] in - let r428 = S (N N_module_type) :: r427 in - let r429 = [R 378] in - let r430 = S (N N_module_type) :: r429 in - let r431 = S (T T_MINUSGREATER) :: r430 in - let r432 = S (N N_functor_args) :: r431 in - let r433 = [R 349] in - let r434 = Sub (r111) :: r433 in - let r435 = [R 389] in - let r436 = Sub (r434) :: r435 in - let r437 = [R 831] in - let r438 = S (N N_module_type) :: r437 in - let r439 = S (T T_EQUAL) :: r438 in - let r440 = Sub (r436) :: r439 in - let r441 = S (T T_TYPE) :: r440 in - let r442 = S (T T_MODULE) :: r441 in - let r443 = [R 569] in - let r444 = Sub (r442) :: r443 in - let r445 = [R 385] in - let r446 = [R 828] in - let r447 = Sub (r91) :: r446 in - let r448 = S (T T_COLONEQUAL) :: r447 in - let r449 = Sub (r258) :: r448 in - let r450 = [R 827] in - let r451 = R 552 :: r450 in - let r452 = [R 553] in - let r453 = Sub (r93) :: r452 in - let r454 = S (T T_EQUAL) :: r453 in - let r455 = [R 350] in - let r456 = Sub (r111) :: r455 in - let r457 = [R 832] in - let r458 = [R 384] in - let r459 = [R 829] in - let r460 = Sub (r293) :: r459 in - let r461 = S (T T_UIDENT) :: r224 in - let r462 = [R 830] in - let r463 = [R 570] in - let r464 = [R 371] in - let r465 = [R 477] in - let r466 = S (T T_RPAREN) :: r465 in - let r467 = [R 587] in - let r468 = S (N N_expr) :: r467 in - let r469 = [R 672] in - let r470 = S (T T_RBRACKET) :: r469 in - let r471 = [R 657] in - let r472 = [R 590] in - let r473 = R 465 :: r472 in - let r474 = [R 466] in - let r475 = [R 596] in - let r476 = R 465 :: r475 in - let r477 = R 473 :: r476 in - let r478 = Sub (r258) :: r477 in - let r479 = [R 538] in - let r480 = Sub (r478) :: r479 in - let r481 = [R 666] in - let r482 = S (T T_RBRACE) :: r481 in - let r483 = [R 632] in - let r484 = [R 631] in - let r485 = S (T T_GREATERDOT) :: r484 in - let r486 = [R 160] in - let r487 = Sub (r1) :: r486 in - let r488 = R 289 :: r487 in - let r489 = [R 645] in - let r490 = S (T T_END) :: r489 in - let r491 = R 289 :: r490 in - let r492 = [R 156] in - let r493 = S (N N_expr) :: r492 in - let r494 = S (T T_THEN) :: r493 in - let r495 = Sub (r7) :: r494 in - let r496 = R 289 :: r495 in - let r497 = [R 600] in - let r498 = Sub (r42) :: r497 in - let r499 = R 289 :: r498 in - let r500 = [R 565] in - let r501 = [R 323] in - let r502 = Sub (r7) :: r501 in - let r503 = S (T T_MINUSGREATER) :: r502 in - let r504 = [R 257] in - let r505 = Sub (r331) :: r504 in - let r506 = [R 203] in - let r507 = Sub (r505) :: r506 in - let r508 = [R 554] in - let r509 = Sub (r507) :: r508 in - let r510 = [R 204] in - let r511 = Sub (r509) :: r510 in - let r512 = [R 146] in - let r513 = Sub (r5) :: r512 in - let r514 = [R 152] in - let r515 = Sub (r513) :: r514 in - let r516 = S (T T_MINUSGREATER) :: r515 in - let r517 = R 461 :: r516 in - let r518 = Sub (r511) :: r517 in - let r519 = R 289 :: r518 in - let r520 = [R 462] in - let r521 = [R 145] in - let r522 = Sub (r42) :: r521 in - let r523 = R 289 :: r522 in - let r524 = [R 566] in - let r525 = [R 132] in - let r526 = S (T T_DONE) :: r525 in - let r527 = Sub (r7) :: r526 in - let r528 = S (T T_DO) :: r527 in - let r529 = Sub (r7) :: r528 in - let r530 = S (T T_IN) :: r529 in - let r531 = S (N N_pattern) :: r530 in - let r532 = R 289 :: r531 in - let r533 = [R 123] in - let r534 = S (T T_DOWNTO) :: r533 in - let r535 = [R 158] in - let r536 = S (T T_DONE) :: r535 in - let r537 = Sub (r7) :: r536 in - let r538 = S (T T_DO) :: r537 in - let r539 = Sub (r7) :: r538 in - let r540 = Sub (r534) :: r539 in - let r541 = Sub (r7) :: r540 in - let r542 = S (T T_EQUAL) :: r541 in - let r543 = S (N N_pattern) :: r542 in - let r544 = R 289 :: r543 in - let r545 = [R 655] in - let r546 = [R 665] in - let r547 = S (T T_RPAREN) :: r546 in - let r548 = S (T T_LPAREN) :: r547 in - let r549 = S (T T_DOT) :: r548 in - let r550 = [R 675] in - let r551 = S (T T_RPAREN) :: r550 in - let r552 = S (N N_module_type) :: r551 in - let r553 = S (T T_COLON) :: r552 in - let r554 = S (N N_module_expr) :: r553 in - let r555 = R 289 :: r554 in - let r556 = [R 275] in - let r557 = Sub (r7) :: r556 in - let r558 = S (T T_EQUAL) :: r557 in - let r559 = [R 159] in - let r560 = Sub (r1) :: r559 in - let r561 = R 289 :: r560 in - let r562 = [R 662] in - let r563 = [R 638] in - let r564 = S (T T_RPAREN) :: r563 in - let r565 = Sub (r468) :: r564 in - let r566 = S (T T_LPAREN) :: r565 in - let r567 = [R 134] in - let r568 = Sub (r42) :: r567 in - let r569 = R 289 :: r568 in - let r570 = [R 185] in - let r571 = [R 246] in - let r572 = [R 785] in - let r573 = Sub (r93) :: r572 in - let r574 = S (T T_COLON) :: r573 in - let r575 = [R 247] in + let r379 = R 496 :: r378 in + let r380 = [R 497] in + let r381 = [R 139] in + let r382 = Sub (r3) :: r381 in + let r383 = S (T T_IN) :: r382 in + let r384 = S (N N_module_expr) :: r383 in + let r385 = R 316 :: r384 in + let r386 = R 124 :: r385 in + let r387 = [R 286] in + let r388 = Sub (r24) :: r387 in + let r389 = [R 293] in + let r390 = R 322 :: r389 in + let r391 = Sub (r388) :: r390 in + let r392 = R 565 :: r391 in + let r393 = R 316 :: r392 in + let r394 = R 124 :: r393 in + let r395 = [R 140] in + let r396 = Sub (r3) :: r395 in + let r397 = S (T T_IN) :: r396 in + let r398 = S (N N_module_expr) :: r397 in + let r399 = R 316 :: r398 in + let r400 = [R 390] in + let r401 = S (N N_module_expr) :: r400 in + let r402 = S (T T_MINUSGREATER) :: r401 in + let r403 = S (N N_functor_args) :: r402 in + let r404 = [R 240] in + let r405 = [R 241] in + let r406 = S (T T_RPAREN) :: r405 in + let r407 = S (N N_module_type) :: r406 in + let r408 = [R 404] in + let r409 = S (T T_RPAREN) :: r408 in + let r410 = [R 407] in + let r411 = S (N N_module_type) :: r410 in + let r412 = [R 402] in + let r413 = S (N N_module_type) :: r412 in + let r414 = S (T T_MINUSGREATER) :: r413 in + let r415 = S (N N_functor_args) :: r414 in + let r416 = [R 373] in + let r417 = Sub (r59) :: r416 in + let r418 = [R 413] in + let r419 = Sub (r417) :: r418 in + let r420 = [R 867] in + let r421 = S (N N_module_type) :: r420 in + let r422 = S (T T_EQUAL) :: r421 in + let r423 = Sub (r419) :: r422 in + let r424 = S (T T_TYPE) :: r423 in + let r425 = S (T T_MODULE) :: r424 in + let r426 = [R 598] in + let r427 = Sub (r425) :: r426 in + let r428 = [R 409] in + let r429 = [R 864] in + let r430 = Sub (r32) :: r429 in + let r431 = S (T T_COLONEQUAL) :: r430 in + let r432 = Sub (r258) :: r431 in + let r433 = [R 863] in + let r434 = R 581 :: r433 in + let r435 = [R 582] in + let r436 = Sub (r34) :: r435 in + let r437 = S (T T_EQUAL) :: r436 in + let r438 = [R 374] in + let r439 = Sub (r59) :: r438 in + let r440 = [R 868] in + let r441 = [R 408] in + let r442 = [R 865] in + let r443 = Sub (r293) :: r442 in + let r444 = S (T T_UIDENT) :: r232 in + let r445 = [R 866] in + let r446 = [R 599] in + let r447 = [R 395] in + let r448 = [R 502] in + let r449 = S (T T_RPAREN) :: r448 in + let r450 = [R 620] in + let r451 = S (N N_fun_expr) :: r450 in + let r452 = [R 709] in + let r453 = S (T T_RBRACKET) :: r452 in + let r454 = [R 694] in + let r455 = [R 626] in + let r456 = R 489 :: r455 in + let r457 = [R 490] in + let r458 = [R 632] in + let r459 = R 489 :: r458 in + let r460 = R 498 :: r459 in + let r461 = Sub (r258) :: r460 in + let r462 = [R 567] in + let r463 = Sub (r461) :: r462 in + let r464 = [R 703] in + let r465 = S (T T_RBRACE) :: r464 in + let r466 = [R 669] in + let r467 = [R 667] in + let r468 = S (T T_GREATERDOT) :: r467 in + let r469 = [R 153] in + let r470 = Sub (r180) :: r469 in + let r471 = R 316 :: r470 in + let r472 = [R 682] in + let r473 = S (T T_END) :: r472 in + let r474 = R 316 :: r473 in + let r475 = [R 148] in + let r476 = S (N N_fun_expr) :: r475 in + let r477 = S (T T_THEN) :: r476 in + let r478 = Sub (r3) :: r477 in + let r479 = R 316 :: r478 in + let r480 = [R 636] in + let r481 = Sub (r174) :: r480 in + let r482 = R 316 :: r481 in + let r483 = [R 594] in + let r484 = [R 347] in + let r485 = Sub (r3) :: r484 in + let r486 = S (T T_MINUSGREATER) :: r485 in + let r487 = [R 284] in + let r488 = Sub (r331) :: r487 in + let r489 = [R 230] in + let r490 = Sub (r488) :: r489 in + let r491 = [R 583] in + let r492 = Sub (r490) :: r491 in + let r493 = [R 231] in + let r494 = Sub (r492) :: r493 in + let r495 = [R 135] in + let r496 = Sub (r1) :: r495 in + let r497 = [R 141] in + let r498 = Sub (r496) :: r497 in + let r499 = S (T T_MINUSGREATER) :: r498 in + let r500 = R 485 :: r499 in + let r501 = Sub (r494) :: r500 in + let r502 = R 316 :: r501 in + let r503 = [R 546] in + let r504 = S (T T_UNDERSCORE) :: r503 in + let r505 = [R 280] in + let r506 = [R 279] in + let r507 = S (T T_RPAREN) :: r506 in + let r508 = R 496 :: r507 in + let r509 = [R 299] in + let r510 = [R 229] in + let r511 = S (T T_RPAREN) :: r510 in + let r512 = [R 283] in + let r513 = [R 486] in + let r514 = [R 134] in + let r515 = Sub (r174) :: r514 in + let r516 = R 316 :: r515 in + let r517 = [R 614] in + let r518 = [R 615] in + let r519 = Sub (r174) :: r518 in + let r520 = R 316 :: r519 in + let r521 = [R 595] in + let r522 = [R 123] in + let r523 = S (T T_DOWNTO) :: r522 in + let r524 = [R 151] in + let r525 = S (T T_DONE) :: r524 in + let r526 = Sub (r3) :: r525 in + let r527 = S (T T_DO) :: r526 in + let r528 = Sub (r3) :: r527 in + let r529 = Sub (r523) :: r528 in + let r530 = Sub (r3) :: r529 in + let r531 = S (T T_EQUAL) :: r530 in + let r532 = S (N N_pattern) :: r531 in + let r533 = R 316 :: r532 in + let r534 = [R 692] in + let r535 = [R 702] in + let r536 = S (T T_RPAREN) :: r535 in + let r537 = S (T T_LPAREN) :: r536 in + let r538 = S (T T_DOT) :: r537 in + let r539 = [R 712] in + let r540 = S (T T_RPAREN) :: r539 in + let r541 = S (N N_module_type) :: r540 in + let r542 = S (T T_COLON) :: r541 in + let r543 = S (N N_module_expr) :: r542 in + let r544 = R 316 :: r543 in + let r545 = [R 302] in + let r546 = Sub (r3) :: r545 in + let r547 = S (T T_EQUAL) :: r546 in + let r548 = [R 152] in + let r549 = Sub (r180) :: r548 in + let r550 = R 316 :: r549 in + let r551 = [R 699] in + let r552 = [R 675] in + let r553 = S (T T_RPAREN) :: r552 in + let r554 = Sub (r451) :: r553 in + let r555 = S (T T_LPAREN) :: r554 in + let r556 = [R 622] in + let r557 = Sub (r174) :: r556 in + let r558 = R 316 :: r557 in + let r559 = [R 198] in + let r560 = [R 199] in + let r561 = Sub (r174) :: r560 in + let r562 = R 316 :: r561 in + let r563 = [R 273] in + let r564 = [R 821] in + let r565 = Sub (r34) :: r564 in + let r566 = S (T T_COLON) :: r565 in + let r567 = [R 274] in + let r568 = S (T T_RPAREN) :: r567 in + let r569 = Sub (r566) :: r568 in + let r570 = [R 823] in + let r571 = [R 822] in + let r572 = [R 275] in + let r573 = [R 276] in + let r574 = [R 698] in + let r575 = [R 672] in let r576 = S (T T_RPAREN) :: r575 in - let r577 = Sub (r574) :: r576 in - let r578 = [R 787] in - let r579 = [R 786] in - let r580 = [R 248] in - let r581 = [R 249] in - let r582 = [R 661] in - let r583 = [R 658] in - let r584 = Sub (r258) :: r583 in - let r585 = [R 635] in - let r586 = S (T T_RPAREN) :: r585 in - let r587 = Sub (r7) :: r586 in - let r588 = [R 581] in - let r589 = [R 124] in - let r590 = Sub (r7) :: r589 in - let r591 = [R 187] in - let r592 = Sub (r7) :: r591 in - let r593 = [R 175] in - let r594 = [R 172] in - let r595 = [R 186] in - let r596 = [R 171] in - let r597 = [R 170] in - let r598 = [R 176] in - let r599 = [R 180] in - let r600 = [R 174] in - let r601 = [R 173] in - let r602 = [R 178] in - let r603 = [R 169] in - let r604 = [R 168] in - let r605 = [R 167] in - let r606 = [R 166] in - let r607 = [R 165] in - let r608 = [R 179] in - let r609 = [R 177] in - let r610 = [R 184] in - let r611 = [R 582] in - let r612 = S (N N_expr) :: r611 in - let r613 = [R 189] in - let r614 = [R 181] in - let r615 = [R 182] in - let r616 = [R 183] in - let r617 = [R 208] in - let r618 = Sub (r7) :: r617 in - let r619 = [R 19] in - let r620 = R 295 :: r619 in - let r621 = Sub (r245) :: r620 in - let r622 = [R 265] in - let r623 = Sub (r7) :: r622 in - let r624 = S (T T_EQUAL) :: r623 in - let r625 = [R 264] in - let r626 = Sub (r7) :: r625 in - let r627 = [R 504] in - let r628 = [R 510] in - let r629 = [R 515] in - let r630 = [R 513] in - let r631 = [R 503] in - let r632 = [R 527] in - let r633 = S (T T_RBRACKET) :: r632 in - let r634 = Sub (r23) :: r633 in - let r635 = [R 521] in - let r636 = [R 522] in - let r637 = [R 360] in - let r638 = S (N N_module_expr) :: r637 in - let r639 = S (T T_EQUAL) :: r638 in - let r640 = [R 761] in - let r641 = R 295 :: r640 in - let r642 = Sub (r639) :: r641 in - let r643 = Sub (r69) :: r642 in - let r644 = R 289 :: r643 in - let r645 = [R 387] in - let r646 = R 295 :: r645 in - let r647 = R 467 :: r646 in - let r648 = Sub (r111) :: r647 in - let r649 = R 289 :: r648 in - let r650 = R 135 :: r649 in - let r651 = [R 468] in - let r652 = [R 296] in - let r653 = [R 762] in - let r654 = R 285 :: r653 in - let r655 = R 295 :: r654 in - let r656 = Sub (r639) :: r655 in - let r657 = [R 361] in - let r658 = S (N N_module_expr) :: r657 in - let r659 = S (T T_EQUAL) :: r658 in - let r660 = [R 286] in - let r661 = R 285 :: r660 in - let r662 = R 295 :: r661 in - let r663 = Sub (r639) :: r662 in - let r664 = Sub (r69) :: r663 in - let r665 = [R 362] in - let r666 = [R 234] in - let r667 = S (T T_RBRACKET) :: r666 in - let r668 = Sub (r21) :: r667 in - let r669 = [R 142] in - let r670 = S (T T_RBRACKET) :: r669 in - let r671 = Sub (r23) :: r670 in - let r672 = [R 767] in - let r673 = R 295 :: r672 in - let r674 = S (N N_module_expr) :: r673 in - let r675 = R 289 :: r674 in - let r676 = [R 400] in - let r677 = S (T T_STRING) :: r676 in - let r678 = [R 528] in - let r679 = R 295 :: r678 in - let r680 = Sub (r677) :: r679 in - let r681 = S (T T_EQUAL) :: r680 in - let r682 = Sub (r95) :: r681 in - let r683 = S (T T_COLON) :: r682 in - let r684 = Sub (r83) :: r683 in - let r685 = R 289 :: r684 in - let r686 = [R 524] in - let r687 = Sub (r93) :: r686 in - let r688 = [R 563] in - let r689 = Sub (r134) :: r357 in - let r690 = [R 746] in - let r691 = R 295 :: r690 in - let r692 = R 289 :: r691 in - let r693 = Sub (r689) :: r692 in - let r694 = S (T T_EQUAL) :: r693 in - let r695 = Sub (r136) :: r694 in - let r696 = R 289 :: r695 in - let r697 = [R 601] in - let r698 = R 295 :: r697 in - let r699 = R 289 :: r698 in - let r700 = R 216 :: r699 in - let r701 = Sub (r136) :: r700 in - let r702 = R 289 :: r701 in - let r703 = R 135 :: r702 in - let r704 = [R 103] in - let r705 = Sub (r85) :: r704 in - let r706 = [R 217] in - let r707 = [R 236] in - let r708 = R 289 :: r707 in - let r709 = Sub (r194) :: r708 in - let r710 = S (T T_COLON) :: r709 in - let r711 = S (T T_LIDENT) :: r710 in - let r712 = R 390 :: r711 in - let r713 = [R 238] in - let r714 = Sub (r712) :: r713 in - let r715 = [R 105] in - let r716 = S (T T_RBRACE) :: r715 in - let r717 = [R 237] in - let r718 = R 289 :: r717 in - let r719 = S (T T_SEMI) :: r718 in - let r720 = R 289 :: r719 in - let r721 = Sub (r194) :: r720 in - let r722 = S (T T_COLON) :: r721 in - let r723 = [R 526] in - let r724 = Sub (r91) :: r723 in - let r725 = [R 104] in - let r726 = Sub (r85) :: r725 in - let r727 = S (T T_COLONCOLON) :: r366 in - let r728 = [R 220] in - let r729 = [R 221] in - let r730 = Sub (r85) :: r729 in - let r731 = [R 219] in - let r732 = Sub (r85) :: r731 in - let r733 = [R 218] in - let r734 = Sub (r85) :: r733 in - let r735 = [R 519] in - let r736 = [R 549] in - let r737 = Sub (r140) :: r736 in - let r738 = [R 609] in - let r739 = R 295 :: r738 in - let r740 = Sub (r737) :: r739 in - let r741 = R 529 :: r740 in - let r742 = S (T T_PLUSEQ) :: r741 in - let r743 = Sub (r132) :: r742 in - let r744 = R 792 :: r743 in - let r745 = R 289 :: r744 in - let r746 = [R 610] in - let r747 = R 295 :: r746 in - let r748 = Sub (r737) :: r747 in - let r749 = R 529 :: r748 in - let r750 = S (T T_PLUSEQ) :: r749 in - let r751 = Sub (r132) :: r750 in - let r752 = [R 225] in - let r753 = R 295 :: r752 in - let r754 = R 552 :: r753 in - let r755 = [R 412] in - let r756 = S (T T_RBRACE) :: r755 in - let r757 = [R 222] in - let r758 = R 289 :: r757 in - let r759 = R 216 :: r758 in - let r760 = Sub (r136) :: r759 in - let r761 = [R 410] in - let r762 = [R 411] in - let r763 = [R 415] in - let r764 = S (T T_RBRACE) :: r763 in - let r765 = [R 414] in - let r766 = S (T T_RBRACE) :: r765 in - let r767 = [R 224] in - let r768 = R 295 :: r767 in - let r769 = R 552 :: r768 in - let r770 = [R 298] in - let r771 = [R 420] in - let r772 = R 295 :: r771 in - let r773 = Sub (r293) :: r772 in - let r774 = R 289 :: r773 in - let r775 = [R 421] in - let r776 = R 295 :: r775 in - let r777 = Sub (r293) :: r776 in - let r778 = R 289 :: r777 in - let r779 = [R 363] in - let r780 = S (N N_module_type) :: r779 in - let r781 = S (T T_COLON) :: r780 in - let r782 = [R 612] in - let r783 = R 295 :: r782 in - let r784 = Sub (r781) :: r783 in - let r785 = Sub (r69) :: r784 in - let r786 = R 289 :: r785 in - let r787 = [R 388] in - let r788 = R 295 :: r787 in - let r789 = S (N N_module_type) :: r788 in - let r790 = S (T T_COLONEQUAL) :: r789 in - let r791 = Sub (r111) :: r790 in - let r792 = R 289 :: r791 in - let r793 = [R 376] in - let r794 = R 295 :: r793 in - let r795 = [R 615] in - let r796 = R 287 :: r795 in - let r797 = R 295 :: r796 in - let r798 = S (N N_module_type) :: r797 in - let r799 = S (T T_COLON) :: r798 in - let r800 = [R 288] in - let r801 = R 287 :: r800 in - let r802 = R 295 :: r801 in - let r803 = S (N N_module_type) :: r802 in - let r804 = S (T T_COLON) :: r803 in - let r805 = Sub (r69) :: r804 in - let r806 = S (T T_UIDENT) :: r33 in - let r807 = Sub (r806) :: r225 in - let r808 = [R 613] in - let r809 = R 295 :: r808 in - let r810 = [R 364] in - let r811 = [R 619] in - let r812 = R 295 :: r811 in - let r813 = S (N N_module_type) :: r812 in - let r814 = R 289 :: r813 in - let r815 = S (T T_QUOTED_STRING_EXPR) :: r48 in - let r816 = [R 71] in - let r817 = Sub (r815) :: r816 in - let r818 = [R 81] in - let r819 = Sub (r817) :: r818 in - let r820 = [R 620] in - let r821 = R 281 :: r820 in - let r822 = R 295 :: r821 in - let r823 = Sub (r819) :: r822 in - let r824 = S (T T_COLON) :: r823 in - let r825 = S (T T_LIDENT) :: r824 in - let r826 = R 143 :: r825 in - let r827 = R 819 :: r826 in - let r828 = R 289 :: r827 in - let r829 = [R 85] in - let r830 = R 283 :: r829 in - let r831 = R 295 :: r830 in - let r832 = Sub (r817) :: r831 in - let r833 = S (T T_EQUAL) :: r832 in - let r834 = S (T T_LIDENT) :: r833 in - let r835 = R 143 :: r834 in - let r836 = R 819 :: r835 in - let r837 = R 289 :: r836 in - let r838 = [R 144] in - let r839 = S (T T_RBRACKET) :: r838 in - let r840 = [R 72] in - let r841 = S (T T_END) :: r840 in - let r842 = R 304 :: r841 in - let r843 = R 62 :: r842 in - let r844 = [R 61] in - let r845 = S (T T_RPAREN) :: r844 in - let r846 = [R 64] in - let r847 = R 295 :: r846 in - let r848 = Sub (r93) :: r847 in - let r849 = S (T T_COLON) :: r848 in - let r850 = S (T T_LIDENT) :: r849 in - let r851 = R 392 :: r850 in - let r852 = [R 65] in - let r853 = R 295 :: r852 in - let r854 = Sub (r95) :: r853 in - let r855 = S (T T_COLON) :: r854 in - let r856 = S (T T_LIDENT) :: r855 in - let r857 = R 531 :: r856 in - let r858 = [R 63] in - let r859 = R 295 :: r858 in - let r860 = Sub (r817) :: r859 in - let r861 = [R 74] in - let r862 = Sub (r817) :: r861 in - let r863 = S (T T_IN) :: r862 in - let r864 = Sub (r807) :: r863 in - let r865 = R 289 :: r864 in - let r866 = [R 75] in - let r867 = Sub (r817) :: r866 in - let r868 = S (T T_IN) :: r867 in - let r869 = Sub (r807) :: r868 in - let r870 = [R 573] in - let r871 = Sub (r93) :: r870 in - let r872 = [R 70] in - let r873 = Sub (r286) :: r872 in - let r874 = S (T T_RBRACKET) :: r873 in - let r875 = Sub (r871) :: r874 in - let r876 = [R 574] in - let r877 = [R 102] in - let r878 = Sub (r93) :: r877 in - let r879 = S (T T_EQUAL) :: r878 in - let r880 = Sub (r93) :: r879 in - let r881 = [R 66] in - let r882 = R 295 :: r881 in - let r883 = Sub (r880) :: r882 in - let r884 = [R 67] in - let r885 = [R 305] in - let r886 = [R 284] in - let r887 = R 283 :: r886 in - let r888 = R 295 :: r887 in - let r889 = Sub (r817) :: r888 in - let r890 = S (T T_EQUAL) :: r889 in - let r891 = S (T T_LIDENT) :: r890 in - let r892 = R 143 :: r891 in - let r893 = R 819 :: r892 in - let r894 = [R 83] in - let r895 = Sub (r819) :: r894 in - let r896 = S (T T_MINUSGREATER) :: r895 in - let r897 = Sub (r87) :: r896 in - let r898 = [R 84] in - let r899 = Sub (r819) :: r898 in - let r900 = [R 82] in - let r901 = Sub (r819) :: r900 in - let r902 = S (T T_MINUSGREATER) :: r901 in - let r903 = [R 282] in - let r904 = R 281 :: r903 in - let r905 = R 295 :: r904 in - let r906 = Sub (r819) :: r905 in - let r907 = S (T T_COLON) :: r906 in - let r908 = S (T T_LIDENT) :: r907 in - let r909 = R 143 :: r908 in - let r910 = R 819 :: r909 in - let r911 = [R 299] in - let r912 = [R 603] in - let r913 = [R 607] in - let r914 = [R 292] in - let r915 = R 291 :: r914 in - let r916 = R 295 :: r915 in - let r917 = R 552 :: r916 in - let r918 = R 788 :: r917 in - let r919 = S (T T_LIDENT) :: r918 in - let r920 = R 792 :: r919 in - let r921 = [R 608] in - let r922 = [R 294] in - let r923 = R 293 :: r922 in - let r924 = R 295 :: r923 in - let r925 = R 552 :: r924 in - let r926 = Sub (r183) :: r925 in - let r927 = S (T T_COLONEQUAL) :: r926 in - let r928 = S (T T_LIDENT) :: r927 in - let r929 = R 792 :: r928 in - let r930 = [R 43] in - let r931 = Sub (r815) :: r930 in - let r932 = [R 52] in - let r933 = Sub (r931) :: r932 in - let r934 = S (T T_EQUAL) :: r933 in - let r935 = [R 765] in - let r936 = R 279 :: r935 in - let r937 = R 295 :: r936 in - let r938 = Sub (r934) :: r937 in - let r939 = S (T T_LIDENT) :: r938 in - let r940 = R 143 :: r939 in - let r941 = R 819 :: r940 in - let r942 = R 289 :: r941 in - let r943 = [R 80] in - let r944 = S (T T_END) :: r943 in - let r945 = R 306 :: r944 in - let r946 = R 60 :: r945 in - let r947 = [R 814] in - let r948 = Sub (r7) :: r947 in - let r949 = S (T T_EQUAL) :: r948 in - let r950 = S (T T_LIDENT) :: r949 in - let r951 = R 390 :: r950 in - let r952 = R 289 :: r951 in - let r953 = [R 46] in - let r954 = R 295 :: r953 in - let r955 = [R 815] in - let r956 = Sub (r7) :: r955 in - let r957 = S (T T_EQUAL) :: r956 in - let r958 = S (T T_LIDENT) :: r957 in - let r959 = R 390 :: r958 in - let r960 = [R 817] in - let r961 = Sub (r7) :: r960 in - let r962 = [R 813] in - let r963 = Sub (r93) :: r962 in - let r964 = S (T T_COLON) :: r963 in - let r965 = [R 816] in - let r966 = Sub (r7) :: r965 in - let r967 = S (T T_EQUAL) :: r399 in - let r968 = [R 333] in - let r969 = Sub (r967) :: r968 in - let r970 = S (T T_LIDENT) :: r969 in - let r971 = R 529 :: r970 in - let r972 = R 289 :: r971 in - let r973 = [R 47] in - let r974 = R 295 :: r973 in - let r975 = [R 334] in - let r976 = Sub (r967) :: r975 in - let r977 = S (T T_LIDENT) :: r976 in - let r978 = R 529 :: r977 in - let r979 = [R 336] in - let r980 = Sub (r7) :: r979 in - let r981 = S (T T_EQUAL) :: r980 in - let r982 = [R 338] in - let r983 = Sub (r7) :: r982 in - let r984 = S (T T_EQUAL) :: r983 in - let r985 = Sub (r93) :: r984 in - let r986 = S (T T_DOT) :: r985 in - let r987 = [R 748] in - let r988 = Sub (r513) :: r987 in - let r989 = S (T T_EQUAL) :: r988 in - let r990 = [R 332] in - let r991 = Sub (r95) :: r990 in - let r992 = S (T T_COLON) :: r991 in - let r993 = [R 335] in - let r994 = Sub (r7) :: r993 in - let r995 = S (T T_EQUAL) :: r994 in - let r996 = [R 337] in - let r997 = Sub (r7) :: r996 in - let r998 = S (T T_EQUAL) :: r997 in - let r999 = Sub (r93) :: r998 in - let r1000 = S (T T_DOT) :: r999 in - let r1001 = [R 49] in - let r1002 = R 295 :: r1001 in - let r1003 = Sub (r7) :: r1002 in - let r1004 = [R 44] in - let r1005 = R 295 :: r1004 in - let r1006 = R 459 :: r1005 in - let r1007 = Sub (r931) :: r1006 in - let r1008 = [R 45] in - let r1009 = R 295 :: r1008 in - let r1010 = R 459 :: r1009 in - let r1011 = Sub (r931) :: r1010 in - let r1012 = [R 76] in - let r1013 = S (T T_RPAREN) :: r1012 in - let r1014 = [R 39] in - let r1015 = Sub (r931) :: r1014 in - let r1016 = S (T T_IN) :: r1015 in - let r1017 = Sub (r807) :: r1016 in - let r1018 = R 289 :: r1017 in - let r1019 = [R 269] in - let r1020 = R 295 :: r1019 in - let r1021 = Sub (r245) :: r1020 in - let r1022 = R 536 :: r1021 in - let r1023 = R 289 :: r1022 in - let r1024 = [R 40] in - let r1025 = Sub (r931) :: r1024 in - let r1026 = S (T T_IN) :: r1025 in - let r1027 = Sub (r807) :: r1026 in - let r1028 = [R 78] in - let r1029 = Sub (r218) :: r1028 in - let r1030 = S (T T_RBRACKET) :: r1029 in - let r1031 = [R 55] in - let r1032 = Sub (r931) :: r1031 in - let r1033 = S (T T_MINUSGREATER) :: r1032 in - let r1034 = Sub (r505) :: r1033 in - let r1035 = [R 37] in - let r1036 = Sub (r1034) :: r1035 in - let r1037 = [R 38] in - let r1038 = Sub (r931) :: r1037 in - let r1039 = [R 245] in - let r1040 = [R 268] in - let r1041 = R 295 :: r1040 in - let r1042 = Sub (r245) :: r1041 in - let r1043 = [R 79] in - let r1044 = S (T T_RPAREN) :: r1043 in - let r1045 = [R 460] in - let r1046 = [R 48] in - let r1047 = R 295 :: r1046 in - let r1048 = Sub (r880) :: r1047 in - let r1049 = [R 50] in - let r1050 = [R 307] in - let r1051 = [R 53] in - let r1052 = Sub (r931) :: r1051 in - let r1053 = S (T T_EQUAL) :: r1052 in - let r1054 = [R 54] in - let r1055 = [R 280] in - let r1056 = R 279 :: r1055 in - let r1057 = R 295 :: r1056 in - let r1058 = Sub (r934) :: r1057 in - let r1059 = S (T T_LIDENT) :: r1058 in - let r1060 = R 143 :: r1059 in - let r1061 = R 819 :: r1060 in - let r1062 = [R 303] in - let r1063 = [R 753] in - let r1064 = [R 757] in - let r1065 = [R 750] in - let r1066 = R 300 :: r1065 in - let r1067 = [R 637] in - let r1068 = S (T T_RBRACKET) :: r1067 in - let r1069 = Sub (r7) :: r1068 in - let r1070 = [R 636] in - let r1071 = S (T T_RBRACE) :: r1070 in - let r1072 = Sub (r7) :: r1071 in - let r1073 = [R 639] in - let r1074 = S (T T_RPAREN) :: r1073 in - let r1075 = Sub (r468) :: r1074 in - let r1076 = S (T T_LPAREN) :: r1075 in - let r1077 = [R 643] in - let r1078 = S (T T_RBRACKET) :: r1077 in - let r1079 = Sub (r468) :: r1078 in - let r1080 = [R 641] in - let r1081 = S (T T_RBRACE) :: r1080 in - let r1082 = Sub (r468) :: r1081 in - let r1083 = [R 195] in - let r1084 = [R 642] in - let r1085 = S (T T_RBRACKET) :: r1084 in - let r1086 = Sub (r468) :: r1085 in - let r1087 = [R 199] in - let r1088 = [R 640] in - let r1089 = S (T T_RBRACE) :: r1088 in - let r1090 = Sub (r468) :: r1089 in - let r1091 = [R 197] in - let r1092 = [R 192] in - let r1093 = [R 194] in - let r1094 = [R 193] in - let r1095 = [R 196] in - let r1096 = [R 200] in - let r1097 = [R 198] in - let r1098 = [R 191] in - let r1099 = [R 276] in - let r1100 = Sub (r7) :: r1099 in - let r1101 = [R 278] in - let r1102 = [R 659] in - let r1103 = [R 671] in - let r1104 = [R 670] in - let r1105 = [R 674] in - let r1106 = [R 673] in - let r1107 = S (T T_LIDENT) :: r473 in - let r1108 = [R 660] in - let r1109 = S (T T_GREATERRBRACE) :: r1108 in - let r1110 = [R 667] in - let r1111 = S (T T_RBRACE) :: r1110 in - let r1112 = [R 539] in - let r1113 = Sub (r478) :: r1112 in - let r1114 = [R 131] in - let r1115 = S (T T_DONE) :: r1114 in - let r1116 = Sub (r7) :: r1115 in - let r1117 = S (T T_DO) :: r1116 in - let r1118 = Sub (r7) :: r1117 in - let r1119 = Sub (r534) :: r1118 in - let r1120 = [R 155] in - let r1121 = [R 644] in - let r1122 = [R 656] in - let r1123 = [R 148] in - let r1124 = Sub (r7) :: r1123 in - let r1125 = S (T T_IN) :: r1124 in - let r1126 = Sub (r639) :: r1125 in - let r1127 = Sub (r69) :: r1126 in - let r1128 = R 289 :: r1127 in - let r1129 = [R 149] in - let r1130 = Sub (r7) :: r1129 in - let r1131 = S (T T_IN) :: r1130 in - let r1132 = R 289 :: r1131 in - let r1133 = R 216 :: r1132 in - let r1134 = Sub (r136) :: r1133 in - let r1135 = R 289 :: r1134 in - let r1136 = [R 263] in - let r1137 = Sub (r7) :: r1136 in + let r577 = Sub (r3) :: r576 in + let r578 = S (T T_LPAREN) :: r577 in + let r579 = [R 610] in + let r580 = [R 611] in + let r581 = Sub (r174) :: r580 in + let r582 = R 316 :: r581 in + let r583 = [R 202] in + let r584 = Sub (r3) :: r583 in + let r585 = [R 178] in + let r586 = [R 179] in + let r587 = Sub (r174) :: r586 in + let r588 = R 316 :: r587 in + let r589 = [R 166] in + let r590 = [R 167] in + let r591 = Sub (r174) :: r590 in + let r592 = R 316 :: r591 in + let r593 = [R 200] in + let r594 = [R 201] in + let r595 = Sub (r174) :: r594 in + let r596 = R 316 :: r595 in + let r597 = [R 235] in + let r598 = Sub (r3) :: r597 in + let r599 = [R 172] in + let r600 = [R 173] in + let r601 = Sub (r174) :: r600 in + let r602 = R 316 :: r601 in + let r603 = [R 180] in + let r604 = [R 181] in + let r605 = Sub (r174) :: r604 in + let r606 = R 316 :: r605 in + let r607 = [R 164] in + let r608 = [R 165] in + let r609 = Sub (r174) :: r608 in + let r610 = R 316 :: r609 in + let r611 = [R 170] in + let r612 = [R 171] in + let r613 = Sub (r174) :: r612 in + let r614 = R 316 :: r613 in + let r615 = [R 168] in + let r616 = [R 169] in + let r617 = Sub (r174) :: r616 in + let r618 = R 316 :: r617 in + let r619 = [R 188] in + let r620 = [R 189] in + let r621 = Sub (r174) :: r620 in + let r622 = R 316 :: r621 in + let r623 = [R 176] in + let r624 = [R 177] in + let r625 = Sub (r174) :: r624 in + let r626 = R 316 :: r625 in + let r627 = [R 174] in + let r628 = [R 175] in + let r629 = Sub (r174) :: r628 in + let r630 = R 316 :: r629 in + let r631 = [R 184] in + let r632 = [R 185] in + let r633 = Sub (r174) :: r632 in + let r634 = R 316 :: r633 in + let r635 = [R 162] in + let r636 = [R 163] in + let r637 = Sub (r174) :: r636 in + let r638 = R 316 :: r637 in + let r639 = [R 160] in + let r640 = [R 161] in + let r641 = Sub (r174) :: r640 in + let r642 = R 316 :: r641 in + let r643 = [R 204] in + let r644 = [R 205] in + let r645 = Sub (r174) :: r644 in + let r646 = R 316 :: r645 in + let r647 = [R 158] in + let r648 = [R 159] in + let r649 = Sub (r174) :: r648 in + let r650 = R 316 :: r649 in + let r651 = [R 186] in + let r652 = [R 187] in + let r653 = Sub (r174) :: r652 in + let r654 = R 316 :: r653 in + let r655 = [R 182] in + let r656 = [R 183] in + let r657 = Sub (r174) :: r656 in + let r658 = R 316 :: r657 in + let r659 = [R 190] in + let r660 = [R 191] in + let r661 = Sub (r174) :: r660 in + let r662 = R 316 :: r661 in + let r663 = [R 192] in + let r664 = [R 193] in + let r665 = Sub (r174) :: r664 in + let r666 = R 316 :: r665 in + let r667 = [R 194] in + let r668 = [R 195] in + let r669 = Sub (r174) :: r668 in + let r670 = R 316 :: r669 in + let r671 = [R 612] in + let r672 = [R 613] in + let r673 = Sub (r174) :: r672 in + let r674 = R 316 :: r673 in + let r675 = [R 196] in + let r676 = [R 197] in + let r677 = Sub (r174) :: r676 in + let r678 = R 316 :: r677 in + let r679 = [R 19] in + let r680 = R 322 :: r679 in + let r681 = Sub (r388) :: r680 in + let r682 = [R 784] in + let r683 = Sub (r3) :: r682 in + let r684 = [R 290] in + let r685 = Sub (r3) :: r684 in + let r686 = S (T T_EQUAL) :: r685 in + let r687 = Sub (r34) :: r686 in + let r688 = S (T T_DOT) :: r687 in + let r689 = [R 289] in + let r690 = Sub (r3) :: r689 in + let r691 = S (T T_EQUAL) :: r690 in + let r692 = Sub (r34) :: r691 in + let r693 = [R 592] in + let r694 = [R 288] in + let r695 = Sub (r3) :: r694 in + let r696 = [R 785] in + let r697 = Sub (r496) :: r696 in + let r698 = S (T T_EQUAL) :: r697 in + let r699 = [R 292] in + let r700 = Sub (r3) :: r699 in + let r701 = S (T T_EQUAL) :: r700 in + let r702 = [R 291] in + let r703 = Sub (r3) :: r702 in + let r704 = [R 533] in + let r705 = [R 539] in + let r706 = [R 544] in + let r707 = [R 542] in + let r708 = [R 532] in + let r709 = [R 323] in + let r710 = [R 674] in + let r711 = S (T T_RBRACKET) :: r710 in + let r712 = Sub (r3) :: r711 in + let r713 = [R 673] in + let r714 = S (T T_RBRACE) :: r713 in + let r715 = Sub (r3) :: r714 in + let r716 = [R 676] in + let r717 = S (T T_RPAREN) :: r716 in + let r718 = Sub (r451) :: r717 in + let r719 = S (T T_LPAREN) :: r718 in + let r720 = [R 680] in + let r721 = S (T T_RBRACKET) :: r720 in + let r722 = Sub (r451) :: r721 in + let r723 = [R 678] in + let r724 = S (T T_RBRACE) :: r723 in + let r725 = Sub (r451) :: r724 in + let r726 = [R 272] in + let r727 = [R 216] in + let r728 = [R 217] in + let r729 = Sub (r174) :: r728 in + let r730 = R 316 :: r729 in + let r731 = [R 679] in + let r732 = S (T T_RBRACKET) :: r731 in + let r733 = Sub (r451) :: r732 in + let r734 = [R 224] in + let r735 = [R 225] in + let r736 = Sub (r174) :: r735 in + let r737 = R 316 :: r736 in + let r738 = [R 677] in + let r739 = S (T T_RBRACE) :: r738 in + let r740 = Sub (r451) :: r739 in + let r741 = [R 220] in + let r742 = [R 221] in + let r743 = Sub (r174) :: r742 in + let r744 = R 316 :: r743 in + let r745 = [R 210] in + let r746 = [R 211] in + let r747 = Sub (r174) :: r746 in + let r748 = R 316 :: r747 in + let r749 = [R 214] in + let r750 = [R 215] in + let r751 = Sub (r174) :: r750 in + let r752 = R 316 :: r751 in + let r753 = [R 212] in + let r754 = [R 213] in + let r755 = Sub (r174) :: r754 in + let r756 = R 316 :: r755 in + let r757 = [R 218] in + let r758 = [R 219] in + let r759 = Sub (r174) :: r758 in + let r760 = R 316 :: r759 in + let r761 = [R 226] in + let r762 = [R 227] in + let r763 = Sub (r174) :: r762 in + let r764 = R 316 :: r763 in + let r765 = [R 222] in + let r766 = [R 223] in + let r767 = Sub (r174) :: r766 in + let r768 = R 316 :: r767 in + let r769 = [R 208] in + let r770 = [R 209] in + let r771 = Sub (r174) :: r770 in + let r772 = R 316 :: r771 in + let r773 = [R 303] in + let r774 = Sub (r3) :: r773 in + let r775 = [R 305] in + let r776 = [R 696] in + let r777 = [R 708] in + let r778 = [R 707] in + let r779 = [R 711] in + let r780 = [R 710] in + let r781 = S (T T_LIDENT) :: r456 in + let r782 = [R 697] in + let r783 = S (T T_GREATERRBRACE) :: r782 in + let r784 = [R 704] in + let r785 = S (T T_RBRACE) :: r784 in + let r786 = [R 568] in + let r787 = Sub (r461) :: r786 in + let r788 = [R 149] in + let r789 = Sub (r174) :: r788 in + let r790 = R 316 :: r789 in + let r791 = [R 146] in + let r792 = [R 147] in + let r793 = Sub (r174) :: r792 in + let r794 = R 316 :: r793 in + let r795 = [R 144] in + let r796 = [R 145] in + let r797 = Sub (r174) :: r796 in + let r798 = R 316 :: r797 in + let r799 = [R 681] in + let r800 = [R 668] in + let r801 = S (T T_GREATERDOT) :: r800 in + let r802 = Sub (r174) :: r801 in + let r803 = R 316 :: r802 in + let r804 = [R 491] in + let r805 = Sub (r174) :: r804 in + let r806 = R 316 :: r805 in + let r807 = [R 693] in + let r808 = [R 384] in + let r809 = S (N N_module_expr) :: r808 in + let r810 = S (T T_EQUAL) :: r809 in + let r811 = [R 137] in + let r812 = Sub (r3) :: r811 in + let r813 = S (T T_IN) :: r812 in + let r814 = Sub (r810) :: r813 in + let r815 = Sub (r195) :: r814 in + let r816 = R 316 :: r815 in + let r817 = [R 385] in + let r818 = S (N N_module_expr) :: r817 in + let r819 = S (T T_EQUAL) :: r818 in + let r820 = [R 386] in + let r821 = [R 138] in + let r822 = Sub (r3) :: r821 in + let r823 = S (T T_IN) :: r822 in + let r824 = R 316 :: r823 in + let r825 = R 243 :: r824 in + let r826 = Sub (r90) :: r825 in + let r827 = R 316 :: r826 in + let r828 = [R 103] in + let r829 = Sub (r26) :: r828 in + let r830 = [R 244] in + let r831 = [R 263] in + let r832 = R 316 :: r831 in + let r833 = Sub (r141) :: r832 in + let r834 = S (T T_COLON) :: r833 in + let r835 = S (T T_LIDENT) :: r834 in + let r836 = R 414 :: r835 in + let r837 = [R 265] in + let r838 = Sub (r836) :: r837 in + let r839 = [R 105] in + let r840 = S (T T_RBRACE) :: r839 in + let r841 = [R 264] in + let r842 = R 316 :: r841 in + let r843 = S (T T_SEMI) :: r842 in + let r844 = R 316 :: r843 in + let r845 = Sub (r141) :: r844 in + let r846 = S (T T_COLON) :: r845 in + let r847 = [R 555] in + let r848 = Sub (r32) :: r847 in + let r849 = [R 104] in + let r850 = Sub (r26) :: r849 in + let r851 = [R 247] in + let r852 = [R 248] in + let r853 = Sub (r26) :: r852 in + let r854 = [R 246] in + let r855 = Sub (r26) :: r854 in + let r856 = [R 245] in + let r857 = Sub (r26) :: r856 in + let r858 = [R 207] in + let r859 = Sub (r174) :: r858 in + let r860 = R 316 :: r859 in + let r861 = [R 705] in + let r862 = [R 684] in + let r863 = S (T T_RPAREN) :: r862 in + let r864 = S (N N_module_expr) :: r863 in + let r865 = R 316 :: r864 in + let r866 = [R 685] in + let r867 = S (T T_RPAREN) :: r866 in + let r868 = [R 671] in + let r869 = [R 505] in + let r870 = S (T T_RPAREN) :: r869 in + let r871 = Sub (r174) :: r870 in + let r872 = R 316 :: r871 in + let r873 = [R 511] in + let r874 = S (T T_RPAREN) :: r873 in + let r875 = [R 507] in + let r876 = S (T T_RPAREN) :: r875 in + let r877 = [R 509] in + let r878 = S (T T_RPAREN) :: r877 in + let r879 = [R 510] in + let r880 = S (T T_RPAREN) :: r879 in + let r881 = [R 506] in + let r882 = S (T T_RPAREN) :: r881 in + let r883 = [R 508] in + let r884 = S (T T_RPAREN) :: r883 in + let r885 = [R 797] in + let r886 = R 322 :: r885 in + let r887 = Sub (r810) :: r886 in + let r888 = Sub (r195) :: r887 in + let r889 = R 316 :: r888 in + let r890 = [R 411] in + let r891 = R 322 :: r890 in + let r892 = R 492 :: r891 in + let r893 = Sub (r59) :: r892 in + let r894 = R 316 :: r893 in + let r895 = R 124 :: r894 in + let r896 = [R 493] in + let r897 = [R 798] in + let r898 = R 312 :: r897 in + let r899 = R 322 :: r898 in + let r900 = Sub (r810) :: r899 in + let r901 = [R 313] in + let r902 = R 312 :: r901 in + let r903 = R 322 :: r902 in + let r904 = Sub (r810) :: r903 in + let r905 = Sub (r195) :: r904 in + let r906 = [R 261] in + let r907 = S (T T_RBRACKET) :: r906 in + let r908 = Sub (r17) :: r907 in + let r909 = [R 550] in + let r910 = [R 551] in + let r911 = [R 131] in + let r912 = S (T T_RBRACKET) :: r911 in + let r913 = Sub (r19) :: r912 in + let r914 = [R 803] in + let r915 = R 322 :: r914 in + let r916 = S (N N_module_expr) :: r915 in + let r917 = R 316 :: r916 in + let r918 = [R 424] in + let r919 = S (T T_STRING) :: r918 in + let r920 = [R 557] in + let r921 = R 322 :: r920 in + let r922 = Sub (r919) :: r921 in + let r923 = S (T T_EQUAL) :: r922 in + let r924 = Sub (r36) :: r923 in + let r925 = S (T T_COLON) :: r924 in + let r926 = Sub (r24) :: r925 in + let r927 = R 316 :: r926 in + let r928 = [R 553] in + let r929 = Sub (r34) :: r928 in + let r930 = Sub (r88) :: r357 in + let r931 = [R 783] in + let r932 = R 322 :: r931 in + let r933 = R 316 :: r932 in + let r934 = Sub (r930) :: r933 in + let r935 = S (T T_EQUAL) :: r934 in + let r936 = Sub (r90) :: r935 in + let r937 = R 316 :: r936 in + let r938 = [R 637] in + let r939 = R 322 :: r938 in + let r940 = R 316 :: r939 in + let r941 = R 243 :: r940 in + let r942 = Sub (r90) :: r941 in + let r943 = R 316 :: r942 in + let r944 = R 124 :: r943 in + let r945 = S (T T_COLONCOLON) :: r366 in + let r946 = [R 548] in + let r947 = [R 325] in + let r948 = [R 444] in + let r949 = R 322 :: r948 in + let r950 = Sub (r293) :: r949 in + let r951 = R 316 :: r950 in + let r952 = [R 445] in + let r953 = R 322 :: r952 in + let r954 = Sub (r293) :: r953 in + let r955 = R 316 :: r954 in + let r956 = [R 387] in + let r957 = S (N N_module_type) :: r956 in + let r958 = S (T T_COLON) :: r957 in + let r959 = [R 648] in + let r960 = R 322 :: r959 in + let r961 = Sub (r958) :: r960 in + let r962 = Sub (r195) :: r961 in + let r963 = R 316 :: r962 in + let r964 = [R 412] in + let r965 = R 322 :: r964 in + let r966 = S (N N_module_type) :: r965 in + let r967 = S (T T_COLONEQUAL) :: r966 in + let r968 = Sub (r59) :: r967 in + let r969 = R 316 :: r968 in + let r970 = [R 400] in + let r971 = R 322 :: r970 in + let r972 = [R 651] in + let r973 = R 314 :: r972 in + let r974 = R 322 :: r973 in + let r975 = S (N N_module_type) :: r974 in + let r976 = S (T T_COLON) :: r975 in + let r977 = [R 315] in + let r978 = R 314 :: r977 in + let r979 = R 322 :: r978 in + let r980 = S (N N_module_type) :: r979 in + let r981 = S (T T_COLON) :: r980 in + let r982 = Sub (r195) :: r981 in + let r983 = S (T T_UIDENT) :: r149 in + let r984 = Sub (r983) :: r233 in + let r985 = [R 649] in + let r986 = R 322 :: r985 in + let r987 = [R 388] in + let r988 = [R 655] in + let r989 = R 322 :: r988 in + let r990 = S (N N_module_type) :: r989 in + let r991 = R 316 :: r990 in + let r992 = S (T T_QUOTED_STRING_EXPR) :: r57 in + let r993 = [R 71] in + let r994 = Sub (r992) :: r993 in + let r995 = [R 81] in + let r996 = Sub (r994) :: r995 in + let r997 = [R 656] in + let r998 = R 308 :: r997 in + let r999 = R 322 :: r998 in + let r1000 = Sub (r996) :: r999 in + let r1001 = S (T T_COLON) :: r1000 in + let r1002 = S (T T_LIDENT) :: r1001 in + let r1003 = R 132 :: r1002 in + let r1004 = R 855 :: r1003 in + let r1005 = R 316 :: r1004 in + let r1006 = [R 85] in + let r1007 = R 310 :: r1006 in + let r1008 = R 322 :: r1007 in + let r1009 = Sub (r994) :: r1008 in + let r1010 = S (T T_EQUAL) :: r1009 in + let r1011 = S (T T_LIDENT) :: r1010 in + let r1012 = R 132 :: r1011 in + let r1013 = R 855 :: r1012 in + let r1014 = R 316 :: r1013 in + let r1015 = [R 133] in + let r1016 = S (T T_RBRACKET) :: r1015 in + let r1017 = [R 72] in + let r1018 = S (T T_END) :: r1017 in + let r1019 = R 331 :: r1018 in + let r1020 = R 62 :: r1019 in + let r1021 = [R 61] in + let r1022 = S (T T_RPAREN) :: r1021 in + let r1023 = [R 64] in + let r1024 = R 322 :: r1023 in + let r1025 = Sub (r34) :: r1024 in + let r1026 = S (T T_COLON) :: r1025 in + let r1027 = S (T T_LIDENT) :: r1026 in + let r1028 = R 416 :: r1027 in + let r1029 = [R 65] in + let r1030 = R 322 :: r1029 in + let r1031 = Sub (r36) :: r1030 in + let r1032 = S (T T_COLON) :: r1031 in + let r1033 = S (T T_LIDENT) :: r1032 in + let r1034 = R 560 :: r1033 in + let r1035 = [R 63] in + let r1036 = R 322 :: r1035 in + let r1037 = Sub (r994) :: r1036 in + let r1038 = [R 74] in + let r1039 = Sub (r994) :: r1038 in + let r1040 = S (T T_IN) :: r1039 in + let r1041 = Sub (r984) :: r1040 in + let r1042 = R 316 :: r1041 in + let r1043 = [R 75] in + let r1044 = Sub (r994) :: r1043 in + let r1045 = S (T T_IN) :: r1044 in + let r1046 = Sub (r984) :: r1045 in + let r1047 = [R 602] in + let r1048 = Sub (r34) :: r1047 in + let r1049 = [R 70] in + let r1050 = Sub (r286) :: r1049 in + let r1051 = S (T T_RBRACKET) :: r1050 in + let r1052 = Sub (r1048) :: r1051 in + let r1053 = [R 603] in + let r1054 = [R 102] in + let r1055 = Sub (r34) :: r1054 in + let r1056 = S (T T_EQUAL) :: r1055 in + let r1057 = Sub (r34) :: r1056 in + let r1058 = [R 66] in + let r1059 = R 322 :: r1058 in + let r1060 = Sub (r1057) :: r1059 in + let r1061 = [R 67] in + let r1062 = [R 332] in + let r1063 = [R 311] in + let r1064 = R 310 :: r1063 in + let r1065 = R 322 :: r1064 in + let r1066 = Sub (r994) :: r1065 in + let r1067 = S (T T_EQUAL) :: r1066 in + let r1068 = S (T T_LIDENT) :: r1067 in + let r1069 = R 132 :: r1068 in + let r1070 = R 855 :: r1069 in + let r1071 = [R 83] in + let r1072 = Sub (r996) :: r1071 in + let r1073 = S (T T_MINUSGREATER) :: r1072 in + let r1074 = Sub (r28) :: r1073 in + let r1075 = [R 84] in + let r1076 = Sub (r996) :: r1075 in + let r1077 = [R 82] in + let r1078 = Sub (r996) :: r1077 in + let r1079 = S (T T_MINUSGREATER) :: r1078 in + let r1080 = [R 309] in + let r1081 = R 308 :: r1080 in + let r1082 = R 322 :: r1081 in + let r1083 = Sub (r996) :: r1082 in + let r1084 = S (T T_COLON) :: r1083 in + let r1085 = S (T T_LIDENT) :: r1084 in + let r1086 = R 132 :: r1085 in + let r1087 = R 855 :: r1086 in + let r1088 = [R 326] in + let r1089 = [R 639] in + let r1090 = [R 643] in + let r1091 = [R 319] in + let r1092 = R 318 :: r1091 in + let r1093 = R 322 :: r1092 in + let r1094 = R 581 :: r1093 in + let r1095 = R 824 :: r1094 in + let r1096 = S (T T_LIDENT) :: r1095 in + let r1097 = R 828 :: r1096 in + let r1098 = [R 644] in + let r1099 = [R 321] in + let r1100 = R 320 :: r1099 in + let r1101 = R 322 :: r1100 in + let r1102 = R 581 :: r1101 in + let r1103 = Sub (r129) :: r1102 in + let r1104 = S (T T_COLONEQUAL) :: r1103 in + let r1105 = S (T T_LIDENT) :: r1104 in + let r1106 = R 828 :: r1105 in + let r1107 = [R 436] in + let r1108 = S (T T_RBRACE) :: r1107 in + let r1109 = [R 249] in + let r1110 = R 316 :: r1109 in + let r1111 = R 243 :: r1110 in + let r1112 = Sub (r90) :: r1111 in + let r1113 = [R 434] in + let r1114 = [R 435] in + let r1115 = [R 439] in + let r1116 = S (T T_RBRACE) :: r1115 in + let r1117 = [R 438] in + let r1118 = S (T T_RBRACE) :: r1117 in + let r1119 = [R 43] in + let r1120 = Sub (r992) :: r1119 in + let r1121 = [R 52] in + let r1122 = Sub (r1120) :: r1121 in + let r1123 = S (T T_EQUAL) :: r1122 in + let r1124 = [R 801] in + let r1125 = R 306 :: r1124 in + let r1126 = R 322 :: r1125 in + let r1127 = Sub (r1123) :: r1126 in + let r1128 = S (T T_LIDENT) :: r1127 in + let r1129 = R 132 :: r1128 in + let r1130 = R 855 :: r1129 in + let r1131 = R 316 :: r1130 in + let r1132 = [R 80] in + let r1133 = S (T T_END) :: r1132 in + let r1134 = R 333 :: r1133 in + let r1135 = R 60 :: r1134 in + let r1136 = [R 850] in + let r1137 = Sub (r3) :: r1136 in let r1138 = S (T T_EQUAL) :: r1137 in - let r1139 = Sub (r93) :: r1138 in - let r1140 = S (T T_DOT) :: r1139 in - let r1141 = [R 262] in - let r1142 = Sub (r7) :: r1141 in - let r1143 = S (T T_EQUAL) :: r1142 in - let r1144 = Sub (r93) :: r1143 in - let r1145 = [R 261] in - let r1146 = Sub (r7) :: r1145 in - let r1147 = [R 668] in - let r1148 = [R 648] in - let r1149 = S (T T_RPAREN) :: r1148 in - let r1150 = [R 633] in - let r1151 = [R 634] in - let r1152 = [R 482] in - let r1153 = S (T T_RPAREN) :: r1152 in - let r1154 = [R 480] in - let r1155 = S (T T_RPAREN) :: r1154 in - let r1156 = [R 481] in - let r1157 = S (T T_RPAREN) :: r1156 in - let r1158 = [R 302] in - let r1159 = R 300 :: r1158 in - let r1160 = [R 327] in - let r1161 = [R 416] in - let r1162 = [R 25] in - let r1163 = Sub (r132) :: r1162 in - let r1164 = [R 28] in - let r1165 = [R 579] in - let r1166 = [R 580] in - let r1167 = [R 413] in - let r1168 = S (T T_RBRACE) :: r1167 in - let r1169 = [R 139] in - let r1170 = R 289 :: r1169 in - let r1171 = [R 140] in - let r1172 = R 289 :: r1171 in - let r1173 = [R 59] in - let r1174 = S (T T_RPAREN) :: r1173 in - let r1175 = [R 127] in - let r1176 = [R 129] in - let r1177 = [R 128] in - let r1178 = [R 230] in - let r1179 = [R 233] in - let r1180 = [R 344] in - let r1181 = [R 347] in - let r1182 = S (T T_RPAREN) :: r1181 in - let r1183 = S (T T_COLONCOLON) :: r1182 in - let r1184 = S (T T_LPAREN) :: r1183 in - let r1185 = [R 483] in - let r1186 = [R 484] in - let r1187 = [R 485] in - let r1188 = [R 486] in - let r1189 = [R 487] in - let r1190 = [R 488] in - let r1191 = [R 489] in - let r1192 = [R 490] in - let r1193 = [R 491] in - let r1194 = [R 492] in - let r1195 = [R 493] in - let r1196 = [R 772] in - let r1197 = [R 781] in - let r1198 = [R 309] in - let r1199 = [R 779] in - let r1200 = S (T T_SEMISEMI) :: r1199 in - let r1201 = [R 780] in - let r1202 = [R 311] in - let r1203 = [R 314] in - let r1204 = [R 313] in - let r1205 = [R 312] in - let r1206 = R 310 :: r1205 in - let r1207 = [R 808] in - let r1208 = S (T T_EOF) :: r1207 in - let r1209 = R 310 :: r1208 in - let r1210 = [R 807] in + let r1139 = S (T T_LIDENT) :: r1138 in + let r1140 = R 414 :: r1139 in + let r1141 = R 316 :: r1140 in + let r1142 = [R 46] in + let r1143 = R 322 :: r1142 in + let r1144 = [R 851] in + let r1145 = Sub (r3) :: r1144 in + let r1146 = S (T T_EQUAL) :: r1145 in + let r1147 = S (T T_LIDENT) :: r1146 in + let r1148 = R 414 :: r1147 in + let r1149 = [R 853] in + let r1150 = Sub (r3) :: r1149 in + let r1151 = [R 849] in + let r1152 = Sub (r34) :: r1151 in + let r1153 = S (T T_COLON) :: r1152 in + let r1154 = [R 852] in + let r1155 = Sub (r3) :: r1154 in + let r1156 = S (T T_EQUAL) :: r683 in + let r1157 = [R 357] in + let r1158 = Sub (r1156) :: r1157 in + let r1159 = S (T T_LIDENT) :: r1158 in + let r1160 = R 558 :: r1159 in + let r1161 = R 316 :: r1160 in + let r1162 = [R 47] in + let r1163 = R 322 :: r1162 in + let r1164 = [R 358] in + let r1165 = Sub (r1156) :: r1164 in + let r1166 = S (T T_LIDENT) :: r1165 in + let r1167 = R 558 :: r1166 in + let r1168 = [R 360] in + let r1169 = Sub (r3) :: r1168 in + let r1170 = S (T T_EQUAL) :: r1169 in + let r1171 = [R 362] in + let r1172 = Sub (r3) :: r1171 in + let r1173 = S (T T_EQUAL) :: r1172 in + let r1174 = Sub (r34) :: r1173 in + let r1175 = S (T T_DOT) :: r1174 in + let r1176 = [R 356] in + let r1177 = Sub (r36) :: r1176 in + let r1178 = S (T T_COLON) :: r1177 in + let r1179 = [R 359] in + let r1180 = Sub (r3) :: r1179 in + let r1181 = S (T T_EQUAL) :: r1180 in + let r1182 = [R 361] in + let r1183 = Sub (r3) :: r1182 in + let r1184 = S (T T_EQUAL) :: r1183 in + let r1185 = Sub (r34) :: r1184 in + let r1186 = S (T T_DOT) :: r1185 in + let r1187 = [R 49] in + let r1188 = R 322 :: r1187 in + let r1189 = Sub (r3) :: r1188 in + let r1190 = [R 44] in + let r1191 = R 322 :: r1190 in + let r1192 = R 483 :: r1191 in + let r1193 = Sub (r1120) :: r1192 in + let r1194 = [R 45] in + let r1195 = R 322 :: r1194 in + let r1196 = R 483 :: r1195 in + let r1197 = Sub (r1120) :: r1196 in + let r1198 = [R 76] in + let r1199 = S (T T_RPAREN) :: r1198 in + let r1200 = [R 39] in + let r1201 = Sub (r1120) :: r1200 in + let r1202 = S (T T_IN) :: r1201 in + let r1203 = Sub (r984) :: r1202 in + let r1204 = R 316 :: r1203 in + let r1205 = [R 296] in + let r1206 = R 322 :: r1205 in + let r1207 = Sub (r388) :: r1206 in + let r1208 = R 565 :: r1207 in + let r1209 = R 316 :: r1208 in + let r1210 = [R 40] in + let r1211 = Sub (r1120) :: r1210 in + let r1212 = S (T T_IN) :: r1211 in + let r1213 = Sub (r984) :: r1212 in + let r1214 = [R 78] in + let r1215 = Sub (r226) :: r1214 in + let r1216 = S (T T_RBRACKET) :: r1215 in + let r1217 = [R 55] in + let r1218 = Sub (r1120) :: r1217 in + let r1219 = S (T T_MINUSGREATER) :: r1218 in + let r1220 = Sub (r488) :: r1219 in + let r1221 = [R 37] in + let r1222 = Sub (r1220) :: r1221 in + let r1223 = [R 38] in + let r1224 = Sub (r1120) :: r1223 in + let r1225 = [R 295] in + let r1226 = R 322 :: r1225 in + let r1227 = Sub (r388) :: r1226 in + let r1228 = [R 79] in + let r1229 = S (T T_RPAREN) :: r1228 in + let r1230 = [R 484] in + let r1231 = [R 48] in + let r1232 = R 322 :: r1231 in + let r1233 = Sub (r1057) :: r1232 in + let r1234 = [R 50] in + let r1235 = [R 334] in + let r1236 = [R 53] in + let r1237 = Sub (r1120) :: r1236 in + let r1238 = S (T T_EQUAL) :: r1237 in + let r1239 = [R 54] in + let r1240 = [R 307] in + let r1241 = R 306 :: r1240 in + let r1242 = R 322 :: r1241 in + let r1243 = Sub (r1123) :: r1242 in + let r1244 = S (T T_LIDENT) :: r1243 in + let r1245 = R 132 :: r1244 in + let r1246 = R 855 :: r1245 in + let r1247 = [R 330] in + let r1248 = [R 789] in + let r1249 = [R 793] in + let r1250 = [R 787] in + let r1251 = R 327 :: r1250 in + let r1252 = [R 329] in + let r1253 = R 327 :: r1252 in + let r1254 = [R 59] in + let r1255 = S (T T_RPAREN) :: r1254 in + let r1256 = [R 128] in + let r1257 = R 316 :: r1256 in + let r1258 = [R 129] in + let r1259 = R 316 :: r1258 in + let r1260 = [R 351] in + let r1261 = [R 440] in + let r1262 = [R 25] in + let r1263 = Sub (r86) :: r1262 in + let r1264 = [R 28] in + let r1265 = [R 608] in + let r1266 = [R 609] in + let r1267 = [R 437] in + let r1268 = S (T T_RBRACE) :: r1267 in + let r1269 = [R 252] in + let r1270 = R 322 :: r1269 in + let r1271 = R 581 :: r1270 in + let r1272 = [R 251] in + let r1273 = R 322 :: r1272 in + let r1274 = R 581 :: r1273 in + let r1275 = [R 257] in + let r1276 = [R 260] in + let r1277 = [R 368] in + let r1278 = [R 371] in + let r1279 = S (T T_RPAREN) :: r1278 in + let r1280 = S (T T_COLONCOLON) :: r1279 in + let r1281 = S (T T_LPAREN) :: r1280 in + let r1282 = [R 512] in + let r1283 = [R 513] in + let r1284 = [R 514] in + let r1285 = [R 515] in + let r1286 = [R 516] in + let r1287 = [R 517] in + let r1288 = [R 518] in + let r1289 = [R 519] in + let r1290 = [R 520] in + let r1291 = [R 521] in + let r1292 = [R 522] in + let r1293 = [R 808] in + let r1294 = [R 817] in + let r1295 = [R 336] in + let r1296 = [R 815] in + let r1297 = S (T T_SEMISEMI) :: r1296 in + let r1298 = [R 816] in + let r1299 = [R 338] in + let r1300 = [R 341] in + let r1301 = [R 340] in + let r1302 = [R 339] in + let r1303 = R 337 :: r1302 in + let r1304 = [R 844] in + let r1305 = S (T T_EOF) :: r1304 in + let r1306 = R 337 :: r1305 in + let r1307 = [R 843] in function - | 0 | 1772 | 1776 | 1794 | 1798 | 1802 | 1806 | 1810 | 1814 | 1818 | 1822 | 1826 | 1830 | 1836 | 1856 -> Nothing - | 1771 -> One ([R 0]) - | 1775 -> One ([R 1]) - | 1781 -> One ([R 2]) - | 1795 -> One ([R 3]) - | 1799 -> One ([R 4]) - | 1805 -> One ([R 5]) - | 1807 -> One ([R 6]) - | 1811 -> One ([R 7]) - | 1815 -> One ([R 8]) - | 1819 -> One ([R 9]) - | 1823 -> One ([R 10]) - | 1829 -> One ([R 11]) - | 1833 -> One ([R 12]) - | 1846 -> One ([R 13]) - | 1866 -> One ([R 14]) - | 214 -> One ([R 15]) - | 213 -> One ([R 16]) - | 1789 -> One ([R 20]) - | 1791 -> One ([R 21]) - | 301 -> One ([R 22]) - | 284 -> One ([R 23]) - | 307 -> One ([R 24]) - | 1299 -> One ([R 36]) - | 1308 -> One ([R 41]) - | 1303 -> One ([R 42]) - | 1344 -> One ([R 51]) - | 1311 -> One ([R 56]) - | 1095 -> One ([R 68]) - | 1075 -> One ([R 69]) - | 1077 -> One ([R 73]) - | 1306 -> One ([R 77]) - | 362 -> One ([R 88]) - | 73 -> One ([R 89]) - | 360 -> One ([R 90]) - | 72 -> One ([R 94]) - | 200 | 841 -> One ([R 95]) - | 873 -> One ([R 98]) - | 907 -> One ([R 106]) - | 911 -> One ([R 107]) - | 311 -> One ([R 109]) - | 289 -> One ([R 110]) - | 298 -> One ([R 111]) - | 300 -> One ([R 112]) - | 1529 -> One ([R 122]) - | 691 -> One ([R 133]) - | 1 -> One (R 135 :: r13) - | 61 -> One (R 135 :: r32) - | 66 -> One (R 135 :: r36) - | 69 -> One (R 135 :: r47) - | 76 -> One (R 135 :: r54) - | 96 -> One (R 135 :: r73) - | 107 -> One (R 135 :: r101) - | 215 -> One (R 135 :: r205) - | 216 -> One (R 135 :: r209) - | 222 -> One (R 135 :: r221) - | 237 -> One (R 135 :: r231) - | 240 -> One (R 135 :: r236) - | 248 -> One (R 135 :: r250) - | 354 -> One (R 135 :: r334) - | 377 -> One (R 135 :: r347) - | 474 -> One (R 135 :: r416) - | 568 -> One (R 135 :: r488) - | 571 -> One (R 135 :: r491) - | 574 -> One (R 135 :: r496) - | 577 -> One (R 135 :: r499) - | 583 -> One (R 135 :: r519) - | 595 -> One (R 135 :: r523) - | 602 -> One (R 135 :: r532) - | 607 -> One (R 135 :: r544) - | 623 -> One (R 135 :: r555) - | 637 -> One (R 135 :: r561) - | 645 -> One (R 135 :: r569) - | 777 -> One (R 135 :: r644) - | 816 -> One (R 135 :: r675) - | 821 -> One (R 135 :: r685) - | 963 -> One (R 135 :: r774) - | 964 -> One (R 135 :: r778) - | 973 -> One (R 135 :: r786) - | 1010 -> One (R 135 :: r814) - | 1019 -> One (R 135 :: r828) - | 1020 -> One (R 135 :: r837) - | 1183 -> One (R 135 :: r942) - | 1585 -> One (R 135 :: r1128) - | 1592 -> One (R 135 :: r1135) - | 299 -> One ([R 141]) - | 1478 -> One ([R 161]) - | 673 -> One ([R 162]) - | 695 -> One ([R 163]) - | 676 -> One ([R 164]) - | 738 -> One ([R 201]) - | 740 -> One ([R 206]) - | 745 -> One ([R 207]) - | 488 -> One ([R 215]) - | 153 -> One ([R 228]) - | 131 -> One (R 231 :: r107) - | 135 -> One (R 231 :: r109) - | 212 -> One ([R 235]) - | 863 -> One ([R 239]) - | 864 -> One ([R 240]) - | 1302 -> One ([R 244]) - | 769 -> One ([R 258]) - | 1621 -> One ([R 260]) - | 1382 -> One ([R 267]) - | 1309 -> One ([R 270]) - | 457 -> One ([R 271]) - | 1601 -> One ([R 273]) - | 105 -> One (R 289 :: r81) - | 171 -> One (R 289 :: r128) - | 220 -> One (R 289 :: r214) - | 233 -> One (R 289 :: r226) - | 477 -> One (R 289 :: r420) - | 486 -> One (R 289 :: r432) - | 746 -> One (R 289 :: r621) - | 800 -> One (R 289 :: r664) - | 992 -> One (R 289 :: r805) - | 1031 -> One (R 289 :: r843) - | 1037 -> One (R 289 :: r851) - | 1048 -> One (R 289 :: r857) - | 1059 -> One (R 289 :: r860) - | 1063 -> One (R 289 :: r869) - | 1084 -> One (R 289 :: r883) - | 1100 -> One (R 289 :: r893) - | 1135 -> One (R 289 :: r910) - | 1157 -> One (R 289 :: r920) - | 1167 -> One (R 289 :: r929) - | 1190 -> One (R 289 :: r946) - | 1194 -> One (R 289 :: r959) - | 1222 -> One (R 289 :: r978) - | 1268 -> One (R 289 :: r1003) - | 1272 -> One (R 289 :: r1007) - | 1273 -> One (R 289 :: r1011) - | 1284 -> One (R 289 :: r1027) - | 1292 -> One (R 289 :: r1036) - | 1336 -> One (R 289 :: r1048) - | 1356 -> One (R 289 :: r1061) - | 1672 -> One (R 289 :: r1160) - | 1156 -> One (R 291 :: r913) - | 1385 -> One (R 291 :: r1064) - | 1166 -> One (R 293 :: r921) - | 785 -> One (R 295 :: r652) - | 1093 -> One (R 295 :: r884) - | 1154 -> One (R 295 :: r912) - | 1342 -> One (R 295 :: r1049) - | 1383 -> One (R 295 :: r1063) - | 1390 -> One (R 295 :: r1066) - | 1664 -> One (R 295 :: r1159) - | 1851 -> One (R 295 :: r1200) - | 1862 -> One (R 295 :: r1206) - | 1867 -> One (R 295 :: r1209) - | 962 -> One (R 297 :: r770) - | 1146 -> One (R 297 :: r911) - | 211 -> One (R 300 :: r201) - | 1366 -> One (R 300 :: r1062) - | 1096 -> One (R 304 :: r885) - | 1345 -> One (R 306 :: r1050) - | 1849 -> One (R 308 :: r1198) - | 1857 -> One (R 310 :: r1202) - | 1858 -> One (R 310 :: r1203) - | 1859 -> One (R 310 :: r1204) - | 431 -> One ([R 316]) - | 435 -> One ([R 318]) - | 684 -> One ([R 320]) - | 1379 -> One ([R 321]) - | 1552 -> One ([R 324]) - | 1675 -> One ([R 325]) - | 1678 -> One ([R 326]) - | 1677 -> One ([R 328]) - | 1676 -> One ([R 330]) - | 1674 -> One ([R 331]) - | 1790 -> One ([R 343]) - | 1780 -> One ([R 345]) - | 1788 -> One ([R 346]) - | 1787 -> One ([R 348]) - | 614 -> One ([R 355]) - | 1527 -> One ([R 356]) - | 545 -> One ([R 367]) - | 555 -> One ([R 368]) - | 556 -> One ([R 369]) - | 554 -> One ([R 370]) - | 557 -> One ([R 372]) - | 170 -> One ([R 373]) - | 100 | 983 -> One ([R 374]) - | 515 -> One ([R 381]) - | 492 -> One ([R 382]) - | 522 -> One ([R 386]) - | 849 | 1208 -> One ([R 391]) - | 1041 -> One ([R 393]) - | 1039 -> One ([R 394]) - | 1042 -> One ([R 395]) - | 1040 -> One ([R 396]) - | 395 -> One ([R 399]) - | 834 -> One ([R 401]) - | 919 -> One ([R 402]) - | 1699 -> One ([R 403]) - | 935 -> One ([R 404]) - | 1700 -> One ([R 405]) - | 934 -> One ([R 406]) - | 926 -> One ([R 407]) - | 90 | 244 -> One ([R 422]) - | 114 | 632 -> One ([R 423]) - | 142 -> One ([R 424]) - | 130 -> One ([R 426]) - | 134 -> One ([R 428]) - | 138 -> One ([R 430]) - | 121 -> One ([R 431]) - | 141 | 1498 -> One ([R 432]) - | 120 -> One ([R 433]) - | 119 -> One ([R 434]) - | 118 -> One ([R 435]) - | 117 -> One ([R 436]) - | 116 -> One ([R 437]) - | 93 | 111 | 622 -> One ([R 438]) - | 92 | 621 -> One ([R 439]) - | 91 -> One ([R 440]) - | 113 | 401 | 631 -> One ([R 441]) - | 112 | 630 -> One ([R 442]) - | 88 -> One ([R 443]) - | 94 -> One ([R 444]) - | 123 -> One ([R 445]) - | 115 -> One ([R 446]) - | 122 -> One ([R 447]) - | 95 -> One ([R 448]) - | 140 -> One ([R 449]) - | 143 -> One ([R 450]) - | 139 -> One ([R 452]) - | 327 -> One ([R 453]) - | 326 -> One (R 454 :: r319) - | 262 -> One (R 455 :: r272) - | 263 -> One ([R 456]) - | 432 -> One (R 457 :: r368) - | 433 -> One ([R 458]) - | 1237 -> One (R 473 :: r989) - | 1238 -> One ([R 474]) - | 159 -> One ([R 475]) - | 387 -> One ([R 495]) - | 381 -> One ([R 496]) - | 382 -> One ([R 498]) - | 380 | 633 -> One ([R 505]) - | 764 -> One ([R 511]) - | 765 -> One ([R 512]) - | 766 -> One ([R 514]) - | 463 -> One ([R 516]) - | 1182 -> One ([R 520]) - | 941 | 1249 -> One ([R 530]) - | 1052 -> One ([R 532]) - | 1050 -> One ([R 533]) - | 1053 -> One ([R 534]) - | 1051 -> One ([R 535]) - | 1318 -> One (R 536 :: r1042) - | 251 -> One ([R 537]) - | 917 -> One ([R 540]) - | 918 -> One ([R 541]) - | 913 -> One ([R 542]) - | 1716 -> One ([R 544]) - | 1715 -> One ([R 545]) - | 1717 -> One ([R 546]) - | 1712 -> One ([R 547]) - | 1713 -> One ([R 548]) - | 947 -> One ([R 550]) - | 945 -> One ([R 551]) - | 589 -> One ([R 555]) - | 537 -> One ([R 556]) - | 489 -> One ([R 557]) - | 1305 -> One ([R 558]) - | 1304 -> One ([R 559]) - | 349 -> One ([R 561]) - | 319 -> One ([R 585]) - | 1417 -> One ([R 588]) - | 1418 -> One ([R 589]) - | 1572 -> One ([R 591]) - | 1573 -> One ([R 592]) - | 426 -> One ([R 594]) - | 427 -> One ([R 595]) - | 1519 -> One ([R 597]) - | 1520 -> One ([R 598]) - | 1177 -> One ([R 604]) - | 1145 -> One ([R 605]) - | 1148 -> One ([R 606]) - | 1147 -> One ([R 611]) - | 1152 -> One ([R 614]) - | 1151 -> One ([R 616]) - | 1150 -> One ([R 617]) - | 1149 -> One ([R 618]) - | 1178 -> One ([R 621]) - | 86 -> One ([R 624]) - | 83 -> One ([R 626]) - | 613 -> One ([R 650]) - | 680 -> One ([R 651]) - | 679 | 694 -> One ([R 652]) - | 616 | 675 -> One ([R 653]) - | 678 -> One ([R 663]) - | 363 -> One ([R 676]) - | 367 -> One ([R 679]) - | 368 -> One ([R 683]) - | 399 -> One ([R 685]) - | 372 -> One ([R 686]) - | 428 -> One ([R 688]) - | 390 -> One ([R 693]) - | 28 -> One ([R 694]) - | 8 -> One ([R 695]) - | 52 -> One ([R 697]) - | 51 -> One ([R 698]) - | 50 -> One ([R 699]) - | 49 -> One ([R 700]) - | 48 -> One ([R 701]) - | 47 -> One ([R 702]) - | 46 -> One ([R 703]) - | 45 -> One ([R 704]) - | 44 -> One ([R 705]) - | 43 -> One ([R 706]) - | 42 -> One ([R 707]) - | 41 -> One ([R 708]) - | 40 -> One ([R 709]) - | 39 -> One ([R 710]) - | 38 -> One ([R 711]) - | 37 -> One ([R 712]) - | 36 -> One ([R 713]) - | 35 -> One ([R 714]) - | 34 -> One ([R 715]) - | 33 -> One ([R 716]) - | 32 -> One ([R 717]) - | 31 -> One ([R 718]) - | 30 -> One ([R 719]) - | 29 -> One ([R 720]) - | 27 -> One ([R 721]) - | 26 -> One ([R 722]) - | 25 -> One ([R 723]) - | 24 -> One ([R 724]) - | 23 -> One ([R 725]) - | 22 -> One ([R 726]) - | 21 -> One ([R 727]) - | 20 -> One ([R 728]) - | 19 -> One ([R 729]) - | 18 -> One ([R 730]) - | 17 -> One ([R 731]) - | 16 -> One ([R 732]) - | 15 -> One ([R 733]) - | 14 -> One ([R 734]) - | 13 -> One ([R 735]) - | 12 -> One ([R 736]) - | 11 -> One ([R 737]) - | 10 -> One ([R 738]) - | 9 -> One ([R 739]) - | 7 -> One ([R 740]) - | 6 -> One ([R 741]) - | 5 -> One ([R 742]) - | 4 -> One ([R 743]) - | 3 -> One ([R 744]) - | 1374 -> One ([R 745]) - | 1395 -> One ([R 749]) - | 1378 | 1394 -> One ([R 751]) - | 1381 | 1396 -> One ([R 752]) - | 1387 -> One ([R 754]) - | 1375 -> One ([R 755]) - | 1365 -> One ([R 756]) - | 1373 -> One ([R 760]) - | 1377 -> One ([R 763]) - | 1376 -> One ([R 764]) - | 1388 -> One ([R 766]) - | 236 -> One ([R 768]) - | 235 -> One ([R 769]) - | 1840 -> One ([R 773]) - | 1841 -> One ([R 774]) - | 1843 -> One ([R 775]) - | 1844 -> One ([R 776]) - | 1842 -> One ([R 777]) - | 1839 -> One ([R 778]) - | 1845 -> One ([R 782]) - | 287 -> One ([R 784]) - | 495 -> One (R 792 :: r449) - | 509 -> One ([R 793]) - | 177 -> One ([R 798]) - | 180 -> One ([R 799]) - | 184 -> One ([R 800]) - | 178 -> One ([R 801]) - | 185 -> One ([R 802]) - | 181 -> One ([R 803]) - | 186 -> One ([R 804]) - | 183 -> One ([R 805]) - | 176 -> One ([R 806]) - | 364 -> One ([R 811]) - | 677 -> One ([R 812]) - | 1023 -> One ([R 820]) - | 1206 -> One ([R 821]) - | 1209 -> One ([R 822]) - | 1207 -> One ([R 823]) - | 1247 -> One ([R 824]) - | 1250 -> One ([R 825]) - | 1248 -> One ([R 826]) - | 498 -> One ([R 833]) - | 499 -> One ([R 834]) - | 1513 -> One (S (T T_WITH) :: r1113) - | 166 -> One (S (T T_TYPE) :: r125) - | 866 -> One (S (T T_STAR) :: r726) - | 1847 -> One (S (T T_SEMISEMI) :: r1197) - | 1854 -> One (S (T T_SEMISEMI) :: r1201) - | 1777 -> One (S (T T_RPAREN) :: r60) - | 309 | 1692 -> One (S (T T_RPAREN) :: r311) - | 375 -> One (S (T T_RPAREN) :: r344) - | 419 -> One (S (T T_RPAREN) :: r367) - | 479 -> One (S (T T_RPAREN) :: r421) - | 547 -> One (S (T T_RPAREN) :: r464) - | 1499 -> One (S (T T_RPAREN) :: r1102) - | 1637 -> One (S (T T_RPAREN) :: r1150) - | 1639 -> One (S (T T_RPAREN) :: r1151) - | 1685 -> One (S (T T_RPAREN) :: r1163) - | 1778 -> One (S (T T_RPAREN) :: r1180) - | 845 | 902 -> One (S (T T_RBRACKET) :: r252) - | 1505 -> One (S (T T_RBRACKET) :: r1105) - | 1507 -> One (S (T T_RBRACKET) :: r1106) - | 313 -> One (S (T T_QUOTE) :: r313) - | 1061 -> One (S (T T_OPEN) :: r865) - | 1276 -> One (S (T T_OPEN) :: r1018) - | 160 | 292 -> One (S (T T_MODULE) :: r121) - | 484 -> One (S (T T_MINUSGREATER) :: r428) - | 882 -> One (S (T T_MINUSGREATER) :: r732) - | 886 -> One (S (T T_MINUSGREATER) :: r734) - | 1122 -> One (S (T T_MINUSGREATER) :: r899) - | 124 -> One (S (T T_LPAREN) :: r104) - | 156 -> One (S (T T_LIDENT) :: r116) - | 440 -> One (S (T T_LIDENT) :: r370) - | 448 -> One (S (T T_LIDENT) :: r376) - | 651 -> One (S (T T_LIDENT) :: r571) - | 652 -> One (S (T T_LIDENT) :: r577) - | 663 -> One (S (T T_LIDENT) :: r580) - | 667 -> One (S (T T_LIDENT) :: r582) - | 850 -> One (S (T T_LIDENT) :: r722) - | 1210 -> One (S (T T_LIDENT) :: r964) - | 1251 -> One (S (T T_LIDENT) :: r992) - | 1328 -> One (S (T T_LIDENT) :: r1045) - | 81 -> One (S (T T_INT) :: r58) - | 84 -> One (S (T T_INT) :: r59) - | 681 -> One (S (T T_IN) :: r590) - | 685 -> One (S (T T_IN) :: r592) - | 1296 -> One (S (T T_IN) :: r1038) - | 561 -> One (S (T T_GREATERRBRACE) :: r471) - | 1575 -> One (S (T T_GREATERRBRACE) :: r1122) - | 206 -> One (S (T T_GREATER) :: r192) - | 1680 -> One (S (T T_GREATER) :: r1161) - | 527 -> One (S (T T_EQUAL) :: r460) - | 753 -> One (S (T T_EQUAL) :: r626) - | 1200 -> One (S (T T_EQUAL) :: r961) - | 1218 -> One (S (T T_EQUAL) :: r966) - | 1489 -> One (S (T T_EQUAL) :: r1100) - | 1618 -> One (S (T T_EQUAL) :: r1146) - | 1769 -> One (S (T T_EOF) :: r1178) - | 1773 -> One (S (T T_EOF) :: r1179) - | 1792 -> One (S (T T_EOF) :: r1185) - | 1796 -> One (S (T T_EOF) :: r1186) - | 1800 -> One (S (T T_EOF) :: r1187) - | 1803 -> One (S (T T_EOF) :: r1188) - | 1808 -> One (S (T T_EOF) :: r1189) - | 1812 -> One (S (T T_EOF) :: r1190) - | 1816 -> One (S (T T_EOF) :: r1191) - | 1820 -> One (S (T T_EOF) :: r1192) - | 1824 -> One (S (T T_EOF) :: r1193) - | 1827 -> One (S (T T_EOF) :: r1194) - | 1831 -> One (S (T T_EOF) :: r1195) - | 1871 -> One (S (T T_EOF) :: r1210) - | 1562 -> One (S (T T_END) :: r1121) - | 126 -> One (S (T T_DOTDOT) :: r105) - | 201 -> One (S (T T_DOTDOT) :: r185) - | 920 -> One (S (T T_DOTDOT) :: r761) - | 921 -> One (S (T T_DOTDOT) :: r762) - | 226 | 1411 | 1458 -> One (S (T T_DOT) :: r223) - | 1834 -> One (S (T T_DOT) :: r461) - | 826 -> One (S (T T_DOT) :: r687) - | 853 -> One (S (T T_DOT) :: r724) - | 880 -> One (S (T T_DOT) :: r730) - | 1613 -> One (S (T T_DOT) :: r1144) - | 1782 -> One (S (T T_DOT) :: r1184) - | 744 -> One (S (T T_COMMA) :: r612) - | 202 | 842 -> One (S (T T_COLONCOLON) :: r187) - | 207 -> One (S (T T_COLON) :: r197) - | 481 -> One (S (T T_COLON) :: r424) - | 1116 -> One (S (T T_COLON) :: r897) - | 245 -> One (S (T T_BARRBRACKET) :: r242) - | 253 -> One (S (T T_BARRBRACKET) :: r251) - | 437 -> One (S (T T_BARRBRACKET) :: r369) - | 1501 -> One (S (T T_BARRBRACKET) :: r1103) - | 1503 -> One (S (T T_BARRBRACKET) :: r1104) - | 1626 -> One (S (T T_BARRBRACKET) :: r1147) - | 338 -> One (S (T T_BAR) :: r323) - | 79 -> One (S (N N_pattern) :: r56) - | 392 | 465 -> One (S (N N_pattern) :: r62) - | 353 -> One (S (N N_pattern) :: r328) - | 383 -> One (S (N N_pattern) :: r348) - | 385 -> One (S (N N_pattern) :: r349) - | 406 -> One (S (N N_pattern) :: r360) - | 411 -> One (S (N N_pattern) :: r363) - | 756 -> One (S (N N_pattern) :: r627) - | 758 -> One (S (N N_pattern) :: r628) - | 760 -> One (S (N N_pattern) :: r629) - | 767 -> One (S (N N_pattern) :: r631) - | 773 -> One (S (N N_pattern) :: r635) - | 103 -> One (S (N N_module_type) :: r75) - | 483 -> One (S (N N_module_type) :: r426) - | 523 -> One (S (N N_module_type) :: r457) - | 525 -> One (S (N N_module_type) :: r458) - | 551 -> One (S (N N_module_type) :: r466) - | 782 -> One (S (N N_module_type) :: r651) - | 794 -> One (S (N N_module_type) :: r659) - | 1634 -> One (S (N N_module_type) :: r1149) - | 1649 -> One (S (N N_module_type) :: r1153) - | 1652 -> One (S (N N_module_type) :: r1155) - | 1655 -> One (S (N N_module_type) :: r1157) - | 219 -> One (S (N N_module_expr) :: r211) - | 456 -> One (S (N N_let_pattern) :: r393) - | 247 -> One (S (N N_expr) :: r243) - | 563 -> One (S (N N_expr) :: r474) - | 567 -> One (S (N N_expr) :: r485) - | 649 -> One (S (N N_expr) :: r570) - | 674 -> One (S (N N_expr) :: r588) - | 690 -> One (S (N N_expr) :: r593) - | 692 -> One (S (N N_expr) :: r594) - | 696 -> One (S (N N_expr) :: r595) - | 698 -> One (S (N N_expr) :: r596) - | 700 -> One (S (N N_expr) :: r597) - | 702 -> One (S (N N_expr) :: r598) - | 704 -> One (S (N N_expr) :: r599) - | 706 -> One (S (N N_expr) :: r600) - | 708 -> One (S (N N_expr) :: r601) - | 710 -> One (S (N N_expr) :: r602) - | 712 -> One (S (N N_expr) :: r603) - | 714 -> One (S (N N_expr) :: r604) - | 716 -> One (S (N N_expr) :: r605) - | 718 -> One (S (N N_expr) :: r606) - | 720 -> One (S (N N_expr) :: r607) - | 722 -> One (S (N N_expr) :: r608) - | 724 -> One (S (N N_expr) :: r609) - | 726 -> One (S (N N_expr) :: r610) - | 730 -> One (S (N N_expr) :: r613) - | 732 -> One (S (N N_expr) :: r614) - | 734 -> One (S (N N_expr) :: r615) - | 736 -> One (S (N N_expr) :: r616) - | 1430 -> One (S (N N_expr) :: r1083) - | 1435 -> One (S (N N_expr) :: r1087) - | 1440 -> One (S (N N_expr) :: r1091) - | 1446 -> One (S (N N_expr) :: r1092) - | 1451 -> One (S (N N_expr) :: r1093) - | 1456 -> One (S (N N_expr) :: r1094) - | 1463 -> One (S (N N_expr) :: r1095) - | 1468 -> One (S (N N_expr) :: r1096) - | 1473 -> One (S (N N_expr) :: r1097) - | 1476 -> One (S (N N_expr) :: r1098) - | 1559 -> One (S (N N_expr) :: r1120) - | 75 -> One (Sub (r1) :: r49) - | 566 -> One (Sub (r1) :: r483) - | 612 -> One (Sub (r1) :: r545) - | 641 -> One (Sub (r1) :: r562) - | 665 -> One (Sub (r1) :: r581) - | 1300 -> One (Sub (r1) :: r1039) - | 451 -> One (Sub (r7) :: r380) - | 582 -> One (Sub (r7) :: r503) - | 775 -> One (Sub (r7) :: r636) - | 1540 -> One (Sub (r7) :: r1119) - | 1754 -> One (Sub (r7) :: r1176) - | 1756 -> One (Sub (r7) :: r1177) - | 2 -> One (Sub (r17) :: r18) - | 55 -> One (Sub (r17) :: r19) - | 59 -> One (Sub (r17) :: r26) - | 209 -> One (Sub (r17) :: r200) - | 741 -> One (Sub (r17) :: r618) - | 771 -> One (Sub (r17) :: r634) - | 812 -> One (Sub (r17) :: r668) - | 814 -> One (Sub (r17) :: r671) - | 1277 -> One (Sub (r17) :: r1023) - | 580 -> One (Sub (r40) :: r500) - | 599 -> One (Sub (r40) :: r524) - | 1752 -> One (Sub (r42) :: r1175) - | 790 -> One (Sub (r69) :: r656) - | 987 -> One (Sub (r69) :: r799) - | 894 -> One (Sub (r78) :: r735) - | 413 -> One (Sub (r83) :: r364) - | 762 -> One (Sub (r83) :: r630) - | 288 -> One (Sub (r85) :: r301) - | 303 -> One (Sub (r85) :: r309) - | 591 -> One (Sub (r85) :: r520) - | 879 -> One (Sub (r85) :: r728) - | 293 -> One (Sub (r87) :: r308) - | 1124 -> One (Sub (r87) :: r902) - | 286 -> One (Sub (r89) :: r300) - | 330 -> One (Sub (r91) :: r320) - | 502 -> One (Sub (r91) :: r451) - | 261 -> One (Sub (r93) :: r265) - | 408 -> One (Sub (r93) :: r362) - | 443 -> One (Sub (r93) :: r375) - | 458 -> One (Sub (r93) :: r394) - | 505 -> One (Sub (r93) :: r454) - | 634 -> One (Sub (r93) :: r558) - | 654 -> One (Sub (r93) :: r578) - | 658 -> One (Sub (r93) :: r579) - | 749 -> One (Sub (r93) :: r624) - | 1033 -> One (Sub (r93) :: r845) - | 1071 -> One (Sub (r93) :: r876) - | 1690 -> One (Sub (r93) :: r1165) - | 1693 -> One (Sub (r93) :: r1166) - | 1742 -> One (Sub (r93) :: r1174) - | 1226 -> One (Sub (r95) :: r981) - | 1257 -> One (Sub (r95) :: r995) - | 189 -> One (Sub (r111) :: r180) - | 827 -> One (Sub (r111) :: r688) - | 1837 -> One (Sub (r111) :: r1196) - | 358 -> One (Sub (r132) :: r336) - | 195 -> One (Sub (r175) :: r181) - | 182 -> One (Sub (r177) :: r179) - | 1025 -> One (Sub (r177) :: r839) - | 199 -> One (Sub (r183) :: r184) - | 901 -> One (Sub (r183) :: r754) - | 950 -> One (Sub (r183) :: r769) - | 256 -> One (Sub (r262) :: r264) - | 323 -> One (Sub (r267) :: r314) - | 267 -> One (Sub (r269) :: r276) - | 281 -> One (Sub (r269) :: r299) - | 268 -> One (Sub (r282) :: r284) - | 269 -> One (Sub (r286) :: r287) - | 305 -> One (Sub (r286) :: r310) - | 1687 -> One (Sub (r286) :: r1164) - | 271 -> One (Sub (r293) :: r295) - | 531 -> One (Sub (r293) :: r462) - | 984 -> One (Sub (r293) :: r794) - | 346 -> One (Sub (r325) :: r327) - | 469 -> One (Sub (r331) :: r397) - | 369 -> One (Sub (r339) :: r340) - | 393 -> One (Sub (r353) :: r356) - | 466 -> One (Sub (r353) :: r396) - | 1227 -> One (Sub (r353) :: r986) - | 1258 -> One (Sub (r353) :: r1000) - | 1607 -> One (Sub (r353) :: r1140) - | 441 -> One (Sub (r372) :: r374) - | 449 -> One (Sub (r372) :: r379) - | 1495 -> One (Sub (r382) :: r1101) - | 452 -> One (Sub (r384) :: r387) - | 454 -> One (Sub (r389) :: r390) - | 535 -> One (Sub (r442) :: r463) - | 494 -> One (Sub (r444) :: r445) - | 564 -> One (Sub (r480) :: r482) - | 1512 -> One (Sub (r480) :: r1111) - | 806 -> One (Sub (r639) :: r665) - | 1707 -> One (Sub (r689) :: r1170) - | 1719 -> One (Sub (r689) :: r1172) - | 847 -> One (Sub (r705) :: r706) - | 848 -> One (Sub (r714) :: r716) - | 903 -> One (Sub (r714) :: r756) - | 922 -> One (Sub (r714) :: r764) - | 930 -> One (Sub (r714) :: r766) - | 1695 -> One (Sub (r714) :: r1168) - | 1008 -> One (Sub (r781) :: r810) - | 1001 -> One (Sub (r807) :: r809) - | 1324 -> One (Sub (r819) :: r1044) - | 1348 -> One (Sub (r819) :: r1053) - | 1288 -> One (Sub (r871) :: r1030) - | 1275 -> One (Sub (r931) :: r1013) - | 1352 -> One (Sub (r934) :: r1054) - | 1193 -> One (Sub (r952) :: r954) - | 1221 -> One (Sub (r972) :: r974) - | 1509 -> One (Sub (r1107) :: r1109) - | 64 -> One (r0) - | 650 -> One (r2) - | 689 -> One (r4) - | 688 -> One (r6) - | 1768 -> One (r8) - | 1767 -> One (r9) - | 1766 -> One (r10) - | 1765 -> One (r11) - | 1764 -> One (r12) - | 58 -> One (r13) - | 53 -> One (r14) - | 54 -> One (r16) - | 57 -> One (r18) - | 56 -> One (r19) - | 1389 -> One (r20) - | 1393 -> One (r22) - | 1763 -> One (r24) - | 1762 -> One (r25) - | 60 -> One (r26) - | 1761 -> One (r27) - | 1760 -> One (r28) - | 1759 -> One (r29) - | 1758 -> One (r30) - | 63 -> One (r31) - | 62 -> One (r32) - | 65 -> One (r33) - | 1751 -> One (r34) - | 68 -> One (r35) - | 67 -> One (r36) - | 1553 -> One (r37) - | 1551 -> One (r38) - | 581 -> One (r39) - | 601 -> One (r41) - | 1750 -> One (r43) - | 1749 -> One (r44) - | 1748 -> One (r45) - | 71 -> One (r46) - | 70 -> One (r47) - | 74 -> One (r48) - | 1628 -> One (r49) - | 1747 -> One (r50) - | 1746 -> One (r51) - | 1745 -> One (r52) - | 78 -> One (r53) - | 77 -> One (r54) - | 1741 -> One (r55) - | 1740 -> One (r56) - | 80 -> One (r57) - | 82 -> One (r58) - | 85 -> One (r59) - | 89 -> One (r60) - | 405 -> One (r61) - | 404 -> One (r62) - | 144 -> One (r63) - | 146 -> One (r65) - | 145 -> One (r66) - | 110 -> One (r67) - | 99 -> One (r68) - | 102 -> One (r70) - | 101 -> One (r71) - | 98 -> One (r72) - | 97 -> One (r73) - | 1739 -> One (r74) - | 1738 -> One (r75) - | 104 | 151 -> One (r76) - | 1181 -> One (r77) - | 1737 -> One (r79) - | 1736 -> One (r80) - | 106 -> One (r81) - | 147 | 246 | 565 | 1526 -> One (r82) - | 150 -> One (r84) - | 302 -> One (r86) - | 285 -> One (r88) - | 308 -> One (r90) - | 312 -> One (r92) - | 837 -> One (r94) - | 1735 -> One (r96) - | 1734 -> One (r97) - | 149 -> One (r98) - | 148 -> One (r99) - | 109 -> One (r100) - | 108 -> One (r101) - | 129 -> One (r102) - | 128 -> One (r103) - | 125 -> One (r104) - | 127 -> One (r105) - | 133 -> One (r106) - | 132 -> One (r107) - | 137 -> One (r108) - | 136 -> One (r109) - | 154 -> One (r110) - | 162 -> One (r112) - | 161 -> One (r113) - | 158 -> One (r115) - | 157 -> One (r116) - | 1733 -> One (r117) - | 1732 -> One (r118) - | 165 -> One (r119) - | 164 -> One (r120) - | 163 -> One (r121) - | 1731 -> One (r122) - | 169 -> One (r123) - | 168 -> One (r124) - | 167 -> One (r125) - | 1730 -> One (r126) - | 1729 -> One (r127) - | 172 -> One (r128) - | 205 -> One (r129) - | 296 -> One (r131) - | 361 -> One (r133) - | 893 -> One (r135) - | 929 -> One (r137) - | 928 -> One (r138) - | 927 | 1718 -> One (r139) - | 1714 -> One (r141) - | 1728 -> One (r143) - | 1727 -> One (r144) - | 1726 -> One (r145) - | 1725 -> One (r146) - | 1724 -> One (r147) - | 956 -> One (r151) - | 955 -> One (r152) - | 954 -> One (r153) - | 1711 -> One (r159) - | 1710 -> One (r160) - | 1704 -> One (r161) - | 1703 -> One (r162) - | 1702 -> One (r163) - | 938 -> One (r165) - | 937 -> One (r166) - | 936 -> One (r167) - | 188 -> One (r171) - | 191 -> One (r173) - | 187 -> One (r174) - | 192 -> One (r176) - | 194 -> One (r178) - | 193 -> One (r179) - | 190 -> One (r180) - | 196 -> One (r181) - | 906 -> One (r182) - | 1701 -> One (r184) - | 1698 -> One (r185) - | 844 -> One (r186) - | 843 -> One (r187) - | 1684 -> One (r188) - | 1683 -> One (r189) - | 1682 -> One (r190) - | 204 -> One (r191) - | 1679 -> One (r192) - | 860 -> One (r193) - | 1671 -> One (r195) - | 1670 -> One (r196) - | 208 -> One (r197) - | 1669 -> One (r198) - | 1668 -> One (r199) - | 210 -> One (r200) - | 1667 -> One (r201) - | 1663 -> One (r202) - | 1662 -> One (r203) - | 1661 -> One (r204) - | 1660 -> One (r205) - | 1659 -> One (r206) - | 1658 -> One (r207) - | 218 -> One (r208) - | 217 -> One (r209) - | 550 -> One (r210) - | 549 -> One (r211) - | 1648 -> One (r212) - | 1647 -> One (r213) - | 221 -> One (r214) - | 225 -> One (r215) - | 231 -> One (r217) - | 232 -> One (r219) - | 224 -> One (r220) - | 223 -> One (r221) - | 229 -> One (r222) - | 227 -> One (r223) - | 228 -> One (r224) - | 230 -> One (r225) - | 234 -> One (r226) - | 1646 -> One (r227) - | 1645 -> One (r228) - | 1644 -> One (r229) - | 239 -> One (r230) - | 238 -> One (r231) - | 1643 -> One (r232) - | 1642 -> One (r233) - | 1641 -> One (r234) - | 242 -> One (r235) - | 241 -> One (r236) - | 1633 -> One (r237) - | 1632 -> One (r238) - | 1631 -> One (r239) - | 1630 -> One (r240) - | 1629 -> One (r241) - | 1625 -> One (r242) - | 1624 -> One (r243) - | 439 -> One (r244) - | 1623 -> One (r246) - | 1622 -> One (r247) - | 252 -> One (r248) - | 250 -> One (r249) - | 249 -> One (r250) - | 436 -> One (r251) - | 255 -> One (r252) - | 425 -> One (r253) - | 424 -> One (r255) - | 423 -> One (r256) - | 257 -> One (r257) - | 430 -> One (r259) - | 352 -> One (r260) - | 260 -> One (r261) - | 259 -> One (r263) - | 258 -> One (r264) - | 351 -> One (r265) - | 335 -> One (r266) - | 320 -> One (r268) - | 345 -> One (r270) - | 344 -> One (r271) - | 264 -> One (r272) - | 266 -> One (r273) - | 265 -> One (r274) - | 343 -> One (r275) - | 342 -> One (r276) - | 283 -> One (r277) - | 282 -> One (r278) - | 334 -> One (r280) - | 325 -> One (r281) - | 337 -> One (r283) - | 336 -> One (r284) - | 279 | 1127 -> One (r285) - | 280 -> One (r287) - | 278 -> One (r288) - | 277 -> One (r289) - | 270 -> One (r290) - | 276 -> One (r292) - | 273 -> One (r294) - | 272 -> One (r295) - | 275 -> One (r296) - | 274 -> One (r297) - | 322 -> One (r298) - | 321 -> One (r299) - | 318 -> One (r300) - | 317 -> One (r301) - | 316 -> One (r304) - | 297 -> One (r306) - | 295 -> One (r307) - | 294 -> One (r308) - | 304 -> One (r309) - | 306 -> One (r310) - | 310 -> One (r311) - | 315 -> One (r312) - | 314 -> One (r313) - | 324 -> One (r314) - | 333 -> One (r315) - | 332 -> One (r317) - | 329 -> One (r318) - | 328 -> One (r319) - | 331 -> One (r320) - | 341 -> One (r321) - | 340 -> One (r322) - | 339 -> One (r323) - | 350 -> One (r324) - | 348 -> One (r326) - | 347 -> One (r327) - | 429 -> One (r328) - | 365 | 748 -> One (r330) - | 366 -> One (r332) - | 356 -> One (r333) - | 355 -> One (r334) - | 357 -> One (r335) - | 359 -> One (r336) - | 371 -> One (r338) - | 370 -> One (r340) - | 422 -> One (r341) - | 421 -> One (r342) - | 374 -> One (r343) - | 376 -> One (r344) - | 416 -> One (r345) - | 379 -> One (r346) - | 378 -> One (r347) - | 384 -> One (r348) - | 386 -> One (r349) - | 389 -> One (r350) - | 415 -> One (r351) - | 394 -> One (r352) - | 398 -> One (r354) - | 397 -> One (r355) - | 396 -> One (r356) - | 400 -> One (r357) - | 403 -> One (r358) - | 402 -> One (r359) - | 407 -> One (r360) - | 410 -> One (r361) - | 409 -> One (r362) - | 412 -> One (r363) - | 414 -> One (r364) - | 418 -> One (r365) - | 417 -> One (r366) - | 420 -> One (r367) - | 434 -> One (r368) - | 438 -> One (r369) - | 447 -> One (r370) - | 442 -> One (r371) - | 446 -> One (r373) - | 445 -> One (r374) - | 444 -> One (r375) - | 1605 -> One (r376) - | 1604 -> One (r377) - | 1603 -> One (r378) - | 450 -> One (r379) - | 1602 -> One (r380) - | 453 -> One (r381) - | 1497 -> One (r383) - | 1494 -> One (r385) - | 1493 -> One (r386) - | 1492 -> One (r387) - | 455 -> One (r388) - | 464 -> One (r390) - | 462 -> One (r391) - | 461 -> One (r392) - | 460 -> One (r393) - | 459 -> One (r394) - | 468 -> One (r395) - | 467 -> One (r396) - | 470 -> One (r397) - | 1600 -> One (r398) - | 471 -> One (r399) - | 1372 -> One (r400) - | 1371 -> One (r401) - | 1370 -> One (r402) - | 1369 -> One (r403) - | 1368 -> One (r404) - | 1367 -> One (r405) - | 1584 -> One (r406) - | 1583 -> One (r407) - | 1582 -> One (r408) - | 1581 -> One (r409) - | 1580 -> One (r410) - | 473 -> One (r411) - | 1579 -> One (r412) - | 559 -> One (r413) - | 558 -> One (r414) - | 476 -> One (r415) - | 475 -> One (r416) - | 546 -> One (r417) - | 544 -> One (r418) - | 543 -> One (r419) - | 478 -> One (r420) - | 480 -> One (r421) - | 542 -> One (r422) - | 541 -> One (r423) - | 482 -> One (r424) - | 540 -> One (r425) - | 539 -> One (r426) - | 538 -> One (r427) - | 485 -> One (r428) - | 493 -> One (r429) - | 491 -> One (r430) - | 490 -> One (r431) - | 487 -> One (r432) - | 521 -> One (r433) - | 520 -> One (r435) - | 514 -> One (r437) - | 513 -> One (r438) - | 512 -> One (r439) - | 511 -> One (r440) - | 510 -> One (r441) - | 533 -> One (r443) - | 534 -> One (r445) - | 501 -> One (r446) - | 500 -> One (r447) - | 497 -> One (r448) - | 496 -> One (r449) - | 504 -> One (r450) - | 503 -> One (r451) - | 508 -> One (r452) - | 507 -> One (r453) - | 506 -> One (r454) - | 519 -> One (r455) - | 524 -> One (r457) - | 526 -> One (r458) - | 529 -> One (r459) - | 528 -> One (r460) - | 530 | 1835 -> One (r461) - | 532 -> One (r462) - | 536 -> One (r463) - | 548 -> One (r464) - | 553 -> One (r465) - | 552 -> One (r466) - | 1416 -> One (r467) - | 1578 -> One (r469) - | 1577 -> One (r470) - | 1574 -> One (r471) - | 1571 -> One (r472) - | 562 -> One (r473) - | 1570 -> One (r474) - | 1518 -> One (r475) - | 1517 -> One (r476) - | 1516 -> One (r477) - | 1521 -> One (r479) - | 1569 -> One (r481) - | 1568 -> One (r482) - | 1567 -> One (r483) - | 1566 -> One (r484) - | 1565 -> One (r485) - | 1564 -> One (r486) - | 570 -> One (r487) - | 569 -> One (r488) - | 1561 -> One (r489) - | 573 -> One (r490) - | 572 -> One (r491) - | 1558 -> One (r492) - | 1557 -> One (r493) - | 1556 -> One (r494) - | 576 -> One (r495) - | 575 -> One (r496) - | 1555 -> One (r497) - | 579 -> One (r498) - | 578 -> One (r499) - | 1554 -> One (r500) - | 1550 -> One (r501) - | 1549 -> One (r502) - | 1548 -> One (r503) - | 586 -> One (r504) - | 588 -> One (r506) - | 1243 -> One (r508) - | 587 -> One (r510) - | 1241 -> One (r512) - | 1547 -> One (r514) - | 594 -> One (r515) - | 593 -> One (r516) - | 590 -> One (r517) - | 585 -> One (r518) - | 584 -> One (r519) - | 592 -> One (r520) - | 598 -> One (r521) - | 597 -> One (r522) - | 596 -> One (r523) - | 600 -> One (r524) - | 1539 -> One (r525) - | 1538 -> One (r526) - | 1537 -> One (r527) - | 1536 -> One (r528) - | 606 -> One (r529) + | 0 | 1907 | 1911 | 1929 | 1933 | 1937 | 1941 | 1945 | 1949 | 1953 | 1957 | 1961 | 1965 | 1971 | 1991 -> Nothing + | 1906 -> One ([R 0]) + | 1910 -> One ([R 1]) + | 1916 -> One ([R 2]) + | 1930 -> One ([R 3]) + | 1934 -> One ([R 4]) + | 1940 -> One ([R 5]) + | 1942 -> One ([R 6]) + | 1946 -> One ([R 7]) + | 1950 -> One ([R 8]) + | 1954 -> One ([R 9]) + | 1958 -> One ([R 10]) + | 1964 -> One ([R 11]) + | 1968 -> One ([R 12]) + | 1981 -> One ([R 13]) + | 2001 -> One ([R 14]) + | 218 -> One ([R 15]) + | 217 -> One ([R 16]) + | 1924 -> One ([R 20]) + | 1926 -> One ([R 21]) + | 298 -> One ([R 22]) + | 281 -> One ([R 23]) + | 304 -> One ([R 24]) + | 1693 -> One ([R 36]) + | 1697 -> One ([R 41]) + | 1694 -> One ([R 42]) + | 1733 -> One ([R 51]) + | 1700 -> One ([R 56]) + | 1464 -> One ([R 68]) + | 1444 -> One ([R 69]) + | 1446 -> One ([R 73]) + | 1695 -> One ([R 77]) + | 359 -> One ([R 88]) + | 185 -> One ([R 89]) + | 357 -> One ([R 90]) + | 158 -> One ([R 94]) + | 157 | 1150 -> One ([R 95]) + | 1321 -> One ([R 98]) + | 1546 -> One ([R 106]) + | 1550 -> One ([R 107]) + | 308 -> One ([R 109]) + | 286 -> One ([R 110]) + | 295 -> One ([R 111]) + | 297 -> One ([R 112]) + | 1063 -> One ([R 122]) + | 1 -> One (R 124 :: r9) + | 61 -> One (R 124 :: r42) + | 182 -> One (R 124 :: r179) + | 187 -> One (R 124 :: r186) + | 200 -> One (R 124 :: r199) + | 219 -> One (R 124 :: r213) + | 220 -> One (R 124 :: r217) + | 226 -> One (R 124 :: r229) + | 241 -> One (R 124 :: r239) + | 351 -> One (R 124 :: r334) + | 374 -> One (R 124 :: r347) + | 451 -> One (R 124 :: r399) + | 545 -> One (R 124 :: r471) + | 548 -> One (R 124 :: r474) + | 551 -> One (R 124 :: r479) + | 554 -> One (R 124 :: r482) + | 560 -> One (R 124 :: r502) + | 589 -> One (R 124 :: r516) + | 594 -> One (R 124 :: r520) + | 601 -> One (R 124 :: r533) + | 617 -> One (R 124 :: r544) + | 631 -> One (R 124 :: r550) + | 639 -> One (R 124 :: r558) + | 645 -> One (R 124 :: r562) + | 674 -> One (R 124 :: r582) + | 690 -> One (R 124 :: r588) + | 696 -> One (R 124 :: r592) + | 705 -> One (R 124 :: r596) + | 716 -> One (R 124 :: r602) + | 722 -> One (R 124 :: r606) + | 728 -> One (R 124 :: r610) + | 734 -> One (R 124 :: r614) + | 740 -> One (R 124 :: r618) + | 746 -> One (R 124 :: r622) + | 752 -> One (R 124 :: r626) + | 758 -> One (R 124 :: r630) + | 764 -> One (R 124 :: r634) + | 770 -> One (R 124 :: r638) + | 776 -> One (R 124 :: r642) + | 782 -> One (R 124 :: r646) + | 788 -> One (R 124 :: r650) + | 794 -> One (R 124 :: r654) + | 800 -> One (R 124 :: r658) + | 806 -> One (R 124 :: r662) + | 812 -> One (R 124 :: r666) + | 818 -> One (R 124 :: r670) + | 824 -> One (R 124 :: r674) + | 830 -> One (R 124 :: r678) + | 921 -> One (R 124 :: r730) + | 930 -> One (R 124 :: r737) + | 939 -> One (R 124 :: r744) + | 949 -> One (R 124 :: r748) + | 958 -> One (R 124 :: r752) + | 967 -> One (R 124 :: r756) + | 978 -> One (R 124 :: r760) + | 987 -> One (R 124 :: r764) + | 996 -> One (R 124 :: r768) + | 1003 -> One (R 124 :: r772) + | 1082 -> One (R 124 :: r790) + | 1087 -> One (R 124 :: r794) + | 1094 -> One (R 124 :: r798) + | 1103 -> One (R 124 :: r803) + | 1113 -> One (R 124 :: r806) + | 1132 -> One (R 124 :: r816) + | 1147 -> One (R 124 :: r827) + | 1207 -> One (R 124 :: r860) + | 1216 -> One (R 124 :: r865) + | 1231 -> One (R 124 :: r872) + | 1262 -> One (R 124 :: r889) + | 1295 -> One (R 124 :: r917) + | 1300 -> One (R 124 :: r927) + | 1332 -> One (R 124 :: r951) + | 1333 -> One (R 124 :: r955) + | 1342 -> One (R 124 :: r963) + | 1379 -> One (R 124 :: r991) + | 1388 -> One (R 124 :: r1005) + | 1389 -> One (R 124 :: r1014) + | 1583 -> One (R 124 :: r1131) + | 296 -> One ([R 130]) + | 649 -> One ([R 136]) + | 1009 -> One ([R 154]) + | 672 -> One ([R 155]) + | 703 -> One ([R 156]) + | 679 -> One ([R 157]) + | 701 -> One ([R 228]) + | 710 -> One ([R 233]) + | 714 -> One ([R 234]) + | 465 -> One ([R 242]) + | 114 -> One ([R 255]) + | 91 -> One (R 258 :: r53) + | 95 -> One (R 258 :: r55) + | 216 -> One ([R 262]) + | 1172 -> One ([R 266]) + | 1173 -> One ([R 267]) + | 1008 -> One ([R 271]) + | 886 -> One ([R 285]) + | 857 -> One ([R 287]) + | 891 -> One ([R 294]) + | 1698 -> One ([R 297]) + | 566 -> One ([R 298]) + | 1206 -> One ([R 300]) + | 128 -> One (R 316 :: r74) + | 213 -> One (R 316 :: r208) + | 224 -> One (R 316 :: r222) + | 237 -> One (R 316 :: r234) + | 454 -> One (R 316 :: r403) + | 463 -> One (R 316 :: r415) + | 835 -> One (R 316 :: r681) + | 1277 -> One (R 316 :: r905) + | 1361 -> One (R 316 :: r982) + | 1400 -> One (R 316 :: r1020) + | 1406 -> One (R 316 :: r1028) + | 1417 -> One (R 316 :: r1034) + | 1428 -> One (R 316 :: r1037) + | 1432 -> One (R 316 :: r1046) + | 1453 -> One (R 316 :: r1060) + | 1469 -> One (R 316 :: r1070) + | 1504 -> One (R 316 :: r1087) + | 1526 -> One (R 316 :: r1097) + | 1536 -> One (R 316 :: r1106) + | 1590 -> One (R 316 :: r1135) + | 1594 -> One (R 316 :: r1148) + | 1622 -> One (R 316 :: r1167) + | 1662 -> One (R 316 :: r1189) + | 1666 -> One (R 316 :: r1193) + | 1667 -> One (R 316 :: r1197) + | 1678 -> One (R 316 :: r1213) + | 1686 -> One (R 316 :: r1222) + | 1725 -> One (R 316 :: r1233) + | 1745 -> One (R 316 :: r1246) + | 1838 -> One (R 316 :: r1260) + | 1525 -> One (R 318 :: r1090) + | 1766 -> One (R 318 :: r1249) + | 1535 -> One (R 320 :: r1098) + | 888 -> One (R 322 :: r709) + | 1462 -> One (R 322 :: r1061) + | 1523 -> One (R 322 :: r1089) + | 1731 -> One (R 322 :: r1234) + | 1764 -> One (R 322 :: r1248) + | 1771 -> One (R 322 :: r1251) + | 1781 -> One (R 322 :: r1253) + | 1986 -> One (R 322 :: r1297) + | 1997 -> One (R 322 :: r1303) + | 2002 -> One (R 322 :: r1306) + | 1331 -> One (R 324 :: r947) + | 1515 -> One (R 324 :: r1088) + | 215 -> One (R 327 :: r209) + | 1755 -> One (R 327 :: r1247) + | 1465 -> One (R 331 :: r1062) + | 1734 -> One (R 333 :: r1235) + | 1984 -> One (R 335 :: r1295) + | 1992 -> One (R 337 :: r1299) + | 1993 -> One (R 337 :: r1300) + | 1994 -> One (R 337 :: r1301) + | 428 -> One ([R 343]) + | 432 -> One ([R 345]) + | 1076 -> One ([R 348]) + | 1841 -> One ([R 349]) + | 1844 -> One ([R 350]) + | 1843 -> One ([R 352]) + | 1842 -> One ([R 354]) + | 1840 -> One ([R 355]) + | 1925 -> One ([R 367]) + | 1915 -> One ([R 369]) + | 1923 -> One ([R 370]) + | 1922 -> One ([R 372]) + | 608 -> One ([R 379]) + | 1061 -> One ([R 380]) + | 522 -> One ([R 391]) + | 532 -> One ([R 392]) + | 533 -> One ([R 393]) + | 531 -> One ([R 394]) + | 534 -> One ([R 396]) + | 212 -> One ([R 397]) + | 204 | 1352 -> One ([R 398]) + | 492 -> One ([R 405]) + | 469 -> One ([R 406]) + | 499 -> One ([R 410]) + | 1158 | 1608 -> One ([R 415]) + | 1410 -> One ([R 417]) + | 1408 -> One ([R 418]) + | 1411 -> One ([R 419]) + | 1409 -> One ([R 420]) + | 392 -> One ([R 423]) + | 1311 -> One ([R 425]) + | 1559 -> One ([R 426]) + | 1865 -> One ([R 427]) + | 1575 -> One ([R 428]) + | 1866 -> One ([R 429]) + | 1574 -> One ([R 430]) + | 1566 -> One ([R 431]) + | 66 | 245 -> One ([R 446]) + | 74 | 626 -> One ([R 447]) + | 102 -> One ([R 448]) + | 90 -> One ([R 450]) + | 94 -> One ([R 452]) + | 98 -> One ([R 454]) + | 81 -> One ([R 455]) + | 101 | 1032 -> One ([R 456]) + | 80 -> One ([R 457]) + | 79 -> One ([R 458]) + | 78 -> One ([R 459]) + | 77 -> One ([R 460]) + | 76 -> One ([R 461]) + | 69 | 199 | 616 -> One ([R 462]) + | 68 | 615 -> One ([R 463]) + | 67 -> One ([R 464]) + | 73 | 398 | 625 -> One ([R 465]) + | 72 | 624 -> One ([R 466]) + | 65 -> One ([R 467]) + | 70 -> One ([R 468]) + | 83 -> One ([R 469]) + | 75 -> One ([R 470]) + | 82 -> One ([R 471]) + | 71 -> One ([R 472]) + | 100 -> One ([R 473]) + | 103 -> One ([R 474]) + | 99 -> One ([R 476]) + | 324 -> One ([R 477]) + | 323 -> One (R 478 :: r319) + | 259 -> One (R 479 :: r272) + | 260 -> One ([R 480]) + | 429 -> One (R 481 :: r368) + | 430 -> One ([R 482]) + | 858 -> One (R 498 :: r698) + | 859 -> One ([R 499]) + | 120 -> One ([R 500]) + | 384 -> One ([R 524]) + | 378 -> One ([R 525]) + | 379 -> One ([R 527]) + | 377 | 627 -> One ([R 534]) + | 881 -> One ([R 540]) + | 882 -> One ([R 541]) + | 883 -> One ([R 543]) + | 572 -> One ([R 545]) + | 1582 -> One ([R 549]) + | 1624 | 1643 -> One ([R 559]) + | 1421 -> One ([R 561]) + | 1419 -> One ([R 562]) + | 1422 -> One ([R 563]) + | 1420 -> One ([R 564]) + | 1707 -> One (R 565 :: r1227) + | 1198 -> One ([R 566]) + | 1557 -> One ([R 569]) + | 1558 -> One ([R 570]) + | 1552 -> One ([R 571]) + | 1818 -> One ([R 573]) + | 1817 -> One ([R 574]) + | 1819 -> One ([R 575]) + | 1814 -> One ([R 576]) + | 1815 -> One ([R 577]) + | 1879 -> One ([R 579]) + | 1877 -> One ([R 580]) + | 583 -> One ([R 584]) + | 514 -> One ([R 585]) + | 466 -> One ([R 586]) + | 1011 -> One ([R 587]) + | 1010 -> One ([R 588]) + | 346 -> One ([R 590]) + | 316 -> One ([R 618]) + | 905 -> One ([R 621]) + | 643 -> One ([R 623]) + | 906 -> One ([R 624]) + | 1013 -> One ([R 625]) + | 1119 -> One ([R 627]) + | 1120 -> One ([R 628]) + | 423 -> One ([R 630]) + | 424 -> One ([R 631]) + | 1053 -> One ([R 633]) + | 1054 -> One ([R 634]) + | 1577 -> One ([R 640]) + | 1514 -> One ([R 641]) + | 1517 -> One ([R 642]) + | 1516 -> One ([R 647]) + | 1521 -> One ([R 650]) + | 1520 -> One ([R 652]) + | 1519 -> One ([R 653]) + | 1518 -> One ([R 654]) + | 1578 -> One ([R 657]) + | 197 -> One ([R 660]) + | 194 -> One ([R 662]) + | 607 -> One ([R 687]) + | 683 -> One ([R 688]) + | 682 | 702 -> One ([R 689]) + | 610 | 678 -> One ([R 690]) + | 913 | 1001 -> One ([R 695]) + | 681 -> One ([R 700]) + | 360 -> One ([R 713]) + | 364 -> One ([R 716]) + | 365 -> One ([R 720]) + | 396 -> One ([R 722]) + | 369 -> One ([R 723]) + | 425 -> One ([R 725]) + | 387 -> One ([R 730]) + | 28 -> One ([R 731]) + | 8 -> One ([R 732]) + | 52 -> One ([R 734]) + | 51 -> One ([R 735]) + | 50 -> One ([R 736]) + | 49 -> One ([R 737]) + | 48 -> One ([R 738]) + | 47 -> One ([R 739]) + | 46 -> One ([R 740]) + | 45 -> One ([R 741]) + | 44 -> One ([R 742]) + | 43 -> One ([R 743]) + | 42 -> One ([R 744]) + | 41 -> One ([R 745]) + | 40 -> One ([R 746]) + | 39 -> One ([R 747]) + | 38 -> One ([R 748]) + | 37 -> One ([R 749]) + | 36 -> One ([R 750]) + | 35 -> One ([R 751]) + | 34 -> One ([R 752]) + | 33 -> One ([R 753]) + | 32 -> One ([R 754]) + | 31 -> One ([R 755]) + | 30 -> One ([R 756]) + | 29 -> One ([R 757]) + | 27 -> One ([R 758]) + | 26 -> One ([R 759]) + | 25 -> One ([R 760]) + | 24 -> One ([R 761]) + | 23 -> One ([R 762]) + | 22 -> One ([R 763]) + | 21 -> One ([R 764]) + | 20 -> One ([R 765]) + | 19 -> One ([R 766]) + | 18 -> One ([R 767]) + | 17 -> One ([R 768]) + | 16 -> One ([R 769]) + | 15 -> One ([R 770]) + | 14 -> One ([R 771]) + | 13 -> One ([R 772]) + | 12 -> One ([R 773]) + | 11 -> One ([R 774]) + | 10 -> One ([R 775]) + | 9 -> One ([R 776]) + | 7 -> One ([R 777]) + | 6 -> One ([R 778]) + | 5 -> One ([R 779]) + | 4 -> One ([R 780]) + | 3 -> One ([R 781]) + | 1758 -> One ([R 782]) + | 1775 -> One ([R 786]) + | 1763 | 1776 -> One ([R 788]) + | 1768 -> One ([R 790]) + | 1759 -> One ([R 791]) + | 1754 -> One ([R 792]) + | 1757 -> One ([R 796]) + | 1761 -> One ([R 799]) + | 1760 -> One ([R 800]) + | 1769 -> One ([R 802]) + | 240 -> One ([R 804]) + | 239 -> One ([R 805]) + | 1975 -> One ([R 809]) + | 1976 -> One ([R 810]) + | 1978 -> One ([R 811]) + | 1979 -> One ([R 812]) + | 1977 -> One ([R 813]) + | 1974 -> One ([R 814]) + | 1980 -> One ([R 818]) + | 284 -> One ([R 820]) + | 472 -> One (R 828 :: r432) + | 486 -> One ([R 829]) + | 134 -> One ([R 834]) + | 137 -> One ([R 835]) + | 141 -> One ([R 836]) + | 135 -> One ([R 837]) + | 142 -> One ([R 838]) + | 138 -> One ([R 839]) + | 143 -> One ([R 840]) + | 140 -> One ([R 841]) + | 133 -> One ([R 842]) + | 361 -> One ([R 847]) + | 680 -> One ([R 848]) + | 1392 -> One ([R 856]) + | 1606 -> One ([R 857]) + | 1609 -> One ([R 858]) + | 1607 -> One ([R 859]) + | 1641 -> One ([R 860]) + | 1644 -> One ([R 861]) + | 1642 -> One ([R 862]) + | 475 -> One ([R 869]) + | 476 -> One ([R 870]) + | 1047 -> One (S (T T_WITH) :: r787) + | 208 -> One (S (T T_TYPE) :: r205) + | 1175 -> One (S (T T_STAR) :: r850) + | 1982 -> One (S (T T_SEMISEMI) :: r1294) + | 1989 -> One (S (T T_SEMISEMI) :: r1298) + | 1912 -> One (S (T T_RPAREN) :: r134) + | 306 | 1858 -> One (S (T T_RPAREN) :: r311) + | 372 -> One (S (T T_RPAREN) :: r344) + | 416 -> One (S (T T_RPAREN) :: r367) + | 456 -> One (S (T T_RPAREN) :: r404) + | 524 -> One (S (T T_RPAREN) :: r447) + | 1033 -> One (S (T T_RPAREN) :: r776) + | 1226 -> One (S (T T_RPAREN) :: r868) + | 1851 -> One (S (T T_RPAREN) :: r1263) + | 1913 -> One (S (T T_RPAREN) :: r1277) + | 1154 | 1541 -> One (S (T T_RBRACKET) :: r252) + | 1039 -> One (S (T T_RBRACKET) :: r779) + | 1041 -> One (S (T T_RBRACKET) :: r780) + | 310 -> One (S (T T_QUOTE) :: r313) + | 1430 -> One (S (T T_OPEN) :: r1042) + | 1670 -> One (S (T T_OPEN) :: r1204) + | 121 | 289 -> One (S (T T_MODULE) :: r69) + | 461 -> One (S (T T_MINUSGREATER) :: r411) + | 1183 -> One (S (T T_MINUSGREATER) :: r855) + | 1187 -> One (S (T T_MINUSGREATER) :: r857) + | 1491 -> One (S (T T_MINUSGREATER) :: r1076) + | 84 -> One (S (T T_LPAREN) :: r50) + | 117 -> One (S (T T_LIDENT) :: r64) + | 437 -> One (S (T T_LIDENT) :: r370) + | 445 -> One (S (T T_LIDENT) :: r376) + | 650 -> One (S (T T_LIDENT) :: r563) + | 651 -> One (S (T T_LIDENT) :: r569) + | 662 -> One (S (T T_LIDENT) :: r572) + | 666 -> One (S (T T_LIDENT) :: r574) + | 1159 -> One (S (T T_LIDENT) :: r846) + | 1610 -> One (S (T T_LIDENT) :: r1153) + | 1645 -> One (S (T T_LIDENT) :: r1178) + | 1717 -> One (S (T T_LIDENT) :: r1230) + | 192 -> One (S (T T_INT) :: r190) + | 195 -> One (S (T T_INT) :: r191) + | 684 -> One (S (T T_IN) :: r584) + | 1690 -> One (S (T T_IN) :: r1224) + | 538 -> One (S (T T_GREATERRBRACE) :: r454) + | 1122 -> One (S (T T_GREATERRBRACE) :: r807) + | 165 -> One (S (T T_GREATER) :: r139) + | 1846 -> One (S (T T_GREATER) :: r1261) + | 504 -> One (S (T T_EQUAL) :: r443) + | 854 -> One (S (T T_EQUAL) :: r695) + | 870 -> One (S (T T_EQUAL) :: r703) + | 1023 -> One (S (T T_EQUAL) :: r774) + | 1600 -> One (S (T T_EQUAL) :: r1150) + | 1618 -> One (S (T T_EQUAL) :: r1155) + | 1904 -> One (S (T T_EOF) :: r1275) + | 1908 -> One (S (T T_EOF) :: r1276) + | 1927 -> One (S (T T_EOF) :: r1282) + | 1931 -> One (S (T T_EOF) :: r1283) + | 1935 -> One (S (T T_EOF) :: r1284) + | 1938 -> One (S (T T_EOF) :: r1285) + | 1943 -> One (S (T T_EOF) :: r1286) + | 1947 -> One (S (T T_EOF) :: r1287) + | 1951 -> One (S (T T_EOF) :: r1288) + | 1955 -> One (S (T T_EOF) :: r1289) + | 1959 -> One (S (T T_EOF) :: r1290) + | 1962 -> One (S (T T_EOF) :: r1291) + | 1966 -> One (S (T T_EOF) :: r1292) + | 2006 -> One (S (T T_EOF) :: r1307) + | 1100 -> One (S (T T_END) :: r799) + | 86 -> One (S (T T_DOTDOT) :: r51) + | 159 -> One (S (T T_DOTDOT) :: r131) + | 1560 -> One (S (T T_DOTDOT) :: r1113) + | 1561 -> One (S (T T_DOTDOT) :: r1114) + | 230 | 899 | 972 -> One (S (T T_DOT) :: r231) + | 1969 -> One (S (T T_DOT) :: r444) + | 847 -> One (S (T T_DOT) :: r692) + | 1162 -> One (S (T T_DOT) :: r848) + | 1181 -> One (S (T T_DOT) :: r853) + | 1305 -> One (S (T T_DOT) :: r929) + | 1917 -> One (S (T T_DOT) :: r1281) + | 160 | 1151 -> One (S (T T_COLONCOLON) :: r133) + | 166 -> One (S (T T_COLON) :: r144) + | 458 -> One (S (T T_COLON) :: r407) + | 1485 -> One (S (T T_COLON) :: r1074) + | 246 -> One (S (T T_BARRBRACKET) :: r242) + | 250 -> One (S (T T_BARRBRACKET) :: r251) + | 434 -> One (S (T T_BARRBRACKET) :: r369) + | 1035 -> One (S (T T_BARRBRACKET) :: r777) + | 1037 -> One (S (T T_BARRBRACKET) :: r778) + | 1213 -> One (S (T T_BARRBRACKET) :: r861) + | 335 -> One (S (T T_BAR) :: r323) + | 190 -> One (S (N N_pattern) :: r188) + | 389 | 574 -> One (S (N N_pattern) :: r193) + | 350 -> One (S (N N_pattern) :: r328) + | 380 -> One (S (N N_pattern) :: r348) + | 382 -> One (S (N N_pattern) :: r349) + | 403 -> One (S (N N_pattern) :: r360) + | 408 -> One (S (N N_pattern) :: r363) + | 873 -> One (S (N N_pattern) :: r704) + | 875 -> One (S (N N_pattern) :: r705) + | 877 -> One (S (N N_pattern) :: r706) + | 884 -> One (S (N N_pattern) :: r708) + | 1289 -> One (S (N N_pattern) :: r909) + | 207 -> One (S (N N_module_type) :: r201) + | 460 -> One (S (N N_module_type) :: r409) + | 500 -> One (S (N N_module_type) :: r440) + | 502 -> One (S (N N_module_type) :: r441) + | 528 -> One (S (N N_module_type) :: r449) + | 1138 -> One (S (N N_module_type) :: r819) + | 1221 -> One (S (N N_module_type) :: r867) + | 1236 -> One (S (N N_module_type) :: r874) + | 1239 -> One (S (N N_module_type) :: r876) + | 1242 -> One (S (N N_module_type) :: r878) + | 1247 -> One (S (N N_module_type) :: r880) + | 1250 -> One (S (N N_module_type) :: r882) + | 1253 -> One (S (N N_module_type) :: r884) + | 1267 -> One (S (N N_module_type) :: r896) + | 223 -> One (S (N N_module_expr) :: r219) + | 565 -> One (S (N N_let_pattern) :: r508) + | 248 -> One (S (N N_fun_expr) :: r243) + | 540 -> One (S (N N_fun_expr) :: r457) + | 544 -> One (S (N N_fun_expr) :: r468) + | 593 -> One (S (N N_fun_expr) :: r517) + | 644 -> One (S (N N_fun_expr) :: r559) + | 673 -> One (S (N N_fun_expr) :: r579) + | 689 -> One (S (N N_fun_expr) :: r585) + | 695 -> One (S (N N_fun_expr) :: r589) + | 704 -> One (S (N N_fun_expr) :: r593) + | 715 -> One (S (N N_fun_expr) :: r599) + | 721 -> One (S (N N_fun_expr) :: r603) + | 727 -> One (S (N N_fun_expr) :: r607) + | 733 -> One (S (N N_fun_expr) :: r611) + | 739 -> One (S (N N_fun_expr) :: r615) + | 745 -> One (S (N N_fun_expr) :: r619) + | 751 -> One (S (N N_fun_expr) :: r623) + | 757 -> One (S (N N_fun_expr) :: r627) + | 763 -> One (S (N N_fun_expr) :: r631) + | 769 -> One (S (N N_fun_expr) :: r635) + | 775 -> One (S (N N_fun_expr) :: r639) + | 781 -> One (S (N N_fun_expr) :: r643) + | 787 -> One (S (N N_fun_expr) :: r647) + | 793 -> One (S (N N_fun_expr) :: r651) + | 799 -> One (S (N N_fun_expr) :: r655) + | 805 -> One (S (N N_fun_expr) :: r659) + | 811 -> One (S (N N_fun_expr) :: r663) + | 817 -> One (S (N N_fun_expr) :: r667) + | 823 -> One (S (N N_fun_expr) :: r671) + | 829 -> One (S (N N_fun_expr) :: r675) + | 920 -> One (S (N N_fun_expr) :: r727) + | 929 -> One (S (N N_fun_expr) :: r734) + | 938 -> One (S (N N_fun_expr) :: r741) + | 948 -> One (S (N N_fun_expr) :: r745) + | 957 -> One (S (N N_fun_expr) :: r749) + | 966 -> One (S (N N_fun_expr) :: r753) + | 977 -> One (S (N N_fun_expr) :: r757) + | 986 -> One (S (N N_fun_expr) :: r761) + | 995 -> One (S (N N_fun_expr) :: r765) + | 1002 -> One (S (N N_fun_expr) :: r769) + | 1086 -> One (S (N N_fun_expr) :: r791) + | 1093 -> One (S (N N_fun_expr) :: r795) + | 448 -> One (Sub (r3) :: r380) + | 559 -> One (Sub (r3) :: r486) + | 1291 -> One (Sub (r3) :: r910) + | 2 -> One (Sub (r13) :: r14) + | 55 -> One (Sub (r13) :: r15) + | 59 -> One (Sub (r13) :: r22) + | 168 -> One (Sub (r13) :: r147) + | 180 -> One (Sub (r13) :: r168) + | 711 -> One (Sub (r13) :: r598) + | 1287 -> One (Sub (r13) :: r908) + | 1293 -> One (Sub (r13) :: r913) + | 1671 -> One (Sub (r13) :: r1209) + | 410 -> One (Sub (r24) :: r364) + | 879 -> One (Sub (r24) :: r707) + | 285 -> One (Sub (r26) :: r301) + | 300 -> One (Sub (r26) :: r309) + | 585 -> One (Sub (r26) :: r513) + | 1180 -> One (Sub (r26) :: r851) + | 290 -> One (Sub (r28) :: r308) + | 1493 -> One (Sub (r28) :: r1079) + | 283 -> One (Sub (r30) :: r300) + | 327 -> One (Sub (r32) :: r320) + | 479 -> One (Sub (r32) :: r434) + | 258 -> One (Sub (r34) :: r265) + | 405 -> One (Sub (r34) :: r362) + | 440 -> One (Sub (r34) :: r375) + | 482 -> One (Sub (r34) :: r437) + | 567 -> One (Sub (r34) :: r509) + | 628 -> One (Sub (r34) :: r547) + | 653 -> One (Sub (r34) :: r570) + | 657 -> One (Sub (r34) :: r571) + | 866 -> One (Sub (r34) :: r701) + | 1402 -> One (Sub (r34) :: r1022) + | 1440 -> One (Sub (r34) :: r1053) + | 1792 -> One (Sub (r34) :: r1255) + | 1856 -> One (Sub (r34) :: r1265) + | 1859 -> One (Sub (r34) :: r1266) + | 1627 -> One (Sub (r36) :: r1170) + | 1651 -> One (Sub (r36) :: r1181) + | 146 -> One (Sub (r59) :: r126) + | 848 -> One (Sub (r59) :: r693) + | 1972 -> One (Sub (r59) :: r1293) + | 1330 -> One (Sub (r71) :: r946) + | 355 -> One (Sub (r86) :: r336) + | 152 -> One (Sub (r121) :: r127) + | 139 -> One (Sub (r123) :: r125) + | 1394 -> One (Sub (r123) :: r1016) + | 156 -> One (Sub (r129) :: r130) + | 1868 -> One (Sub (r129) :: r1271) + | 1882 -> One (Sub (r129) :: r1274) + | 557 -> One (Sub (r172) :: r483) + | 598 -> One (Sub (r172) :: r521) + | 186 -> One (Sub (r180) :: r181) + | 543 -> One (Sub (r180) :: r466) + | 606 -> One (Sub (r180) :: r534) + | 635 -> One (Sub (r180) :: r551) + | 664 -> One (Sub (r180) :: r573) + | 914 -> One (Sub (r180) :: r726) + | 1273 -> One (Sub (r195) :: r900) + | 1356 -> One (Sub (r195) :: r976) + | 1029 -> One (Sub (r245) :: r775) + | 249 -> One (Sub (r247) :: r250) + | 253 -> One (Sub (r262) :: r264) + | 320 -> One (Sub (r267) :: r314) + | 264 -> One (Sub (r269) :: r276) + | 278 -> One (Sub (r269) :: r299) + | 265 -> One (Sub (r282) :: r284) + | 266 -> One (Sub (r286) :: r287) + | 302 -> One (Sub (r286) :: r310) + | 1853 -> One (Sub (r286) :: r1264) + | 268 -> One (Sub (r293) :: r295) + | 508 -> One (Sub (r293) :: r445) + | 1353 -> One (Sub (r293) :: r971) + | 343 -> One (Sub (r325) :: r327) + | 578 -> One (Sub (r331) :: r512) + | 366 -> One (Sub (r339) :: r340) + | 390 -> One (Sub (r353) :: r356) + | 575 -> One (Sub (r353) :: r511) + | 841 -> One (Sub (r353) :: r688) + | 1628 -> One (Sub (r353) :: r1175) + | 1652 -> One (Sub (r353) :: r1186) + | 438 -> One (Sub (r372) :: r374) + | 446 -> One (Sub (r372) :: r379) + | 512 -> One (Sub (r425) :: r446) + | 471 -> One (Sub (r427) :: r428) + | 541 -> One (Sub (r463) :: r465) + | 1046 -> One (Sub (r463) :: r785) + | 563 -> One (Sub (r504) :: r505) + | 1043 -> One (Sub (r781) :: r783) + | 1145 -> One (Sub (r810) :: r820) + | 1156 -> One (Sub (r829) :: r830) + | 1157 -> One (Sub (r838) :: r840) + | 1542 -> One (Sub (r838) :: r1108) + | 1562 -> One (Sub (r838) :: r1116) + | 1570 -> One (Sub (r838) :: r1118) + | 1861 -> One (Sub (r838) :: r1268) + | 1809 -> One (Sub (r930) :: r1257) + | 1821 -> One (Sub (r930) :: r1259) + | 1377 -> One (Sub (r958) :: r987) + | 1370 -> One (Sub (r984) :: r986) + | 1713 -> One (Sub (r996) :: r1229) + | 1737 -> One (Sub (r996) :: r1238) + | 1682 -> One (Sub (r1048) :: r1216) + | 1669 -> One (Sub (r1120) :: r1199) + | 1741 -> One (Sub (r1123) :: r1239) + | 1593 -> One (Sub (r1141) :: r1143) + | 1621 -> One (Sub (r1161) :: r1163) + | 688 -> One (r0) + | 687 -> One (r2) + | 1903 -> One (r4) + | 1902 -> One (r5) + | 1901 -> One (r6) + | 1900 -> One (r7) + | 1899 -> One (r8) + | 58 -> One (r9) + | 53 -> One (r10) + | 54 -> One (r12) + | 57 -> One (r14) + | 56 -> One (r15) + | 1770 -> One (r16) + | 1774 -> One (r18) + | 1898 -> One (r20) + | 1897 -> One (r21) + | 60 -> One (r22) + | 107 | 247 | 542 | 1060 -> One (r23) + | 110 -> One (r25) + | 299 -> One (r27) + | 282 -> One (r29) + | 305 -> One (r31) + | 309 -> One (r33) + | 1314 -> One (r35) + | 1896 -> One (r37) + | 1895 -> One (r38) + | 109 -> One (r39) + | 108 -> One (r40) + | 63 -> One (r41) + | 62 -> One (r42) + | 104 -> One (r43) + | 106 -> One (r45) + | 105 -> One (r46) + | 64 -> One (r47) + | 89 -> One (r48) + | 88 -> One (r49) + | 85 -> One (r50) + | 87 -> One (r51) + | 93 -> One (r52) + | 92 -> One (r53) + | 97 -> One (r54) + | 96 -> One (r55) + | 111 | 127 -> One (r56) + | 112 -> One (r57) + | 115 -> One (r58) + | 123 -> One (r61) + | 122 -> One (r62) + | 119 -> One (r63) + | 118 -> One (r64) + | 1894 -> One (r65) + | 1893 -> One (r66) + | 126 -> One (r67) + | 125 -> One (r68) + | 124 -> One (r69) + | 1581 -> One (r70) + | 1892 -> One (r72) + | 1891 -> One (r73) + | 129 -> One (r74) + | 1828 -> One (r75) + | 1827 -> One (r76) + | 1826 -> One (r77) + | 164 -> One (r83) + | 293 -> One (r85) + | 358 -> One (r87) + | 1195 -> One (r89) + | 1569 -> One (r91) + | 1568 -> One (r92) + | 1567 | 1820 -> One (r93) + | 1878 -> One (r95) + | 1890 -> One (r97) + | 1889 -> One (r98) + | 1888 -> One (r99) + | 1887 -> One (r100) + | 1886 -> One (r101) + | 1803 -> One (r105) + | 179 -> One (r106) + | 178 -> One (r107) + | 1876 -> One (r111) + | 1875 -> One (r112) + | 1874 -> One (r113) + | 1873 -> One (r114) + | 1872 -> One (r115) + | 145 -> One (r117) + | 148 -> One (r119) + | 144 -> One (r120) + | 149 -> One (r122) + | 151 -> One (r124) + | 150 -> One (r125) + | 147 -> One (r126) + | 153 -> One (r127) + | 1545 -> One (r128) + | 1867 -> One (r130) + | 1864 -> One (r131) + | 1153 -> One (r132) + | 1152 -> One (r133) + | 161 -> One (r134) + | 1850 -> One (r135) + | 1849 -> One (r136) + | 1848 -> One (r137) + | 163 -> One (r138) + | 1845 -> One (r139) + | 1169 -> One (r140) + | 1837 -> One (r142) + | 1836 -> One (r143) + | 167 -> One (r144) + | 1835 -> One (r145) + | 1834 -> One (r146) + | 169 -> One (r147) + | 170 -> One (r148) + | 171 -> One (r149) + | 1816 -> One (r150) + | 1833 -> One (r152) + | 1832 -> One (r153) + | 1831 -> One (r154) + | 1830 -> One (r155) + | 1829 -> One (r156) + | 1813 -> One (r160) + | 1812 -> One (r161) + | 1806 -> One (r162) + | 1805 -> One (r163) + | 1804 -> One (r164) + | 1802 -> One (r166) + | 1801 -> One (r167) + | 181 -> One (r168) + | 1077 -> One (r169) + | 1075 -> One (r170) + | 558 -> One (r171) + | 600 -> One (r173) + | 1800 -> One (r175) + | 1799 -> One (r176) + | 1798 -> One (r177) + | 184 -> One (r178) + | 183 -> One (r179) + | 1215 -> One (r181) + | 1797 -> One (r182) + | 1796 -> One (r183) + | 1795 -> One (r184) + | 189 -> One (r185) + | 188 -> One (r186) + | 1791 -> One (r187) + | 1790 -> One (r188) + | 191 -> One (r189) + | 193 -> One (r190) + | 196 -> One (r191) + | 402 -> One (r192) + | 401 -> One (r193) + | 203 -> One (r194) + | 206 -> One (r196) + | 205 -> One (r197) + | 202 -> One (r198) + | 201 -> One (r199) + | 1789 -> One (r200) + | 1788 -> One (r201) + | 1787 -> One (r202) + | 211 -> One (r203) + | 210 -> One (r204) + | 209 -> One (r205) + | 1786 -> One (r206) + | 1785 -> One (r207) + | 214 -> One (r208) + | 1784 -> One (r209) + | 1261 -> One (r210) + | 1260 -> One (r211) + | 1259 -> One (r212) + | 1258 -> One (r213) + | 1257 -> One (r214) + | 1256 -> One (r215) + | 222 -> One (r216) + | 221 -> One (r217) + | 527 -> One (r218) + | 526 -> One (r219) + | 1246 -> One (r220) + | 1245 -> One (r221) + | 225 -> One (r222) + | 229 -> One (r223) + | 235 -> One (r225) + | 236 -> One (r227) + | 228 -> One (r228) + | 227 -> One (r229) + | 233 -> One (r230) + | 231 -> One (r231) + | 232 -> One (r232) + | 234 -> One (r233) + | 238 -> One (r234) + | 1230 -> One (r235) + | 1229 -> One (r236) + | 1228 -> One (r237) + | 243 -> One (r238) + | 242 -> One (r239) + | 1225 -> One (r240) + | 1224 -> One (r241) + | 1212 -> One (r242) + | 1211 -> One (r243) + | 436 -> One (r244) + | 1031 -> One (r246) + | 1028 -> One (r248) + | 1027 -> One (r249) + | 1026 -> One (r250) + | 433 -> One (r251) + | 252 -> One (r252) + | 422 -> One (r253) + | 421 -> One (r255) + | 420 -> One (r256) + | 254 -> One (r257) + | 427 -> One (r259) + | 349 -> One (r260) + | 257 -> One (r261) + | 256 -> One (r263) + | 255 -> One (r264) + | 348 -> One (r265) + | 332 -> One (r266) + | 317 -> One (r268) + | 342 -> One (r270) + | 341 -> One (r271) + | 261 -> One (r272) + | 263 -> One (r273) + | 262 -> One (r274) + | 340 -> One (r275) + | 339 -> One (r276) + | 280 -> One (r277) + | 279 -> One (r278) + | 331 -> One (r280) + | 322 -> One (r281) + | 334 -> One (r283) + | 333 -> One (r284) + | 276 | 1496 -> One (r285) + | 277 -> One (r287) + | 275 -> One (r288) + | 274 -> One (r289) + | 267 -> One (r290) + | 273 -> One (r292) + | 270 -> One (r294) + | 269 -> One (r295) + | 272 -> One (r296) + | 271 -> One (r297) + | 319 -> One (r298) + | 318 -> One (r299) + | 315 -> One (r300) + | 314 -> One (r301) + | 313 -> One (r304) + | 294 -> One (r306) + | 292 -> One (r307) + | 291 -> One (r308) + | 301 -> One (r309) + | 303 -> One (r310) + | 307 -> One (r311) + | 312 -> One (r312) + | 311 -> One (r313) + | 321 -> One (r314) + | 330 -> One (r315) + | 329 -> One (r317) + | 326 -> One (r318) + | 325 -> One (r319) + | 328 -> One (r320) + | 338 -> One (r321) + | 337 -> One (r322) + | 336 -> One (r323) + | 347 -> One (r324) + | 345 -> One (r326) + | 344 -> One (r327) + | 426 -> One (r328) + | 362 | 865 -> One (r330) + | 363 -> One (r332) + | 353 -> One (r333) + | 352 -> One (r334) + | 354 -> One (r335) + | 356 -> One (r336) + | 368 -> One (r338) + | 367 -> One (r340) + | 419 -> One (r341) + | 418 -> One (r342) + | 371 -> One (r343) + | 373 -> One (r344) + | 413 -> One (r345) + | 376 -> One (r346) + | 375 -> One (r347) + | 381 -> One (r348) + | 383 -> One (r349) + | 386 -> One (r350) + | 412 -> One (r351) + | 391 -> One (r352) + | 395 -> One (r354) + | 394 -> One (r355) + | 393 -> One (r356) + | 397 -> One (r357) + | 400 -> One (r358) + | 399 -> One (r359) + | 404 -> One (r360) + | 407 -> One (r361) + | 406 -> One (r362) + | 409 -> One (r363) + | 411 -> One (r364) + | 415 -> One (r365) + | 414 -> One (r366) + | 417 -> One (r367) + | 431 -> One (r368) + | 435 -> One (r369) + | 444 -> One (r370) + | 439 -> One (r371) + | 443 -> One (r373) + | 442 -> One (r374) + | 441 -> One (r375) + | 1205 -> One (r376) + | 1204 -> One (r377) + | 1203 -> One (r378) + | 447 -> One (r379) + | 1202 -> One (r380) + | 1131 -> One (r381) + | 1130 -> One (r382) + | 1129 -> One (r383) + | 1128 -> One (r384) + | 1127 -> One (r385) + | 450 -> One (r386) + | 837 -> One (r387) + | 1201 -> One (r389) + | 1200 -> One (r390) + | 1199 -> One (r391) + | 1197 -> One (r392) + | 1196 -> One (r393) + | 1756 -> One (r394) + | 1126 -> One (r395) + | 536 -> One (r396) + | 535 -> One (r397) + | 453 -> One (r398) + | 452 -> One (r399) + | 523 -> One (r400) + | 521 -> One (r401) + | 520 -> One (r402) + | 455 -> One (r403) + | 457 -> One (r404) + | 519 -> One (r405) + | 518 -> One (r406) + | 459 -> One (r407) + | 517 -> One (r408) + | 516 -> One (r409) + | 515 -> One (r410) + | 462 -> One (r411) + | 470 -> One (r412) + | 468 -> One (r413) + | 467 -> One (r414) + | 464 -> One (r415) + | 498 -> One (r416) + | 497 -> One (r418) + | 491 -> One (r420) + | 490 -> One (r421) + | 489 -> One (r422) + | 488 -> One (r423) + | 487 -> One (r424) + | 510 -> One (r426) + | 511 -> One (r428) + | 478 -> One (r429) + | 477 -> One (r430) + | 474 -> One (r431) + | 473 -> One (r432) + | 481 -> One (r433) + | 480 -> One (r434) + | 485 -> One (r435) + | 484 -> One (r436) + | 483 -> One (r437) + | 496 -> One (r438) + | 501 -> One (r440) + | 503 -> One (r441) + | 506 -> One (r442) + | 505 -> One (r443) + | 507 | 1970 -> One (r444) + | 509 -> One (r445) + | 513 -> One (r446) + | 525 -> One (r447) + | 530 -> One (r448) + | 529 -> One (r449) + | 904 -> One (r450) + | 1125 -> One (r452) + | 1124 -> One (r453) + | 1121 -> One (r454) + | 1118 -> One (r455) + | 539 -> One (r456) + | 1117 -> One (r457) + | 1052 -> One (r458) + | 1051 -> One (r459) + | 1050 -> One (r460) + | 1055 -> One (r462) + | 1112 -> One (r464) + | 1111 -> One (r465) + | 1110 -> One (r466) + | 1109 -> One (r467) + | 1108 -> One (r468) + | 1102 -> One (r469) + | 547 -> One (r470) + | 546 -> One (r471) + | 1099 -> One (r472) + | 550 -> One (r473) + | 549 -> One (r474) + | 1092 -> One (r475) + | 1081 -> One (r476) + | 1080 -> One (r477) + | 553 -> One (r478) + | 552 -> One (r479) + | 1079 -> One (r480) + | 556 -> One (r481) + | 555 -> One (r482) + | 1078 -> One (r483) + | 1074 -> One (r484) + | 1073 -> One (r485) + | 1072 -> One (r486) + | 580 -> One (r487) + | 582 -> One (r489) + | 864 -> One (r491) + | 581 -> One (r493) + | 862 -> One (r495) + | 1071 -> One (r497) + | 588 -> One (r498) + | 587 -> One (r499) + | 584 -> One (r500) + | 562 -> One (r501) + | 561 -> One (r502) + | 564 -> One (r503) + | 573 -> One (r505) + | 571 -> One (r506) + | 570 -> One (r507) + | 569 -> One (r508) + | 568 -> One (r509) + | 577 -> One (r510) + | 576 -> One (r511) + | 579 -> One (r512) + | 586 -> One (r513) + | 592 -> One (r514) + | 591 -> One (r515) + | 590 -> One (r516) + | 1070 -> One (r517) + | 597 -> One (r518) + | 596 -> One (r519) + | 595 -> One (r520) + | 599 -> One (r521) + | 1064 -> One (r522) + | 1069 -> One (r524) + | 1068 -> One (r525) + | 1067 -> One (r526) + | 1066 -> One (r527) + | 1065 -> One (r528) + | 1062 -> One (r529) | 605 -> One (r530) | 604 -> One (r531) | 603 -> One (r532) - | 1530 -> One (r533) - | 1535 -> One (r535) - | 1534 -> One (r536) - | 1533 -> One (r537) - | 1532 -> One (r538) - | 1531 -> One (r539) - | 1528 -> One (r540) - | 611 -> One (r541) - | 610 -> One (r542) - | 609 -> One (r543) - | 608 -> One (r544) - | 615 -> One (r545) - | 620 -> One (r546) - | 619 -> One (r547) - | 618 | 1525 -> One (r548) - | 1524 -> One (r549) - | 629 -> One (r550) - | 628 -> One (r551) - | 627 -> One (r552) - | 626 -> One (r553) - | 625 -> One (r554) - | 624 -> One (r555) - | 1488 -> One (r556) - | 636 -> One (r557) - | 635 -> One (r558) - | 640 -> One (r559) - | 639 -> One (r560) - | 638 -> One (r561) - | 642 -> One (r562) - | 1429 | 1481 -> One (r563) - | 1428 | 1480 -> One (r564) - | 644 | 1427 -> One (r565) - | 643 | 1426 -> One (r566) - | 648 -> One (r567) - | 647 -> One (r568) - | 646 -> One (r569) - | 1479 -> One (r570) - | 662 -> One (r571) - | 657 -> One (r572) - | 656 | 1606 -> One (r573) - | 661 -> One (r575) - | 660 -> One (r576) - | 653 -> One (r577) - | 655 -> One (r578) - | 659 -> One (r579) - | 664 -> One (r580) - | 666 -> One (r581) - | 668 -> One (r582) - | 1425 | 1475 -> One (r583) - | 669 | 1442 -> One (r584) - | 672 | 1445 -> One (r585) - | 671 | 1444 -> One (r586) - | 670 | 1443 -> One (r587) - | 1404 -> One (r588) - | 683 -> One (r589) - | 682 -> One (r590) - | 687 -> One (r591) - | 686 -> One (r592) - | 739 -> One (r593) - | 693 -> One (r594) - | 697 -> One (r595) - | 699 -> One (r596) - | 701 -> One (r597) - | 703 -> One (r598) - | 705 -> One (r599) - | 707 -> One (r600) - | 709 -> One (r601) - | 711 -> One (r602) - | 713 -> One (r603) - | 715 -> One (r604) - | 717 -> One (r605) - | 719 -> One (r606) - | 721 -> One (r607) - | 723 -> One (r608) - | 725 -> One (r609) - | 727 -> One (r610) - | 729 -> One (r611) - | 728 -> One (r612) - | 731 -> One (r613) - | 733 -> One (r614) - | 735 -> One (r615) - | 737 -> One (r616) - | 743 -> One (r617) - | 742 -> One (r618) - | 1403 -> One (r619) - | 770 -> One (r620) - | 747 -> One (r621) - | 752 -> One (r622) - | 751 -> One (r623) - | 750 -> One (r624) - | 755 -> One (r625) - | 754 -> One (r626) - | 757 -> One (r627) - | 759 -> One (r628) - | 761 -> One (r629) - | 763 -> One (r630) + | 602 -> One (r533) + | 609 -> One (r534) + | 614 -> One (r535) + | 613 -> One (r536) + | 612 | 1059 -> One (r537) + | 1058 -> One (r538) + | 623 -> One (r539) + | 622 -> One (r540) + | 621 -> One (r541) + | 620 -> One (r542) + | 619 -> One (r543) + | 618 -> One (r544) + | 1022 -> One (r545) + | 630 -> One (r546) + | 629 -> One (r547) + | 634 -> One (r548) + | 633 -> One (r549) + | 632 -> One (r550) + | 636 -> One (r551) + | 919 | 1015 -> One (r552) + | 918 | 1014 -> One (r553) + | 638 | 917 -> One (r554) + | 637 | 916 -> One (r555) + | 642 -> One (r556) + | 641 -> One (r557) + | 640 -> One (r558) + | 1012 -> One (r559) + | 648 -> One (r560) + | 647 -> One (r561) + | 646 -> One (r562) + | 661 -> One (r563) + | 656 -> One (r564) + | 655 | 840 -> One (r565) + | 660 -> One (r567) + | 659 -> One (r568) + | 652 -> One (r569) + | 654 -> One (r570) + | 658 -> One (r571) + | 663 -> One (r572) + | 665 -> One (r573) + | 667 -> One (r574) + | 671 | 947 -> One (r575) + | 670 | 946 -> One (r576) + | 669 | 945 -> One (r577) + | 668 | 944 -> One (r578) + | 892 -> One (r579) + | 677 -> One (r580) + | 676 -> One (r581) + | 675 -> One (r582) + | 686 -> One (r583) + | 685 -> One (r584) + | 694 -> One (r585) + | 693 -> One (r586) + | 692 -> One (r587) + | 691 -> One (r588) + | 700 -> One (r589) + | 699 -> One (r590) + | 698 -> One (r591) + | 697 -> One (r592) + | 709 -> One (r593) + | 708 -> One (r594) + | 707 -> One (r595) + | 706 -> One (r596) + | 713 -> One (r597) + | 712 -> One (r598) + | 720 -> One (r599) + | 719 -> One (r600) + | 718 -> One (r601) + | 717 -> One (r602) + | 726 -> One (r603) + | 725 -> One (r604) + | 724 -> One (r605) + | 723 -> One (r606) + | 732 -> One (r607) + | 731 -> One (r608) + | 730 -> One (r609) + | 729 -> One (r610) + | 738 -> One (r611) + | 737 -> One (r612) + | 736 -> One (r613) + | 735 -> One (r614) + | 744 -> One (r615) + | 743 -> One (r616) + | 742 -> One (r617) + | 741 -> One (r618) + | 750 -> One (r619) + | 749 -> One (r620) + | 748 -> One (r621) + | 747 -> One (r622) + | 756 -> One (r623) + | 755 -> One (r624) + | 754 -> One (r625) + | 753 -> One (r626) + | 762 -> One (r627) + | 761 -> One (r628) + | 760 -> One (r629) + | 759 -> One (r630) | 768 -> One (r631) - | 1402 -> One (r632) - | 1401 -> One (r633) - | 772 -> One (r634) + | 767 -> One (r632) + | 766 -> One (r633) + | 765 -> One (r634) | 774 -> One (r635) - | 776 -> One (r636) - | 793 -> One (r637) - | 792 -> One (r638) - | 811 -> One (r640) - | 810 -> One (r641) - | 809 -> One (r642) - | 789 -> One (r643) - | 788 -> One (r644) - | 787 -> One (r645) - | 784 -> One (r646) - | 781 -> One (r647) - | 780 -> One (r648) - | 779 -> One (r649) - | 778 -> One (r650) - | 783 -> One (r651) - | 786 -> One (r652) - | 808 -> One (r653) - | 799 -> One (r654) - | 798 -> One (r655) - | 791 -> One (r656) - | 797 -> One (r657) - | 796 -> One (r658) - | 795 -> One (r659) - | 805 -> One (r660) - | 804 -> One (r661) - | 803 -> One (r662) - | 802 -> One (r663) - | 801 -> One (r664) - | 807 -> One (r665) - | 1400 -> One (r666) - | 1399 -> One (r667) - | 813 -> One (r668) - | 1398 -> One (r669) - | 1397 -> One (r670) - | 815 -> One (r671) - | 820 -> One (r672) - | 819 -> One (r673) - | 818 -> One (r674) - | 817 -> One (r675) + | 773 -> One (r636) + | 772 -> One (r637) + | 771 -> One (r638) + | 780 -> One (r639) + | 779 -> One (r640) + | 778 -> One (r641) + | 777 -> One (r642) + | 786 -> One (r643) + | 785 -> One (r644) + | 784 -> One (r645) + | 783 -> One (r646) + | 792 -> One (r647) + | 791 -> One (r648) + | 790 -> One (r649) + | 789 -> One (r650) + | 798 -> One (r651) + | 797 -> One (r652) + | 796 -> One (r653) + | 795 -> One (r654) + | 804 -> One (r655) + | 803 -> One (r656) + | 802 -> One (r657) + | 801 -> One (r658) + | 810 -> One (r659) + | 809 -> One (r660) + | 808 -> One (r661) + | 807 -> One (r662) + | 816 -> One (r663) + | 815 -> One (r664) + | 814 -> One (r665) + | 813 -> One (r666) + | 822 -> One (r667) + | 821 -> One (r668) + | 820 -> One (r669) + | 819 -> One (r670) + | 828 -> One (r671) + | 827 -> One (r672) + | 826 -> One (r673) + | 825 -> One (r674) + | 834 -> One (r675) | 833 -> One (r676) - | 836 -> One (r678) - | 835 -> One (r679) - | 832 -> One (r680) - | 831 -> One (r681) - | 825 -> One (r682) - | 824 -> One (r683) - | 823 -> One (r684) - | 822 -> One (r685) - | 830 -> One (r686) - | 829 -> One (r687) - | 828 -> One (r688) - | 878 -> One (r690) - | 877 -> One (r691) - | 876 -> One (r692) - | 871 -> One (r693) - | 892 -> One (r697) - | 891 -> One (r698) - | 890 -> One (r699) - | 1018 -> One (r700) - | 1017 -> One (r701) - | 1016 -> One (r702) - | 1015 -> One (r703) - | 870 -> One (r704) - | 869 -> One (r706) - | 865 -> One (r713) - | 862 -> One (r715) - | 861 -> One (r716) - | 859 -> One (r717) - | 858 -> One (r718) - | 857 -> One (r719) - | 856 -> One (r720) - | 852 -> One (r721) - | 851 -> One (r722) - | 855 -> One (r723) - | 854 -> One (r724) - | 868 -> One (r725) - | 867 -> One (r726) - | 875 -> One (r727) - | 889 -> One (r728) - | 885 -> One (r729) - | 881 -> One (r730) - | 884 -> One (r731) - | 883 -> One (r732) - | 888 -> One (r733) - | 887 -> One (r734) - | 1180 -> One (r735) - | 946 -> One (r736) - | 961 -> One (r738) - | 960 -> One (r739) - | 959 -> One (r740) - | 958 -> One (r741) - | 957 -> One (r742) - | 944 -> One (r746) - | 943 -> One (r747) - | 942 -> One (r748) - | 940 -> One (r749) - | 939 -> One (r750) - | 916 -> One (r752) - | 915 -> One (r753) - | 914 -> One (r754) - | 905 -> One (r755) - | 904 -> One (r756) - | 910 -> One (r757) - | 909 -> One (r758) - | 908 | 1706 -> One (r759) - | 912 | 1705 -> One (r760) - | 933 -> One (r761) - | 925 -> One (r762) - | 924 -> One (r763) - | 923 -> One (r764) - | 932 -> One (r765) - | 931 -> One (r766) - | 953 -> One (r767) - | 952 -> One (r768) - | 951 -> One (r769) - | 1179 -> One (r770) - | 972 -> One (r771) - | 971 -> One (r772) - | 970 -> One (r773) - | 969 -> One (r774) - | 968 -> One (r775) - | 967 -> One (r776) - | 966 -> One (r777) - | 965 -> One (r778) - | 1005 -> One (r779) - | 1004 -> One (r780) - | 1007 -> One (r782) - | 1006 -> One (r783) - | 1000 -> One (r784) - | 982 -> One (r785) - | 981 -> One (r786) - | 980 -> One (r787) - | 979 -> One (r788) - | 978 -> One (r789) - | 986 -> One (r793) - | 985 -> One (r794) - | 999 -> One (r795) - | 991 -> One (r796) - | 990 -> One (r797) - | 989 -> One (r798) - | 988 -> One (r799) - | 998 -> One (r800) - | 997 -> One (r801) - | 996 -> One (r802) - | 995 -> One (r803) - | 994 -> One (r804) - | 993 -> One (r805) - | 1003 -> One (r808) - | 1002 -> One (r809) - | 1009 -> One (r810) - | 1014 -> One (r811) - | 1013 -> One (r812) - | 1012 -> One (r813) - | 1011 -> One (r814) - | 1074 | 1128 -> One (r816) - | 1130 -> One (r818) - | 1144 -> One (r820) - | 1134 -> One (r821) - | 1133 -> One (r822) - | 1115 -> One (r823) - | 1114 -> One (r824) - | 1113 -> One (r825) - | 1112 -> One (r826) - | 1111 -> One (r827) - | 1110 -> One (r828) - | 1109 -> One (r829) - | 1099 -> One (r830) - | 1098 -> One (r831) - | 1030 -> One (r832) - | 1029 -> One (r833) - | 1028 -> One (r834) - | 1024 -> One (r835) - | 1022 -> One (r836) - | 1021 -> One (r837) - | 1027 -> One (r838) - | 1026 -> One (r839) - | 1092 -> One (r840) - | 1091 -> One (r841) - | 1036 -> One (r842) - | 1032 -> One (r843) - | 1035 -> One (r844) - | 1034 -> One (r845) - | 1047 -> One (r846) - | 1046 -> One (r847) - | 1045 -> One (r848) - | 1044 -> One (r849) - | 1043 -> One (r850) - | 1038 -> One (r851) - | 1058 -> One (r852) - | 1057 -> One (r853) - | 1056 -> One (r854) - | 1055 -> One (r855) - | 1054 -> One (r856) - | 1049 -> One (r857) - | 1083 -> One (r858) - | 1082 -> One (r859) - | 1060 -> One (r860) - | 1081 -> One (r861) - | 1080 -> One (r862) - | 1079 -> One (r863) - | 1078 -> One (r864) - | 1062 -> One (r865) - | 1076 -> One (r866) - | 1066 -> One (r867) - | 1065 -> One (r868) - | 1064 -> One (r869) - | 1073 | 1121 -> One (r870) - | 1070 -> One (r872) - | 1069 -> One (r873) - | 1068 -> One (r874) - | 1067 | 1120 -> One (r875) - | 1072 -> One (r876) - | 1088 -> One (r877) - | 1087 -> One (r878) - | 1086 -> One (r879) - | 1090 -> One (r881) - | 1089 -> One (r882) - | 1085 -> One (r883) - | 1094 -> One (r884) - | 1097 -> One (r885) - | 1108 -> One (r886) - | 1107 -> One (r887) - | 1106 -> One (r888) - | 1105 -> One (r889) - | 1104 -> One (r890) - | 1103 -> One (r891) - | 1102 -> One (r892) - | 1101 -> One (r893) - | 1132 -> One (r894) - | 1119 -> One (r895) - | 1118 -> One (r896) - | 1117 -> One (r897) - | 1131 -> One (r898) - | 1123 -> One (r899) - | 1129 -> One (r900) - | 1126 -> One (r901) - | 1125 -> One (r902) - | 1143 -> One (r903) - | 1142 -> One (r904) - | 1141 -> One (r905) - | 1140 -> One (r906) - | 1139 -> One (r907) - | 1138 -> One (r908) - | 1137 -> One (r909) - | 1136 -> One (r910) - | 1153 -> One (r911) - | 1155 -> One (r912) - | 1165 -> One (r913) - | 1164 -> One (r914) - | 1163 -> One (r915) - | 1162 -> One (r916) - | 1161 -> One (r917) - | 1160 -> One (r918) - | 1159 -> One (r919) - | 1158 -> One (r920) - | 1176 -> One (r921) - | 1175 -> One (r922) - | 1174 -> One (r923) - | 1173 -> One (r924) - | 1172 -> One (r925) - | 1171 -> One (r926) - | 1170 -> One (r927) - | 1169 -> One (r928) - | 1168 -> One (r929) - | 1298 -> One (r930) - | 1347 -> One (r932) - | 1189 -> One (r933) - | 1364 -> One (r935) - | 1355 -> One (r936) - | 1354 -> One (r937) - | 1188 -> One (r938) - | 1187 -> One (r939) - | 1186 -> One (r940) - | 1185 -> One (r941) - | 1184 -> One (r942) - | 1341 -> One (r943) - | 1340 -> One (r944) - | 1192 -> One (r945) - | 1191 -> One (r946) - | 1217 -> One (r947) - | 1216 -> One (r948) - | 1215 -> One (r949) - | 1214 -> One (r950) - | 1205 -> One (r951) - | 1204 -> One (r953) - | 1203 -> One (r954) - | 1199 -> One (r955) - | 1198 -> One (r956) - | 1197 -> One (r957) - | 1196 -> One (r958) - | 1195 -> One (r959) - | 1202 -> One (r960) - | 1201 -> One (r961) - | 1213 -> One (r962) - | 1212 -> One (r963) - | 1211 -> One (r964) - | 1220 -> One (r965) - | 1219 -> One (r966) - | 1267 -> One (r968) - | 1256 -> One (r969) - | 1255 -> One (r970) - | 1246 -> One (r971) - | 1245 -> One (r973) - | 1244 -> One (r974) - | 1236 -> One (r975) - | 1225 -> One (r976) - | 1224 -> One (r977) - | 1223 -> One (r978) - | 1235 -> One (r979) - | 1234 -> One (r980) - | 1233 -> One (r981) - | 1232 -> One (r982) - | 1231 -> One (r983) - | 1230 -> One (r984) - | 1229 -> One (r985) - | 1228 -> One (r986) - | 1242 -> One (r987) - | 1240 -> One (r988) - | 1239 -> One (r989) - | 1254 -> One (r990) - | 1253 -> One (r991) - | 1252 -> One (r992) - | 1266 -> One (r993) - | 1265 -> One (r994) - | 1264 -> One (r995) - | 1263 -> One (r996) - | 1262 -> One (r997) - | 1261 -> One (r998) - | 1260 -> One (r999) - | 1259 -> One (r1000) - | 1271 -> One (r1001) - | 1270 -> One (r1002) - | 1269 -> One (r1003) - | 1335 -> One (r1004) - | 1334 -> One (r1005) - | 1333 -> One (r1006) - | 1332 -> One (r1007) - | 1331 -> One (r1008) - | 1330 -> One (r1009) - | 1327 -> One (r1010) - | 1274 -> One (r1011) - | 1323 -> One (r1012) - | 1322 -> One (r1013) - | 1317 -> One (r1014) - | 1316 -> One (r1015) - | 1315 -> One (r1016) - | 1314 -> One (r1017) - | 1283 -> One (r1018) - | 1282 -> One (r1019) - | 1281 -> One (r1020) - | 1280 -> One (r1021) - | 1279 -> One (r1022) - | 1278 -> One (r1023) - | 1313 -> One (r1024) - | 1287 -> One (r1025) - | 1286 -> One (r1026) - | 1285 -> One (r1027) - | 1291 -> One (r1028) - | 1290 -> One (r1029) - | 1289 -> One (r1030) - | 1310 -> One (r1031) - | 1295 -> One (r1032) - | 1294 -> One (r1033) - | 1312 -> One (r1035) - | 1293 -> One (r1036) - | 1307 -> One (r1037) - | 1297 -> One (r1038) - | 1301 -> One (r1039) - | 1321 -> One (r1040) - | 1320 -> One (r1041) - | 1319 -> One (r1042) - | 1326 -> One (r1043) - | 1325 -> One (r1044) - | 1329 -> One (r1045) - | 1339 -> One (r1046) - | 1338 -> One (r1047) - | 1337 -> One (r1048) - | 1343 -> One (r1049) - | 1346 -> One (r1050) - | 1351 -> One (r1051) - | 1350 -> One (r1052) - | 1349 -> One (r1053) - | 1353 -> One (r1054) - | 1363 -> One (r1055) - | 1362 -> One (r1056) - | 1361 -> One (r1057) - | 1360 -> One (r1058) - | 1359 -> One (r1059) - | 1358 -> One (r1060) - | 1357 -> One (r1061) - | 1380 -> One (r1062) - | 1384 -> One (r1063) - | 1386 -> One (r1064) - | 1392 -> One (r1065) - | 1391 -> One (r1066) - | 1407 | 1450 -> One (r1067) - | 1406 | 1449 -> One (r1068) - | 1405 | 1448 -> One (r1069) - | 1410 | 1455 -> One (r1070) - | 1409 | 1454 -> One (r1071) - | 1408 | 1453 -> One (r1072) - | 1415 | 1462 -> One (r1073) - | 1414 | 1461 -> One (r1074) - | 1413 | 1460 -> One (r1075) - | 1412 | 1459 -> One (r1076) - | 1421 | 1467 -> One (r1077) - | 1420 | 1466 -> One (r1078) - | 1419 | 1465 -> One (r1079) - | 1424 | 1472 -> One (r1080) - | 1423 | 1471 -> One (r1081) - | 1422 | 1470 -> One (r1082) - | 1431 -> One (r1083) - | 1434 | 1484 -> One (r1084) - | 1433 | 1483 -> One (r1085) - | 1432 | 1482 -> One (r1086) - | 1436 -> One (r1087) - | 1439 | 1487 -> One (r1088) - | 1438 | 1486 -> One (r1089) - | 1437 | 1485 -> One (r1090) - | 1441 -> One (r1091) - | 1447 -> One (r1092) - | 1452 -> One (r1093) - | 1457 -> One (r1094) - | 1464 -> One (r1095) - | 1469 -> One (r1096) - | 1474 -> One (r1097) - | 1477 -> One (r1098) - | 1491 -> One (r1099) - | 1490 -> One (r1100) - | 1496 -> One (r1101) - | 1500 -> One (r1102) - | 1502 -> One (r1103) - | 1504 -> One (r1104) - | 1506 -> One (r1105) - | 1508 -> One (r1106) - | 1511 -> One (r1108) - | 1510 -> One (r1109) - | 1523 -> One (r1110) - | 1522 -> One (r1111) - | 1515 -> One (r1112) - | 1514 -> One (r1113) - | 1546 -> One (r1114) - | 1545 -> One (r1115) - | 1544 -> One (r1116) - | 1543 -> One (r1117) - | 1542 -> One (r1118) - | 1541 -> One (r1119) - | 1560 -> One (r1120) - | 1563 -> One (r1121) - | 1576 -> One (r1122) - | 1591 -> One (r1123) - | 1590 -> One (r1124) - | 1589 -> One (r1125) - | 1588 -> One (r1126) - | 1587 -> One (r1127) - | 1586 -> One (r1128) - | 1599 -> One (r1129) - | 1598 -> One (r1130) - | 1597 -> One (r1131) - | 1596 -> One (r1132) - | 1595 -> One (r1133) - | 1594 -> One (r1134) - | 1593 -> One (r1135) - | 1612 -> One (r1136) - | 1611 -> One (r1137) - | 1610 -> One (r1138) - | 1609 -> One (r1139) - | 1608 -> One (r1140) - | 1617 -> One (r1141) - | 1616 -> One (r1142) - | 1615 -> One (r1143) - | 1614 -> One (r1144) - | 1620 -> One (r1145) - | 1619 -> One (r1146) - | 1627 -> One (r1147) - | 1636 -> One (r1148) - | 1635 -> One (r1149) - | 1638 -> One (r1150) - | 1640 -> One (r1151) - | 1651 -> One (r1152) - | 1650 -> One (r1153) - | 1654 -> One (r1154) - | 1653 -> One (r1155) - | 1657 -> One (r1156) - | 1656 -> One (r1157) - | 1666 -> One (r1158) - | 1665 -> One (r1159) - | 1673 -> One (r1160) - | 1681 -> One (r1161) - | 1689 -> One (r1162) - | 1686 -> One (r1163) - | 1688 -> One (r1164) - | 1691 -> One (r1165) - | 1694 -> One (r1166) - | 1697 -> One (r1167) - | 1696 -> One (r1168) - | 1709 -> One (r1169) - | 1708 -> One (r1170) - | 1721 -> One (r1171) - | 1720 -> One (r1172) - | 1744 -> One (r1173) - | 1743 -> One (r1174) - | 1753 -> One (r1175) - | 1755 -> One (r1176) - | 1757 -> One (r1177) - | 1770 -> One (r1178) - | 1774 -> One (r1179) - | 1779 -> One (r1180) - | 1786 -> One (r1181) - | 1785 -> One (r1182) - | 1784 -> One (r1183) - | 1783 -> One (r1184) - | 1793 -> One (r1185) - | 1797 -> One (r1186) - | 1801 -> One (r1187) - | 1804 -> One (r1188) - | 1809 -> One (r1189) - | 1813 -> One (r1190) - | 1817 -> One (r1191) - | 1821 -> One (r1192) - | 1825 -> One (r1193) - | 1828 -> One (r1194) - | 1832 -> One (r1195) - | 1838 -> One (r1196) - | 1848 -> One (r1197) - | 1850 -> One (r1198) - | 1853 -> One (r1199) - | 1852 -> One (r1200) - | 1855 -> One (r1201) - | 1865 -> One (r1202) - | 1861 -> One (r1203) - | 1860 -> One (r1204) - | 1864 -> One (r1205) - | 1863 -> One (r1206) - | 1870 -> One (r1207) - | 1869 -> One (r1208) - | 1868 -> One (r1209) - | 1872 -> One (r1210) - | 373 -> Select (function + | 832 -> One (r677) + | 831 -> One (r678) + | 890 -> One (r679) + | 887 -> One (r680) + | 836 -> One (r681) + | 839 -> One (r682) + | 838 -> One (r683) + | 846 -> One (r684) + | 845 -> One (r685) + | 844 -> One (r686) + | 843 -> One (r687) + | 842 -> One (r688) + | 853 -> One (r689) + | 852 -> One (r690) + | 851 -> One (r691) + | 850 -> One (r692) + | 849 -> One (r693) + | 856 -> One (r694) + | 855 -> One (r695) + | 863 -> One (r696) + | 861 -> One (r697) + | 860 -> One (r698) + | 869 -> One (r699) + | 868 -> One (r700) + | 867 -> One (r701) + | 872 -> One (r702) + | 871 -> One (r703) + | 874 -> One (r704) + | 876 -> One (r705) + | 878 -> One (r706) + | 880 -> One (r707) + | 885 -> One (r708) + | 889 -> One (r709) + | 895 | 956 -> One (r710) + | 894 | 955 -> One (r711) + | 893 | 954 -> One (r712) + | 898 | 965 -> One (r713) + | 897 | 964 -> One (r714) + | 896 | 963 -> One (r715) + | 903 | 976 -> One (r716) + | 902 | 975 -> One (r717) + | 901 | 974 -> One (r718) + | 900 | 973 -> One (r719) + | 909 | 985 -> One (r720) + | 908 | 984 -> One (r721) + | 907 | 983 -> One (r722) + | 912 | 994 -> One (r723) + | 911 | 993 -> One (r724) + | 910 | 992 -> One (r725) + | 915 -> One (r726) + | 925 -> One (r727) + | 924 -> One (r728) + | 923 -> One (r729) + | 922 -> One (r730) + | 928 | 1018 -> One (r731) + | 927 | 1017 -> One (r732) + | 926 | 1016 -> One (r733) + | 934 -> One (r734) + | 933 -> One (r735) + | 932 -> One (r736) + | 931 -> One (r737) + | 937 | 1021 -> One (r738) + | 936 | 1020 -> One (r739) + | 935 | 1019 -> One (r740) + | 943 -> One (r741) + | 942 -> One (r742) + | 941 -> One (r743) + | 940 -> One (r744) + | 953 -> One (r745) + | 952 -> One (r746) + | 951 -> One (r747) + | 950 -> One (r748) + | 962 -> One (r749) + | 961 -> One (r750) + | 960 -> One (r751) + | 959 -> One (r752) + | 971 -> One (r753) + | 970 -> One (r754) + | 969 -> One (r755) + | 968 -> One (r756) + | 982 -> One (r757) + | 981 -> One (r758) + | 980 -> One (r759) + | 979 -> One (r760) + | 991 -> One (r761) + | 990 -> One (r762) + | 989 -> One (r763) + | 988 -> One (r764) + | 1000 -> One (r765) + | 999 -> One (r766) + | 998 -> One (r767) + | 997 -> One (r768) + | 1007 -> One (r769) + | 1006 -> One (r770) + | 1005 -> One (r771) + | 1004 -> One (r772) + | 1025 -> One (r773) + | 1024 -> One (r774) + | 1030 -> One (r775) + | 1034 -> One (r776) + | 1036 -> One (r777) + | 1038 -> One (r778) + | 1040 -> One (r779) + | 1042 -> One (r780) + | 1045 -> One (r782) + | 1044 -> One (r783) + | 1057 -> One (r784) + | 1056 -> One (r785) + | 1049 -> One (r786) + | 1048 -> One (r787) + | 1085 -> One (r788) + | 1084 -> One (r789) + | 1083 -> One (r790) + | 1091 -> One (r791) + | 1090 -> One (r792) + | 1089 -> One (r793) + | 1088 -> One (r794) + | 1098 -> One (r795) + | 1097 -> One (r796) + | 1096 -> One (r797) + | 1095 -> One (r798) + | 1101 -> One (r799) + | 1107 -> One (r800) + | 1106 -> One (r801) + | 1105 -> One (r802) + | 1104 -> One (r803) + | 1116 -> One (r804) + | 1115 -> One (r805) + | 1114 -> One (r806) + | 1123 -> One (r807) + | 1137 -> One (r808) + | 1136 -> One (r809) + | 1144 -> One (r811) + | 1143 -> One (r812) + | 1142 -> One (r813) + | 1135 -> One (r814) + | 1134 -> One (r815) + | 1133 -> One (r816) + | 1141 -> One (r817) + | 1140 -> One (r818) + | 1139 -> One (r819) + | 1146 -> One (r820) + | 1194 -> One (r821) + | 1193 -> One (r822) + | 1192 -> One (r823) + | 1191 -> One (r824) + | 1155 -> One (r825) + | 1149 -> One (r826) + | 1148 -> One (r827) + | 1179 -> One (r828) + | 1178 -> One (r830) + | 1174 -> One (r837) + | 1171 -> One (r839) + | 1170 -> One (r840) + | 1168 -> One (r841) + | 1167 -> One (r842) + | 1166 -> One (r843) + | 1165 -> One (r844) + | 1161 -> One (r845) + | 1160 -> One (r846) + | 1164 -> One (r847) + | 1163 -> One (r848) + | 1177 -> One (r849) + | 1176 -> One (r850) + | 1190 -> One (r851) + | 1186 -> One (r852) + | 1182 -> One (r853) + | 1185 -> One (r854) + | 1184 -> One (r855) + | 1189 -> One (r856) + | 1188 -> One (r857) + | 1210 -> One (r858) + | 1209 -> One (r859) + | 1208 -> One (r860) + | 1214 -> One (r861) + | 1220 -> One (r862) + | 1219 -> One (r863) + | 1218 -> One (r864) + | 1217 -> One (r865) + | 1223 -> One (r866) + | 1222 -> One (r867) + | 1227 -> One (r868) + | 1235 -> One (r869) + | 1234 -> One (r870) + | 1233 -> One (r871) + | 1232 -> One (r872) + | 1238 -> One (r873) + | 1237 -> One (r874) + | 1241 -> One (r875) + | 1240 -> One (r876) + | 1244 -> One (r877) + | 1243 -> One (r878) + | 1249 -> One (r879) + | 1248 -> One (r880) + | 1252 -> One (r881) + | 1251 -> One (r882) + | 1255 -> One (r883) + | 1254 -> One (r884) + | 1286 -> One (r885) + | 1285 -> One (r886) + | 1284 -> One (r887) + | 1272 -> One (r888) + | 1271 -> One (r889) + | 1270 -> One (r890) + | 1269 -> One (r891) + | 1266 -> One (r892) + | 1265 -> One (r893) + | 1264 -> One (r894) + | 1263 -> One (r895) + | 1268 -> One (r896) + | 1283 -> One (r897) + | 1276 -> One (r898) + | 1275 -> One (r899) + | 1274 -> One (r900) + | 1282 -> One (r901) + | 1281 -> One (r902) + | 1280 -> One (r903) + | 1279 -> One (r904) + | 1278 -> One (r905) + | 1780 -> One (r906) + | 1779 -> One (r907) + | 1288 -> One (r908) + | 1290 -> One (r909) + | 1292 -> One (r910) + | 1778 -> One (r911) + | 1777 -> One (r912) + | 1294 -> One (r913) + | 1299 -> One (r914) + | 1298 -> One (r915) + | 1297 -> One (r916) + | 1296 -> One (r917) + | 1310 -> One (r918) + | 1313 -> One (r920) + | 1312 -> One (r921) + | 1309 -> One (r922) + | 1308 -> One (r923) + | 1304 -> One (r924) + | 1303 -> One (r925) + | 1302 -> One (r926) + | 1301 -> One (r927) + | 1307 -> One (r928) + | 1306 -> One (r929) + | 1326 -> One (r931) + | 1325 -> One (r932) + | 1324 -> One (r933) + | 1319 -> One (r934) + | 1329 -> One (r938) + | 1328 -> One (r939) + | 1327 -> One (r940) + | 1387 -> One (r941) + | 1386 -> One (r942) + | 1385 -> One (r943) + | 1384 -> One (r944) + | 1323 -> One (r945) + | 1580 -> One (r946) + | 1579 -> One (r947) + | 1341 -> One (r948) + | 1340 -> One (r949) + | 1339 -> One (r950) + | 1338 -> One (r951) + | 1337 -> One (r952) + | 1336 -> One (r953) + | 1335 -> One (r954) + | 1334 -> One (r955) + | 1374 -> One (r956) + | 1373 -> One (r957) + | 1376 -> One (r959) + | 1375 -> One (r960) + | 1369 -> One (r961) + | 1351 -> One (r962) + | 1350 -> One (r963) + | 1349 -> One (r964) + | 1348 -> One (r965) + | 1347 -> One (r966) + | 1355 -> One (r970) + | 1354 -> One (r971) + | 1368 -> One (r972) + | 1360 -> One (r973) + | 1359 -> One (r974) + | 1358 -> One (r975) + | 1357 -> One (r976) + | 1367 -> One (r977) + | 1366 -> One (r978) + | 1365 -> One (r979) + | 1364 -> One (r980) + | 1363 -> One (r981) + | 1362 -> One (r982) + | 1372 -> One (r985) + | 1371 -> One (r986) + | 1378 -> One (r987) + | 1383 -> One (r988) + | 1382 -> One (r989) + | 1381 -> One (r990) + | 1380 -> One (r991) + | 1443 | 1497 -> One (r993) + | 1499 -> One (r995) + | 1513 -> One (r997) + | 1503 -> One (r998) + | 1502 -> One (r999) + | 1484 -> One (r1000) + | 1483 -> One (r1001) + | 1482 -> One (r1002) + | 1481 -> One (r1003) + | 1480 -> One (r1004) + | 1479 -> One (r1005) + | 1478 -> One (r1006) + | 1468 -> One (r1007) + | 1467 -> One (r1008) + | 1399 -> One (r1009) + | 1398 -> One (r1010) + | 1397 -> One (r1011) + | 1393 -> One (r1012) + | 1391 -> One (r1013) + | 1390 -> One (r1014) + | 1396 -> One (r1015) + | 1395 -> One (r1016) + | 1461 -> One (r1017) + | 1460 -> One (r1018) + | 1405 -> One (r1019) + | 1401 -> One (r1020) + | 1404 -> One (r1021) + | 1403 -> One (r1022) + | 1416 -> One (r1023) + | 1415 -> One (r1024) + | 1414 -> One (r1025) + | 1413 -> One (r1026) + | 1412 -> One (r1027) + | 1407 -> One (r1028) + | 1427 -> One (r1029) + | 1426 -> One (r1030) + | 1425 -> One (r1031) + | 1424 -> One (r1032) + | 1423 -> One (r1033) + | 1418 -> One (r1034) + | 1452 -> One (r1035) + | 1451 -> One (r1036) + | 1429 -> One (r1037) + | 1450 -> One (r1038) + | 1449 -> One (r1039) + | 1448 -> One (r1040) + | 1447 -> One (r1041) + | 1431 -> One (r1042) + | 1445 -> One (r1043) + | 1435 -> One (r1044) + | 1434 -> One (r1045) + | 1433 -> One (r1046) + | 1442 | 1490 -> One (r1047) + | 1439 -> One (r1049) + | 1438 -> One (r1050) + | 1437 -> One (r1051) + | 1436 | 1489 -> One (r1052) + | 1441 -> One (r1053) + | 1457 -> One (r1054) + | 1456 -> One (r1055) + | 1455 -> One (r1056) + | 1459 -> One (r1058) + | 1458 -> One (r1059) + | 1454 -> One (r1060) + | 1463 -> One (r1061) + | 1466 -> One (r1062) + | 1477 -> One (r1063) + | 1476 -> One (r1064) + | 1475 -> One (r1065) + | 1474 -> One (r1066) + | 1473 -> One (r1067) + | 1472 -> One (r1068) + | 1471 -> One (r1069) + | 1470 -> One (r1070) + | 1501 -> One (r1071) + | 1488 -> One (r1072) + | 1487 -> One (r1073) + | 1486 -> One (r1074) + | 1500 -> One (r1075) + | 1492 -> One (r1076) + | 1498 -> One (r1077) + | 1495 -> One (r1078) + | 1494 -> One (r1079) + | 1512 -> One (r1080) + | 1511 -> One (r1081) + | 1510 -> One (r1082) + | 1509 -> One (r1083) + | 1508 -> One (r1084) + | 1507 -> One (r1085) + | 1506 -> One (r1086) + | 1505 -> One (r1087) + | 1522 -> One (r1088) + | 1524 -> One (r1089) + | 1534 -> One (r1090) + | 1533 -> One (r1091) + | 1532 -> One (r1092) + | 1531 -> One (r1093) + | 1530 -> One (r1094) + | 1529 -> One (r1095) + | 1528 -> One (r1096) + | 1527 -> One (r1097) + | 1576 -> One (r1098) + | 1556 -> One (r1099) + | 1555 -> One (r1100) + | 1554 -> One (r1101) + | 1553 -> One (r1102) + | 1540 -> One (r1103) + | 1539 -> One (r1104) + | 1538 -> One (r1105) + | 1537 -> One (r1106) + | 1544 -> One (r1107) + | 1543 -> One (r1108) + | 1549 -> One (r1109) + | 1548 -> One (r1110) + | 1547 | 1808 -> One (r1111) + | 1551 | 1807 -> One (r1112) + | 1573 -> One (r1113) + | 1565 -> One (r1114) + | 1564 -> One (r1115) + | 1563 -> One (r1116) + | 1572 -> One (r1117) + | 1571 -> One (r1118) + | 1692 -> One (r1119) + | 1736 -> One (r1121) + | 1589 -> One (r1122) + | 1753 -> One (r1124) + | 1744 -> One (r1125) + | 1743 -> One (r1126) + | 1588 -> One (r1127) + | 1587 -> One (r1128) + | 1586 -> One (r1129) + | 1585 -> One (r1130) + | 1584 -> One (r1131) + | 1730 -> One (r1132) + | 1729 -> One (r1133) + | 1592 -> One (r1134) + | 1591 -> One (r1135) + | 1617 -> One (r1136) + | 1616 -> One (r1137) + | 1615 -> One (r1138) + | 1614 -> One (r1139) + | 1605 -> One (r1140) + | 1604 -> One (r1142) + | 1603 -> One (r1143) + | 1599 -> One (r1144) + | 1598 -> One (r1145) + | 1597 -> One (r1146) + | 1596 -> One (r1147) + | 1595 -> One (r1148) + | 1602 -> One (r1149) + | 1601 -> One (r1150) + | 1613 -> One (r1151) + | 1612 -> One (r1152) + | 1611 -> One (r1153) + | 1620 -> One (r1154) + | 1619 -> One (r1155) + | 1661 -> One (r1157) + | 1650 -> One (r1158) + | 1649 -> One (r1159) + | 1640 -> One (r1160) + | 1639 -> One (r1162) + | 1638 -> One (r1163) + | 1637 -> One (r1164) + | 1626 -> One (r1165) + | 1625 -> One (r1166) + | 1623 -> One (r1167) + | 1636 -> One (r1168) + | 1635 -> One (r1169) + | 1634 -> One (r1170) + | 1633 -> One (r1171) + | 1632 -> One (r1172) + | 1631 -> One (r1173) + | 1630 -> One (r1174) + | 1629 -> One (r1175) + | 1648 -> One (r1176) + | 1647 -> One (r1177) + | 1646 -> One (r1178) + | 1660 -> One (r1179) + | 1659 -> One (r1180) + | 1658 -> One (r1181) + | 1657 -> One (r1182) + | 1656 -> One (r1183) + | 1655 -> One (r1184) + | 1654 -> One (r1185) + | 1653 -> One (r1186) + | 1665 -> One (r1187) + | 1664 -> One (r1188) + | 1663 -> One (r1189) + | 1724 -> One (r1190) + | 1723 -> One (r1191) + | 1722 -> One (r1192) + | 1721 -> One (r1193) + | 1720 -> One (r1194) + | 1719 -> One (r1195) + | 1716 -> One (r1196) + | 1668 -> One (r1197) + | 1712 -> One (r1198) + | 1711 -> One (r1199) + | 1706 -> One (r1200) + | 1705 -> One (r1201) + | 1704 -> One (r1202) + | 1703 -> One (r1203) + | 1677 -> One (r1204) + | 1676 -> One (r1205) + | 1675 -> One (r1206) + | 1674 -> One (r1207) + | 1673 -> One (r1208) + | 1672 -> One (r1209) + | 1702 -> One (r1210) + | 1681 -> One (r1211) + | 1680 -> One (r1212) + | 1679 -> One (r1213) + | 1685 -> One (r1214) + | 1684 -> One (r1215) + | 1683 -> One (r1216) + | 1699 -> One (r1217) + | 1689 -> One (r1218) + | 1688 -> One (r1219) + | 1701 -> One (r1221) + | 1687 -> One (r1222) + | 1696 -> One (r1223) + | 1691 -> One (r1224) + | 1710 -> One (r1225) + | 1709 -> One (r1226) + | 1708 -> One (r1227) + | 1715 -> One (r1228) + | 1714 -> One (r1229) + | 1718 -> One (r1230) + | 1728 -> One (r1231) + | 1727 -> One (r1232) + | 1726 -> One (r1233) + | 1732 -> One (r1234) + | 1735 -> One (r1235) + | 1740 -> One (r1236) + | 1739 -> One (r1237) + | 1738 -> One (r1238) + | 1742 -> One (r1239) + | 1752 -> One (r1240) + | 1751 -> One (r1241) + | 1750 -> One (r1242) + | 1749 -> One (r1243) + | 1748 -> One (r1244) + | 1747 -> One (r1245) + | 1746 -> One (r1246) + | 1762 -> One (r1247) + | 1765 -> One (r1248) + | 1767 -> One (r1249) + | 1773 -> One (r1250) + | 1772 -> One (r1251) + | 1783 -> One (r1252) + | 1782 -> One (r1253) + | 1794 -> One (r1254) + | 1793 -> One (r1255) + | 1811 -> One (r1256) + | 1810 -> One (r1257) + | 1823 -> One (r1258) + | 1822 -> One (r1259) + | 1839 -> One (r1260) + | 1847 -> One (r1261) + | 1855 -> One (r1262) + | 1852 -> One (r1263) + | 1854 -> One (r1264) + | 1857 -> One (r1265) + | 1860 -> One (r1266) + | 1863 -> One (r1267) + | 1862 -> One (r1268) + | 1871 -> One (r1269) + | 1870 -> One (r1270) + | 1869 -> One (r1271) + | 1885 -> One (r1272) + | 1884 -> One (r1273) + | 1883 -> One (r1274) + | 1905 -> One (r1275) + | 1909 -> One (r1276) + | 1914 -> One (r1277) + | 1921 -> One (r1278) + | 1920 -> One (r1279) + | 1919 -> One (r1280) + | 1918 -> One (r1281) + | 1928 -> One (r1282) + | 1932 -> One (r1283) + | 1936 -> One (r1284) + | 1939 -> One (r1285) + | 1944 -> One (r1286) + | 1948 -> One (r1287) + | 1952 -> One (r1288) + | 1956 -> One (r1289) + | 1960 -> One (r1290) + | 1963 -> One (r1291) + | 1967 -> One (r1292) + | 1973 -> One (r1293) + | 1983 -> One (r1294) + | 1985 -> One (r1295) + | 1988 -> One (r1296) + | 1987 -> One (r1297) + | 1990 -> One (r1298) + | 2000 -> One (r1299) + | 1996 -> One (r1300) + | 1995 -> One (r1301) + | 1999 -> One (r1302) + | 1998 -> One (r1303) + | 2005 -> One (r1304) + | 2004 -> One (r1305) + | 2003 -> One (r1306) + | 2007 -> One (r1307) + | 370 -> Select (function | -1 -> [R 98] | _ -> S (T T_DOT) :: r343) - | 617 -> Select (function + | 611 -> Select (function | -1 -> [R 98] - | _ -> r549) - | 173 -> Select (function - | -1 -> r158 - | _ -> R 135 :: r150) - | 838 -> Select (function - | -1 -> r703 - | _ -> R 135 :: r696) - | 895 -> Select (function - | -1 -> r158 - | _ -> R 135 :: r745) - | 974 -> Select (function - | -1 -> r650 - | _ -> R 135 :: r792) - | 518 -> Select (function + | _ -> r538) + | 130 -> Select (function + | -1 -> r82 + | _ -> R 124 :: r104) + | 172 -> Select (function + | -1 -> r82 + | _ -> R 124 :: r159) + | 1315 -> Select (function + | -1 -> r944 + | _ -> R 124 :: r937) + | 1343 -> Select (function + | -1 -> r895 + | _ -> R 124 :: r969) + | 495 -> Select (function | -1 -> r296 - | _ -> [R 228]) - | 391 -> Select (function - | -1 -> [R 685] - | _ -> S (N N_pattern) :: r351) + | _ -> [R 255]) | 388 -> Select (function - | -1 -> [R 686] + | -1 -> [R 722] + | _ -> S (N N_pattern) :: r351) + | 385 -> Select (function + | -1 -> [R 723] | _ -> S (N N_pattern) :: r350) - | 179 -> Select (function - | -1 -> r170 - | _ -> R 792 :: r164) - | 898 -> Select (function - | -1 -> r170 - | _ -> R 792 :: r751) - | 243 -> Select (function - | -1 -> S (T T_RPAREN) :: r60 - | _ -> S (T T_MODULE) :: r241) - | 872 -> Select (function - | -1 -> S (T T_RPAREN) :: r60 + | 136 -> Select (function + | -1 -> r110 + | _ -> R 828 :: r116) + | 175 -> Select (function + | -1 -> r110 + | _ -> R 828 :: r165) + | 1320 -> Select (function + | -1 -> S (T T_RPAREN) :: r134 | _ -> S (T T_COLONCOLON) :: r359) - | 87 -> Select (function - | 252 | 452 | 632 | 747 | 1280 | 1319 | 1370 | 1495 -> r67 - | -1 -> S (T T_RPAREN) :: r60 - | _ -> S (N N_pattern) :: r62) - | 254 -> Select (function + | 198 -> Select (function + | 249 | 626 | 836 | 1029 | 1199 | 1674 | 1708 -> r47 + | -1 -> S (T T_RPAREN) :: r134 + | _ -> S (N N_pattern) :: r193) + | 244 -> Select (function + | -1 -> S (T T_RPAREN) :: r134 + | _ -> Sub (r3) :: r241) + | 251 -> Select (function | -1 -> S (T T_RBRACKET) :: r252 | _ -> Sub (r254) :: r256) - | 560 -> Select (function + | 537 -> Select (function | -1 -> S (T T_RBRACKET) :: r252 - | _ -> Sub (r468) :: r470) - | 472 -> Select (function - | -1 | 60 | 172 | 210 | 211 | 772 | 813 | 815 | 1857 -> r405 - | _ -> S (T T_OPEN) :: r411) - | 874 -> Select (function - | -1 -> r461 - | _ -> S (T T_LPAREN) :: r727) - | 290 -> Select (function - | 1115 | 1119 | 1123 | 1126 | 1140 | 1324 | 1348 -> r290 + | _ -> Sub (r451) :: r453) + | 449 -> Select (function + | 60 | 169 | 181 | 214 | 1288 | 1294 -> r394 + | _ -> S (T T_OPEN) :: r386) + | 1322 -> Select (function + | -1 -> r444 + | _ -> S (T T_LPAREN) :: r945) + | 287 -> Select (function + | 1484 | 1488 | 1492 | 1495 | 1509 | 1713 | 1737 -> r290 | -1 -> r302 | _ -> S (T T_DOT) :: r305) - | 516 -> Select (function + | 493 -> Select (function | -1 -> r302 - | _ -> S (T T_DOT) :: r456) - | 203 -> Select (function - | -1 -> r129 - | _ -> S (T T_COLON) :: r191) - | 152 -> Select (function - | 879 | 1606 -> r113 - | _ -> Sub (r111) :: r114) - | 155 -> Select (function - | 879 | 1606 -> r112 - | _ -> r114) - | 1723 -> Select (function - | -1 -> r154 - | _ -> r129) - | 198 -> Select (function - | -1 -> r168 - | _ -> r129) - | 949 -> Select (function - | -1 -> r154 - | _ -> r129) - | 900 -> Select (function - | -1 -> r168 - | _ -> r129) - | 1722 -> Select (function - | -1 -> r155 - | _ -> r148) - | 175 -> Select (function - | -1 -> r156 - | _ -> r149) + | _ -> S (T T_DOT) :: r439) + | 162 -> Select (function + | -1 -> r83 + | _ -> S (T T_COLON) :: r138) + | 113 -> Select (function + | 840 | 1180 -> r62 + | _ -> Sub (r59) :: r60) + | 116 -> Select (function + | 840 | 1180 -> r61 + | _ -> r60) + | 1825 -> Select (function + | -1 -> r78 + | _ -> r83) + | 1881 -> Select (function + | -1 -> r78 + | _ -> r83) + | 1880 -> Select (function + | -1 -> r79 + | _ -> r102) + | 1824 -> Select (function + | -1 -> r79 + | _ -> r157) + | 132 -> Select (function + | -1 -> r80 + | _ -> r103) | 174 -> Select (function - | -1 -> r157 - | _ -> r150) - | 948 -> Select (function - | -1 -> r155 - | _ -> r743) - | 897 -> Select (function - | -1 -> r156 - | _ -> r744) - | 896 -> Select (function - | -1 -> r157 - | _ -> r745) - | 197 -> Select (function - | -1 -> r169 - | _ -> r164) - | 899 -> Select (function - | -1 -> r169 - | _ -> r751) - | 291 -> Select (function - | 1115 | 1119 | 1123 | 1126 | 1140 | 1324 | 1348 -> r289 + | -1 -> r80 + | _ -> r158) + | 131 -> Select (function + | -1 -> r81 + | _ -> r104) + | 173 -> Select (function + | -1 -> r81 + | _ -> r159) + | 177 -> Select (function + | -1 -> r108 + | _ -> r83) + | 155 -> Select (function + | -1 -> r108 + | _ -> r83) + | 154 -> Select (function + | -1 -> r109 + | _ -> r116) + | 176 -> Select (function + | -1 -> r109 + | _ -> r165) + | 288 -> Select (function + | 1484 | 1488 | 1492 | 1495 | 1509 | 1713 | 1737 -> r289 | -1 -> r297 | _ -> r305) - | 517 -> Select (function + | 494 -> Select (function | -1 -> r297 - | _ -> r456) - | 977 -> Select (function - | -1 -> r647 - | _ -> r790) - | 976 -> Select (function - | -1 -> r648 - | _ -> r791) - | 975 -> Select (function - | -1 -> r649 - | _ -> r792) - | 846 -> Select (function - | -1 -> r700 - | _ -> r694) - | 840 -> Select (function - | -1 -> r701 - | _ -> r695) - | 839 -> Select (function - | -1 -> r702 - | _ -> r696) + | _ -> r439) + | 1346 -> Select (function + | -1 -> r892 + | _ -> r967) + | 1345 -> Select (function + | -1 -> r893 + | _ -> r968) + | 1344 -> Select (function + | -1 -> r894 + | _ -> r969) + | 1318 -> Select (function + | -1 -> r941 + | _ -> r935) + | 1317 -> Select (function + | -1 -> r942 + | _ -> r936) + | 1316 -> Select (function + | -1 -> r943 + | _ -> r937) | _ -> raise Not_found diff --git a/tests/test-dirs/completion/kind.t/run.t b/tests/test-dirs/completion/kind.t/run.t index a7f52707cb..d30c518db8 100644 --- a/tests/test-dirs/completion/kind.t/run.t +++ b/tests/test-dirs/completion/kind.t/run.t @@ -25,8 +25,6 @@ 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" From fca9b6e31d222d9c113e288c4512bb9ecb356caf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 14 Feb 2024 16:50:04 +0100 Subject: [PATCH 080/130] Try to restore function recovery --- src/ocaml/typing/typecore.ml | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index 0b90e9c0e1..b7e7f25057 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -4694,7 +4694,10 @@ and split_function_ty env ty_expected ~arg_label ~first ~in_function = then Not_a_function (ty_fun, explanation) else Too_many_arguments (ty_fun, explanation) in - raise (Error(loc, env, err)) + (* Merlin: we recover with an expected type of 'a -> 'b *) + let level = get_level (instance ty_expected) in + raise_error (error(loc, env, err)); + (ty_expected, newvar2 level) in let ty_arg = if is_optional arg_label then @@ -4758,13 +4761,10 @@ and type_function ~first:false ~in_function in (params, body, newtypes, contains_gadt), exp_type) - (* Merlin: we recover with an expected type of 'a -> 'b *) - (* let level = get_level (instance ty_expected) in - raise_error (error(loc_fun, env, err)); - (newvar2 level, newvar2 level) *) in - with_explanation ty_fun.explanation (fun () -> + (try with_explanation ty_fun.explanation (fun () -> unify_exp_types loc env exp_type (instance ty_expected)); + with _ -> Msupport.erroneous_type_register ty_expected); let newtype = nt_id, newtype, nt_uid in exp_type, params, body, newtype :: newtypes, contains_gadt | { pparam_desc = Pparam_val (arg_label, default_arg, pat); pparam_loc } @@ -4835,8 +4835,9 @@ and type_function type for each new parameter. Now that functions are n-ary, we could possibly run this once. *) - with_explanation ty_fun.explanation (fun () -> + (try with_explanation ty_fun.explanation (fun () -> unify_exp_types loc env exp_type (instance ty_expected)); + with _ -> Msupport.erroneous_type_register ty_expected); (* This is quadratic, as it extracts all of the parameters from an arrow type for each parameter that's added. Now that functions are n-ary, there might be an opportunity to improve this. @@ -6085,7 +6086,8 @@ and type_function_cases_expect let ty_fun = instance (newgenty (Tarrow (Nolabel, ty_arg, ty_res, commu_ok))) in - unify_exp_types loc env ty_fun (instance ty_expected); + (try unify_exp_types loc env ty_fun (instance ty_expected); + with _ -> Msupport.erroneous_type_register ty_expected); cases, partial, ty_fun end From 069261b5695a604d3039e024191c7f0f110bfa65 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 14 Feb 2024 16:52:11 +0100 Subject: [PATCH 081/130] tests: promote changes --- tests/test-dirs/enclosing.t | 11 +----- .../errors/typing-after-parsing.t/run.t | 4 +- .../test-dirs/type-enclosing/issue864.t/run.t | 37 +------------------ 3 files changed, 4 insertions(+), 48 deletions(-) diff --git a/tests/test-dirs/enclosing.t b/tests/test-dirs/enclosing.t index 8853c00d4f..f3e6ca26fa 100644 --- a/tests/test-dirs/enclosing.t +++ b/tests/test-dirs/enclosing.t @@ -1,3 +1,4 @@ +FIXME: with 5.2 new function representation we lost some granularity $ cat >main.ml < module M = struct > let g = @@ -30,16 +31,6 @@ "col": 33 } }, - { - "start": { - "line": 3, - "col": 17 - }, - "end": { - "line": 3, - "col": 33 - } - }, { "start": { "line": 3, diff --git a/tests/test-dirs/errors/typing-after-parsing.t/run.t b/tests/test-dirs/errors/typing-after-parsing.t/run.t index 521ab9692c..e3a8622a10 100644 --- a/tests/test-dirs/errors/typing-after-parsing.t/run.t +++ b/tests/test-dirs/errors/typing-after-parsing.t/run.t @@ -30,7 +30,7 @@ First ask for all the errors: "type": "parser", "sub": [], "valid": true, - "message": "Syntax error, expecting expr" + "message": "Syntax error, expecting fun_expr" } ], "notifications": [] @@ -81,7 +81,7 @@ And let's also try filtering out type errors: "type": "parser", "sub": [], "valid": true, - "message": "Syntax error, expecting expr" + "message": "Syntax error, expecting fun_expr" } ], "notifications": [] diff --git a/tests/test-dirs/type-enclosing/issue864.t/run.t b/tests/test-dirs/type-enclosing/issue864.t/run.t index 75b887deb4..59d92370a0 100644 --- a/tests/test-dirs/type-enclosing/issue864.t/run.t +++ b/tests/test-dirs/type-enclosing/issue864.t/run.t @@ -1,3 +1,4 @@ +FIXME: with 5.2 new function representation we lost some granularity $ $MERLIN single type-enclosing -position 5:24 -verbosity 0 \ > -filename ./issue864.ml < ./issue864.ml { @@ -27,18 +28,6 @@ "type": "int", "tail": "no" }, - { - "start": { - "line": 5, - "col": 9 - }, - "end": { - "line": 5, - "col": 24 - }, - "type": "X.t -> int", - "tail": "no" - }, { "start": { "line": 5, @@ -84,18 +73,6 @@ "type": "int", "tail": "no" }, - { - "start": { - "line": 7, - "col": 20 - }, - "end": { - "line": 7, - "col": 37 - }, - "type": "X.t -> int", - "tail": "no" - }, { "start": { "line": 7, @@ -141,18 +118,6 @@ "type": "int", "tail": "no" }, - { - "start": { - "line": 9, - "col": 20 - }, - "end": { - "line": 9, - "col": 35 - }, - "type": "X.t -> int", - "tail": "no" - }, { "start": { "line": 9, From 861388e6d1d843b023dc404988e70f785ff80889 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 16 Feb 2024 13:02:40 +0100 Subject: [PATCH 082/130] printtyped: expose expression printing --- src/ocaml/typing/printtyped.ml | 2 ++ src/ocaml/typing/printtyped.mli | 1 + 2 files changed, 3 insertions(+) diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml index 83bc701fc3..950a89433a 100644 --- a/src/ocaml/typing/printtyped.ml +++ b/src/ocaml/typing/printtyped.ml @@ -1007,3 +1007,5 @@ let implementation ppf x = list 0 structure_item ppf x.str_items let implementation_with_coercion ppf Typedtree.{structure; _} = implementation ppf structure + +let expression ppf x = expression 0 ppf x diff --git a/src/ocaml/typing/printtyped.mli b/src/ocaml/typing/printtyped.mli index ae9a6ad4fd..1150e2e16c 100644 --- a/src/ocaml/typing/printtyped.mli +++ b/src/ocaml/typing/printtyped.mli @@ -24,3 +24,4 @@ val implementation_with_coercion : (* Added by merlin for debugging purposes *) val pattern : int -> formatter -> _ general_pattern -> unit +val expression : formatter -> expression -> unit From 192658b0b60ce8b30aa69a8347ec6819b80e884b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 16 Feb 2024 13:28:29 +0100 Subject: [PATCH 083/130] tests: push test changes with remaining FIXMEs --- tests/test-dirs/config/flags/unsafe.t | 32 ++ tests/test-dirs/destruct/destruct-fun.t | 38 +- tests/test-dirs/errors/function-warnings.t | 48 ++ tests/test-dirs/errors/issue1222.t | 32 +- tests/test-dirs/function-recovery.t | 532 +++++++----------- tests/test-dirs/no-escape.t/run.t | 4 +- tests/test-dirs/occurrences/issue1398.t/run.t | 7 +- .../test-dirs/type-enclosing/underscore-ids.t | 41 +- tests/test-dirs/typing-recovery.t | 214 +++---- 9 files changed, 479 insertions(+), 469 deletions(-) create mode 100644 tests/test-dirs/errors/function-warnings.t diff --git a/tests/test-dirs/config/flags/unsafe.t b/tests/test-dirs/config/flags/unsafe.t index 60579f5e9a..d6379fc70b 100644 --- a/tests/test-dirs/config/flags/unsafe.t +++ b/tests/test-dirs/config/flags/unsafe.t @@ -9,6 +9,8 @@ Testing array desugaring "notifications": [] } +FIXME UPGRADE 5.2: this test show additionnal warnings after the 5.2 upgrade; probably a +type that should be marked as incorrect is not anymore. $ $MERLIN single errors -filename array_bad.ml < module Array = struct end > let x = [|0|].(0) @@ -29,6 +31,20 @@ Testing array desugaring "sub": [], "valid": true, "message": "Unbound value Array.get" + }, + { + "start": { + "line": 2, + "col": 15 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": "warning", + "sub": [], + "valid": true, + "message": "Warning 20: this argument will not be used by the function." } ], "notifications": [] @@ -53,6 +69,8 @@ Testing array desugaring "notifications": [] } +FIXME UPGRADE 5.2: this test show additionnal warnings after the 5.2 upgrade; probably a +type that should be marked as incorrect is not anymore. $ $MERLIN single errors -filename unsafe_array_bad.ml -unsafe < module Array = struct end > let x = [|0|].(0) @@ -73,6 +91,20 @@ Testing array desugaring "sub": [], "valid": true, "message": "Unbound value Array.unsafe_get" + }, + { + "start": { + "line": 2, + "col": 15 + }, + "end": { + "line": 2, + "col": 16 + }, + "type": "warning", + "sub": [], + "valid": true, + "message": "Warning 20: this argument will not be used by the function." } ], "notifications": [] diff --git a/tests/test-dirs/destruct/destruct-fun.t b/tests/test-dirs/destruct/destruct-fun.t index 773633384f..44c915da48 100644 --- a/tests/test-dirs/destruct/destruct-fun.t +++ b/tests/test-dirs/destruct/destruct-fun.t @@ -1,11 +1,25 @@ -Test case-analysis in the middle of a [fun]. +Test case-analysis on a function parameter: $ cat >fun.ml < let f x (bb : bool) y = something > EOF +FIXME UPGRADE 5.2: this was working before the upgrade $ $MERLIN single case-analysis -start 1:10 -end 1:11 \ - > -log-file - -filename fun.ml -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "exception", + "value": "File \"src/analysis/destruct.ml\",line 265,characters 51-57: Assertion failedRaised at Merlin_analysis__Destruct.get_every_pattern.(fun) in file \"src/analysis/destruct.ml\",line 265,characters 51-63Called from Merlin_specific__Browse_raw.(**) in file \"src/ocaml/merlin_specific/browse_raw.ml\" (inlined),line 233,characters 11-25Called from Merlin_specific__Browse_raw.of_pattern in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 274,characters 2-55Called from Merlin_specific__Browse_raw.list_fold in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 236,characters 37-53Called from Merlin_specific__Browse_raw.(**) in file \"src/ocaml/merlin_specific/browse_raw.ml\" (inlined),line 233,characters 11-25Called from Merlin_specific__Browse_raw.of_expression_desc in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 328,characters 4-63Called from Merlin_analysis__Destruct.get_every_pattern in file \"src/analysis/destruct.ml\",lines 263-289,characters 8-31Called from Merlin_analysis__Destruct.node in file \"src/analysis/destruct.ml\",line 591,characters 40-65Called from Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 45,characters 8-15Re-raised at Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 62,characters 10-24Called from Merlin_utils__Misc.protect_refs.(fun) in file \"src/utils/misc.ml\",line 82,characters 10-14Re-raised at Merlin_utils__Misc.protect_refs.(fun) in file \"src/utils/misc.ml\",line 84,characters 38-45Called from Ocaml_typing__Persistent_env.without_cmis in file \"src/ocaml/typing/persistent_env.ml\",lines 156-158,characters 10-27Called from Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 695,characters 8-12Re-raised at Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 697,characters 30-39Called from Dune__exe__New_commands.run in file \"src/frontend/ocamlmerlin/new/new_commands.ml\",line 65,characters 15-53Called from Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 695,characters 8-12Re-raised at Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 697,characters 30-39Called from Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 45,characters 8-15Re-raised at Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 62,characters 10-24Called from Stdlib__Fun.protect in file \"fun.ml\",line 34,characters 8-15Re-raised at Stdlib__Fun.protect in file \"fun.ml\",line 39,characters 6-52Called from Merlin_kernel__Mocaml.with_state in file \"src/kernel/mocaml.ml\",line 18,characters 8-38Re-raised at Merlin_kernel__Mocaml.with_state in file \"src/kernel/mocaml.ml\",line 20,characters 42-53Called from Dune__exe__New_merlin.run.(fun) in file \"src/frontend/ocamlmerlin/new/new_merlin.ml\",lines 103-104,characters 14-50", + "notifications": [] + } + + $ cat >fun.ml < let _ = match true with _ as bb -> bb + > EOF + + $ $MERLIN single case-analysis -start 1:24 -end 1:25 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' { "class": "return", @@ -13,14 +27,28 @@ Test case-analysis in the middle of a [fun]. { "start": { "line": 1, - "col": 9 + "col": 24 }, "end": { "line": 1, - "col": 11 + "col": 31 } }, - "((false as bb) : bool)|((true as bb) : bool)" + "(false as bb)|(true as bb)" ], "notifications": [] } + + $ cat >fun.ml < let f x ((false as bb) : bool) y = something + > EOF + +FIXME UPGRADE 5.2: this was working before the upgrade + $ $MERLIN single case-analysis -start 1:10 -end 1:15 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "exception", + "value": "File \"src/analysis/destruct.ml\",line 265,characters 51-57: Assertion failedRaised at Merlin_analysis__Destruct.get_every_pattern.(fun) in file \"src/analysis/destruct.ml\",line 265,characters 51-63Called from Merlin_specific__Browse_raw.(**) in file \"src/ocaml/merlin_specific/browse_raw.ml\" (inlined),line 233,characters 11-25Called from Merlin_specific__Browse_raw.of_pattern in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 274,characters 2-55Called from Merlin_specific__Browse_raw.list_fold in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 236,characters 37-53Called from Merlin_specific__Browse_raw.(**) in file \"src/ocaml/merlin_specific/browse_raw.ml\" (inlined),line 233,characters 11-25Called from Merlin_specific__Browse_raw.of_expression_desc in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 328,characters 4-63Called from Merlin_analysis__Destruct.get_every_pattern in file \"src/analysis/destruct.ml\",lines 263-289,characters 8-31Called from Merlin_analysis__Destruct.node in file \"src/analysis/destruct.ml\",line 591,characters 40-65Called from Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 45,characters 8-15Re-raised at Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 62,characters 10-24Called from Merlin_utils__Misc.protect_refs.(fun) in file \"src/utils/misc.ml\",line 82,characters 10-14Re-raised at Merlin_utils__Misc.protect_refs.(fun) in file \"src/utils/misc.ml\",line 84,characters 38-45Called from Ocaml_typing__Persistent_env.without_cmis in file \"src/ocaml/typing/persistent_env.ml\",lines 156-158,characters 10-27Called from Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 695,characters 8-12Re-raised at Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 697,characters 30-39Called from Dune__exe__New_commands.run in file \"src/frontend/ocamlmerlin/new/new_commands.ml\",line 65,characters 15-53Called from Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 695,characters 8-12Re-raised at Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 697,characters 30-39Called from Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 45,characters 8-15Re-raised at Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 62,characters 10-24Called from Stdlib__Fun.protect in file \"fun.ml\",line 34,characters 8-15Re-raised at Stdlib__Fun.protect in file \"fun.ml\",line 39,characters 6-52Called from Merlin_kernel__Mocaml.with_state in file \"src/kernel/mocaml.ml\",line 18,characters 8-38Re-raised at Merlin_kernel__Mocaml.with_state in file \"src/kernel/mocaml.ml\",line 20,characters 42-53Called from Dune__exe__New_merlin.run.(fun) in file \"src/frontend/ocamlmerlin/new/new_merlin.ml\",lines 103-104,characters 14-50", + "notifications": [] + } diff --git a/tests/test-dirs/errors/function-warnings.t b/tests/test-dirs/errors/function-warnings.t new file mode 100644 index 0000000000..13fdb477a6 --- /dev/null +++ b/tests/test-dirs/errors/function-warnings.t @@ -0,0 +1,48 @@ + $ $MERLIN single errors -filename fun_bad.ml < let f () = () + > let x = f () 0 + > EOF + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 14 + }, + "type": "typer", + "sub": [ + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 14 + }, + "message": "Hint: Did you forget a ';'?" + }, + { + "start": { + "line": 2, + "col": 8 + }, + "end": { + "line": 2, + "col": 14 + }, + "message": "This extra argument is not expected." + } + ], + "valid": true, + "message": "The function f has type unit -> unit + It is applied to too many arguments" + } + ], + "notifications": [] + } diff --git a/tests/test-dirs/errors/issue1222.t b/tests/test-dirs/errors/issue1222.t index 277ced577d..0a9ad6ab2d 100644 --- a/tests/test-dirs/errors/issue1222.t +++ b/tests/test-dirs/errors/issue1222.t @@ -1,3 +1,5 @@ +FIXME UPGRADE 5.2: The first error is still a parser error... Following errors +should be ignored ? $ $MERLIN single errors -filename issue1222.ml < let minimal : type a. 'a t > EOF @@ -13,10 +15,38 @@ "line": 1, "col": 24 }, - "type": "parser", + "type": "typer", "sub": [], "valid": true, "message": "In this scoped type, variable 'a is reserved for the local type a." + }, + { + "start": { + "line": 1, + "col": 25 + }, + "end": { + "line": 1, + "col": 26 + }, + "type": "typer", + "sub": [], + "valid": true, + "message": "Unbound type constructor t" + }, + { + "start": { + "line": 2, + "col": 0 + }, + "end": { + "line": 2, + "col": 0 + }, + "type": "parser", + "sub": [], + "valid": true, + "message": "Syntax error, expecting `='" } ], "notifications": [] diff --git a/tests/test-dirs/function-recovery.t b/tests/test-dirs/function-recovery.t index d8e16ed3e6..ea0e83b143 100644 --- a/tests/test-dirs/function-recovery.t +++ b/tests/test-dirs/function-recovery.t @@ -34,18 +34,17 @@ None expression (test.ml[3,104+11]..test.ml[3,104+28]) Texp_function - Nolabel [ - + Nolabel + Param_pat pattern (test.ml[3,104+15]..test.ml[3,104+17]) Tpat_construct \"()\" [] None - expression (test.ml[3,104+21]..test.ml[3,104+28]) - attribute \"merlin.loc\" - [] - Texp_ident \"problem/275\" ] + Tfunction_body + expression (test.ml[3,104+21]..test.ml[3,104+28]) + Texp_ident \"problem/276\" ] ] ] @@ -66,14 +65,14 @@ [ pattern (type.ml[1,0+4]..type.ml[1,0+5]) - Tpat_var \"f/275\" + Tpat_var \"f/276\" expression (type.ml[1,0+8]..type.ml[1,0+61]) extra Texp_newtype' \"t/278\" Texp_function - Nolabel [ - + Nolabel + Param_pat pattern (type.ml[1,0+22]..type.ml[1,0+25]) extra Tpat_extra_constraint @@ -84,40 +83,41 @@ Ttyp_constr \"t/278\" [] ] - Tpat_alias \"foo/277\" - pattern (type.ml[1,0+22]..type.ml[1,0+25]) + Tpat_alias \"foo/279\" + pattern (type.ml[1,0+22]..type.ml[1,0+25]) ghost + attribute \"merlin.hide\" + [] Tpat_any - expression (type.ml[1,0+39]..type.ml[1,0+61]) - attribute \"merlin.loc\" - [] - Texp_let Nonrec - [ - - pattern (type.ml[1,0+44]..type.ml[1,0+45]) - extra - Tpat_extra_constraint - core_type (type.ml[1,0+48]..type.ml[1,0+49]) - Ttyp_constr \"t/276\" - [] - Tpat_any - expression (type.ml[1,0+53]..type.ml[1,0+55]) - attribute \"merlin.incorrect\" + ] + Tfunction_body + expression (type.ml[1,0+39]..type.ml[1,0+61]) + Texp_let Nonrec + [ + + pattern (type.ml[1,0+44]..type.ml[1,0+45]) + extra + Tpat_extra_constraint + core_type (type.ml[1,0+48]..type.ml[1,0+49]) + Ttyp_constr \"t/278\" [] - 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_ident \"*type-error*/278\" - ] - expression (type.ml[1,0+59]..type.ml[1,0+61]) - attribute \"merlin.loc\" - [] - Texp_construct \"()\" + Tpat_any + expression (type.ml[1,0+53]..type.ml[1,0+55]) + 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_ident \"*type-error*/280\" + ] + expression (type.ml[1,0+59]..type.ml[1,0+61]) + attribute \"merlin.loc\" [] - ] + Texp_construct \"()\" + [] ] ] @@ -190,7 +190,7 @@ "ghost": false, "attrs": [], "kind": "pattern (test.ml[1,0+4]..test.ml[1,0+5]) - Tpat_var \"f/275\" + Tpat_var \"f/276\" ", "children": [] }, @@ -215,8 +215,25 @@ "col": 6 }, "end": { - "line": 4, - "col": 17 + "line": 1, + "col": 9 + }, + "ghost": false, + "attrs": [], + "kind": "pattern (test.ml[1,0+6]..test.ml[1,0+9]) + Tpat_var \"x/278\" + ", + "children": [] + }, + { + "filename": "test.ml", + "start": { + "line": 2, + "col": 4 + }, + "end": { + "line": 2, + "col": 13 }, "ghost": false, "attrs": [], @@ -225,29 +242,86 @@ { "filename": "test.ml", "start": { - "line": 1, - "col": 6 + "line": 2, + "col": 4 }, "end": { - "line": 1, - "col": 9 + "line": 2, + "col": 8 }, "ghost": false, - "attrs": [], - "kind": "pattern (test.ml[1,0+6]..test.ml[1,0+9]) - Tpat_var \"x/277\" + "attrs": [ + { + "start": { + "line": 0, + "col": -1 + }, + "end": { + "line": 0, + "col": -1 + }, + "name": "merlin.incorrect" + } + ], + "kind": "pattern (test.ml[2,27+4]..test.ml[2,27+8]) + attribute \"merlin.incorrect\" + [] + Tpat_any ", "children": [] }, { "filename": "test.ml", "start": { - "line": 1, - "col": 10 + "line": 2, + "col": 12 }, "end": { - "line": 4, - "col": 17 + "line": 2, + "col": 13 + }, + "ghost": false, + "attrs": [ + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 13 + }, + "name": "merlin.loc" + } + ], + "kind": "expression", + "children": [] + } + ] + }, + { + "filename": "test.ml", + "start": { + "line": 3, + "col": 4 + }, + "end": { + "line": 3, + "col": 15 + }, + "ghost": false, + "attrs": [], + "kind": "case", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 3, + "col": 4 + }, + "end": { + "line": 3, + "col": 10 }, "ghost": false, "attrs": [ @@ -261,293 +335,115 @@ "col": -1 }, "name": "merlin.incorrect" - }, + } + ], + "kind": "pattern (test.ml[3,41+4]..test.ml[3,41+10]) + attribute \"merlin.incorrect\" + [] + Tpat_any + ", + "children": [] + }, + { + "filename": "test.ml", + "start": { + "line": 3, + "col": 14 + }, + "end": { + "line": 3, + "col": 15 + }, + "ghost": false, + "attrs": [ { "start": { - "line": 0, - "col": -1 + "line": 3, + "col": 13 }, "end": { - "line": 0, - "col": -1 + "line": 3, + "col": 15 }, - "name": "merlin.saved-parts _" + "name": "merlin.loc" } ], "kind": "expression", - "children": [ + "children": [] + } + ] + }, + { + "filename": "test.ml", + "start": { + "line": 4, + "col": 4 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [], + "kind": "case", + "children": [ + { + "filename": "test.ml", + "start": { + "line": 4, + "col": 4 + }, + "end": { + "line": 4, + "col": 12 + }, + "ghost": false, + "attrs": [ { - "filename": "test.ml", "start": { - "line": 1, - "col": 18 + "line": 0, + "col": -1 }, "end": { - "line": 4, - "col": 17 + "line": 0, + "col": -1 }, - "ghost": false, - "attrs": [], - "kind": "expression", - "children": [ - { - "filename": "test.ml", - "start": { - "line": 2, - "col": 4 - }, - "end": { - "line": 2, - "col": 13 - }, - "ghost": false, - "attrs": [], - "kind": "case", - "children": [ - { - "filename": "test.ml", - "start": { - "line": 2, - "col": 4 - }, - "end": { - "line": 2, - "col": 8 - }, - "ghost": false, - "attrs": [], - "kind": "pattern (test.ml[2,27+4]..test.ml[2,27+8]) - Tpat_construct \"None\" - [] - None - ", - "children": [] - }, - { - "filename": "test.ml", - "start": { - "line": 2, - "col": 12 - }, - "end": { - "line": 2, - "col": 13 - }, - "ghost": false, - "attrs": [ - { - "start": { - "line": 2, - "col": 11 - }, - "end": { - "line": 2, - "col": 13 - }, - "name": "merlin.loc" - } - ], - "kind": "expression", - "children": [] - } - ] - }, - { - "filename": "test.ml", - "start": { - "line": 3, - "col": 4 - }, - "end": { - "line": 3, - "col": 15 - }, - "ghost": false, - "attrs": [], - "kind": "case", - "children": [ - { - "filename": "test.ml", - "start": { - "line": 3, - "col": 4 - }, - "end": { - "line": 3, - "col": 10 - }, - "ghost": false, - "attrs": [], - "kind": "pattern (test.ml[3,41+4]..test.ml[3,41+10]) - Tpat_construct \"Some\" - [ - pattern (test.ml[3,41+9]..test.ml[3,41+10]) - Tpat_constant Const_int 5 - ] - None - ", - "children": [ - { - "filename": "test.ml", - "start": { - "line": 3, - "col": 9 - }, - "end": { - "line": 3, - "col": 10 - }, - "ghost": false, - "attrs": [], - "kind": "pattern (test.ml[3,41+9]..test.ml[3,41+10]) - Tpat_constant Const_int 5 - ", - "children": [] - } - ] - }, - { - "filename": "test.ml", - "start": { - "line": 3, - "col": 14 - }, - "end": { - "line": 3, - "col": 15 - }, - "ghost": false, - "attrs": [ - { - "start": { - "line": 3, - "col": 13 - }, - "end": { - "line": 3, - "col": 15 - }, - "name": "merlin.loc" - } - ], - "kind": "expression", - "children": [] - } - ] - }, - { - "filename": "test.ml", - "start": { - "line": 4, - "col": 4 - }, - "end": { - "line": 4, - "col": 17 - }, - "ghost": false, - "attrs": [], - "kind": "case", - "children": [ - { - "filename": "test.ml", - "start": { - "line": 4, - "col": 4 - }, - "end": { - "line": 4, - "col": 12 - }, - "ghost": false, - "attrs": [], - "kind": "pattern (test.ml[4,57+4]..test.ml[4,57+12]) - Tpat_construct \"Some\" - [ - pattern (test.ml[4,57+9]..test.ml[4,57+12]) - Tpat_var \"_aa/278\" - ] - None - ", - "children": [ - { - "filename": "test.ml", - "start": { - "line": 4, - "col": 9 - }, - "end": { - "line": 4, - "col": 12 - }, - "ghost": false, - "attrs": [], - "kind": "pattern (test.ml[4,57+9]..test.ml[4,57+12]) - Tpat_var \"_aa/278\" + "name": "merlin.incorrect" + } + ], + "kind": "pattern (test.ml[4,57+4]..test.ml[4,57+12]) + attribute \"merlin.incorrect\" + [] + Tpat_any ", - "children": [] - } - ] - }, - { - "filename": "test.ml", - "start": { - "line": 4, - "col": 16 - }, - "end": { - "line": 4, - "col": 17 - }, - "ghost": false, - "attrs": [ - { - "start": { - "line": 4, - "col": 15 - }, - "end": { - "line": 4, - "col": 17 - }, - "name": "merlin.loc" - } - ], - "kind": "expression", - "children": [] - } - ] - } - ] - }, + "children": [] + }, + { + "filename": "test.ml", + "start": { + "line": 4, + "col": 16 + }, + "end": { + "line": 4, + "col": 17 + }, + "ghost": false, + "attrs": [ { - "filename": "test.ml", "start": { "line": 4, - "col": 16 + "col": 15 }, "end": { "line": 4, "col": 17 }, - "ghost": false, - "attrs": [ - { - "start": { - "line": 4, - "col": 15 - }, - "end": { - "line": 4, - "col": 17 - }, - "name": "merlin.loc" - } - ], - "kind": "expression", - "children": [] + "name": "merlin.loc" } - ] + ], + "kind": "expression", + "children": [] } ] } diff --git a/tests/test-dirs/no-escape.t/run.t b/tests/test-dirs/no-escape.t/run.t index 84c60655b5..6b1f49a020 100644 --- a/tests/test-dirs/no-escape.t/run.t +++ b/tests/test-dirs/no-escape.t/run.t @@ -212,7 +212,7 @@ unused case after } Syntax errors also shouldn't escape: - +FIXME UPGRADE 5.2: this is still a parser error $ echo "let f (_ : (module S with type 'a t = int)) = ()" | > $MERLIN single errors -filename "invalid_package_type.ml" { @@ -241,7 +241,7 @@ Syntax errors also shouldn't escape: "line": 1, "col": 41 }, - "type": "parser", + "type": "typer", "sub": [], "valid": true, "message": "invalid package type: parametrized types are not supported" diff --git a/tests/test-dirs/occurrences/issue1398.t/run.t b/tests/test-dirs/occurrences/issue1398.t/run.t index cefc396798..0cc6eaf859 100644 --- a/tests/test-dirs/occurrences/issue1398.t/run.t +++ b/tests/test-dirs/occurrences/issue1398.t/run.t @@ -1,5 +1,5 @@ Test finding occurrences of let-based binding operator, from reified syntax: - +FIXME UPGRADE 5.2: some of these locations are slightly off. $ $MERLIN single occurrences -identifier-at 3:11 ./issue1398.ml < ./issue1398.ml { "class": "return", @@ -17,7 +17,7 @@ Test finding occurrences of let-based binding operator, from reified syntax: { "start": { "line": 3, - "col": 10 + "col": 12 }, "end": { "line": 3, @@ -57,7 +57,7 @@ Test finding occurrences of and-based binding operator, from reified syntax: { "start": { "line": 3, - "col": 19 + "col": 21 }, "end": { "line": 3, @@ -154,5 +154,6 @@ FIXME -- some locs are inexact "col": 17 } } + ], "notifications": [] } diff --git a/tests/test-dirs/type-enclosing/underscore-ids.t b/tests/test-dirs/type-enclosing/underscore-ids.t index 3dcf1df667..9c63021ddb 100644 --- a/tests/test-dirs/type-enclosing/underscore-ids.t +++ b/tests/test-dirs/type-enclosing/underscore-ids.t @@ -282,6 +282,7 @@ We try several places in the identifier to check the result stability } 3.1 +FIXME UPGRADE 5.2: there is something wrong with the recovery here $ $MERLIN single type-enclosing -position 5:10 -filename under.ml < let aa = 4.2 > let f (x) : int = function @@ -292,18 +293,6 @@ We try several places in the identifier to check the result stability { "class": "return", "value": [ - { - "start": { - "line": 5, - "col": 9 - }, - "end": { - "line": 5, - "col": 12 - }, - "type": "int", - "tail": "no" - }, { "start": { "line": 5, @@ -313,31 +302,7 @@ We try several places in the identifier to check the result stability "line": 5, "col": 12 }, - "type": "int option", - "tail": "no" - }, - { - "start": { - "line": 2, - "col": 18 - }, - "end": { - "line": 5, - "col": 17 - }, - "type": "int option -> int", - "tail": "no" - }, - { - "start": { - "line": 2, - "col": 10 - }, - "end": { - "line": 5, - "col": 17 - }, - "type": "'a", + "type": "int", "tail": "no" }, { @@ -349,7 +314,7 @@ We try several places in the identifier to check the result stability "line": 5, "col": 17 }, - "type": "'a -> 'b", + "type": "'a -> int", "tail": "no" } ], diff --git a/tests/test-dirs/typing-recovery.t b/tests/test-dirs/typing-recovery.t index d22de62fe8..7b8a99ad3c 100644 --- a/tests/test-dirs/typing-recovery.t +++ b/tests/test-dirs/typing-recovery.t @@ -67,7 +67,7 @@ structure_item (test.ml[1,0+0]..test.ml[1,0+14]) Tstr_type Rec [ - type_declaration t/275 (test.ml[1,0+0]..test.ml[1,0+14]) + type_declaration t/276 (test.ml[1,0+0]..test.ml[1,0+14]) ptype_params = [] ptype_cstrs = @@ -76,11 +76,11 @@ Ttype_variant [ (test.ml[1,0+9]..test.ml[1,0+10]) - A/276 + A/277 [] None (test.ml[1,0+11]..test.ml[1,0+14]) - B/277 + B/278 [] None ] @@ -93,80 +93,83 @@ [ pattern (test.ml[2,15+4]..test.ml[2,15+5]) - Tpat_var \"f/278\" + Tpat_var \"f/279\" expression (test.ml[2,15+6]..test.ml[6,69+12]) ghost Texp_function - Nolabel [ - + Nolabel + Param_pat pattern (test.ml[2,15+7]..test.ml[2,15+8]) extra Tpat_extra_constraint core_type (test.ml[2,15+11]..test.ml[2,15+12]) - Ttyp_constr \"t/275\" + Ttyp_constr \"t/276\" + [] + Tpat_alias \"x/281\" + pattern (test.ml[2,15+7]..test.ml[2,15+8]) ghost + attribute \"merlin.hide\" [] - Tpat_alias \"x/280\" - 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/280\" - [ - + ] + Tfunction_body + 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/281\" + [ + + 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_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 \"()\" + Tpat_construct \"A\" + [] + None + expression (test.ml[4,46+9]..test.ml[4,46+11]) + attribute \"merlin.loc\" [] - + Texp_construct \"()\" + [] + + 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_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*/281\" - + 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*/282\" + + pattern (test.ml[6,69+4]..test.ml[6,69+5]) + Tpat_value 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*/282\" - ] - ] + 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*/283\" + ] ] ] @@ -224,7 +227,7 @@ structure_item (test2.ml[1,0+0]..test2.ml[1,0+14]) Tstr_type Rec [ - type_declaration t/275 (test2.ml[1,0+0]..test2.ml[1,0+14]) + type_declaration t/276 (test2.ml[1,0+0]..test2.ml[1,0+14]) ptype_params = [] ptype_cstrs = @@ -233,11 +236,11 @@ Ttype_variant [ (test2.ml[1,0+9]..test2.ml[1,0+10]) - A/276 + A/277 [] None (test2.ml[1,0+11]..test2.ml[1,0+14]) - B/277 + B/278 [] None ] @@ -250,38 +253,39 @@ [ pattern (test2.ml[2,15+4]..test2.ml[2,15+5]) - Tpat_var \"f/278\" + Tpat_var \"f/279\" expression (test2.ml[2,15+6]..test2.ml[2,15+24]) ghost Texp_function - Nolabel [ - + Nolabel + Param_pat pattern (test2.ml[2,15+7]..test2.ml[2,15+8]) attribute \"merlin.incorrect\" [] extra Tpat_extra_constraint core_type (test2.ml[2,15+11]..test2.ml[2,15+12]) - Ttyp_constr \"t/275\" + Ttyp_constr \"t/276\" [] 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) - ] - extra - Texp_constraint - core_type (test2.ml[2,15+16]..test2.ml[2,15+19]) - Ttyp_constr \"int/1!\" - [] - Texp_ident \"*type-error*/280\" ] + Tfunction_body + 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) + ] + extra + Texp_constraint + core_type (test2.ml[2,15+16]..test2.ml[2,15+19]) + Ttyp_constr \"int/1!\" + [] + Texp_ident \"*type-error*/281\" ] ] @@ -330,14 +334,14 @@ First a simple case: "value": "[ signature_item (test.mli[1,0+0]..test.mli[1,0+14]) Tsig_value - value_description foo1/275 (test.mli[1,0+0]..test.mli[1,0+14]) + value_description foo1/276 (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/276 (test.mli[3,16+0]..test.mli[3,16+21]) + value_description foo2/277 (test.mli[3,16+0]..test.mli[3,16+21]) core_type (test.mli[3,16+11]..test.mli[3,16+21]) Ttyp_tuple [ @@ -350,7 +354,7 @@ First a simple case: [] signature_item (test.mli[5,39+0]..test.mli[5,39+21]) Tsig_value - value_description foo3/277 (test.mli[5,39+0]..test.mli[5,39+21]) + value_description foo3/278 (test.mli[5,39+0]..test.mli[5,39+21]) core_type (test.mli[5,39+11]..test.mli[5,39+21]) Ttyp_tuple [ @@ -414,38 +418,38 @@ And now, with an error deep in a submodule: "value": "[ signature_item (test2.mli[1,0+0]..test2.mli[1,0+14]) Tsig_value - value_description foo1/275 (test2.mli[1,0+0]..test2.mli[1,0+14]) + value_description foo1/276 (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/281\" + Tsig_module \"M/282\" 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/276 (test2.mli[4,31+2]..test2.mli[4,31+17]) + value_description foo21/277 (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/280\" + Tsig_module \"N/281\" 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/277 (test2.mli[6,66+4]..test2.mli[6,66+20]) + value_description foo211/278 (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/278 (test2.mli[7,87+4]..test2.mli[7,87+27]) + value_description foo212/279 (test2.mli[7,87+4]..test2.mli[7,87+27]) core_type (test2.mli[7,87+17]..test2.mli[7,87+27]) Ttyp_tuple [ @@ -458,7 +462,7 @@ And now, with an error deep in a submodule: [] signature_item (test2.mli[8,115+4]..test2.mli[8,115+27]) Tsig_value - value_description foo213/279 (test2.mli[8,115+4]..test2.mli[8,115+27]) + value_description foo213/280 (test2.mli[8,115+4]..test2.mli[8,115+27]) core_type (test2.mli[8,115+17]..test2.mli[8,115+27]) Ttyp_tuple [ @@ -474,7 +478,7 @@ And now, with an error deep in a submodule: ] signature_item (test2.mli[12,154+0]..test2.mli[12,154+21]) Tsig_value - value_description foo3/282 (test2.mli[12,154+0]..test2.mli[12,154+21]) + value_description foo3/283 (test2.mli[12,154+0]..test2.mli[12,154+21]) core_type (test2.mli[12,154+11]..test2.mli[12,154+21]) Ttyp_tuple [ @@ -542,8 +546,10 @@ make sure we also handle that correctly in structures: core_type (test_ct.ml[1,0+11]..test_ct.ml[1,0+14]) Ttyp_constr \"int/1!\" [] - Tpat_alias \"foo1/275\" - pattern (test_ct.ml[1,0+4]..test_ct.ml[1,0+8]) + Tpat_alias \"foo1/276\" + pattern (test_ct.ml[1,0+4]..test_ct.ml[1,0+8]) ghost + attribute \"merlin.hide\" + [] Tpat_any expression (test_ct.ml[1,0+17]..test_ct.ml[1,0+18]) extra @@ -569,8 +575,10 @@ make sure we also handle that correctly in structures: core_type (test_ct.ml[3,20+17]..test_ct.ml[3,20+21]) Ttyp_any ] - Tpat_alias \"foo2/276\" - pattern (test_ct.ml[3,20+4]..test_ct.ml[3,20+8]) + Tpat_alias \"foo2/277\" + pattern (test_ct.ml[3,20+4]..test_ct.ml[3,20+8]) ghost + attribute \"merlin.hide\" + [] Tpat_any expression (test_ct.ml[3,20+24]..test_ct.ml[3,20+28]) extra @@ -609,8 +617,10 @@ make sure we also handle that correctly in structures: Ttyp_constr \"int/1!\" [] ] - Tpat_alias \"foo3/277\" - pattern (test_ct.ml[5,50+4]..test_ct.ml[5,50+8]) + Tpat_alias \"foo3/278\" + pattern (test_ct.ml[5,50+4]..test_ct.ml[5,50+8]) ghost + attribute \"merlin.hide\" + [] Tpat_any expression (test_ct.ml[5,50+23]..test_ct.ml[5,50+27]) extra From 5358cf53e30b80a9db74677a5a9fa370247a2433 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 16 Feb 2024 13:30:50 +0100 Subject: [PATCH 084/130] destruct: wip: stop raising when called on function parameters --- src/analysis/destruct.ml | 2 +- tests/test-dirs/destruct/destruct-fun.t | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index dd4dfb8093..9cd4880913 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -477,7 +477,7 @@ let find_branch patterns sub = is_sub_patt p1 ~sub || is_sub_patt p2 ~sub in let rec aux before = function - | [] -> raise Not_found + | [] -> raise Nothing_to_do | p :: after when is_sub_patt p ~sub -> before, after, p | p :: ps -> aux (p :: before) ps in diff --git a/tests/test-dirs/destruct/destruct-fun.t b/tests/test-dirs/destruct/destruct-fun.t index 44c915da48..088a3bdc3d 100644 --- a/tests/test-dirs/destruct/destruct-fun.t +++ b/tests/test-dirs/destruct/destruct-fun.t @@ -9,8 +9,8 @@ FIXME UPGRADE 5.2: this was working before the upgrade > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' { - "class": "exception", - "value": "File \"src/analysis/destruct.ml\",line 265,characters 51-57: Assertion failedRaised at Merlin_analysis__Destruct.get_every_pattern.(fun) in file \"src/analysis/destruct.ml\",line 265,characters 51-63Called from Merlin_specific__Browse_raw.(**) in file \"src/ocaml/merlin_specific/browse_raw.ml\" (inlined),line 233,characters 11-25Called from Merlin_specific__Browse_raw.of_pattern in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 274,characters 2-55Called from Merlin_specific__Browse_raw.list_fold in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 236,characters 37-53Called from Merlin_specific__Browse_raw.(**) in file \"src/ocaml/merlin_specific/browse_raw.ml\" (inlined),line 233,characters 11-25Called from Merlin_specific__Browse_raw.of_expression_desc in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 328,characters 4-63Called from Merlin_analysis__Destruct.get_every_pattern in file \"src/analysis/destruct.ml\",lines 263-289,characters 8-31Called from Merlin_analysis__Destruct.node in file \"src/analysis/destruct.ml\",line 591,characters 40-65Called from Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 45,characters 8-15Re-raised at Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 62,characters 10-24Called from Merlin_utils__Misc.protect_refs.(fun) in file \"src/utils/misc.ml\",line 82,characters 10-14Re-raised at Merlin_utils__Misc.protect_refs.(fun) in file \"src/utils/misc.ml\",line 84,characters 38-45Called from Ocaml_typing__Persistent_env.without_cmis in file \"src/ocaml/typing/persistent_env.ml\",lines 156-158,characters 10-27Called from Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 695,characters 8-12Re-raised at Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 697,characters 30-39Called from Dune__exe__New_commands.run in file \"src/frontend/ocamlmerlin/new/new_commands.ml\",line 65,characters 15-53Called from Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 695,characters 8-12Re-raised at Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 697,characters 30-39Called from Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 45,characters 8-15Re-raised at Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 62,characters 10-24Called from Stdlib__Fun.protect in file \"fun.ml\",line 34,characters 8-15Re-raised at Stdlib__Fun.protect in file \"fun.ml\",line 39,characters 6-52Called from Merlin_kernel__Mocaml.with_state in file \"src/kernel/mocaml.ml\",line 18,characters 8-38Re-raised at Merlin_kernel__Mocaml.with_state in file \"src/kernel/mocaml.ml\",line 20,characters 42-53Called from Dune__exe__New_merlin.run.(fun) in file \"src/frontend/ocamlmerlin/new/new_merlin.ml\",lines 103-104,characters 14-50", + "class": "error", + "value": "Nothing to do", "notifications": [] } @@ -48,7 +48,7 @@ FIXME UPGRADE 5.2: this was working before the upgrade > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' { - "class": "exception", - "value": "File \"src/analysis/destruct.ml\",line 265,characters 51-57: Assertion failedRaised at Merlin_analysis__Destruct.get_every_pattern.(fun) in file \"src/analysis/destruct.ml\",line 265,characters 51-63Called from Merlin_specific__Browse_raw.(**) in file \"src/ocaml/merlin_specific/browse_raw.ml\" (inlined),line 233,characters 11-25Called from Merlin_specific__Browse_raw.of_pattern in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 274,characters 2-55Called from Merlin_specific__Browse_raw.list_fold in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 236,characters 37-53Called from Merlin_specific__Browse_raw.(**) in file \"src/ocaml/merlin_specific/browse_raw.ml\" (inlined),line 233,characters 11-25Called from Merlin_specific__Browse_raw.of_expression_desc in file \"src/ocaml/merlin_specific/browse_raw.ml\",line 328,characters 4-63Called from Merlin_analysis__Destruct.get_every_pattern in file \"src/analysis/destruct.ml\",lines 263-289,characters 8-31Called from Merlin_analysis__Destruct.node in file \"src/analysis/destruct.ml\",line 591,characters 40-65Called from Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 45,characters 8-15Re-raised at Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 62,characters 10-24Called from Merlin_utils__Misc.protect_refs.(fun) in file \"src/utils/misc.ml\",line 82,characters 10-14Re-raised at Merlin_utils__Misc.protect_refs.(fun) in file \"src/utils/misc.ml\",line 84,characters 38-45Called from Ocaml_typing__Persistent_env.without_cmis in file \"src/ocaml/typing/persistent_env.ml\",lines 156-158,characters 10-27Called from Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 695,characters 8-12Re-raised at Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 697,characters 30-39Called from Dune__exe__New_commands.run in file \"src/frontend/ocamlmerlin/new/new_commands.ml\",line 65,characters 15-53Called from Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 695,characters 8-12Re-raised at Merlin_utils__Std.let_ref in file \"src/utils/std.ml\",line 697,characters 30-39Called from Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 45,characters 8-15Re-raised at Merlin_utils__Misc.try_finally in file \"src/utils/misc.ml\",line 62,characters 10-24Called from Stdlib__Fun.protect in file \"fun.ml\",line 34,characters 8-15Re-raised at Stdlib__Fun.protect in file \"fun.ml\",line 39,characters 6-52Called from Merlin_kernel__Mocaml.with_state in file \"src/kernel/mocaml.ml\",line 18,characters 8-38Re-raised at Merlin_kernel__Mocaml.with_state in file \"src/kernel/mocaml.ml\",line 20,characters 42-53Called from Dune__exe__New_merlin.run.(fun) in file \"src/frontend/ocamlmerlin/new/new_merlin.ml\",lines 103-104,characters 14-50", + "class": "error", + "value": "Nothing to do", "notifications": [] } From 729a8cc31e465c17b124a7af500b11f9ef5856ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 16 Feb 2024 13:34:25 +0100 Subject: [PATCH 085/130] Prepare for preview release --- .github/workflows/main.yml | 2 +- CHANGES.md | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index e259ad71d1..e1c81f68f8 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -40,7 +40,7 @@ jobs: - ubuntu-latest # - windows-latest ocaml-compiler: - - 5.1.x + - 5.2.x # The type of runner that the job will run on runs-on: ${{ matrix.os }} diff --git a/CHANGES.md b/CHANGES.md index 2e5df8269f..6f6da4ce1e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -14,6 +14,8 @@ merlin 4.14 Thu Feb 22 14:00:42 CET 2024 + merlin binary + - Preliminary support for OCaml 5.2 + - Some regressions in recovery and destruct are present. - Add a "heap_mbytes" field to Merlin server responses to report heap usage (#1717) - Add cache stats to telemetry (#1711) - Add new SyntaxDocument command to find information about the node under the cursor (#1706) From 4ab50e826a715cd444add1bda1e2bed889de5b2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 19 Feb 2024 13:24:29 +0100 Subject: [PATCH 086/130] recovery: fix issue with function recovery --- src/ocaml/typing/typecore.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index b7e7f25057..bf7de04965 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -4697,7 +4697,7 @@ and split_function_ty env ty_expected ~arg_label ~first ~in_function = (* Merlin: we recover with an expected type of 'a -> 'b *) let level = get_level (instance ty_expected) in raise_error (error(loc, env, err)); - (ty_expected, newvar2 level) + (newvar2 level, ty_expected) in let ty_arg = if is_optional arg_label then From 3a0f31bc8c409edc62d21cfeae76c05eeda5b67a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 19 Feb 2024 13:24:40 +0100 Subject: [PATCH 087/130] tests: more function recovery test --- .../type-enclosing/type-fun-recovery.t | 223 ++++++++++++++++++ .../test-dirs/type-enclosing/underscore-ids.t | 95 +++++++- 2 files changed, 317 insertions(+), 1 deletion(-) create mode 100644 tests/test-dirs/type-enclosing/type-fun-recovery.t diff --git a/tests/test-dirs/type-enclosing/type-fun-recovery.t b/tests/test-dirs/type-enclosing/type-fun-recovery.t new file mode 100644 index 0000000000..933d0caf5e --- /dev/null +++ b/tests/test-dirs/type-enclosing/type-fun-recovery.t @@ -0,0 +1,223 @@ +1. Here the expected type `int` is not even a function + $ cat >test.ml <<'EOF' + > let f (x) : int = function + > | None -> 3 + > | Some 5 -> 4 + > | Some _aa -> 4 + > EOF + +1.1 + $ $MERLIN single type-enclosing -position 4:10 \ + > -filename under.ml -filename under.ml test.ml <<'EOF' + > let f : int -> int = fun x -> match x with + > | Some 5 -> 4 + > | None -> 3 + > | Some _aa -> 4 + > EOF + + $ $MERLIN single type-enclosing -position 4:10 \ + > -filename under.ml -filename under.ml -filename under.ml test.ml <<'EOF' + > let f x : int = + > let () = ignore (2 * x) in + > 3.14 + > EOF + + $ $MERLIN single type-enclosing -position 2:22 \ + > -filename under.ml -filename under.ml int", + "tail": "no" + } + +4. Here we bind twice the same type + $ cat >test.ml <<'EOF' + > let f (type t t) x : int = + > let () = ignore (2 * x) in + > 3.14 + > EOF + + $ $MERLIN single type-enclosing -position 1:4 \ + > -filename under.ml int", + "tail": "no" + } + + $ cat >test.ml <<'EOF' + > let f (x : t) : int = + > let () = ignore (2 * x) in + > 3.14 + > EOF + + $ $MERLIN single type-enclosing -position 1:4 \ + > -filename under.ml int", + "tail": "no" + } + + $ $MERLIN single type-enclosing -position 2:22 \ + > -filename under.ml test.ml <<'EOF' + > let f ?(x : int) : int = + > let () = ignore (2 * x) in + > 3.14 + > EOF + + $ $MERLIN single type-enclosing -position 1:4 \ + > -filename under.ml int", + "tail": "no" + } + + $ $MERLIN single type-enclosing -position 2:22 \ + > -filename under.ml let aa = 4.2 + > let f (x) : int = function + > | None -> 3 + > | Some 5 -> 4 + > | Some _aa -> 4 + > EOF + { + "class": "return", + "value": "[ + structure_item (under.ml[1,0+0]..under.ml[1,0+12]) + Tstr_value Nonrec + [ + + pattern (under.ml[1,0+4]..under.ml[1,0+6]) + Tpat_var \"aa/276\" + expression (under.ml[1,0+9]..under.ml[1,0+12]) + Texp_constant Const_float 4.2 + ] + structure_item (under.ml[2,13+0]..under.ml[5,70+17]) + Tstr_value Nonrec + [ + + pattern (under.ml[2,13+4]..under.ml[2,13+5]) + Tpat_var \"f/277\" + expression (under.ml[2,13+6]..under.ml[5,70+17]) ghost + Texp_function + [ + Nolabel + Param_pat + pattern (under.ml[2,13+6]..under.ml[2,13+9]) + Tpat_var \"x/279\" + ] + Tfunction_cases (under.ml[2,13+18]..under.ml[5,70+17]) + Texp_constraint + core_type (under.ml[2,13+12]..under.ml[2,13+15]) + Ttyp_constr \"int/1!\" + [] + [ + + pattern (under.ml[3,40+4]..under.ml[3,40+8]) + Tpat_construct \"None\" + [] + None + expression (under.ml[3,40+12]..under.ml[3,40+13]) + attribute \"merlin.loc\" + [] + Texp_constant Const_int 3 + + pattern (under.ml[4,54+4]..under.ml[4,54+10]) + Tpat_construct \"Some\" + [ + pattern (under.ml[4,54+9]..under.ml[4,54+10]) + Tpat_constant Const_int 5 + ] + None + expression (under.ml[4,54+14]..under.ml[4,54+15]) + attribute \"merlin.loc\" + [] + Texp_constant Const_int 4 + + pattern (under.ml[5,70+4]..under.ml[5,70+12]) + Tpat_construct \"Some\" + [ + pattern (under.ml[5,70+9]..under.ml[5,70+12]) + Tpat_var \"_aa/280\" + ] + None + expression (under.ml[5,70+16]..under.ml[5,70+17]) + attribute \"merlin.loc\" + [] + Texp_constant Const_int 4 + ] + ] + ] + + + ", + "notifications": [] + } From b9a727dd039ccd5c87ab4fa6949255afcada898b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 19 Feb 2024 14:17:02 +0100 Subject: [PATCH 088/130] recovery: fix erroneous type repr MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Frédéric Bour --- src/ocaml/typing/msupport.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/ocaml/typing/msupport.ml b/src/ocaml/typing/msupport.ml index 211b9a81c9..0e59809885 100644 --- a/src/ocaml/typing/msupport.ml +++ b/src/ocaml/typing/msupport.ml @@ -28,7 +28,9 @@ open Std -let errors : (exn list ref * unit Btype.TypeHash.t) option ref = ref None +module RawTypeHash = Hashtbl.Make(Types.TransientTypeOps) + +let errors : (exn list ref * unit RawTypeHash.t) option ref = ref None let monitor_errors' = ref (ref false) let monitor_errors () = @@ -66,7 +68,7 @@ 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)); + errors := (Some (caught,RawTypeHash.create 3)); Misc.try_finally f ~always:(fun () -> errors := errors'; @@ -78,13 +80,13 @@ let uncatch_errors f = let erroneous_type_register te = let te = Types.Transient_expr.coerce te in match !errors with - | Some (_,h) -> Btype.TypeHash.replace h te () + | Some (_,h) -> RawTypeHash.replace h te () | None -> () let erroneous_type_check te = - (* let te = Types.Transient_expr.coerce te in *) + let te = Types.Transient_expr.coerce te in match !errors with - | Some (_,h) -> Btype.TypeHash.mem h te + | Some (_,h) -> RawTypeHash.mem h te | _ -> false let rec erroneous_expr_check e = From fce3c2758159cfddf50522423321d7ce8dd4b6da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 19 Feb 2024 14:19:31 +0100 Subject: [PATCH 089/130] test: promote improvements in testsuite --- tests/test-dirs/config/flags/unsafe.t | 32 -------- tests/test-dirs/function-recovery.t | 103 +++++++++++++++----------- 2 files changed, 59 insertions(+), 76 deletions(-) diff --git a/tests/test-dirs/config/flags/unsafe.t b/tests/test-dirs/config/flags/unsafe.t index d6379fc70b..60579f5e9a 100644 --- a/tests/test-dirs/config/flags/unsafe.t +++ b/tests/test-dirs/config/flags/unsafe.t @@ -9,8 +9,6 @@ Testing array desugaring "notifications": [] } -FIXME UPGRADE 5.2: this test show additionnal warnings after the 5.2 upgrade; probably a -type that should be marked as incorrect is not anymore. $ $MERLIN single errors -filename array_bad.ml < module Array = struct end > let x = [|0|].(0) @@ -31,20 +29,6 @@ type that should be marked as incorrect is not anymore. "sub": [], "valid": true, "message": "Unbound value Array.get" - }, - { - "start": { - "line": 2, - "col": 15 - }, - "end": { - "line": 2, - "col": 16 - }, - "type": "warning", - "sub": [], - "valid": true, - "message": "Warning 20: this argument will not be used by the function." } ], "notifications": [] @@ -69,8 +53,6 @@ type that should be marked as incorrect is not anymore. "notifications": [] } -FIXME UPGRADE 5.2: this test show additionnal warnings after the 5.2 upgrade; probably a -type that should be marked as incorrect is not anymore. $ $MERLIN single errors -filename unsafe_array_bad.ml -unsafe < module Array = struct end > let x = [|0|].(0) @@ -91,20 +73,6 @@ type that should be marked as incorrect is not anymore. "sub": [], "valid": true, "message": "Unbound value Array.unsafe_get" - }, - { - "start": { - "line": 2, - "col": 15 - }, - "end": { - "line": 2, - "col": 16 - }, - "type": "warning", - "sub": [], - "valid": true, - "message": "Warning 20: this argument will not be used by the function." } ], "notifications": [] diff --git a/tests/test-dirs/function-recovery.t b/tests/test-dirs/function-recovery.t index ea0e83b143..e9fbacb55e 100644 --- a/tests/test-dirs/function-recovery.t +++ b/tests/test-dirs/function-recovery.t @@ -10,7 +10,7 @@ "value": "[ structure_item (test.ml[1,0+0]..test.ml[3,104+28]) Tstr_module - ERROR_locate_from_inside_function_literal_used_as_non_function/278 + ERROR_locate_from_inside_function_literal_used_as_non_function/279 module_expr (test.ml[1,0+72]..test.ml[3,104+28]) Tmod_structure [ @@ -44,7 +44,16 @@ ] Tfunction_body expression (test.ml[3,104+21]..test.ml[3,104+28]) - Texp_ident \"problem/276\" + 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_ident \"*type-error*/277\" ] ] ] @@ -250,23 +259,11 @@ "col": 8 }, "ghost": false, - "attrs": [ - { - "start": { - "line": 0, - "col": -1 - }, - "end": { - "line": 0, - "col": -1 - }, - "name": "merlin.incorrect" - } - ], + "attrs": [], "kind": "pattern (test.ml[2,27+4]..test.ml[2,27+8]) - attribute \"merlin.incorrect\" - [] - Tpat_any + Tpat_construct \"None\" + [] + None ", "children": [] }, @@ -324,25 +321,34 @@ "col": 10 }, "ghost": false, - "attrs": [ + "attrs": [], + "kind": "pattern (test.ml[3,41+4]..test.ml[3,41+10]) + Tpat_construct \"Some\" + [ + pattern (test.ml[3,41+9]..test.ml[3,41+10]) + Tpat_constant Const_int 5 + ] + None + ", + "children": [ { + "filename": "test.ml", "start": { - "line": 0, - "col": -1 + "line": 3, + "col": 9 }, "end": { - "line": 0, - "col": -1 + "line": 3, + "col": 10 }, - "name": "merlin.incorrect" - } - ], - "kind": "pattern (test.ml[3,41+4]..test.ml[3,41+10]) - attribute \"merlin.incorrect\" - [] - Tpat_any + "ghost": false, + "attrs": [], + "kind": "pattern (test.ml[3,41+9]..test.ml[3,41+10]) + Tpat_constant Const_int 5 ", - "children": [] + "children": [] + } + ] }, { "filename": "test.ml", @@ -398,25 +404,34 @@ "col": 12 }, "ghost": false, - "attrs": [ + "attrs": [], + "kind": "pattern (test.ml[4,57+4]..test.ml[4,57+12]) + Tpat_construct \"Some\" + [ + pattern (test.ml[4,57+9]..test.ml[4,57+12]) + Tpat_var \"_aa/279\" + ] + None + ", + "children": [ { + "filename": "test.ml", "start": { - "line": 0, - "col": -1 + "line": 4, + "col": 9 }, "end": { - "line": 0, - "col": -1 + "line": 4, + "col": 12 }, - "name": "merlin.incorrect" - } - ], - "kind": "pattern (test.ml[4,57+4]..test.ml[4,57+12]) - attribute \"merlin.incorrect\" - [] - Tpat_any + "ghost": false, + "attrs": [], + "kind": "pattern (test.ml[4,57+9]..test.ml[4,57+12]) + Tpat_var \"_aa/279\" ", - "children": [] + "children": [] + } + ] }, { "filename": "test.ml", From 32378c281662ae253c9741ec1f9d3d4a3d862f16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 19 Feb 2024 17:03:07 +0100 Subject: [PATCH 090/130] occurrences: refactor and remove code related to project-wide occurrences. --- src/analysis/occurrences.ml | 41 +++++----------------------------- src/analysis/occurrences.mli | 7 ++++++ src/frontend/query_commands.ml | 4 ++-- 3 files changed, 15 insertions(+), 37 deletions(-) create mode 100644 src/analysis/occurrences.mli diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index f622d47999..dbf8e78edb 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -108,8 +108,6 @@ let index_buffer ~current_buffer_path ~local_defs () = Ast_iterators.iter_on_usages ~f local_defs; defs -let merge_tbl ~into tbl = Hashtbl.iter (Index_format.add into) tbl - (* A longident can have the form: A.B.x Right now we are only interested in values, but we will eventually want to index all occurrences of modules in such longidents. However there is an issue with that: we only have the @@ -147,27 +145,12 @@ let uid_and_loc_of_node env node = Some (val_val.val_uid, val_name.loc) | _ -> None -let loc_of_local_def ~local_defs uid = - (* WIP *) - (* todo: cache or specialize ? *) - let uid_to_locs_tbl : string Location.loc Types.Uid.Tbl.t = - Types.Uid.Tbl.create 64 - in - match local_defs with - | `Interface _ -> failwith "not implemented" - | `Implementation str -> - let iter = Ast_iterators.iter_on_defs ~uid_to_locs_tbl in - iter.structure iter str; - (* todo: optimize, the iterator could be more flexible *) - (* we could check equality and raise with the result as soon that it arrive *) - Shape.Uid.Tbl.find uid_to_locs_tbl uid - let comp_unit_of_uid = function | Shape.Uid.Compilation_unit comp_unit | Item { comp_unit; _ } -> Some comp_unit | Internal | Predef _ -> None -let locs_of ~config ~env ~local_defs ~pos ~node:_ path = +let locs_of ~config ~env ~local_defs ~pos path = log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" path (Lexing.print_position () pos); @@ -176,17 +159,13 @@ let locs_of ~config ~env ~local_defs ~pos ~node:_ path = ~config:{ mconfig = config; traverse_aliases=false; ml_or_mli = `ML} ~env ~local_defs ~pos path in - (* When we fail to find an exact definition we restrict the scope to the local - buffer *) let def = match locate_result with | `At_origin -> log ~title:"locs_of" "Cursor is on definition / declaration"; (* We are on a definition / declaration so we look for the node's uid *) - (* todo: refactor *) let browse = Mbrowse.of_typedtree local_defs in - let node = Mbrowse.enclosing pos [browse] in - let env, node = Mbrowse.leaf_node node in + let env, node = Mbrowse.leaf_node (Mbrowse.enclosing pos [browse]) in uid_and_loc_of_node env node | `Found { uid; location; approximated = false; _ } -> log ~title:"locs_of" "Found definition uid using locate: %a " @@ -216,22 +195,14 @@ let locs_of ~config ~env ~local_defs ~pos ~node:_ path = index_buffer ~current_buffer_path ~local_defs () in let buffer_locs = Hashtbl.find_opt buffer_index def_uid in - let locs = Option.value ~default: LidSet.empty buffer_locs in + let locs = Option.value ~default:LidSet.empty buffer_locs in let locs = log ~title:"occurrences" "Found %i locs" (LidSet.cardinal locs); LidSet.elements locs - |> List.filter_map ~f:(fun {Location.txt; loc} -> + |> List.map ~f:(fun {Location.txt; loc} -> log ~title:"occurrences" "Found occ: %s %a" (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc); - let loc = last_loc loc txt in - let fname = loc.Location.loc_start.Lexing.pos_fname in - if Filename.is_relative fname then begin - match Locate.find_source ~config loc fname with - | `Found (file, _) -> Some (set_fname ~file loc) - | `File_not_found msg -> - log ~title:"occurrences" "%s" msg; - None - end else Some loc) + last_loc loc txt) in let def_uid_is_in_current_unit = let uid_comp_unit = comp_unit_of_uid def_uid in @@ -240,4 +211,4 @@ let locs_of ~config ~env ~local_defs ~pos ~node:_ path = in if not def_uid_is_in_current_unit then Ok locs else Ok (set_fname ~file:current_buffer_path def_loc :: locs) - | None -> Error "nouid" + | None -> Error "Could not find the uid of the definition." diff --git a/src/analysis/occurrences.mli b/src/analysis/occurrences.mli new file mode 100644 index 0000000000..9e11c0972e --- /dev/null +++ b/src/analysis/occurrences.mli @@ -0,0 +1,7 @@ +val locs_of + : config:Mconfig.t + -> env:Env.t + -> local_defs:Mtyper.typedtree + -> pos:Lexing.position + -> string + -> (Warnings.loc list, string) result diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 92959b6449..ac362ac995 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -809,7 +809,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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, node = Mbrowse.leaf_node (Mtyper.node_at typer pos) in + let env, _node = Mbrowse.leaf_node (Mtyper.node_at typer pos) in let path = let path = reconstruct_identifier pipeline pos None in let path = Mreader_lexer.identifier_suffix path in @@ -819,7 +819,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = path in let locs = - Occurrences.locs_of ~config ~env ~local_defs ~node ~pos path + Occurrences.locs_of ~config ~env ~local_defs ~pos path |> Result.value ~default:[] in let loc_start l = l.Location.loc_start in From 8cd46cba3922c9258c734050314c48164b00f0d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 20 Feb 2024 16:31:37 +0100 Subject: [PATCH 091/130] occurrences: introduce a cache for the index The cache is based on the typer's stamp and should make successive occurrences queries faster. --- src/analysis/occurrences.ml | 27 +++++++++++++-- src/analysis/occurrences.mli | 2 +- src/frontend/query_commands.ml | 7 ++-- src/kernel/mtyper.ml | 6 +++- src/kernel/mtyper.mli | 2 ++ .../server-tests/buffer-index-cache.t | 33 +++++++++++++++++++ 6 files changed, 68 insertions(+), 9 deletions(-) create mode 100644 tests/test-dirs/server-tests/buffer-index-cache.t diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index dbf8e78edb..be4da7cf37 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -25,7 +25,7 @@ let decl_of_path_or_lid env namespace path lid = end | _ -> Env_lookup.loc path namespace env -let index_buffer ~current_buffer_path ~local_defs () = +let index_buffer_ ~current_buffer_path ~local_defs () = let {Logger. log} = Logger.for_section "index" in let defs = Hashtbl.create 64 in let module Shape_reduce = @@ -108,6 +108,25 @@ let index_buffer ~current_buffer_path ~local_defs () = Ast_iterators.iter_on_usages ~f local_defs; defs +let index_buffer = + (* Right now, we only cache the last used index. We could do better by caching + the index for every known buffer. *) + let cache = ref None in + fun ~current_buffer_path ~stamp ~local_defs () -> + let {Logger. log} = Logger.for_section "index" in + match !cache with + | Some (path, stamp', value) when + String.equal path current_buffer_path + && Int.equal stamp' stamp -> + log ~title:"index_cache" "Reusing cached value for path %s and stamp %i." + path stamp'; + value + | _ -> + log ~title:"index_cache" "No valid cache found, reindexing."; + let result = index_buffer_ ~current_buffer_path ~local_defs () in + cache := Some (current_buffer_path, stamp, result); + result + (* A longident can have the form: A.B.x Right now we are only interested in values, but we will eventually want to index all occurrences of modules in such longidents. However there is an issue with that: we only have the @@ -150,10 +169,11 @@ let comp_unit_of_uid = function | Item { comp_unit; _ } -> Some comp_unit | Internal | Predef _ -> None -let locs_of ~config ~env ~local_defs ~pos path = +let locs_of ~config ~env ~typer_result ~pos path = log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" path (Lexing.print_position () pos); + let local_defs = Mtyper.get_typedtree typer_result in let locate_result = Locate.from_string ~config:{ mconfig = config; traverse_aliases=false; ml_or_mli = `ML} @@ -192,7 +212,8 @@ let locs_of ~config ~env ~local_defs ~pos path = Logger.fmt (fun fmt -> Location.print_loc fmt def_loc); log ~title:"locs_of" "Indexing current buffer"; let buffer_index = - index_buffer ~current_buffer_path ~local_defs () + let stamp = Mtyper.get_stamp typer_result in + index_buffer ~current_buffer_path ~stamp ~local_defs () in let buffer_locs = Hashtbl.find_opt buffer_index def_uid in let locs = Option.value ~default:LidSet.empty buffer_locs in diff --git a/src/analysis/occurrences.mli b/src/analysis/occurrences.mli index 9e11c0972e..eea7b6b3e7 100644 --- a/src/analysis/occurrences.mli +++ b/src/analysis/occurrences.mli @@ -1,7 +1,7 @@ val locs_of : config:Mconfig.t -> env:Env.t - -> local_defs:Mtyper.typedtree + -> typer_result:Mtyper.result -> pos:Lexing.position -> string -> (Warnings.loc list, string) result diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index ac362ac995..8913d1b87d 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -806,10 +806,9 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | Occurrences (`Ident_at pos, _) -> let config = Mpipeline.final_config pipeline in - let typer = Mpipeline.typer_result pipeline in - let local_defs = Mtyper.get_typedtree typer in + let typer_result = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos in - let env, _node = Mbrowse.leaf_node (Mtyper.node_at typer pos) in + let env, _node = Mbrowse.leaf_node (Mtyper.node_at typer_result pos) in let path = let path = reconstruct_identifier pipeline pos None in let path = Mreader_lexer.identifier_suffix path in @@ -819,7 +818,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = path in let locs = - Occurrences.locs_of ~config ~env ~local_defs ~pos path + Occurrences.locs_of ~config ~env ~typer_result ~pos path |> Result.value ~default:[] in let loc_start l = l.Location.loc_start in diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index bae1e7a257..3b4b72db7d 100644 --- a/src/kernel/mtyper.ml +++ b/src/kernel/mtyper.ml @@ -47,6 +47,7 @@ type result = { initial_env : Env.t; initial_snapshot : Types.snapshot; initial_stamp : int; + stamp : int; typedtree : [ | `Interface of (Parsetree.signature_item, Typedtree.signature_item) item list @@ -168,8 +169,9 @@ let run config parsetree = | `Implementation parsetree -> type_implementation config caught parsetree | `Interface parsetree -> type_interface config caught parsetree in + let stamp = Ident.get_currentstamp () in Typecore.reset_delayed_checks (); - { config; initial_env; initial_snapshot; initial_stamp; typedtree; cache_stat } + { config; initial_env; initial_snapshot; initial_stamp; stamp; typedtree; cache_stat } let get_env ?pos:_ t = Option.value ~default:t.initial_env ( @@ -206,6 +208,8 @@ let get_typedtree t = let sig_items, sig_type = split_items l in `Interface {Typedtree. sig_items; sig_type; sig_final_env = get_env t} +let get_stamp t = t.stamp + 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); diff --git a/src/kernel/mtyper.mli b/src/kernel/mtyper.mli index fd6a7a6b77..58cedd9582 100644 --- a/src/kernel/mtyper.mli +++ b/src/kernel/mtyper.mli @@ -22,6 +22,8 @@ val get_env : ?pos:Msource.position -> result -> Env.t val get_typedtree : result -> typedtree +val get_stamp : result -> int + val get_errors : result -> exn list val initial_env : result -> Env.t diff --git a/tests/test-dirs/server-tests/buffer-index-cache.t b/tests/test-dirs/server-tests/buffer-index-cache.t new file mode 100644 index 0000000000..931efc47ab --- /dev/null +++ b/tests/test-dirs/server-tests/buffer-index-cache.t @@ -0,0 +1,33 @@ + $ cat >test.ml <<'EOF' + > let x = 36 + > let y = + > let z = x + x in + > z + x + > EOF + + $ $MERLIN server occurrences -identifier-at 4:6 \ + > -log-file log -log-section index \ + > -filename test.ml /dev/null + + $ cat log | grep index_cache -A1 | tail -n 1 + No valid cache found, reindexing. + + $ $MERLIN server occurrences -identifier-at 4:6 \ + > -log-file log -log-section index \ + > -filename test.ml /dev/null + + $ cat log | grep index_cache -A1 | tail -n 1 + Reusing cached value for path $TESTCASE_ROOT/test.ml and stamp 278. + + $ cat >>test.ml <<'EOF' + > let z = y + y + > EOF + + $ $MERLIN server occurrences -identifier-at 4:6 \ + > -log-file log -log-section index \ + > -filename test.ml /dev/null + + $ cat log | grep index_cache -A1 | tail -n 1 + No valid cache found, reindexing. + + $ $MERLIN server stop-server From 1bd0d88e1c2ed42dac61f7555beed043188f47b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 22 Feb 2024 14:46:33 +0100 Subject: [PATCH 092/130] index: remove unused index_format --- src/analysis/index_format.ml | 92 ------------------------------------ 1 file changed, 92 deletions(-) diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml index 45502fa4ff..6ad601e7a9 100644 --- a/src/analysis/index_format.ml +++ b/src/analysis/index_format.ml @@ -7,101 +7,9 @@ module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct | n -> n let compare (t1 : t) (t2 : t) = - (* TODO CHECK...*) match compare_pos t1.loc.loc_start t2.loc.loc_start with | 0 -> compare_pos t1.loc.loc_end t2.loc.loc_end | n -> n end module LidSet = Set.Make (Lid) - -(** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this key is - already present the locations are merged. *) -let add tbl uid locs = - try - let locations = Hashtbl.find tbl uid in - Hashtbl.replace tbl uid (LidSet.union locs locations) - with Not_found -> Hashtbl.add tbl uid locs - -type payload = { - defs : (Shape.Uid.t, LidSet.t) Hashtbl.t; - partials : (Shape.t, LidSet.t) Hashtbl.t; - unreduced : (Shape.t * Longident.t Location.loc) list; - load_path : string list; - cu_shape : (string, Shape.t) Hashtbl.t; -} - -type file_format = V1 of payload - -let pp_partials (fmt : Format.formatter) - (partials : (Shape.t, LidSet.t) Hashtbl.t) = - Format.fprintf fmt "{@["; - Hashtbl.iter - (fun shape locs -> - Format.fprintf fmt "@[shape: %a; locs:@ @[%a@]@]@;" Shape.print - shape - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") - (fun fmt { Location.txt; loc } -> - Format.fprintf fmt "%S: %a" - (try Longident.flatten txt |> String.concat "." with _ -> "") - Location.print_loc loc)) - (LidSet.elements locs)) - partials; - Format.fprintf fmt "@]}" - -let pp_unreduced (fmt : Format.formatter) - (unreduced : (Shape.t * Longident.t Location.loc) list) = - Format.fprintf fmt "{@["; - List.iter - (fun (shape, { Location.txt; loc }) -> - Format.fprintf fmt "@[shape: %a; locs:@ @[%s: %a@]@]@;" - Shape.print shape - (try Longident.flatten txt |> String.concat "." with _ -> "") - Location.print_loc loc) - unreduced; - Format.fprintf fmt "@]}" - -let pp_payload (fmt : Format.formatter) pl = - Format.fprintf fmt "%i uids:@ {@[" (Hashtbl.length pl.defs); - Hashtbl.iter - (fun uid locs -> - Format.fprintf fmt "@[uid: %a; locs:@ @[%a@]@]@;" - Shape.Uid.print uid - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;") - (fun fmt { Location.txt; loc } -> - Format.fprintf fmt "%S: %a" - (try Longident.flatten txt |> String.concat "." with _ -> "") - Location.print_loc loc)) - (LidSet.elements locs)) - pl.defs; - Format.fprintf fmt "@]},@ "; - Format.fprintf fmt "%i partial shapes:@ @[%a@],@ " - (Hashtbl.length pl.partials) - pp_partials pl.partials; - Format.fprintf fmt "%i unreduced shapes:@ @[%a@]@ " (List.length pl.unreduced) - pp_unreduced pl.unreduced; - Format.fprintf fmt "and shapes for CUS %s.@ " - (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq)) - -let pp (fmt : Format.formatter) ff = - match ff with V1 tbl -> Format.fprintf fmt "V1@,%a" pp_payload tbl - -let ext = "uideps" - -let write ~file tbl = - let oc = open_out_bin file in - Marshal.to_channel oc (V1 tbl) []; - close_out oc - -let read ~file = - let ic = open_in_bin file in - try - let payload = - match Marshal.from_channel ic with V1 payload -> payload - (* TODO is that "safe" ? We probably want some magic number *) - in - close_in ic; - payload - with e -> raise e (* todo *) From 3b4d0d948b1ee18666b150e96cc30f17d0027544 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 22 Feb 2024 17:19:19 +0100 Subject: [PATCH 093/130] index: re-add missing function --- src/analysis/index_format.ml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml index 6ad601e7a9..12957f1d9d 100644 --- a/src/analysis/index_format.ml +++ b/src/analysis/index_format.ml @@ -13,3 +13,11 @@ module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct end module LidSet = Set.Make (Lid) + +(** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this key is + already present the locations are merged. *) + let add tbl uid locs = + try + let locations = Hashtbl.find tbl uid in + Hashtbl.replace tbl uid (LidSet.union locs locations) + with Not_found -> Hashtbl.add tbl uid locs From f7512b20a5c7507fd75b8319260e0506b7ce0d96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 29 Feb 2024 13:23:19 +0000 Subject: [PATCH 094/130] occurrences: use the cache, Luke ! --- src/analysis/occurrences.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index be4da7cf37..78ab680474 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -35,11 +35,11 @@ let index_buffer_ ~current_buffer_path ~local_defs () = let read_unit_shape ~unit_name = log ~title:"read_unit_shape" "inspecting %s" unit_name; let cmt = Format.sprintf "%s.cmt" unit_name in - match Cmt_format.read (Load_path.find_normalized cmt) with - | _, Some cmt_infos -> + match Cmt_cache.read (Load_path.find_normalized cmt) with + | { cmt_infos = { cmt_impl_shape; _ }; _ } -> log ~title:"read_unit_shape" "shapes loaded for %s" unit_name; - cmt_infos.cmt_impl_shape - | exception _ | _ -> + cmt_impl_shape + | exception _ -> log ~title:"read_unit_shape" "failed to find %s" unit_name; None end) From dbdd17d61c725488076a1616d2a013ba4395fdd6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 1 Mar 2024 10:49:03 +0000 Subject: [PATCH 095/130] shapes: don't read_back entire modules in alias case --- src/ocaml/typing/shape_reduce.ml | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/src/ocaml/typing/shape_reduce.ml b/src/ocaml/typing/shape_reduce.ml index 8706038fa2..21a900c458 100644 --- a/src/ocaml/typing/shape_reduce.ml +++ b/src/ocaml/typing/shape_reduce.ml @@ -271,6 +271,22 @@ end) = struct | NComp_unit s -> Comp_unit s | NError s -> Error s + (* When interested only of in the uid of aliased modules we do not read_back + the entire shape of the module, just enough to unroll the chain of aliases. + *) + let read_back_aliases_uids env (nf : nf) = + let force (Thunk (local_env, t)) = + reduce_ { env with local_env } t + in + let rec aux acc (nf : nf) = match nf with + | { uid = Some uid; desc = NAlias dnf; _ } -> + aux (uid::acc) (force dnf) + | { uid = Some uid; _ } -> + Resolved_alias (List.rev (uid::acc)) + | { uid = None; _ } -> Internal_error_missing_uid + in + aux [] nf + (* Sharing the memo tables is safe at the level of a compilation unit since idents should be unique *) let reduce_memo_table = Hashtbl.create 42 @@ -300,14 +316,6 @@ end) = struct | NError _ -> false | NLeaf -> false - let get_aliases_uids (t : t) = - let rec aux acc (t : t) = match t with - | { uid = Some uid; desc = Alias t; _ } -> aux (uid::acc) t - | { uid = Some uid; _ } -> Resolved_alias (List.rev (uid::acc)) - | _ -> Internal_error_missing_uid - in - aux [] t - let reduce_for_uid global_env t = let fuel = ref Params.fuel in let local_env = Ident.Map.empty in @@ -323,7 +331,7 @@ end) = struct Unresolved (read_back env nf) else match nf with | { desc = NAlias _; approximated = false; _ } -> - get_aliases_uids (read_back env nf) + read_back_aliases_uids env nf | { uid = Some uid; approximated = false; _ } -> Resolved uid | { uid; approximated = true; _ } -> From e75c892f5a7fc396c528ff30b6fcb4ab6bd1024c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 15 Apr 2024 19:21:35 +0200 Subject: [PATCH 096/130] upstream: pull changes from ocaml/ocaml --- upstream/ocaml_502/base-rev.txt | 2 +- upstream/ocaml_502/file_formats/cmi_format.ml | 4 +- upstream/ocaml_502/file_formats/cmt_format.ml | 4 +- upstream/ocaml_502/parsing/unit_info.ml | 5 +- upstream/ocaml_502/parsing/unit_info.mli | 8 +- upstream/ocaml_502/typing/ctype.ml | 2 +- .../typing/includemod_errorprinter.ml | 7 +- upstream/ocaml_502/typing/printtyp.ml | 7 +- upstream/ocaml_502/typing/printtyped.ml | 14 ++- upstream/ocaml_502/typing/shape_reduce.ml | 63 ++++++------ upstream/ocaml_502/typing/shape_reduce.mli | 4 +- upstream/ocaml_502/typing/signature_group.mli | 4 +- upstream/ocaml_502/typing/typecore.ml | 4 +- upstream/ocaml_502/typing/typedecl.ml | 37 ++++++- upstream/ocaml_502/typing/typedecl.mli | 3 + upstream/ocaml_502/typing/typemod.ml | 79 ++++++++++++--- upstream/ocaml_502/typing/typemod.mli | 1 + upstream/ocaml_502/typing/typetexp.ml | 34 +++---- upstream/ocaml_502/typing/typetexp.mli | 4 + upstream/ocaml_502/typing/value_rec_check.ml | 98 +++++++++---------- upstream/ocaml_502/typing/value_rec_types.mli | 29 ++---- 21 files changed, 236 insertions(+), 177 deletions(-) diff --git a/upstream/ocaml_502/base-rev.txt b/upstream/ocaml_502/base-rev.txt index b7ed60003b..1f82cfe9c7 100644 --- a/upstream/ocaml_502/base-rev.txt +++ b/upstream/ocaml_502/base-rev.txt @@ -1 +1 @@ -02b39701d81ef4d4f5824a2d018e6387b1eeb5a7 +d38925dd59a2e620fad19ea8b14e90e4a4c1fb24 diff --git a/upstream/ocaml_502/file_formats/cmi_format.ml b/upstream/ocaml_502/file_formats/cmi_format.ml index f4d19fa0ee..9b29030ca2 100644 --- a/upstream/ocaml_502/file_formats/cmi_format.ml +++ b/upstream/ocaml_502/file_formats/cmi_format.ml @@ -42,7 +42,7 @@ type cmi_infos = { } let input_cmi ic = - let (name, sign) = (input_value ic : header) in + let (name, sign) = (Compression.input_value ic : header) in let crcs = (input_value ic : crcs) in let flags = (input_value ic : flags) in { @@ -84,7 +84,7 @@ let read_cmi filename = let output_cmi filename oc cmi = (* beware: the provided signature must have been substituted for saving *) output_string oc Config.cmi_magic_number; - Marshal.(to_channel oc ((cmi.cmi_name, cmi.cmi_sign) : header) [Compression]); + Compression.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 diff --git a/upstream/ocaml_502/file_formats/cmt_format.ml b/upstream/ocaml_502/file_formats/cmt_format.ml index 65f2494c6f..853aeec8f0 100644 --- a/upstream/ocaml_502/file_formats/cmt_format.ml +++ b/upstream/ocaml_502/file_formats/cmt_format.ml @@ -380,11 +380,11 @@ let index_occurrences binary_annots = exception Error of error -let input_cmt ic = (input_value ic : cmt_infos) +let input_cmt ic = (Compression.input_value ic : cmt_infos) let output_cmt oc cmt = output_string oc Config.cmt_magic_number; - Marshal.(to_channel oc (cmt : cmt_infos) [Compression]) + Compression.output_value oc (cmt : cmt_infos) let read filename = (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) diff --git a/upstream/ocaml_502/parsing/unit_info.ml b/upstream/ocaml_502/parsing/unit_info.ml index b2e081a221..03e8d44949 100644 --- a/upstream/ocaml_502/parsing/unit_info.ml +++ b/upstream/ocaml_502/parsing/unit_info.ml @@ -103,9 +103,12 @@ let cmti f = mk_artifact ".cmti" f let annot f = mk_artifact ".annot" f let companion_obj f = companion_artifact Config.ext_obj f -let companion_cmi f = companion_artifact ".cmi" f let companion_cmt f = companion_artifact ".cmt" f +let companion_cmi f = + let prefix = Misc.chop_extensions f.Artifact.filename in + { f with Artifact.filename = prefix ^ ".cmi"} + let mli_from_artifact f = Artifact.prefix f ^ !Config.interface_suffix let mli_from_source u = let prefix = Filename.remove_extension (source_file u) in diff --git a/upstream/ocaml_502/parsing/unit_info.mli b/upstream/ocaml_502/parsing/unit_info.mli index 48acafc06d..466a07a228 100644 --- a/upstream/ocaml_502/parsing/unit_info.mli +++ b/upstream/ocaml_502/parsing/unit_info.mli @@ -124,10 +124,16 @@ val annot: t -> Artifact.t extension of its filename. Those functions purposefully do not cover all artifact kinds because we want to track which artifacts are assumed to be bundled together. *) -val companion_cmi: Artifact.t -> Artifact.t val companion_obj: Artifact.t -> Artifact.t val companion_cmt: Artifact.t -> Artifact.t +val companion_cmi: Artifact.t -> Artifact.t +(** Beware that [companion_cmi a] strips all extensions from the + filename of [a] before adding the [".cmi"] suffix contrarily to + the other functions which only remove the rightmost extension. + In other words, the companion cmi of a file [something.d.cmo] is + [something.cmi] and not [something.d.cmi]. +*) (** {1:ml_mli_cmi_interaction Mli and cmi derived from implementation files } *) diff --git a/upstream/ocaml_502/typing/ctype.ml b/upstream/ocaml_502/typing/ctype.ml index 6202e8e65f..8e7c35bb39 100644 --- a/upstream/ocaml_502/typing/ctype.ml +++ b/upstream/ocaml_502/typing/ctype.ml @@ -1841,7 +1841,7 @@ let rec occur_rec env allow_recursive visited ty0 ty = 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 + let ty' = try_expand_head try_expand_safe 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' diff --git a/upstream/ocaml_502/typing/includemod_errorprinter.ml b/upstream/ocaml_502/typing/includemod_errorprinter.ml index 5c538592fa..ab348c1e3b 100644 --- a/upstream/ocaml_502/typing/includemod_errorprinter.ml +++ b/upstream/ocaml_502/typing/includemod_errorprinter.ml @@ -780,10 +780,11 @@ and functor_symptom ~expansion_token ~env ~before ~ctx = function 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 , _ -> + | _ :: _ as missings, _ -> if expansion_token then - with_context ctx missing_field a - :: List.map (Location.msg "%a" missing_field) l + let init_missings, last_missing = Misc.split_last missings in + List.map (Location.msg "%a" missing_field) init_missings + @ [ with_context ctx missing_field last_missing ] @ before else before diff --git a/upstream/ocaml_502/typing/printtyp.ml b/upstream/ocaml_502/typing/printtyp.ml index 8c480b7954..18489a5e4f 100644 --- a/upstream/ocaml_502/typing/printtyp.ml +++ b/upstream/ocaml_502/typing/printtyp.ml @@ -497,6 +497,10 @@ let rec raw_type ppf ty = ty.scope raw_type_desc ty.desc end and raw_type_list tl = raw_list raw_type tl +and raw_lid_type_list tl = + raw_list (fun ppf (lid, typ) -> + fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) + tl and raw_type_desc ppf = function Tvar name -> fprintf ppf "Tvar %a" print_name name | Tarrow(l,t1,t2,c) -> @@ -546,8 +550,7 @@ and raw_type_desc ppf = function | Some(p,tl) -> fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) | Tpackage (p, fl) -> - fprintf ppf "@[Tpackage(@,%a@,%a)@]" path p - raw_type_list (List.map snd fl) + fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p raw_lid_type_list fl and raw_row_fixed ppf = function | None -> fprintf ppf "None" | Some Types.Fixed_private -> fprintf ppf "Some Fixed_private" diff --git a/upstream/ocaml_502/typing/printtyped.ml b/upstream/ocaml_502/typing/printtyped.ml index 25b6e6c6d4..f7bd8e48e6 100644 --- a/upstream/ocaml_502/typing/printtyped.ml +++ b/upstream/ocaml_502/typing/printtyped.ml @@ -341,7 +341,7 @@ and expression i ppf x = | 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; + list i (value_binding rf) ppf l; expression i ppf e; | Texp_function (params, body) -> line i ppf "Texp_function\n"; @@ -648,7 +648,7 @@ and class_expr i ppf x = 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 (value_binding rf) ppf l1; list i ident_x_expression_def ppf l2; class_expr i ppf ce; | Tcl_constraint (ce, Some ct, _, _, _) -> @@ -868,7 +868,7 @@ and structure_item i ppf x = 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; + list i (value_binding rf) ppf l; | Tstr_primitive vd -> line i ppf "Tstr_primitive\n"; value_description i ppf vd; @@ -954,8 +954,12 @@ and case end; expression (i+1) ppf c_rhs; -and value_binding i ppf x = - line i ppf "\n"; +and value_binding rec_flag i ppf x = + begin match rec_flag, x.vb_rec_kind with + | Nonrecursive, _ -> line i ppf "\n" + | Recursive, Static -> line i ppf "\n" + | Recursive, Dynamic -> line i ppf "\n" + end; attributes (i+1) ppf x.vb_attributes; pattern (i+1) ppf x.vb_pat; expression (i+1) ppf x.vb_expr diff --git a/upstream/ocaml_502/typing/shape_reduce.ml b/upstream/ocaml_502/typing/shape_reduce.ml index 718b212133..9f793e7b82 100644 --- a/upstream/ocaml_502/typing/shape_reduce.ml +++ b/upstream/ocaml_502/typing/shape_reduce.ml @@ -19,19 +19,18 @@ open Shape type result = | Resolved of Uid.t - | Resolved_alias of Uid.t list + | Resolved_alias of Uid.t * result | Unresolved of t | Approximated of Uid.t option | Internal_error_missing_uid -let print_result fmt result = +let rec print_result fmt result = match result with | Resolved uid -> Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid - | Resolved_alias uids -> - Format.fprintf fmt "@[Resolved_alias: %a@]@;" - Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ -> ") - Uid.print) uids + | Resolved_alias (uid, r) -> + Format.fprintf fmt "@[Alias: %a -> %a@]@;" + Uid.print uid print_result r | Unresolved shape -> Format.fprintf fmt "@[Unresolved: %a@]@;" print shape | Approximated (Some uid) -> @@ -152,17 +151,19 @@ end) = struct obtained by the same term traversal, adding binders in the same order, giving the same balanced trees: the environments have the same hash. -*) + *) + + and force env (Thunk (local_env, t)) = + reduce_ { env with local_env } t and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) = let reduce env t = reduce_ env t in let delay_reduce env t = Thunk (env.local_env, t) in - let force (Thunk (local_env, t)) = reduce { env with local_env } t in let return desc = { uid = t.uid; desc; approximated = t.approximated } in let rec force_aliases nf = match nf.desc with | NAlias delayed_nf -> - let nf = force delayed_nf in + let nf = force env delayed_nf in force_aliases nf | _ -> nf in @@ -197,7 +198,7 @@ end) = struct | NStruct (items) -> begin match Item.Map.find item items with | exception Not_found -> nored () - | nf -> force nf |> reset_uid_if_new_binding + | nf -> force env nf |> reset_uid_if_new_binding end | _ -> nored () @@ -218,7 +219,7 @@ end) = struct their binding-time [Uid.t]. *) | None -> return (NVar id) | Some def -> - begin match force def with + begin match force env def with | { uid = Some _; _ } as nf -> nf (* This var already has a binding uid *) | { uid = None; _ } as nf -> { nf with uid = t.uid } @@ -253,8 +254,7 @@ end) = struct and read_back_desc env desc = let read_back nf = read_back env nf in - let read_back_force (Thunk (local_env, t)) = - read_back (reduce_ { env with local_env } t) in + let read_back_force dnf = read_back (force env dnf) in match desc with | NVar v -> Var v @@ -300,13 +300,20 @@ end) = struct | NError _ -> false | NLeaf -> false - let get_aliases_uids (t : t) = - let rec aux acc (t : t) = match t with - | { uid = Some uid; desc = Alias t; _ } -> aux (uid::acc) t - | { uid = Some uid; _ } -> Resolved_alias (List.rev (uid::acc)) - | _ -> Internal_error_missing_uid - in - aux [] t + let rec reduce_aliases_for_uid env (nf : nf) = + match nf with + | { uid = Some uid; desc = NAlias dnf; approximated = false; _ } -> + let result = reduce_aliases_for_uid env (force env dnf) in + Resolved_alias (uid, result) + | { uid = Some uid; approximated = false; _ } -> Resolved uid + | { uid; approximated = true } -> Approximated uid + | { uid = None; approximated = false; _ } -> + (* A missing Uid after a complete reduction means the Uid was first + missing in the shape which is a code error. Having the + [Missing_uid] reported will allow Merlin (or another tool working + with the index) to ask users to report the issue if it does happen. + *) + Internal_error_missing_uid let reduce_for_uid global_env t = let fuel = ref Params.fuel in @@ -321,20 +328,8 @@ end) = struct let nf = reduce_ env t in if is_stuck_on_comp_unit nf then Unresolved (read_back env nf) - else match nf with - | { desc = NAlias _; approximated = false; _ } -> - get_aliases_uids (read_back env nf) - | { uid = Some uid; approximated = false; _ } -> - Resolved uid - | { uid; approximated = true; _ } -> - Approximated uid - | { uid = None; approximated = false; _ } -> - (* A missing Uid after a complete reduction means the Uid was first - missing in the shape which is a code error. Having the - [Missing_uid] reported will allow Merlin (or another tool working - with the index) to ask users to report the issue if it does happen. - *) - Internal_error_missing_uid + else + reduce_aliases_for_uid env nf end module Local_reduce = diff --git a/upstream/ocaml_502/typing/shape_reduce.mli b/upstream/ocaml_502/typing/shape_reduce.mli index 5e409c3cd7..307bc7683f 100644 --- a/upstream/ocaml_502/typing/shape_reduce.mli +++ b/upstream/ocaml_502/typing/shape_reduce.mli @@ -18,10 +18,10 @@ (** The result of reducing a shape and looking for its uid *) type result = | Resolved of Shape.Uid.t (** Shape reduction succeeded and a uid was found *) - | Resolved_alias of Shape.Uid.t list (** Reduction led to an alias chain *) + | Resolved_alias of Shape.Uid.t * result (** Reduction led to an alias *) | Unresolved of Shape.t (** Result still contains [Comp_unit] terms *) | Approximated of Shape.Uid.t option - (** Reduction failed: it can arrive with first-clsss modules for example *) + (** Reduction failed: it can arrive with first-class modules for example *) | Internal_error_missing_uid (** Reduction succeeded but no uid was found, this should never happen *) diff --git a/upstream/ocaml_502/typing/signature_group.mli b/upstream/ocaml_502/typing/signature_group.mli index 0b736a5b45..a84925db3b 100644 --- a/upstream/ocaml_502/typing/signature_group.mli +++ b/upstream/ocaml_502/typing/signature_group.mli @@ -73,9 +73,7 @@ type in_place_patch = { (** [!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]. + for which [patch ~ghosts component] returns [Some (value,patch)]. The [ghosts] list is the current prefix of ghost components associated to [component] *) diff --git a/upstream/ocaml_502/typing/typecore.ml b/upstream/ocaml_502/typing/typecore.ml index 35d057aaea..9a54846656 100644 --- a/upstream/ocaml_502/typing/typecore.ml +++ b/upstream/ocaml_502/typing/typecore.ml @@ -5173,7 +5173,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = 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; vb_rec_kind = Not_recursive; + vb_loc=Location.none; vb_rec_kind = Dynamic; }], func let_var) } end @@ -5987,7 +5987,7 @@ and type_let ?check ?check_strict (fun (p, (e, _)) pvb -> (* vb_rec_kind will be computed later for recursive bindings *) {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes; - vb_loc=pvb.pvb_loc; vb_rec_kind = Not_recursive; + vb_loc=pvb.pvb_loc; vb_rec_kind = Dynamic; }) l spat_sexp_list in diff --git a/upstream/ocaml_502/typing/typedecl.ml b/upstream/ocaml_502/typing/typedecl.ml index b42e990a53..2db34361d0 100644 --- a/upstream/ocaml_502/typing/typedecl.ml +++ b/upstream/ocaml_502/typing/typedecl.ml @@ -1719,10 +1719,10 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env in let no_row = not (is_fixed_type sdecl) in let (tman, man) = match sdecl.ptype_manifest with - None -> None, None + None -> Misc.fatal_error "Typedecl.transl_with_constraint: no manifest" | Some sty -> let cty = transl_simple_type env ~closed:no_row sty in - Some cty, Some cty.ctyp_type + cty, 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 @@ -1756,7 +1756,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env && sdecl.ptype_private = Private then Location.deprecated loc "spurious use of private"; let type_kind, type_unboxed_default = - if arity_ok && man <> None then + if arity_ok then sig_decl.type_kind, sig_decl.type_unboxed_default else Type_abstract Definition, false @@ -1766,7 +1766,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env type_arity = arity; type_kind; type_private = priv; - type_manifest = man; + type_manifest = Some man; type_variance = []; type_separability = Types.Separability.default_signature ~arity; type_is_newtype = false; @@ -1826,7 +1826,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env typ_type = new_sig_decl; typ_cstrs = constraints; typ_loc = loc; - typ_manifest = tman; + typ_manifest = Some tman; typ_kind = Ttype_abstract; typ_private = sdecl.ptype_private; typ_attributes = sdecl.ptype_attributes; @@ -1834,6 +1834,33 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env end ~post:(fun ttyp -> generalize_decl ttyp.typ_type) +(* A simplified version of [transl_with_constraint], for the case of packages. + Package constraints are much simpler than normal with type constraints (e.g., + they can not have parameters and can only update abstract types.) *) +let transl_package_constraint ~loc env ty = + let new_sig_decl = + { type_params = []; + type_arity = 0; + type_kind = Type_abstract Definition; + type_private = Public; + type_manifest = Some ty; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = loc; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) + } + in + let new_type_immediate = + (* Typedecl_immediacy.compute_decl never raises *) + Typedecl_immediacy.compute_decl env new_sig_decl + in + { new_sig_decl with type_immediate = new_type_immediate } + (* Approximate a type declaration: just make all types abstract *) let abstract_type_decl ~injective arity = diff --git a/upstream/ocaml_502/typing/typedecl.mli b/upstream/ocaml_502/typing/typedecl.mli index 5598271b0a..52a3197f74 100644 --- a/upstream/ocaml_502/typing/typedecl.mli +++ b/upstream/ocaml_502/typing/typedecl.mli @@ -46,6 +46,9 @@ val transl_with_constraint: outer_env:Env.t -> Parsetree.type_declaration -> Typedtree.type_declaration +val transl_package_constraint: + loc:Location.t -> Env.t -> type_expr -> Types.type_declaration + val abstract_type_decl: injective:bool -> int -> type_declaration val approx_type_decl: Parsetree.type_declaration list -> diff --git a/upstream/ocaml_502/typing/typemod.ml b/upstream/ocaml_502/typing/typemod.ml index b8934f1713..486fcdcffc 100644 --- a/upstream/ocaml_502/typing/typemod.ml +++ b/upstream/ocaml_502/typing/typemod.ml @@ -58,6 +58,7 @@ type error = Longident.t * Path.t * Includemod.explanation | With_changes_module_alias of Longident.t * Ident.t * Path.t | With_cannot_remove_constrained_type + | With_package_manifest of Longident.t * type_expr | Repeated_name of Sig_component_kind.t * string | Non_generalizable of { vars : type_expr list; expression : type_expr } | Non_generalizable_module of @@ -466,11 +467,15 @@ type with_info = | With_modsubst of Longident.t loc * Path.t * Types.module_declaration | With_modtype of Typedtree.module_type | With_modtypesubst of Typedtree.module_type + | With_type_package of Typedtree.core_type + (* Package with type constraints only use this last case. Normal module + with constraints never use it. *) let merge_constraint initial_env loc sg lid constr = let destructive_substitution = match constr with - | With_type _ | With_module _ | With_modtype _ -> false + | With_type _ | With_module _ | With_modtype _ + | With_type_package _ -> false | With_typesubst _ | With_modsubst _ | With_modtypesubst _ -> true in let real_ids = ref [] in @@ -544,7 +549,7 @@ let merge_constraint initial_env loc sg lid constr = in return ~ghosts ~replace_by:(Some (Sig_type(id, newdecl, rs, priv))) - (Pident id, lid, Twith_type tdecl) + (Pident id, lid, Some (Twith_type tdecl)) | Sig_type(id, sig_decl, rs, priv) , [s], (With_type sdecl | With_typesubst sdecl as constr) when Ident.name id = s -> @@ -561,12 +566,26 @@ let merge_constraint initial_env loc sg lid constr = With_type _ -> return ~ghosts ~replace_by:(Some(Sig_type(id, newdecl, rs, priv))) - (Pident id, lid, Twith_type tdecl) + (Pident id, lid, Some (Twith_type tdecl)) | (* With_typesubst *) _ -> real_ids := [Pident id]; return ~ghosts ~replace_by:None - (Pident id, lid, Twith_typesubst tdecl) + (Pident id, lid, Some (Twith_typesubst tdecl)) end + | Sig_type(id, sig_decl, rs, priv), [s], With_type_package cty + when Ident.name id = s -> + begin match sig_decl.type_manifest with + | None -> () + | Some ty -> + raise (Error(loc, outer_sig_env, With_package_manifest (lid.txt, ty))) + end; + let tdecl = + Typedecl.transl_package_constraint ~loc outer_sig_env cty.ctyp_type + in + check_type_decl outer_sig_env sg_for_env loc id None tdecl sig_decl; + let tdecl = { tdecl with type_manifest = None } in + return ~ghosts ~replace_by:(Some(Sig_type(id, tdecl, rs, priv))) + (Pident id, lid, None) | Sig_modtype(id, mtd, priv), [s], (With_modtype mty | With_modtypesubst mty) when Ident.name id = s -> @@ -588,7 +607,7 @@ let merge_constraint initial_env loc sg lid constr = in return ~replace_by:(Some(Sig_modtype(id, mtd', priv))) - (Pident id, lid, Twith_modtype mty) + (Pident id, lid, Some (Twith_modtype mty)) else begin let path = Pident id in real_ids := [path]; @@ -596,7 +615,8 @@ let merge_constraint initial_env loc sg lid constr = | Mty_ident _ -> () | mty -> unpackable_modtype := Some mty end; - return ~replace_by:None (Pident id, lid, Twith_modtypesubst mty) + return ~replace_by:None + (Pident id, lid, Some (Twith_modtypesubst mty)) end | Sig_module(id, pres, md, rs, priv), [s], With_module {lid=lid'; md=md'; path; remove_aliases} @@ -610,7 +630,7 @@ let merge_constraint initial_env loc sg lid constr = newmd.md_type md.md_type); return ~replace_by:(Some(Sig_module(id, pres, newmd, rs, priv))) - (Pident id, lid, Twith_module (path, lid')) + (Pident id, lid, Some (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 @@ -619,7 +639,8 @@ let merge_constraint initial_env loc sg lid constr = (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')) + return ~replace_by:None + (Pident id, lid, Some (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 @@ -654,7 +675,7 @@ let merge_constraint initial_env loc sg lid constr = !unpackable_modtype sg; let sg = match tcstr with - | (_, _, Twith_typesubst tdecl) -> + | (_, _, Some (Twith_typesubst tdecl)) -> let how_to_extend_subst = let sdecl = match constr with @@ -683,7 +704,7 @@ let merge_constraint initial_env loc sg lid constr = 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, _)) -> + | (_, _, Some (Twith_modsubst (real_path, _))) -> let sub = Subst.change_locs Subst.identity loc in let sub = List.fold_left @@ -693,7 +714,7 @@ let merge_constraint initial_env loc sg lid constr = in (* See explanation in the [Twith_typesubst] case above. *) Subst.signature Make_local sub sg - | (_, _, Twith_modtypesubst tmty) -> + | (_, _, Some (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 @@ -707,6 +728,25 @@ let merge_constraint initial_env loc sg lid constr = with Includemod.Error explanation -> raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation))) +let merge_package_constraint initial_env loc sg lid cty = + let _, s = merge_constraint initial_env loc sg lid (With_type_package cty) in + s + +let check_package_with_type_constraints loc env mty constraints = + let sg = extract_sig env loc mty in + let sg = + List.fold_left + (fun sg (lid, cty) -> + merge_package_constraint env loc sg lid cty) + sg constraints + in + let scope = Ctype.create_scope () in + Mtype.freshen ~scope (Mty_signature sg) + +let () = + Typetexp.check_package_with_type_constraints := + check_package_with_type_constraints + (* Add recursion flags on declarations arising from a mutually recursive block. *) @@ -1356,8 +1396,10 @@ and transl_with ~loc env remove_aliases (rev_tcstrs,sg) constr = 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) + let ((path, lid, tcstr), sg) = merge_constraint env loc sg lid with_info in + (* Only package with constraints result in None here. *) + let tcstr = Option.get tcstr in + ((path, lid, tcstr) :: rev_tcstrs, sg) @@ -2017,7 +2059,9 @@ let rec package_constraints_sig env loc sg constrs = | 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) + let td = {td with type_manifest = Some ty} in + let type_immediate = Typedecl_immediacy.compute_decl env td in + Sig_type (id, {td with type_immediate}, rs, priv) | Sig_module (id, pres, md, rs, priv) -> let rec aux = function | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> @@ -3307,6 +3351,13 @@ let report_error ~loc _env = function Style.inline_code "with" (Style.as_inline_code pp_constraint) () Misc.print_see_manual manual_ref + | With_package_manifest (lid, ty) -> + Location.errorf ~loc + "In the constrained signature, type %a is defined to be %a.@ \ + Package %a constraints may only be used on abstract types." + (Style.as_inline_code longident) lid + (Style.as_inline_code Printtyp.type_expr) ty + Style.inline_code "with" | Repeated_name(kind, name) -> Location.errorf ~loc "@[Multiple definition of the %s name %a.@ \ diff --git a/upstream/ocaml_502/typing/typemod.mli b/upstream/ocaml_502/typing/typemod.mli index 05f750a020..dd4d1dc357 100644 --- a/upstream/ocaml_502/typing/typemod.mli +++ b/upstream/ocaml_502/typing/typemod.mli @@ -117,6 +117,7 @@ type error = Longident.t * Path.t * Includemod.explanation | With_changes_module_alias of Longident.t * Ident.t * Path.t | With_cannot_remove_constrained_type + | With_package_manifest of Longident.t * type_expr | Repeated_name of Sig_component_kind.t * string | Non_generalizable of { vars : type_expr list; expression : type_expr } | Non_generalizable_module of diff --git a/upstream/ocaml_502/typing/typetexp.ml b/upstream/ocaml_502/typing/typetexp.ml index 24cbf515d4..2d7d690790 100644 --- a/upstream/ocaml_502/typing/typetexp.ml +++ b/upstream/ocaml_502/typing/typetexp.ml @@ -338,6 +338,7 @@ end let transl_modtype_longident = ref (fun _ -> assert false) let transl_modtype = ref (fun _ -> assert false) +let check_package_with_type_constraints = ref (fun _ -> assert false) let sort_constraints_no_duplicates loc env l = List.sort @@ -347,23 +348,6 @@ let sort_constraints_no_duplicates loc env l = compare s1.txt s2.txt) l -let create_package_mty loc p l = - List.fold_left - (fun mty (s, _) -> - 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 = None; - 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 generalize_ctyp typ = generalize typ.ctyp_type @@ -679,19 +663,23 @@ and transl_type_aux env ~row_context ~aliased ~policy styp = | Ptyp_package (p, l) -> let loc = styp.ptyp_loc in let l = sort_constraints_no_duplicates loc env l in - let mty = create_package_mty loc p l in + let mty = Ast_helper.Mty.mk ~loc (Pmty_ident p) in + let mty = TyVarEnv.with_local_scope (fun () -> !transl_modtype env mty) in + let ptys = + List.map (fun (s, pty) -> s, transl_type env ~policy ~row_context pty) l + in let mty = - TyVarEnv.with_local_scope (fun () -> !transl_modtype env mty) in - let ptys = List.map (fun (s, pty) -> - s, transl_type env ~policy ~row_context pty - ) l in + if ptys <> [] then + !check_package_with_type_constraints loc env mty.mty_type ptys + else mty.mty_type + in let path = !transl_modtype_longident 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_type = mty; pack_fields = ptys; pack_txt = p; }) ty diff --git a/upstream/ocaml_502/typing/typetexp.mli b/upstream/ocaml_502/typing/typetexp.mli index 56ed31c5fb..34243b1d42 100644 --- a/upstream/ocaml_502/typing/typetexp.mli +++ b/upstream/ocaml_502/typing/typetexp.mli @@ -102,3 +102,7 @@ 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 check_package_with_type_constraints: (* from Typemod *) + (Location.t -> Env.t -> Types.module_type -> + (Longident.t Asttypes.loc * Typedtree.core_type) list -> + Types.module_type) ref diff --git a/upstream/ocaml_502/typing/value_rec_check.ml b/upstream/ocaml_502/typing/value_rec_check.ml index e80e43a8ff..e36f2b3293 100644 --- a/upstream/ocaml_502/typing/value_rec_check.ml +++ b/upstream/ocaml_502/typing/value_rec_check.ml @@ -145,51 +145,56 @@ let classify_expression : Typedtree.expression -> sd = size) but the second one is unsound (`y` has no statically-known size). *) let rec classify_expression env e : sd = - let is_constant expr = - match classify_expression env expr with - | Constant -> true - | _ -> false - in 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_letmodule (Some mid, _, _, mexp, e) -> + (* Note on module presence: + For absent modules (i.e. module aliases), the module being bound + does not have a physical representation, but its size can still be + derived from the alias itself, so we can re-use the same code as + for modules that are present. *) + let size = classify_module_expression env mexp in + let env = Ident.add mid size env in + classify_expression env e | Texp_ident (path, _, _) -> classify_path env path (* non-binding cases *) | Texp_open (_, e) - | Texp_letmodule (_, _, _, _, e) + | Texp_letmodule (None, _, _, _, e) | Texp_sequence (_, e) | Texp_letexception (_, e) -> classify_expression env e | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) -> classify_expression env e - | Texp_construct (_, _, exprs) -> - if List.for_all is_constant exprs then Constant else Static - - | Texp_variant (_, Some expr) -> - if is_constant expr then Constant else Static - | Texp_variant (_, None) -> - Constant + | Texp_construct _ -> + Static | Texp_record { representation = Record_unboxed _; fields = [| _, Overridden (_,e) |] } -> classify_expression env e - | Texp_record { fields; _ } -> - (* We ignore the [extended_expression] field. - As long as all fields are Overridden rather than Kept, the value - can be constant. *) - let is_constant_field (_label, def) = - match def with - | Kept _ -> false - | Overridden (_loc, expr) -> is_constant expr - in - if Array.for_all is_constant_field fields then Constant else Static - | Texp_tuple exprs -> - if List.for_all is_constant exprs then Constant else Static + | Texp_record _ -> + Static + + | Texp_variant _ + | Texp_tuple _ + | Texp_extension_constructor _ + | Texp_constant _ -> + Static + + | Texp_for _ + | Texp_setfield _ + | Texp_while _ + | Texp_setinstvar _ -> + (* Unit-returning expressions *) + Static + + | Texp_unreachable -> + Static | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _) when is_ref vd -> @@ -198,7 +203,7 @@ let classify_expression : Typedtree.expression -> sd = when List.exists is_abstracted_arg args -> Static | Texp_apply _ -> - Not_recursive + Dynamic | Texp_array _ -> Static @@ -223,21 +228,6 @@ let classify_expression : Typedtree.expression -> sd = (* other cases compile to a lazy block holding a function *) Static end - | Texp_extension_constructor _ -> - Static - - | Texp_constant _ -> - Constant - - | Texp_for _ - | Texp_setfield _ - | Texp_while _ - | Texp_setinstvar _ -> - (* Unit-returning expressions *) - Constant - - | Texp_unreachable -> - Constant | Texp_new _ | Texp_instvar _ @@ -250,7 +240,7 @@ let classify_expression : Typedtree.expression -> sd = | Texp_try _ | Texp_override _ | Texp_letop _ -> - Not_recursive + Dynamic and classify_value_bindings rec_flag env bindings = (* We use a non-recursive classification, classifying each binding with respect to the old environment @@ -294,31 +284,33 @@ let classify_expression : Typedtree.expression -> sd = This could be fixed by a more complete implementation. *) - Not_recursive + Dynamic end | Path.Pdot _ | Path.Papply _ | Path.Pextra_ty _ -> (* local modules could have such paths to local definitions; classify_expression could be extend to compute module shapes more precisely *) - Not_recursive + Dynamic and classify_module_expression env mexp : sd = match mexp.mod_desc with - | Tmod_ident _ -> - Not_recursive + | Tmod_ident (path, _) -> + classify_path env path | Tmod_structure _ -> Static | Tmod_functor _ -> Static | Tmod_apply _ -> - Not_recursive + Dynamic | Tmod_apply_unit _ -> - Not_recursive + Dynamic | Tmod_constraint (mexp, _, _, coe) -> begin match coe with - | Tcoerce_none -> classify_module_expression env mexp + | Tcoerce_none -> + classify_module_expression env mexp | Tcoerce_structure _ -> Static - | Tcoerce_functor _ -> Static + | Tcoerce_functor _ -> + Static | Tcoerce_primitive _ -> Misc.fatal_error "letrec: primitive coercion on a module" | Tcoerce_alias _ -> @@ -1370,16 +1362,14 @@ let is_valid_recursive_expression idlist expr : sd option = let rkind = classify_expression expr in let is_valid = match rkind with - | Static | Constant -> + | Static -> (* The expression has known size or is constant *) let ty = expression expr Return in Env.unguarded ty idlist = [] - | Not_recursive -> + | Dynamic -> (* The expression has unknown size *) let ty = expression expr Return in Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] - | Class -> - assert false (* Not generated by [classify_expression] *) in if is_valid then Some rkind else None diff --git a/upstream/ocaml_502/typing/value_rec_types.mli b/upstream/ocaml_502/typing/value_rec_types.mli index 93be6ee9ba..a907935cc9 100644 --- a/upstream/ocaml_502/typing/value_rec_types.mli +++ b/upstream/ocaml_502/typing/value_rec_types.mli @@ -16,27 +16,12 @@ recursive definitions) *) (** The kind of recursive bindings, as computed by - [Rec_check.classify_expression] *) + [Value_rec_check.classify_expression] *) type recursive_binding_kind = | Static - (** The expression evaluates to a function or block of a - statically known size. - It will be pre-allocated and back-patched later. - The expression can refer to recursive variables as long as it - does not inspect them during its evaluation. *) -| Constant - (** The expression evaluates to a value that does not contain any - occurrence of a recursive variable. - Combined with the invariant that recursive variables must never be - examined during the definitions, this special case allow using the - same rules as Static bindings (i.e. allow guarded occurrences of - recursive variables in the expression) for values that cannot be - back-patched (unit, integers, empty arrays, ...). *) -| Not_recursive - (** Non recursive bindings. Arbitrary expressions, that are not allowed to - refer to any recursive variable. *) -| Class - (** Bindings generated by the compilation of objects and classes. - These bindings are generated in Lambda form directly and never go through - [Rec_check], so to avoid re-implementing the classification pass on Lambda - we simply identify this special case with a dedicated constructor. *) + (** Bindings for which some kind of pre-allocation scheme is possible. + The expression is allowed to be recursive, as long as its definition does + not inspect recursively defined values. *) +| Dynamic + (** Bindings for which pre-allocation is not possible. + The expression is not allowed to refer to any recursive variable. *) From bce24e53e0617579c6a4e2cdc2c35d689ae8da68 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 16 Apr 2024 10:44:55 +0200 Subject: [PATCH 097/130] Merge changes in vendored typer and update analysis --- src/analysis/locate.ml | 35 +++---- src/analysis/locate.mli | 5 +- src/analysis/occurrences.ml | 28 +++--- src/ocaml/parsing/unit_info.ml | 5 +- src/ocaml/parsing/unit_info.mli | 8 +- src/ocaml/typing/ctype.ml | 2 +- src/ocaml/typing/includemod_errorprinter.ml | 7 +- src/ocaml/typing/printtyp.ml | 8 +- src/ocaml/typing/printtyped.ml | 14 ++- src/ocaml/typing/shape_reduce.ml | 73 ++++++-------- src/ocaml/typing/shape_reduce.mli | 4 +- src/ocaml/typing/signature_group.mli | 4 +- src/ocaml/typing/typecore.ml | 4 +- src/ocaml/typing/typedecl.ml | 37 +++++++- src/ocaml/typing/typedecl.mli | 3 + src/ocaml/typing/typemod.ml | 79 +++++++++++++--- src/ocaml/typing/typemod.mli | 1 + src/ocaml/typing/typetexp.ml | 34 +++---- src/ocaml/typing/typetexp.mli | 4 + src/ocaml/typing/value_rec_check.ml | 100 +++++++++----------- src/ocaml/typing/value_rec_types.mli | 33 ++----- 21 files changed, 271 insertions(+), 217 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index e6a5746911..c795e4083a 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -574,17 +574,22 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path = Logger.fmt (fun fmt -> Shape_reduce.print_result fmt reduced); reduced -let rec uid_of_aliases ~traverse_aliases = function - | [] -> assert false - | [ def ] -> def - | (Shape.Uid.Item { comp_unit; _ }) - :: (((Compilation_unit comp_unit') :: _) as tl) - when let by = comp_unit ^ "__" in String.is_prefixed ~by comp_unit' -> +let rec uid_of_result ~traverse_aliases = function + | Shape_reduce.Resolved uid -> + Some uid, false + | Resolved_alias (Item { comp_unit; _ }, + (Resolved_alias (Compilation_unit comp_unit', _) as rest)) + when let by = comp_unit ^ "__" in String.is_prefixed ~by comp_unit' -> (* Always traverse dune-wrapper aliases *) - uid_of_aliases ~traverse_aliases tl - | [ alias; def ] -> if traverse_aliases then def else alias - | _alias :: tl when traverse_aliases -> uid_of_aliases ~traverse_aliases tl - | alias :: _tl -> alias + uid_of_result ~traverse_aliases rest + | Resolved_alias (_alias, rest) when traverse_aliases -> + uid_of_result ~traverse_aliases rest + | Resolved_alias (alias, _rest) -> + Some alias, false + | Unresolved { uid = Some uid; desc = Comp_unit _; approximated } -> + Some uid, approximated + | Approximated _ | Unresolved _ | Internal_error_missing_uid -> + None, true (** This is the main function here *) let from_path ~config ~env ~local_defs ~decl path = @@ -605,12 +610,10 @@ let from_path ~config ~env ~local_defs ~decl path = | `MLI -> decl.uid, false | `ML -> let traverse_aliases = config.traverse_aliases in - match find_definition_uid ~config ~env ~decl path with - | Resolved uid -> uid, false - | Resolved_alias aliases -> uid_of_aliases ~traverse_aliases aliases, false - | Unresolved { uid = Some uid; desc = Comp_unit _; approximated } -> - uid, approximated - | Approximated _ | Unresolved _ | Internal_error_missing_uid -> + let result = find_definition_uid ~config ~env ~decl path in + match uid_of_result ~traverse_aliases result with + | Some uid, approx -> uid, approx + | None, _approx -> log ~title "No definition uid, falling back to the declaration uid: %a" Logger.fmt (Fun.flip Shape.Uid.print decl.uid); decl.uid, true diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli index 2fb5b8f3ec..0d201bcd8b 100644 --- a/src/analysis/locate.mli +++ b/src/analysis/locate.mli @@ -42,7 +42,10 @@ type result = { approximated: bool; } -val uid_of_aliases : traverse_aliases:bool -> Shape.Uid.t list -> Shape.Uid.t +val uid_of_result + : traverse_aliases:bool + -> Shape_reduce.result + -> Shape.Uid.t option * bool val find_source : config: Mconfig.t diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 78ab680474..edb205c97b 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -63,27 +63,21 @@ let index_buffer_ ~current_buffer_path ~local_defs () = | path_shape -> log ~title:"index_buffer" "Shape of path: %a" Logger.fmt (Fun.flip Shape.print path_shape); - begin match Shape_reduce.reduce_for_uid env path_shape with - | Internal_error_missing_uid -> - log ~title:"index_buffer" "Reduction failed: missing uid"; - index_decl () - | Resolved_alias l -> - let uid = Locate.uid_of_aliases ~traverse_aliases:false l in - Index_format.(add defs uid (LidSet.singleton lid)) - | Resolved uid -> + let result = Shape_reduce.reduce_for_uid env path_shape in + begin match Locate.uid_of_result ~traverse_aliases:false result with + | Some uid, false -> log ~title:"index_buffer" "Found %s (%a) wiht uid %a" (Longident.head lid.txt) Logger.fmt (Fun.flip Location.print_loc lid.loc) Logger.fmt (Fun.flip Shape.Uid.print uid); - Index_format.(add defs uid (LidSet.singleton lid)) - | Approximated s -> - log ~title:"index_buffer" "Shape is approximative, found uid: %a" - Logger.fmt (Fun.flip (Format.pp_print_option Shape.Uid.print) s); - index_decl () - | Unresolved s -> - log ~title:"index_buffer" "Shape unresolved, stuck on: %a" - Logger.fmt (Fun.flip Shape.print s); - index_decl () + Index_format.(add defs uid (LidSet.singleton lid)) + | Some uid, true -> + log ~title:"index_buffer" "Shape is approximative, found uid: %a" + Logger.fmt (Fun.flip Shape.Uid.print uid); + index_decl () + | None, _ -> + log ~title:"index_buffer" "Reduction failed: missing uid"; + index_decl () end in let f ~namespace env path (lid : Longident.t Location.loc) = diff --git a/src/ocaml/parsing/unit_info.ml b/src/ocaml/parsing/unit_info.ml index b2e081a221..03e8d44949 100644 --- a/src/ocaml/parsing/unit_info.ml +++ b/src/ocaml/parsing/unit_info.ml @@ -103,9 +103,12 @@ let cmti f = mk_artifact ".cmti" f let annot f = mk_artifact ".annot" f let companion_obj f = companion_artifact Config.ext_obj f -let companion_cmi f = companion_artifact ".cmi" f let companion_cmt f = companion_artifact ".cmt" f +let companion_cmi f = + let prefix = Misc.chop_extensions f.Artifact.filename in + { f with Artifact.filename = prefix ^ ".cmi"} + let mli_from_artifact f = Artifact.prefix f ^ !Config.interface_suffix let mli_from_source u = let prefix = Filename.remove_extension (source_file u) in diff --git a/src/ocaml/parsing/unit_info.mli b/src/ocaml/parsing/unit_info.mli index 48acafc06d..466a07a228 100644 --- a/src/ocaml/parsing/unit_info.mli +++ b/src/ocaml/parsing/unit_info.mli @@ -124,10 +124,16 @@ val annot: t -> Artifact.t extension of its filename. Those functions purposefully do not cover all artifact kinds because we want to track which artifacts are assumed to be bundled together. *) -val companion_cmi: Artifact.t -> Artifact.t val companion_obj: Artifact.t -> Artifact.t val companion_cmt: Artifact.t -> Artifact.t +val companion_cmi: Artifact.t -> Artifact.t +(** Beware that [companion_cmi a] strips all extensions from the + filename of [a] before adding the [".cmi"] suffix contrarily to + the other functions which only remove the rightmost extension. + In other words, the companion cmi of a file [something.d.cmo] is + [something.cmi] and not [something.d.cmi]. +*) (** {1:ml_mli_cmi_interaction Mli and cmi derived from implementation files } *) diff --git a/src/ocaml/typing/ctype.ml b/src/ocaml/typing/ctype.ml index d4364f161a..970c637a94 100644 --- a/src/ocaml/typing/ctype.ml +++ b/src/ocaml/typing/ctype.ml @@ -1859,7 +1859,7 @@ let rec occur_rec env allow_recursive visited ty0 ty = 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 + let ty' = try_expand_head try_expand_safe 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' diff --git a/src/ocaml/typing/includemod_errorprinter.ml b/src/ocaml/typing/includemod_errorprinter.ml index db974635ec..0ffd000bba 100644 --- a/src/ocaml/typing/includemod_errorprinter.ml +++ b/src/ocaml/typing/includemod_errorprinter.ml @@ -781,10 +781,11 @@ and functor_symptom ~expansion_token ~env ~before ~ctx = function 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 , _ -> + | _ :: _ as missings, _ -> if expansion_token then - with_context ctx missing_field a - :: List.map (Location.msg "%a" missing_field) l + let init_missings, last_missing = Misc.split_last missings in + List.map (Location.msg "%a" missing_field) init_missings + @ [ with_context ctx missing_field last_missing ] @ before else before diff --git a/src/ocaml/typing/printtyp.ml b/src/ocaml/typing/printtyp.ml index 70542c81e4..833db2360a 100644 --- a/src/ocaml/typing/printtyp.ml +++ b/src/ocaml/typing/printtyp.ml @@ -492,6 +492,10 @@ let rec raw_type ppf ty = ty.scope raw_type_desc ty.desc end and raw_type_list tl = raw_list raw_type tl +and raw_lid_type_list tl = + raw_list (fun ppf (lid, typ) -> + fprintf ppf "(@,%a,@,%a)" longident lid raw_type typ) + tl and raw_type_desc ppf = function Tvar name -> fprintf ppf "Tvar %a" print_name name | Tarrow(l,t1,t2,c) -> @@ -541,8 +545,8 @@ and raw_type_desc ppf = function | Some(p,tl) -> fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) | Tpackage (p, fl) -> - fprintf ppf "@[Tpackage(@,%a@,%a)@]" path p - raw_type_list (List.map snd fl) + fprintf ppf "@[Tpackage(@,%a,@,%a)@]" path p raw_lid_type_list fl + and raw_row_fixed ppf = function | None -> fprintf ppf "None" | Some Types.Fixed_private -> fprintf ppf "Some Fixed_private" diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml index 950a89433a..28b973942e 100644 --- a/src/ocaml/typing/printtyped.ml +++ b/src/ocaml/typing/printtyped.ml @@ -348,7 +348,7 @@ and expression i ppf x = | 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; + list i (value_binding rf) ppf l; expression i ppf e; | Texp_function (params, body) -> line i ppf "Texp_function\n"; @@ -657,7 +657,7 @@ and class_expr i ppf x = 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 (value_binding rf) ppf l1; list i ident_x_expression_def ppf l2; class_expr i ppf ce; | Tcl_constraint (ce, Some ct, _, _, _) -> @@ -878,7 +878,7 @@ and structure_item i ppf x = 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; + list i (value_binding rf) ppf l; | Tstr_primitive vd -> line i ppf "Tstr_primitive\n"; value_description i ppf vd; @@ -964,8 +964,12 @@ and case end; expression (i+1) ppf c_rhs; -and value_binding i ppf x = - line i ppf "\n"; +and value_binding rec_flag i ppf x = + begin match rec_flag, x.vb_rec_kind with + | Nonrecursive, _ -> line i ppf "\n" + | Recursive, Static -> line i ppf "\n" + | Recursive, Dynamic -> line i ppf "\n" + end; attributes (i+1) ppf x.vb_attributes; pattern (i+1) ppf x.vb_pat; expression (i+1) ppf x.vb_expr diff --git a/src/ocaml/typing/shape_reduce.ml b/src/ocaml/typing/shape_reduce.ml index 21a900c458..00a0ec88aa 100644 --- a/src/ocaml/typing/shape_reduce.ml +++ b/src/ocaml/typing/shape_reduce.ml @@ -19,19 +19,18 @@ open Shape type result = | Resolved of Uid.t - | Resolved_alias of Uid.t list + | Resolved_alias of Uid.t * result | Unresolved of t | Approximated of Uid.t option | Internal_error_missing_uid -let print_result fmt result = +let rec print_result fmt result = match result with | Resolved uid -> Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid - | Resolved_alias uids -> - Format.fprintf fmt "@[Resolved_alias: %a@]@;" - Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ -> ") - Uid.print) uids + | Resolved_alias (uid, r) -> + Format.fprintf fmt "@[Alias: %a -> %a@]@;" + Uid.print uid print_result r | Unresolved shape -> Format.fprintf fmt "@[Unresolved: %a@]@;" print shape | Approximated (Some uid) -> @@ -152,17 +151,19 @@ end) = struct obtained by the same term traversal, adding binders in the same order, giving the same balanced trees: the environments have the same hash. -*) + *) + + and force env (Thunk (local_env, t)) = + reduce_ { env with local_env } t and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) = let reduce env t = reduce_ env t in let delay_reduce env t = Thunk (env.local_env, t) in - let force (Thunk (local_env, t)) = reduce { env with local_env } t in let return desc = { uid = t.uid; desc; approximated = t.approximated } in let rec force_aliases nf = match nf.desc with | NAlias delayed_nf -> - let nf = force delayed_nf in + let nf = force env delayed_nf in force_aliases nf | _ -> nf in @@ -197,7 +198,7 @@ end) = struct | NStruct (items) -> begin match Item.Map.find item items with | exception Not_found -> nored () - | nf -> force nf |> reset_uid_if_new_binding + | nf -> force env nf |> reset_uid_if_new_binding end | _ -> nored () @@ -218,7 +219,7 @@ end) = struct their binding-time [Uid.t]. *) | None -> return (NVar id) | Some def -> - begin match force def with + begin match force env def with | { uid = Some _; _ } as nf -> nf (* This var already has a binding uid *) | { uid = None; _ } as nf -> { nf with uid = t.uid } @@ -253,8 +254,7 @@ end) = struct and read_back_desc env desc = let read_back nf = read_back env nf in - let read_back_force (Thunk (local_env, t)) = - read_back (reduce_ { env with local_env } t) in + let read_back_force dnf = read_back (force env dnf) in match desc with | NVar v -> Var v @@ -271,22 +271,6 @@ end) = struct | NComp_unit s -> Comp_unit s | NError s -> Error s - (* When interested only of in the uid of aliased modules we do not read_back - the entire shape of the module, just enough to unroll the chain of aliases. - *) - let read_back_aliases_uids env (nf : nf) = - let force (Thunk (local_env, t)) = - reduce_ { env with local_env } t - in - let rec aux acc (nf : nf) = match nf with - | { uid = Some uid; desc = NAlias dnf; _ } -> - aux (uid::acc) (force dnf) - | { uid = Some uid; _ } -> - Resolved_alias (List.rev (uid::acc)) - | { uid = None; _ } -> Internal_error_missing_uid - in - aux [] nf - (* Sharing the memo tables is safe at the level of a compilation unit since idents should be unique *) let reduce_memo_table = Hashtbl.create 42 @@ -316,6 +300,21 @@ end) = struct | NError _ -> false | NLeaf -> false + let rec reduce_aliases_for_uid env (nf : nf) = + match nf with + | { uid = Some uid; desc = NAlias dnf; approximated = false; _ } -> + let result = reduce_aliases_for_uid env (force env dnf) in + Resolved_alias (uid, result) + | { uid = Some uid; approximated = false; _ } -> Resolved uid + | { uid; approximated = true } -> Approximated uid + | { uid = None; approximated = false; _ } -> + (* A missing Uid after a complete reduction means the Uid was first + missing in the shape which is a code error. Having the + [Missing_uid] reported will allow Merlin (or another tool working + with the index) to ask users to report the issue if it does happen. + *) + Internal_error_missing_uid + let reduce_for_uid global_env t = let fuel = ref Params.fuel in let local_env = Ident.Map.empty in @@ -329,20 +328,8 @@ end) = struct let nf = reduce_ env t in if is_stuck_on_comp_unit nf then Unresolved (read_back env nf) - else match nf with - | { desc = NAlias _; approximated = false; _ } -> - read_back_aliases_uids env nf - | { uid = Some uid; approximated = false; _ } -> - Resolved uid - | { uid; approximated = true; _ } -> - Approximated uid - | { uid = None; approximated = false; _ } -> - (* A missing Uid after a complete reduction means the Uid was first - missing in the shape which is a code error. Having the - [Missing_uid] reported will allow Merlin (or another tool working - with the index) to ask users to report the issue if it does happen. - *) - Internal_error_missing_uid + else + reduce_aliases_for_uid env nf end module Local_reduce = diff --git a/src/ocaml/typing/shape_reduce.mli b/src/ocaml/typing/shape_reduce.mli index 5e409c3cd7..307bc7683f 100644 --- a/src/ocaml/typing/shape_reduce.mli +++ b/src/ocaml/typing/shape_reduce.mli @@ -18,10 +18,10 @@ (** The result of reducing a shape and looking for its uid *) type result = | Resolved of Shape.Uid.t (** Shape reduction succeeded and a uid was found *) - | Resolved_alias of Shape.Uid.t list (** Reduction led to an alias chain *) + | Resolved_alias of Shape.Uid.t * result (** Reduction led to an alias *) | Unresolved of Shape.t (** Result still contains [Comp_unit] terms *) | Approximated of Shape.Uid.t option - (** Reduction failed: it can arrive with first-clsss modules for example *) + (** Reduction failed: it can arrive with first-class modules for example *) | Internal_error_missing_uid (** Reduction succeeded but no uid was found, this should never happen *) diff --git a/src/ocaml/typing/signature_group.mli b/src/ocaml/typing/signature_group.mli index 0b736a5b45..a84925db3b 100644 --- a/src/ocaml/typing/signature_group.mli +++ b/src/ocaml/typing/signature_group.mli @@ -73,9 +73,7 @@ type in_place_patch = { (** [!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]. + for which [patch ~ghosts component] returns [Some (value,patch)]. The [ghosts] list is the current prefix of ghost components associated to [component] *) diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml index bf7de04965..605b6823bf 100644 --- a/src/ocaml/typing/typecore.ml +++ b/src/ocaml/typing/typecore.ml @@ -5410,7 +5410,7 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected = 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; vb_rec_kind = Not_recursive; + vb_loc=Location.none; vb_rec_kind = Dynamic; }], func let_var) } end @@ -6238,7 +6238,7 @@ and type_let ?check ?check_strict (fun (p, (e, _)) pvb -> (* vb_rec_kind will be computed later for recursive bindings *) {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes; - vb_loc=pvb.pvb_loc; vb_rec_kind = Not_recursive; + vb_loc=pvb.pvb_loc; vb_rec_kind = Dynamic; }) l spat_sexp_list in diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml index 42f9814efa..626cd35fb5 100644 --- a/src/ocaml/typing/typedecl.ml +++ b/src/ocaml/typing/typedecl.ml @@ -1727,10 +1727,10 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env in let no_row = not (is_fixed_type sdecl) in let (tman, man) = match sdecl.ptype_manifest with - None -> None, None + None -> Misc.fatal_error "Typedecl.transl_with_constraint: no manifest" | Some sty -> let cty = transl_simple_type env ~closed:no_row sty in - Some cty, Some cty.ctyp_type + cty, 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 @@ -1764,7 +1764,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env && sdecl.ptype_private = Private then Location.deprecated loc "spurious use of private"; let type_kind, type_unboxed_default = - if arity_ok && man <> None then + if arity_ok then sig_decl.type_kind, sig_decl.type_unboxed_default else Type_abstract Definition, false @@ -1774,7 +1774,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env type_arity = arity; type_kind; type_private = priv; - type_manifest = man; + type_manifest = Some man; type_variance = []; type_separability = Types.Separability.default_signature ~arity; type_is_newtype = false; @@ -1834,7 +1834,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env typ_type = new_sig_decl; typ_cstrs = constraints; typ_loc = loc; - typ_manifest = tman; + typ_manifest = Some tman; typ_kind = Ttype_abstract; typ_private = sdecl.ptype_private; typ_attributes = sdecl.ptype_attributes; @@ -1842,6 +1842,33 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env end ~post:(fun ttyp -> generalize_decl ttyp.typ_type) +(* A simplified version of [transl_with_constraint], for the case of packages. + Package constraints are much simpler than normal with type constraints (e.g., + they can not have parameters and can only update abstract types.) *) +let transl_package_constraint ~loc env ty = + let new_sig_decl = + { type_params = []; + type_arity = 0; + type_kind = Type_abstract Definition; + type_private = Public; + type_manifest = Some ty; + type_variance = []; + type_separability = []; + type_is_newtype = false; + type_expansion_scope = Btype.lowest_level; + type_loc = loc; + type_attributes = []; + type_immediate = Unknown; + type_unboxed_default = false; + type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) + } + in + let new_type_immediate = + (* Typedecl_immediacy.compute_decl never raises *) + Typedecl_immediacy.compute_decl env new_sig_decl + in + { new_sig_decl with type_immediate = new_type_immediate } + (* Approximate a type declaration: just make all types abstract *) let abstract_type_decl ~injective arity = diff --git a/src/ocaml/typing/typedecl.mli b/src/ocaml/typing/typedecl.mli index 5598271b0a..52a3197f74 100644 --- a/src/ocaml/typing/typedecl.mli +++ b/src/ocaml/typing/typedecl.mli @@ -46,6 +46,9 @@ val transl_with_constraint: outer_env:Env.t -> Parsetree.type_declaration -> Typedtree.type_declaration +val transl_package_constraint: + loc:Location.t -> Env.t -> type_expr -> Types.type_declaration + val abstract_type_decl: injective:bool -> int -> type_declaration val approx_type_decl: Parsetree.type_declaration list -> diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml index 9f9a1b0f63..a5fea9214b 100644 --- a/src/ocaml/typing/typemod.ml +++ b/src/ocaml/typing/typemod.ml @@ -58,6 +58,7 @@ type error = Longident.t * Path.t * Includemod.explanation | With_changes_module_alias of Longident.t * Ident.t * Path.t | With_cannot_remove_constrained_type + | With_package_manifest of Longident.t * type_expr | Repeated_name of Sig_component_kind.t * string | Non_generalizable of { vars : type_expr list; expression : type_expr } | Non_generalizable_module of @@ -475,11 +476,15 @@ type with_info = | With_modsubst of Longident.t loc * Path.t * Types.module_declaration | With_modtype of Typedtree.module_type | With_modtypesubst of Typedtree.module_type + | With_type_package of Typedtree.core_type + (* Package with type constraints only use this last case. Normal module + with constraints never use it. *) let merge_constraint initial_env loc sg lid constr = let destructive_substitution = match constr with - | With_type _ | With_module _ | With_modtype _ -> false + | With_type _ | With_module _ | With_modtype _ + | With_type_package _ -> false | With_typesubst _ | With_modsubst _ | With_modtypesubst _ -> true in let real_ids = ref [] in @@ -553,7 +558,7 @@ let merge_constraint initial_env loc sg lid constr = in return ~ghosts ~replace_by:(Some (Sig_type(id, newdecl, rs, priv))) - (Pident id, lid, Twith_type tdecl) + (Pident id, lid, Some (Twith_type tdecl)) | Sig_type(id, sig_decl, rs, priv) , [s], (With_type sdecl | With_typesubst sdecl as constr) when Ident.name id = s -> @@ -570,12 +575,26 @@ let merge_constraint initial_env loc sg lid constr = With_type _ -> return ~ghosts ~replace_by:(Some(Sig_type(id, newdecl, rs, priv))) - (Pident id, lid, Twith_type tdecl) + (Pident id, lid, Some (Twith_type tdecl)) | (* With_typesubst *) _ -> real_ids := [Pident id]; return ~ghosts ~replace_by:None - (Pident id, lid, Twith_typesubst tdecl) + (Pident id, lid, Some (Twith_typesubst tdecl)) end + | Sig_type(id, sig_decl, rs, priv), [s], With_type_package cty + when Ident.name id = s -> + begin match sig_decl.type_manifest with + | None -> () + | Some ty -> + raise (Error(loc, outer_sig_env, With_package_manifest (lid.txt, ty))) + end; + let tdecl = + Typedecl.transl_package_constraint ~loc outer_sig_env cty.ctyp_type + in + check_type_decl outer_sig_env sg_for_env loc id None tdecl sig_decl; + let tdecl = { tdecl with type_manifest = None } in + return ~ghosts ~replace_by:(Some(Sig_type(id, tdecl, rs, priv))) + (Pident id, lid, None) | Sig_modtype(id, mtd, priv), [s], (With_modtype mty | With_modtypesubst mty) when Ident.name id = s -> @@ -597,7 +616,7 @@ let merge_constraint initial_env loc sg lid constr = in return ~replace_by:(Some(Sig_modtype(id, mtd', priv))) - (Pident id, lid, Twith_modtype mty) + (Pident id, lid, Some (Twith_modtype mty)) else begin let path = Pident id in real_ids := [path]; @@ -605,7 +624,8 @@ let merge_constraint initial_env loc sg lid constr = | Mty_ident _ -> () | mty -> unpackable_modtype := Some mty end; - return ~replace_by:None (Pident id, lid, Twith_modtypesubst mty) + return ~replace_by:None + (Pident id, lid, Some (Twith_modtypesubst mty)) end | Sig_module(id, pres, md, rs, priv), [s], With_module {lid=lid'; md=md'; path; remove_aliases} @@ -619,7 +639,7 @@ let merge_constraint initial_env loc sg lid constr = newmd.md_type md.md_type); return ~replace_by:(Some(Sig_module(id, pres, newmd, rs, priv))) - (Pident id, lid, Twith_module (path, lid')) + (Pident id, lid, Some (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 @@ -628,7 +648,8 @@ let merge_constraint initial_env loc sg lid constr = (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')) + return ~replace_by:None + (Pident id, lid, Some (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 @@ -663,7 +684,7 @@ let merge_constraint initial_env loc sg lid constr = !unpackable_modtype sg; let sg = match tcstr with - | (_, _, Twith_typesubst tdecl) -> + | (_, _, Some (Twith_typesubst tdecl)) -> let how_to_extend_subst = let sdecl = match constr with @@ -692,7 +713,7 @@ let merge_constraint initial_env loc sg lid constr = 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, _)) -> + | (_, _, Some (Twith_modsubst (real_path, _))) -> let sub = Subst.change_locs Subst.identity loc in let sub = List.fold_left @@ -702,7 +723,7 @@ let merge_constraint initial_env loc sg lid constr = in (* See explanation in the [Twith_typesubst] case above. *) Subst.signature Make_local sub sg - | (_, _, Twith_modtypesubst tmty) -> + | (_, _, Some (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 @@ -716,6 +737,25 @@ let merge_constraint initial_env loc sg lid constr = with Includemod.Error explanation -> raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation))) +let merge_package_constraint initial_env loc sg lid cty = + let _, s = merge_constraint initial_env loc sg lid (With_type_package cty) in + s + +let check_package_with_type_constraints loc env mty constraints = + let sg = extract_sig env loc mty in + let sg = + List.fold_left + (fun sg (lid, cty) -> + merge_package_constraint env loc sg lid cty) + sg constraints + in + let scope = Ctype.create_scope () in + Mtype.freshen ~scope (Mty_signature sg) + +let () = + Typetexp.check_package_with_type_constraints := + check_package_with_type_constraints + (* Add recursion flags on declarations arising from a mutually recursive block. *) @@ -1365,8 +1405,10 @@ and transl_with ~loc env remove_aliases (rev_tcstrs,sg) constr = 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) + let ((path, lid, tcstr), sg) = merge_constraint env loc sg lid with_info in + (* Only package with constraints result in None here. *) + let tcstr = Option.get tcstr in + ((path, lid, tcstr) :: rev_tcstrs, sg) @@ -2128,7 +2170,9 @@ let rec package_constraints_sig env loc sg constrs = | 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) + let td = {td with type_manifest = Some ty} in + let type_immediate = Typedecl_immediacy.compute_decl env td in + Sig_type (id, {td with type_immediate}, rs, priv) | Sig_module (id, pres, md, rs, priv) -> let rec aux = function | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> @@ -3500,6 +3544,13 @@ let report_error ~loc _env = function Style.inline_code "with" (Style.as_inline_code pp_constraint) () Misc.print_see_manual manual_ref + | With_package_manifest (lid, ty) -> + Location.errorf ~loc + "In the constrained signature, type %a is defined to be %a.@ \ + Package %a constraints may only be used on abstract types." + (Style.as_inline_code longident) lid + (Style.as_inline_code Printtyp.type_expr) ty + Style.inline_code "with" | Repeated_name(kind, name) -> Location.errorf ~loc "@[Multiple definition of the %s name %a.@ \ diff --git a/src/ocaml/typing/typemod.mli b/src/ocaml/typing/typemod.mli index 0b85d88513..d88d5b247f 100644 --- a/src/ocaml/typing/typemod.mli +++ b/src/ocaml/typing/typemod.mli @@ -117,6 +117,7 @@ type error = Longident.t * Path.t * Includemod.explanation | With_changes_module_alias of Longident.t * Ident.t * Path.t | With_cannot_remove_constrained_type + | With_package_manifest of Longident.t * type_expr | Repeated_name of Sig_component_kind.t * string | Non_generalizable of { vars : type_expr list; expression : type_expr } | Non_generalizable_module of diff --git a/src/ocaml/typing/typetexp.ml b/src/ocaml/typing/typetexp.ml index 837ea4e901..78d4fa883d 100644 --- a/src/ocaml/typing/typetexp.ml +++ b/src/ocaml/typing/typetexp.ml @@ -338,6 +338,7 @@ end let transl_modtype_longident = ref (fun _ -> assert false) let transl_modtype = ref (fun _ -> assert false) +let check_package_with_type_constraints = ref (fun _ -> assert false) let sort_constraints_no_duplicates loc env l = List.sort @@ -347,23 +348,6 @@ let sort_constraints_no_duplicates loc env l = compare s1.txt s2.txt) l -let create_package_mty loc p l = - List.fold_left - (fun mty (s, _) -> - 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 = None; - 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 generalize_ctyp typ = generalize typ.ctyp_type @@ -693,19 +677,23 @@ and transl_type_aux env ~row_context ~aliased ~policy styp = | Ptyp_package (p, l) -> let loc = styp.ptyp_loc in let l = sort_constraints_no_duplicates loc env l in - let mty = create_package_mty loc p l in + let mty = Ast_helper.Mty.mk ~loc (Pmty_ident p) in + let mty = TyVarEnv.with_local_scope (fun () -> !transl_modtype env mty) in + let ptys = + List.map (fun (s, pty) -> s, transl_type env ~policy ~row_context pty) l + in let mty = - TyVarEnv.with_local_scope (fun () -> !transl_modtype env mty) in - let ptys = List.map (fun (s, pty) -> - s, transl_type env ~policy ~row_context pty - ) l in + if ptys <> [] then + !check_package_with_type_constraints loc env mty.mty_type ptys + else mty.mty_type + in let path = !transl_modtype_longident 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_type = mty; pack_fields = ptys; pack_txt = p; }) ty diff --git a/src/ocaml/typing/typetexp.mli b/src/ocaml/typing/typetexp.mli index 56ed31c5fb..34243b1d42 100644 --- a/src/ocaml/typing/typetexp.mli +++ b/src/ocaml/typing/typetexp.mli @@ -102,3 +102,7 @@ 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 check_package_with_type_constraints: (* from Typemod *) + (Location.t -> Env.t -> Types.module_type -> + (Longident.t Asttypes.loc * Typedtree.core_type) list -> + Types.module_type) ref diff --git a/src/ocaml/typing/value_rec_check.ml b/src/ocaml/typing/value_rec_check.ml index 91a73ca48b..eb741e744a 100644 --- a/src/ocaml/typing/value_rec_check.ml +++ b/src/ocaml/typing/value_rec_check.ml @@ -145,51 +145,56 @@ let classify_expression : Typedtree.expression -> sd = size) but the second one is unsound (`y` has no statically-known size). *) let rec classify_expression env e : sd = - let is_constant expr = - match classify_expression env expr with - | Constant -> true - | _ -> false - in 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_letmodule (Some mid, _, _, mexp, e) -> + (* Note on module presence: + For absent modules (i.e. module aliases), the module being bound + does not have a physical representation, but its size can still be + derived from the alias itself, so we can re-use the same code as + for modules that are present. *) + let size = classify_module_expression env mexp in + let env = Ident.add mid size env in + classify_expression env e | Texp_ident (path, _, _) -> classify_path env path (* non-binding cases *) | Texp_open (_, e) - | Texp_letmodule (_, _, _, _, e) + | Texp_letmodule (None, _, _, _, e) | Texp_sequence (_, e) | Texp_letexception (_, e) -> classify_expression env e | Texp_construct (_, {cstr_tag = Cstr_unboxed}, [e]) -> classify_expression env e - | Texp_construct (_, _, exprs) -> - if List.for_all is_constant exprs then Constant else Static - - | Texp_variant (_, Some expr) -> - if is_constant expr then Constant else Static - | Texp_variant (_, None) -> - Constant + | Texp_construct _ -> + Static | Texp_record { representation = Record_unboxed _; fields = [| _, Overridden (_,e) |] } -> classify_expression env e - | Texp_record { fields; _ } -> - (* We ignore the [extended_expression] field. - As long as all fields are Overridden rather than Kept, the value - can be constant. *) - let is_constant_field (_label, def) = - match def with - | Kept _ -> false - | Overridden (_loc, expr) -> is_constant expr - in - if Array.for_all is_constant_field fields then Constant else Static - | Texp_tuple exprs -> - if List.for_all is_constant exprs then Constant else Static + | Texp_record _ -> + Static + + | Texp_variant _ + | Texp_tuple _ + | Texp_extension_constructor _ + | Texp_constant _ -> + Static + + | Texp_for _ + | Texp_setfield _ + | Texp_while _ + | Texp_setinstvar _ -> + (* Unit-returning expressions *) + Static + + | Texp_unreachable -> + Static | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _) when is_ref vd -> @@ -198,7 +203,7 @@ let classify_expression : Typedtree.expression -> sd = when List.exists is_abstracted_arg args -> Static | Texp_apply _ -> - Not_recursive + Dynamic | Texp_array _ -> Static @@ -223,21 +228,6 @@ let classify_expression : Typedtree.expression -> sd = (* other cases compile to a lazy block holding a function *) Static end - | Texp_extension_constructor _ -> - Static - - | Texp_constant _ -> - Constant - - | Texp_for _ - | Texp_setfield _ - | Texp_while _ - | Texp_setinstvar _ -> - (* Unit-returning expressions *) - Constant - - | Texp_unreachable -> - Constant | Texp_new _ | Texp_instvar _ @@ -250,7 +240,7 @@ let classify_expression : Typedtree.expression -> sd = | Texp_try _ | Texp_override _ | Texp_letop _ -> - Not_recursive + Dynamic | Texp_hole -> Static and classify_value_bindings rec_flag env bindings = @@ -296,31 +286,35 @@ let classify_expression : Typedtree.expression -> sd = This could be fixed by a more complete implementation. *) - Not_recursive + Dynamic end | Path.Pdot _ | Path.Papply _ | Path.Pextra_ty _ -> (* local modules could have such paths to local definitions; classify_expression could be extend to compute module shapes more precisely *) - Not_recursive + Dynamic and classify_module_expression env mexp : sd = match mexp.mod_desc with - | Tmod_ident _ | Tmod_hole -> - Not_recursive + | Tmod_hole -> + Dynamic + | Tmod_ident (path, _) -> + classify_path env path | Tmod_structure _ -> Static | Tmod_functor _ -> Static | Tmod_apply _ -> - Not_recursive + Dynamic | Tmod_apply_unit _ -> - Not_recursive + Dynamic | Tmod_constraint (mexp, _, _, coe) -> begin match coe with - | Tcoerce_none -> classify_module_expression env mexp + | Tcoerce_none -> + classify_module_expression env mexp | Tcoerce_structure _ -> Static - | Tcoerce_functor _ -> Static + | Tcoerce_functor _ -> + Static | Tcoerce_primitive _ -> Misc.fatal_error "letrec: primitive coercion on a module" | Tcoerce_alias _ -> @@ -1373,16 +1367,14 @@ let is_valid_recursive_expression idlist expr : sd option = let rkind = classify_expression expr in let is_valid = match rkind with - | Static | Constant -> + | Static -> (* The expression has known size or is constant *) let ty = expression expr Return in Env.unguarded ty idlist = [] - | Not_recursive -> + | Dynamic -> (* The expression has unknown size *) let ty = expression expr Return in Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] - | Class -> - assert false (* Not generated by [classify_expression] *) in if is_valid then Some rkind else None diff --git a/src/ocaml/typing/value_rec_types.mli b/src/ocaml/typing/value_rec_types.mli index 93be6ee9ba..83b838549c 100644 --- a/src/ocaml/typing/value_rec_types.mli +++ b/src/ocaml/typing/value_rec_types.mli @@ -16,27 +16,12 @@ recursive definitions) *) (** The kind of recursive bindings, as computed by - [Rec_check.classify_expression] *) -type recursive_binding_kind = -| Static - (** The expression evaluates to a function or block of a - statically known size. - It will be pre-allocated and back-patched later. - The expression can refer to recursive variables as long as it - does not inspect them during its evaluation. *) -| Constant - (** The expression evaluates to a value that does not contain any - occurrence of a recursive variable. - Combined with the invariant that recursive variables must never be - examined during the definitions, this special case allow using the - same rules as Static bindings (i.e. allow guarded occurrences of - recursive variables in the expression) for values that cannot be - back-patched (unit, integers, empty arrays, ...). *) -| Not_recursive - (** Non recursive bindings. Arbitrary expressions, that are not allowed to - refer to any recursive variable. *) -| Class - (** Bindings generated by the compilation of objects and classes. - These bindings are generated in Lambda form directly and never go through - [Rec_check], so to avoid re-implementing the classification pass on Lambda - we simply identify this special case with a dedicated constructor. *) + [Value_rec_check.classify_expression] *) + type recursive_binding_kind = + | Static + (** Bindings for which some kind of pre-allocation scheme is possible. + The expression is allowed to be recursive, as long as its definition does + not inspect recursively defined values. *) + | Dynamic + (** Bindings for which pre-allocation is not possible. + The expression is not allowed to refer to any recursive variable. *) From a12d6a9a4b917c68eaaa87af76d57b7dacdb84d7 Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 8 Apr 2024 15:36:46 +0200 Subject: [PATCH 098/130] Test case and changelog for #1739 --- tests/test-dirs/destruct/destruct-fun.t | 60 ++++++++++++++++++++++--- 1 file changed, 55 insertions(+), 5 deletions(-) diff --git a/tests/test-dirs/destruct/destruct-fun.t b/tests/test-dirs/destruct/destruct-fun.t index 088a3bdc3d..884843d715 100644 --- a/tests/test-dirs/destruct/destruct-fun.t +++ b/tests/test-dirs/destruct/destruct-fun.t @@ -9,8 +9,20 @@ FIXME UPGRADE 5.2: this was working before the upgrade > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' { - "class": "error", - "value": "Nothing to do", + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 9 + }, + "end": { + "line": 1, + "col": 11 + } + }, + "false|true" + ], "notifications": [] } @@ -43,12 +55,50 @@ FIXME UPGRADE 5.2: this was working before the upgrade > let f x ((false as bb) : bool) y = something > EOF +FIXME UPGRADE 5.2: this was not working before the upgrade + $ $MERLIN single case-analysis -start 1:11 -end 1:15 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 15 + }, + "end": { + "line": 1, + "col": 15 + } + }, + "|true -> _" + ], + "notifications": [] + } + + $ cat >fun.ml < let f x (_ as bb : bool) y = something + > EOF + FIXME UPGRADE 5.2: this was working before the upgrade - $ $MERLIN single case-analysis -start 1:10 -end 1:15 \ + $ $MERLIN single case-analysis -start 1:10 -end 1:10 \ > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' { - "class": "error", - "value": "Nothing to do", + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 9 + }, + "end": { + "line": 1, + "col": 16 + } + }, + "((false as bb) : bool)|((true as bb) : bool)" + ], "notifications": [] } From fbaa902293cda4a7ec98e86abbca4972f7f76af2 Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 8 Apr 2024 15:41:47 +0200 Subject: [PATCH 099/130] Refactor `destruct` Fragment the various stages of the `node` function to facilitate understanding of its flow and the reuse of parts. --- src/analysis/destruct.ml | 29 ++++++++++------------------- 1 file changed, 10 insertions(+), 19 deletions(-) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index 9cd4880913..77650dca7e 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -589,14 +589,12 @@ let destruct_expression loc config source parents expr = let str = if needs_parentheses then "(" ^ str ^ ")" else str in loc, str - let refine_partial_match last_case_loc config source patterns = - let cases = List.map patterns ~f:(fun pat -> + let cases = List.map patterns ~f:(fun pat -> let _pat, constrs, labels = Conv.conv pat in let unmangling_tables = constrs, labels in (* Unmangling and prefixing *) - let pat = - qualify_constructors ~unmangling_tables Printtyp.shorten_type_path pat in + 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 @@ -615,14 +613,13 @@ let filter_new_branches new_branches patterns = if branch != p then branch else List.fold_left lst ~init:branch ~f:rm_sub)) -let refine_current_pattern patt config source parents generated_pattern = +let refine_current_pattern parents patt config source generated_pattern = let punned_field = find_field_name_for_punned_field patt parents in let ppat = filter_pat_attr (Untypeast.untype_pattern generated_pattern) in let str = print_pretty ?punned_field config source (Pretty_pattern ppat) in patt.Typedtree.pat_loc, str -let refine_and_generate_branches patt config source - (patterns : Typedtree.pattern list) sub_patterns = +let refine_and_generate_branches patt config source patterns 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) @@ -644,8 +641,8 @@ let refine_and_generate_branches patt config source top_patt.Typedtree.pat_loc, str let refine_complete_match - (type a) (patt: a Typedtree.general_pattern) - config source parents patterns = + (type a) parents (patt: a Typedtree.general_pattern) + config source patterns = match Typedtree.classify_pattern patt with | Computation -> raise (Not_allowed ("computation pattern")) | Value -> @@ -658,7 +655,7 @@ let refine_complete_match | [more_precise_pattern] -> (* If only one pattern is generated, then we're only refining the current pattern, not generating new branches. *) - refine_current_pattern patt config source parents more_precise_pattern + refine_current_pattern parents patt config source more_precise_pattern | sub_patterns -> (* If more than one pattern is generated, then we're generating new branches. *) @@ -677,16 +674,11 @@ let destruct_pattern in 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 + let pred = Typecore.partial_pred ~lev:Btype.generic_level m.Typedtree.exp_env e_typ in match Parmatch.complete_partial ~pred pss with | [] -> (* The match is already complete, we try to refine it *) - refine_complete_match patt config source parents patterns + refine_complete_match parents patt config source patterns | patterns -> refine_partial_match last_case_loc config source patterns @@ -705,7 +697,6 @@ and node config source selected_node parents = destruct_record config source selected_node parents | Expression expr -> destruct_expression loc config source parents expr - | Pattern patt -> - destruct_pattern patt config source parents + | Pattern patt -> destruct_pattern patt config source parents | node -> raise (Not_allowed (string_of_node node)) From 9ac62286f43386084ceb91a8aaa294245d80f816 Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 8 Apr 2024 15:44:11 +0200 Subject: [PATCH 100/130] Fix #1739: destruct in function arguments --- src/analysis/destruct.ml | 35 ++++++++++++++++++++++++++++++----- 1 file changed, 30 insertions(+), 5 deletions(-) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index 77650dca7e..7405999836 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -282,17 +282,42 @@ let collect_every_pattern_for_expression parent = ) Env.empty parent Location.none in loc, patterns -let rec get_every_pattern = function +let collect_function_pattern loc param_pattern = + match param_pattern.Typedtree.fp_kind with + | Typedtree.Tparam_pat pattern -> + loc, [pattern] + | Typedtree.Tparam_optional_default _ -> + raise (Not_allowed "value_binding") + +let rec get_every_pattern loc = function | [] -> assert false | parent :: parents -> match parent with | Case _ | Pattern _ -> (* We are still in the same branch, going up. *) - get_every_pattern parents + get_every_pattern loc parents | Expression { exp_desc = Typedtree.Texp_ident (Path.Pident id, _, _) ; _} when Ident.name id = "*type-error*" -> raise (Ill_typed) + | Expression { exp_desc = Typedtree.Texp_function (params, _body); _ } -> + (* So we need to deal with the case where we're either in the body of a + function, or in a function parameter. *) + begin + match + List.find_some ~f:(fun param -> + let open Location in + let param_loc = param.Typedtree.fp_loc in + Lexing.compare_pos loc.loc_start param_loc.loc_start >= 0 + && Lexing.compare_pos param_loc.loc_end loc.loc_end >= 0 + ) params with + | Some pattern -> + (* In parameter case *) + collect_function_pattern loc pattern + | None -> + (* In function body *) + collect_every_pattern_for_expression parent + end | Expression _ -> (* We are on the right node *) collect_every_pattern_for_expression parent @@ -664,8 +689,8 @@ let refine_complete_match let destruct_pattern (type a) (patt: a Typedtree.general_pattern) - config source parents = - let last_case_loc, patterns = get_every_pattern parents in + config source loc parents = + let last_case_loc, patterns = get_every_pattern loc parents in (* Printf.eprintf "tot %d o%!"(List.length patterns); *) let () = List.iter patterns ~f:(fun p -> let p = filter_pat_attr (Untypeast.untype_pattern p) in @@ -697,6 +722,6 @@ and node config source selected_node parents = destruct_record config source selected_node parents | Expression expr -> destruct_expression loc config source parents expr - | Pattern patt -> destruct_pattern patt config source parents + | Pattern patt -> destruct_pattern patt config source loc parents | node -> raise (Not_allowed (string_of_node node)) From a62af4285ff1ae74b0dc30ee6c593786deaca58a Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 9 Apr 2024 15:39:29 +0200 Subject: [PATCH 101/130] Additional tests using 1-elt sum/record --- tests/test-dirs/destruct/destruct-fun.t | 52 +++++++++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/tests/test-dirs/destruct/destruct-fun.t b/tests/test-dirs/destruct/destruct-fun.t index 884843d715..0da3f9f7c2 100644 --- a/tests/test-dirs/destruct/destruct-fun.t +++ b/tests/test-dirs/destruct/destruct-fun.t @@ -102,3 +102,55 @@ FIXME UPGRADE 5.2: this was working before the upgrade ], "notifications": [] } + + $ cat >fun.ml < type t = { foo: int } + > let f a (b: t) c = something + > EOF + + $ $MERLIN single case-analysis -start 2:10 -end 2:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 10 + } + }, + "{ foo }" + ], + "notifications": [] + } + + $ cat >fun.ml < type t = Foo + > let f a (b: t) c = something + > EOF + + $ $MERLIN single case-analysis -start 2:10 -end 2:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 10 + } + }, + "Foo" + ], + "notifications": [] + } From 881892e53e28fe8273ca347964d7c903c87ca1db Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 10 Apr 2024 15:44:56 +0200 Subject: [PATCH 102/130] Add more bunch of test and remove old FIXME --- tests/test-dirs/destruct/destruct-fun.t | 81 ++++++++++++++++++++++++- 1 file changed, 78 insertions(+), 3 deletions(-) diff --git a/tests/test-dirs/destruct/destruct-fun.t b/tests/test-dirs/destruct/destruct-fun.t index 0da3f9f7c2..4625b82fee 100644 --- a/tests/test-dirs/destruct/destruct-fun.t +++ b/tests/test-dirs/destruct/destruct-fun.t @@ -4,7 +4,6 @@ Test case-analysis on a function parameter: > let f x (bb : bool) y = something > EOF -FIXME UPGRADE 5.2: this was working before the upgrade $ $MERLIN single case-analysis -start 1:10 -end 1:11 \ > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' @@ -55,7 +54,6 @@ FIXME UPGRADE 5.2: this was working before the upgrade > let f x ((false as bb) : bool) y = something > EOF -FIXME UPGRADE 5.2: this was not working before the upgrade $ $MERLIN single case-analysis -start 1:11 -end 1:15 \ > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' @@ -81,7 +79,6 @@ FIXME UPGRADE 5.2: this was not working before the upgrade > let f x (_ as bb : bool) y = something > EOF -FIXME UPGRADE 5.2: this was working before the upgrade $ $MERLIN single case-analysis -start 1:10 -end 1:10 \ > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' @@ -154,3 +151,81 @@ FIXME UPGRADE 5.2: this was working before the upgrade ], "notifications": [] } + + $ cat >fun.ml < type t = Foo of int option * string + > let f a (b: t) c = something + > EOF + + $ $MERLIN single case-analysis -start 2:10 -end 2:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr '\n' ' ' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 10 + } + }, + "Foo (_,_)" + ], + "notifications": [] + } + + $ cat >fun.ml < type t = Foo of { foo: int; bar: string } + > let f a (b: t) c = something + > EOF + + $ $MERLIN single case-analysis -start 2:10 -end 2:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr '\n' ' ' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 10 + } + }, + "Foo _" + ], + "notifications": [] + } + + $ cat >fun.ml < type _ t = Foo : int t | Bar : float t + > let f a (b: int t) c = something + > EOF + + $ $MERLIN single case-analysis -start 2:10 -end 2:10 \ + > -filename fun.ml sed -e 's/, /,/g' | sed -e 's/ *| */|/g' | tr -d '\n' | jq '.' + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 10 + } + }, + "Foo" + ], + "notifications": [] + } From 8ac60d08e93813f68e96a0cbb205ad31ed16a823 Mon Sep 17 00:00:00 2001 From: xvw Date: Fri, 12 Apr 2024 17:52:05 +0200 Subject: [PATCH 103/130] Externalize `included_in` for location overlapping --- src/analysis/destruct.ml | 7 ++----- src/ocaml/parsing/location_aux.ml | 4 ++++ src/ocaml/parsing/location_aux.mli | 4 ++++ 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index 7405999836..cc4a0b8b75 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -306,11 +306,8 @@ let rec get_every_pattern loc = function begin match List.find_some ~f:(fun param -> - let open Location in - let param_loc = param.Typedtree.fp_loc in - Lexing.compare_pos loc.loc_start param_loc.loc_start >= 0 - && Lexing.compare_pos param_loc.loc_end loc.loc_end >= 0 - ) params with + Location_aux.included_in param.Typedtree.fp_loc loc + ) params with | Some pattern -> (* In parameter case *) collect_function_pattern loc pattern diff --git a/src/ocaml/parsing/location_aux.ml b/src/ocaml/parsing/location_aux.ml index 966ebdd3f7..ef2e8adf27 100644 --- a/src/ocaml/parsing/location_aux.ml +++ b/src/ocaml/parsing/location_aux.ml @@ -46,6 +46,10 @@ let compare_pos pos loc = else 0 +let included_in parent_loc child_loc = +Lexing.compare_pos child_loc.loc_start parent_loc.loc_start >= 0 && + Lexing.compare_pos parent_loc.loc_end child_loc.loc_end >= 0 + let union l1 l2 = if l1 = Location.none then l2 else if l2 = Location.none then l1 diff --git a/src/ocaml/parsing/location_aux.mli b/src/ocaml/parsing/location_aux.mli index 7d99d36a05..c4866ec0bf 100644 --- a/src/ocaml/parsing/location_aux.mli +++ b/src/ocaml/parsing/location_aux.mli @@ -42,6 +42,10 @@ val union : t -> t -> t (** Like location_union, but keep loc_ghost'ness of first argument *) val extend : t -> t -> t +(** [included_in parent child] returns [true] if [child] is included + in [parent]. Otherwise returns [false]. *) +val included_in : t -> t -> bool + (** Filter valid errors, log invalid ones *) val prepare_errors : exn list -> Location.error list From 4cd85fcd60cd3ed06d5d078309bda6a713e4ad51 Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 15 Apr 2024 15:12:42 +0200 Subject: [PATCH 104/130] Add labeled argument for `Location_aux.included` --- src/analysis/destruct.ml | 2 +- src/ocaml/parsing/location_aux.ml | 2 +- src/ocaml/parsing/location_aux.mli | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml index cc4a0b8b75..17758f42ab 100644 --- a/src/analysis/destruct.ml +++ b/src/analysis/destruct.ml @@ -306,7 +306,7 @@ let rec get_every_pattern loc = function begin match List.find_some ~f:(fun param -> - Location_aux.included_in param.Typedtree.fp_loc loc + Location_aux.included ~into:param.Typedtree.fp_loc loc ) params with | Some pattern -> (* In parameter case *) diff --git a/src/ocaml/parsing/location_aux.ml b/src/ocaml/parsing/location_aux.ml index ef2e8adf27..5a9ec92d87 100644 --- a/src/ocaml/parsing/location_aux.ml +++ b/src/ocaml/parsing/location_aux.ml @@ -46,7 +46,7 @@ let compare_pos pos loc = else 0 -let included_in parent_loc child_loc = +let included ~into:parent_loc child_loc = Lexing.compare_pos child_loc.loc_start parent_loc.loc_start >= 0 && Lexing.compare_pos parent_loc.loc_end child_loc.loc_end >= 0 diff --git a/src/ocaml/parsing/location_aux.mli b/src/ocaml/parsing/location_aux.mli index c4866ec0bf..d6164b2cd7 100644 --- a/src/ocaml/parsing/location_aux.mli +++ b/src/ocaml/parsing/location_aux.mli @@ -42,9 +42,9 @@ val union : t -> t -> t (** Like location_union, but keep loc_ghost'ness of first argument *) val extend : t -> t -> t -(** [included_in parent child] returns [true] if [child] is included +(** [included ~into:parent child] returns [true] if [child] is included in [parent]. Otherwise returns [false]. *) -val included_in : t -> t -> bool +val included : into:t -> t -> bool (** Filter valid errors, log invalid ones *) val prepare_errors : exn list -> Location.error list From 91c05c756365e656c2c7339a6c181313a206e52a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 26 Apr 2024 16:38:40 +0200 Subject: [PATCH 105/130] Fix a typo in lexer_raw --- src/ocaml/preprocess/lexer_raw.mll | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ocaml/preprocess/lexer_raw.mll b/src/ocaml/preprocess/lexer_raw.mll index c6c39fe58a..d80597c833 100644 --- a/src/ocaml/preprocess/lexer_raw.mll +++ b/src/ocaml/preprocess/lexer_raw.mll @@ -416,7 +416,7 @@ let hex_float_literal = ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )? (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? let literal_modifier = ['G'-'Z' 'g'-'z'] -let raw_ident_escape = "\#" +let raw_ident_escape = "\\#" refill {fun k lexbuf -> Refill (fun () -> k lexbuf)} From c2d0346eab49d761b3cac240cfe3facb6134d0e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 26 Apr 2024 16:39:24 +0200 Subject: [PATCH 106/130] hidden_path: use distinct source and build paths --- src/dot-merlin/dot_merlin_reader.ml | 5 ++-- src/dot-protocol/merlin_dot_protocol.ml | 13 ++++++-- src/dot-protocol/merlin_dot_protocol.mli | 7 ++++- src/kernel/mconfig.ml | 30 ++++++++++++++----- src/kernel/mconfig.mli | 5 ++-- src/kernel/mconfig_dot.ml | 12 +++++--- src/kernel/mconfig_dot.mli | 3 +- src/kernel/mocaml.ml | 2 +- .../config/dot-merlin-reader/quoting.t | 2 ++ 9 files changed, 58 insertions(+), 21 deletions(-) diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index e768d6cacb..fa8401dd31 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -326,7 +326,7 @@ let empty_config = { let prepend_config ~cwd ~cfg = List.fold_left ~init:cfg ~f:(fun cfg (d : Merlin_dot_protocol.Directive.Raw.t) -> match d with - | `B _ | `H _ | `S _ | `CMI _ | `CMT _ as directive -> + | `B _ | `S _ | `BH _ | `SH _ | `CMI _ | `CMT _ as directive -> { cfg with to_canonicalize = (cwd, directive) :: cfg.to_canonicalize } | `EXT _ | `SUFFIX _ | `FLG _ | `READER _ | (`EXCLUDE_QUERY_DIR | `USE_PPX_CACHE | `UNKNOWN_TAG _) as directive -> @@ -454,8 +454,9 @@ let postprocess cfg = let dirs = match directive with | `B path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `B p) - | `H path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `H p) | `S path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `S p) + | `BH path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `BH p) + | `SH path -> List.map (expand ~stdlib dir path) ~f:(fun p -> `SH 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 diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index ba7ea25d0c..6798632b68 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -31,7 +31,12 @@ open Merlin_utils.Std.Result module Directive = struct type include_path = - [ `B of string | `H of string | `S of string | `CMI of string | `CMT of string ] + [ `B of string + | `S of string + | `BH of string + | `SH of string + | `CMI of string + | `CMT of string ] type no_processing_required = [ `EXT of string list @@ -82,7 +87,8 @@ module Sexp = struct begin match tag with | "S" -> `S value | "B" -> `B value - | "H" -> `H value + | "SH" -> `SH value + | "BH" -> `BH value | "CMI" -> `CMI value | "CMT" -> `CMT value | "STDLIB" -> `STDLIB value @@ -112,8 +118,9 @@ module Sexp = struct let single s = [ Atom s ] in match t with | `B s -> ("B", single s) - | `H s -> ("H", single s) | `S s -> ("S", single s) + | `BH s -> ("BH", single s) + | `SH s -> ("SH", single s) | `CMI s -> ("CMI", single s) | `CMT s -> ("CMT", single s) | `EXT ss -> ("EXT", [ List (atoms_of_strings ss) ]) diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index 2acff7bbf3..96e34972d2 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -43,7 +43,12 @@ really do not want to load them. *) module Directive : sig type include_path = - [ `B of string | `H of string| `S of string | `CMI of string | `CMT of string ] + [ `B of string + | `S of string + | `BH of string + | `SH of string + | `CMI of string + | `CMT of string ] type no_processing_required = [ `EXT of string list diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 3728dffcd5..6793f2984e 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -71,8 +71,9 @@ let marg_commandline f = type merlin = { build_path : string list; - hidden_path : string list; source_path : string list; + hidden_build_path : string list; + hidden_source_path : string list; cmi_path : string list; cmt_path : string list; extensions : string list; @@ -105,6 +106,8 @@ let dump_merlin x = `Assoc [ "build_path" , `List (List.map ~f:Json.string x.build_path); "source_path" , `List (List.map ~f:Json.string x.source_path); + "hidden_build_path" , `List (List.map ~f:Json.string x.hidden_build_path); + "hidden_source_path", `List (List.map ~f:Json.string x.hidden_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); @@ -235,10 +238,10 @@ let rec normalize t = let merge_merlin_config dot merlin ~failures ~config_path = { merlin with - build_path = dot.Mconfig_dot.build_path @ merlin.build_path; + 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; + hidden_build_path = dot.hidden_build_path @ merlinhidden_build_path; + hidden_source_path = dot.hidden_source_path @ merlinhidden_source_path; exclude_query_dir = dot.exclude_query_dir || merlin.exclude_query_dir; use_ppx_cache = dot.use_ppx_cache || merlin.use_ppx_cache; extensions = dot.extensions @ merlin.extensions; @@ -276,6 +279,18 @@ let merlin_flags = [ {merlin with source_path = dir :: merlin.source_path}), " Add to merlin source path" ); + ( + "-hidden-build-path", + marg_path (fun dir merlin -> + {merlin with hidden_build_path = dir :: merlin.hidden_build_path}), + " Add to merlin hidden build path" + ); + ( + "-hidden-source-path", + marg_path (fun dir merlin -> + {merlin with hidden_source_path = dir :: merlin.hidden_source_path}), + " Add to merlin hidden source path" + ); ( "-cmi-path", marg_path (fun dir merlin -> @@ -617,8 +632,9 @@ let initial = { }; merlin = { build_path = []; - hidden_path = []; source_path = []; + hidden_build_path = []; + hidden_source_path = []; cmi_path = []; cmt_path = []; extensions = []; @@ -764,8 +780,8 @@ let build_path config = ( result' ) -let hidden_path config = - config.merlin.hidden_path @ config.ocaml.hidden_dirs +let hidden_build_path config = + config.merlin.hidden_build_path @ config.ocaml.hidden_dirs let cmt_path config = ( let dirs = diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli index 2aa395b7a4..0111f6c125 100644 --- a/src/kernel/mconfig.mli +++ b/src/kernel/mconfig.mli @@ -29,8 +29,9 @@ val dump_ocaml : ocaml -> json type merlin = { build_path : string list; - hidden_path : string list; source_path : string list; + hidden_build_path : string list; + hidden_source_path : string list; cmi_path : string list; cmt_path : string list; extensions : string list; @@ -115,7 +116,7 @@ val source_path : t -> string list val build_path : t -> string list -val hidden_path : t -> string list +val hidden_build_path : t -> string list val cmt_path : t -> string list diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index a4d7ff1a9c..a5303f7a53 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -34,8 +34,9 @@ type directive = Merlin_dot_protocol.directive type config = { build_path : string list; - hidden_path : string list; source_path : string list; + hidden_build_path : string list; + hidden_source_path : string list; cmi_path : string list; cmt_path : string list; flags : string list with_workdir list; @@ -49,7 +50,8 @@ type config = { let empty_config = { build_path = []; - hidden_path = []; + hidden_build_path =[]; + hidden_source_path = []; source_path = []; cmi_path = []; cmt_path = []; @@ -236,8 +238,9 @@ 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 - | `H path -> {config with hidden_path = path :: config.hidden_path}, errors | `S path -> {config with source_path = path :: config.source_path}, errors + | `BH path -> {config with hidden_build_path = path :: config.hidden_build_path}, errors + | `SH path -> {config with hidden_source_path = path :: config.hidden_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 -> @@ -270,8 +273,9 @@ let postprocess_config config = let clean list = List.rev (List.filter_dup list) in { build_path = clean config.build_path; - hidden_path = clean config.hidden_path; source_path = clean config.source_path; + hidden_build_path = clean config.hidden_build_path; + hidden_source_path = clean config.hidden_source_path; cmi_path = clean config.cmi_path; cmt_path = clean config.cmt_path; extensions = clean config.extensions; diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli index 8e10e2e648..b31f31b36f 100644 --- a/src/kernel/mconfig_dot.mli +++ b/src/kernel/mconfig_dot.mli @@ -36,8 +36,9 @@ end type config = { build_path : string list; - hidden_path : string list; source_path : string list; + hidden_build_path : string list; + hidden_source_path : string list; cmi_path : string list; cmt_path : string list; flags : string list with_workdir list; diff --git a/src/kernel/mocaml.ml b/src/kernel/mocaml.ml index 833db64fe8..95f87afc24 100644 --- a/src/kernel/mocaml.ml +++ b/src/kernel/mocaml.ml @@ -47,7 +47,7 @@ let setup_reader_config config = ( let setup_typer_config config = ( setup_reader_config config; let visible = Mconfig.build_path config in - let hidden = Mconfig.hidden_path config in + let hidden = Mconfig.hidden_build_path config in Load_path.(init ~auto_include:no_auto_include ~visible ~hidden); ) diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t index b9ae8c7eee..f8d0604e58 100644 --- a/tests/test-dirs/config/dot-merlin-reader/quoting.t +++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t @@ -14,6 +14,8 @@ { "build_path": [], "source_path": [], + "hidden_build_path": [], + "hidden_source_path": [], "cmi_path": [], "cmt_path": [], "flags_applied": [ From 5d4a6629154e8999f700d297f1c33ad133813836 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 30 Apr 2024 11:16:55 +0200 Subject: [PATCH 107/130] Attempt to please ocaml-ci --- dot-merlin-reader.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dot-merlin-reader.opam b/dot-merlin-reader.opam index 1346ab3386..67bfc002e2 100644 --- a/dot-merlin-reader.opam +++ b/dot-merlin-reader.opam @@ -11,7 +11,7 @@ build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ - "ocaml" {>= "5.1" } + "ocaml" {>= "5.2" } "dune" {>= "2.9.0"} "merlin-lib" {>= "4.9"} "ocamlfind" {>= "1.6.0"} From fb5ffaddbb28dfad72fd73423d757ade00f2fb5d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 30 Apr 2024 18:17:36 +0200 Subject: [PATCH 108/130] hidden path: change H -> BH and SH in dot_merlin_reader --- src/dot-merlin/dot_merlin_reader.ml | 6 ++++-- src/kernel/mconfig.ml | 6 +++--- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index fa8401dd31..7fd2fff19d 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/src/dot-merlin/dot_merlin_reader.ml @@ -72,10 +72,12 @@ module Cache = File_cache.Make (struct else if String.is_prefixed ~by:"B " line then tell (`B (String.drop 2 line)) - else if String.is_prefixed ~by:"H " line then - tell (`S (String.drop 2 line)) + else if String.is_prefixed ~by:"BH " line then + tell (`BH (String.drop 3 line)) else if String.is_prefixed ~by:"S " line then tell (`S (String.drop 2 line)) + else if String.is_prefixed ~by:"SH " line then + tell (`SH (String.drop 3 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 diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 6793f2984e..4e4f565321 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -238,10 +238,10 @@ let rec normalize t = let merge_merlin_config dot merlin ~failures ~config_path = { merlin with - build_path = dot.build_path @ merlin.build_path; + build_path = dot.Mconfig_dot.build_path @ merlin.build_path; source_path = dot.source_path @ merlin.source_path; - hidden_build_path = dot.hidden_build_path @ merlinhidden_build_path; - hidden_source_path = dot.hidden_source_path @ merlinhidden_source_path; + hidden_build_path = dot.hidden_build_path @ merlin.hidden_build_path; + hidden_source_path = dot.hidden_source_path @ merlin.hidden_source_path; exclude_query_dir = dot.exclude_query_dir || merlin.exclude_query_dir; use_ppx_cache = dot.use_ppx_cache || merlin.use_ppx_cache; extensions = dot.extensions @ merlin.extensions; From 3b78aa82ac2ca9fca3080e7d5d1f3f1ab14812dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 2 May 2024 13:19:56 +0200 Subject: [PATCH 109/130] Small refactors, added documentation and tests update --- src/analysis/construct.ml | 4 +- src/analysis/env_lookup.ml | 5 +- src/analysis/env_lookup.mli | 84 +++++++++++-------- src/analysis/locate.ml | 4 +- src/analysis/misc_utils.mli | 7 +- src/analysis/occurrences.ml | 2 +- src/analysis/tail_analysis.ml | 3 +- .../test-dirs/type-enclosing/underscore-ids.t | 82 ------------------ 8 files changed, 61 insertions(+), 130 deletions(-) diff --git a/src/analysis/construct.ml b/src/analysis/construct.ml index b99b8cc534..3af7fa7754 100644 --- a/src/analysis/construct.ml +++ b/src/analysis/construct.ml @@ -340,11 +340,11 @@ module Gen = struct match label with | Labelled s | Optional s -> (* Pun for labelled arguments *) - make_param label (Ast_helper.Pat.var ( Location.mknoloc s)), s + make_param label (Ast_helper.Pat.var (Location.mknoloc s)), s | Nolabel -> begin match get_desc ty with | Tconstr (path, _, _) -> let name = uniq_name env (Path.last path) in - make_param label (Ast_helper.Pat.var ( Location.mknoloc name)), name + make_param label (Ast_helper.Pat.var (Location.mknoloc name)), name | _ -> make_param label (Ast_helper.Pat.any ()), "_" end in diff --git a/src/analysis/env_lookup.ml b/src/analysis/env_lookup.ml index e51a2ad966..929ee982b5 100644 --- a/src/analysis/env_lookup.ml +++ b/src/analysis/env_lookup.ml @@ -34,7 +34,7 @@ type item = { namespace: Shape.Sig_component_kind.t } -let loc path (namespace : Namespace.t) env = +let by_path path (namespace : Namespace.t) env = try let loc, uid, (namespace : Namespace.t) = match namespace with @@ -56,7 +56,6 @@ let loc path (namespace : Namespace.t) env = | Class_type -> let clty = Env.find_cltype path env in clty.clty_loc, clty.clty_uid, Class - in Some { uid; loc; namespace } with @@ -82,7 +81,7 @@ let path_and_loc_from_label desc env = path, typ_decl.Types.type_loc | _ -> assert false -let in_namespaces (nss : Namespace.inferred list) ident env = +let by_longident (nss : Namespace.inferred list) ident env = let open Shape.Sig_component_kind in try List.iter nss ~f:(fun namespace -> diff --git a/src/analysis/env_lookup.mli b/src/analysis/env_lookup.mli index 41e070fa0f..cca3499e58 100644 --- a/src/analysis/env_lookup.mli +++ b/src/analysis/env_lookup.mli @@ -1,38 +1,48 @@ +(** Provides tools to lookup items in the typing environment. + + Establishing the namespace of an item before looking it up in the environement + is necessary to prevent mixing items which have the same name but are not of + the same namespace. (For example the environment can contain both type named + `t` and a value named `t`.) *) + +(** Namespaces describe in which section of the environment an item should be + looked for. *) module Namespace : sig - type t = Shape.Sig_component_kind.t - - val to_string : t -> string - - type under_type = [ `Constr | `Labels ] - type inferred_basic = - [ `Constr | `Labels | `Mod | `Modtype | `Type | `Vals ] - type inferred = - [ `Constr - | `Labels - | `Mod - | `Modtype - | `This_cstr of Types.constructor_description - | `This_label of Types.label_description - | `Type - | `Vals ] - - val from_context : Context.t -> inferred list - end - - type item = { - uid: Shape.Uid.t; - loc: Location.t; - namespace: Namespace.t - } - - val loc - : Path.t - -> Namespace.t - -> Env.t - -> item option - - val in_namespaces - : Namespace.inferred list - -> Longident.t - -> Env.t - -> (Path.t * item) option + type t = Shape.Sig_component_kind.t + + val to_string : t -> string + + type under_type = [ `Constr | `Labels ] + type inferred_basic = + [ `Constr | `Labels | `Mod | `Modtype | `Type | `Vals ] + type inferred = + [ `Constr + | `Labels + | `Mod + | `Modtype + | `This_cstr of Types.constructor_description + | `This_label of Types.label_description + | `Type + | `Vals ] + + (** Returns potential namespaces given the context of an expression *) + val from_context : Context.t -> inferred list +end + +type item = { + uid: Shape.Uid.t; + loc: Location.t; + namespace: Namespace.t +} + +val by_path + : Path.t + -> Namespace.t + -> Env.t + -> item option + +val by_longident + : Namespace.inferred list + -> Longident.t + -> Env.t + -> (Path.t * item) option diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index c795e4083a..ac5cfabf63 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -652,13 +652,13 @@ let from_longident ~config ~env ~local_defs nss ident = try String.concat ~sep:"." (Longident.flatten ident) with _-> "Not a flat longident" in - match Env_lookup.in_namespaces nss ident env with + match Env_lookup.by_longident nss ident env with | None -> `Not_in_env str_ident | Some (path, decl) -> from_path ~config ~env ~local_defs ~decl path let from_path ~config ~env ~local_defs ~namespace path = File_switching.reset (); - match Env_lookup.loc path namespace env with + match Env_lookup.by_path path namespace env with | None -> `Not_in_env (Path.name path) | Some decl -> from_path ~config ~env ~local_defs ~decl path diff --git a/src/analysis/misc_utils.mli b/src/analysis/misc_utils.mli index 4444d618bf..32b15d5683 100644 --- a/src/analysis/misc_utils.mli +++ b/src/analysis/misc_utils.mli @@ -32,5 +32,8 @@ module Compat : sig -> (Typedtree.pattern * Ident.t * string Location.loc) option end -(** Extracts the loc from cmt's cmt_uid_to_decl tables *) -val loc_of_decl : uid:Shape.Uid.t -> Typedtree.item_declaration -> string Location.loc option +(** Extracts the location of a [uid] from a [Typedtree.item_declaration] *) +val loc_of_decl : + uid:Shape.Uid.t -> + Typedtree.item_declaration -> + string Location.loc option diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index edb205c97b..34b51bd339 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -23,7 +23,7 @@ let decl_of_path_or_lid env namespace path lid = | {lbl_uid; lbl_loc; _ } -> Some { Env_lookup.uid = lbl_uid; loc = lbl_loc; namespace } end - | _ -> Env_lookup.loc path namespace env + | _ -> Env_lookup.by_path path namespace env let index_buffer_ ~current_buffer_path ~local_defs () = let {Logger. log} = Logger.for_section "index" in diff --git a/src/analysis/tail_analysis.ml b/src/analysis/tail_analysis.ml index 2b9891483c..d05e2ac37e 100644 --- a/src/analysis/tail_analysis.ml +++ b/src/analysis/tail_analysis.ml @@ -74,7 +74,8 @@ let tail_positions = function (* 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 - (* TODO UPGRADE *) + (* FIXME This was broken with the upgrade to 5.2 + It seems like that feature was already broket before that upgrade. *) (* | Texp_function (cases, _) -> List.map cases ~f:(fun c -> Case c) *) | _ -> [] diff --git a/tests/test-dirs/type-enclosing/underscore-ids.t b/tests/test-dirs/type-enclosing/underscore-ids.t index 97eb6eb78f..ba304a3183 100644 --- a/tests/test-dirs/type-enclosing/underscore-ids.t +++ b/tests/test-dirs/type-enclosing/underscore-ids.t @@ -282,7 +282,6 @@ We try several places in the identifier to check the result stability } 3.1 -FIXME UPGRADE 5.2: there is something wrong with the recovery here $ $MERLIN single type-enclosing -position 5:10 -filename under.ml < let aa = 4.2 > let f (x) : int = function @@ -332,84 +331,3 @@ FIXME UPGRADE 5.2: there is something wrong with the recovery here ], "notifications": [] } - - $ $MERLIN single dump -what typedtree -filename under.ml < let aa = 4.2 - > let f (x) : int = function - > | None -> 3 - > | Some 5 -> 4 - > | Some _aa -> 4 - > EOF - { - "class": "return", - "value": "[ - structure_item (under.ml[1,0+0]..under.ml[1,0+12]) - Tstr_value Nonrec - [ - - pattern (under.ml[1,0+4]..under.ml[1,0+6]) - Tpat_var \"aa/276\" - expression (under.ml[1,0+9]..under.ml[1,0+12]) - Texp_constant Const_float 4.2 - ] - structure_item (under.ml[2,13+0]..under.ml[5,70+17]) - Tstr_value Nonrec - [ - - pattern (under.ml[2,13+4]..under.ml[2,13+5]) - Tpat_var \"f/277\" - expression (under.ml[2,13+6]..under.ml[5,70+17]) ghost - Texp_function - [ - Nolabel - Param_pat - pattern (under.ml[2,13+6]..under.ml[2,13+9]) - Tpat_var \"x/279\" - ] - Tfunction_cases (under.ml[2,13+18]..under.ml[5,70+17]) - Texp_constraint - core_type (under.ml[2,13+12]..under.ml[2,13+15]) - Ttyp_constr \"int/1!\" - [] - [ - - pattern (under.ml[3,40+4]..under.ml[3,40+8]) - Tpat_construct \"None\" - [] - None - expression (under.ml[3,40+12]..under.ml[3,40+13]) - attribute \"merlin.loc\" - [] - Texp_constant Const_int 3 - - pattern (under.ml[4,54+4]..under.ml[4,54+10]) - Tpat_construct \"Some\" - [ - pattern (under.ml[4,54+9]..under.ml[4,54+10]) - Tpat_constant Const_int 5 - ] - None - expression (under.ml[4,54+14]..under.ml[4,54+15]) - attribute \"merlin.loc\" - [] - Texp_constant Const_int 4 - - pattern (under.ml[5,70+4]..under.ml[5,70+12]) - Tpat_construct \"Some\" - [ - pattern (under.ml[5,70+9]..under.ml[5,70+12]) - Tpat_var \"_aa/280\" - ] - None - expression (under.ml[5,70+16]..under.ml[5,70+17]) - attribute \"merlin.loc\" - [] - Texp_constant Const_int 4 - ] - ] - ] - - - ", - "notifications": [] - } From 1850cbe8f0d52c02d0c1d2fae18d5e46336df0c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 2 May 2024 10:08:23 +0200 Subject: [PATCH 110/130] occurrences: do not attempt to shrink the selection of idents that needs parenthesis Doing that properly require compiler support for located longidents. --- src/analysis/occurrences.ml | 27 +- src/ocaml/parsing/pprintast.mli | 1 + tests/test-dirs/occurrences/issue1398.t/run.t | 9 +- tests/test-dirs/occurrences/lid-locs.t | 234 ++++++++++++++++++ 4 files changed, 258 insertions(+), 13 deletions(-) create mode 100644 tests/test-dirs/occurrences/lid-locs.t diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 34b51bd339..9027e29120 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -126,16 +126,27 @@ let index_buffer = such longidents. However there is an issue with that: we only have the location of the complete longident which might span multiple lines. This is enough to get the last component since it will always be on the last line, - but will prevent us to find the location of previous components. *) + but will prevent us to find the location of previous components. + + However, we can safely deduce the location of the last part of the lid only + when the ident does not require parenthesis. In that case the loc sie differs + from the name size in a way that depends on the concrete syntax which is + lost. *) let last_loc (loc : Location.t) lid = - if lid = Longident.Lident "*unknown*" then loc - else - let last_size = Longident.last lid |> String.length in - { loc with - loc_start = { loc.loc_end with - pos_cnum = loc.loc_end.pos_cnum - last_size; + match lid with + | Longident.Lident _ -> loc + | _ -> + let last_segment = Longident.last lid in + let needs_parens = Pprintast.needs_parens last_segment in + if not needs_parens then + let last_size = last_segment |> String.length in + { loc with + loc_start = { loc.loc_end with + pos_cnum = loc.loc_end.pos_cnum - last_size; + } } - } + else + loc let uid_and_loc_of_node env node = let open Browse_raw in diff --git a/src/ocaml/parsing/pprintast.mli b/src/ocaml/parsing/pprintast.mli index 1f921f02c0..142f9b4cf6 100644 --- a/src/ocaml/parsing/pprintast.mli +++ b/src/ocaml/parsing/pprintast.mli @@ -65,3 +65,4 @@ val case_list : Format.formatter -> Parsetree.case list -> unit val protect_ident : Format.formatter -> string -> unit val needs_parens : string -> bool val ident_of_name : Format.formatter -> string -> unit +val needs_parens : string -> bool diff --git a/tests/test-dirs/occurrences/issue1398.t/run.t b/tests/test-dirs/occurrences/issue1398.t/run.t index 0cc6eaf859..b49549322d 100644 --- a/tests/test-dirs/occurrences/issue1398.t/run.t +++ b/tests/test-dirs/occurrences/issue1398.t/run.t @@ -1,5 +1,4 @@ Test finding occurrences of let-based binding operator, from reified syntax: -FIXME UPGRADE 5.2: some of these locations are slightly off. $ $MERLIN single occurrences -identifier-at 3:11 ./issue1398.ml < ./issue1398.ml { "class": "return", @@ -17,7 +16,7 @@ FIXME UPGRADE 5.2: some of these locations are slightly off. { "start": { "line": 3, - "col": 12 + "col": 10 }, "end": { "line": 3, @@ -57,7 +56,7 @@ Test finding occurrences of and-based binding operator, from reified syntax: { "start": { "line": 3, - "col": 21 + "col": 19 }, "end": { "line": 3, @@ -97,7 +96,7 @@ FIXME -- some locs are inexact { "start": { "line": 3, - "col": 12 + "col": 10 }, "end": { "line": 3, @@ -137,7 +136,7 @@ FIXME -- some locs are inexact { "start": { "line": 3, - "col": 21 + "col": 19 }, "end": { "line": 3, diff --git a/tests/test-dirs/occurrences/lid-locs.t b/tests/test-dirs/occurrences/lid-locs.t new file mode 100644 index 0000000000..fa151fbf05 --- /dev/null +++ b/tests/test-dirs/occurrences/lid-locs.t @@ -0,0 +1,234 @@ +An ident that doesn't need parenthesis: +The parenthesis are typed as an open statement + + $ cat >test.ml <<'EOF' + > module M = struct + > let x = 42 + > end + > let _ = M.x + > let _ = M. x + > let _ = M.( x ) + > let _ = M.( ( x ) ) + > let _ = M. + > x + > EOF + + $ $MERLIN single occurrences -identifier-at 4:10 ./test.ml < ./test.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 6 + }, + "end": { + "line": 2, + "col": 7 + } + }, + { + "start": { + "line": 4, + "col": 10 + }, + "end": { + "line": 4, + "col": 11 + } + }, + { + "start": { + "line": 5, + "col": 11 + }, + "end": { + "line": 5, + "col": 12 + } + }, + { + "start": { + "line": 6, + "col": 12 + }, + "end": { + "line": 6, + "col": 13 + } + }, + { + "start": { + "line": 7, + "col": 14 + }, + "end": { + "line": 7, + "col": 15 + } + }, + { + "start": { + "line": 9, + "col": 2 + }, + "end": { + "line": 9, + "col": 3 + } + } + ], + "notifications": [] + } + +An ident that needs parenthesis: +We don't have enough information to safely shrink the enclosing + $ cat >test.ml <<'EOF' + > module M = struct + > let (++) a b = a + b + > end + > let _ = M.(++) + > let _ = M.( ++ ) + > let _ = M. ( ++) + > let _ = M. ( + > ++) + > let _ = let open M in ( ++ ) + > EOF + + $ $MERLIN single occurrences -identifier-at 4:12 ./test.ml < ./test.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 2, + "col": 6 + }, + "end": { + "line": 2, + "col": 10 + } + }, + { + "start": { + "line": 4, + "col": 8 + }, + "end": { + "line": 4, + "col": 14 + } + }, + { + "start": { + "line": 5, + "col": 8 + }, + "end": { + "line": 5, + "col": 16 + } + }, + { + "start": { + "line": 6, + "col": 8 + }, + "end": { + "line": 6, + "col": 16 + } + }, + { + "start": { + "line": 7, + "col": 8 + }, + "end": { + "line": 8, + "col": 5 + } + }, + { + "start": { + "line": 9, + "col": 22 + }, + "end": { + "line": 9, + "col": 28 + } + } + ], + "notifications": [] + } + +Same for an ident that requires both parenthesis and spaces: + $ cat >test.ml <<'EOF' + > module M = struct + > let ( * ) a b = a * b + > end + > let _ = M.( * ) + > let _ = M. ( * ) + > let _ = M.( *) + > let _ = M. ( + > *) + > EOF + + $ $MERLIN single occurrences -identifier-at 4:10 ./test.ml < ./test.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 7 + }, + "end": { + "line": 1, + "col": 8 + } + }, + { + "start": { + "line": 4, + "col": 8 + }, + "end": { + "line": 4, + "col": 13 + } + }, + { + "start": { + "line": 5, + "col": 8 + }, + "end": { + "line": 5, + "col": 15 + } + }, + { + "start": { + "line": 6, + "col": 8 + }, + "end": { + "line": 6, + "col": 12 + } + }, + { + "start": { + "line": 7, + "col": 8 + }, + "end": { + "line": 8, + "col": 2 + } + } + ], + "notifications": [] + } From 2ce5d3c6662095da1cb2a1b23d525041c5d2c9c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 2 May 2024 13:08:23 +0200 Subject: [PATCH 111/130] hidden_deps: test showing multiple issues --- tests/test-dirs/config/hidden-deps.t | 92 ++++++++++++++++++++++++++++ 1 file changed, 92 insertions(+) create mode 100644 tests/test-dirs/config/hidden-deps.t diff --git a/tests/test-dirs/config/hidden-deps.t b/tests/test-dirs/config/hidden-deps.t new file mode 100644 index 0000000000..2d53678b4b --- /dev/null +++ b/tests/test-dirs/config/hidden-deps.t @@ -0,0 +1,92 @@ + + $ cat >main.ml <<'EOF' + > let _ = print_int Vlib.x + > EOF + + $ mkdir hsrc + $ cat >hsrc/hlib.ml <<'EOF' + > let x = 42 + > EOF + + $ mkdir vsrc + $ cat >vsrc/vlib.ml <<'EOF' + > include Hlib + > EOF + + $ mkdir _build + $ mkdir _build/hsrc + $ mkdir _build/vsrc + + $ cp main.ml _build/main.ml + $ cp hsrc/hlib.ml _build/hsrc/hlib.ml + $ cp vsrc/vlib.ml _build/vsrc/vlib.ml + + $ (cd _build/hsrc && $OCAMLC -c -bin-annot hlib.ml ) + $ (cd _build/vsrc && $OCAMLC -c -bin-annot vlib.ml -I ../hsrc ) + $ (cd _build && $OCAMLC -c -bin-annot main.ml -I vsrc) + + $ cat >.merlin <<'EOF' + > B _build + > B _build/vsrc + > BH _build/hsrc + > S . + > S vsrc + > SH hsrc + > EOF + + $ $MERLIN single errors -filename main.ml Date: Thu, 2 May 2024 13:09:25 +0200 Subject: [PATCH 112/130] hidden_deps: fix new load_path init function --- src/ocaml/utils/load_path.ml | 26 ++++++++++----- tests/test-dirs/config/hidden-deps.t | 47 ++-------------------------- 2 files changed, 20 insertions(+), 53 deletions(-) diff --git a/src/ocaml/utils/load_path.ml b/src/ocaml/utils/load_path.ml index 1944e32b9b..2707339bac 100644 --- a/src/ocaml/utils/load_path.ml +++ b/src/ocaml/utils/load_path.ml @@ -67,14 +67,21 @@ let hidden_dirs = s_ref [] let no_auto_include _ _ = raise Not_found let auto_include_callback = ref no_auto_include -let reset () = +let reset_visible () = assert (not Config.merlin || Local_store.is_bound ()); - STbl.clear !hidden_files; - STbl.clear !hidden_files_uncap; STbl.clear !visible_files; STbl.clear !visible_files_uncap; - hidden_dirs := []; - visible_dirs := []; + visible_dirs := [] + +let reset_hidden () = + assert (not Config.merlin || Local_store.is_bound ()); + STbl.clear !hidden_files; + STbl.clear !hidden_files_uncap; + hidden_dirs := [] + +let reset ?(only_hidden = false) ?(only_visible = false) () = + if not only_visible then reset_hidden (); + if not only_hidden then reset_visible (); auto_include_callback := no_auto_include let get_visible () = List.rev !visible_dirs @@ -138,7 +145,7 @@ let init ~auto_include ~visible ~hidden = match loop_unchanged ~hidden:false [] visible (List.rev !visible_dirs) with | None -> () | Some new_dirs -> - reset (); + reset ~only_visible:true (); visible_dirs := new_dirs; List.iter prepend_add new_dirs; auto_include_callback := auto_include @@ -146,7 +153,7 @@ let init ~auto_include ~visible ~hidden = match loop_unchanged ~hidden:true [] hidden (List.rev !hidden_dirs) with | None -> () | Some new_dirs -> - reset (); + reset ~only_hidden:true (); hidden_dirs := new_dirs; List.iter prepend_add new_dirs; auto_include_callback := auto_include @@ -257,4 +264,7 @@ let find_normalized_with_visibility fn = let fn_uncap = Misc.normalized_unit_filename fn in (!auto_include_callback Dir.find_normalized fn_uncap, Visible) - let find_normalized fn = fst (find_normalized_with_visibility fn) +let find_normalized fn = fst (find_normalized_with_visibility fn) + +(* Merlin: expose standard reset function *) +let reset () = reset () diff --git a/tests/test-dirs/config/hidden-deps.t b/tests/test-dirs/config/hidden-deps.t index 2d53678b4b..835e97968c 100644 --- a/tests/test-dirs/config/hidden-deps.t +++ b/tests/test-dirs/config/hidden-deps.t @@ -37,56 +37,13 @@ $ $MERLIN single errors -filename main.ml Date: Thu, 2 May 2024 13:10:12 +0200 Subject: [PATCH 113/130] hidden_deps: add hidden paths to source and cmt paths --- src/analysis/locate.ml | 5 ++++- src/kernel/mconfig.ml | 4 +++- tests/test-dirs/config/hidden-deps.t | 8 +++++++- 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index ac5cfabf63..fdf7e220c3 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -219,6 +219,8 @@ module Utils = struct Note: We do not refine the load path for module path as we used too. *) let find_all_in_path_uncap ?src_suffix_pair ~with_fallback path file = let name = File.with_ext ?src_suffix_pair file in + log ~title:"find_all_in_path_uncap" "Looking for file %S in path:\n%a" name + Logger.fmt (fun fmt -> Format.pp_print_list Format.pp_print_string fmt path); let uname = String.uncapitalize name in let fallback, ufallback = let alt = File.alternate file in @@ -278,7 +280,7 @@ module Utils = struct find_file_with_path ~config ?with_fallback file @@ match file with | ML _ | MLI _ | MLL _ -> Mconfig.source_path config - | CMT _ | CMTI _ -> Mconfig.build_path config + | CMT _ | CMTI _ -> Mconfig.cmt_path config end let move_to filename cmt_infos = @@ -372,6 +374,7 @@ let find_source ~config loc = | None -> fname | Some s -> s in + log ~title:"find_source" "initial path: %S" initial_path; let dir = Filename.dirname initial_path in let dir = match config.Mconfig.query.directory with diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml index 4e4f565321..0ec794d370 100644 --- a/src/kernel/mconfig.ml +++ b/src/kernel/mconfig.ml @@ -748,7 +748,8 @@ let source_path config = List.concat [[config.query.directory]; stdlib; - config.merlin.source_path] + config.merlin.source_path; + config.merlin.hidden_source_path] |> List.filter_dup let build_path config = ( @@ -793,6 +794,7 @@ let cmt_path config = ( let dirs = config.merlin.cmt_path @ config.merlin.build_path @ + config.merlin.hidden_build_path @ dirs in let stdlib = stdlib config in diff --git a/tests/test-dirs/config/hidden-deps.t b/tests/test-dirs/config/hidden-deps.t index 835e97968c..57cd4ffba5 100644 --- a/tests/test-dirs/config/hidden-deps.t +++ b/tests/test-dirs/config/hidden-deps.t @@ -44,6 +44,12 @@ $ $MERLIN single locate -look-for ml -position 1:23 -filename main.ml Date: Thu, 2 May 2024 13:11:49 +0200 Subject: [PATCH 114/130] hidden_deps: show that the dep is hidden in the test --- tests/test-dirs/config/hidden-deps.t | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/tests/test-dirs/config/hidden-deps.t b/tests/test-dirs/config/hidden-deps.t index 57cd4ffba5..ff857768c5 100644 --- a/tests/test-dirs/config/hidden-deps.t +++ b/tests/test-dirs/config/hidden-deps.t @@ -53,3 +53,24 @@ }, "notifications": [] } + +Show that hidden deps are actually hidden: + $ cat >main.ml <<'EOF' + > let _ = print_int Hlib.x + > EOF + + $ $MERLIN single errors -filename main.ml Date: Thu, 2 May 2024 18:26:55 +0200 Subject: [PATCH 115/130] syntax_doc: adapt to new function repr --- src/analysis/syntax_doc.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/analysis/syntax_doc.ml b/src/analysis/syntax_doc.ml index 49335d12cd..9b1299973a 100644 --- a/src/analysis/syntax_doc.ml +++ b/src/analysis/syntax_doc.ml @@ -190,13 +190,12 @@ let get_syntax_doc cursor_loc node : syntax_info = } | (_, Expression _) :: (_, Expression _) - :: (_, Case _) :: (_, Expression _) :: ( _, Value_binding { vb_expr = - { exp_extra = [ (Texp_newtype' (_, loc), _, _) ]; exp_loc; _ }; + { exp_extra = [ (Texp_newtype' (_, loc, _), _, _) ]; exp_loc; _ }; _; } ) :: _ -> ( From e8c91f897cf441efa4a4e4874af1a650316f8786 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 2 May 2024 18:44:11 +0200 Subject: [PATCH 116/130] fix pprintast exports after rebase --- src/ocaml/parsing/pprintast.mli | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/ocaml/parsing/pprintast.mli b/src/ocaml/parsing/pprintast.mli index 142f9b4cf6..bf73501394 100644 --- a/src/ocaml/parsing/pprintast.mli +++ b/src/ocaml/parsing/pprintast.mli @@ -62,7 +62,5 @@ val tyvar: Format.formatter -> string -> unit (* merlin *) val case_list : Format.formatter -> Parsetree.case list -> unit -val protect_ident : Format.formatter -> string -> unit -val needs_parens : string -> bool val ident_of_name : Format.formatter -> string -> unit val needs_parens : string -> bool From ee41c4d8e9f6b77810c83faa25696e99c961a2aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Thu, 2 May 2024 18:44:20 +0200 Subject: [PATCH 117/130] promote slight test improvement --- tests/test-dirs/type-enclosing/need-parens.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/test-dirs/type-enclosing/need-parens.t b/tests/test-dirs/type-enclosing/need-parens.t index 9e7d310097..54f2d40691 100644 --- a/tests/test-dirs/type-enclosing/need-parens.t +++ b/tests/test-dirs/type-enclosing/need-parens.t @@ -37,7 +37,7 @@ Locate on `M.(| * )` should work: "file": "test.ml", "pos": { "line": 1, - "col": 0 + "col": 7 } } From 5e9eab295533790e94c378610106f37a06ec9ffe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 May 2024 11:08:37 +0200 Subject: [PATCH 118/130] Pull latest changes from upstream dfe59502ad2e115882296416afc4cfd814821572 --- upstream/ocaml_502/base-rev.txt | 2 +- upstream/ocaml_502/parsing/pprintast.ml | 18 +++++++++++------- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/upstream/ocaml_502/base-rev.txt b/upstream/ocaml_502/base-rev.txt index 1f82cfe9c7..2d0acb6b35 100644 --- a/upstream/ocaml_502/base-rev.txt +++ b/upstream/ocaml_502/base-rev.txt @@ -1 +1 @@ -d38925dd59a2e620fad19ea8b14e90e4a4c1fb24 +dfe59502ad2e115882296416afc4cfd814821572 diff --git a/upstream/ocaml_502/parsing/pprintast.ml b/upstream/ocaml_502/parsing/pprintast.ml index d7fea80a7c..ac20c3155e 100644 --- a/upstream/ocaml_502/parsing/pprintast.ml +++ b/upstream/ocaml_502/parsing/pprintast.ml @@ -108,11 +108,12 @@ let ident_of_name ppf txt = let ident_of_name_loc ppf s = ident_of_name ppf s.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 + if not (needs_parens txt) then + fprintf ppf "%a.%a" print_longident longprefix ident_of_name txt + else if needs_spaces txt then + fprintf ppf "%a.(@;%s@;)" print_longident longprefix txt + else + fprintf ppf "%a.(%s)" print_longident longprefix txt type space_formatter = (unit, Format.formatter, unit) format @@ -405,8 +406,11 @@ and core_type1 ctxt f x = |_ -> pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_open(li, ct) -> + pp f "@[%a.(%a)@]" longident_loc li (core_type ctxt) ct | Ptyp_extension e -> extension ctxt f e - | _ -> paren true (core_type ctxt) f x + | (Ptyp_arrow _ | Ptyp_alias _ | Ptyp_poly _) -> + paren true (core_type ctxt) f x (********************pattern********************) (* be cautious when use [pattern], [pattern1] is preferred *) @@ -625,7 +629,7 @@ and sugar_expr ctxt f e = and function_param ctxt f param = match param.pparam_desc with | Pparam_val (a, b, c) -> label_exp ctxt f (a, b, c) - | Pparam_newtype ty -> pp f "(type %s)@;" ty.txt + | Pparam_newtype ty -> pp f "(type %a)@;" ident_of_name ty.txt and function_body ctxt f function_body = match function_body with From 477132dd97a2e13b8af550f1d03df775133d9769 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 May 2024 11:08:52 +0200 Subject: [PATCH 119/130] Apply patches to internal compiler --- src/ocaml/parsing/pprintast.ml | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml index f8c866d1de..9c6406acd7 100644 --- a/src/ocaml/parsing/pprintast.ml +++ b/src/ocaml/parsing/pprintast.ml @@ -108,11 +108,12 @@ let ident_of_name ppf txt = let ident_of_name_loc ppf s = ident_of_name ppf s.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 + if not (needs_parens txt) then + fprintf ppf "%a.%a" print_longident longprefix ident_of_name txt + else if needs_spaces txt then + fprintf ppf "%a.(@;%s@;)" print_longident longprefix txt + else + fprintf ppf "%a.(%s)" print_longident longprefix txt type space_formatter = (unit, Format.formatter, unit) format @@ -405,8 +406,11 @@ and core_type1 ctxt f x = |_ -> pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_open(li, ct) -> + pp f "@[%a.(%a)@]" longident_loc li (core_type ctxt) ct | Ptyp_extension e -> extension ctxt f e - | _ -> paren true (core_type ctxt) f x + | (Ptyp_arrow _ | Ptyp_alias _ | Ptyp_poly _) -> + paren true (core_type ctxt) f x (********************pattern********************) (* be cautious when use [pattern], [pattern1] is preferred *) @@ -625,7 +629,7 @@ and sugar_expr ctxt f e = and function_param ctxt f param = match param.pparam_desc with | Pparam_val (a, b, c) -> label_exp ctxt f (a, b, c) - | Pparam_newtype ty -> pp f "(type %s)@;" ty.txt + | Pparam_newtype ty -> pp f "(type %a)@;" ident_of_name ty.txt and function_body ctxt f function_body = match function_body with From 48abbf4c72fe4ea6ca0af1c887438e47a6be5d8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 May 2024 11:09:45 +0200 Subject: [PATCH 120/130] Add changelog entry for #1757 --- CHANGES.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGES.md b/CHANGES.md index 6f6da4ce1e..2e5045ce0b 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,7 @@ merlin NEXT_VERSION ================== + merlin binary + - Support for OCaml 5.2 (#1757) - destruct: Removal of residual patterns (#1737, fixes #1560) - Do not erase fields' names when destructing punned record fields (#1734, fixes #1661) From 1d3e9348913d09be87d34caf9c97133b3d8b834d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 May 2024 11:35:51 +0200 Subject: [PATCH 121/130] Re-enable ppx tests --- tests/test-dirs/dune | 4 ---- 1 file changed, 4 deletions(-) diff --git a/tests/test-dirs/dune b/tests/test-dirs/dune index 41016b4f67..6e9db30beb 100755 --- a/tests/test-dirs/dune +++ b/tests/test-dirs/dune @@ -11,7 +11,3 @@ (<> %{ocaml_version} 4.12.0+multicore) (<> %{ocaml_version} 4.12.0+domains)))) -; FIXME: re-enable once ppxlib for 5.1 is released -(cram - (applies_to with-ppx) - (enabled_if false)) From 6f853420e6bfc8765daa380257887dca2d022d5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 May 2024 11:50:40 +0200 Subject: [PATCH 122/130] tests: remove staled fixme --- tests/test-dirs/occurrences/issue1398.t/run.t | 4 ---- tests/test-dirs/short-paths.t/run.t | 2 -- 2 files changed, 6 deletions(-) diff --git a/tests/test-dirs/occurrences/issue1398.t/run.t b/tests/test-dirs/occurrences/issue1398.t/run.t index b49549322d..995b5fac6e 100644 --- a/tests/test-dirs/occurrences/issue1398.t/run.t +++ b/tests/test-dirs/occurrences/issue1398.t/run.t @@ -77,8 +77,6 @@ Test finding occurrences of and-based binding operator, from reified syntax: "notifications": [] } -FIXME -- some locs are inexact - $ $MERLIN single occurrences -identifier-at 4:0 ./issue1398.ml < ./issue1398.ml { "class": "return", @@ -117,8 +115,6 @@ FIXME -- some locs are inexact "notifications": [] } -FIXME -- some locs are inexact - $ $MERLIN single occurrences -identifier-at 4:12 ./issue1398.ml < ./issue1398.ml { "class": "return", diff --git a/tests/test-dirs/short-paths.t/run.t b/tests/test-dirs/short-paths.t/run.t index c721fed1d5..7082820c92 100644 --- a/tests/test-dirs/short-paths.t/run.t +++ b/tests/test-dirs/short-paths.t/run.t @@ -1,7 +1,5 @@ $ $OCAMLC -c dep.mli -FIXME: the signature mismatch appear to be a bit less precise after moving to -ocaml 5.1. Is that expected ? $ $MERLIN single errors -filename test.ml < test.ml { "class": "return", From aafec74620cc73660c1a9869c7af12409f84671d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Fri, 3 May 2024 16:39:35 +0200 Subject: [PATCH 123/130] fix regression with parser error labelling --- src/ocaml/parsing/pprintast.ml | 18 +++++++++-------- tests/test-dirs/errors/issue1222.t | 32 +----------------------------- tests/test-dirs/no-escape.t/run.t | 3 +-- 3 files changed, 12 insertions(+), 41 deletions(-) diff --git a/src/ocaml/parsing/pprintast.ml b/src/ocaml/parsing/pprintast.ml index 9c6406acd7..ef87dcb4af 100644 --- a/src/ocaml/parsing/pprintast.ml +++ b/src/ocaml/parsing/pprintast.ml @@ -1764,10 +1764,12 @@ let case_list = case_list reset_ctxt module Style = Misc.Style (* merlin: moved from parse.ml *) 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 @@ -1776,27 +1778,27 @@ let prepare_error err = "Syntax error: %a expected" Style.inline_code closing | Expecting (loc, nonterm) -> - Location.errorf ~loc "Syntax error: %a expected." + Location.errorf ~source ~loc "Syntax error: %a expected." Style.inline_code nonterm | Not_expecting (loc, nonterm) -> - Location.errorf ~loc "Syntax error: %a not expected." + Location.errorf ~source ~loc "Syntax error: %a not expected." Style.inline_code nonterm | Applicative_path loc -> - Location.errorf ~loc + Location.errorf ~source ~loc "Syntax error: applicative paths of the form %a \ are not supported when the option %a is set." Style.inline_code "F(X).t" Style.inline_code "-no-app-func" | Variable_in_scope (loc, var) -> - Location.errorf ~loc + Location.errorf ~source ~loc "In this scoped type, variable %a \ is reserved for the local type %a." (Style.as_inline_code tyvar) var Style.inline_code var | Other loc -> - Location.errorf ~loc "Syntax error" + Location.errorf ~source ~loc "Syntax error" | Ill_formed_ast (loc, s) -> - Location.errorf ~loc + Location.errorf ~source ~loc "broken invariant in parsetree: %s" s | Invalid_package_type (loc, ipt) -> let invalid ppf ipt = match ipt with @@ -1814,9 +1816,9 @@ let prepare_error err = "only module type identifier and %a constraints are supported" Style.inline_code "with type" in - Location.errorf ~loc "invalid package type: %a" invalid ipt + Location.errorf ~source ~loc "invalid package type: %a" invalid ipt | Removed_string_set loc -> - Location.errorf ~loc + Location.errorf ~source ~loc "Syntax error: strings are immutable, there is no assignment \ syntax for them.\n\ @{Hint@}: Mutable sequences of bytes are available in \ diff --git a/tests/test-dirs/errors/issue1222.t b/tests/test-dirs/errors/issue1222.t index 0a9ad6ab2d..277ced577d 100644 --- a/tests/test-dirs/errors/issue1222.t +++ b/tests/test-dirs/errors/issue1222.t @@ -1,5 +1,3 @@ -FIXME UPGRADE 5.2: The first error is still a parser error... Following errors -should be ignored ? $ $MERLIN single errors -filename issue1222.ml < let minimal : type a. 'a t > EOF @@ -15,38 +13,10 @@ should be ignored ? "line": 1, "col": 24 }, - "type": "typer", - "sub": [], - "valid": true, - "message": "In this scoped type, variable 'a is reserved for the local type a." - }, - { - "start": { - "line": 1, - "col": 25 - }, - "end": { - "line": 1, - "col": 26 - }, - "type": "typer", - "sub": [], - "valid": true, - "message": "Unbound type constructor t" - }, - { - "start": { - "line": 2, - "col": 0 - }, - "end": { - "line": 2, - "col": 0 - }, "type": "parser", "sub": [], "valid": true, - "message": "Syntax error, expecting `='" + "message": "In this scoped type, variable 'a is reserved for the local type a." } ], "notifications": [] diff --git a/tests/test-dirs/no-escape.t/run.t b/tests/test-dirs/no-escape.t/run.t index 6b1f49a020..a974233a46 100644 --- a/tests/test-dirs/no-escape.t/run.t +++ b/tests/test-dirs/no-escape.t/run.t @@ -212,7 +212,6 @@ unused case after } Syntax errors also shouldn't escape: -FIXME UPGRADE 5.2: this is still a parser error $ echo "let f (_ : (module S with type 'a t = int)) = ()" | > $MERLIN single errors -filename "invalid_package_type.ml" { @@ -241,7 +240,7 @@ FIXME UPGRADE 5.2: this is still a parser error "line": 1, "col": 41 }, - "type": "typer", + "type": "parser", "sub": [], "valid": true, "message": "invalid package type: parametrized types are not supported" From cde4ea9a63c9d21394c6d12cdee4d355a301275e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 6 May 2024 14:44:43 +0200 Subject: [PATCH 124/130] hidden path: also use for ppxes and Path_list Authored-by: Liam Stevenson --- src/frontend/query_commands.ml | 4 ++-- src/kernel/mppx.ml | 18 +++++++++++++----- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 8913d1b87d..dec83ce803 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -798,11 +798,11 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | Path_list `Build -> let config = Mpipeline.final_config pipeline in - Mconfig.(config.merlin.build_path) + Mconfig.(config.merlin.build_path @ config.merlin.hidden_build_path) | Path_list `Source -> let config = Mpipeline.final_config pipeline in - Mconfig.(config.merlin.source_path) + Mconfig.(config.merlin.source_path @ config.merlin.hidden_source_path) | Occurrences (`Ident_at pos, _) -> let config = Mpipeline.final_config pipeline in diff --git a/src/kernel/mppx.ml b/src/kernel/mppx.ml index 4e1fea6002..43bb0f0d1c 100644 --- a/src/kernel/mppx.ml +++ b/src/kernel/mppx.ml @@ -2,10 +2,15 @@ open Mconfig let {Logger. log} = Logger.for_section "Mppx" -let with_include_dir path f = - let saved = !Clflags.include_dirs in - let restore () = Clflags.include_dirs := saved in - Clflags.include_dirs := path; +let with_include_dir ~visible_path ~hidden_path f = + let saved_visible = !Clflags.include_dirs in + let saved_hidden = !Clflags.hidden_include_dirs in + let restore () = + Clflags.include_dirs := saved_visible; + Clflags.hidden_include_dirs := saved_hidden + in + Clflags.include_dirs := visible_path; + Clflags.hidden_include_dirs := hidden_path; let result = begin try @@ -22,7 +27,10 @@ let with_include_dir path f = let rewrite parsetree cfg = let ppx = cfg.ocaml.ppx in (* add include path attribute to the parsetree *) - with_include_dir (Mconfig.build_path cfg) @@ fun () -> + with_include_dir + ~visible_path:(Mconfig.build_path cfg) + ~hidden_path:(Mconfig.hidden_build_path cfg) + @@ fun () -> match Pparse.apply_rewriters ~restore:false ~ppx ~tool_name:"merlin" parsetree with From b5fe8d74b09e6c0aee15b2185087905fefa403e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 6 May 2024 14:45:10 +0200 Subject: [PATCH 125/130] tests: more hidden path tests Authored-by: Liam Stevenson --- .../config/dot-merlin-reader/load-config.t | 63 +++++ tests/test-dirs/hidden-deps/dash-h.t | 224 ++++++++++++++++++ .../hidden-deps/hd-directives.t/a/a.ml | 1 + .../hidden-deps/hd-directives.t/a/a.mli | 1 + .../hidden-deps/hd-directives.t/b/b.ml | 2 + .../hidden-deps/hd-directives.t/b/b.mli | 2 + .../hidden-deps/hd-directives.t/c/correct.ml | 3 + .../hidden-deps/hd-directives.t/c/error.ml | 3 + .../hidden-deps/hd-directives.t/run.t | 136 +++++++++++ 9 files changed, 435 insertions(+) create mode 100644 tests/test-dirs/config/dot-merlin-reader/load-config.t create mode 100644 tests/test-dirs/hidden-deps/dash-h.t create mode 100644 tests/test-dirs/hidden-deps/hd-directives.t/a/a.ml create mode 100644 tests/test-dirs/hidden-deps/hd-directives.t/a/a.mli create mode 100644 tests/test-dirs/hidden-deps/hd-directives.t/b/b.ml create mode 100644 tests/test-dirs/hidden-deps/hd-directives.t/b/b.mli create mode 100644 tests/test-dirs/hidden-deps/hd-directives.t/c/correct.ml create mode 100644 tests/test-dirs/hidden-deps/hd-directives.t/c/error.ml create mode 100644 tests/test-dirs/hidden-deps/hd-directives.t/run.t diff --git a/tests/test-dirs/config/dot-merlin-reader/load-config.t b/tests/test-dirs/config/dot-merlin-reader/load-config.t new file mode 100644 index 0000000000..3aeea7a183 --- /dev/null +++ b/tests/test-dirs/config/dot-merlin-reader/load-config.t @@ -0,0 +1,63 @@ +This test comes from: https://github.com/janestreet/merlin-jst/pull/59 + + $ cat > .merlin < B build/dir + > S source/dir + > BH build-hidden/dir + > SH source-hidden/dir + > EOF + + $ FILE=$(pwd)/test.ml; dot-merlin-reader < (4:File${#FILE}:$FILE) + > EOF + ((?:B?:$TESTCASE_ROOT/build/dir)(?:S?:$TESTCASE_ROOT/source/dir)(?:BH?:$TESTCASE_ROOT/build-hidden/dir)(?:SH?:$TESTCASE_ROOT/source-hidden/dir)) + + $ echo | $MERLIN single dump-configuration -filename test.ml 2> /dev/null | jq '.value.merlin' + { + "build_path": [ + "$TESTCASE_ROOT/build/dir" + ], + "source_path": [ + "$TESTCASE_ROOT/source/dir" + ], + "hidden_build_path": [ + "$TESTCASE_ROOT/build-hidden/dir" + ], + "hidden_source_path": [ + "$TESTCASE_ROOT/source-hidden/dir" + ], + "cmi_path": [], + "cmt_path": [], + "flags_applied": [], + "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" + } + ], + "cache_lifespan": "5" + } + + $ rm .merlin diff --git a/tests/test-dirs/hidden-deps/dash-h.t b/tests/test-dirs/hidden-deps/dash-h.t new file mode 100644 index 0000000000..8f2cdc76c6 --- /dev/null +++ b/tests/test-dirs/hidden-deps/dash-h.t @@ -0,0 +1,224 @@ +This test comes from: https://github.com/janestreet/merlin-jst/pull/59 + +Test "-H". We want to check both that merlin can check things that require +indirect use of hidden dependencies, and that it doesn't check things which +would require direct use of hidden dependencies. + +Create a simple dependency chain Liba -> Libb -> Libc. + + $ mkdir liba libb libc + + $ cat < liba/liba.ml + > type t = int + > let x = 42 + > type s = Baz + > EOF + + $ cat < libb/libb.ml + > type t = Liba.t + > let x : Liba.t = Liba.x + > let f : Liba.t -> Liba.t = fun x -> x + > EOF + + $ cat < libc/libc.ml + > type t = Libb.t [@@immediate] + > let x : t = Libb.x + > let y = x + 42 + > let z = Liba.Baz + > EOF + + $ cd liba + $ $OCAMLC -c liba.ml + $ cd ../libb + $ $OCAMLC -I ../liba -c libb.ml + $ cd ../libc + +When compiling libc.ml with liba made available via -H, we expect merlin to be +able to see the first three lines typecheck and the last does not. + +Check the type of `x`, should work. + + $ $MERLIN single type-enclosing -position 3:9 -I ../libb -H ../liba \ + > -filename "libc.ml" < "libc.ml" + { + "class": "return", + "value": [ + { + "start": { + "line": 3, + "col": 8 + }, + "end": { + "line": 3, + "col": 9 + }, + "type": "t", + "tail": "no" + }, + { + "start": { + "line": 3, + "col": 8 + }, + "end": { + "line": 3, + "col": 14 + }, + "type": "int", + "tail": "no" + } + ], + "notifications": [] + } + +Check the type of Liba.Baz three ways: With -I liba we should get the type. -H +liba and leaving the library off entirely should behave the same for a direct +refence like this (and merlin's behavior in this case is to just guess 'a for +the type) + + $ $MERLIN single type-enclosing -position 4:8 -I ../libb -I ../liba \ + > -filename "libc.ml" < "libc.ml" + { + "class": "return", + "value": [ + { + "start": { + "line": 4, + "col": 8 + }, + "end": { + "line": 4, + "col": 12 + }, + "type": "sig type t = int val x : int type s = Baz end", + "tail": "no" + }, + { + "start": { + "line": 4, + "col": 8 + }, + "end": { + "line": 4, + "col": 16 + }, + "type": "Liba.s", + "tail": "no" + } + ], + "notifications": [] + } + + $ $MERLIN single type-enclosing -position 4:8 -I ../libb -H ../liba \ + > -filename "libc.ml" < "libc.ml" + { + "class": "return", + "value": [ + { + "start": { + "line": 4, + "col": 8 + }, + "end": { + "line": 4, + "col": 16 + }, + "type": "'a", + "tail": "no" + } + ], + "notifications": [] + } + + $ $MERLIN single type-enclosing -position 4:8 -I ../libb \ + > -filename "libc.ml" < "libc.ml" + { + "class": "return", + "value": [ + { + "start": { + "line": 4, + "col": 8 + }, + "end": { + "line": 4, + "col": 16 + }, + "type": "'a", + "tail": "no" + } + ], + "notifications": [] + } + +Look at the errors: With -I liba, none. With -H liba, an error on the direct +reference. With no liba, we also can't see Libb.t is int. + + $ $MERLIN single errors -I ../libb -I ../liba \ + > -filename "libc.ml" < "libc.ml" + { + "class": "return", + "value": [], + "notifications": [] + } + + $ $MERLIN single errors -I ../libb -H ../liba \ + > -filename "libc.ml" < "libc.ml" + { + "class": "return", + "value": [ + { + "start": { + "line": 4, + "col": 8 + }, + "end": { + "line": 4, + "col": 16 + }, + "type": "typer", + "sub": [], + "valid": true, + "message": "Unbound module Liba" + } + ], + "notifications": [] + } + + $ $MERLIN single errors -I ../libb \ + > -filename "libc.ml" < "libc.ml" + { + "class": "return", + "value": [ + { + "start": { + "line": 3, + "col": 8 + }, + "end": { + "line": 3, + "col": 9 + }, + "type": "typer", + "sub": [], + "valid": true, + "message": "This expression has type t = Liba.t but an expression was expected of type + int" + }, + { + "start": { + "line": 4, + "col": 8 + }, + "end": { + "line": 4, + "col": 16 + }, + "type": "typer", + "sub": [], + "valid": true, + "message": "Unbound module Liba" + } + ], + "notifications": [] + } diff --git a/tests/test-dirs/hidden-deps/hd-directives.t/a/a.ml b/tests/test-dirs/hidden-deps/hd-directives.t/a/a.ml new file mode 100644 index 0000000000..e46c633fc1 --- /dev/null +++ b/tests/test-dirs/hidden-deps/hd-directives.t/a/a.ml @@ -0,0 +1 @@ +let a = 10 diff --git a/tests/test-dirs/hidden-deps/hd-directives.t/a/a.mli b/tests/test-dirs/hidden-deps/hd-directives.t/a/a.mli new file mode 100644 index 0000000000..3f79c81490 --- /dev/null +++ b/tests/test-dirs/hidden-deps/hd-directives.t/a/a.mli @@ -0,0 +1 @@ +val a : int diff --git a/tests/test-dirs/hidden-deps/hd-directives.t/b/b.ml b/tests/test-dirs/hidden-deps/hd-directives.t/b/b.ml new file mode 100644 index 0000000000..7a9a2287fb --- /dev/null +++ b/tests/test-dirs/hidden-deps/hd-directives.t/b/b.ml @@ -0,0 +1,2 @@ +include A +let b = 20 diff --git a/tests/test-dirs/hidden-deps/hd-directives.t/b/b.mli b/tests/test-dirs/hidden-deps/hd-directives.t/b/b.mli new file mode 100644 index 0000000000..63567b698d --- /dev/null +++ b/tests/test-dirs/hidden-deps/hd-directives.t/b/b.mli @@ -0,0 +1,2 @@ +val a : int +val b : int diff --git a/tests/test-dirs/hidden-deps/hd-directives.t/c/correct.ml b/tests/test-dirs/hidden-deps/hd-directives.t/c/correct.ml new file mode 100644 index 0000000000..00eec83eaf --- /dev/null +++ b/tests/test-dirs/hidden-deps/hd-directives.t/c/correct.ml @@ -0,0 +1,3 @@ +let c = B.a + B.b + +let () = print_endline (Int.to_string c) diff --git a/tests/test-dirs/hidden-deps/hd-directives.t/c/error.ml b/tests/test-dirs/hidden-deps/hd-directives.t/c/error.ml new file mode 100644 index 0000000000..1c2f4da76d --- /dev/null +++ b/tests/test-dirs/hidden-deps/hd-directives.t/c/error.ml @@ -0,0 +1,3 @@ +let c = A.a + B.b + +let () = print_endline (Int.to_string c) diff --git a/tests/test-dirs/hidden-deps/hd-directives.t/run.t b/tests/test-dirs/hidden-deps/hd-directives.t/run.t new file mode 100644 index 0000000000..b16eea15bd --- /dev/null +++ b/tests/test-dirs/hidden-deps/hd-directives.t/run.t @@ -0,0 +1,136 @@ +This test comes from: https://github.com/janestreet/merlin-jst/pull/59 + +Test that Merlin correctly handles BH and SH directives. +These are for hidden dependencies and correspond to the +-H compiler flag. + +Start by building some dependencies. C depends on B +which depends on A. A will be a hidden dependency of C, +while B will be direct. + +B exposes a variable from A, allowing C to directly use +it via B. + + $ mkdir -p _build/a + $ cp a/*.ml* _build/a + $ cd _build/a + $ $OCAMLC -c -bin-annot a.mli -o a.cmi + $ $OCAMLC -c -bin-annot a.ml -o a.cmo + $ cd ../.. + + $ mkdir -p _build/b + $ cp b/*.ml* _build/b + $ cd _build/b + $ $OCAMLC -c -bin-annot b.mli -o b.cmi + $ $OCAMLC -c -bin-annot -I ../a b.ml -o b.cmo + $ cd ../.. + +Create a .merlin file + + $ cat >c/.merlin < BH ../_build/a + > SH ../a + > B ../_build/b + > S ../b + > EOF + +Merlin does not report errors when there are none + + $ $MERLIN single errors -filename c/correct.ml < c/correct.ml | jq ".value" + [] + +Merlin can locate a value in an interface from a direct dependency + + $ $MERLIN single locate -position 1:17 -look-for interface -filename c/correct.ml < c/correct.ml | jq ".value" + { + "file": "$TESTCASE_ROOT/b/b.mli", + "pos": { + "line": 2, + "col": 4 + } + } + +Merlin can locate a value in an interface from a hidden dependency + + $ $MERLIN single locate -position 1:11 -look-for interface -filename c/correct.ml < c/correct.ml | jq ".value" + { + "file": "$TESTCASE_ROOT/b/b.mli", + "pos": { + "line": 1, + "col": 4 + } + } + +Merlin can locate a value in an implementation from a direct dependency + + $ $MERLIN single locate -position 1:17 -look-for implementation -filename c/correct.ml < c/correct.ml | jq ".value" + { + "file": "$TESTCASE_ROOT/b/b.ml", + "pos": { + "line": 2, + "col": 4 + } + } + +Merlin can locate a value in an implementation from a hidden dependency + + $ $MERLIN single locate -position 1:11 -look-for implementation -filename c/correct.ml < c/correct.ml | jq ".value" + { + "file": "$TESTCASE_ROOT/a/a.ml", + "pos": { + "line": 1, + "col": 4 + } + } + +Merlin reports an error when a hidden dependency is directly used + + $ $MERLIN single errors -filename c/error.ml < c/error.ml | jq ".value" + [ + { + "start": { + "line": 1, + "col": 8 + }, + "end": { + "line": 1, + "col": 11 + }, + "type": "typer", + "sub": [], + "valid": true, + "message": "Unbound module A" + } + ] + +Merlin can locate a value in an interface from a direct dependency when there is an error + + $ $MERLIN single locate -position 1:17 -look-for interface -filename c/error.ml < c/error.ml | jq ".value" + { + "file": "$TESTCASE_ROOT/b/b.mli", + "pos": { + "line": 2, + "col": 4 + } + } + +Merlin fails locate a value in an interface from a hidden dependency that is illegally used + + $ $MERLIN single locate -position 1:11 -look-for interface -filename c/error.ml < c/error.ml | jq ".value" + "Not in environment 'A.a'" + +Merlin can locate a value in an implementation from a direct dependency when there is an error + + $ $MERLIN single locate -position 1:17 -look-for implementation -filename c/error.ml < c/error.ml | jq ".value" + { + "file": "$TESTCASE_ROOT/b/b.ml", + "pos": { + "line": 2, + "col": 4 + } + } + +Merlin fails locate a value in an implementation from a hidden dependency that is illegally used + + $ $MERLIN single locate -position 1:11 -look-for implementation -filename c/error.ml < c/error.ml | jq ".value" + "Not in environment 'A.a'" From 082a1ac038cfca56cece60b4321d11480d7ecfc6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 13 May 2024 16:17:13 +0200 Subject: [PATCH 126/130] refactor: extract identifier parsing from query commands --- src/analysis/misc_utils.ml | 11 +++++++++++ src/analysis/misc_utils.mli | 7 +++++++ src/frontend/query_commands.ml | 15 +++------------ 3 files changed, 21 insertions(+), 12 deletions(-) diff --git a/src/analysis/misc_utils.ml b/src/analysis/misc_utils.ml index 3e26dd7fd6..12ce609f68 100644 --- a/src/analysis/misc_utils.ml +++ b/src/analysis/misc_utils.ml @@ -58,6 +58,17 @@ let parenthesize_name name = "(" ^ name ^ ")" ) +let parse_identifier (config, source) pos = + let path = Mreader.reconstruct_identifier config source 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))); + path + module Compat = struct open Typedtree let pat_var_id_and_loc = function diff --git a/src/analysis/misc_utils.mli b/src/analysis/misc_utils.mli index 32b15d5683..9962d80db2 100644 --- a/src/analysis/misc_utils.mli +++ b/src/analysis/misc_utils.mli @@ -1,3 +1,5 @@ +open Misc + module Path : 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 @@ -23,6 +25,11 @@ end (* Add parenthesis to qualified operators *) val parenthesize_name : string -> string +(** [parse_identifier] attempts to re-parse a longident so that we get + the location of each of its components. *) +val parse_identifier : + (Mconfig.t * Msource.t) -> Lexing.position -> modname Location.loc list + module Compat : sig val pat_var_id_and_loc : Typedtree.pattern -> (Ident.t * string Location.loc) option diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index dec83ce803..b2686fbe50 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -204,18 +204,9 @@ let dump pipeline = function 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 config = Mpipeline.input_config pipeline in + let source = Mpipeline.raw_source pipeline in + let path = Misc_utils.parse_identifier (config, source) pos in let reify dot = if dot = "" || (dot.[0] >= 'a' && dot.[0] <= 'z') || From 77d00e46e319179c0a2ff30d6f5b45dca6c5aa6d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 13 May 2024 16:17:22 +0200 Subject: [PATCH 127/130] locate: fix alias traversal --- src/analysis/locate.ml | 19 +++++-------------- 1 file changed, 5 insertions(+), 14 deletions(-) diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml index fdf7e220c3..f7a9fba6f7 100644 --- a/src/analysis/locate.ml +++ b/src/analysis/locate.ml @@ -559,18 +559,6 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path = let shape = Env.shape_of_path ~namespace env path in log ~title:"shape_of_path" "initial: %a" Logger.fmt (Fun.flip Shape.print shape); - let _keep_aliases = - if config.traverse_aliases - then (fun _ -> false) - else (function - | Shape. { uid = Some (Item { comp_unit; _ }); - desc = Alias { desc = Comp_unit alias_cu; _ }; - _ } - when let by = comp_unit ^ "__" in - Merlin_utils.Std.String.is_prefixed ~by alias_cu -> - false - | _ -> true) - in let reduced = Reduce.reduce_for_uid env shape in log ~title:"shape_of_path" "reduced: %a" @@ -580,10 +568,13 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path = let rec uid_of_result ~traverse_aliases = function | Shape_reduce.Resolved uid -> Some uid, false - | Resolved_alias (Item { comp_unit; _ }, - (Resolved_alias (Compilation_unit comp_unit', _) as rest)) + | Resolved_alias ((Item { comp_unit; _ } | Compilation_unit comp_unit), + ((Resolved_alias (Compilation_unit comp_unit', _) + | Resolved (Compilation_unit comp_unit') ) as rest)) when let by = comp_unit ^ "__" in String.is_prefixed ~by comp_unit' -> (* Always traverse dune-wrapper aliases *) + log ~title:"uid_of_result" + "Traversing wrapping alias: %s__ %s" comp_unit comp_unit'; uid_of_result ~traverse_aliases rest | Resolved_alias (_alias, rest) when traverse_aliases -> uid_of_result ~traverse_aliases rest From a1547db44349812164be991e1715efe8b345c2e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 13 May 2024 16:18:04 +0200 Subject: [PATCH 128/130] test: promote --- tests/test-dirs/occurrences/lid-locs.t | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/tests/test-dirs/occurrences/lid-locs.t b/tests/test-dirs/occurrences/lid-locs.t index fa151fbf05..cc9bc650c3 100644 --- a/tests/test-dirs/occurrences/lid-locs.t +++ b/tests/test-dirs/occurrences/lid-locs.t @@ -175,18 +175,18 @@ Same for an ident that requires both parenthesis and spaces: > *) > EOF - $ $MERLIN single occurrences -identifier-at 4:10 ./test.ml < ./test.ml + $ $MERLIN single occurrences -identifier-at 4:12 ./test.ml < ./test.ml { "class": "return", "value": [ { "start": { - "line": 1, - "col": 7 + "line": 2, + "col": 6 }, "end": { - "line": 1, - "col": 8 + "line": 2, + "col": 11 } }, { @@ -196,7 +196,7 @@ Same for an ident that requires both parenthesis and spaces: }, "end": { "line": 4, - "col": 13 + "col": 15 } }, { @@ -206,7 +206,7 @@ Same for an ident that requires both parenthesis and spaces: }, "end": { "line": 5, - "col": 15 + "col": 17 } }, { @@ -216,7 +216,7 @@ Same for an ident that requires both parenthesis and spaces: }, "end": { "line": 6, - "col": 12 + "col": 14 } }, { @@ -226,7 +226,7 @@ Same for an ident that requires both parenthesis and spaces: }, "end": { "line": 8, - "col": 2 + "col": 4 } } ], From 02959ba9a307f2870e1f2fc2ac81653af3806083 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 13 May 2024 16:31:05 +0200 Subject: [PATCH 129/130] occ: improve handling of paths in current buffer --- src/analysis/occurrences.ml | 71 ++++++----- src/analysis/occurrences.mli | 1 + src/frontend/query_commands.ml | 3 +- tests/test-dirs/occurrences/mod-in-path-2.t | 78 ++++++++++++ tests/test-dirs/occurrences/mod-in-path-3.t | 114 ++++++++++++++++++ tests/test-dirs/occurrences/mod-in-path.t | 125 ++++++++++++++++++++ 6 files changed, 363 insertions(+), 29 deletions(-) create mode 100644 tests/test-dirs/occurrences/mod-in-path-2.t create mode 100644 tests/test-dirs/occurrences/mod-in-path-3.t create mode 100644 tests/test-dirs/occurrences/mod-in-path.t diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml index 9027e29120..a1236a483b 100644 --- a/src/analysis/occurrences.ml +++ b/src/analysis/occurrences.ml @@ -25,7 +25,7 @@ let decl_of_path_or_lid env namespace path lid = end | _ -> Env_lookup.by_path path namespace env -let index_buffer_ ~current_buffer_path ~local_defs () = +let index_buffer_ ~config ~source ~current_buffer_path ~local_defs () = let {Logger. log} = Logger.for_section "index" in let defs = Hashtbl.create 64 in let module Shape_reduce = @@ -66,38 +66,51 @@ let index_buffer_ ~current_buffer_path ~local_defs () = let result = Shape_reduce.reduce_for_uid env path_shape in begin match Locate.uid_of_result ~traverse_aliases:false result with | Some uid, false -> - log ~title:"index_buffer" "Found %s (%a) wiht uid %a" - (Longident.head lid.txt) + log ~title:"index_buffer" "Found %a (%a) wiht uid %a" + Logger.fmt (Fun.flip Pprintast.longident lid.txt) Logger.fmt (Fun.flip Location.print_loc lid.loc) Logger.fmt (Fun.flip Shape.Uid.print uid); - Index_format.(add defs uid (LidSet.singleton lid)) - | Some uid, true -> - log ~title:"index_buffer" "Shape is approximative, found uid: %a" - Logger.fmt (Fun.flip Shape.Uid.print uid); - index_decl () - | None, _ -> - log ~title:"index_buffer" "Reduction failed: missing uid"; - index_decl () + Index_format.(add defs uid (LidSet.singleton lid)) + | Some uid, true -> + log ~title:"index_buffer" "Shape is approximative, found uid: %a" + Logger.fmt (Fun.flip Shape.Uid.print uid); + index_decl () + | None, _ -> + log ~title:"index_buffer" "Reduction failed: missing uid"; + index_decl () end in let f ~namespace env path (lid : Longident.t Location.loc) = (* The compiler lacks sufficient location information to precisely hihglight modules in paths. This function hacks around that issue when looking for occurrences in the current buffer only. *) - let rec iter_on_path ~namespace path ({Location.txt; loc} as lid) = - let () = f ~namespace env path lid in - match path, txt with - | Pdot (path, _), Ldot (lid, s) -> - let length_with_dot = String.length s + 1 in - let lid = - { Location.txt = lid; loc = { loc with loc_end = {loc.loc_end with - pos_cnum = loc.loc_end.pos_cnum - length_with_dot}} } - in - iter_on_path ~namespace:Module path lid - | Papply _, _ -> () - | _, _ -> () + (* We rely on a custom re-parsing of the longidents that provide us with + location information and match these with the real path and longident. *) + let rec iter_on_path ~namespace (path : Path.t) lid reparsed = + log ~title:"iter_on_path" "Path %a, lid: %a" + Logger.fmt (Fun.flip Path.print path) + Logger.fmt (Fun.flip Pprintast.longident lid.Location.txt); + match path, lid.txt, reparsed with + | Pdot (path', n), (Ldot (_, s) | Lident s), _ + when n <> s && String.lowercase_ascii n = n -> + iter_on_path ~namespace path' lid reparsed + | (Pdot _ | Pident _), Lident s, [{ Location.txt = name; loc}] + when name = s -> + log ~title:"iter_on_path" "Last %a, lid: %a" + Logger.fmt (Fun.flip Path.print path) + Logger.fmt (Fun.flip Pprintast.longident lid.Location.txt); + f ~namespace env path { lid with loc = loc } + | Pdot (path', _), Ldot (lid', s), { txt = name; loc} :: tl when name = s -> + let () = f ~namespace env path { lid with loc = loc } in + iter_on_path ~namespace:Module path' { lid with txt = lid' } tl + | Papply _, _, _ -> f ~namespace env path lid + | _, _, _ -> f ~namespace env path lid + in + let reparsed_lid = + Misc_utils.parse_identifier (config, source) lid.loc.loc_end + |> List.rev in - iter_on_path ~namespace path lid + iter_on_path ~namespace path lid reparsed_lid in Ast_iterators.iter_on_usages ~f local_defs; defs @@ -106,7 +119,7 @@ let index_buffer = (* Right now, we only cache the last used index. We could do better by caching the index for every known buffer. *) let cache = ref None in - fun ~current_buffer_path ~stamp ~local_defs () -> + fun ~config ~source ~current_buffer_path ~stamp ~local_defs () -> let {Logger. log} = Logger.for_section "index" in match !cache with | Some (path, stamp', value) when @@ -117,7 +130,9 @@ let index_buffer = value | _ -> log ~title:"index_cache" "No valid cache found, reindexing."; - let result = index_buffer_ ~current_buffer_path ~local_defs () in + let result = + index_buffer_ ~config ~source ~current_buffer_path ~local_defs () + in cache := Some (current_buffer_path, stamp, result); result @@ -174,7 +189,7 @@ let comp_unit_of_uid = function | Item { comp_unit; _ } -> Some comp_unit | Internal | Predef _ -> None -let locs_of ~config ~env ~typer_result ~pos path = +let locs_of ~config ~source ~env ~typer_result ~pos path = log ~title:"occurrences" "Looking for occurences of %s (pos: %s)" path (Lexing.print_position () pos); @@ -218,7 +233,7 @@ let locs_of ~config ~env ~typer_result ~pos path = log ~title:"locs_of" "Indexing current buffer"; let buffer_index = let stamp = Mtyper.get_stamp typer_result in - index_buffer ~current_buffer_path ~stamp ~local_defs () + index_buffer ~config ~source ~current_buffer_path ~stamp ~local_defs () in let buffer_locs = Hashtbl.find_opt buffer_index def_uid in let locs = Option.value ~default:LidSet.empty buffer_locs in diff --git a/src/analysis/occurrences.mli b/src/analysis/occurrences.mli index eea7b6b3e7..871341430c 100644 --- a/src/analysis/occurrences.mli +++ b/src/analysis/occurrences.mli @@ -1,5 +1,6 @@ val locs_of : config:Mconfig.t + -> source:Msource.t -> env:Env.t -> typer_result:Mtyper.result -> pos:Lexing.position diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index b2686fbe50..e5b1518ffd 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -797,6 +797,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = | Occurrences (`Ident_at pos, _) -> let config = Mpipeline.final_config pipeline in + let source = Mpipeline.raw_source pipeline in let typer_result = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos in let env, _node = Mbrowse.leaf_node (Mtyper.node_at typer_result pos) in @@ -809,7 +810,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = path in let locs = - Occurrences.locs_of ~config ~env ~typer_result ~pos path + Occurrences.locs_of ~config ~source ~env ~typer_result ~pos path |> Result.value ~default:[] in let loc_start l = l.Location.loc_start in diff --git a/tests/test-dirs/occurrences/mod-in-path-2.t b/tests/test-dirs/occurrences/mod-in-path-2.t new file mode 100644 index 0000000000..1f120c0a26 --- /dev/null +++ b/tests/test-dirs/occurrences/mod-in-path-2.t @@ -0,0 +1,78 @@ + $ cat >test.ml <<'EOF' + > module Mod = struct + > type t = A + > end + > let () = + > match Mod.A with + > | Mod.A -> () + > EOF + + $ $MERLIN single occurrences -identifier-at 1:8 -filename test.ml jq '.value' + [ + { + "start": { + "line": 1, + "col": 7 + }, + "end": { + "line": 1, + "col": 10 + } + }, + { + "start": { + "line": 5, + "col": 8 + }, + "end": { + "line": 5, + "col": 11 + } + }, + { + "start": { + "line": 6, + "col": 4 + }, + "end": { + "line": 6, + "col": 7 + } + } + ] + + $ $MERLIN single occurrences -identifier-at 2:11 -filename test.ml jq '.value' + [ + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 12 + } + }, + { + "start": { + "line": 5, + "col": 12 + }, + "end": { + "line": 5, + "col": 13 + } + }, + { + "start": { + "line": 6, + "col": 8 + }, + "end": { + "line": 6, + "col": 9 + } + } + ] diff --git a/tests/test-dirs/occurrences/mod-in-path-3.t b/tests/test-dirs/occurrences/mod-in-path-3.t new file mode 100644 index 0000000000..6ba604a26b --- /dev/null +++ b/tests/test-dirs/occurrences/mod-in-path-3.t @@ -0,0 +1,114 @@ + $ cat >test.ml <<'EOF' + > module Mod = struct + > type t = A of { lbl : int } + > end + > let x = Mod.A { lbl = 42 } + > let _ = + > match x with + > | Mod.A r -> r.lbl + > EOF + + $ $MERLIN single occurrences -identifier-at 4:9 -filename test.ml jq '.value' + [ + { + "start": { + "line": 1, + "col": 7 + }, + "end": { + "line": 1, + "col": 10 + } + }, + { + "start": { + "line": 4, + "col": 8 + }, + "end": { + "line": 4, + "col": 11 + } + }, + { + "start": { + "line": 7, + "col": 4 + }, + "end": { + "line": 7, + "col": 7 + } + } + ] + + $ $MERLIN single occurrences -identifier-at 4:12 -filename test.ml jq '.value' + [ + { + "start": { + "line": 2, + "col": 11 + }, + "end": { + "line": 2, + "col": 12 + } + }, + { + "start": { + "line": 4, + "col": 12 + }, + "end": { + "line": 4, + "col": 13 + } + }, + { + "start": { + "line": 7, + "col": 8 + }, + "end": { + "line": 7, + "col": 9 + } + } + ] + + $ $MERLIN single occurrences -identifier-at 4:18 -filename test.ml jq '.value' + [ + { + "start": { + "line": 2, + "col": 18 + }, + "end": { + "line": 2, + "col": 21 + } + }, + { + "start": { + "line": 4, + "col": 16 + }, + "end": { + "line": 4, + "col": 19 + } + }, + { + "start": { + "line": 7, + "col": 17 + }, + "end": { + "line": 7, + "col": 20 + } + } + ] diff --git a/tests/test-dirs/occurrences/mod-in-path.t b/tests/test-dirs/occurrences/mod-in-path.t new file mode 100644 index 0000000000..eeadb58482 --- /dev/null +++ b/tests/test-dirs/occurrences/mod-in-path.t @@ -0,0 +1,125 @@ + $ cat >test.ml <<'EOF' + > module Mod = struct + > module Nod = struct + > let x = 42 + > end + > end + > let _ = Mod.Nod.x + > let _ = Mod . Nod . x + > let _ = Mod . + > Nod + > . + > x + > let _ = let open Mod in Nod.x + > EOF + + $ $MERLIN single occurrences -identifier-at 6:13 -filename test.ml jq '.value' + [ + { + "start": { + "line": 2, + "col": 9 + }, + "end": { + "line": 2, + "col": 12 + } + }, + { + "start": { + "line": 6, + "col": 12 + }, + "end": { + "line": 6, + "col": 15 + } + }, + { + "start": { + "line": 7, + "col": 14 + }, + "end": { + "line": 7, + "col": 17 + } + }, + { + "start": { + "line": 9, + "col": 0 + }, + "end": { + "line": 9, + "col": 3 + } + }, + { + "start": { + "line": 12, + "col": 24 + }, + "end": { + "line": 12, + "col": 27 + } + } + ] + + + $ $MERLIN single occurrences -identifier-at 12:18 -filename test.ml jq '.value' + [ + { + "start": { + "line": 1, + "col": 7 + }, + "end": { + "line": 1, + "col": 10 + } + }, + { + "start": { + "line": 6, + "col": 8 + }, + "end": { + "line": 6, + "col": 11 + } + }, + { + "start": { + "line": 7, + "col": 8 + }, + "end": { + "line": 7, + "col": 11 + } + }, + { + "start": { + "line": 8, + "col": 8 + }, + "end": { + "line": 8, + "col": 11 + } + }, + { + "start": { + "line": 12, + "col": 17 + }, + "end": { + "line": 12, + "col": 20 + } + } + ] From 11bc49a89ef036009e7c31d29c56ee02edb110d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Mon, 13 May 2024 16:48:30 +0200 Subject: [PATCH 130/130] Remove old occurrences code --- src/analysis/browse_tree.ml | 81 ------------------------------------ src/analysis/browse_tree.mli | 7 ---- 2 files changed, 88 deletions(-) diff --git a/src/analysis/browse_tree.ml b/src/analysis/browse_tree.ml index 2f5b78b22b..65f205b544 100644 --- a/src/analysis/browse_tree.ml +++ b/src/analysis/browse_tree.ml @@ -60,87 +60,6 @@ let dummy = { t_children = lazy [] } -let rec normalize_type_expr env type_expr = - match Types.get_desc type_expr with - | 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 = `Id 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 - | `Extension_constructor ec -> Ident.name ec.Typedtree.ext_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 - | Type_open -> - [`Uid d.cstr_uid] - | _ -> assert false - end - | `Declaration d -> - [`Id d.Typedtree.cd_id] - | `Extension_constructor ext_cons -> - let des = Env.find_ident_constructor ext_cons.Typedtree.ext_id env in - [`Uid des.cstr_uid] - in - let a = get_decls a in - let b = get_decls b in - let same a b = match a, b with - | `Id a, `Id b -> Ident.same a b - | `Uid a, `Uid b -> Shape.Uid.equal a b - | _, _ -> false - in - List.exists a ~f:(fun id -> List.exists b ~f:(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 - if Browse_raw.has_attr ~name:"merlin.hide" t.t_node then - acc - else - 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 - if Browse_raw.has_attr ~name:"merlin.hide" t.t_node then - acc - else - 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 || diff --git a/src/analysis/browse_tree.mli b/src/analysis/browse_tree.mli index 66713bba13..48c1c33d3c 100644 --- a/src/analysis/browse_tree.mli +++ b/src/analysis/browse_tree.mli @@ -45,12 +45,5 @@ 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 - | `Extension_constructor of Typedtree.extension_constructor ] - -> t -> t Location.loc list - val all_occurrences_of_prefix : Path.t -> Browse_raw.node -> (Path.t Location.loc * Longident.t) list